ProForth for the Apple II (6502 Source, could be adapted to the Atari 8bit)#

fdict.s

          LST OFF,NOGen,NOWarn,NOVsym,NOAsym,NOExp
          MACLIB
          ORG $800
SSIZE     EQU 1024
NBUF      EQU 2
BMAG      EQU SSIZE+4*NBUF
BOS       EQU $60
TOS       EQU $DE
N         EQU TOS+8
IP        EQU N+8
W         EQU IP+3
UP        EQU W+2
XSAVE     EQU UP+2
KSWL      EQU $38
TIBX      EQU $0300
MEM       EQU $BF00
UAREA     EQU MEM-128
DAREA     EQU UAREA-BMAG
MLI       EQU $BF00
OUTCH     EQU $FDED
INCH      EQU $FD0C
CROUT     EQU $FD8E
MONITOR   EQU $FF69
ORIG      EQU *
ENTER     JMP COLD+2
          NOP  
REENTER   JMP WARM
          NOP
          DW $0004
          DW $5ED2
          DW NTOP Last NFA
          DW 8 Backspace key
          DW UAREA User start 
          DW TOS Program TOS
          DW $1FF Return TOS
          DW TIBX Terminal input buffer
          DW 31 Name field size max
          DW 1 Warning
          DW TOP FENCE
          DW TOP DP
          DW VLO VOC-LINK
          DW 0
L22       NAME $83,'LIT'
          DW 00
LIT       DW *+2
          LDA (IP),Y
          PHA
          INC IP
          BNE L30
          INC IP+1
L30       LDA (IP),Y
L31       INC IP
          BNE PUSH
          INC IP+1
PUSH      DEX
          DEX
PUT       STA 1,X
          PLA
          STA 0,X
NEXT      LDY #1
          LDA (IP),Y
          STA W+1
          DEY
          LDA (IP),Y
          STA W
          CLC
          LDA IP
          ADC #2
          STA IP
          BCC L54
          INC IP+1
L54       JMP W-1
*
L35       NAME $84,'CLIT'
          DW L22
CLIT      DW *+2
          LDA (IP),Y
          PHA
          TYA
          BEQ L31
SETUP     ASL A
          STA N-1
L63       LDA 0,X
          STA N,Y
          INX
          INY
          CPY N-1
          BNE L63
          LDY #0
          RTS
L75       NAME $87,'EXECUTE'
          DW L35
EXEC      DW *+2
          LDA 0,X
          STA W
          LDA 1,X
          STA W+1
          INX
          INX
          JMP W-1
L89       NAME $86,'BRANCH'
          DW L75
BRAN      DW *+2
          CLC
          LDA (IP),Y
          ADC IP
          PHA
          INY
          LDA (IP),Y
          ADC IP+1
          STA IP+1
          PLA
          STA IP
          JMP NEXT+2
L107      NAME $87,'0BRANCH'
          DW L89
ZBRAN     DW *+2
          INX
          INX
          LDA $FE,X
          ORA $FF,X
          BEQ BRAN+2
BUMP      CLC
          LDA IP
          ADC #2
          STA IP
          BCC L122
          INC IP+1
L122      JMP NEXT
L127      NAME $86,'(LOOP)'
          DW L107
PLOOP     DW L130
L130      STX XSAVE
          TSX
          INC $101,X
          BNE PL1
          INC $102,X
PL1       CLC
          LDA $103,X
          SBC $101,X
          LDA $104,X
          SBC $102,X
PL2       LDX XSAVE
          ASL A
          BCC BRAN+2
          PLA
          PLA
          PLA
          PLA
          JMP BUMP
L154      NAME $87,'(+LOOP)'
          DW L127
PPLOO     DW *+2
          INX
          INX
          STX XSAVE
          LDA $FF,X
          PHA
          PHA
          LDA $FE,X
          TSX
          INX
          INX
          CLC
          ADC $101,X
          STA $101,X
          PLA
          ADC $102,X
          STA $102,X
          PLA
          BPL PL1
          CLC
          LDA $101,X
          SBC $103,X
          LDA $102,X
          SBC $104,X
          JMP PL2
L185      NAME $84,'(DO)'
          DW L154
PDO       DW *+2
          LDA 3,X
          PHA
          LDA 2,X
          PHA
          LDA 1,X
          PHA
          LDA 0,X
          PHA
POPTWO    INX
          INX
POP       INX
          INX
          JMP NEXT
L207      NAME $81,'I'
          DW L185
I         DW R+2
L214      NAME $85,'DIGIT'
          DW L207
DIGIT     DW *+2
          SEC
          LDA 2,X
          SBC #$30
          BMI L234
          CMP #$A
          BMI L227
          SEC
          SBC #7
          CMP #$A
          BMI L234
L227      CMP 0,X
          BPL L234
          STA 2,X
          LDA #1
          PHA
          TYA
          JMP PUT
L234      TYA
          PHA
          INX
          INX
          JMP PUT
L243      NAME $86,'(FIND)'
          DW L214
PFIND     DW *+2
          LDA #2
          JSR SETUP
          STX XSAVE
L249      LDY #0
          LDA (N),Y
          EOR (N+2),Y
          AND #$3F
          BNE L281
L254      INY
          LDA (N),Y
          EOR (N+2),Y
          ASL A
          BNE L280
          BCC L254
          LDX XSAVE
          DEX
          DEX
          DEX
          DEX
          CLC
          TYA
          ADC #5
          ADC N
          STA 2,X
          LDY #0
          TYA
          ADC N+1
          STA 3,X
          STY 1,X
          LDA (N),Y
          STA 0,X
          LDA #1
          PHA
          JMP PUSH
L280      BCS L284
L281      INY
          LDA (N),Y
          BPL L281
L284      INY
          LDA (N),Y
          TAX
          INY
          LDA (N),Y
          STA N+1
          STX N
          ORA N
          BNE L249
          LDX XSAVE
          LDA #0
          PHA
          JMP PUSH
L301      NAME $87,'ENCLOSE'
          DW L243
ENCL      DW *+2
          LDA #2
          JSR SETUP
          TXA
          SEC
          SBC #8
          TAX
          STY 3,X
          STY 1,X
          DEY
          DEC N+3
          DEC 1,X
L313      INY
          BNE LX1
          INC N+3
          INC 1,X
LX1       LDA (N+2),Y
          CMP N
          BEQ L313
          STY 4,X
          LDA 1,X
          STA 5,X
L318      LDA (N+2),Y
          BNE L327
          STY 2,X
          STY 0,X
          LDA 1,X
          STA 3,X
          TYA
          CMP 4,X
          BNE L326
          LDA 1,X
          CMP 5,X
          BNE L326
          INC 2,X
          BNE L326
          INC 3,X
L326      JMP NEXT
L327      PHA
          STY 2,X
          LDA 1,X
          STA 3,X
          INY
          BNE LX2
          INC 1,X
          INC N+3
LX2       PLA
          CMP N
          BNE L318
          STY 0,X
          JMP NEXT
L337      NAME $84,'EMIT'
          DW L301
EMIT      DW XEMIT
L344      NAME $83,'KEY'
          DW L337
KEY       DW XKEY
L351      NAME $89,'?TERMINAL'
          DW L344
QTERM     DW XQTER
L358      NAME $82,'CR'
          DW L351
CR        DW XCR
L365      NAME $85,'CMOVE'
          DW L358
CMOVE     DW *+2
          LDA #3
          JSR SETUP
L370      CPY N
          BNE L375
          DEC N+1
          BPL L375
          JMP NEXT
L375      LDA (N+4),Y
          STA (N+2),Y
          INY
          BNE L370
          INC N+5
          INC N+3
          JMP L370
L386      NAME $82,'U*'
          DW L365
USTAR     DW *+2
          LDA 2,X
          STA N
          STY 2,X
          LDA 3,X
          STA N+1
          STY 3,X
          LDY #16
L396      ASL 2,X
          ROL 3,X
          ROL 0,X
          ROL 1,X
          BCC L411
          CLC
          LDA N
          ADC 2,X
          STA 2,X
          LDA N+1
          ADC 3,X
          STA 3,X
          LDA #0
          ADC 0,X
          STA 0,X
L411      DEY
          BNE L396
          JMP NEXT
L418      NAME $82,'U/'
          DW L386
USLAS     DW *+2
          LDA 4,X
          LDY 2,X
          STY 4,X
          ASL A
          STA 2,X
          LDA 5,X
          LDY 3,X
          STY 5,X
          ROL A
          STA 3,X
          LDA #16
          STA N
L433      ROL 4,X
          ROL 5,X
          SEC
          LDA 4,X
          SBC 0,X
          TAY
          LDA 5,X
          SBC 1,X
          BCC L444
          STY 4,X
          STA 5,X
