1000 ;
1010 ; Through the courtesy of
1020 ;
1030 ; FORTH INTEREST GROUP
1040 ; P. O. Box 1105
1050 ; San Carlos, CA  94070
1060 ;
1070 ; Release 1
1080 ; With compiler security and
1090 ; variable length names
1100 ;
1110 ; Equates giving memory assignments,
1120 ; machine registers and disk parameters
1130 ;
1140 SSIZE =512 sector size in bytes
1150 NBUF =8 number of buffers desired in RAM
1160 ;               (SSIZE*NBUF>=1024)
1170 SECTR =100 sectors per drive
1180 SECTL =200 sector limit for 2 drives
1190 BMAG =SSIZE+4*NBUF 1056 total buffer magnitude, in bytes
1210 ;
1220 BOS =$84 bottom of data stack, in Z-page
1230 TOS =$BA top of data stack, in Z-page
1240 N =TOS+8 xXxxxxxxx scratch workspace
1250 IP =N+8 Xx interpretive pointer
1260 W =IP+3 xXx code field pointer
1270 UP =W+2 Xx user area pointer
1280 XSAVE =UP+2 X temporary for X-register
1290 ;
1300 TIBX =$0100 terminal input buffer of 84 bytes
1340 DAREA =$2800 disk buffer area
1341  *=DAREA+BMAG
1342 UAREA=* 128 bytes of user area
1343  *=*+128
1344 DCB0 .BYTE $10 iocb #
1345  .BYTE 0,0 open,eof
1346  .WORD 0 block #(0=closed)
1348  .BYTE "D:SYSTEM.4TH",$9B
1350  *=3*SECTR+23+DCB0
1352 DCB1 .BYTE $20
1353  .BYTE 0,0
1354  .WORD 0
1356  .BYTE "D:DR1",$9B
1358 ORIG =3*SECTR+23+DCB1+$FF/$100*$100 origin of FORTH's dictonary
1460 ;
1470 ; Boot up parameters.
1480 ;
1482  *=$2E0 ; final RUN address
1484  .WORD ENTER ; cold entry
1490  *=ORIG
1500 ENTER NOP User cold entry point
1510  JMP COLD+2 vector to COLD entry
1520 REENTR NOP User warm entry point
1530  JMP WARM vector to WARM entry
1540  .WORD $0004,$5ED2 6502 encoded in radix-36
1550  .WORD NTOP Name address of MON
1560  .WORD $7E Backspace character
1570  .WORD UAREA Initial user area
1580  .WORD TOS Initial top of stack
1590  .WORD $1FF Initial top of return stack
1600  .WORD TIBX Initial terminal input buffer
1610  .WORD 31 Initial name field width
1620  .WORD 1 0=no disk,1=disk
1630  .WORD TOP Initial fence address
1640  .WORD TOP Initial top of dictionary
1650  .WORD VLO Initial vocabulary link pointer
1690 ;<>
1700 L22 .BYTE $83,"LIT" <--- name field
1710  .WORD 0 <--- link field (last is 0)
1720 LIT .WORD *+2 <--- code address field
1730  LDA (IP),Y <--- start of parameter field
1740  PHA
1750  INC IP
1760  BNE L30
1770  INC IP+1
1780 L30 LDA (IP),Y
1790 L31 INC IP
1800  BNE PUSH
1810  INC IP+1
1820 ;
1830 PUSH DEX
1840  DEX
1850 ;
1860 PUT STA 1,X
1870  PLA
1880  STA 0,X
1890 ;
1900 ; NEXT is the address interpreter that moves
1910 ; from machine level word to word.
1920 ;
1930 NEXT LDY #1
1940  LDA (IP),Y Fetch code field address pointed
1950  STA W+1 to by IP
1960  DEY
1970  LDA (IP),Y
1980  STA W
1981  CMP #$FF
1982  BEQ L32 branch to avoid JMP (xxFF)
1990 ;JSR TRACE Remove this when all is well
2000  CLC Increment IP by two
2010  LDA IP
2020  ADC #2
2030  STA IP
2040  BCC L54
2050  INC IP+1
2060 L54 JMP W-1 Jump to an indirect jump(W)
2061 ;L32 JSR TRACE avoid JMP (xxFF)
2062 L32 CLC
2063  LDA IP
2064  ADC #2
2065  STA IP
2066  BCC FIXW
2067  INC IP+1
2068 FIXW INY
2069  LDA (W),Y simulate JMP (xxFF)
2070  STA L34+2
2071  DEY
2072  LDA (W),Y
2073  STA L34+1
2074 L34 JMP W-1 **this instruction will be modified**
2079 ;
2080 ; CLIT pushes next inline byte to data stack
2090 ;
2100 L35 .BYTE $84,"CLIT"
2110  .WORD L22
2120 CLIT .WORD *+2
2130  LDA (IP),Y
2140  PHA
2150  TYA
2160  BEQ L31 forced branch into LIT
2170 ;
2180 ; Temporary trace routine.
2190 ;
2250 ;XW=$CC Scratch register to next code field address
2260 ;NP=$CE another scratch register pointer to name
2270 ;
2280 ;TRACE STX XSAVE
2290 ;JSR CRLF
2300 ;LDA IP+1
2310 ;JSR HEX2
2320 ;LDA IP
2330 ;JSR HEX2 Print IP
2340 ;JSR XBLANK
2350 ;
2360 ;LDY #0
2370 ;LDA (IP),Y
2380 ;STA XW
2390 ;STA NP Fetch next code field pointer
2400 ;INY
2410 ;LDA (IP),Y
2420 ;STA XW+1
2430 ;STA NP+1
2440 ;JSR PRNAM Print dictionary name
2450 ;
2460 ;LDA XW+1
2470 ;JSR HEX2 Print W
2480 ;LDA XW
2490 ;JSR HEX2
2500 ;JSR XBLANK
2510 ;
2520 ;LDA XSAVE Print SP
2530 ;JSR HEX2
2540 ;JSR XBLANK
2550 ;
2560 ;LDA #1 Print return stack bottom
2570 ;JSR HEX2
2580 ;TSX
2590 ;INX
2600 ;TXA
2610 ;JSR HEX2
2620 ;JSR XBLANK
2630 ;
2640 ;JSR ONEKEY Wait for operator keystroke
2650 ;LDX XSAVE
2660 ;LDY #0
2670 ;RTS
2680 ;
2690 ; TCOLON called from DOCOLON to label
2700 ; each point where FORTH nests one level
2710 ;
2720 ;TCOLON STX XSAVE
2730 ;LDA W
2740 ;STA NP Locate name of called word
2750 ;LDA W+1
2760 ;STA NP+1
2770 ;JSR CRLF
2780 ;LDA #':
2790 ;JSR LETTER
2800 ;JSR XBLANK
2810 ;JSR PRNAM
2820 ;LDX XSAVE
2830 ;RTS
2840 ;
2850 ; Print name by its code field address in NP
2860 ;
2870 ;PRNAM JSR DECNP
2880 ;JSR DECNP
2890 ;JSR DECNP
2900 ;LDY #0
2910 ;PN1 JSR DECNP
2920 ;LDA (NP),Y loop till D7 in name set
2930 ;BPL PN1
2940 ;PN2 INY
2950 ;LDA (NP),Y
2960 ;JSR LETTER print letters of name field
2970 ;LDA (NP),Y
2980 ;BPL PN2
2990 ;JSR XBLANK
3000 ;LDY #0
3010 ;RTS
3020 ;
3030 ; Decrement name field pointer
3040 ;
3050 ;DECNP LDA NP
3060 ;BNE DECNP1
3070 ;DEC NP+1
3080 ;DECNP1 DEC NP
3090 ;RTS
3100 ;
3110 ;
3120 SETUP ASL A
3130  STA N-1
3140 L63 LDA 0,X
3150  STA N,Y
3160  INX
3170  INY
3180  CPY N-1
3190  BNE L63
3200  LDY #0
3210  RTS
3220 ;<>
3230 L75 .BYTE $87,"EXECUTE"
3240  .WORD L35
3250 EXEC .WORD *+2
3260  LDA 0,X
3270  STA W
3280  LDA 1,X
3290  STA W+1
3300  INX
3310  INX
3320  JMP FIXW to JMP (W) in Z-page
3330 ;<>
3340 L89 .BYTE $86,"BRANCH"
3350  .WORD L75
3360 BRAN .WORD *+2
3370  CLC
3380  LDA (IP),Y
3390  ADC IP
3400  PHA
3410  INY
3420  LDA (IP),Y
3430  ADC IP+1
3440  STA IP+1
3450  PLA
3460  STA IP
3470  JMP NEXT+2
3480 ;<>
3490 L107 .BYTE $87,"0BRANCH"
3500  .WORD L89
3510 ZBRAN .WORD *+2
3520  INX
3530  INX
3540  LDA $FE,X
3550  ORA $FF,X
3560  BEQ BRAN+2
3570 ;
3580 BUMP CLC
3590  LDA IP
3600  ADC #2
3610  STA IP
3620  BCC L122
3630  INC IP+1
3640 L122 JMP NEXT
3650 ;<>
3660 L127 .BYTE $86,"(LOOP)"
3670  .WORD L107
3680 PLOOP .WORD L130
3690 L130 STX XSAVE
3700  TSX
3710  INC $101,X
3720  BNE PL1
3730  INC $102,X
3740 ;
3750 PL1 CLC
3760  LDA $103,X
3770  SBC $101,X
3780  LDA $104,X
3790  SBC $102,X
3800 ;
3810 PL2 LDX XSAVE
3820  ASL A
3830  BCC BRAN+2
3840  PLA
3850  PLA
3860  PLA
3870  PLA
3880  JMP BUMP
3890 ;<>
3900 L154 .BYTE $87,"(+LOOP)"
3910  .WORD L127
3920 PPLOO .WORD *+2
3930  INX
3940  INX
3950  STX XSAVE
3960  LDA $FF,X
3970  PHA
3980  PHA
3990  LDA $FE,X
4000  TSX
4010  INX
4020  INX
4030  CLC
4040  ADC $101,X
4050  STA $101,X
4060  PLA
4070  ADC $102,X
4080  STA $102,X
4090  PLA
4100  BPL PL1
4110  CLC
4120  LDA $101,X
4130  SBC $103,X
4140  LDA $102,X
4150  SBC $104,X
4160  JMP PL2
4170 ;<>
4180 L185 .BYTE $84,"(DO)"
4190  .WORD L154
4200 PDO .WORD *+2
4210  LDA 3,X
4220  PHA
4230  LDA 2,X
4240  PHA
4250  LDA 1,X
4260  PHA
4270  LDA 0,X
4280  PHA
4290 ;
4300 POPTWO INX
4310  INX
4320 ;
4330 POP INX
4340  INX
4350  JMP NEXT
4360 ;<>
4370 L207 .BYTE $81,"I"
4380  .WORD L185
4390 I .WORD R+2 share code for R
4400 ;<>
4410 L214 .BYTE $85,"DIGIT"
4430  .WORD L207
4440 DIGIT .WORD *+2
4450  SEC
4460  LDA 2,X
4470  SBC #$30
4480  BMI L234
4490  CMP #$A
4500  BMI L227
4510  SEC
4520  SBC #7
4530  CMP #$A
4540  BMI L234
4550 L227 CMP 0,X
4560  BPL L234
4570  STA 2,X
4580  LDA #1
4590  PHA
4600  TYA
4610  JMP PUT exit true with converted value
4620 L234 TYA
4630  PHA
4640  INX
4650  INX
4660  JMP PUT exit false with bad conversion
4670 ;<>
4680 L243 .BYTE $86,"(FIND)"
4690  .WORD L214
4700 PFIND .WORD *+2
4710  LDA #2
4720  JSR SETUP
4730  STX XSAVE
4740 L249 LDY #0
4750  LDA (N),Y
4760  EOR (N+2),Y
4770  AND #$3F
4780  BNE L281
4790 L254 INY
4800  LDA (N),Y
4810  EOR (N+2),Y
4820  ASL A
4830  BNE L280
4840  BCC L254
4850  LDX XSAVE
4860  DEX
4870  DEX
4880  DEX
4890  DEX
4900  CLC
4910  TYA
4920  ADC #5
4930  ADC N
4940  STA 2,X
4950  LDY #0
4960  TYA
4970  ADC N+1
4980  STA 3,X
4990  STY 1,X
5000  LDA (N),Y
5010  STA 0,X
5020  LDA #1
5030  PHA
5040  JMP PUSH
5050 L280 BCS L284
5060 L281 INY
5070  LDA (N),Y
5080  BPL L281
5090 L284 INY
5100  LDA (N),Y
5110  TAX
5120  INY
5130  LDA (N),Y
5140  STA N+1
5150  STX N
5160  ORA N
5170  BNE L249
5180  LDX XSAVE
5190  LDA #0
5200  PHA
5210  JMP PUSH
5220 ;<>
5230 L301 .BYTE $87,"ENCLOSE"
5240  .WORD L243
5250 ENCL .WORD *+2
5260  LDA #2
5270  JSR SETUP
5280  TXA
5290  SEC
5300  SBC #8
5310  TAX
5320  STY N+5 clear high byte of offset
5330  JMP L314 skip over inc first time
5350 L313 INY
5352  BNE L314 no carry
5354  INC N+5 carry to high byte of offset
5356  INC N+3 carry to high byte of addr
5360 L314 LDA (N+2),Y
5370  CMP N
5380  BEQ L313
5390  STY 4,X
5392  LDA N+5 store high byte of offset
5394  STA 5,X
5400 L318 LDA (N+2),Y
5420  BNE L327
5430  STY 2,X
5440  STY 0,X
5442  LDA N+5 store high byte of offset
5444  STA 1,X
5446  STA 3,X
5450  TYA
5460  CMP 4,X
5470  BNE L326
5472  LDA N+5 make sure high bytes not different
5474  CMP 5,X
5476  BNE L326
5480  INC 2,X
5482  BNE L326 check for carry
5484  INC 3,X
5490 L326 JMP NEXT
5500 L327 STY 2,X
5502  PHA save A
5504  LDA N+5 save high byte of offset
5506  STA 3,X
5508  PLA
5510  INY
5512  BNE L328 check for carry
5514  INC N+5
5516  INC N+3
5520 L328 CMP N
5530  BNE L318
5540  STY 0,X
5542  LDA N+5 store high byte of offset
5544  STA 1,X
5550  JMP NEXT
5560 ;<>
5570 L337 .BYTE $86,"(EMIT)"
5580  .WORD L301
5590 PEMIT .WORD XEMIT vector to code for EMIT
5591 ;<>
5592 ;<>
5593 L338 .BYTE $84,"EMIT"
5594  .WORD L337
5595 EMIT .WORD DOCOL
5596  .WORD CKPRFL,PEMIT,SEMIS
5597 ;<>
5598 L339 .BYTE $86,"CKPRFL"
5599  .WORD L338
5600 CKPRFL .WORD DOCOL
5601  .WORD PRFLAG,AT,ZBRAN
5602  .WORD L340-*
5603  .WORD CLIT
5604  .BYTE $70
5605  .WORD OVER,PUTB
5606 L340 .WORD SEMIS
5607 ;<>
5608 L341 .BYTE $86,"PRFLAG"
5609  .WORD L339
5610 PRFLAG .WORD DOVAR
5611  .WORD 0 printer off
5634 L344 .BYTE $83,"KEY"
5636  .WORD L341
5638 KEY .WORD XKEY vector to code for KEY
5640 ;<>
5650 L351 .BYTE $89,"?TERMINAL"
5660  .WORD L344
5670 QTERM .WORD XQTER vector to code for ?TERMINAL
5680 ;<>
5690 L358 .BYTE $84,"(CR)"
5700  .WORD L351
5710 PCR .WORD XCR vector to code for CR
5720 ;<>
5721 L359 .BYTE $82,"CR"
5722  .WORD L358
5723 CR .WORD DOCOL
5724  .WORD CLIT
5725  .BYTE $9B EOL
5726  .WORD CKPRFL,DROP,PCR,SEMIS
5730 L365 .BYTE $85,"CMOVE"
5740  .WORD L359
5750 CMOVE .WORD *+2
5760  LDA #3
5770  JSR SETUP
5780 L370 CPY N
5790  BNE L375
5800  DEC N+1
5810  BPL L375
5820  JMP NEXT
5830 L375 LDA (N+4),Y
5840  STA (N+2),Y
5850  INY
5860  BNE L370
5870  INC N+5
5880  INC N+3
5890  JMP L370
5900 ;<>
5910 L386 .BYTE $82,"U*"
5920  .WORD L365
5930 USTAR .WORD *+2
5940  LDA 2,X
5950  STA N
5960  STY 2,X
5970  LDA 3,X
5980  STA N+1
5990  STY 3,X
6000  LDY #16 for 16 bits
6010 L396 ASL 2,X
6020  ROL 3,X
6030  ROL 0,X
6040  ROL 1,X
6050  BCC L411
6060  CLC
6070  LDA N
6080  ADC 2,X
6090  STA 2,X
6100  LDA N+1
6110  ADC 3,X
6120  STA 3,X
6130  LDA #0
6140  ADC 0,X
6150  STA 0,X
6160 L411 DEY
6170  BNE L396
6180  JMP NEXT
6190 ;<>
6210 L418 .BYTE $82,"U/"
6220  .WORD L386
6230 USLAS .WORD *+2
6240  LDA 4,X
6250  LDY 2,X
6260  STY 4,X
6270  ASL A
6280  STA 2,X
6290  LDA 5,X
6300  LDY 3,X
6310  STY 5,X
6320  ROL A
6330  STA 3,X
6340  LDA #16 for 16 bits
6350  STA N
6360 L433 ROL 4,X
6370  ROL 5,X
6380  SEC
6390  LDA 4,X
6400  SBC 0,X
6410  TAY
6420  LDA 5,X
6430  SBC 1,X
6440  BCC L444
6450  STY 4,X
6460  STA 5,X
6470 L444 ROL 2,X
6480  ROL 3,X
6490  DEC N
6500  BNE L433
6510  JMP POP
6520 ;<>
6530 L453 .BYTE $83,"AND"
6540  .WORD L418
6550 ANDD .WORD *+2
6560  LDA 0,X
6570  AND 2,X
6580  PHA
6590  LDA 1,X
6600  AND 3,X
6610 ;
6620 BINARY INX
6630  INX
6640  JMP PUT
6650 ;<>
6660 L469 .BYTE $82,"OR"
6670  .WORD L453
6680 OR .WORD *+2
6690  LDA 0,X
6700  ORA 2,X
6710  PHA
6720  LDA 1,X
6730  ORA 3,X
6740  INX
6750  INX
6760  JMP PUT
6770 ;<>
6780 L484 .BYTE $83,"XOR"
6790  .WORD L469
6800 XOR .WORD *+2
6810  LDA 0,X
6820  EOR 2,X
6830  PHA
6840  LDA 1,X
6850  EOR 3,X
6860  INX
6870  INX
6880  JMP PUT
6890 ;<>
6900 L499 .BYTE $83,"SP@"
6910  .WORD L484
6920 SPAT .WORD *+2
6930  TXA
6940 ;
6950 PUSH0A PHA
6960  LDA #0
6970  JMP PUSH
6980 ;<>
6990 L511 .BYTE $83,"SP!"
7000  .WORD L499
7010 SPSTO .WORD *+2
7020  LDY #6
7040  LDA (UP),Y load data stack pointer (X-reg) from
7050  TAX silent user variable S0
7060  JMP NEXT
7070 ;<>
7080 L522 .BYTE $83,"RP!"
7090  .WORD L511
7100 RPSTO .WORD *+2
7110  STX XSAVE load return stack pointer
7120  LDY #8 (machine stack pointer) from
7130  LDA (UP),Y silent user variable R0
7140  TAX
7150  TXS
7160  LDX XSAVE
7170  JMP NEXT
7180 ;<>
7190 L536 .BYTE $82,";S"
7200  .WORD L522
7210 SEMIS .WORD *+2
7220  PLA
7230  STA IP
7240  PLA
7250  STA IP+1
7260  JMP NEXT
7270 ;<>
7280 L548 .BYTE $85,"LEAVE"
7290  .WORD L536
7300 LEAVE .WORD *+2
7310  STX XSAVE
7320  TSX
7330  LDA $101,X
7340  STA $103,X
7350  LDA $102,X
7360  STA $104,X
7370  LDX XSAVE
7380  JMP NEXT
7390 ;<>
7400 L563 .BYTE $82,">R"
7410  .WORD L548
7420 TOR .WORD *+2
7430  LDA 1,X move high byte
7440  PHA
7450  LDA 0,X then low byte
7460  PHA to return stack
7470  INX
7480  INX popping off data stack
7490  JMP NEXT
7500 ;<>
7510 L577 .BYTE $82,"R>"
7520  .WORD L563
7530 RFROM .WORD *+2
7540  DEX make room on data stack
7550  DEX
7560  PLA high byte
7570  STA 0,X
7580  PLA then low byte
7590  STA 1,X restored to data stack
7600  JMP NEXT
7610 ;<>
7620 L591 .BYTE $81,"R"
7630  .WORD L577
7640 R .WORD *+2
7650  STX XSAVE
7660  TSX address return stack
7670  LDA $101,X copy bottom value
7680  PHA to data stack
7690  LDA $102,X
7700  LDX XSAVE
7710  JMP PUSH
7720 ;<>
7730 L605 .BYTE $82,"0="
7740  .WORD L591
7750 ZEQU .WORD *+2
7760  LDA 0,X
7770  ORA 1,X
7780  STY 1,X
7790  BNE L613
7810  INY
7820 L613 STY 0,X
7830  JMP NEXT
7840 ;<>
7850 L619 .BYTE $82,"0<"
7860  .WORD L605
7870 ZLESS .WORD *+2
7880  ASL 1,X
7890  TYA
7900  ROL A
7910  STY 1,X
7920  STA 0,X
7930  JMP NEXT
7940 ;<>
7950 L632 .BYTE $81,"+"
7960  .WORD L619
7970 PLUS .WORD *+2
7980  CLC
7990  LDA 0,X
8000  ADC 2,X
8010  STA 2,X
8020  LDA 1,X
8030  ADC 3,X
8040  STA 3,X
8050  INX
8060  INX
8070  JMP NEXT
8080 ;<>
8090 L649 .BYTE $82,"D+"
8100  .WORD L632
8110 DPLUS .WORD *+2
8120  CLC
8130  LDA 2,X
8140  ADC 6,X
8150  STA 6,X
8160  LDA 3,X
8170  ADC 7,X
8180  STA 7,X
8190  LDA 0,X
8200  ADC 4,X
8210  STA 4,X
8220  LDA 1,X
8230  ADC 5,X
8240  STA 5,X
8250  JMP POPTWO
8260 ;<>
8270 L670 .BYTE $85,"MINUS"
8280  .WORD L649
8290 MINUS .WORD *+2
8300  SEC
8310  TYA
8320  SBC 0,X
8330  STA 0,X
8340  TYA
8350  SBC 1,X
8360  STA 1,X
8370  JMP NEXT
8380 ;<>
8390 L685 .BYTE $86,"DMINUS"
8400  .WORD L670
8410 DMINU .WORD *+2
8420  SEC
8430  TYA
8440  SBC 2,X
8450  STA 2,X
8460  TYA
8470  SBC 3,X
8480  STA 3,X
8490  JMP MINUS+3
8500 ;<>
8510 L700 .BYTE $84,"OVER"
8520  .WORD L685
8530 OVER .WORD *+2
8540  LDA 2,X
8550  PHA
8560  LDA 3,X
8570  JMP PUSH
8580 ;<>
8590 L711 .BYTE $84,"DROP"
8600  .WORD L700
8610 DROP .WORD POP
8620 ;<>
8630 L718 .BYTE $84,"SWAP"
8640  .WORD L711
8650 SWAP .WORD *+2
8660  LDA 2,X
8670  PHA
8680  LDA 0,X
8690  STA 2,X
8700  LDA 3,X
8710  LDY 1,X
8720  STY 3,X
8730  JMP PUT
8740 ;<>
8750 L733 .BYTE $83,"DUP"
8760  .WORD L718
8770 DUP .WORD *+2
8780  LDA 0,X
8790  PHA
8800  LDA 1,X
8810  JMP PUSH
8820 ;<>
8830 L744 .BYTE $82,"+!"
8840  .WORD L733
8850 PSTOR .WORD *+2
8860  CLC
8870  LDA (0,X) fetch 16-bit value addressed
8880  ADC 2,X by bottom of stack, adding to
8890  STA (0,X) second item on stack, and
8900  INC 0,X return to memory
8910  BNE L754
8920  INC 1,X
8930 L754 LDA (0,X)
8940  ADC 3,X
8950  STA (0,X)
8960  JMP POPTWO
8970 ;<>
8980 L762 .BYTE $86,"TOGGLE"
8990  .WORD L744
9000 TOGGL .WORD *+2
9010  LDA (2,X) complement bits in memory address
9020  EOR 0,X second on stack, by pattern
9030  STA (2,X) on bottom of stack
9040  JMP POPTWO
9050 ;<>
9060 L773 .BYTE $81,"@"
9070  .WORD L762
9080 AT .WORD *+2
9090  LDA (0,X)
9100  PHA
9110  INC 0,X
9120  BNE L781
9130  INC 1,X
9140 L781 LDA (0,X)
9150  JMP PUT
9160 ;<>
9170 L787 .BYTE $82,"C@"
9180  .WORD L773
9190 CAT .WORD *+2
9200  LDA (0,X) fetch byte addressed by bottom
9210  STA 0,X of stack to stack, zeroing
9220  STY 1,X the high byte
9230  JMP NEXT
9240 ;<>
9250 L798 .BYTE $81,"!"
9260  .WORD L787
9270 STORE .WORD *+2
9280  LDA 2,X
9290  STA (0,X) store second 16-bit value on stack
9300  INC 0,X to memory as addresses by
9310  BNE L806
9320  INC 1,X bottom of stack
9330 L806 LDA 3,X
9340  STA (0,X)
9350  JMP POPTWO
9360 ;<>
9370 L813 .BYTE $82,"C!"
9380  .WORD L798
9390 CSTOR .WORD *+2
9400  LDA 2,X
9410  STA (0,X)
9420  JMP POPTWO
9430 ;<>
9440 L823 .BYTE $C1,":"
9450  .WORD L813
9460 COLON .WORD DOCOL
9470  .WORD QEXEC,SCSP,CURR,AT,CON
9480  .WORD STORE,CREAT,RBRAC,PSCOD
9490 ;
9500 DOCOL LDA IP+1
9510  PHA
9520  LDA IP
9530  PHA
9540 ;JSR TCOLON Mark the start of traced : def
9550  CLC
9560  LDA W
9570  ADC #2
9580  STA IP
9590  TYA
9600  ADC W+1
9610  STA IP+1
9620  JMP NEXT
9630 ;<>
9640 L853 .BYTE $C1,";"
9650  .WORD L823
9660  .WORD DOCOL
9670  .WORD QCSP,COMP,SEMIS,SMUDG
9680  .WORD LBRAC,SEMIS
9690 ;<>
9700 L867 .BYTE $88,"CONSTANT"
9710  .WORD L853
9720 CONST .WORD DOCOL
9730  .WORD CREAT,SMUDG,COMMA,PSCOD
9740 ;
9750 DOCON LDY #2
9760  LDA (W),Y
9770  PHA
9780  INY
9790  LDA (W),Y
9800  JMP PUSH
9810 ;<>
9820 L885 .BYTE $88,"VARIABLE"
9830  .WORD L867
9840 VAR .WORD DOCOL
9850  .WORD CONST,PSCOD
9860 ;
9870 DOVAR CLC
9880  LDA W
9890  ADC #2
9900  PHA
9910  TYA
9920  ADC W+1
9930  JMP PUSH
9940 ;<>
9950 L902 .BYTE $84,"USER"
9970  .WORD L885
9980 USER .WORD DOCOL
9990  .WORD CONST,PSCOD
010000 ;
010010 DOUSE LDY #2
010020  CLC
010030  LDA (W),Y
010040  ADC UP
010050  PHA
010060  LDA #0
010070  ADC UP+1
010080  JMP PUSH
010090 ;<>
010100 L920 .BYTE $81,"0"
010110  .WORD L902
010120 ZERO .WORD DOCON
010130  .WORD 0
010140 ;<>
010150 L928 .BYTE $81,"1"
010160  .WORD L920
010170 ONE .WORD DOCON
010180  .WORD 1
010190 ;<>
010200 L936 .BYTE $81,"2"
010210  .WORD L928
010220 TWO .WORD DOCON
010230  .WORD 2
010240 ;<>
010250 L944 .BYTE $81,"3"
010260  .WORD L936
010270 THREE .WORD DOCON
010280  .WORD 3
010290 ;<>
010300 L952 .BYTE $82,"BL"
010310  .WORD L944
010320 BL .WORD DOCON
010330  .WORD $20
010340 ;<>
010350 L960 .BYTE $83,"C/L"
010360  .WORD L952
010370 CSLL .WORD DOCON
010380  .WORD 32
010390 ;<>
010400 L968 .BYTE $85,"FIRST"
010410  .WORD L960
010420 FIRST .WORD DOCON
010430  .WORD DAREA bottom of disk buffer area
010440 ;<>
010450 L976 .BYTE $85,"LIMIT"
010460  .WORD L968
010470 LIMIT .WORD DOCON
010480  .WORD DAREA+BMAG buffers end at user area
010490 ;<>
010500 L984 .BYTE $85,"B/BUF"
010510  .WORD L976
010520 BBUF .WORD DOCON
010530  .WORD SSIZE sector size
010540 ;<>
010550 L992 .BYTE $85,"B/SCR"
010560  .WORD L984
010570 BSCR .WORD DOCON
010580  .WORD 1 blocks to make one screen
010590 ;<>
010600 L1000 .BYTE $87,"+ORIGIN"
010610  .WORD L992
010620 PORIG .WORD DOCOL
010630  .WORD LIT,ORIG,PLUS,SEMIS
010640 ;<>
010650 L1010 .BYTE $83,"TIB"
010660  .WORD L1000
010670 TIB .WORD DOUSE
010680  .BYTE $A
010690 ;<>
010700 L1018 .BYTE $85,"WIDTH"
010710  .WORD L1010
010720 WIDTH .WORD DOUSE
010730  .BYTE $C
010740 ;<>
010750 L1026 .BYTE $87,"WARNING"
010760  .WORD L1018
010770 WARN .WORD DOUSE
010780  .BYTE $E
010790 ;<>
010800 L1034 .BYTE $85,"FENCE"
010810  .WORD L1026
010820 FENCE .WORD DOUSE
010830  .BYTE $10
010840 ;<>
010850 L1042 .BYTE $82,"DP"
010860  .WORD L1034
010870 DP .WORD DOUSE
010880  .BYTE $12
010890 ;<>
010900 L1050 .BYTE $88,"VOC-LINK"
010910  .WORD L1042
010920 VOCL .WORD DOUSE
010930  .BYTE $14
010940 ;<>
010950 L1058 .BYTE $83,"BLK"
010960  .WORD L1050
010970 BLK .WORD DOUSE
010980  .BYTE $16
010990 ;<>
011000 L1066 .BYTE $82,"IN"
011010  .WORD L1058
011020 IN .WORD DOUSE
011030  .BYTE $18
011040 ;<>
011050 L1074 .BYTE $83,"OUT"
011060  .WORD L1066
011070 OUT .WORD DOUSE
011080  .BYTE $1A
011090 ;<>
011100 L1082 .BYTE $83,"SCR"
011110  .WORD L1074
011120 SCR .WORD DOUSE
011130  .BYTE $1C
011140 ;<>
011150 L1090 .BYTE $86,"OFFSET"
011160  .WORD L1082
011170 OFSET .WORD DOUSE
011180  .BYTE $1E
011190 ;<>
011200 L1098 .BYTE $87,"CONTEXT"
011210  .WORD L1090
011220 CON .WORD DOUSE
011230  .BYTE $20
011240 ;<>
011250 L1106 .BYTE $87,"CURRENT"
011260  .WORD L1098
011270 CURR .WORD DOUSE
011280  .BYTE $22
011290 ;<>
011300 L1114 .BYTE $85,"STATE"
011310  .WORD L1106
011320 STATE .WORD DOUSE
011330  .BYTE $24
011340 ;<>
011350 L1122 .BYTE $84,"BASE"
011360  .WORD L1114
011370 BASE .WORD DOUSE
011380  .BYTE $26
011390 ;<>
011400 L1130 .BYTE $83,"DPL"
011410  .WORD L1122
011420 DPL .WORD DOUSE
011430  .BYTE $28
011440 ;<>
011450 L1138 .BYTE $83,"FLD"
011460  .WORD L1130
011470 FLD .WORD DOUSE
011480  .BYTE $2A
011490 ;<>
011500 L1146 .BYTE $83,"CSP"
011510  .WORD L1138
011520 CSP .WORD DOUSE
011530  .BYTE $2C
011540 ;<>
011550 L1154 .BYTE $82,"R#"
011560  .WORD L1146
011570 RNUM .WORD DOUSE
011580  .BYTE $2E
011590 ;<>
011600 L1162 .BYTE $83,"HLD"
011610  .WORD L1154
011620 HLD .WORD DOUSE
011630  .BYTE $30
011640 ;<>
011650 L1170 .BYTE $82,"1+"
011660  .WORD L1162
011670 ONEP .WORD DOCOL
011680  .WORD ONE,PLUS,SEMIS
011690 ;<>
011700 L1180 .BYTE $82,"2+"
011710  .WORD L1170
011720 TWOP .WORD DOCOL
011730  .WORD TWO,PLUS,SEMIS
011740 ;<>
011750 L1190 .BYTE $84,"HERE"
011760  .WORD L1180
011770 HERE .WORD DOCOL
011780  .WORD DP,AT,SEMIS
011790 ;<>
011800 L1200 .BYTE $85,"ALLOT"
011810  .WORD L1190
011820 ALLOT .WORD DOCOL
011830  .WORD DP,PSTOR,SEMIS
011840 ;<>
011850 L1210 .BYTE $81,","
011860  .WORD L1200
011870 COMMA .WORD DOCOL
011880  .WORD HERE,STORE,TWO,ALLOT,SEMIS
011890 ;<>
011900 L1222 .BYTE $82,"C,"
011910  .WORD L1210
011920 CCOMM .WORD DOCOL
011930  .WORD HERE,CSTOR,ONE,ALLOT,SEMIS
011940 ;<>
011950 L1234 .BYTE $81,"-"
011960  .WORD L1222
011970 SUB .WORD DOCOL
011980  .WORD MINUS,PLUS,SEMIS
011990 ;<>
012000 L1244 .BYTE $81,"="
012010  .WORD L1234
012020 EQUAL .WORD DOCOL
012030  .WORD SUB,ZEQU,SEMIS
012040 ;<>
012050 L1246 .BYTE $82,"U<" unsigned less than
012060  .WORD L1244
012070 ULESS .WORD DOCOL
012080  .WORD OVER,OVER,XOR,ZLESS,ZBRAN
012090  .WORD L1247-*,DROP,ZLESS,ZEQU
012100  .WORD BRAN
012101  .WORD L1248-*
012102 L1247 .WORD SUB,ZLESS
012104 L1248 .WORD SEMIS
012110 ;<>
012120 L1254 .BYTE $81,"<"
012140  .WORD L1246
012150 LESS .WORD *+2
012160  SEC
012170  LDA 2,X
012180  SBC 0,X subtract
012190  LDA 3,X
012200  SBC 1,X
012210  STY 3,X zero hi byte
012220  BVC L1258
012230  EOR #$80 correct overflow
012240 L1258 BPL L1260
012250  INY invert boolean
012260 L1260 STY 2,X leave boolean
012270  JMP POP
012280 ;<>
012290 L1264 .BYTE $81,">"
012300  .WORD L1254
012310 GREAT .WORD DOCOL
012320  .WORD SWAP,LESS,SEMIS
012330 ;<>
012340 L1274 .BYTE $83,"ROT"
012350  .WORD L1264
012360 ROT .WORD DOCOL
012370  .WORD TOR,SWAP,RFROM,SWAP,SEMIS
012380 ;<>
012390 L1286 .BYTE $85,"SPACE"
012400  .WORD L1274
012410 SPACE .WORD DOCOL
012420  .WORD BL,EMIT,SEMIS
012430 ;<>
012440 L1296 .BYTE $84,"-DUP"
012450  .WORD L1286
012460 DDUP .WORD DOCOL
012470  .WORD DUP,ZBRAN
012480 L1301 .WORD L1303-L1301
012490  .WORD DUP
012500 L1303 .WORD SEMIS
012510 ;<>
012520 L1308 .BYTE $88,"TRAVERSE"
012530  .WORD L1296
012540 TRAV .WORD DOCOL
012550  .WORD SWAP
012560 L1312 .WORD OVER,PLUS,CLIT
012570  .BYTE $7F
012580  .WORD OVER,CAT,LESS,ZBRAN
012590 L1320 .WORD L1312-L1320
012600  .WORD SWAP,DROP,SEMIS
012610 ;<>
012620 L1328 .BYTE $86,"LATEST"
012630  .WORD L1308
012640 LATES .WORD DOCOL
012650  .WORD CURR,AT,AT,SEMIS
012660 ;<>
012670 L1339 .BYTE $83,"LFA"
012680  .WORD L1328
012690 LFA .WORD DOCOL
012700  .WORD CLIT
012710  .BYTE 4
012720  .WORD SUB,SEMIS
012730 ;<>
012740 L1350 .BYTE $83,"CFA"
012750  .WORD L1339
012760 CFA .WORD DOCOL
012770  .WORD TWO,SUB,SEMIS
012780 ;<>
012790 L1360 .BYTE $83,"NFA"
012800  .WORD L1350
012810 NFA .WORD DOCOL
012820  .WORD CLIT
012830  .BYTE $5
012840  .WORD SUB,LIT,$FFFF,TRAV,SEMIS
012850 ;<>
012860 L1373 .BYTE $83,"PFA"
012870  .WORD L1360
012880 PFA .WORD DOCOL
012890  .WORD ONE,TRAV,CLIT
012900  .BYTE 5
012910  .WORD PLUS,SEMIS
012920 ;<>
012930 L1386 .BYTE $84,"!CSP"
012940  .WORD L1373
012950 SCSP .WORD DOCOL
012960  .WORD SPAT,CSP,STORE,SEMIS
012970 ;<>
012980 L1397 .BYTE $86,"?ERROR"
012990  .WORD L1386
013000 QERR .WORD DOCOL
013010  .WORD SWAP,ZBRAN
013020 L1402 .WORD L1406-L1402
013030  .WORD ERROR,BRAN
013040 L1405 .WORD L1407-L1405
013050 L1406 .WORD DROP
013060 L1407 .WORD SEMIS
013070 ;<>
013080 L1412 .BYTE $85,"?COMP"
013090  .WORD L1397
013100 QCOMP .WORD DOCOL
013110  .WORD STATE,AT,ZEQU,CLIT
013120  .BYTE $11
013130  .WORD QERR,SEMIS
013140 ;<>
013150 L1426 .BYTE $85,"?EXEC"
013160  .WORD L1412
013170 QEXEC .WORD DOCOL
013180  .WORD STATE,AT,CLIT
013190  .BYTE $12
013200  .WORD QERR,SEMIS
013210 ;<>
013220 L1439 .BYTE $86,"?PAIRS"
013230  .WORD L1426
013240 QPAIR .WORD DOCOL
013250  .WORD SUB,CLIT
013260  .BYTE $13
013270  .WORD QERR,SEMIS
013280 ;<>
013290 L1451 .BYTE $84,"?CSP"
013300  .WORD L1439
013310 QCSP .WORD DOCOL
013320  .WORD SPAT,CSP,AT,SUB,CLIT
013330  .BYTE $14
013340  .WORD QERR,SEMIS
013350 ;<>
013360 L1466 .BYTE $88,"?LOADING"
013370  .WORD L1451
013380 QLOAD .WORD DOCOL
013390  .WORD BLK,AT,ZEQU,CLIT
013400  .BYTE $16
013410  .WORD QERR,SEMIS
013420 ;<>
013430 L1480 .BYTE $87,"COMPILE"
013440  .WORD L1466
013450 COMP .WORD DOCOL
013460  .WORD QCOMP,RFROM,DUP,TWOP,TOR
013470  .WORD AT,COMMA,SEMIS
013480 ;<>
013490 L1495 .BYTE $C1,"["
013500  .WORD L1480
013510 LBRAC .WORD DOCOL
013520  .WORD ZERO,STATE,STORE,SEMIS
013530 ;<>
013540 L1507 .BYTE $81,"]"
013550  .WORD L1495
013560 RBRAC .WORD DOCOL
013570  .WORD CLIT
013580  .BYTE $C0
013590  .WORD STATE,STORE,SEMIS
013600 ;<>
013610 L1519 .BYTE $86,"SMUDGE"
013620  .WORD L1507
013630 SMUDG .WORD DOCOL
013640  .WORD LATES,CLIT
013650  .BYTE $20
013660  .WORD TOGGL,SEMIS
013670 ;<>
013680 L1531 .BYTE $83,"HEX"
013690  .WORD L1519
013700 HEX .WORD DOCOL
013710  .WORD CLIT
013720  .BYTE 16
013730  .WORD BASE,STORE,SEMIS
013740 ;<>
013750 L1543 .BYTE $87,"DECIMAL"
013760  .WORD L1531
013770 DECIM .WORD DOCOL
013780  .WORD CLIT
013790  .BYTE 10
013800  .WORD BASE,STORE,SEMIS
013810 ;<>
013820 L1555 .BYTE $87,"(;CODE)"
013830  .WORD L1543
013840 PSCOD .WORD DOCOL
013850  .WORD RFROM,LATES,PFA,CFA,STORE
013860  .WORD SEMIS
013870 ;<>
013880 L1568 .BYTE $C5,";CODE"
013890  .WORD L1555
013900  .WORD DOCOL
013910  .WORD QCSP,COMP,PSCOD,LBRAC
013920  .WORD SMUDG,SEMIS
013930 ;<>
013940 L1582 .BYTE $87,"<BUILDS"
013950  .WORD L1568
013960 BUILD .WORD DOCOL
013970  .WORD ZERO,CONST,SEMIS
013980 ;<>
013990 L1592 .BYTE $85,"DOES>"
014000  .WORD L1582
014010 DOES .WORD DOCOL
014020  .WORD RFROM,LATES,PFA,STORE,PSCOD
014030 ;
014040 DODOE LDA IP+1
014050  PHA
014060  LDA IP
014070  PHA
014080  LDY #2
014090  LDA (W),Y
014100  STA IP
014110  INY
014120  LDA (W),Y
014130  STA IP+1
014140  CLC
014150  LDA W
014160  ADC #4
014170  PHA
014180  LDA W+1
014190  ADC #0
014200  JMP PUSH
014210 ;<>
014220 L1622 .BYTE $85,"COUNT"
014230  .WORD L1592
014240 COUNT .WORD DOCOL
014250  .WORD DUP,ONEP,SWAP,CAT,SEMIS
014260 ;<>
014270 L1634 .BYTE $84,"TYPE"
014280  .WORD L1622
014290 TYPE .WORD DOCOL
014300  .WORD DDUP,ZBRAN
014310 L1639 .WORD L1651-L1639
014320  .WORD OVER,PLUS,SWAP,PDO
014330 L1644 .WORD I
014340  .WORD CAT,EMIT,PLOOP
014350 L1648 .WORD L1644-L1648
014360  .WORD BRAN
014370 L1650 .WORD L1652-L1650
014380 L1651 .WORD DROP
014390 L1652 .WORD SEMIS
014400 ;<>
014410 L1657 .BYTE $89,"-TRAILING"
014420  .WORD L1634
014430 DTRAI .WORD DOCOL
014440  .WORD DUP,ZERO,PDO
014450 L1663 .WORD OVER
014460  .WORD OVER,PLUS,ONE,SUB,CAT,BL
014470  .WORD SUB,ZBRAN
014480 L1672 .WORD L1676-L1672
014490  .WORD LEAVE,BRAN
014500 L1675 .WORD L1678-L1675
014510 L1676 .WORD ONE
014520  .WORD SUB
014530 L1678 .WORD PLOOP
014540 L1679 .WORD L1663-L1679
014550  .WORD SEMIS
020000 ;<>
020010 L1685 .BYTE $84,"(.",$22,")"  (.")
020020  .WORD L1657
020030 PDOTQ .WORD DOCOL
020040  .WORD R,COUNT,DUP,ONEP,RFROM
020050  .WORD PLUS,TOR,TYPE,SEMIS
020060 ;<>
020070 L1701 .BYTE $C2,".""
020080  .WORD L1685
020090  .WORD DOCOL
020100  .WORD CLIT
020110  .BYTE $22
020120  .WORD STATE,AT,ZBRAN
020130 L1709 .WORD L1719-L1709
020140  .WORD COMP,PDOTQ,WORD,HERE,CAT
020150  .WORD ONEP,ALLOT,BRAN
020160 L1718 .WORD L1723-L1718
020170 L1719 .WORD WORD,HERE,COUNT,TYPE
020180 L1723 .WORD SEMIS
020190 ;<>
020200 L1729 .BYTE $86,"EXPECT"
020210  .WORD L1701
020220 EXPEC .WORD DOCOL
020230  .WORD OVER,PLUS,OVER,PDO
020240 L1736 .WORD PKEY
020250  .WORD DUP,CLIT
020260  .BYTE $E
020270  .WORD PORIG,AT,EQUAL,ZBRAN
020280 L1744 .WORD L1760-L1744
020290  .WORD DROP,CLIT
020300  .BYTE $7E
020310  .WORD OVER,I,EQUAL,RFROM
020320  .WORD TWO,SUB,PLUS,TOR,BRAN
020330 L1759 .WORD L1779-L1759
020340 L1760 .WORD DUP
020350  .WORD CLIT
020360  .BYTE $9B
020370  .WORD EQUAL,ZBRAN
020380 L1765 .WORD L1772-L1765
020390  .WORD LEAVE,DROP,BL,ZERO,BRAN
020400 L1771 .WORD L1773-L1771
020410 L1772 .WORD DUP
020420 L1773 .WORD I
020430  .WORD CSTOR,ZERO,I,ONEP,STORE
020440 L1779 .WORD EMIT
020450  .WORD PLOOP
020460 L1781 .WORD L1736-L1781
020470  .WORD DROP,SEMIS
020480 ;<>
020490 L1788 .BYTE $85,"QUERY"
020500  .WORD L1729
020510 QUERY .WORD DOCOL
020520  .WORD TIB,AT,CLIT
020530  .BYTE 80 80 characters from terminal
020540  .WORD EXPEC,ZERO,IN,STORE,SEMIS
020550 ;<>
020560 L1804 .BYTE $C1,$80 ASCII null
020570  .WORD L1788
020580  .WORD DOCOL
020590  .WORD BLK,AT,ZBRAN
020600 L1810 .WORD L1830-L1810
020610  .WORD ONE,BLK,PSTOR,ZERO,IN
020620  .WORD STORE,BLK,AT,ZERO,BSCR
020630  .WORD USLAS,DROP,ZEQU,ZBRAN
020640 L1824 .WORD L1828-L1824
020650  .WORD QEXEC,RFROM,DROP
020660 L1828 .WORD BRAN
020670 L1829 .WORD L1832-L1829
020680 L1830 .WORD RFROM
020690  .WORD DROP
020700 L1832 .WORD SEMIS
020710 ;<>
020720 L1838 .BYTE $84,"FILL"
020730  .WORD L1804
020740 FILL .WORD DOCOL
020750  .WORD SWAP,TOR,OVER,CSTOR,DUP
020760  .WORD ONEP,RFROM,ONE,SUB,CMOVE
020770  .WORD SEMIS
020780 ;<>
020790 L1856 .BYTE $85,"ERASE"
020800  .WORD L1838
020810 ERASE .WORD DOCOL
020820  .WORD ZERO,FILL,SEMIS
020830 ;<>
020840 L1866 .BYTE $86,"BLANKS"
020850  .WORD L1856
020860 BLANK .WORD DOCOL
020870  .WORD BL,FILL,SEMIS
020880 ;<>
020890 L1876 .BYTE $84,"HOLD"
020900  .WORD L1866
020910 HOLD .WORD DOCOL
020920  .WORD LIT,$FFFF
020930  .WORD HLD,PSTOR,HLD,AT,CSTOR
020940  .WORD SEMIS
020950 ;<>
020960 L1890 .BYTE $83,"PAD"
020970  .WORD L1876
020980 PAD .WORD DOCOL
020990  .WORD HERE,CLIT
021000  .BYTE 68 PAD is 68 bytes above here
021010  .WORD PLUS,SEMIS
021020 ;<>
021030 L1902 .BYTE $84,"WORD"
021040  .WORD L1890
021050 WORD .WORD DOCOL
021060  .WORD BLK,AT,ZBRAN
021070 L1908 .WORD L1914-L1908
021080  .WORD BLK,AT,BLOCK,BRAN
021090 L1913 .WORD L1916-L1913
021100 L1914 .WORD TIB
021110  .WORD AT
021120 L1916 .WORD IN
021130  .WORD AT,PLUS,SWAP,ENCL,HERE
021140  .WORD CLIT
021150  .BYTE $22
021160  .WORD BLANK,IN,PSTOR,OVER,SUB
021170  .WORD TOR,R,HERE,CSTOR,PLUS
021180  .WORD HERE,ONEP,RFROM,CMOVE
021190  .WORD SEMIS
021200 ;<>
021210 L1943 .BYTE $85,"UPPER"
021220  .WORD L1902
021230 UPPER .WORD DOCOL
021240  .WORD OVER This routine converts test to upper
021250  .WORD PLUS case.  It allows interpretation
021260  .WORD SWAP from a terminal without a shift
021270  .WORD PDO lock
021280 L1950 .WORD I
021290  .WORD CAT,CLIT
021300  .BYTE $80
021310  .WORD ANDD,ZBRAN
021320 L1956 .WORD L1961-L1956
021330  .WORD I,CLIT
021340  .BYTE $80
021350  .WORD TOGGL
021360 L1961 .WORD PLOOP
021370 L1962 .WORD L1950-L1962
021380  .WORD SEMIS
021390 ;<>
021400 L1968 .BYTE $88,"(NUMBER)"
021410  .WORD L1943
021420 PNUMB .WORD DOCOL
021430 L1971 .WORD ONEP
021440  .WORD DUP,TOR,CAT,BASE,AT
021450  .WORD DIGIT,ZBRAN
021460 L1979 .WORD L2001-L1979
021470  .WORD SWAP,BASE,AT,USTAR,DROP
021480  .WORD ROT,BASE,AT,USTAR,DPLUS
021490  .WORD DPL,AT,ONEP,ZBRAN
021500 L1994 .WORD L1998-L1994
021510  .WORD ONE,DPL,PSTOR
021520 L1998 .WORD RFROM
021530  .WORD BRAN
021540 L2000 .WORD L1971-L2000
021550 L2001 .WORD RFROM
021560  .WORD SEMIS
021570 ;<>
021580 L2007 .BYTE $86,"NUMBER"
021590  .WORD L1968
021600 NUMBER .WORD DOCOL
021610  .WORD ZERO,ZERO,ROT,DUP,ONEP
021620  .WORD CAT,CLIT
021630  .BYTE $2D
021640  .WORD EQUAL,DUP,TOR,PLUS
021650  .WORD LIT,$FFFF
021660 L2023 .WORD DPL
021670  .WORD STORE,PNUMB,DUP,CAT,BL
021680  .WORD SUB,ZBRAN
021690 L2031 .WORD L2042-L2031
021700  .WORD DUP,CAT,CLIT
021710  .BYTE $2E
021720  .WORD SUB,ZERO,QERR,ZERO,BRAN
021730 L2041 .WORD L2023-L2041
021740 L2042 .WORD DROP
021750  .WORD RFROM,ZBRAN
021760 L2045 .WORD L2047-L2045
021770  .WORD DMINU
021780 L2047 .WORD SEMIS
021790 ;<>
021800 L2052 .BYTE $85,"-FIND"
021810  .WORD L2007
021820 DFIND .WORD DOCOL
021830  .WORD BL,WORD
021840  .WORD HERE Optional, allowing free use of lower
021850  .WORD COUNT case from terminal
021860  .WORD UPPER,HERE,CON,AT,AT
021870  .WORD PFIND,DUP,ZEQU,ZBRAN
021880 L2068 .WORD L2073-L2068
021890  .WORD DROP,HERE,LATES,PFIND
021900 L2073 .WORD SEMIS
021910 ;<>
021920 L2078 .BYTE $87,"(ABORT)"
021930  .WORD L2052
021940 PABOR .WORD DOCOL
021950  .WORD ABORT,SEMIS
021960 ;<>
021970 L2087 .BYTE $85,"ERROR"
021980  .WORD L2078
021990 ERROR .WORD DOCOL
022000  .WORD WARN,AT,ZLESS,ZBRAN
022010 L2094 .WORD L2096-L2094
022020  .WORD PABOR
022030 L2096 .WORD HERE
022040  .WORD COUNT,TYPE,PDOTQ
022050  .BYTE 4,"  ? "
022060  .WORD MESS,SPSTO
022070  .WORD DROP,DROP make room for 2 error values
022080  .WORD IN,AT,BLK,AT,QUIT,SEMIS
022090 ;<>
022100 L2113 .BYTE $83,"ID."
022110  .WORD L2087
022120 IDDOT .WORD DOCOL
022130  .WORD PAD,CLIT
022140  .BYTE $20
022150  .WORD CLIT
022170  .BYTE $5F
022180  .WORD FILL,DUP,PFA,LFA,OVER
022190  .WORD SUB,PAD,SWAP,CMOVE,PAD
022200  .WORD COUNT,CLIT
022210  .BYTE $1F
022220  .WORD ANDD,OVER,OVER,PLUS,ONE
022222  .WORD SUB,DUP,CAT,CLIT
022224  .BYTE $7F
022226  .WORD ANDD,SWAP,CSTOR
022228  .WORD TYPE,SPACE,SEMIS
022230 ;<>
022240 L2142 .BYTE $86,"CREATE"
022250  .WORD L2113
022260 CREAT .WORD DOCOL
022270  .WORD MEMTOP,AT 6502 only, assures room exists
022280  .WORD HERE in dictionary
022290  .WORD CLIT
022300  .BYTE $A0
022310  .WORD PLUS,ULESS,TWO,QERR
022320  .WORD DFIND,ZBRAN
022330 L2155 .WORD L2163-L2155
022340  .WORD DROP,NFA,IDDOT,CLIT
022350  .BYTE 4
022360  .WORD MESS,SPACE
022370 L2163 .WORD HERE
022380  .WORD DUP,CAT,WIDTH,AT,MIN
022390  .WORD ONEP,ALLOT
022440  .WORD DUP,CLIT
022450  .BYTE $A0
022460  .WORD TOGGL,HERE,ONE,SUB
022470  .WORD CLIT
022480  .BYTE $80
022490  .WORD TOGGL
022500  .WORD LATES,COMMA,CURR,AT,STORE
022510  .WORD HERE,TWOP,COMMA,SEMIS
022520 ;<>
022530 L2200 .BYTE $C9,"[COMPILE]"
022540  .WORD L2142
022550  .WORD DOCOL
022560  .WORD DFIND,ZEQU,ZERO,QERR
022570  .WORD DROP,CFA,COMMA,SEMIS
022580 ;<>
022590 L2216 .BYTE $C7,"LITERAL"
022600  .WORD L2200
022610 LITER .WORD DOCOL
022620  .WORD STATE,AT,ZBRAN
022630 L2222 .WORD L2226-L2222
022640  .WORD COMP,LIT,COMMA
022650 L2226 .WORD SEMIS
022660 ;<>
022670 L2232 .BYTE $C8,"DLITERAL"
022680  .WORD L2216
022690 DLIT .WORD DOCOL
022700  .WORD STATE,AT,ZBRAN
022710 L2238 .WORD L2242-L2238
022720  .WORD SWAP,LITER,LITER
022730 L2242 .WORD SEMIS
022740 ;<>
022750 L2248 .BYTE $86,"?STACK"
022760  .WORD L2232
022770 QSTAC .WORD DOCOL
022780  .WORD CLIT
022790  .BYTE TOS
022800  .WORD SPAT,ULESS,ONE,QERR
022810  .WORD SPAT,CLIT
022820  .BYTE BOS
022830  .WORD ULESS,CLIT
022840  .BYTE 7
022850  .WORD QERR,SEMIS
022860 ;<>
022870 L2269 .BYTE $89,"INTERPRET"
022880  .WORD L2248
022890 INTER .WORD DOCOL
022900 L2272 .WORD DFIND
022910  .WORD ZBRAN
022920 L2274 .WORD L2289-L2274
022930  .WORD STATE,AT,LESS,ZBRAN
022940 L2279 .WORD L2284-L2279
022950  .WORD CFA,COMMA,BRAN
022960 L2283 .WORD L2286-L2283
022970 L2284 .WORD CFA
022980  .WORD EXEC
022990 L2286 .WORD QSTAC
023000  .WORD BRAN
023010 L2288 .WORD L2302-L2288
023020 L2289 .WORD HERE
023030  .WORD NUMBER,DPL,AT,ONEP
023040  .WORD ZBRAN
023050 L2295 .WORD L2299-L2295
023060  .WORD DLIT,BRAN
023070 L2298 .WORD L2301-L2298
023080 L2299 .WORD DROP
023090  .WORD LITER
023100 L2301 .WORD QSTAC
023110 L2302 .WORD BRAN
023120 L2303 .WORD L2272-L2303
023130 ;<>
023140 L2309 .BYTE $89,"IMMEDIATE"
023150  .WORD L2269
023160  .WORD DOCOL
023170  .WORD LATES,CLIT
023180  .BYTE $40
023190  .WORD TOGGL,SEMIS
023200 ;<>
023210 L2321 .BYTE $8A,"VOCABULARY"
023220  .WORD L2309
023230  .WORD DOCOL
023240  .WORD BUILD,LIT,$A081
023250  .WORD COMMA,CURR,AT,CFA
023260  .WORD COMMA,HERE,VOCL,AT
023270  .WORD COMMA,VOCL,STORE,DOES
023280 DOVOC .WORD TWOP,CON,STORE,SEMIS
023290 ;<>
023300 L2346 .BYTE $C5,"FORTH"
023310  .WORD L2321
023320 FORTH .WORD DODOE
023330  .WORD DOVOC
023340  .WORD $A081
023350 XFOR .WORD NTOP points to top name in FORTH
023360 VLO .WORD 0 last vocabulary link ends at zero
023370 ;<>
023380 L2357 .BYTE $8B,"DEFINITIONS"
023390  .WORD L2346
023400 DEFIN .WORD DOCOL
023410  .WORD CON,AT,CURR,STORE,SEMIS
023420 ;<>
023430 L2369 .BYTE $C1,"("
023440  .WORD L2357
023450  .WORD DOCOL
023460  .WORD CLIT
023470  .BYTE $29
023480  .WORD WORD,SEMIS
023490 ;<>
023500 L2381 .BYTE $84,"QUIT"
023510  .WORD L2369
023520 QUIT .WORD DOCOL
023530  .WORD ZERO,BLK,STORE,LBRAC
023540 L2388 .WORD RPSTO
023542  .WORD ZERO,LIT,BRFLG,CSTOR
023550  .WORD CR,QUERY,INTER,STATE,AT
023560  .WORD ZEQU,ZBRAN
023570 L2396 .WORD L2399-L2396
023580  .WORD PDOTQ
023590  .BYTE 2,"OK"
023600 L2399 .WORD BRAN
023610 L2400 .WORD L2388-L2400
023620  .WORD SEMIS
023630 ;<>
023640 L2406 .BYTE $85,"ABORT"
023650  .WORD L2381
023660 ABORT .WORD DOCOL
023670  .WORD SPSTO,DECIM,DR0,CR
023680  .WORD PDOTQ
023690  .BYTE 14,"fig-FORTH 1.0D"
023700  .WORD FORTH
023710  .WORD DEFIN,QUIT
023720 ;<>
023730 L2423 .BYTE $84,"COLD"
023740  .WORD L2406
023750 COLD .WORD *+2
023752  LDA DINI+2 first COLD start?
023754  BNE COLD2 branch if not
023756  LDA #1 set BOOT?
023758  STA $9
023760  LDA #0 clear COLDFG
023761  STA $244
023764  LDA $C move DOSINI add to local JSR
023766  STA DINI+1
023768  LDA $D
023770  STA DINI+2
023772  LDA #REENTR&$FF move REENTR to DOSINI location
023774  STA $C
023776  LDA #REENTR/$100
023778  STA $D
023784 COLD2 LDA ORIG+$0C from cold start area
023786  STA FORTH+6
023788  LDA ORIG+$0D
023790  STA FORTH+7
023792  LDY #1 indicate cold start
023794  STY CLDFG
023800  LDY #$15
023810  BNE L2433
023812 WARM LDY #0 indicate warm start
023814  STY CLDFG
023816 DINI JSR $0000 execute DOSINI to reinit DOS (addr set by COLD)
023820  LDY #$0F
023830 L2433 LDA ORIG+$10
023840  STA UP
023850  LDA ORIG+$11
023860  STA UP+1
023870 L2437 LDA ORIG+$0C,Y
023880  STA (UP),Y
023890  DEY
023900  BPL L2437
023910  LDA #PCOLD+2/$100
023920  STA IP+1
023930  LDA #PCOLD+2&$FF
023940  STA IP
023950  CLD
023960  LDA #$6C
023970  STA W-1
023980  JMP RPSTO+2 and off we go!
023982 ;<>
023984 ;  internal cold start
023986 L2440 .BYTE $86,"(COLD)"
023988  .WORD L2423
023990 PCOLD .WORD DOCOL
023992  .WORD SPSTO,CLDR0,CLDR1,CLIT
023994 CLDFG .BYTE 0 (1=cold start)
023996  .WORD ZBRAN
024000  .WORD L2449-*
024002  .WORD EMPTY
024004  .WORD FIRST,USE,STORE
024005  .WORD FIRST,PREV,STORE
024006 L2449 .WORD ABORT
024007 ;<>
024008 L2453 .BYTE $84,"S->D"
024010  .WORD L2423
024020 STOD .WORD DOCOL
024030  .WORD DUP,ZLESS,MINUS,SEMIS
024040 ;<>
024050 L2464 .BYTE $82,"+-"
024060  .WORD L2440
024070 PM .WORD DOCOL
024080  .WORD ZLESS,ZBRAN
024090 L2469 .WORD L2471-L2469
024100  .WORD MINUS
024110 L2471 .WORD SEMIS
024120 ;<>
024130 L2476 .BYTE $83,"D+-"
024140  .WORD L2464
024150 DPM .WORD DOCOL
024160  .WORD ZLESS,ZBRAN
024170 L2481 .WORD L2483-L2481
024180  .WORD DMINU
024190 L2483 .WORD SEMIS
024200 ;<>
024210 L2488 .BYTE $83,"ABS"
024220  .WORD L2476
024230 ABS .WORD DOCOL
024240  .WORD DUP,PM,SEMIS
024250 ;<>
024260 L2498 .BYTE $84,"DABS"
024270  .WORD L2488
024280 DABS .WORD DOCOL
024290  .WORD DUP,DPM,SEMIS
024300 ;<>
024310 L2508 .BYTE $83,"MIN"
024320  .WORD L2498
024330 MIN .WORD DOCOL
024340  .WORD OVER,OVER,GREAT,ZBRAN
024350 L2515 .WORD L2517-L2515
024360  .WORD SWAP
024370 L2517 .WORD DROP
024380  .WORD SEMIS
024390 ;<>
024400 L2523 .BYTE $83,"MAX"
024410  .WORD L2508
024420 MAX .WORD DOCOL
024430  .WORD OVER,OVER,LESS,ZBRAN
024440 L2530 .WORD L2532-L2530
024450  .WORD SWAP
024460 L2532 .WORD DROP
024470  .WORD SEMIS
024480 ;<>
024490 L2538 .BYTE $82,"M*"
024500  .WORD L2523
024510 MSTAR .WORD DOCOL
024520  .WORD OVER,OVER,XOR,TOR,ABS
024530  .WORD SWAP,ABS,USTAR,RFROM
024540  .WORD DPM,SEMIS
024550 ;<>
024560 L2556 .BYTE $82,"M/"
024570  .WORD L2538
024580 MSLAS .WORD DOCOL
024590  .WORD OVER,TOR,TOR,DABS,R,ABS
024600  .WORD USLAS,RFROM,R,XOR,PM
024610  .WORD SWAP,RFROM,PM,SWAP,SEMIS
024620 ;<>
024630 L2579 .BYTE $81,"*"
024640  .WORD L2556
024650 STAR .WORD DOCOL
024660  .WORD USTAR,DROP,SEMIS
024670 ;<>
024680 L2589 .BYTE $84,"/MOD"
024690  .WORD L2579
024700 SLMOD .WORD DOCOL
024710  .WORD TOR,STOD,RFROM,MSLAS
024720  .WORD SEMIS
024730 ;<>
024740 L2601 .BYTE $81,"/"
024750  .WORD L2589
024760 SLASH .WORD DOCOL
024770  .WORD SLMOD,SWAP,DROP,SEMIS
024780 ;<>
024790 L2612 .BYTE $83,"MOD"
024800  .WORD L2601
024810 MOD .WORD DOCOL
024820  .WORD SLMOD,DROP,SEMIS
024830 ;<>
024840 L2622 .BYTE $85,"*/MOD"
024850  .WORD L2612
024860 SSMOD .WORD DOCOL
024870  .WORD TOR,MSTAR,RFROM,MSLAS
024880  .WORD SEMIS
024890 ;<>
024900 L2634 .BYTE $82,"*/"
024910  .WORD L2622
024920 SSLAS .WORD DOCOL
024930  .WORD SSMOD,SWAP,DROP,SEMIS
024940 ;<>
024950 L2645 .BYTE $85,"M/MOD"
024960  .WORD L2634
024970 MSMOD .WORD DOCOL
024980  .WORD TOR,ZERO,R,USLAS,RFROM
024990  .WORD SWAP,TOR,USLAS,RFROM
025000  .WORD SEMIS
025010 ;<>
025020 L2662 .BYTE $83,"USE"
025030  .WORD L2645
025040 USE .WORD DOVAR
025050  .WORD DAREA
025060 ;<>
025070 L2670 .BYTE $84,"PREV"
025080  .WORD L2662
025090 PREV .WORD DOVAR
025100  .WORD DAREA
025110 ;<>
025120 L2678 .BYTE $84,"+BUF"
025130  .WORD L2670
025140 PBUF .WORD DOCOL
025150  .WORD LIT
025160  .WORD SSIZE+4 holds block #, one sector, two nu..
025170  .WORD PLUS,DUP,LIMIT,EQUAL
025180  .WORD ZBRAN
025190 L2688 .WORD L2691-L2688
025200  .WORD DROP,FIRST
025210 L2691 .WORD DUP
025220  .WORD PREV,AT,SUB,SEMIS
025230 ;<>
025240 L2700 .BYTE $86,"UPDATE"
025250  .WORD L2678
025260 UPDAT .WORD DOCOL
025270  .WORD PREV,AT,AT,LIT,$8000
025280  .WORD OR,PREV,AT,STORE,SEMIS
025290 ;<>
025300 L2716 .BYTE $8D,"EMPTY-BUFFERS"
025310  .WORD L2700
025320 EMPTY .WORD DOCOL
025330  .WORD FIRST,LIMIT,OVER,SUB
025340  .WORD ERASE,SEMIS
025350 ;<>
025360 L2729 .BYTE $83,"DR0"
025370  .WORD L2716
025380 DR0 .WORD DOCOL
025390  .WORD ZERO,OFSET,STORE,SEMIS
025400 ;<>
025410 L2740 .BYTE $83,"DR1"
025420  .WORD L2729
025430  .WORD DOCOL
025440  .WORD LIT,SECTR sectors per drive
025450  .WORD OFSET,STORE,SEMIS
025460 ;<>
025470 L2751 .BYTE $86,"BUFFER"
025480  .WORD L2740
025490 BUFFR .WORD DOCOL
025500  .WORD USE,AT,DUP,TOR
025510 L2758 .WORD PBUF
025520  .WORD ZBRAN
025530 L2760 .WORD L2758-L2760
025540  .WORD USE,STORE,R,AT,ZLESS
025550  .WORD ZBRAN
025560 L2767 .WORD L2776-L2767
025570  .WORD R,TWOP,R,AT,LIT,$7FFF
025580  .WORD ANDD,ZERO,RSLW
025590 L2776 .WORD R
025600  .WORD STORE,R,PREV,STORE
025610  .WORD RFROM,TWOP,SEMIS
025620 ;<>
025630 L2788 .BYTE $85,"BLOCK"
025640  .WORD L2751
025650 BLOCK .WORD DOCOL
025660  .WORD OFSET,AT,PLUS,TOR,PREV
025670  .WORD AT,DUP,AT,R,SUB,DUP
025680  .WORD PLUS,ZBRAN
025690 L2804 .WORD L2830-L2804
025700 L2805 .WORD PBUF
025710  .WORD ZEQU,ZBRAN
025720 L2808 .WORD L2818-L2808
025730  .WORD DROP,R,BUFFR,DUP,R,ONE
025740  .WORD RSLW,TWO,SUB
025750 L2818 .WORD DUP
025760  .WORD AT,R,SUB,DUP,PLUS,ZEQU
025770  .WORD ZBRAN
025780 L2826 .WORD L2805-L2826
025790  .WORD DUP,PREV,STORE
025800 L2830 .WORD RFROM
025810  .WORD DROP,TWOP
025820  .WORD SEMIS end of block
025830 ;<>
025840 L2833 .BYTE $85,"FLUSH"
025850  .WORD L2788
025860 FLUSH .WORD DOCOL
025870  .WORD LIMIT,FIRST,SUB,BBUF
025880  .WORD CLIT
025890  .BYTE 4
025900  .WORD PLUS,SLASH,ONEP,ZERO,PDO
025910 L2835 .WORD LIT,$7FFF,BUFFR
025920  .WORD DROP,PLOOP
025930  .WORD L2835-*
025940  .WORD SEMIS
025950 ;<>
025960 L2838 .BYTE $86,"(LINE)"
025970  .WORD L2833
025980 PLINE .WORD DOCOL
025990  .WORD TOR,CSLL,BBUF,SSMOD
026000  .WORD RFROM,BSCR,STAR,PLUS
026010  .WORD BLOCK,PLUS,CSLL,SEMIS
026020 ;<>
026030 L2857 .BYTE $85,".LINE"
026040  .WORD L2838
026050 DLINE .WORD DOCOL
026060  .WORD PLINE,DTRAI,TYPE,SEMIS
026070 ;<>
026080 L2868 .BYTE $87,"MESSAGE"
026090  .WORD L2857
026100 MESS .WORD DOCOL
026110  .WORD WARN,AT,ZBRAN
026120 L2874 .WORD L2888-L2874
026130  .WORD DDUP,ZBRAN
026140 L2877 .WORD L2886-L2877
026150  .WORD CLIT
026160  .BYTE 4
026170  .WORD OFSET,AT,BSCR,SLASH,SUB
026180  .WORD DLINE
026190 L2886 .WORD BRAN
026200 L2887 .WORD L2891-L2887
026210 L2888 .WORD PDOTQ
026220  .BYTE 6,"MSG # "
026230  .WORD DOT
026240 L2891 .WORD SEMIS
026250 ;<>
026260 L2896 .BYTE $84,"LOAD"
026270  .WORD L2868
026280 LOAD .WORD DOCOL
026290  .WORD BLK,AT,TOR,IN,AT,TOR
026300  .WORD ZERO,IN,STORE,BSCR,STAR
026310  .WORD BLK,STORE,INTER,RFROM
026320  .WORD IN,STORE,RFROM,BLK
026330  .WORD STORE,SEMIS
026340 ;<>
026350 L2924 .BYTE $C3,"-->"
026360  .WORD L2896
026370  .WORD DOCOL
026380  .WORD QLOAD,ZERO,IN,STORE,BSCR
026390  .WORD BLK,AT,OVER,MOD,SUB,BLK
026400  .WORD PSTOR,SEMIS
026410 ;<>
026420 XEMIT TYA write one ASCII char to terminal
026430  SEC
026440  LDY #$1A
026450  ADC (UP),Y
026460  STA (UP),Y
026470  INY bump user variable OUT
026480  LDA #0
026490  ADC (UP),Y
026500  STA (UP),Y
026510  LDA 0,X fetch char to output
026520  STX XSAVE
026530  JSR OUTCH and display it
026540  LDX XSAVE
026550  JMP POP
026560 ;<>
026570 XKEY STX XSAVE read one terminal keystroke to stack
026590  JSR INCH
026600  LDX XSAVE
026610  JMP PUSH0A
026620 ;<>
026630 XQTER LDA #0 assume no BREAK
026640  LDY $11 check BRKKEY
026645  BNE XQTER2 branch if no BRK
026650  LDA #1 indicate BREAK
026652  STA $11 reset BRKKEY
026654  BNE XQTER3
026656 XQTER2 LDY BRFLG check term I/O break flag
026658  BEQ XQTER3 no break during I/O
026660  LDA #1 indicate break
026662 XQTER3 LDY #0 clear BRFLG
026664  STY BRFLG
026666  JMP PUSH0A
026670 ;<>
026680 XCR STX XSAVE display CR/LF to terminal
026690  LDA #$9B EOL
026692  JSR OUTCH
026700  LDX XSAVE
026710  JMP NEXT
026715 ;
026720 ; Terminal Handler
026725 ;
026730 GOVEC TAY indirect jump to handler
026735  LDA $E401,X
026740  PHA
026745  LDA $E400,X
026750  PHA
026755  TYA
026760  RTS
026765 ;
026770 OUTCH LDX #$6 put byte to editor
026775  JSR GOVEC
026780  CPY #$80
026785  BEQ BREAK
026790  RTS
026795 ;
026800 BREAK INC BRFLG break key hit
026805  RTS
026810 BRFLG .BYTE 0 break during I/O flag
026815 ;
026820 INCH LDX #$24 get byte from keyboard
026825  JSR GOVEC
026830  CPY #$80
026835  BEQ BREAK
026840  RTS
027230 ;<>
027240 L3202 .BYTE $C1,"'"
027250  .WORD L2924
027260 TICK .WORD DOCOL
027270  .WORD DFIND,ZEQU,ZERO,QERR
027280  .WORD DROP,LITER,SEMIS
027290 ;<>
027300 L3217 .BYTE $86,"FORGET"
027310  .WORD L3202
027320 FORG .WORD DOCOL
027330  .WORD TICK,NFA,DUP
027340  .WORD FENCE,AT,ULESS,CLIT
027350  .BYTE $15
027360  .WORD QERR,TOR,VOCL,AT
027370 L3220 .WORD R,OVER,ULESS,ZBRAN
027380  .WORD L3225-*
027390  .WORD FORTH,DEFIN,AT,DUP
027400  .WORD VOCL,STORE
027410  .WORD BRAN
027420  .WORD L3220-*
027430 L3225 .WORD DUP,CLIT
027440  .BYTE 4
027450  .WORD SUB
027460 L3228 .WORD PFA,LFA,AT
027470  .WORD DUP,R,ULESS,ZBRAN
027480  .WORD L3228-*
027490  .WORD OVER,TWO,SUB,STORE
027500  .WORD AT,DDUP,ZEQU,ZBRAN
027510  .WORD L3225-*
027520  .WORD RFROM,DP,STORE
027530  .WORD SEMIS
027540 ;<>
027550 L3250 .BYTE $84,"BACK"
027560  .WORD L3217
027570 BACK .WORD DOCOL
027580  .WORD HERE,SUB,COMMA,SEMIS
027590 ;<>
027600 L3261 .BYTE $C5,"BEGIN"
027610  .WORD L3250
027620  .WORD DOCOL
027630  .WORD QCOMP,HERE,ONE,SEMIS
027640 ;<>
027650 L3273 .BYTE $C5,"ENDIF"
027660  .WORD L3261
027670 ENDIF .WORD DOCOL
027680  .WORD QCOMP,TWO,QPAIR,HERE
027690  .WORD OVER,SUB,SWAP,STORE
027700  .WORD SEMIS
027710 ;<>
027720 L3290 .BYTE $C4,"THEN"
027730  .WORD L3273
027740  .WORD DOCOL
027750  .WORD ENDIF,SEMIS
027760 ;<>
027770 L3300 .BYTE $C2,"DO"
027780  .WORD L3290
027790  .WORD DOCOL
027800  .WORD COMP,PDO,HERE,THREE
027810  .WORD SEMIS
027820 ;<>
027830 L3313 .BYTE $C4,"LOOP"
027840  .WORD L3300
027850  .WORD DOCOL
027860  .WORD THREE,QPAIR,COMP,PLOOP
027870  .WORD BACK,SEMIS
027880 ;<>
027890 L3327 .BYTE $C5,"+LOOP"
027900  .WORD L3313
027910  .WORD DOCOL
027920  .WORD THREE,QPAIR,COMP,PPLOO
027930  .WORD BACK,SEMIS
027940 ;<>
027950 L3341 .BYTE $C5,"UNTIL"
027960  .WORD L3327
027970 UNTIL .WORD DOCOL
027980  .WORD ONE,QPAIR,COMP,ZBRAN
027990  .WORD BACK,SEMIS
028000 ;<>
028010 L3355 .BYTE $C3,"END"
028020  .WORD L3341
028030  .WORD DOCOL
028040  .WORD UNTIL,SEMIS
028050 ;<>
028060 L3365 .BYTE $C5,"AGAIN"
028070  .WORD L3355
028080 AGAIN .WORD DOCOL
028090  .WORD ONE,QPAIR,COMP,BRAN
028100  .WORD BACK,SEMIS
028110 ;<>
028120 L3379 .BYTE $C6,"REPEAT"
028125  .WORD L3365
028130  .WORD DOCOL
028140  .WORD TOR,TOR,AGAIN,RFROM
028150  .WORD RFROM,TWO,SUB,ENDIF
028160  .WORD SEMIS
028170 ;<>
028180 L3396 .BYTE $C2,"IF"
028190  .WORD L3379
028200 IF .WORD DOCOL
028210  .WORD COMP,ZBRAN,HERE,ZERO
028220  .WORD COMMA,TWO,SEMIS
028230 ;<>
028240 L3411 .BYTE $C4,"ELSE"
028250  .WORD L3396
028260  .WORD DOCOL
028270  .WORD TWO,QPAIR,COMP,BRAN,HERE
028280  .WORD ZERO,COMMA,SWAP,TWO
028290  .WORD ENDIF,TWO,SEMIS
028300 ;<>
028310 L3431 .BYTE $C5,"WHILE"
028320  .WORD L3411
028330  .WORD DOCOL
028340  .WORD IF,TWOP,SEMIS
028350 ;<>
028360 L3442 .BYTE $86,"SPACES"
028370  .WORD L3431
028380 SPACS .WORD DOCOL
028390  .WORD ZERO,MAX,DDUP,ZBRAN
028400 L3449 .WORD L3455-L3449
028410  .WORD ZERO,PDO
028420 L3452 .WORD SPACE
028430  .WORD PLOOP
028440 L3454 .WORD L3452-L3454
028450 L3455 .WORD SEMIS
028460 ;<>
028470 L3460 .BYTE $82,"<#"
028480  .WORD L3442
028490 BDIGS .WORD DOCOL
028500  .WORD PAD,HLD,STORE,SEMIS
028510 ;<>
028520 L3471 .BYTE $82,"#>"
028530  .WORD L3460
028540 EDIGS .WORD DOCOL
028550  .WORD DROP,DROP,HLD,AT,PAD
028560  .WORD OVER,SUB,SEMIS
028570 ;<>
028580 L3486 .BYTE $84,"SIGN"
028590  .WORD L3471
028600 SIGN .WORD DOCOL
028610  .WORD ROT,ZLESS,ZBRAN
028620 L3492 .WORD L3496-L3492
028630  .WORD CLIT
028640  .BYTE $2D
028650  .WORD HOLD
028660 L3496 .WORD SEMIS
028670 ;<>
028680 L3501 .BYTE $81,"#"
028690  .WORD L3486
028700 DIG .WORD DOCOL
028710  .WORD BASE,AT,MSMOD,ROT,CLIT
028720  .BYTE 9
028730  .WORD OVER,LESS,ZBRAN
028740 L3513 .WORD L3517-L3513
028750  .WORD CLIT
028760  .BYTE 7
028770  .WORD PLUS
028780 L3517 .WORD CLIT
028790  .BYTE $30
028800  .WORD PLUS,HOLD,SEMIS
028810 ;<>
028820 L3526 .BYTE $82,"#S"
028830  .WORD L3501
028840 DIGS .WORD DOCOL
028850 L3529 .WORD DIG
028860  .WORD OVER,OVER,OR,ZEQU,ZBRAN
028870 L3535 .WORD L3529-L3535
028880  .WORD SEMIS
028890 ;<>
028900 L3541 .BYTE $83,"D.R"
028910  .WORD L3526
028920 DDOTR .WORD DOCOL
028930  .WORD TOR,SWAP,OVER,DABS
028940  .WORD BDIGS,DIGS,SIGN,EDIGS
028950  .WORD RFROM,OVER,SUB,SPACS
028960  .WORD TYPE,SEMIS
028970 ;<>
028980 L3562 .BYTE $82,"D."
028990  .WORD L3541
029000 DDOT .WORD DOCOL
029010  .WORD ZERO,DDOTR,SPACE,SEMIS
029020 ;<>
029030 L3573 .BYTE $82,".R"
029040  .WORD L3562
029050 DOTR .WORD DOCOL
029060  .WORD TOR,STOD,RFROM,DDOTR
029070  .WORD SEMIS
029080 ;<>
029090 L3585 .BYTE $81,"."
029100  .WORD L3573
029110 DOT .WORD DOCOL
029120  .WORD STOD,DDOT,SEMIS
029130 ;<>
029140 L3595 .BYTE $81,"?"
029150  .WORD L3585
029160 QUES .WORD DOCOL
029170  .WORD AT,DOT,SEMIS
029180 ;<>
029190 L3605 .BYTE $84,"LIST"
029200  .WORD L3595
029210 LIST .WORD DOCOL
029220  .WORD DECIM,CR,DUP,SCR,STORE
029230  .WORD PDOTQ
029240  .BYTE 6,"SCR # "
029250  .WORD DOT,CLIT
029260  .BYTE 16
029270  .WORD ZERO,PDO
029280 L3620 .WORD CR
029290  .WORD I,THREE,DOTR,SPACE,I
029300  .WORD SCR,AT,DLINE,PLOOP
029310 L3630 .WORD L3620-L3630
029320  .WORD CR,SEMIS
029330 ;<>
029340 L3637 .BYTE $85,"INDEX"
029350  .WORD L3605
029360  .WORD DOCOL
029370  .WORD CR,ONEP,SWAP,PDO
029380 L3647 .WORD CR
029390  .WORD I,THREE,DOTR,SPACE,ZERO
029400  .WORD I,DLINE,QTERM,ZBRAN
029410 L3657 .WORD L3659-L3657
029420  .WORD LEAVE
029430 L3659 .WORD PLOOP
029440 L3660 .WORD L3647-L3660
029450  .WORD CR,CR
029480  .WORD SEMIS
029490 ;<>
029500 L3666 .BYTE $85,"TRIAD"
029510  .WORD L3637
029520  .WORD DOCOL
029530  .WORD THREE,SLASH,THREE,STAR
029540  .WORD THREE,OVER,PLUS,SWAP
029550  .WORD PDO
029560 L3681 .WORD CR
029570  .WORD I,LIST,PLOOP
029580 L3685 .WORD L3681-L3685
029590  .WORD CR,CLIT
029600  .BYTE $F
029610  .WORD MESS,CR,CR,CR
029640  .WORD SEMIS
029650 ;<>
029660 L3696 .BYTE $85,"VLIST"
029670  .WORD L3666
029680 VLIST .WORD DOCOL
029690  .WORD CLIT
029700  .BYTE $80
029710  .WORD OUT,STORE,CON,AT,AT
029720 L3706 .WORD OUT
029730  .WORD AT,CSLL,GREAT,ZBRAN
029740 L3711 .WORD L3716-L3711
029750  .WORD CR,ZERO,OUT,STORE
029760 L3716 .WORD DUP
029770  .WORD IDDOT,SPACE,SPACE,PFA
029780  .WORD LFA,AT,DUP,ZEQU
029790  .WORD QTERM,OR,ZBRAN
029800 L3728 .WORD L3706-L3728
029810  .WORD DROP
029820  .WORD SEMIS
040000 ;<>
040002 ; get n-th item from stack:
040004 ;  n --> m
040010 L4001 .BYTE $84,"PICK"
040020  .WORD L3696
040030 PICK .WORD *+2
040040  LDA 0,X
040050  ASL A
040060  STX XSAVE
040070  CLC
040080  ADC XSAVE
040090  TAY
040100  LDA 0,Y
040110  STA 0,X
040120  LDA 1,Y
040130  STA 1,X
040140  JMP NEXT
040150 ;<>
040160 ; call CIO
040170 ;  iocb cmd -->
040180 L4018 .BYTE $86,"JSRCIO"
040190  .WORD L4001
040198 JSRCIO .WORD *+2
040200  LDY 2,X get iocb offset
040210  LDA 0,X store command
040220  STA $342,Y
040230  INX
040240  INX
040250  INX
040260  INX
040270  STX XSAVE
040280  TYA
040290  TAX
040300  JSR $E456 (CIOV)
040310  STY PSTAT+2 store status
040320  LDX XSAVE
040330  JMP NEXT
040340 ;<>
040350 ;  status of previous CIO op
040360 L4036 .BYTE $86,"(STAT)"
040370  .WORD L4018
040380 PSTAT .WORD DOVAR
040390  .WORD 0
040400 ;<>
040410 ;  disk error abort
040420 ;  -->
040430 ; : ?DISKERROR
040440 ;  (STAT) @ 7F >   error if >80
040450 ;  IF
040460 ;   BASE @ HEX     save base
040470 ;   HERE COUNT TYPE print word
040480 ;   ."  ? DISK ERROR "
040490 ;   (STAT) @ .     print err #
040500 ;   BASE !         restore base
040510 ;   SP! IN @ BLK @ QUIT
040512 ;  ENDIF ;
040520 L4052 .BYTE $8A,"?DISKERROR"
040530  .WORD L4036
040540 DSKER .WORD DOCOL
040550  .WORD PSTAT,AT,CLIT
040560  .BYTE $7F
040570  .WORD GREAT,ZBRAN
040572  .WORD L4064-*
040580  .WORD BASE,AT,HEX
040590  .WORD HERE,COUNT,TYPE,PDOTQ
040600  .BYTE 14," ? DISK ERROR "
040610  .WORD PSTAT,AT,DOT
040620  .WORD BASE,STORE
040630  .WORD SPSTO,IN,AT,BLK,AT,QUIT
040640 L4064 .WORD SEMIS
040650 ;<>
040660 ; point to block on disk, update
040670 ; DCB if necessary
040680 ;  blk dcb -->
040690 ; : (POINT)
040760 ; BEGIN        read blocks until needed block found
040770 ;  DUP 3 + @   get latest blk #
040780 ;  3 PICK <    check if found yet
040790 ; WHILE
040792 ;  DUP 2+ C@   end-of-file?
040794 ;  IF 6 ERROR ENDIF error if so
040800 ;  (RDNXTBLK)  read next block
040810 ; REPEAT       block now mapped
040830 ; DUP C@       get iocb #
040840 ; ROT ROT      put it down stack
040850 ; 19 +         offset to block entry in DCB
040860 ; SWAP
040870 ; 3 * +        compute offset for block
040880 ; DUP @        get sector #
040890 ; SWAP 2+ C@   get disp
040900 ; POINT ?DISKERROR ; point to block
040910 L4091 .BYTE $87,"(POINT)"
040920  .WORD L4052
040930 PPOIN .WORD DOCOL
041010 L4101 .WORD DUP,THREE,PLUS,AT
041020  .WORD THREE,PICK,LESS,ZBRAN
041030  .WORD L4105-*
041031  .WORD DUP,TWOP,CAT,ZBRAN
041032  .WORD L4104-*
041033  .WORD CLIT
041034  .BYTE 6
041035  .WORD ERROR
041040 L4104 .WORD PRDNX,BRAN
041042  .WORD L4101-*
041050 L4105 .WORD DUP,CAT,ROT,ROT,CLIT
041060  .BYTE 19
041070  .WORD PLUS,SWAP
041080  .WORD THREE,STAR,PLUS,DUP
041090  .WORD AT,SWAP,TWOP,CAT
041100  .WORD POINT,DSKER,SEMIS
041110 ;<>
041120 ; mark new block in DCB
041130 ;  dcb --> dcb
041140 ; : (NEWBLK)
041150 ; (STAT) @ 3 =   end-of-file?
041160 ; IF
041170 ;  DUP 2+ 1
041180 ;  SWAP C!       make blk count pos.(all file mapped)
041190 ; ELSE
041200 ;  DUP 3 + DUP 1
041210 ;  SWAP +!       inc blk #(neg.)
041220 ;  @             fetch blk #
041230 ;  3 * 19 + OVER + offset in DCB
041240 ;  >R            store offset on ret. stk
041250 ;  DUP C@        get iocb #
041260 ;  NOTE ?DISKERROR get pos. in file
041270 ;  R 2+ C!       store disp
041280 ;  R> !          store sector
041290 ; ENDIF ;
041300 L4130 .BYTE $88,"(NEWBLK)"
041310  .WORD L4091
041320 PNEWB .WORD DOCOL
041330  .WORD PSTAT,AT,THREE,EQUAL
041340  .WORD ZBRAN
041342  .WORD L4137-*
041350  .WORD DUP,TWOP,ONE
041360  .WORD SWAP,CSTOR,BRAN
041362  .WORD L4144-*
041370 L4137 .WORD DUP,THREE,PLUS,DUP
041380  .WORD ONE,SWAP,PSTOR,AT
041390  .WORD THREE,STAR,CLIT
041400  .BYTE 19
041410  .WORD PLUS,OVER,PLUS,TOR,DUP
041420  .WORD CAT,NOTE,DSKER,R,TWOP,CSTOR
041430  .WORD RFROM,STORE
041440 L4144 .WORD SEMIS
041450 ;<>
041460 ; read next block in file
041470 ;  dcb --> dcb
041480 ; : (RDNXTBLK)
041490 ; DUP 3 + @       next blk #
041500 ; OVER (POINT)    point in file
041510 ; USE @ @ <0      oldest buffer marked update?
041520 ; IF              read 1 byte at a time if so
041530 ;  B/BUF 0 DO     read 1 block
041540 ;   DUP C@        get iocb #
041550 ;   GET DROP      get/ignore byte
041555 ;  ?DISKERROR
041560 ;  LOOP
041570 ; ELSE            read 1 block
041580 ;  DUP C@         get icob #
041590 ;  USE @          use oldest buffer
041600 ;  7FFF OVER !    clear buffer blk #
041610 ;  2+ B/BUF GETBUF get buffer from disk
041620 ;  DROP           ignore length
041630 ;  ?DISKERROR
041640 ; ENDIF
041650 ; (NEWBLK) ;      update DCB for new block
041660 L4166 .BYTE $8A,"(RDNXTBLK)"
041670  .WORD L4130
041680 PRDNX .WORD DOCOL
041690  .WORD DUP,THREE,PLUS,AT,OVER
041700  .WORD PPOIN,USE,AT,AT,ZLESS,ZBRAN
041710  .WORD L4176-*,BBUF
041720  .WORD ZERO,PDO
041730 L4173 .WORD DUP,CAT,GET,DROP
041740  .WORD DSKER,PLOOP
041742  .WORD L4173-*,BRAN
041750  .WORD L4179-*
041760 L4176 .WORD DUP,CAT,USE,AT,LIT
041770  .WORD $7FFF,OVER,STORE,TWOP,BBUF
041780  .WORD GETBU,DROP,DSKER
041790 L4179 .WORD PNEWB,SEMIS
041800 ;<>
041810 ; get I/O status
041820 ;  iocb --> status
041830 ; : STATUS
041840 ; DUP #STATUS JSRCIO
041850 ; ICSTA + C@ ;
041860 L4186 .BYTE $86,"STATUS"
041870  .WORD L4166
041880 STATU .WORD DOCOL
041890  .WORD DUP,CLIT
041900  .BYTE $0D
041910  .WORD JSRCIO,LIT,$343
041920  .WORD PLUS,CAT,SEMIS
041930 ;<>
041940 ; open I/O
041950 ;  iocb aux1 aux2 nameaddr -->
041960 ; : OPEN
041970 ; 4 PICK          get iocb #
041980 ; DUP >R          put on ret stk
041990 ; ICBA + !        store name addr
042000 ; R ICAX2 + C!    store aux2
042010 ; R> ICAX1 + C!   store aux1
042020 ; #OPEN JSRCIO ;
042030 L4203 .BYTE $84,"OPEN"
042040  .WORD L4186
042050 OPEN .WORD DOCOL
042060  .WORD CLIT
042070  .BYTE 4
042080  .WORD PICK,DUP,TOR,LIT,$344
042090  .WORD PLUS,STORE,R,LIT,$34B
042100  .WORD PLUS,CSTOR,RFROM,LIT
042110  .WORD $34A,PLUS,CSTOR,CLIT
042120  .BYTE $03
042130  .WORD JSRCIO,SEMIS
042140 ;<>
042150 ; close file
042160 ;  iocb -->
042170 ; : CLOSE
042180 ; #CLOSE JSRCIO ;
042190 L4219 .BYTE $85,"CLOSE"
042200  .WORD L4203
042210 CLOSE .WORD DOCOL
042220  .WORD CLIT
042230  .BYTE $0C
042240  .WORD JSRCIO,SEMIS
042250 ;<>
042260 ; note position in file
042270 ;  iocb --> sector disp
042280 ; : NOTE
042290 ; DUP             save iocb #
042300 ; #NOTE JSRCIO
042310 ; DUP >R          put iocb # on ret stk
042320 ; ICAX3 + @       get sector #
042330 ; R> ICAX5 + C@ ; get disp
042340 L4234 .BYTE $84,"NOTE"
042350  .WORD L4219
042360 NOTE .WORD DOCOL
042370  .WORD DUP,CLIT
042380  .BYTE $26
042390  .WORD JSRCIO,DUP,TOR,LIT,$34C
042400  .WORD PLUS,AT,RFROM,LIT,$34E
042410  .WORD PLUS,CAT,SEMIS
042420 ;<>
042430 ; point to position in file
042440 ;  iocb sector disp -->
042450 ; : POINT
042460 ; 3 PICK          get iocb #
042470 ; ICAX5 + C!      store disp
042480 ; 2 PICK
042490 ; ICAX3 + !       store sector
042500 ; #POINT JSRCIO ;
042510 L4251 .BYTE $85,"POINT"
042520  .WORD L4234
042530 POINT .WORD DOCOL
042540  .WORD THREE,PICK,LIT,$34E,PLUS
042550  .WORD CSTOR,TWO,PICK,LIT,$34C
042560  .WORD PLUS,STORE,CLIT
042570  .BYTE $25
042580  .WORD JSRCIO,SEMIS
042590 ;<>
042600 ; internal GET
042610 ;  iocb addr len cmd --> len
042620 ; : (GET)
042630 ; >R              save command
042640 ; 3 PICK          get iocb #
042650 ; ICBLL + !       store buf len
042660 ; 2 PICK
042670 ; ICBAL + !       store buf addr
042680 ; DUP R> JSRCIO   do appropriate get
042690 ; ICBLL + @ ;     return length
042700 L4270 .BYTE $85,"(GET)"
042710  .WORD L4251
042720 PGET .WORD DOCOL
042730  .WORD TOR,THREE,PICK,LIT,$348
042740  .WORD PLUS,STORE,TWO,PICK
042750  .WORD LIT,$344,PLUS,STORE
042760  .WORD DUP,RFROM,JSRCIO,LIT
042770  .WORD $348,PLUS,AT,SEMIS
042780 ;<>
042790 ; get buffer I/O
042800 ;  iocb addr len --> len
042810 ; : GETBUF
042820 ; #GET (GET) ;
042830 L4283 .BYTE $86,"GETBUF"
042840  .WORD L4270
042850 GETBU .WORD DOCOL
042860  .WORD CLIT
042870  .BYTE $07
042880  .WORD PGET,SEMIS
042890 ;<>
042900 ; get record I/O
042910 ;  iocb addr len --> len
042920 ; : GETREC
042930 ; #GETREC (GET)
042940 L4294 .BYTE $86,"GETREC"
042950  .WORD L4283
042960 GETRE .WORD DOCOL
042970  .WORD CLIT
042980  .BYTE $05
042990  .WORD PGET,SEMIS
043000 ;<>
043010 ; get byte
043020 ;  iocb --> byte
043030 ; : GET
043040 ; XCH 1 GETBUF   get byte at XCH
043050 ; DROP           ignore length
043060 ; XCH C@ ;       get byte
043070 L4307 .BYTE $83,"GET"
043080  .WORD L4294
043090 GET .WORD DOCOL
043100  .WORD LIT,XCH,ONE,GETBU,DROP
043110  .WORD LIT,XCH,CAT,SEMIS
043112 XCH .BYTE 0 temp for character
043120 ;<>
043130 ; internal PUT
043140 ;  iocb addr len cmd -->
043150 ; : (PUT)
043160 ; >R             save command
043170 ; 3 PICK         get iocb
043180 ; ICBLL + !      save len
043190 ; 2 PICK
043200 ; ICBAL + !      save buf addr
043210 ; R> JSRCIO ;
043220 L4322 .BYTE $85,"(PUT)"
043230  .WORD L4307
043240 PPUT .WORD DOCOL
043250  .WORD TOR,THREE,PICK,LIT,$348
043260  .WORD PLUS,STORE,TWO,PICK,LIT
043270  .WORD $344,PLUS,STORE,RFROM
043280  .WORD JSRCIO,SEMIS
043290 ;<>
043300 ; put buffer I/O
043310 ;  iocb addr len -->
043320 ; : PUTBUF
043330 ; #PUT (PUT) ;
043340 L4334 .BYTE $86,"PUTBUF"
043350  .WORD L4322
043360 PUTBU .WORD DOCOL
043370  .WORD CLIT
043380  .BYTE $0B
043390  .WORD PPUT,SEMIS
043400 ;<>
043410 ; put record I/O
043420 ;  iocb addr len -->
043430 ; : PUTREC
043440 ; #PUTREC (PUT)
043450 L4345 .BYTE $86,"PUTREC"
043460  .WORD L4334
043470 PUTRE .WORD DOCOL
043480  .WORD CLIT
043490  .BYTE $09
043500  .WORD PPUT,SEMIS
043510 ;<>
043520 ; put byte
043530 ;  iocb byte -->
043540 ; : PUT
043550 ; XCH C!          store byte at XCH
043560 ; XCH 1 PUTBUF ;  put 1 byte
043570 L4357 .BYTE $83,"PUT"
043580  .WORD L4345
043590 PUTB .WORD DOCOL
043600  .WORD LIT,XCH,CSTOR,LIT,XCH,ONE
043610  .WORD PUTBU,SEMIS
043620 ;<>
043630 ; disk read/write for FORTH files
043640 ;  addr blk f -->
043650 ;  f=0(write),1(read)
043660 ; : R/W
043670 ; >R             save f
043680 ; DUP SECTR  >   blk>offset(DR1)?
043690 ; IF
043700 ;  SECTR -       subtract offset for DR1
043710 ;  DCB1
043720 ; ELSE
043730 ;  DCB0
043740 ; ENDIF          addr blk dcb --
043750 ; DUP 1+ C@ 0=   file open?
043760 ; IF             open if not
043770 ;  DUP C@        get iocb #
043780 ;  12 0          read/write
043790 ;  4 PICK 5 +    file name addr
043800 ;  OPEN ?DISKERROR
043802 ;  (INITDCB)     init DCB
043810 ; ENDIF
043812 ; OVER OVER      dup blk,dcb
043820 ; (POINT)        point to block
043830 ; DUP C@         get iocb #
043840 ; 4 PICK         buffer addr
043850 ; B/BUF          size of block
043860 ; R              get f
043870 ; IF
043880 ;  GETBUF DROP
043890 ; ELSE
043900 ;  PUTBUF
043910 ; ENDIF
043920 ; ?DISKERROR
043930 ; DUP 3 + @      get blk #
043940 ; 3 PICK =       new block?
043950 ; IF
043960 ;  (NEWBLK)      update DCB
043970 ; ENDIF
043972 ; R>             get f
043974 ; IF
043980 ;  DROP DROP     pop stack for read
043982 ; ELSE
043984 ;  (POINT)       point to beginning of block(to flush last sector, bug in DOS)
043986 ; ENDIF DROP ;
043990 L4399 .BYTE $83,"R/W"
044000  .WORD L4357
044010 RSLW .WORD DOCOL
044020  .WORD TOR,DUP,LIT,SECTR,GREAT,ZBRAN
044030  .WORD L4406-*
044040  .WORD LIT,SECTR,SUB,LIT,DCB1,BRAN
044050  .WORD L4407-*
044060 L4406 .WORD LIT,DCB0
044070 L4407 .WORD DUP,ONEP,CAT,ZEQU,ZBRAN
044080  .WORD L4415-*
044090  .WORD DUP,CAT,CLIT
044100  .BYTE 12
044110  .WORD ZERO,CLIT
044120  .BYTE 4
044130  .WORD PICK,CLIT
044132  .BYTE 5
044134  .WORD PLUS,OPEN
044140  .WORD DSKER,PIND
044150 L4415 .WORD OVER,OVER,PPOIN,DUP,CAT,CLIT
044160  .BYTE 4
044170  .WORD PICK,BBUF,R,ZBRAN
044180  .WORD L4421-*
044190  .WORD GETBU,DROP,BRAN
044200  .WORD L4422-*
044210 L4421 .WORD PUTBU
044220 L4422 .WORD DSKER,DUP,THREE,PLUS
044230  .WORD AT,THREE,PICK,EQUAL,ZBRAN
044240  .WORD L4426-*
044250  .WORD PNEWB
044260 L4426 .WORD RFROM,ZBRAN
044262  .WORD L44266-*,DROP,DROP,BRAN
044264  .WORD L4427-*
044266 L44266 .WORD PPOIN
044270 L4427 .WORD DROP,SEMIS
044280 ;<>
044290 L4429 .BYTE $86,"MEMTOP"
044300  .WORD L4399
044310 MEMTOP .WORD DOCON
044320  .WORD $2E5 top of user memory
044330 ;<>
044340 ; initialize DCB after OPEN
044350 ;  dcb --> dcb
044360 ; : (INITDCB)
044370 ; DUP 1+ 1 SWAP C! file open
044380 ; DUP 2+ 0 SWAP C! no eof
044390 ; DUP 3 + 1 SWAP ! max block=1
044400 ; DUP C@           get iocb
044410 ; NOTE ?DISKERROR  get pos of first block
044420 ; 3 PICK 24 +      offset to first disp
044430 ; C!               store disp
044440 ; OVER 22 + ! ;    store sector
044450 L4445 .BYTE $89,"(INITDCB)"
044460  .WORD L4429
044470 PIND .WORD DOCOL
044480  .WORD DUP,ONEP,ONE,SWAP,CSTOR
044490  .WORD DUP,TWOP,ZERO,SWAP,CSTOR
044500  .WORD DUP,THREE,PLUS,ONE,SWAP
044510  .WORD STORE,DUP,CAT,NOTE,DSKER
044520  .WORD THREE,PICK,CLIT
044530  .BYTE 24
044540  .WORD PLUS,CSTOR,OVER,CLIT
044550  .BYTE 22
044560  .WORD PLUS,STORE,SEMIS
044570 ;<>
044580 ; non-special character KEY
044590 ;  --> key
044600 ; : (KEY)
044610 ; BEGIN        loop until non-
044620 ;  KEY         special key
044630 ;  DUP 7E =    backspace?
044640 ;  OVER 9B = OR or EOL?
044650 ;  IF
044660 ;   0          set FALSE
044670 ;  ELSE
044680 ;   DUP 7F AND clear invert bit
044690 ;   DUP 1A >   1B - 1F
044700 ;   OVER 20 < AND
044710 ;   >R
044720 ;   DUP 7C >   7D - 7F
044730 ;   SWAP 80 < AND
044740 ;   R> OR      either one?
044750 ;  ENDIF
044760 ; WHILE
044770 ;  DROP        drop key value
044780 ; REPEAT ;
044790 L4479 .BYTE $85,"(KEY)"
044800  .WORD L4445
044810 PKEY .WORD DOCOL
044820 L4482 .WORD KEY,DUP,CLIT
044830  .BYTE $7E
044840  .WORD EQUAL,OVER,CLIT
044850  .BYTE $9B
044860  .WORD EQUAL,OR,ZBRAN
044870  .WORD L4489-*,ZERO,BRAN
044880  .WORD L4500-*
044890 L4489 .WORD DUP,CLIT
044900  .BYTE $7F
044910  .WORD ANDD,DUP,CLIT
044920  .BYTE $1A
044930  .WORD GREAT,OVER,CLIT
044940  .BYTE $20
044950  .WORD LESS,ANDD,TOR,DUP,CLIT
044960  .BYTE $7C
044970  .WORD GREAT,SWAP,CLIT
044980  .BYTE $80
044990  .WORD LESS,ANDD,RFROM,OR
045000 L4500 .WORD ZBRAN
045010  .WORD L4503-*,DROP,BRAN
045020  .WORD L4482-*
045030 L4503 .WORD SEMIS
045040 ;<>
045050 ; close DR0
045060 ;  -->
045070 ; : CLOSE-DR0
045080 ; 10 CLOSE      close iocb
045090 ; 0 DCB0+1 ! ;  clear DCB
045100 L4510 .BYTE $89,"CLOSE-DR0"
045110  .WORD L4479
045120 CLDR0 .WORD DOCOL
045130  .WORD CLIT
045140  .BYTE $10
045150  .WORD CLOSE,ZERO,LIT,DCB0+1
045160  .WORD STORE,SEMIS
045170 ;<>
045180 ; close DR1
045190 ;  -->
045200 ; : CLOSE-DR1
045210 ; 20 CLOSE
045220 ; 0 DCB1+1 ! ;
045230 L4523 .BYTE $89,"CLOSE-DR1"
045240  .WORD L4510
045250 CLDR1 .WORD DOCOL
045260  .WORD CLIT
045270  .BYTE $20
045280  .WORD CLOSE,ZERO,LIT,DCB1+1
045290  .WORD STORE,SEMIS
045300 ;<>
045310 ; DCB0 file name address
045320 ; DCB0+5 CONSTANT DR0NAME
045330 L4533 .BYTE $87,"DR0NAME"
045340  .WORD L4523
045350  .WORD DOCON,DCB0+5
045360 ;<>
045370 ; DCB1 file name address
045380 ; DCB1+5 CONSTANT DR1NAME
045390 L4539 .BYTE $87,"DR1NAME"
045400  .WORD L4533
045410  .WORD DOCON,DCB1+5
050000 ;<>
050010 NTOP .BYTE $83,"MON"
050020  .WORD L4539
050030 MON .WORD *+2
050031  RTS
050040  STX XSAVE
050050  BRK break to monitor
050060  LDX XSAVE use this as reentry point
050070  JMP NEXT
050080 ;<>
050090  .OPT LIST
050100 TOP .END
