10 REM > Stamp104/s 10-Aug-2007
   20 REM Source for *Stamp
   30 REM Syntax: *Stamp <afsp> <date>
   40 REM Now does  (<date>)
   50 REM NB: Whether full range is stored depends on filing system
   60 REM 12-Aug-1998 v1.03 JGH: Allows full date range
   70 REM 10-Aug-2007 v1.04 JGH: Full 7-bit year range 1981-2108
   80 :
   90 DIM mcode% &200:load%=&FFFF0900
  100 OSFILE=&FFDD:OSARGS=&FFDA
  110 lptr=&A8:temp=&AA
  120 ver$="1.04"
  130 :
  140 FOR P=0 TO 1
  150   O%=mcode%:P%=load%
  160   [OPT P*3+4
  170   .error
  180   BRK:EQUB 220
  190   EQUS "Syntax: Stamp <afsp>":BRK:\ "(<date>)"BRK
  200   .start%
  210   LDX #lptr:LDY #0:LDA #1:JSR OSARGS
  220   LDA lptr:STA blk:LDA lptr+1:STA blk+1
  230   LDY #0:LDA (lptr),Y:CMP #13:BEQ error
  240   .SkpToSpc
  250   LDA (lptr),Y:INY:CMP #ASC"!"
  260   BCS SkpToSpc
  270   CMP #13:BNE SkpSpc                         :\ Not eol, parse date
  280   LDX #date AND 255:LDY #date DIV 256
  290   LDA #1:STA date:LDA #14:JSR &FFF1          :\ Reads current Year/Month/Day
  300   JMP SetDate
  310   :
  320   .SkpSpc
  330   LDA (lptr),Y:INY:CMP #ASC" "
  340   BEQ SkpSpc:DEY
  350   JSR GetHex:AND #&3F:STA Day:INY            :\ Day &01-&31
  360   JSR GetHex:AND #&1F:STA Month:INY          :\ Month &01-&12
  370   JSR GetHex:BEQ SetYear                     :\ 00xx -> leave as 20xx
  380   CPX #&20:BEQ SetYear                       :\ 20xx -> leave as 20xx
  390   CLC:ADC #&60:CPX #&19:BEQ SetYear          :\ 19xx -> becomes 140+yr
  400   CLC:ADC #&40                               :\ 21xx -> becomes 100+yr
  410   .SetYear
  420   STA Year
  430   :
  440   .SetDate
  450   LDX #3:.SetDateLp
  460   LDA date,X:JSR BCDToBIN:STA date,X         :\ Convert date from BCD
  470   DEX:BPL SetDateLp
  480   LDA Day:PHA:AND #31:STA Day                :\ Ensure day is 1-31
  490   PLA:AND #&E0:LSR A:ADC Year                :\ Get any overflow from Day
  500   CMP #140:BCC P%+4:ADC #95                  :\ If 19xx, year=-20..-1
  510   CLC:ADC #19:STA Year                       :\ Convert to offset from 1981
  520   LDX #blk AND 255:LDY #blk DIV 256:LDA #5
  530   JSR OSFILE:CMP #0:BEQ NotFound             :\ Read current attributes
  540   LDA Year:AND #&70:ASL A:ORA Day:STA blk+15 :\ Merge Day+YearTop
  550   LDA Year:ASL A:ASL A:ASL A:ASL A:ORA Month :\ Merge Month+YearBot
  560   STA blk+16:LDA #4:JMP OSFILE               :\ Write updated attributes
  570   :
  580   .NotFound
  590   BRK:EQUB 214
  600   EQUS "File not found":BRK
  610   :
  620   .GetHex
  630   LDX #0:STX temp+0:STX temp+1
  640   .GetHexLp
  650   LDA (lptr),Y:CMP #ASC"0":BCC GetHexEnd
  660   CMP #ASC"9"+1:BCC GetHexDigit
  670   AND #&DF:CMP #ASC"G":BCS GetHexEnd
  680   SBC #6+64:BCC GetHexEnd
  690   .GetHexDigit
  700   ASL temp+0:ROL temp+1:ASL temp+0:ROL temp+1
  710   ASL temp+0:ROL temp+1:ASL temp+0:ROL temp+1
  720   AND #15:CLC:ADC temp+0:STA temp+0
  730   INX:INY:BNE GetHexLp
  740   .GetHexEnd
  750   LDA temp+0:LDX temp+1:RTS                  :\ Return &XXAA
  760   :
  770   .BCDToBIN
  780   PHA:AND #&F0:LSR A:LSR A:LSR A:STA date+4
  790   ASL A:ASL A:ADC date+4:STA date+4
  800   \CMP #99:\BCS BCDToBINErr
  810   PLA:AND #&0F:\CMP #&0A:\BCS BCDToBINErr
  820   ADC date+4:RTS
  830   \.BCDToBINErr
  840   \JMP error
  850   :
  860   .date:EQUS "YMDdHMS"
  870   .blk :EQUS ver$
  880   ]
  890   Year=date:Month=date+1:Day=date+2
  900 NEXT
  910 PRINT"*SAVE Stamp ";~mcode%;" ";~O%;" ";~start%OR&FFFF0000;" ";~load%

Download Stamp.src

BBC BASIC detokeniser and syntax highlighter by Ben Ryves.