L444      ROL 2,X
          ROL 3,X
          DEC N
          BNE L433
          JMP POP
L453      NAME $83,'AND'
          DW L418
ANDD      DW *+2
          LDA 0,X
          AND 2,X
          PHA
          LDA 1,X
          AND 3,X
BINARY    INX
          INX
          JMP PUT
L469      NAME $82,'OR'
          DW L453
OR        DW *+2
          LDA 0,X
          ORA 2,X
          PHA
          LDA 1,X
          ORA 3,X
          INX
          INX
          JMP PUT
L484      NAME $83,'XOR'
          DW L469
XOR       DW *+2
          LDA 0,X
          EOR 2,X
          PHA
          LDA 1,X
          EOR 3,X
          INX
          INX
          JMP PUT
L499      NAME $83,'SP@'
          DW L484
SPAT      DW *+2
          TXA
PUSHOA    PHA
          LDA #0
          JMP PUSH
L511      NAME $83,'SP!'
          DW L499
SPSTO     DW *+2
          LDY #6
          LDA (UP),Y
          TAX
          JMP NEXT
L522      NAME $83,'RP!'
          DW L511
RPSTO     DW *+2
          STX XSAVE
          LDY #8
          LDA (UP),Y
          TAX
          TXS
          LDX XSAVE
          JMP NEXT
L536      NAME $82,'     ;S'
          DW L522
SEMIS     DW *+2
          PLA
          STA IP
          PLA
          STA IP+1
          JMP NEXT
L548      NAME $85,'LEAVE'
          DW L536
LEAVE     DW *+2
          STX XSAVE
          TSX
          LDA $101,X
          STA $103,X
          LDA $102,X
          STA $104,X
          LDX XSAVE
          JMP NEXT
L563      NAME $82,'>R'
          DW L548
TOR       DW *+2
          LDA 1,X
          PHA
          LDA 0,X
          PHA
          INX
          INX
          JMP NEXT
L577      NAME $82,'R>'
          DW L563
RFROM     DW *+2
          DEX
          DEX
          PLA
          STA 0,X
          PLA
          STA 1,X
          JMP NEXT
L591      NAME $81,'R'
          DW L577
R         DW *+2
          STX XSAVE
          TSX
          LDA $101,X
          PHA
          LDA $102,X
          LDX XSAVE
          JMP PUSH
L605      NAME $82,'0='
          DW L591
ZEQU      DW *+2
          LDA 0,X
          ORA 1,X
          STY 1,X
          BNE L613
          INY
L613      STY 0,X
          JMP NEXT
L619      NAME $82,'0<'
          DW L605
ZLESS     DW *+2
          ASL 1,X
          TYA
          ROL A
          STY 1,X
          STA 0,X
          JMP NEXT
          DW 0
L632      NAME $81,'+'
          DW L619
PLUS      DW *+2
          CLC
          LDA 0,X
          ADC 2,X
          STA 2,X
          LDA 1,X
          ADC 3,X
          STA 3,X
          INX
          INX
          JMP NEXT
L649      NAME $82,'D+'
          DW L632
DPLUS     DW *+2
          CLC
          LDA 2,X
          ADC 6,X
          STA 6,X
          LDA 3,X
          ADC 7,X
          STA 7,X
          LDA 0,X
          ADC 4,X
          STA 4,X
          LDA 1,X
          ADC 5,X
          STA 5,X
          JMP POPTWO
L670      NAME $85,'MINUS'
          DW L649
MINUS     DW *+2
          SEC
          TYA
          SBC 0,X
          STA 0,X
          TYA
          SBC 1,X
          STA 1,X
          JMP NEXT
L685      NAME $86,'DMINUS'
          DW L670
DMINU     DW *+2
          SEC
          TYA
          SBC 2,X
          STA 2,X
          TYA
          SBC 3,X
          STA 3,X
          JMP MINUS+3
L700      NAME $84,'OVER'
          DW L685
OVER      DW *+2
          LDA 2,X
          PHA
          LDA 3,X
          JMP PUSH
L711      NAME $84,'DROP'
          DW L700
DROP      DW POP
L718      NAME $84,'SWAP'
          DW L711
SWAP      DW *+2
          LDA 2,X
          PHA
          LDA 0,X
          STA 2,X
          LDA 3,X
          LDY 1,X
          STY 3,X
          JMP PUT
L733      NAME $83,'DUP'
          DW L718
DUP       DW *+2
          LDA 0,X
          PHA
          LDA 1,X
          JMP PUSH
L744      NAME $82,'+!'
          DW L733
PSTOR     DW *+2
          CLC
          LDA (0,X)
          ADC 2,X
          STA (0,X)
          INC 0,X
          BNE L754
          INC 1,X
L754      LDA (0,X)
          ADC 3,X
          STA (0,X)
          JMP POPTWO
L762      NAME $86,'TOGGLE'
          DW L744
TOGGL     DW *+2
          LDA (2,X)
          EOR 0,X
          STA (2,X)
          JMP POPTWO
L773      NAME $81,'@'
          DW L762
AT        DW *+2
          LDA (0,X)
          PHA
          INC 0,X
          BNE L781
          INC 1,X
L781      LDA (0,X)
          JMP PUT
L787      NAME $82,'C@'
          DW L773
CAT       DW *+2
          LDA (0,X)
          STA 0,X
          STY 1,X
          JMP NEXT
L798      NAME $81,'!'
          DW L787
STORE     DW *+2
          LDA 2,X
          STA (0,X)
          INC 0,X
          BNE L806
          INC 1,X
L806      LDA 3,X
          STA (0,X)
          JMP POPTWO
L813      NAME $82,'C!'
          DW L798
CSTOR     DW *+2
          LDA 2,X
          STA (0,X)
          JMP POPTWO
L823      NAME $C1,':'
          DW L813
COLON     DW DOCOL
          DW QEXEC
          DW SCSP
          DW CURR
          DW AT
          DW CON
          DW STORE
          DW CREAT
          DW RBRAC
          DW PSCOD
DOCOL     LDA IP+1
          PHA
          LDA IP
          PHA
          CLC
          LDA W
          ADC #2
          STA IP
          TYA
          ADC W+1
          STA IP+1
          JMP NEXT
L853      NAME $C1,'     ;'
          DW L823
          DW DOCOL
          DW QCSP
          DW COMP
          DW SEMIS
          DW SMUDG
          DW LBRAC
          DW SEMIS
L867      NAME $88,'CONSTANT'
          DW L853
CONST     DW DOCOL
          DW CREAT
          DW SMUDG
          DW COMMA
          DW PSCOD
DOCON     LDY #2
          LDA (W),Y
          PHA
          INY
          LDA (W),Y
          JMP PUSH
L885      NAME $88,'VARIABLE'
          DW L867
VAR       DW DOCOL
          DW CONST
          DW PSCOD
DOVAR     CLC
          LDA W
          ADC #2
          PHA
          TYA
          ADC W+1
          JMP PUSH
L902      NAME $84,'USER'
          DW L885
USER      DW DOCOL
          DW CONST
          DW PSCOD
DOUSE     LDY #2
          CLC
          LDA (W),Y
          ADC UP
          PHA
          LDA #0
          ADC UP+1
          JMP PUSH
L920      NAME $81,'0'
          DW L902
ZERO      DW DOCON
          DW 0
L928      NAME $81,'1'
          DW L920
ONE       DW DOCON
          DW 1
L936      NAME $81,'2'
          DW L928
TWO       DW DOCON
          DW 2
L944      NAME $81,'3'
          DW L936
THREE     DW DOCON
          DW 3
L952      NAME $82,'BL'
          DW L944
BL        DW DOCON
          DW $20
L960      NAME $83,'C/L'
          DW L952
CSLL      DW DOCON
          DW 64
L968      NAME $85,'FIRST'
          DW L960
FIRST     DW DOCON
          DW DAREA
L976      NAME $85,'LIMIT'
          DW L968
LIMIT     DW DOCON
          DW UAREA
L984      NAME $85,'B/BUF'
          DW L976
BBUF      DW DOCON
          DW SSIZE
L992      NAME $85,'B/SCR'
          DW L984
BSCR      DW DOCON
          DW 1024/SSIZE
L993      NAME $85,'FSIZE'
          DW L992
FSIZE     DW DOCON
          DW 100
L1000     NAME $87,'+ORIGIN'
          DW L993
PORIG     DW DOCOL
          DW LIT,ORIG
          DW PLUS
          DW SEMIS
L1010     NAME $83,'TIB'
          DW L1000
TIB       DW DOUSE
          DFB $A
L1018     NAME $85,'WIDTH'
          DW L1010
