
 1000  *SAVE S.DATE
 1010  *--------------------------------
 1020  *
 1030  *      Program to read or set the
 1040  *      date bytes in the Global Page
 1050  *
 1060  *            by Bill Morgan
 1070  *
 1080  *--------------------------------
 1090  POINTER    .EQ $40,41
 1100  ACCUM      .EQ $42 
 1110  MONTH      .EQ $43    
 1120  DAY        .EQ $44
 1130  TEMP       .EQ $45
 1140   
 1150  WBUF       .EQ $200
 1160   
 1170  EXTRNCMD   .EQ $BE07
 1180  EXTRNADDR  .EQ $BE50,51
 1190  XLEN       .EQ $BE52
 1200  XCNUM      .EQ $BE53
 1210  PBITS      .EQ $BE54
 1220  GP.DATE    .EQ $BF90
 1230   
 1240  PRAX       .EQ $F941
 1250  CROUT      .EQ $FD8E
 1260  COUT       .EQ $FDED
 1270  *--------------------------------
 1280         .OR $803
 1290  *      .TF B.DATE
 1300  *--------------------------------
 1310  INSTALL
 1320         LDA EXTRNCMD+1    exit to old
 1330         STA EXIT+2        user command
 1340         LDA EXTRNCMD
 1350         STA EXIT+1
 1360         LDA /DATE         become new
 1370         STA EXTRNCMD+1    user command
 1380         LDA #DATE
 1390         STA EXTRNCMD
 1400         RTS
 1410  *--------------------------------
 1420  COMMAND .AS /DATE/
 1430  *--------------------------------
 1440  DATE   LDY #0
 1450         STY POINTER       point to input buffer
 1460         LDA /WBUF
 1470         STA POINTER+1
 1480  .1     LDA (POINTER),Y   scan command
 1490         AND #%01111111
 1500         CMP COMMAND,Y
 1510         BNE ERR.BRIDGE    not mine
 1520         INY
 1530         CPY #4
 1540         BCC .1
 1550  *--- ProDOS bookkeeping ---------
 1560         DEY
 1570         STY XLEN          command length - 1
 1580         INY
 1590         LDA #0
 1600         STA PBITS         don't parse parms
 1610         STA XCNUM         external command
 1620         LDA #RTS1
 1630         STA EXTRNADDR     no execution after
 1640         LDA /RTS1         command parsing
 1650         STA EXTRNADDR+1
 1660  *--- set or display date? -------
 1670         LDA (POINTER),Y
 1680         CMP #$8D          DATE only?
 1690         BEQ RETURN.DATE   yes, return old date
 1700  *--------------------------------
 1710  SET.DATE
 1720         DEY
 1730         JSR ACCUMULATE.DIGITS  get month
 1740         CMP #13
 1750         BCS ERROR         >12 no good
 1760         STA MONTH
 1770         JSR ACCUMULATE.DIGITS  get day
 1780         PHP               save status
 1790         CMP #32
 1800         BCC GO.ON         <=31 ok
 1810   
 1820         PLP
 1830  ERR.BRIDGE
 1840         BNE ERROR      ...always
 1850   
 1860  GO.ON  STA DAY
 1870         PLP               recover status
 1880         BCC .1            .CC. if "/"
 1890         LDA #85           year defaults to '85
 1900         BNE .2         ...always
 1910  .1     JSR ACCUMULATE.DIGITS  get year
 1920         CMP #100
 1930         BCS ERROR         >99 no good
 1940  .2     PHA               save year
 1950         LDA MONTH         X 0000MMMM
 1960         LSR               M 00000MMM
 1970         ROR               M M00000MM
 1980         ROR               M MM00000M
 1990         ROR               M MMM00000
 2000         STA MONTH
 2010         PLA               M 0YYYYYYY
 2020         ROL               0 YYYYYYYM
 2030         STA GP.DATE+1
 2040         LDA MONTH           MMM00000
 2050         ORA DAY             MMMDDDDD
 2060         STA GP.DATE
 2070  *--------------------------------
 2080  RETURN.DATE
 2090         JSR CROUT
 2100         LDA GP.DATE+1     X YYYYYYYM
 2110         LSR               M 0YYYYYYY
 2120         PHA
 2130         LDA GP.DATE       M MMMDDDDD
 2140         PHA
 2150         ROR               X MMMMDDDD
 2160         LSR               X 0MMMMDDD
 2170         LSR               X 00MMMMDD
 2180         LSR               X 000MMMMD
 2190         LSR               X 0000MMMM
 2200         JSR DEC.OUT       display month
 2210         LDA #"/"          /
 2220         JSR COUT
 2230         PLA               X MMMDDDDD
 2240         AND #%00011111    X 000DDDDD
 2250         JSR DEC.OUT       display day
 2260         LDA #"/"          /
 2270         JSR COUT
 2280         PLA               X 0YYYYYYY
 2290         JSR DEC.OUT       display year
 2300  *--------------------------------
 2310  GOOD.EXIT
 2320         CLC               signal no error
 2330  RTS1   RTS
 2340  *--------------------------------
 2350  ERROR1 PLA               clean up
 2360         PLA               return addresses
 2370  ERROR  SEC               signal error
 2380  EXIT   JMP RTS1          INSTALL makes address
 2390  *--------------------------------
 2400  ACCUMULATE.DIGITS
 2410         LDA #0
 2420         STA ACCUM         zero accumulator
 2430   
 2440  .1     INY               next character
 2450         LDA (POINTER),Y
 2460         AND #%01111111    hi-bit off
 2470         CMP #' '          space?
 2480         BEQ .1            back for another
 2490         CMP #'/'          slash?
 2500         BEQ .2            yes, exit .CC.
 2510         CMP #$0D          <CR>?
 2520         BEQ .3            yes, exit .CS.
 2530         CMP #'0'          too small?
 2540         BCC ERROR1        not digit
 2550         CMP #'9'+1        too big?
 2560         BCS ERROR1        not digit
 2570   
 2580         AND #%00001111    isolate value
 2590         STA TEMP          stash it
 2600         LDA ACCUM
 2610         ASL               X 2
 2620         ASL               X 4
 2630         ADC ACCUM         X 5
 2640         ASL               X 10
 2650         ADC TEMP          add new digit
 2660         BCS ERROR1        too big
 2670         STA ACCUM
 2680         BCC .1         ...always
 2690   
 2700  .2     CLC               .CC. if /
 2710  .3     LDA ACCUM         return value
 2720         BEQ ERROR1        0 no good
 2730         RTS
 2740  *--------------------------------
 2750  DEC.OUT
 2760         LDY #0            zero counter
 2770         SEC               get ready
 2780  .1     SBC #10           subtract 10
 2790         BCC .2            borrow?
 2800         INY               count a 10
 2810         BPL .1         ...always
 2820   
 2830  .2     ADC #10           restore borrow
 2840         PHA               save units
 2850         TYA               print 10's count
 2860         BEQ .3            no leading zero
 2870         ORA #$B0          make character
 2880         JSR COUT          print it
 2890  .3     PLA               recover units
 2900         ORA #$B0          make character
 2910         JMP COUT          return through COUT