WIDTH     DW DOUSE
                         ;
          DFB $C
L1026     NAME $87,'WARNING'
          DW L1018
WARN      DW DOUSE
          DFB $E
L1034     NAME $85,'FENCE'
          DW L1026
FENCE     DW DOUSE
          DFB $10
L1042     NAME $82,'DP'
          DW L1034
DP        DW DOUSE
          DFB $12
L1050     NAME $88,'VOC-LINK'
          DW L1042
VOCL      DW DOUSE
          DFB $14
L1058     NAME $83,'BLK'
          DW L1050
BLK       DW DOUSE
          DFB $16
L1066     NAME $82,'IN'
          DW L1058
IN        DW DOUSE
          DFB $18
L1074     NAME $83,'OUT'
          DW L1066
OUT       DW DOUSE
          DFB $1A
L1082     NAME $83,'SCR'
          DW L1074
SCR       DW DOUSE
          DFB $1C
L1090     NAME $86,'OFFSET'
          DW L1082
OFSET     DW DOUSE
          DFB $1E
L1098     NAME $87,'CONTEXT'
          DW L1090
CON       DW DOUSE
          DFB $20
L1106     NAME $87,'CURRENT'
          DW L1098
CURR      DW DOUSE
          DFB $22
L1114     NAME $85,'STATE'
          DW L1106
STATE     DW DOUSE
          DFB $24
L1122     NAME $84,'BASE'
          DW L1114
BASE      DW DOUSE
          DFB $26
L1130     NAME $83,'DPL'
          DW L1122
DPL       DW DOUSE
          DFB $28
L1138     NAME $83,'FLD'
          DW L1130
FLD       DW DOUSE
          DFB $2A
L1146     NAME $83,'CSP'
          DW L1138
CSP       DW DOUSE
          DFB $2C
L1154     NAME $82,'R#'
          DW L1146
RNUM      DW DOUSE
          DFB $2E
L1162     NAME $83,'HLD'
          DW L1154
HLD       DW DOUSE
          DFB $30
L1170     NAME $82,'1+'
          DW L1162
ONEP      DW DOCOL
          DW ONE
          DW PLUS
          DW SEMIS
L1180     NAME $82,'2+'
          DW L1170
TWOP      DW DOCOL
          DW TWO
          DW PLUS
          DW SEMIS
L1190     NAME $84,'HERE'
          DW L1180
HERE      DW DOCOL
          DW DP
          DW AT
          DW SEMIS
L1200     NAME $85,'ALLOT'
          DW L1190
ALLOT     DW DOCOL
          DW DP
          DW PSTOR
          DW SEMIS
L1210     DFB $81,$AC ,
          DW L1200
COMMA     DW DOCOL
          DW HERE
          DW STORE
          DW TWO
          DW ALLOT
          DW SEMIS
L1222     DFB $82,'C',$AC C,
          DW L1210
CCOMM     DW DOCOL
          DW HERE
          DW CSTOR
          DW ONE
          DW ALLOT
          DW SEMIS
L1234     NAME $81,'-'
          DW L1222
SUB       DW DOCOL
          DW MINUS
          DW PLUS
          DW SEMIS
L1244     NAME $81,'='
          DW L1234
EQUAL     DW DOCOL
          DW SUB
          DW ZEQU
          DW SEMIS
L1246     NAME $82,'U<'
          DW L1244
ULESS     DW *+2
          LDA 2,X
          CMP 0,X
          LDA 3,X
          SBC 1,X
          TYA
          ROL A
          EOR #1
          STA 2,X
          STY 3,X
          JMP POP
L1254     NAME $81,'<'
          DW L1246
LESS      DW *+2
          SEC
          LDA 2,X
          SBC 0,X
          LDA 3,X
          SBC 1,X
          STY 3,X
          BVC L1258
          EOR #$80
L1258     BPL L1260
          INY
L1260     STY 2,X
          JMP POP
L1264     NAME $81,'>'
          DW L1254
GREAT     DW DOCOL
          DW SWAP
          DW LESS
          DW SEMIS
L1274     NAME $83,'ROT'
          DW L1264
ROT       DW DOCOL
          DW TOR
          DW SWAP
          DW RFROM
          DW SWAP
          DW SEMIS
L1286     NAME $85,'SPACE'
          DW L1274
SPACE     DW DOCOL
          DW BL
          DW EMIT
          DW SEMIS
L1296     NAME $84,'-DUP'
          DW L1286
DDUP      DW DOCOL
          DW DUP
          DW ZBRAN
L1301     DW $4
          DW DUP
L1303     DW SEMIS
L1308     NAME $88,'TRAVERSE'
          DW L1296
TRAV      DW DOCOL
          DW SWAP
L1312     DW OVER
          DW PLUS
          DW CLIT
          DFB $7F
          DW OVER
          DW CAT
          DW LESS
          DW ZBRAN
L1320     DW $FFF1
          DW SWAP
          DW DROP
          DW SEMIS
L1328     NAME $86,'LATEST'
          DW L1308
LATES     DW DOCOL
          DW CURR
          DW AT
          DW AT
          DW SEMIS
L1339     NAME $83,'LFA'
          DW L1328
LFA       DW DOCOL
          DW CLIT
          DFB 4
          DW SUB
          DW SEMIS
L1350     NAME $83,'CFA'
          DW L1339
CFA       DW DOCOL
          DW TWO
          DW SUB
          DW SEMIS
L1360     NAME $83,'NFA'
          DW L1350
NFA       DW DOCOL
          DW CLIT
          DFB $5
          DW SUB
          DW LIT,$FFFF
          DW TRAV
          DW SEMIS
L1373     NAME $83,'PFA'
          DW L1360
PFA       DW DOCOL
          DW ONE
          DW TRAV
          DW CLIT
          DFB 5
          DW PLUS
          DW SEMIS
L1386     NAME $84,'!CSP'
          DW L1373
SCSP      DW DOCOL
          DW SPAT
          DW CSP
          DW STORE
          DW SEMIS
L1397     NAME $86,'?ERROR'
          DW L1386
QERR      DW DOCOL
          DW SWAP
          DW ZBRAN
L1402     DW 8
          DW ERROR
          DW BRAN
L1405     DW 4
L1406     DW DROP
L1407     DW SEMIS
L1412     NAME $85,'?COMP'
          DW L1397
QCOMP     DW DOCOL
          DW STATE
          DW AT
          DW ZEQU
          DW CLIT
          DFB $11
          DW QERR
          DW SEMIS
L1426     NAME $85,'?EXEC'
          DW L1412
QEXEC     DW DOCOL
          DW STATE
          DW AT
          DW CLIT
          DFB $12
          DW QERR
          DW SEMIS
L1439     NAME $86,'?PAIRS'
          DW L1426
QPAIR     DW DOCOL
          DW SUB
          DW CLIT
          DFB $13
          DW QERR
          DW SEMIS
L1451     NAME $84,'?CSP'
          DW L1439
QCSP      DW DOCOL
          DW SPAT
          DW CSP
          DW AT
          DW SUB
          DW CLIT
          DFB $14
          DW QERR
          DW SEMIS
L1466     NAME $88,'?LOADING'
          DW L1451
QLOAD     DW DOCOL
          DW BLK
          DW AT
          DW ZEQU
          DW CLIT
          DFB $16
          DW QERR
          DW SEMIS
L1480     NAME $87,'COMPILE'
          DW L1466
COMP      DW DOCOL
          DW QCOMP
          DW RFROM
          DW DUP
          DW TWOP
          DW TOR
          DW AT
          DW COMMA
          DW SEMIS
L1495     NAME $C1,'['
          DW L1480
LBRAC     DW DOCOL
          DW ZERO
          DW STATE
          DW STORE
          DW SEMIS
L1507     NAME $81,']'
          DW L1495
RBRAC     DW DOCOL
          DW CLIT
          DFB $C0
          DW STATE
          DW STORE
          DW SEMIS
L1519     NAME $86,'SMUDGE'
          DW L1507
SMUDG     DW DOCOL
          DW LATES
          DW CLIT
          DFB $20
          DW TOGGL
          DW SEMIS
L1531     NAME $83,'HEX'
          DW L1519
HEX       DW DOCOL
          DW CLIT
          DFB 16
          DW BASE
          DW STORE
          DW SEMIS
L1543     NAME $87,'DECIMAL'
          DW L1531
DECIM     DW DOCOL
          DW CLIT
          DFB 10
          DW BASE
          DW STORE
          DW SEMIS
L1555     NAME $87,'(    ;CODE)'
          DW L1543
PSCOD     DW DOCOL
          DW RFROM
          DW LATES
          DW PFA
          DW CFA
          DW STORE
          DW SEMIS
L1568     NAME $C5,'     ;CODE'
          DW L1555
          DW DOCOL
          DW QCSP
          DW COMP
          DW PSCOD
          DW LBRAC
          DW SMUDG
          DW SEMIS
L1582     NAME $87,'<BUILDS'
          DW L1568
BUILD     DW DOCOL
          DW ZERO
          DW CONST
          DW SEMIS
L1592     NAME $85,'DOES>'
          DW L1582
DOES      DW DOCOL
          DW RFROM
          DW LATES
          DW PFA
          DW STORE
          DW PSCOD
DODOE     LDA IP+1
          PHA
          LDA IP
          PHA
          LDY #2
          LDA (W),Y
          STA IP
          INY
          LDA (W),Y
          STA IP+1
          CLC
          LDA W
          ADC #4
          PHA
          LDA W+1
          ADC #0
          JMP PUSH
L1622     NAME $85,'COUNT'
          DW L1592
COUNT     DW DOCOL
          DW DUP
          DW ONEP
          DW SWAP
          DW CAT
          DW SEMIS
L1634     NAME $84,'TYPE'
          DW L1622
TYPE      DW DOCOL
          DW DDUP
          DW ZBRAN
L1639     DW $18
          DW OVER
          DW PLUS
          DW SWAP
          DW PDO
L1644     DW I
          DW CAT
          DW EMIT
          DW PLOOP
L1648     DW $FFF8
          DW BRAN
L1650     DW $4
L1651     DW DROP
L1652     DW SEMIS
L1657     NAME $89,'-TRAILING'
          DW L1634
DTRAI     DW *+2
          LDY 0,X
          LDA 2,X
          STA N
          LDA 3,X
          STA N+1
DTR1      DEY
          BMI DTR2
          LDA (N),Y
          CMP #$20
          BEQ DTR1
DTR2      INY
          STY 0,X
          JMP NEXT
L1685     NAME $84,'(.")'
          DW L1657
PDOTQ     DW DOCOL
          DW R
          DW COUNT
          DW DUP
          DW ONEP
          DW RFROM
          DW PLUS
          DW TOR
          DW TYPE
          DW SEMIS
L1701     NAME $C2,'."'
          DW L1685
          DW DOCOL
          DW CLIT
          DFB $22
          DW STATE
          DW AT
          DW ZBRAN
L1709     DW $14
          DW COMP
          DW PDOTQ
          DW WORD
          DW HERE
          DW CAT
          DW ONEP
          DW ALLOT
          DW BRAN
L1718     DW $A
L1719     DW WORD
          DW HERE
          DW COUNT
          DW TYPE
L1723     DW SEMIS
L1729     NAME $86,'EXPECT'
          DW L1701
EXPEC     DW *+2
          STX XSAVE
          LDA 2,X
          STA N
          LDA 3,X
          STA N+1
          JSR $FD6F
          CPX #$4D
          BCC EXPEC1
          LDX #$4C
EXPEC1    LDA #0
          STA $200,X
          INX
          STA $200,X
          INX
          STA $200,X
          INX
          STA $200,X
          TXA
          TAY
EXPEC2    LDA $200,X
          AND #$7F
          STA (N),Y
          DEY
          DEX
          BPL EXPEC2
          LDX XSAVE
          JMP POPTWO
L1788     NAME $85,'QUERY'
          DW L1729
QUERY     DW DOCOL
          DW TIB
          DW AT
          DW CLIT
          DFB 80
          DW EXPEC
          DW ZERO
          DW IN
          DW STORE
          DW SEMIS
L1804     DFB $C1,$80 @
          DW L1788
          DW DOCOL
          DW BLK
          DW AT
          DW ZBRAN
L1810     DW $2A
          DW ONE
          DW BLK
          DW PSTOR
          DW ZERO
          DW IN
          DW STORE
          DW BLK
          DW AT
          DW ZERO,BSCR
          DW USLAS
          DW DROP
          DW ZEQU
          DW ZBRAN
L1824     DW 8
          DW QEXEC
          DW RFROM
          DW DROP
L1828     DW BRAN
L1829     DW 6
L1830     DW RFROM
          DW DROP
L1832     DW SEMIS
L1838     NAME $84,'FILL'
          DW L1804
FILL      DW DOCOL
          DW SWAP
          DW TOR
          DW OVER
          DW CSTOR
          DW DUP
          DW ONEP
          DW RFROM
          DW ONE
          DW SUB
          DW CMOVE
          DW SEMIS
L1856     NAME $85,'ERASE'
          DW L1838
ERASE     DW DOCOL
          DW ZERO
          DW FILL
          DW SEMIS
L1866     NAME $86,'BLANKS'
          DW L1856
BLANK     DW DOCOL
          DW BL
          DW FILL
          DW SEMIS
L1876     NAME $84,'HOLD'
          DW L1866
HOLD      DW DOCOL
          DW LIT,$FFFF
          DW HLD
          DW PSTOR
          DW HLD
          DW AT
          DW CSTOR
          DW SEMIS
L1890     NAME $83,'PAD'
          DW L1876
PAD       DW DOCOL
          DW HERE
          DW CLIT
          DFB 68
          DW PLUS
          DW SEMIS
L1902     NAME $84,'WORD'
          DW L1890
WORD      DW DOCOL
          DW BLK
          DW AT
          DW ZBRAN
L1908     DW $C
          DW BLK
          DW AT
          DW BLOCK
          DW BRAN
L1913     DW $6
L1914     DW TIB
          DW AT
L1916     DW IN
          DW AT
          DW PLUS
          DW SWAP
          DW ENCL
          DW HERE
          DW CLIT
          DFB $22
          DW BLANK
          DW IN
          DW PSTOR
          DW OVER
          DW SUB
          DW TOR
          DW R
          DW HERE
          DW CSTOR
          DW PLUS
          DW HERE
          DW ONEP
          DW RFROM
          DW CMOVE
          DW SEMIS
L1943     NAME $85,'UPPER'
          DW L1902
UPPER     DW DOCOL
          DW OVER
          DW PLUS
          DW SWAP
          DW PDO
L1950     DW I
          DW CAT
          DW CLIT
          DFB $5F
          DW GREAT
          DW ZBRAN
L1956     DW 09
          DW I
          DW CLIT
          DFB $20
          DW TOGGL
L1961     DW PLOOP
L1962     DW $FFEA
          DW SEMIS
L1968     NAME $88,'(NUMBER)'
          DW L1943
PNUMB     DW DOCOL
L1971     DW ONEP
          DW DUP
          DW TOR
          DW CAT
          DW BASE
          DW AT
          DW DIGIT
          DW ZBRAN
L1979     DW $2C
          DW SWAP
          DW BASE
          DW AT
          DW USTAR
          DW DROP
          DW ROT
          DW BASE
          DW AT
          DW USTAR
          DW DPLUS
          DW DPL
          DW AT
          DW ONEP
          DW ZBRAN
L1994     DW 8
          DW ONE
          DW DPL
          DW PSTOR
L1998     DW RFROM
          DW BRAN
L2000     DW $FFC6
L2001     DW RFROM
          DW SEMIS
L2007     NAME $86,'NUMBER'
          DW L1968
NUMBER    DW DOCOL
          DW ZERO
          DW ZERO
          DW ROT
          DW DUP
          DW ONEP
          DW CAT
          DW CLIT
          DFB $2D
          DW EQUAL
          DW DUP
          DW TOR
          DW PLUS
          DW LIT,$FFFF
L2023     DW DPL
          DW STORE
          DW PNUMB
          DW DUP
          DW CAT
          DW BL
          DW SUB
          DW ZBRAN
L2031     DW $15
          DW DUP
          DW CAT
          DW CLIT
          DFB $2E
          DW SUB
          DW ZERO
          DW QERR
          DW ZERO
          DW BRAN
L2041     DW $FFDD
L2042     DW DROP
          DW RFROM
          DW ZBRAN
L2045     DW 4
          DW DMINU
L2047     DW SEMIS
L2052     NAME $85,'-FIND'
          DW L2007
DFIND     DW DOCOL
          DW BL
          DW WORD
          DW HERE
          DW COUNT
          DW UPPER
          DW HERE
          DW CON
          DW AT
          DW AT
          DW PFIND
          DW DUP
          DW ZEQU
          DW ZBRAN
L2068     DW $A
          DW DROP
          DW HERE
          DW LATES
          DW PFIND
L2073     DW SEMIS
L2078     NAME $87,'(ABORT)'
          DW L2052
PABOR     DW DOCOL
          DW ABORT
          DW SEMIS
L2087     NAME $85,'ERROR'
          DW L2078
ERROR     DW DOCOL
          DW WARN
          DW AT
          DW ZLESS
          DW ZBRAN
          DW L2096-*
          DW PABOR
L2096     DW HERE
          DW COUNT
          DW TYPE
          DW PDOTQ
          STR ' ? '
          DW MESS
          DW SPSTO
          DW DROP,DROP
          DW IN
          DW AT
          DW BLK
          DW AT
          DW QUIT
          DW SEMIS
L2113     NAME $83,'ID.'
          DW L2087
IDDOT     DW DOCOL
          DW PAD
          DW CLIT
          DFB $20
          DW CLIT
          DFB $5F
          DW FILL
          DW DUP
          DW PFA
          DW LFA
          DW OVER
          DW SUB
          DW PAD
          DW SWAP
          DW CMOVE
          DW PAD
          DW COUNT
          DW CLIT
          DFB $1F
          DW ANDD
          DW TYPE
          DW SPACE
          DW SEMIS
L2142     NAME $86,'CREATE'
          DW L2113
CREAT     DW DOCOL
          DW LIT,$A800
          DW HERE
          DW ULESS
          DW TWO
          DW QERR
          DW DFIND
          DW ZBRAN
L2155     DW $0F
          DW DROP
          DW NFA
          DW IDDOT
          DW CLIT
          DFB 4
          DW MESS
          DW SPACE
L2163     DW HERE
          DW DUP
          DW CAT
          DW WIDTH
          DW AT
          DW MIN
          DW ONEP
          DW ALLOT
          DW DP
          DW CAT
          DW CLIT
          DFB $FD
          DW EQUAL
          DW ALLOT
          DW DUP
          DW CLIT
          DFB $A0
          DW TOGGL
          DW HERE
          DW ONE
          DW SUB
          DW CLIT
          DFB $80
          DW TOGGL
          DW LATES
          DW COMMA
          DW CURR
          DW AT
          DW STORE
          DW HERE
          DW TWOP
          DW COMMA
          DW SEMIS
L2200     NAME $C9,'[COMPILE]'
          DW L2142
          DW DOCOL
          DW DFIND
          DW ZEQU
          DW ZERO
          DW QERR
          DW DROP
          DW CFA
          DW COMMA
          DW SEMIS
L2216     NAME $C7,'LITERAL'
          DW L2200
LITER     DW DOCOL
          DW STATE
          DW AT
          DW ZBRAN
L2222     DW 8
          DW COMP
          DW LIT
          DW COMMA
L2226     DW SEMIS
L2232     NAME $C8,'DLITERAL'
          DW L2216
DLIT      DW DOCOL
          DW STATE
          DW AT
          DW ZBRAN
L2238     DW 8
          DW SWAP
          DW LITER
          DW LITER
L2242     DW SEMIS
L2248     NAME $86,'?STACK'
          DW L2232
QSTAC     DW DOCOL
          DW CLIT
          DFB TOS-2
          DW SPAT
          DW ULESS
          DW ONE
          DW QERR
          DW SPAT
          DW CLIT
          DFB BOS
          DW ULESS
          DW CLIT
          DFB 7
          DW QERR
          DW SEMIS
L2269     NAME $89,'INTERPRET'
          DW L2248
INTER     DW DOCOL
L2272     DW DFIND
          DW ZBRAN
L2274     DW $1E
          DW STATE
          DW AT
          DW LESS
          DW ZBRAN
L2279     DW $A
          DW CFA
          DW COMMA
          DW BRAN
L2283     DW $6
L2284     DW CFA
          DW EXEC
L2286     DW QSTAC
          DW BRAN
L2288     DW $1C
L2289     DW HERE
          DW NUMBER
          DW DPL
          DW AT
          DW ONEP
          DW ZBRAN
L2295     DW 8
          DW DLIT
          DW BRAN
L2298     DW $6
L2299     DW DROP
          DW LITER
L2301     DW QSTAC
L2302     DW BRAN
L2303     DW $FFC2
L2309     NAME $89,'IMMEDIATE'
          DW L2269
          DW DOCOL
          DW LATES
          DW CLIT
          DFB $40
          DW TOGGL
          DW SEMIS
L2321     NAME $8A,'VOCABULARY'
          DW L2309
          DW DOCOL
          DW BUILD
          DW LIT,$A081
          DW COMMA
          DW CURR
          DW AT
          DW CFA
          DW COMMA
          DW HERE
          DW VOCL
          DW AT
          DW COMMA
          DW VOCL
          DW STORE
          DW DOES
DOVOC     DW TWOP
          DW CON
          DW STORE
          DW SEMIS
L2346     NAME $C5,'FORTH'
          DW L2321
FORTH     DW DODOE
          DW DOVOC
          DW $A081
XFOR      DW NTOP
VLO       DW 0
L2357     NAME $8B,'DEFINITIONS'
          DW L2346
DEFIN     DW DOCOL
          DW CON
          DW AT
          DW CURR
          DW STORE
          DW SEMIS
L2369     NAME $C1,'('
          DW L2357
          DW DOCOL
          DW CLIT
          DFB $29
          DW WORD
          DW SEMIS
L2381     NAME $84,'QUIT'
          DW L2369
QUIT      DW DOCOL
          DW ZERO
          DW BLK
          DW STORE
          DW LBRAC
L2388     DW RPSTO
          DW CR
          DW QUERY
          DW INTER
          DW STATE
          DW AT
          DW ZEQU
          DW ZBRAN
          DW L2399-*
          DW PDOTQ
          STR 'OK'
L2399     DW BRAN
          DW L2388-*
          DW SEMIS
L2406     NAME $85,'ABORT'
          DW L2381
ABORT     DW DOCOL
ABORT1    DW SPSTO
          DW DECIM
          DW DR0
          DW CR
          DW PDOTQ
          STR 'APPLE-DAYTON ProFORTH V3.2'
          DW CR
          DW FORTH
          DW DEFIN
          DW QUIT
L2423     NAME $84,'COLD'
          DW L2406
COLD      DW *+2
          LDA #>WARM
          STA $3F9
          LDA #<WARM
          STA $3FA
          LDA #>RESET
          STA $3F2
          LDA #<RESET
          STA $3F3
          EOR #$A5
          STA $3F4
          LDA #$4C
          STA $3EA
          LDA #>MYHOOK
          STA $3EB
          LDA #<MYHOOK
          STA $3EC
          LDA ORIG+$0C
          STA FORTH+6
          LDA ORIG+$0D
          STA FORTH+7
          LDY #$15
          BNE L2433
WARM      LDY #$0F
L2433     LDA ORIG+$10
          STA UP
          LDA ORIG+$11
          STA UP+1
L2437     LDA ORIG+$0C,Y
          STA (UP),Y
          DEY
          BPL L2437
          LDA #$80 NULL prompt if
          STA $33 backspace to far
          JSR MYHOOK
          LDA #<ABORT1
          STA IP+1
          LDA #>ABORT1
          STA IP
          CLD
          LDA #$6C
          STA W-1
          JMP RPSTO+2
RESET     LDA $BF98
          AND #2
          BEQ RESET1
          JSR $C300
RESET1    JMP WARM
MYKEY     JSR $FF58
          CMP #$FF
          BNE MYKEY1
          LDA #$88 DEL=^H
MYKEY1    RTS
MYHOOK    LDA KSWL+1
          CMP #<MYKEY
          BEQ HOOKED
          STA MYKEY+2
          LDA KSWL
          STA MYKEY+1
          LDA #>MYKEY
          STA KSWL
          LDA #<MYKEY
          STA KSWL+1
HOOKED    RTS
L2453     NAME $84,'S->D'
          DW L2423
STOD      DW DOCOL
          DW DUP
          DW ZLESS
          DW MINUS
          DW SEMIS
L2464     NAME $82,'+-'
          DW L2453
PM        DW DOCOL
          DW ZLESS
          DW ZBRAN
L2469     DW 4
          DW MINUS
L2471     DW SEMIS
L2476     NAME $83,'D+-'
          DW L2464
DPM       DW DOCOL
          DW ZLESS
          DW ZBRAN
L2481     DW 4
          DW DMINU
L2483     DW SEMIS
L2488     NAME $83,'ABS'
          DW L2476
ABS       DW DOCOL
          DW DUP
          DW PM
          DW SEMIS
L2498     NAME $84,'DABS'
          DW L2488
DABS      DW DOCOL
          DW DUP
          DW DPM
          DW SEMIS
L2508     NAME $83,'MIN'
          DW L2498
MIN       DW DOCOL
          DW OVER
          DW OVER
          DW GREAT
          DW ZBRAN
L2515     DW 4
          DW SWAP
L2517     DW DROP
          DW SEMIS
L2523     NAME $83,'MAX'
          DW L2508
MAX       DW DOCOL
          DW OVER
          DW OVER
          DW LESS
          DW ZBRAN
L2530     DW 4
          DW SWAP
L2532     DW DROP
          DW SEMIS
L2538     NAME $82,'M*'
          DW L2523
MSTAR     DW DOCOL
          DW OVER
          DW OVER
          DW XOR
          DW TOR
          DW ABS
          DW SWAP
          DW ABS
          DW USTAR
          DW RFROM
          DW DPM
          DW SEMIS
L2556     NAME $82,'M/'
          DW L2538
MSLAS     DW DOCOL
          DW OVER
          DW TOR
          DW TOR
          DW DABS
          DW R
          DW ABS
          DW USLAS
          DW RFROM
          DW R
          DW XOR
          DW PM
          DW SWAP
          DW RFROM
          DW PM
          DW SWAP
          DW SEMIS
L2579     NAME $81,'*'
          DW L2556
STAR      DW DOCOL
          DW USTAR
          DW DROP
          DW SEMIS
L2589     NAME $84,'/MOD'
          DW L2579
SLMOD     DW DOCOL
          DW TOR
          DW STOD
          DW RFROM
          DW MSLAS
          DW SEMIS
L2601     NAME $81,'/'
          DW L2589
SLASH     DW DOCOL
          DW SLMOD
          DW SWAP
          DW DROP
          DW SEMIS
L2612     NAME $83,'MOD'
          DW L2601
MOD       DW DOCOL
          DW SLMOD
          DW DROP
          DW SEMIS
L2622     NAME $85,'*/MOD'
          DW L2612
SSMOD     DW DOCOL
          DW TOR
          DW MSTAR
          DW RFROM
          DW MSLAS
          DW SEMIS
L2634     NAME $82,'*/'
          DW L2622
SSLAS     DW DOCOL
          DW SSMOD
          DW SWAP
          DW DROP
          DW SEMIS
L2645     NAME $85,'M/MOD'
          DW L2634
MSMOD     DW DOCOL
          DW TOR
          DW ZERO
          DW R
          DW USLAS
          DW RFROM
          DW SWAP
          DW TOR
          DW USLAS
          DW RFROM
          DW SEMIS
L2662     NAME $83,'USE'
          DW L2645
USE       DW DOVAR
          DW DAREA
L2670     NAME $84,'PREV'
          DW L2662
PREV      DW DOVAR
          DW DAREA
L2678     NAME $84,'+BUF'
          DW L2670
PBUF      DW DOCOL
          DW LIT
          DW SSIZE+4
          DW PLUS
          DW DUP
          DW LIMIT
          DW EQUAL
          DW ZBRAN
L2688     DW 6
          DW DROP
          DW FIRST
L2691     DW DUP
          DW PREV
          DW AT
          DW SUB
          DW SEMIS
L2700     NAME $86,'UPDATE'
          DW L2678
UPDAT     DW DOCOL
          DW PREV
          DW AT
          DW AT
          DW LIT,$8000
          DW OR
          DW PREV
          DW AT
          DW STORE
          DW SEMIS
L2705     NAME $85,'FLUSH'
          DW L2700
          DW DOCOL
          DW LIT,NBUF+1
          DW ZERO,PDO
L2835     DW LIT,$7FFF,BUFFR
          DW DROP,PLOOP,L2835-*
          DW SEMIS
L2716     NAME $8D,'EMPTY-BUFFERS'
          DW L2705
          DW DOCOL
          DW FIRST
          DW LIMIT
          DW OVER
          DW SUB
          DW ERASE
          DW SEMIS
L2729     NAME $83,'DR0'
          DW L2716
DR0       DW DOCOL
          DW LIT,0,OFSET,STORE
          DW SEMIS
L2740     NAME $83,'DR1'
          DW L2729
DR1       DW DOCOL
          DW FSIZE,OFSET,STORE
          DW SEMIS
L2751     NAME $86,'BUFFER'
          DW L2740
BUFFR     DW DOCOL
          DW USE
          DW AT
          DW DUP
          DW TOR
L2758     DW PBUF
          DW ZBRAN
L2760     DW $FFFC
          DW USE
          DW STORE
          DW R
          DW AT
          DW ZLESS
          DW ZBRAN
L2767     DW $14
          DW R
          DW TWOP
          DW R
          DW AT
          DW LIT,$7FFF
          DW ANDD
          DW ZERO
          DW RSLW
L2776     DW R
          DW STORE
          DW R
          DW PREV
          DW STORE
          DW RFROM
          DW TWOP
          DW SEMIS
L2788     NAME $85,'BLOCK'
          DW L2751
BLOCK     DW DOCOL
          DW OFSET
          DW AT
          DW PLUS
          DW TOR
          DW PREV
          DW AT
          DW DUP
          DW AT
          DW R
          DW SUB
          DW DUP
          DW PLUS
          DW ZBRAN
L2804     DW $34
L2805     DW PBUF
          DW ZEQU
          DW ZBRAN
L2808     DW $14
          DW DROP
          DW R
          DW BUFFR
          DW DUP
          DW R
          DW ONE
          DW RSLW
          DW TWO
          DW SUB
L2818     DW DUP
          DW AT
          DW R
          DW SUB
          DW DUP
          DW PLUS
          DW ZEQU
          DW ZBRAN
L2826     DW $FFD6
          DW DUP
          DW PREV
          DW STORE
L2830     DW RFROM
          DW DROP
          DW TWOP
          DW SEMIS
L2838     NAME $86,'(LINE)'
          DW L2788
PLINE     DW DOCOL
          DW TOR
          DW CSLL
          DW BBUF
          DW SSMOD
          DW RFROM
          DW BSCR
          DW STAR
          DW PLUS
          DW BLOCK
          DW PLUS
          DW CSLL
          DW SEMIS
L2857     NAME $85,'.LINE'
          DW L2838
DLINE     DW DOCOL
          DW PLINE
          DW DTRAI
          DW TYPE
          DW SEMIS
L2868     NAME $87,'MESSAGE'
          DW L2857
MESS      DW DOCOL
          DW WARN
          DW AT
          DW ZBRAN
          DW L2888-*
          DW CLIT
          DFB 4
          DW OFSET
          DW AT
          DW BSCR
          DW SLASH
          DW SUB
          DW DLINE
          DW BRAN
          DW L2891-*
L2888     DW PDOTQ
          STR 'MSG #'
          DW DOT
L2891     DW SEMIS
L2896     NAME $84,'LOAD'
          DW L2868
LOAD      DW DOCOL
          DW BLK
          DW AT
          DW TOR
          DW IN
          DW AT
          DW TOR
          DW ZERO
          DW IN
          DW STORE
          DW BSCR
          DW STAR
          DW BLK
          DW STORE
          DW INTER
          DW RFROM
          DW IN
          DW STORE
          DW RFROM
          DW BLK
          DW STORE
          DW SEMIS
L2924     NAME $C3,'-->'
          DW L2896
          DW DOCOL
          DW QLOAD
          DW ZERO
          DW IN
          DW STORE
          DW BSCR
          DW BLK
          DW AT
          DW OVER
          DW MOD
          DW SUB
          DW BLK
          DW PSTOR
          DW SEMIS
XEMIT     INC UAREA+$1A
          BNE XEMIT1
          INC UAREA+$1B
XEMIT1    LDA 0,X
          STX XSAVE
          ORA #$80
          JSR OUTCH
          LDX XSAVE
          JMP POP
XKEY      STX XSAVE
          JSR INCH
          AND #$7F
          LDX XSAVE
          JMP PUSHOA
XQTER     BIT $C000
          BPL XQTER2
XQTER1    BIT $C010
          BIT $C000
          BMI XQTER1
          INY
XQTER2    TYA
          JMP PUSHOA
XCR       STX XSAVE
          JSR CROUT
          LDX XSAVE
          JMP NEXT
L3050     NAME $85,'(R/W)'
          DW L2924
PRSLW     DW *+2
          LDA 0,X
          STA SETREF
          STA RWREF
          LDA #$CA
          STA RWCOM
          LDA 2,X
          BNE PRSLW1
          LDA #$CB
          STA RWCOM
PRSLW1    LDA 6,X
          STA RWBUF
          LDA 7,X
          STA RWBUF+1
          LDA 4,X
          ASL A
          STA SETPOS+1
          LDA 5,X
          ROL A
          STA SETPOS+2
          ASL SETPOS+1
          ROL SETPOS+2
          JSR MLI
          DB $CE Set file position
          DW SETLIST
          BCS PRSLW2
          JSR MLI
RWCOM     DB 0 Read/write command
          DW RWLIST
PRSLW2    PHA
          TXA
          CLC
          ADC #6
          TAX
          TYA
          JMP PUT
SETLIST   DB 2
SETREF    DB 0
SETPOS    DB 0,0,0
RWLIST    DB 4
RWREF     DB 0
RWBUF     DW 0
RWLEN     DW 1024,0
FCLIST    DB 1,0
BLIST     DFB 4,0,0,0,0,0,0
L3060     NAME $83,'R/W'
          DW L3050
RSLW      DW DOCOL,TOR,DUP,FSIZE,ULESS
          DW ZBRAN,RSLW1-*
          DW ONE,BRAN,RSLW2-*
RSLW1     DW FSIZE,SUB,TWO
RSLW2     DW RFROM,SWAP,PRSLW
          DW DDUP,ZBRAN,RSLW3-*
          DW DOT,LIT,8,ERROR
RSLW3     DW SEMIS
L3202     NAME $C1,"'"
          DW L3060
TICK      DW DOCOL
          DW DFIND
          DW ZEQU
          DW ZERO
          DW QERR
          DW DROP
          DW LITER
          DW SEMIS
L3217     NAME $86,'FORGET'
          DW L3202
FORG      DW DOCOL
          DW TICK,NFA,DUP
          DW FENCE,AT,ULESS,CLIT
          DFB $15
          DW QERR,TOR,VOCL,AT
L3220     DW R,OVER,ULESS
          DW ZBRAN,L3225-*
          DW FORTH,DEFIN,AT,DUP
          DW VOCL,STORE
          DW BRAN,$FFFF-24+1  ;L3220-*
L3225     DW DUP,CLIT
          DFB 4
          DW SUB
L3228     DW PFA,LFA,AT
          DW DUP,R,ULESS
          DW ZBRAN,$FFFF-14+1 ;L3228-*
          DW OVER,TWO,SUB,STORE
          DW AT,DDUP,ZEQU
          DW ZBRAN,$FFFF-39+1 ;L3225-*
          DW RFROM,DP,STORE
          DW SEMIS
L3250     NAME $84,'BACK'
          DW L3217
BACK      DW DOCOL
          DW HERE
          DW SUB
          DW COMMA
          DW SEMIS
L3261     NAME $C5,'BEGIN'
          DW L3250
          DW DOCOL
          DW QCOMP
          DW HERE
          DW ONE
          DW SEMIS
L3273     NAME $C5,'ENDIF'
          DW L3261
ENDIF     DW DOCOL
          DW QCOMP
          DW TWO
          DW QPAIR
          DW HERE
          DW OVER
          DW SUB
          DW SWAP
          DW STORE
          DW SEMIS
L3290     NAME $C4,'THEN'
          DW L3273
          DW DOCOL
          DW ENDIF
          DW SEMIS
L3300     NAME $C2,'DO'
          DW L3290
          DW DOCOL
          DW COMP
          DW PDO
          DW HERE
          DW THREE
          DW SEMIS
L3313     NAME $C4,'LOOP'
          DW L3300
          DW DOCOL
          DW THREE
          DW QPAIR
          DW COMP
          DW PLOOP
          DW BACK
          DW SEMIS
          DW SEMIS
L3327     NAME $C5,'+LOOP'
          DW L3313
          DW DOCOL
          DW THREE
          DW QPAIR
          DW COMP
          DW PPLOO
          DW BACK
          DW SEMIS
L3341     NAME $C5,'UNTIL'
          DW L3327
UNTIL     DW DOCOL
          DW ONE
          DW QPAIR
          DW COMP
          DW ZBRAN
          DW BACK
          DW SEMIS
L3355     NAME $C3,'END'
          DW L3341
          DW DOCOL
          DW UNTIL
          DW SEMIS
L3365     NAME $C5,'AGAIN'
          DW L3355
AGAIN     DW DOCOL
          DW ONE
          DW QPAIR
          DW COMP
          DW BRAN
          DW BACK
          DW SEMIS
L3379     NAME $C6,'REPEAT'
          DW L3365
          DW DOCOL
          DW TOR
          DW TOR
          DW AGAIN
          DW RFROM
          DW RFROM
          DW TWO
          DW SUB
          DW ENDIF
          DW SEMIS
L3396     NAME $C2,'IF'
          DW L3379
IF        DW DOCOL
          DW COMP
          DW ZBRAN
          DW HERE
          DW ZERO
          DW COMMA
          DW TWO
          DW SEMIS
L3411     NAME $C4,'ELSE'
          DW L3396
          DW DOCOL
          DW TWO
          DW QPAIR
          DW COMP
          DW BRAN
          DW HERE
          DW ZERO
          DW COMMA
          DW SWAP
          DW TWO
          DW ENDIF
          DW TWO
          DW SEMIS
L3431     NAME $C5,'WHILE'
          DW L3411
          DW DOCOL
          DW IF
          DW TWOP
          DW SEMIS
L3442     NAME $86,'SPACES'
          DW L3431
SPACS     DW DOCOL
          DW ZERO
          DW MAX
          DW DDUP
          DW ZBRAN
L3449     DW $0C
          DW ZERO
          DW PDO
L3452     DW SPACE
          DW PLOOP
L3454     DW $FFFC
L3455     DW SEMIS
L3460     NAME $82,'<#'
          DW L3442
BDIGS     DW DOCOL
          DW PAD
          DW HLD
          DW STORE
          DW SEMIS
L3471     NAME $82,'#>'
          DW L3460
EDIGS     DW DOCOL
          DW DROP
          DW DROP
          DW HLD
          DW AT
          DW PAD
          DW OVER
          DW SUB
          DW SEMIS
L3486     NAME $84,'SIGN'
          DW L3471
SIGN      DW DOCOL
          DW ROT
          DW ZLESS
          DW ZBRAN
L3492     DW $7
          DW CLIT
          DFB $2D
          DW HOLD
L3496     DW SEMIS
L3501     DFB $81,$A3
          DW L3486
DIG       DW DOCOL
          DW BASE
          DW AT
          DW MSMOD
          DW ROT
          DW CLIT
          DFB 9
          DW OVER
          DW LESS
          DW ZBRAN
L3513     DW 7
          DW CLIT
          DFB 7
          DW PLUS
L3517     DW CLIT
          DFB $30
          DW PLUS
          DW HOLD
          DW SEMIS
L3526     NAME $82,'#S'
          DW L3501
DIGS      DW DOCOL
L3529     DW DIG
          DW OVER
          DW OVER
          DW OR
          DW ZEQU
          DW ZBRAN
L3535     DW $FFF4
          DW SEMIS
L3541     NAME $83,'D.R'
          DW L3526
DDOTR     DW DOCOL
          DW TOR
          DW SWAP
          DW OVER
          DW DABS
          DW BDIGS
          DW DIGS
          DW SIGN
          DW EDIGS
          DW RFROM
          DW OVER
          DW SUB
          DW SPACS
          DW TYPE
          DW SEMIS
L3562     NAME $82,'D.'
          DW L3541
DDOT      DW DOCOL
          DW ZERO
          DW DDOTR
          DW SPACE
          DW SEMIS
L3573     NAME $82,'.R'
          DW L3562
DOTR      DW DOCOL
          DW TOR
          DW STOD
          DW RFROM
          DW DDOTR
          DW SEMIS
L3585     DFB $81,$AE
          DW L3573
DOT       DW DOCOL
          DW STOD
          DW DDOT
          DW SEMIS
L3595     NAME $81,'?'
          DW L3585
QUES      DW DOCOL
          DW AT
          DW DOT
          DW SEMIS
L3605     NAME $84,'LIST'
          DW L3595
LIST      DW DOCOL
          DW DECIM
          DW CR
          DW DUP
          DW SCR
          DW STORE
          DW PDOTQ
          DFB 6
          ASC 'Scr # '
          DW DOT
          DW CLIT
          DFB 16
          DW ZERO
          DW PDO
L3620     DW CR
          DW I
          DW THREE
          DW DOTR
          DW SPACE
          DW I
          DW SCR
          DW AT
          DW DLINE
          DW PLOOP
L3630     DW $FFEC
          DW CR
          DW SEMIS
L3637     NAME $85,'INDEX'
          DW L3605
          DW DOCOL
          DW CR
          DW ONEP
          DW SWAP
          DW PDO
L3647     DW CR
          DW I
          DW THREE
          DW DOTR
          DW SPACE
          DW ZERO
          DW I
          DW DLINE
          DW QTERM
          DW ZBRAN
L3657     DW 4
          DW LEAVE
L3659     DW PLOOP
L3660     DW $FFE6
          DW CLIT
          DFB $0D
          DW EMIT
          DW SEMIS
L3666     NAME $85,'TRIAD'
          DW L3637
          DW DOCOL
          DW THREE
          DW SLASH
          DW THREE
          DW STAR
          DW THREE
          DW OVER
          DW PLUS
          DW SWAP
          DW PDO
L3681     DW CR
          DW I
          DW LIST
          DW PLOOP
L3685     DW $FFF8
          DW CR
          DW CLIT
          DFB $F
          DW MESS
          DW CR
          DW CLIT
          DFB $0D
          DW EMIT
          DW SEMIS
L3696     NAME $85,'VLIST'
          DW L3666
VLIST     DW DOCOL
          DW CLIT
          DFB $80
          DW OUT
          DW STORE
          DW CON
          DW AT
          DW AT
L3706     DW OUT
          DW AT
          DW CSLL
          DW GREAT
          DW ZBRAN
          DW L3716-*
          DW CR
          DW ZERO
          DW OUT
          DW STORE
L3716     DW DUP
          DW IDDOT
          DW SPACE
          DW SPACE
          DW PFA
          DW LFA
          DW AT
          DW DUP
          DW ZEQU
          DW QTERM
          DW OR
          DW ZBRAN
          DW L3706-*
          DW DROP
          DW SEMIS
NMON      NAME $83,'MON'
          DW L3696
MON       DW *+2
          JMP MONITOR
NMLI      NAME $83,'MLI'
          DW NMON
DOMLI     DW *+2
          LDA 0,X
          STA MLICOM
          LDA 2,X
          STA MLICOM+1
          LDA 3,X
          STA MLICOM+2
          JSR MLI
MLICOM    DFB 0,0,0
          INX
          INX
          PHA
          TYA
          JMP PUT
NCALL     NAME $84,'CALL'
          DW NMLI
CALL      DW *+2
          STX XSAVE
          LDA 0,X
          STA CALL1+1
          LDA 1,X
          STA CALL1+2
          LDA 0
          LDX 1
          LDY 2
CALL1     JSR 0
          STY 2
          STX 1
          STA 0
          LDX XSAVE
          JMP POP
NTOP      NAME $83,'BYE'
          DW NCALL
BYE       DW *+2
          JSR MLI
          DB $CC
          DW FCLIST
          JSR MLI
          DFB $65
          DW BLIST
TOP       DFB 00

fsys.s (ProDos Filesystem interface)

          LST ON,NOGen,NOAsym,NOVsym
* FORTH.SYSTEM by John Matthews, M.D.
A1        EQU $3C
A2        EQU $3E
A4        EQU $42
FSTART    EQU $800 Forth dictionary entry
FBUF1     EQU $B200
MLI       EQU $BF00 Call MLI
BITMAP    EQU $BF58 ProDOS memory bit map
FLEVEL    EQU $BF94
MACHID    EQU $BF98
CLR80COL  EQU $C000 Hardware switches
CLR80VID  EQU $C00C
SETALTCH  EQU $C00F
ROMON     EQU $C082
HOME      EQU $FC58 Monitor routines
GETKEY    EQU $FD0C
CROUT     EQU $FD8E
PRBYTE    EQU $FDDA
COUT      EQU $FDED
MOVE      EQU $FE2C
SETKBD    EQU $FE89
SETVID    EQU $FE93
          SYS
          ORG $2000
          LDX #$FF
          TXS
          LDA #0
          STA A1
          STA A2
          STA A4
          LDA #$21
          STA A1+1
          LDA #$24
          STA A2+1
          LDA #<FSYS
          STA A4+1
          LDY #0
          JSR MOVE
          LDA #>FSYS
          STA $3F2
          LDA #<FSYS
          STA $3F3
          EOR #$A5
          STA $3F4
          JMP FSYS
          ORG $A000
* Initialize normal keyboard & 40 columns
FSYS      LDA ROMON Enable the ROMs!
          JSR SETVID
          JSR SETKBD
          STA CLR80VID
          STA SETALTCH
          STA CLR80COL
          LDA MACHID
          AND #2
          BEQ NO80COL
          JSR $C300
NO80COL   JSR HOME
          JSR SCREEN
* Initialize the ProDOS bit map
          LDX #$17
          LDA #1 Global page ($BF00) in use
          STA BITMAP,X
          DEX
          LDA #0 Free all other pages
          STA FLEVEL File level = 0
CLRBITS   STA BITMAP,X
          DEX
          BPL CLRBITS
          LDA #$CF Zero page, stack and text
          STA BITMAP  page 1 in use
* Clear the future user area & buffers
          LDA #$B2
          STA A1+1
          LDY #0
          STY A1
CLRBUF1   TYA
CLRBUF2   STA (A1),Y
          INY
          BNE CLRBUF2
          INC A1+1
          LDA A1+1
          CMP #$BF
          BNE CLRBUF1
* Close any open files
          JSR MLI
          DB $CC CLOSE command
          DW CLOSLIST
          BCS ERROR
* Get the prefix
          JSR MLI
          DB $C7 GET PREFIX command
          DW PREFLIST
          BCS ERROR
          LDA PREFIX
          BEQ ERROR Null prefix is death
* Open F.DICT file
          LDA #>FNAME1
          STA ONAME
          LDA #<FNAME1
          STA ONAME+1
          JSR MLI
          DB $C8 OPEN command
          DW OPENLIST
          BCS ERROR
* Get end of file mark
          LDA REFNO Use the REFNO supplied
          STA EREF  by the call to OPEN
          JSR MLI
          DB $D1 GET EOF command
          DW EOFLIST
          BCS ERROR
* Read the file
          LDA REFNO Use the REFNO again
          STA RREF
          LDA EPOS Use the length supplied
          STA RLENGTH  by the call to GET EOF
          LDA EPOS+1
          STA RLENGTH+1
          JSR MLI
          DB $CA READ command
          DW READLIST
          BCS ERROR
* Close F.DICT
          JSR MLI
          DB $CC CLOSE command
          DW CLOSLIST
          BCS ERROR
* Open F.DISK
          LDA #>FNAME2
          STA ONAME
          LDA #<FNAME2
          STA ONAME+1
          JSR MLI
          DB $C8 OPEN command
          DW OPENLIST
          BCS ERROR
          JMP FSTART
* Handle fatal error
ERROR     PHA A Save the error code
          JSR CROUT Print RETURN
          LDY ERRMSG Print error message
          LDX #1
ERR1      LDA ERRMSG,X
          ORA #$80
          JSR COUT
          INX
          DEY
          BNE ERR1
          PLA A Restore error code
          JSR PRBYTE Print it
          JSR GETKEY Wait for it
          JSR MLI Die horribly
          DB $65 QUIT command
          DW QLIST
* Standard print routine
PRINT1    LDY #0
          PLA
          STA A1
          PLA
          STA A1+1
PRINT2    INC A1
          BNE PRINT3
          INC A1+1
PRINT3    LDA (A1),Y
          BEQ PRINT4
          ORA #$80
          JSR COUT
          JMP PRINT2
PRINT4    INC A1
          BNE PRINT5
          INC A1+1
PRINT5    JMP (A1)
* Print the credits
SCREEN    JSR PRINT1
          DB 13,13
          ASC "*** PRO-FORTH V3.2 ***"
          DB 13,13,13
          ASC "PRESENTED BY APPLE-DAYTON, INC."
          DB 13,13
          ASC "PO BOX 1666 FAIRBORN OH 45324-7666"
          DB 13,13,13
          ASC "COURTESY OF THE FORTH INTEREST GROUP"
          DB 13,13
          ASC "PO BOX 1105 SAN CARLOS CA 94070"
          DB 13,13,13
          ASC "ADAPTED FOR PRODOS BY JOHN B. MATTHEWS"
          DB 13,13,13
          DB 0
          RTS
* "Prefix" parameter list
PREFLIST  DB 1 Parameter count
          DW PREFIX Pathname pointer
* "Open" parameter list
OPENLIST  DB 3 Parameter count
ONAME     DW FNAME1 File name pointer
          DW FBUF1 File #1 buffer addr.
REFNO     DB 0 Reference number
* "End of File" parameter list
EOFLIST   DB 2 Parameter count
EREF      DB 0 Reference number
EPOS      DB 0,0,0 File position
* "Read" parameter list
READLIST  DB 4 Parameter count
RREF      DB 0 Reference number
RDATA     DW FSTART Data buffer addr.
RLENGTH   DW 0 Requested length
          DW 0 Actual length
* "Close" parameter list
CLOSLIST  DB 1 Parameter count
CREF      DB 0 0 closes all open files
* "Quit aprameter list
QLIST     DFB 4,0,0,0,0,0,0
* String storage
ERRMSG    STR "PRODOS ERROR: $"
FNAME1    STR "F.DICT"
FNAME2    STR "F.DISK"
PREFIX    DS 64,0