Forth screen = 64 characters, 16 lines, 1k --> OOOOO OOOOO OOOOOOO O O O O O O O O O O OOOOOOO OOOOO O O O O O O O O O O O O O o O O o O o OOOOOO OOOO OOOOO OOOOOOO O O O O O O O O O O O O O O O O O O OOOOOO O O OOOOO O OOOOOOO O O O O O O O O O O O O O O O O O OOOO O O O O O \ ART Forth - load screen -CURSOR DECIMAL CR ." Load ART-Forth? " KEY DUP 78 = OVER 110 = OR IFTRUE ABORT THEN IFEND : IT ; : E-B EMPTY-BUFFERS ; : .SCR SCR @ 255 AND . ; : X BASE @ 10 = IF HEX ." hex " ELSE DECIMAL ." decimal " THEN ; THRU" ASM68.BLK" 200 LOAD ABORT --> Threaded Forth - vocabulary format 2 bytes : relative offset to next nfa in hashed chain 1 byte : length of object code in words, max 255 3 bytes : address of object code 1 byte : D7 = subr - forces call to routine D6 = inline - forces embedding within the using word, rather than a call, speeding execution D5 = don't optimise D0-D4 = word type: code/colon/variable/constant..etc 1 byte : D7 = precedence bit D6 = reserved D3-D5 = # stack words required on entry D0-D2 = # stack words left on exit 1 byte : D0-D4 = name count D5-D7 = vocabulary# (0-7), 0=FORTH, 1=TRANSIENT n bytes : variable length name, terminating on an even add-->s exit Threaded Forth - register usage A7 = return stack pointer A6 = parameter stack pointer A5 = pointer to start of object (constant=BASE.PTR) A4 = pointer to user area (constant=USER.PTR) Note: All short addressing other than the user area (eg/ variables) is relative to BP All other registers are available for temporary use. \ Set object & user table base 022886 ART HERE BASE.PTR ! \ set system base HERE CREATE BASE.PTR , CREATE USER.BASE HERE 512 DUP ALLOT ERASE \ User variables 030486 ART 0 USER FIRST.USER 12 USER S0 16 USER R0 44 USER DP 52 USER CONSOLE 68 USER CNT 72 USER COL 76 USER LINE# 80 USER BASE 84 USER DPL 88 USER HLD 92 USER STATE 96 USER TIB 100 USER BLK 104 USER >IN 108 USER OFFSET 120 USER TRUNK 128 USER FENCE 132 USER CSP 136 USER SCR 140 USER R# 152 USER ROW 176 USER CONTEXT 180 USER CURRENT 184 USER LAST.NFA 188 USER VOC.BASE 192 USER VOC.SIZE 196 USER LINK.PTR 140 USER LAST.BLK 8 USER BLK.ADDR \ 232 USER WNDTOP 236 USER WNDLEFT 240 USER WNDBOT \ 244 USER WNDRIGHT 248 USER FORCED.CR 252 USER WPTR 200 USER POCKET \ must be the last user until user#384 \ Pointer to voc.links 020186 ART create VOC.LINKS here 512 dup allot erase \ table contains positive offsets from voc.base LINK.PTR @ HERE 512 - 512 CMOVE HERE 512 - LINK.PTR ! \ I J >R R> R@ AND OR 020186 ART code I ( -- I ) rtop push, return INLINE code J ( -- J ) 8 rp i) push, return INLINE code >R ( n -- ) (sp)+ rpush, return INLINE code R> ( -- n ) rp )+ push, return INLINE code R@ ( -- n ) rtop push, return INLINE code AND ( a/b -- a&b ) D0 pop, top from D0 long and, return code OR ( a/b -- a+b ) D0 pop, top from D0 long or, return \ XOR @ W@ C@ @@ 020186 ART code XOR ( a/b -- a*b ) D0 pop, top D0 long eor, return code @ ( addr -- n ) A0 pop, A0 () push, return code W@ ( addr -- n ) A0 pop, 0 D0 moveq, A0 () D0 word move, D0 push, return code C@ ( addr -- n ) A0 pop, 0 D0 moveq, A0 () D0 byte move, D0 push, return code @@ ( addr -- n ) A0 pop, A0 () A1 lmove, A1 () push, return \ SP@ RP@ ;S LEAVE 0= 0< 0> 022386 ART code SP@ ( -- sp ) sp push, return code RP@ ( -- rp ) rp push, return INLINE code ;S ( -- ) return code LEAVE ( -- ) 4 rp i) rput, return INLINE code 0= ( n -- flag ) 0 D0 moveq, SP )+ long tst, eq if, -1 D0 moveq, then, D0 push, return code 0< ( n -- flag ) 0 D0 moveq, SP )+ long tst, mi if, -1 D0 moveq, then, D0 push, return code 0> ( n -- flag ) 0 D0 moveq, SP )+ long tst, gt if, -1 D0 moveq, then, D0 push, return \ CMOVE (FILL) 020186 ART code CMOVE ( addr/addr/cnt -- ) D0 POP, A1 POP, A0 POP, D0 1 LONG SUBQ, PL IF, D0 32767 LONG CMPI, LT IF, BEGIN, A0 )+ A1 )+ BYTE MOVE, D0 NEVER DBCC, ELSE, BEGIN, A0 )+ A1 )+ BYTE MOVE, D0 1 LONG SUBQ, MI UNTIL, THEN, THEN, RETURN code (FILL) ( addr/cnt -- | D1 contains char to fill with ) D0 POP, A0 POP, D0 1 LONG SUBQ, PL IF, D0 32767 LONG CMPI, LT IF, BEGIN, D1 A0 )+ BYTE MOVE, D0 NEVER DBCC, ELSE, BEGIN, D1 A0 )+ BYTE MOVE, D0 1 LONG SUBQ, MI UNTIL, THEN, THEN, RETURN INLINE \ FILL ERASE BLANKS 020186 ART code FILL ( addr/cnt/char -- ) D1 POP, [COMPILE] (FILL) RETURN code ERASE ( addr/cnt -- ) 0 D1 MOVEQ, [COMPILE] (FILL) RETURN code BLANKS ( addr/cnt -- ) 032 D1 MOVEQ, [COMPILE] (FILL) RETURN \ DUP>R I+ I- IC@ IC! I@ I! 020186 ART code DUP>R ( -- ) (sp) rpush, return INLINE code I+ ( n -- n ) rtop D0 lmove, top from D0 long add, return INLINE code I- ( n -- n ) rtop D0 lmove, top from D0 long sub, return INLINE code IC@ ( -- c ) 0 D0 moveq, rtop A0 lmove, A0 () D0 byte move, D0 push, return INLINE code IC! ( c -- ) D0 pop, rtop A0 lmove, D0 A0 () byte move, return INLINE code I@ ( -- n ) rtop A0 lmove, A0 () push, return INLINE code I! ( n -- ) rtop A0 lmove, A0 () pop, return INLINE \ @SR !SR SP! RP! SWAP-DROP 022586 ART CODE @SR ( -- status reg contents ) 0 D0 MOVEQ, D0 FROMSR, D0 PUSH, RETURN CODE !SR ( new status reg contents -- ) D0 POP, D0 TOSR, RETURN CODE SP! ( -- ) S0 )UP SP LMOVE, SP )+ D0 LMOVE, return CODE RP! ( -- ) R0 )UP RP LMOVE, return INLINE CODE SWAP-DROP ( a/b -- b ) SP )+ SP () LMOVE, RETURN \ I+@ I+! + - NEGATE 021686 ART code I+@ ( offset -- n ) A0 pop, rtop A0 long adda, A0 () push, return INLINE code I+! ( n/offset -- ) A0 pop, rtop A0 long adda, A0 () pop, return INLINE code + ( a/b -- a+b ) D0 pop, top from D0 long add, return code - ( a/b -- a-b ) D0 pop, top from D0 long sub, return code NEGATE ( n -- -n ) top long neg, return \ OVER ROT -ROT DROP NOT 021686 ART code OVER ( a/b -- a/b/a ) 4 sp i) push, return code ROT ( a/b/c -- b/c/a ) D0 pop, D1 pop, D2 pop, D1 push, D0 push, D2 push, return code -ROT ( a/b/c -- c/a/b ) D0 pop, D1 pop, D2 pop, D0 push, D2 push, D1 push, return code DROP ( n -- ) sp 4 long addq, return code NOT ( n -- flag ) 0 D0 moveq, top long tst, eq if, -1 D0 moveq, then, D0 put, return \ SWAP TOGGLE ! W! C! 021686 ART code SWAP ( a/b -- b/a ) D0 pop, D1 pop, D0 push, D1 push, return code TOGGLE ( addr/bit# -- ) D0 pop, A0 pop, A0 () D0 byte eor, return code ! ( n/addr -- ) A0 pop, A0 () pop, return code W! ( n/addr -- ) A0 pop, D0 pop, D0 A0 () word move, return code C! ( n/addr -- ) A0 pop, D0 pop, D0 A0 () byte move, return \ DUP ?DUP +! BS BL 021686 ART code DUP ( n -- n/n ) top push, return code ?DUP ( n -- n/n ) 1 7 (n--n) top long tst, ne if, top push, then, return code +! ( n/addr -- ) A0 pop, D0 pop, A0 () from D0 long add, return 08 constant BS 32 constant BL \ 1+ 2+ 3+ 4+ 5+ 6+ 7+ 8+ 9+ 10+ 16+ 020186 ART code 1+ ( n -- n+1 ) top 1 long addq, return code 2+ ( n -- n+2 ) top 2 long addq, return code 3+ ( n -- n+3 ) top 3 long addq, return code 4+ ( n -- n+4 ) top 4 long addq, return code 5+ ( n -- n+5 ) top 5 long addq, return code 6+ ( n -- n+6 ) top 6 long addq, return code 7+ ( n -- n+7 ) top 7 long addq, return code 8+ ( n -- n+8 ) top 8 long addq, return code 9+ ( n -- n+9 ) top 9 long addi, return code 10+ ( n -- n+10 ) top 10 long addi, return code 16+ ( n -- n+16 ) top 16 long addi, return \ 1- 2- 3- 4- 5- 6- 7- 8- 9- 10- 16- 020186 ART code 1- ( n -- n-1 ) top 1 long subq, return code 2- ( n -- n-2 ) top 2 long subq, return code 3- ( n -- n-3 ) top 3 long subq, return code 4- ( n -- n-4 ) top 4 long subq, return code 5- ( n -- n-5 ) top 5 long subq, return code 6- ( n -- n-6 ) top 6 long subq, return code 7- ( n -- n-7 ) top 7 long subq, return code 8- ( n -- n-8 ) top 8 long subq, return code 9- ( n -- n-9 ) top 9 long subi, return code 10- ( n -- n-10 ) top 10 long subi, return code 16- ( n -- n-16 ) top 16 long subi, return \ >W@< >W!< ON OFF 021686 ART code >W@< ( addr -- n ) A0 pop, 0 D0 moveq, A0 )+ D0 byte move, D0 8 # word asl, A0 () D0 byte move, D0 push, return code >W!< ( n/addr -- ) A0 pop, D0 pop, D0 1 A0 i) byte move, D0 8 # word asr, D0 A0 () byte move, return code ON ( addr -- ) A0 pop, -1 D0 moveq, D0 A0 () lmove, return code OFF ( addr -- ) A0 pop, 0 D0 moveq, D0 A0 () lmove, return \ 2@ 2! 2DUP 2OVER 2SWAP 2DROP 021686 ART code 2@ ( addr -- n/m) A0 get, 4 A0 i) put, A0 () push, return code 2! ( n/m/addr -- ) A0 pop, A0 )+ pop, A0 )+ pop, return code 2DUP ( a/b -- a/b/a/b) 4 sp i) push, 4 sp i) push, return code 2OVER ( a/b/c/d -- a/b/c/d/a/b ) 12 sp i) push, 12 sp i) push, return code 2SWAP ( a/b/c/d -- c/d/a/b ) D0 pop, D1 pop, D2 pop, D3 pop, D1 push, D0 push, D3 push, D2 push, return code 2DROP ( a/b -- ) sp 8 long addq, return \ PICK 0MAX 0MIN 030686 ART code PICK ( depth -- n ) D0 get, D0 2 # word asl, sp to D0 long add, D0 A0 lmove, A0 () put, return code 0MAX ( n -- n or 0 ) top long tst, lt if, 0 D0 moveq, D0 put, then, return code 0MIN ( n -- n or 0 ) top long tst, gt if, 0 D0 moveq, D0 put, then, return \ 2* 4* 8* 16* 32* 64* 128* 256* 020186 ART code 2* ( n -- 2n ) D0 get, top from D0 long add, return code 4* ( n -- 4n ) D0 pop, D0 2 # long asl, D0 push, return code 8* ( n -- 8n ) D0 pop, D0 3 # long asl, D0 push, return code 16* ( n -- 16n ) D0 pop, D0 4 # long asl, D0 push, return code 32* ( n -- 32n ) D0 pop, D0 5 # long asl, D0 push, return code 64* ( n -- 64n ) D0 pop, D0 6 # long asl, D0 push, return code 128* ( n -- 128n ) D0 pop, D0 7 # long asl, D0 push, return code 256* ( n -- 256n ) D0 pop, D0 8 # long asl, D0 push, return \ 2/ 4/ 8/ 16/ 32/ 64/ 128/ 256/ 020186 ART code 2/ ( n -- n/2 ) D0 pop, D0 1 # long asr, D0 push, return code 4/ ( n -- n/4 ) D0 pop, D0 2 # long asr, D0 push, return code 8/ ( n -- n/8 ) D0 pop, D0 3 # long asr, D0 push, return code 16/ ( n -- n/16 ) D0 pop, D0 4 # long asr, D0 push, return code 32/ ( n -- n/32 ) D0 pop, D0 5 # long asr, D0 push, return code 64/ ( n -- n/64 ) D0 pop, D0 6 # long asr, D0 push, return code 128/ ( n -- n/128) D0 pop, D0 7 # long asr, D0 push, return code 256/ ( n -- n/256) D0 pop, D0 8 # long asr, D0 push, return \ DO-LOOP construct 021686 ART code (DO) ( limit\start -- | pushes onto return stack ) 4 sp i) rpush, top rpush, sp 8 long addq, return INLINE code (B.LOOP) ( -- | version for <128 byte branch) rp () 1 long addq, rp A0 lmove, A0 A0 long cmpm, here gt bcc, rp 8 long addq, return INLINE code (W.LOOP) ( -- | version for >128 byte branch) rp () 1 long addq, rp A0 lmove, A0 A0 long cmpm, here 200 - gt bcc, rp 8 long addq, return INLINE \ B+LOOP & W+LOOP constructs 021686 ART code (B+LOOP) ( increment -- | <128 byte branch ) D0 pop, rtop from D0 long add, D0 long tst, ge if, rp A0 long move, A0 A0 long cmpm, here gt bcc, here 8 + allways bcc, then, rp A0 long move, A0 A0 long cmpm, here le bcc, ( exit ) rp 8 long addq, return INLINE code (W+LOOP) ( increment -- | >128 byte branch ) D0 pop, rtop from D0 long add, D0 long tst, ge if, rp A0 long move, A0 A0 long cmpm, here 200 - gt bcc, here 10 + allways bcc, then, rp A0 long move, A0 A0 long cmpm, here 200 - le bcc, ( exit ) rp 8 long addq, return INLINE \ B++LOOP & W++LOOP constructs 021686 ART code (B++LOOP) ( increment -- | +ve looping ) D0 pop, rtop from D0 long add, rp A0 long move, A0 A0 long cmpm, here gt bcc, rp 8 long addq, return INLINE code (W++LOOP) ( increment -- | +ve looping ) D0 pop, rtop from D0 long add, rp A0 long move, A0 A0 long cmpm, here 200 - gt bcc, rp 8 long addq, return INLINE \ BEGIN-UNTIL & IF-THEN constructs 021686 ART code (B.UNTIL) ( flag -- ) here (sp)+ long tst, eq bcc, return INLINE code (W.UNTIL) ( flag -- ) here 200 - (sp)+ long tst, eq bcc, return INLINE code (B.IF) ( flag -- ) (sp)+ long tst, here eq bcc, return INLINE code (W.IF) ( flag -- ) (sp)+ long tst, here 200 + eq bcc, return INLINE \ (FIND) 020986 ART code (FIND) ( $addr\link.start -- NFA or 0 ) A0 pop, ( start addr ) A1 pop, ( $addr ) A0 1 LONG SUBQ, 0 D0 moveq, A1 () D0 byte move, D0 31 word andi, D0 1 # word asr, A1 () D2 word move, A1 2 long addq, A1 D1 lmove, D0 A2 exg, A2 1 long subq, 1 D4 MOVEQ, ( A2=$length/2, D2=1st word of $string, D1=A1=$addr+2 ) here label ! D4 WORD TST, ne if, D4 A0 LONG ADDA, A0 () D4 WORD MOVE, 8 A0 I) D2 word cmp, LABEL @ ne bcc, 10 A0 I) A3 LONG LEA, D1 A1 lmove, A2 D0 lmove, pl if, here A3 A1 word cmpm, D0 ne dbcc, D0 -1 word cmpi, LABEL @ ne bcc, then, A0 PUSH, here 6+ allways bcc, then, 0 D3 moveq, D3 push, return \ DIGIT COUNT EXECUTE 021686 ART code DIGIT ( char/base -- digit/true.flag or false.flag ) D0 pop, D1 pop, D1 48 byte subi, D1 9 byte cmpi, gt if, D1 7 byte subq, D1 10 byte cmpi, ge if, swap then, D1 byte tst, ge if, D1 D0 byte cmp, gt if, D1 push, -1 D1 moveq, D1 push, rts, then, then, then, 0 D1 moveq, D1 push, return SUBR code COUNT ( addr -- addr+1\cnt ) A0 get, top 1 long addq, 0 D0 moveq, A0 () D0 byte move, D0 push, return code EXECUTE ( addr -- ) A0 pop, A0 () jsr, return \ ENCLOSE 021686 ART code ENCLOSE ( $addr\delim -- $addr\non-delim\delim\next.char) D1 pop, A0 get, A0 A2 lmove, begin, A0 )+ D1 byte cmp, ne until, A0 1 long subq, A0 D0 lmove, begin, A0 () byte tst, ne if, A0 )+ D1 byte cmp, swap eq until, A0 D2 lmove, A0 1 long subq, here swap A0 D1 lmove, A2 to D0 long sub, A2 to D1 long sub, A2 to D2 long sub, D0 push, D1 push, D2 push, rts, then, A0 D2 lmove, allways bcc, return SUBR \ MAX MIN ABS ?ALIGN ALLOT 021686 ART code MAX ( a/b -- max ) D0 pop, top D0 long cmp, gt if, D0 put, then, return code MIN ( a/b -- min ) D0 pop, top D0 long cmp, lt if, D0 put, then, return code ABS ( a -- abs.a ) top long tst, mi if, top long neg, then, return code ?ALIGN ( -- | adjusts DP ) DP )UP D0 lmove, D0 1 long addq, D0 hex FFFFFFFE decimal long andi, D0 DP )UP lmove, return code ALLOT ( n -- | allots n bytes ) D0 pop, DP )UP from D0 long add, return \ HERE =CELLS , W, C, COMPILING !CSP 021686 ART code HERE ( -- here ) DP )UP push, return code =CELLS ( addr -- even.addr ) D0 pop, D0 1 long addq, D0 hex FFFFFFFE decimal long andi, D0 push, return code , ( n -- ) DP )UP A1 LMOVE, SP )+ A1 )+ lmove, A1 DP )UP lmove, return code W, ( n -- ) DP )UP A1 lmove, D0 pop, D0 A1 )+ word move, A1 DP )UP lmove, return code C, ( n -- ) DP )UP A1 lmove, D0 pop, D0 A1 )+ byte move, A1 DP )UP lmove, return code COMPILING ( -- state ) STATE )UP push, return code !CSP ( -- | stores SP ) SP CSP )UP lmove, return \ [ ] HEX DECIMAL BINARY PAD LATEST 021686 ART code [ ( -- ) 0 D0 moveq, D0 STATE )UP lmove, return IMMEDIATE code ] ( -- ) -1 D0 moveq, D0 STATE )UP lmove, return code HEX ( -- ) 16 D0 moveq, D0 BASE )UP lmove, return code DECIMAL ( -- ) 10 D0 moveq, D0 BASE )UP lmove, return code BINARY ( -- ) 2 D0 moveq, D0 BASE )UP lmove, return code PAD ( -- pad ) DP )UP A0 lmove, 32 A0 I) A0 long lea, A0 push, return code LATEST ( -- n ) LAST.NFA )UP push, return \ R/W BLOCK EMIT TYPE KEY 021686 ART \ VECTOR R/W ( addr/blk/flag -- ) \ VECTOR BLOCK ( n -- n ) VECTOR ?TERMINAL ( -- flag ) VECTOR KEY VECTOR EMIT VECTOR TYPE code R/W ( addr/blk/flag -- ) ->forth R/W ->code return SUBR code BLOCK ( n -- n ) ->forth BLOCK ->code return SUBR \ -TRAILING UNIQUE.MSG LOWER.CASE >UC? 020186 ART code -TRAILING ( addr\cnt -- cnt ) D0 pop, A0 pop, D0 A0 long adda, bl D1 moveq, here LABEL ! A0 -) D1 byte cmp, eq if, D0 1 long subq, LABEL @ ne bcc, then, D0 push, return variable UNIQUE.MSG variable LOWER.CASE code >UC? ( addr -- | converts to UC if lower.case off ) A1 pop, [compile] LOWER.CASE -2 allot A0 () D0 lmove, eq if, A1 )+ D0 byte move, ( count ) \ D0 1 byte subq, begin, A1 () D1 byte move, D1 95 byte cmpi, gt if, D1 32 byte subi, then, D1 A1 )+ byte move, D0 1 byte subq, eq until, then, return \ (.") (,") 020186 ART code (.") ( -- ) \ used in form JSR (.") $string JSR .... rtop A0 lmove, ( get address we came from ) 0 D0 moveq, A0 )+ D0 byte move, ( count ) D0 push, A0 push, D0 push, [compile] TYPE D0 pop, D0 2 word addq, D0 254 word andi, ( =cells ) rtop from D0 long add, return SUBR code (,") ( -- ) \ used in form JSR (,") $string JSR .... rtop A0 lmove, ( get address we came from ) 0 D0 moveq, A0 () D0 byte move, ( count ) D0 2 word addq, D0 254 word andi, ( =cells ) rtop from D0 long add, return SUBR \ (") 020186 ART code (") ( -- ) \ used in form JSR (") $string JSR .... rtop A0 lmove, ( get address we came from ) 0 D0 moveq, A0 () D0 byte move, ( count ) D0 2 word addq, D0 254 word andi, ( =cells ) rtop from D0 long add, A0 push, return SUBR \ < = > CFA 030386 ART code < ( a/b -- flag ) 0 D0 moveq, sp sp long cmpm, lt if, -1 D0 moveq, then, D0 push, return code = ( a/b -- flag ) 0 D0 moveq, sp sp long cmpm, eq if, -1 D0 moveq, then, D0 push, return code > ( a/b -- flag ) 0 D0 moveq, sp sp long cmpm, gt if, -1 D0 moveq, then, D0 push, return code CFA ( nfa -- cfa ) A0 pop, A0 2 LONG ADDQ, A0 () D0 lmove, D0 hex FFFFFF decimal long andi, D0 push, return \ DEPTH CR BEEP EXIT 021686 ART code DEPTH ( -- depth ) S0 )UP D0 lmove, SP to D0 long sub, D0 2 # long asr, D0 1 long addq, D0 push, return code CR ( -- ) 13 D0 moveq, D0 push, [compile] EMIT RETURN code BEEP ( -- ) 7 D0 moveq, D0 push, [compile] EMIT RETURN code EXIT ( -- ) rp 4 long addq, return SUBR \ BOOLEAN SET-FENCE NO-FENCE -3 -2 -1 0 1 2 3 021686 ART code BOOLEAN ( n -- flag ) 0 D0 moveq, top long tst, ne if, -1 D0 moveq, then, D0 put, return code SET-FENCE ( -- ) DP )UP D0 LMOVE, D0 FENCE )UP lmove, return code NO-FENCE ( -- ) 0 D0 moveq, D0 FENCE )UP lmove, return 0 constant 0 1 constant 1 2 constant 2 3 constant 3 4 constant 4 5 constant 5 6 constant 6 7 constant 7 8 constant 8 -1 constant -1 -2 constant -2 -3 constant -3 -4 constant -4 -8 constant -8 \ M* 020186 ART code M* ( n1/n2 -- high/low parts of 64-bit product ) sp () D2 lmove, 4 sp i) D1 lmove, D1 D3 lmove, D1 D4 lmove, D4 swap, D2 D0 lmove, D0 swap, D2 D1 mulu, D4 D2 mulu, D0 D3 mulu, D0 D4 mulu, D1 swap, D2 to D1 word add, 0 D0 moveq, D0 D4 long addx, D3 to D1 word add, D0 D4 long addx, D1 swap, D2 word clr, D2 swap, D3 word clr, D3 swap, D3 to D2 long add, D4 to D2 long add, sp () long tst, mi if, 4 sp i) to D2 long sub, then, 4 sp i) long tst, mi if, sp () to D2 long sub, then, D1 4 sp i) lmove, D2 sp () lmove, return \ M/MOD R>DROP I' J' 020186 ART code M/MOD ( dhi/dlo/n -- remainder/quotient ) 4 sp i) D0 lmove, 8 sp i) D1 lmove, D2 pop, mi if, D1 long neg, D0 long negx, D2 long neg, then, D0 long tst, mi if, D2 to D0 long add, then, 31 D3 moveq, D1 to D1 long add, begin, D0 1 # long roxl, D2 to D0 long sub, cs if, D2 to D0 long add, then, D1 1 # long roxl, D3 never dbcc, D1 long not, D0 4 sp i) lmove, D1 sp () lmove, return code R>DROP ( -- ) RP 4 long addq, return INLINE code I' ( -- I' ) 4 rp i) push, return INLINE code J' ( -- J' ) 12 rp i) push, return INLINE \ FLIP CODE FLIP ( n -- n | flip high and low bytes ) hex 102E W, 0002 W, 1D6E W, 0003 W, 0002 W, 1D40 W, 0003 W, decimal RETURN \ SCALE RANGE NEW.BP 020186 ART code SCALE ( n/scaler -- scaled n ) 4 SP I) D0 lmove, D1 pop, mi if, D1 word neg, D0 D1 long asr, else, D0 D1 long asl, then, D0 SP () lmove, return code RANGE ( n/min/max -- n/flag ) D0 pop, D1 pop, 0 D2 moveq, SP () D0 long cmp, ge if, SP () D1 long cmp, le if, -1 D2 moveq, then, then, D2 push, return code NEW.BP ( -- ) ' BASE.PTR 8+ @#L A5 lmove, 32766 #W A5 word adda, return \ >REL >ABS )BASE 030186 ART CODE >REL ( 32-bit abs addr -- signed offset to BP ) [COMPILE] BASE.PTR -2 ALLOT A0 () D0 LMOVE, D0 32766 LONG ADDI, SP () FROM D0 LONG SUB, RETURN CODE >ABS ( 16-bit signed offset to BP -- 32-bit abs addr ) D0 POP, D0 WORD EXT, [COMPILE] BASE.PTR -2 ALLOT A0 () TO D0 LONG ADD, D0 32766 LONG ADDI, D0 PUSH, RETURN CODE +BP ( 32-bit signed offset to BP -- 32-bit abs addr ) D0 POP, [COMPILE] BASE.PTR -2 ALLOT A0 () TO D0 LONG ADD, D0 32766 LONG ADDI, D0 PUSH, RETURN \ Ports - PC> 0 \ place holder for input rerun address CODE PC> ( -- n | read from port ) hex 800000 decimal #L A0 LONG MOVE, 0 D0 MOVEQ, drop here \ output rerun address A0 () D0 WORD MOVE, D0 PUSH, RETURN SUBR \ ** NOTE CODE RESTART.INPUT ( -- | restart port read ) D2 FROMSR, $ 2300 #W TOSR, 14 #W RP LONG ADDA, \ drop exception stack frame D2 TOSR, ( input rerun ) @#L JMP, 0 RETURN \ because output rerun address was dropped drop \ now drop the zero \ Ports - >PC 0 \ place holder for output rerun address CODE >PC ( n -- | write to port ) D0 POP, hex A00000 decimal #L A0 LONG MOVE, drop here \ output rerun address D0 A0 () WORD MOVE, RETURN SUBR \ ** NOTE CODE RESTART.OUTPUT ( -- | restart port write ) D2 FROMSR, $ 2300 #W TOSR, 14 #W RP LONG ADDA, \ drop exception stack frame D2 TOSR, ( output rerun ) @#L JMP, 0 RETURN \ because output rerun address was dropped drop \ now drop the zero \ Ports - CODE \ come here on a bus error 2 RP I) hex 80 decimal WORD CMPI, EQ 14 #W RP LONG ADDA, \ drop exception stack frame IF, ' RESTART.INPUT @#L JMP, THEN, ' RESTART.OUTPUT @#L JMP, RETURN \ -TEXT 022886 ART CODE -TEXT ( addrA/cnt/addrB -- flag ) \ compare strings A & B for cnt bytes \ flag represents difference: 0:A=B 1:A>B -1:A 030186 ART CODE +CONTEXT ( addr -- | ORs with CONTEXT*32 ) CONTEXT )UP D0 LMOVE, D0 5 # WORD ASL, A0 POP, A0 () FROM D0 BYTE OR, RETURN CODE +FORTH ( addr -- | ANDs with 31 ) A1 POP, 31 D0 MOVEQ, A1 () FROM D0 BYTE AND, RETURN CODE CMOVE> D0 pop, A1 pop, A0 pop, D0 A0 long adda, D0 A1 long adda, D0 1 long subq, pl if, begin, A0 -) A1 -) byte move, D0 1 long subq, mi until, then, return \ SCAN.FROM 021686 ART CODE SCAN.FROM ( -- addr ) BLK )UP D0 LMOVE, ne if, D0 PUSH, [COMPILE] BLOCK D0 POP, else, TIB )UP D0 LMOVE, then, >IN )UP TO D0 LONG ADD, D0 PUSH, RETURN \ BL-WORD 021686 ART CODE BL-WORD ( -- pocket | moves next word to pocket ) [COMPILE] SCAN.FROM A1 POP, A1 D3 LMOVE, 32 D0 MOVEQ, BEGIN, A1 )+ D0 BYTE CMP, NE UNTIL, A1 1 LONG SUBQ, A1 D1 LMOVE, POCKET )UP A0 LONG LEA, A0 A2 LMOVE, BEGIN, D2 95 BYTE CMPI, GT IF, D2 32 BYTE SUBI, THEN, D2 A0 )+ BYTE MOVE, A1 )+ D2 BYTE MOVE, NE IF, D2 D0 BYTE CMP, SWAP EQ UNTIL, THEN, 0 D0 MOVEQ, D0 A0 )+ BYTE MOVE, \ +trailing A1 TO D1 LONG SUB, D1 WORD NEG, D1 1 WORD SUBQ, D1 A2 () BYTE MOVE, A1 TO D3 LONG SUB, D3 LONG NEG, >IN )UP FROM D3 LONG ADD, \ A2 () BYTE TST, EQ IF, 1 D0 MOVEQ, D0 A2 () BYTE MOVE, THEN, A2 PUSH, RETURN \ ?IMMEDIATE ?SUBR ?INLINE 020186 ART CODE ?IMMEDIATE ( nfa -- flag ) A0 POP, A0 7 LONG ADDQ, A0 () D0 BYTE MOVE, D0 128 BYTE ANDI, EQ IF, 0 D0 MOVEQ, ELSE, -1 D0 MOVEQ, THEN, D0 PUSH, RETURN CODE ?SUBR ( nfa -- flag ) A0 POP, A0 6 LONG ADDQ, A0 () D0 BYTE MOVE, D0 128 BYTE ANDI, EQ IF, 0 D0 MOVEQ, ELSE, -1 D0 MOVEQ, THEN, D0 PUSH, RETURN CODE ?INLINE ( nfa -- flag ) A0 POP, A0 6 LONG ADDQ, A0 () D0 BYTE MOVE, D0 064 BYTE ANDI, EQ IF, 0 D0 MOVEQ, ELSE, -1 D0 MOVEQ, THEN, D0 PUSH, RETURN \ @#BYTES WMOVE 020986 ART CODE @#BYTES ( nfa -- #bytes ) A0 POP, A0 2 LONG ADDQ, 0 D0 MOVEQ, A0 () D0 BYTE MOVE, D0 TO D0 WORD ADD, D0 PUSH, RETURN CODE WMOVE ( addr/addr/cnt -- | moves cnt words ) D0 POP, A1 POP, A0 POP, D0 1 LONG SUBQ, PL IF, D0 32767 LONG CMPI, LT IF, BEGIN, A0 )+ A1 )+ WORD MOVE, D0 NEVER DBCC, ELSE, BEGIN, A0 )+ A1 )+ BYTE MOVE, D0 1 LONG SUBQ, MI UNTIL, THEN, THEN, RETURN \ BLANK 020186 ART \ /MOD MOD / * PC@ PC! 022686 ART : /MOD ( a/b -- rem/quotient ) >R DUP 0< R> M/MOD ; : MOD ( a/b -- a mod b ) /MOD DROP ; : / ( a/b -- quotient ) /MOD SWAP DROP ; : * ( a/b -- a*b ) M* DROP ; : PC@ ( -- n | fetch and swap bytes ) PC> FLIP ; : PC! ( n -- | swap bytes and store ) FLIP >PC ; \ INLINE SUBR CRITICAL.SIZE LAST.VOCAB# DEFINITIONS 022386 ART : SUBR ( -- ) LATEST 6+ DUP C@ 128 OR SWAP C! ; : INLINE ( -- ) LATEST 6+ DUP C@ 064 OR SWAP C! ; : DON'T-OPTIMISE ( -- ) LATEST 6+ DUP C@ 032 OR SWAP C! ; : ?DON'T-OPTIMISE ( nfa -- flag ) 6+ C@ 032 AND BOOLEAN ; : DEFINITIONS ( -- ) CONTEXT @ CURRENT ! ; VARIABLE CRITICAL.SIZE 09 CRITICAL.SIZE ! VARIABLE LAST.VOCAB# 0 LAST.VOCAB# ! \ !#BYTES SMUDGE IMMEDIATE 020986 ART : !#BYTES ( -- | set #bytes field of last defined word ) HERE LATEST CFA - 2/ 255 MIN LATEST 2+ C! ; : SMUDGE ( -- ) LATEST 9+ 128 TOGGLE ; : IMMEDIATE ( -- ) LATEST 7+ DUP C@ 128 OR SWAP C! ; CODE ?SHORT ( n -- n/flag | true flag if -32766 ,JSR 020186 ART hex 4E75 CONSTANT 4EAD CONSTANT <,A5.JSR.W> 4EB9 CONSTANT decimal : ,JSR ( addr -- | compiles JSR ADDR into object ) DUP >REL ?SHORT IF ( short jsr ) <,A5.JSR.W> W, W, DROP ELSE ( long jsr ) DROP W, , THEN ; \ ,JMP 020186 ART hex 4E71 CONSTANT 6000 CONSTANT 4EED CONSTANT <,A5.JMP.W> 4EF9 CONSTANT decimal : ,JMP ( addr -- | compiles JMP ADDR or BRA ADDR into object ) DUP HERE 2+ - ABS DUP 32764 < IF 128 < IF ( short bra ) HERE 2+ - 255 AND OR W, ELSE ( long bra ) HERE 2+ - W, W, THEN ELSE DROP DUP >REL DUP ABS 32768 < IF ( short jmp ) <,A5.JMP.W> W, W, DROP ELSE ( long jmp ) DROP W, , THEN THEN ; \ 020386 ART hex 2D08 CONSTANT \ 41F8 CONSTANT 2D00 CONSTANT \ 41F9 CONSTANT 41EC CONSTANT <,A4.LEA> 41ED CONSTANT <,A5.LEA> 4ED0 CONSTANT 7000 CONSTANT 4A9E CONSTANT 6700 CONSTANT 41FA CONSTANT <,PC.LEA> 206D CONSTANT <,A5.MOVE> 2D3C CONSTANT 2079 CONSTANT decimal \ ,LIT LITERAL ,RTS 020386 ART : ,LIT ( n -- | compiles n into object ) DUP ABS 128 < IF 255 AND OR W, W, ELSE W, , THEN ; : LITERAL ( n -- | compiles as literal or leaves n on stack ) COMPILING IF ,LIT THEN ; IMMEDIATE : ,RTS ( -- ) W, ; \ ,VAR-CODE 020186 ART : ,VAR-CODE ( -- | adds code for a variable to dictionary ) HERE 8+ >REL ?SHORT IF <,A5.LEA> W, W, W, ELSE W, DROP HERE 6+ , THEN ,RTS ; \ ?INLINE 020186 ART : ( cfa/#bytes -- | compiles word inline ) 2- >R HERE R@ 2/ WMOVE R> ALLOT ; : ?[SUBR] ( nfa -- flag | true flag if word must be a subr ) DUP @#BYTES CRITICAL.SIZE @ > OVER ?INLINE 0= AND SWAP ?SUBR OR ; : ( nfa -- | compiles word inline or call to word ) DUP ?[SUBR] IF CFA ,JSR ELSE DUP CFA SWAP @#BYTES THEN ; \ BLANK 030386 ART \ SCR.ADDR SCRVMAX .INVERSE .UNDERLINE 030586 ART \ HEX 5121A0 CONSTANT SCR.BASE DECIMAL \ 1 CONSTANT SCRHMIN 079 CONSTANT SCRHMAX \ SCRHMIN WNDLEFT ! SCRHMAX WNDRIGHT ! \ 0 CONSTANT SCRVMIN 024 CONSTANT SCRVMAX \ SCRVMIN WNDTOP ! SCRVMAX WNDBOT ! \ 160 CONSTANT BYTES/ROW VARIABLE ATTRIBUTE \ 256 CONSTANT .INVERSE \ 1280 CONSTANT .UNDERLINE \ 2304 CONSTANT .LOW \ SCR.ADDR @ROW @COL 030386 ART \ DE SCR.ADDR ( -- current screen address ) \ SCR.BASE #L A2 LMOVE, \ ROW )UP D0 LMOVE, \ add row*160 ( equals row*(128+32) ) \ WNDTOP )UP TO D0 LONG ADD, \ D0 5 # WORD ASL, D0 A2 WORD ADDA, \ D0 2 # WORD ASL, D0 A2 WORD ADDA, \ WNDLEFT )UP D0 LMOVE, \ add window left margin*2 \ COL )UP TO D0 LONG ADD, \ add col*2 \ D0 A2 WORD ADDA, D0 A2 WORD ADDA, A2 PUSH, RETURN \ DE @ROW ( -- row ) ROW )UP PUSH, RETURN \ DE @COL ( -- col ) COL )UP PUSH, RETURN \ CLR-EOL UP-ONE-LINE 030586 ART \ DE CLR-EOL ( -- | clears to end of line ) \ [COMPILE] SCR.ADDR A2 POP, \ WNDRIGHT )UP D0 LMOVE, WNDLEFT )UP TO D0 LONG SUB, \ COL )UP TO D0 LONG SUB, \ ATTRIBUTE >REL A5 I) D1 LMOVE, D1 BL WORD ORI, \ D0 LONG TST, PL \ IF, BEGIN, D1 A2 )+ WORD MOVE, D0 NEVER DBCC, \ THEN, RETURN \ DE UP-ONE-LINE ( line.addr -- | copies line one row up ) \ A0 POP, A0 A1 LMOVE, BYTES/ROW #W A1 WORD SUBA, \ WNDRIGHT )UP D0 LMOVE, WNDLEFT )UP TO D0 LONG SUB, \ \ D0 1 WORD SUBQ, \ BEGIN, A0 )+ A1 )+ WORD MOVE, D0 NEVER DBCC, RETURN \ @WNDTOP @WNDLEFT ROWS/WINDOW COLS/WINDOW 030386 ART \ DE @WNDTOP ( -- top ) WNDTOP )UP PUSH, RETURN \ DE @WNDLEFT ( -- left ) WNDLEFT )UP PUSH, RETURN \ DE @WNDBOT ( -- bottom ) WNDBOT )UP PUSH, RETURN \ DE @WNDRIGHT ( -- right ) WNDRIGHT )UP PUSH, RETURN \ DE ROWS/WINDOW ( -- #lines in current window ) \ WNDBOT )UP D0 LMOVE, WNDTOP )UP TO D0 LONG SUB, \ D0 1 LONG ADDQ, D0 PUSH, RETURN \ DE COLS/WINDOW ( -- #columns in current window ) \ WNDRIGHT )UP D0 LMOVE, WNDLEFT )UP TO D0 LONG SUB, \ D0 1 LONG ADDQ, D0 PUSH, RETURN \ DO.CR DO.LF DO.BS GREY WHITE 030486 ART : DO.CR ( -- | handles CR ) 1 ROW +! COL OFF 13 EMIT ; : DO.LF ( -- | handles LF ) 1 ROW +! 10 EMIT ; : DO.BS ( -- | handles BS ) -1 COL +! COL @ 0< IF 8 EMIT ROW @ 0 > IF 79 COL ! -1 ROW +! ELSE COL OFF THEN THEN ; \ PAGE SCROLL ?SCROLL 030386 ART \ PAGE ( -- | clears active window ) \ ROW OFF COL OFF \ ROWS/WINDOW 0 DO CLR-EOL 1 ROW +! LOOP \ ROW OFF ; \ SCROLL ( -- | scrolls screen ) \ @COL @ROW COL OFF ROW OFF \ ROWS/WINDOW 1 \ DO 1 ROW +! SCR.ADDR UP-ONE-LINE LOOP \ ROWS/WINDOW 1- ROW ! \ CLR-EOL 1- 0MAX ROW ! COL ! ; \ ?SCROLL ( -- ) @ROW ROWS/WINDOW 1- > IF SCROLL THEN ; \ ?IN.WINDOW 030486 ART \ DE ?IN.WINDOW ( -- flag ) \ \ flag true if current position is within window bounds \ -1 D2 MOVEQ, \ WNDRIGHT )UP D1 LMOVE, WNDLEFT )UP TO D1 LONG SUB, \ COL )UP D1 LONG CMP, LT IF, 0 D2 MOVEQ, THEN, \ D2 PUSH, RETURN \ EMIT.CHAR 030586 ART \ DE EMIT.CHAR ( char -- | emits & increments row & col ) \ [COMPILE] SCR.ADDR A2 POP, \ D0 POP, ATTRIBUTE >REL A5 I) TO D0 LONG OR, \ D0 A2 () WORD MOVE, \ COL )UP A0 LONG LEA, A0 () 1 LONG ADDQ, \ WNDRIGHT )UP D0 LMOVE, WNDLEFT )UP TO D0 LONG SUB, \ A0 () D0 LONG CMP, LE \ IF, FORCED.CR )UP LONG TST, NE \ IF, 0 D0 MOVEQ, D0 A0 () LMOVE, \ ROW )UP 1 LONG ADDQ, \ THEN, \ THEN, RETURN \ 'EMIT 030386 ART \ DE 'EMIT ( char -- | emits to screen ) \ D0 POP, D0 31 WORD CMPI, GT \ IF, ] ?IN.WINDOW [ SP )+ LONG TST, NE \ IF, D0 PUSH, ] EMIT.CHAR [ THEN, \ ELSE, D0 13 WORD CMPI, EQ \ IF, ] DO.CR [ \ ELSE, D0 10 WORD CMPI, EQ \ IF, ] DO.LF [ \ ELSE, D0 8 WORD CMPI, EQ \ IF, ] DO.BS [ \ THEN, THEN, THEN, THEN, \ WNDBOT )UP D0 LMOVE, WNDTOP )UP TO D0 LONG SUB, \ ROW )UP D0 LONG CMP, LT \ IF, ] SCROLL [ THEN, RETURN \ CLEAR.SCREEN VHTAB CLR-EOP 030686 ART \ CLEAR.SCREEN ( -- | clears entire text screen ) \ WNDLEFT OFF 080 WNDRIGHT ! \ WNDTOP OFF 024 WNDBOT ! \ PAGE \ 1 WNDLEFT ! 079 WNDRIGHT ! ; \ VHTAB ( x/y -- | sets vtab & htab ) \ ROWS/WINDOW MIN 0MAX ROW ! \ COLS/WINDOW MIN 0MAX COL ! ; \ CLR-EOP ( -- | clears to end of page ) \ CLR-EOL @COL @ROW ROWS/WINDOW OVER \ BEGIN 2DUP > WHILE CR CLR-EOL 1+ REPEAT \ 2DROP ROW ! COL ! ; \ 'EMIT 'KEY '?TERMINAL : 'EMIT ( char -- ) 256* 4 OR PC! ; : '?TERMINAL ( -- flag ) 2 PC! PC@ ; : 'KEY ( key -- ) 3 PC! PC@ 255 AND ; : 'TYPE ( addr/cnt -- ) OVER + SWAP DO I C@ EMIT LOOP ; : PAGE 12 EMIT ; \ +CURSOR -CURSOR KEY 030386 ART \ VARIABLE CURSOR.RATE 1500 CURSOR.RATE ! \ +CURSOR ( -- | turns cursor on for cursor.period ) \ SCR.ADDR DUP W@ 255 AND .UNDERLINE OR SWAP W! \ CURSOR.RATE @ 0 DO ?TERMINAL IF LEAVE THEN LOOP ; \ -CURSOR ( -- | turns cursor off for cursor.period ) \ SCR.ADDR DUP W@ 255 AND .INVERSE OR SWAP W! \ CURSOR.RATE @ 0 DO ?TERMINAL IF LEAVE THEN LOOP ; \ (KEY) ( -- char | gets key and flashes cursor ) \ BEGIN +CURSOR -CURSOR ?TERMINAL UNTIL @KEY ; \ 'KEY ( -- char | also prints char ) (KEY) DUP EMIT ; \ 'TYPE OLD.EXPECT 030386 ART : EXPECT ( addr/cnt -- | gets cnt chars or until CR ) DUP CNT ! OVER + SWAP DO 'KEY DUP IC! DUP 13 = IF I I' - CNT +! LEAVE THEN DUP BS = IF R> 2- >R I' I - CNT @ 1+ > IF R> 1+ >R DROP 0 THEN THEN EMIT LOOP ; ' '?TERMINAL ' ?TERMINAL 8+ ! ' 'EMIT ' EMIT 8+ ! ' 'TYPE ' TYPE 8+ ! ' 'KEY ' KEY 8+ ! \ LAST.IN SPACES (WORD) WORD 030386 ART VECTOR VARIABLE LAST.IN ( stores contents of >in after error ) : SPACE ( -- ) BL EMIT ; : SPACES ( n -- ) DUP 0> IF 0 DO BL EMIT LOOP ELSE DROP THEN ; : (WORD) ( delim\addr -- addr ) >R SCAN.FROM SWAP ENCLOSE >IN +! DUP ROT - 255 MIN DUP 1 MAX R@ C! >R + R@ - R> 1+ R@ 1+ SWAP CMOVE R> ; : WORD ( delim -- addr ) POCKET (WORD) 0 OVER COUNT + C! ; \ Note: using WORD size in machine code will use the Forth \ word WORD until the assembler is loaded. \ ?KEYMORE ?KBD-SLOW ERROR HUH? 030686 ART : ?KEYMORE ( -- flag | true if cr was pressed ) KEY DUP 13 = IF DROP KEY 13 = 0= THEN NOT ; : ?KBD-SLOW ( -- flag | false if timeout before cr ) 0 050 0 DO ?TERMINAL IF NOT LEAVE THEN LOOP DUP IF DROP ?KEYMORE THEN ; : HUH? ( -- ) SPACE 63 EMIT ( ? ) SPACE BEEP SP! ; : ERROR ( -- ) BLK @ LAST.BLK ! >IN @ LAST.IN ! BEEP CR POCKET COUNT 31 AND TYPE SPACE CURRENT OFF HUH? ; SUBR \ RECALL.BUF RECALL.SIZE LAST$ (TIB) (COL) 030386 ART \ 64 CONSTANT RECALL.SIZE \ CREATE RECALL.BUF HERE RECALL.SIZE DUP ALLOT ERASE \ VARIABLE LAST.LEN \ length of least recall string \ VARIABLE BUF.DEPTH \ current displayed entry \ VARIABLE LAST$ RECALL.BUF LAST$ ! \ VARIABLE (TIB) \ address of buffer used by EXPECT \ VARIABLE (COL) \ initial COL when EXPECT called \ 21 CONSTANT INS-LN \ INS LN - recalls succeeding lines \ 20 CONSTANT DEL-LN \ DEL LN - recalls preceding lines \ 4 CONSTANT RUN-KEY \ RUN function key \ 2 CONSTANT EDIT-KEY \ EDIT function key \ 1 CONSTANT INS-CHAR \ INS CHAR or TAB - forward space \ >CLIP< INIT.BUF FIRST.FREE OLDEST.ENTRY 030386 ART \ >CLIP< ( addr -- addr clipped inside buffer ) \ RECALL.BUF - RECALL.SIZE MOD RECALL.BUF + ; \ INIT.BUF ( -- | initialises buffer ) \ RECALL.BUF RECALL.SIZE ERASE \ RECALL.BUF LAST$ ! ; INIT.BUF \ initialise buffer now \ FIRST.FREE ( -- addr of first free space ) \ LAST$ @ BEGIN COUNT ?DUP WHILE + >CLIP< REPEAT 1- ; \ OLDEST.ENTRY ( -- addr of oldest entry ) \ LAST$ @ BEGIN COUNT 2DUP + >CLIP< C@ \ WHILE + >CLIP< \ REPEAT DROP 1- >CLIP< ; \ FREE.SPACE MAKE.SPACE $>BUF 030386 ART \ FREE.SPACE ( -- #bytes free in buffer ) \ FIRST.FREE LAST$ @ 1- >CLIP< - \ RECALL.SIZE SWAP - RECALL.SIZE MOD ; \ MAKE.SPACE ( #bytes -- ) \ \ creates #bytes free space by deleting oldest strings \ BEGIN DUP FREE.SPACE 4- > \ WHILE 0 OLDEST.ENTRY C! REPEAT DROP ; \ $>BUF ( addr/cnt -- | adds to buffer ) \ DUP>R MAKE.SPACE LAST$ @ R@ - 1- >CLIP< DUP LAST$ ! \ R@ OVER C! ( store count ) \ R> 0 DO OVER I+ C@ OVER I+ 1+ >CLIP< C! \ LOOP 2DROP ; \ ENTRY#>ADDR >CONTROL NEXT/PREV 030386 ART \ ENTRY#>ADDR ( entry# -- string start address ) \ LAST$ @ SWAP ?DUP \ IF 0 DO COUNT DUP 0= IF 1- THEN + >CLIP< LOOP THEN ; \ >CONTROL ( char -- char<127, equal 21 if INS-LN ) \ DUP 128 = IF DROP 21 THEN DUP 13 = IF DROP 0 THEN ; \ NEXT/PREV ( char -- true flag if recall control char ) \ DUP INS-LN = \ IF DROP -1 BUF.DEPTH @ 1- 0MAX BUF.DEPTH ! \ ELSE DEL-LN = \ IF BUF.DEPTH @ ENTRY#>ADDR C@ \ IF 1 BUF.DEPTH +! THEN -1 \ ELSE 0 THEN THEN ; \ $>ADDR SHOW-TIB ?RECALL 030386 ART \ $>ADDR ( addr/entry# -- | moves string to addr ) \ ENTRY#>ADDR SWAP OVER C@ DUP LAST.LEN ! 0 \ DO OVER I+ 1+ >CLIP< C@ OVER I+ C! LOOP \ SWAP ( buf.addr ) C@ + 0 SWAP C! ( store terminal zero ) ; \ SHOW-TIB ( -- end-of-string addr | displays input buffer ) \ (COL) @ COL ! (TIB) @ 1- \ BEGIN 1+ DUP C@ DUP WHILE EMIT REPEAT DROP 1- CLR-EOL ; \ ?RECALL ( char/address -- char/end-of-line address ) \ \ takes control char & addr of last char entered \ OVER NEXT/PREV \ IF LAST.LEN @ - BUF.DEPTH @ $>ADDR SHOW-TIB \ THEN ; \ (EXPECT) 030386 ART \ (EXPECT) ( addr/cnt -- | gets cnt chars or until CR ) \ OVER + SWAP \ DO (KEY) >CONTROL R> ?RECALL >R DUP INS-CHAR = \ IF DROP IC@ DUP 0= \ IF DROP -1 THEN \ THEN DUP 0= OVER 13 = OR \ IF I (TIB) @ - CNT ! LEAVE THEN \ DUP BS = \ IF I (TIB) @ > IF R> 2- >R ELSE DROP -1 THEN \ THEN \ DUP 31 > IF DUP IC! LAST.LEN OFF THEN \ DUP 0< IF R> 1- >R LAST.LEN OFF THEN \ 0MAX EMIT \ LOOP ; \ =STRINGS EXPECT 030386 ART \ \ =STRINGS ( addr/cnt/addr/cnt -- true flag if strings equal ) \ ROT OVER = \ IF >R DUP>R - -1 R> R> OVER + SWAP \ DO OVER I+ C@ IC@ = NOT IF DROP 0 LEAVE THEN LOOP \ SWAP DROP \ ELSE 2DROP DROP 0 THEN ; \ \ EXPECT ( addr/cnt -- | gets cnt chars or until CR ) \ CNT OFF 2DUP ERASE \ OVER (TIB) ! COL @ (COL) ! \ BUF.DEPTH ON LAST.LEN OFF (EXPECT) CLR-EOL \ (TIB) @ CNT @ DUP>R LAST$ @ COUNT =STRINGS 0= R> AND \ IF (TIB) @ CNT @ $>BUF THEN ; \ SHOW.BUF 030386 ART \ it \ SHOW.BUF ( -- | displays entries in buffer ) \ CR -1 \ BEGIN 1+ DUP ENTRY#>ADDR C@ \ WHILE CNT OFF PAD OVER $>ADDR CR PAD LAST.LEN @ TYPE \ REPEAT DROP CR ; \ BLANK \ BLANK \ BLANK \ BLANK \ BLANK \ BLANK \ -FIND FIND [COMPILE] 020186 ART : FIND ( -- nfa addr or zero | takes string from pocket ) BL-WORD DUP>R +CONTEXT \ search context R@ DUP HASH LINK.PTR @ + W@ VOC.BASE @ + (FIND) DUP CONTEXT @ 0= OR IF R>DROP ELSE DROP R@ +FORTH \ search forth R> DUP HASH LINK.PTR @ + W@ VOC.BASE @ + (FIND) THEN ; : -FIND ( -- nfa ) FIND DUP 0= IF ERROR THEN ; : [COMPILE] ( -- ) FIND ; IMMEDIATE \ COMPILE 030186 ART : COMPILE ( -- ) -FIND DUP ?[SUBR] IF CFA >REL ,LIT ' +BP ,JSR ' ,JSR ,JSR ELSE DUP CFA >REL ,LIT ' +BP ,JSR @#BYTES ,LIT ' ,JSR THEN ; IMMEDIATE \ Format of COMPILE: \ : TEST COMPILE IF ; | for example \ | \ TEST: PUSH (cfa-of-IF) | push relative cfa of word \ JSR )BP | convert to absolute addr \ PUSH (#bytes-of-IF) | push word size \ JSR | and compile it inline \ RTS | when test is executed. \ (ERROR") ERROR" 050586 ART : (ERROR") ( -- ) >IN @ LAST.IN ! BLK @ LAST.BLK ! BEEP CR POCKET COUNT 31 AND TYPE SPACE 45 EMIT SPACE R> COUNT TYPE SPACE SP! CURRENT OFF ; : ERROR" ( flag -- ) 34 WORD COMPILING IF W, HERE >R W, COMPILE (ERROR") HERE OVER C@ 1+ DUP ALLOT CMOVE ?ALIGN HERE R@ 2+ - 255 AND OR R> W! THEN ; IMMEDIATE \ ." " ," 020186 ART : ." ( -- ) 34 WORD COMPILING IF COMPILE (.") HERE OVER C@ 1+ DUP ALLOT CMOVE ?ALIGN ELSE COUNT TYPE THEN ; IMMEDIATE : " ( -- addr ) 34 WORD COMPILING IF COMPILE (") HERE OVER C@ 1+ DUP ALLOT CMOVE ?ALIGN ELSE PAD OVER C@ 1+ CMOVE THEN ; IMMEDIATE : ," ( -- ) 34 WORD COMPILING IF COMPILE (,") THEN HERE OVER C@ 1+ DUP ALLOT CMOVE ?ALIGN ; IMMEDIATE \ ?COMP ?STACK ?CSP ?EXEC ?PAIRS ?VOCAB 020186 ART : ?COMP ( -- ) COMPILING 0= ERROR" Compilation only - use in a definition!" ; : ?STACK ( -- ) S0 @ SP@ - DUP 0< ERROR" Stack underflow!" 200 > ERROR" Stack overflow!" ; : ?CSP ( -- ) SP@ CSP @ - ERROR" Definition incomplete - stack changed!" ; : ?EXEC ( -- ) COMPILING ERROR" Use in execution mode only!" ; : ?PAIRS ( a/b -- ) = NOT ERROR" Conditionals not paired!" ; : ?VOCAB ( -- ) LAST.NFA @ VOC.BASE @ 50 + - 0< ERROR" Vocabulary full!" ; \ CREATE 020386 ART : CREATE ( -- | creates entry in dictionary ) ?VOCAB ( voc full? ) FIND UNIQUE.MSG @ AND ?DUP IF 8+ COUNT 31 AND TYPE ." isn't unique " THEN POCKET DUP >UC? C@ 30 AND 2+ DUP>R 8+ NEGATE LAST.NFA +! CURRENT @ 32* POCKET C@ OR POCKET C! \ set vocab# POCKET LATEST 8+ R> CMOVE POCKET HASH LINK.PTR @ + DUP W@ >R \ previous link LATEST VOC.BASE @ - SWAP W! \ store new link R@ LATEST VOC.BASE @ - - R> BOOLEAN AND LATEST W! \ offset to next nfa, zero if voc.link entry was zero HERE LATEST 2+ ! \ set CFA pointer 1 LATEST 6+ W! \ set word type, stack usage & size ,VAR-CODE !#BYTES ; \ ' ?DEPTH 050586 ART : ' ( -- cfa ) -FIND CFA COMPILING IF >REL ,LIT COMPILE +BP THEN ; IMMEDIATE : ?DEPTH ( nfa -- | aborts if too few stack items ) 7+ C@ 8/ 7 AND DUP 7 = COMPILING OR IF DROP ELSE DEPTH 2- > ERROR" Insufficient stack items!" THEN ; \ (DOES) DOES> 020986 ART : ,DOES.CODE ( does.addr -- | installs JSR to does) DP @ >R LATEST CFA DP ! LATEST @#BYTES SWAP ,JSR !#BYTES R> DP ! LATEST @#BYTES 2DUP - >R SWAP LATEST CFA + SWAP LATEST CFA + HERE OVER - CMOVE R> NEGATE ALLOT ; : (DOES) ( -- | install a JMP to addr following DOES> in the ) ( eight bytes reserved by CREATE at the start of the word ) LATEST 6+ DUP C@ DUP 15 AND 4 > IF 0 ELSE 07 THEN OR SWAP C! \ set DOES> word-type if not a new word type SUBR \ child must be a subr, due to data field after JSR R> ( addr of executing word ) ,DOES.CODE ; SUBR : DOES> ( -- ) DON'T-OPTIMISE COMPILE (DOES) COMPILE R> ; IMMEDIATE \ HOLD <# # #> 020186 ART : HOLD ( char -- ) -1 HLD +! HLD @ C! ; : # ( n1 -- n2 ) 0 BASE @ M/MOD SWAP 09 OVER < IF 7+ THEN 048 + HOLD ; : <# ( -- ) PAD HLD ! ; : #> ( n -- addr/cnt ) DROP HLD @ PAD OVER - ; \ SIGN #S U. S. .R . ? 020186 ART : SIGN ( n -- ) 0< IF 45 HOLD THEN ; : #S ( n -- 0 ) BEGIN # DUP 0> NOT UNTIL ; : U. ( n -- ) <# #S #> TYPE SPACE ; : S. ( n -- ) DUP ABS <# #S SWAP SIGN #> TYPE SPACE ; : .R ( n/spaces -- ) >R BASE @ 010 = IF DUP ABS <# #S SWAP SIGN #> ELSE <# #S #> THEN R> OVER - SPACES TYPE ; : . ( n -- ) 0 .R SPACE ; : ? ( n -- ) @ . ; \ Word type declaration 020186 ART VARIABLE LAST.TYPE 0 LAST.TYPE ! VARIABLE TYPE.TABLE 80 ALLOT : .WORD-TYPE ( nfa -- | prints word type ) 6+ C@ 15 AND 4* TYPE.TABLE + @ COUNT 31 AND 5- TYPE ; : ADD.TYPE ( -- | builds word which sets word-type field ) CREATE LAST.TYPE @ DUP W, 1 LAST.TYPE +! DUP 18 > ERROR" Word-type table full!" LATEST 8+ SWAP 4* TYPE.TABLE + ! DOES> W@ LAST.NFA @ 6+ DUP>R C@ 240 AND OR R> C! ; ADD.TYPE DATA.TYPE ( -- ) ADD.TYPE CODE.TYPE ( -- ) ADD.TYPE COLON.TYPE ( -- ) ADD.TYPE VAR.TYPE ( -- ) ADD.TYPE CONST.TYPE ( -- ) ADD.TYPE VECTOR.TYPE ( -- ) ADD.TYPE USER.TYPE ( -- ) ADD.TYPE DOES>.TYPE ( -- ) ADD.TYPE VOCAB.TYPE ( -- ) \ VARIABLE USER CONSTANT 021686 ART : VARIABLE ( -- | creates a variable of the form ) \ LEA d(A5),A0 PUSH A0 with d offset from BP CREATE VAR.TYPE 0 , ; : USER ( n -- creates a user variable of the form ) \ LEA d(A4),A0 PUSH A0 with d offset into user table CREATE USER.TYPE LATEST CFA DP ! <,A4.LEA> W, ( user offset ) W, W, ,RTS !#BYTES ; : CONSTANT ( n -- | creates a constant of the form ) \ MOVE n,-(SP) or MOVEQ n,D0 PUSH D0 depending on size CREATE CONST.TYPE LATEST CFA DP ! ,LIT ,RTS !#BYTES ; \ ?VECTOR VECTOR 020186 ART : ?VECTOR ( -- | prints error message ) ERROR" Undefined vector!" ; : VECTOR ( -- | creates a vector word of the form ) \ MOVE d(A5),A0 JMP (A0) RTS CREATE VECTOR.TYPE SUBR LATEST CFA DP ! HERE 8+ >REL ?SHORT IF <,A5.MOVE> W, W, ELSE W, >ABS 2+ , THEN W, ,RTS !#BYTES ' ?VECTOR , ; \ ,0BRANCH REVECTORS 022886 ART : ,0BRANCH ( addr -- | compiles BEQ ADDR into object ) W, HERE 2+ - DUP ABS DUP 32767 > ERROR" Branch out of range!" 128 < IF ( short beq ) 255 AND OR W, ELSE ( long beq ) W, W, THEN ; : REVECTORS ( cfa -- | revectors following word to given cfa ) -FIND CFA >R DUP >REL ?SHORT IF <,A5.JMP.W> R@ W! R> 2+ W! DROP ELSE R@ W! DROP R> 2+ ! THEN ; \ BEGIN UNTIL AGAIN IF ELSE THEN 021686 ART : BEGIN ( -- addr/1 ) ?COMP HERE 1 ; IMMEDIATE : UNTIL ( addr/1 -- ) ?COMP 1 ?PAIRS ,0BRANCH ; IMMEDIATE : AGAIN ( addr/1 -- ) ?COMP 1 ?PAIRS ,JMP ; IMMEDIATE : IF ( -- addr/2 ) ?COMP HERE 2+ DUP 200 + ,0BRANCH 2 ; IMMEDIATE : ELSE ( addr/2 -- addr/2 ) ?COMP 2 ?PAIRS HERE 2+ OVER - SWAP 2+ W! HERE DUP 200 + ,JMP 2 ; IMMEDIATE : THEN ( addr/2 -- ) ?COMP 2 ?PAIRS HERE 2- OVER - SWAP 2+ W! ; IMMEDIATE \ DO LOOP 4+LOOP 021686 ART : DO ( -- addr/3 ) ?COMP ' (DO) HERE 08 ALLOT 08 CMOVE HERE 03 ; IMMEDIATE : LOOP ( addr/3 -- ) ?COMP 03 ?PAIRS HERE 8+ OVER - 128 < IF ' (B.LOOP) HERE 010 ALLOT 010 CMOVE HERE 2- - 255 AND HERE 4- W@ 65280 AND OR HERE 4- W! ELSE ' (W.LOOP) HERE 12 ALLOT 12 CMOVE HERE 4- - HERE 4- W! THEN ; IMMEDIATE : 2+LOOP ( addr/3 -- ) ?COMP HERE >R [COMPILE] LOOP 21655 R> W! ; IMMEDIATE : 4+LOOP ( addr/3 -- ) ?COMP HERE >R [COMPILE] LOOP 22679 R> W! ; IMMEDIATE \ B+LOOP W+LOOP +LOOP 021686 ART : B+LOOP ( target addr -- ) ' (B+LOOP) HERE 24 ALLOT 24 CMOVE DUP HERE 2- - 255 AND HERE 4- W@ 65280 AND OR HERE 4- W! HERE 010 - - 255 AND HERE 12 - W@ 65280 AND OR HERE 12 - W! ; : W+LOOP ( target addr -- ) ' (W+LOOP) HERE 28 ALLOT 28 CMOVE DUP HERE 4- - HERE 4- W! HERE 14 - - HERE 14 - W! ; : +LOOP ( addr/3 -- ) ?COMP 03 ?PAIRS HERE 14 + OVER - 128 < IF B+LOOP ELSE W+LOOP THEN ; IMMEDIATE \ ++LOOP WHILE REPEAT 021686 ART : ++LOOP ( addr/3 -- ) ?COMP 03 ?PAIRS HERE 8+ OVER - 128 < IF ' (B++LOOP) HERE 12 ALLOT 12 CMOVE HERE 2- - 255 AND HERE 4- W@ 65280 AND OR HERE 4- W! ELSE ' (W++LOOP) HERE 14 ALLOT 14 CMOVE HERE 4- - HERE 4- W! THEN ; IMMEDIATE : WHILE ( -- addr/4 ) ?COMP HERE 2+ DUP 200 + ,0BRANCH 04 ; IMMEDIATE : REPEAT ( addr/4 -- ) ?COMP >R >R 1 ?PAIRS ,JMP ( AGAIN ) R> R> 04 ?PAIRS HERE 2- OVER - SWAP 2+ W! ; IMMEDIATE \ VOCABULARY FORTH ASSEMBLER TRANSIENT 020186 ART 0 LAST.VOCAB# ! \ no vocabularies declared yet : VOCABULARY ( -- | creates new vocabulary ) CREATE VOCAB.TYPE IMMEDIATE LAST.VOCAB# @ DUP W, 07 > ERROR" All 8 possible vocabularies already used!" 1 LAST.VOCAB# +! DOES> W@ CONTEXT ! ; \ VOCABULARY FORTH ( -- ) \ VOCABULARY TRANSIENT ( -- ) \ Stack usage from comments 020186 ART \ COMMENT MUST BE OF FORM ( addr/cnt -- flag/flag | comment ) VARIABLE #IN VARIABLE #OUT VARIABLE VALID.I/O : ?ITEMS ( addr -- #items | searches to right bracket ) #IN >R 1- BEGIN 1+ DUP C@ R@ @ 0= IF DUP BL = OVER 124 = OR OVER 45 = OR OVER 41 = OR 0= IF 1 R@ ! THEN THEN DUP 47 = ( is it "/" ? ) IF 1 R@ +! THEN OVER 1+ C@ 45 = OVER 45 = AND IF R>DROP #OUT >R VALID.I/O ON THEN DUP 124 = SWAP 41 = OR \ is it a "|" or a ")" ? UNTIL R>DROP DROP ; \ Stack usage from comments 030186 ART : (N--N) ( entry\exit -- | sets stack usages bits ) SWAP 8* + LATEST 7+ DUP>R C@ 192 AND OR R> C! ; : ID. ( nfa -- ) ?DUP IF 8+ COUNT 31 AND TYPE THEN ; VARIABLE FAST.COMMENTS FAST.COMMENTS OFF : ( FAST.COMMENTS @ 0= IF VALID.I/O OFF #IN OFF #OUT OFF SCAN.FROM ?ITEMS VALID.I/O @ IF #IN @ #OUT @ (N--N) THEN THEN 41 WORD DROP ; IMMEDIATE \ ?PUNCT CONVERT NUMBER 020186 ART : ?PUNCT ( addr -- true flag if char is one of , . ; ) C@ 046 = ; : CONVERT ( n1/addr -- n2/addr2 ) BEGIN 1+ DUP>R C@ BASE @ DIGIT WHILE SWAP BASE @ M* DROP + DPL @ 1+ IF 1 DPL +! THEN R> REPEAT R> ; : NUMBER ( addr -- n ) 0 SWAP DUP 1+ C@ 45 = NEGATE DUP>R + -1 BEGIN DPL ! CONVERT DUP C@ DUP BL = 0= AND WHILE DUP ?PUNCT NOT ERROR" ? " 0 REPEAT DROP R> IF NEGATE THEN ; \ (.S) .S QUERY 'C .MS 020186 ART : (.S) ( -- ) ." [ " DEPTH . ." ] " DEPTH 0> IF DEPTH 03 MIN ?DUP IF 1 SWAP DO ." \ " I PICK . -1 +LOOP THEN THEN ; : .S ( -- ) CR (.S) ; : QUERY ( -- ) TIB @ 080 EXPECT TIB @ CNT @ + 0 OVER C! 1+ 0 SWAP C! BL EMIT ; \ { \ : ; TURNKEY.VECTOR 020186 ART \ { ( -- ) 125 WORD DROP ; IMMEDIATE : \ ( -- ) >IN @ 32704 AND 064 + >IN ! ; IMMEDIATE : : ( -- ) ?EXEC !CSP CURRENT @ CONTEXT ! CREATE SMUDGE 07 07 (N--N) LATEST CFA DP ! COLON.TYPE ] ; IMMEDIATE : ; ( -- ) ?CSP ?COMP ,RTS SMUDGE !#BYTES [COMPILE] [ ; IMMEDIATE VARIABLE TURNKEY.VECTOR \ executed in COLD \ INTERPRET QUIT 050586 ART : INTERPRET ( -- | new outer interpreter ) BEGIN ?STACK FIND ?DUP IF DUP ?IMMEDIATE COMPILING > IF ELSE DUP ?DEPTH CFA EXECUTE THEN ELSE POCKET 1+ C@ 0= IF EXIT THEN POCKET NUMBER [COMPILE] LITERAL THEN AGAIN ; : QUIT ( -- ) NEW.BP BLK OFF [COMPILE] [ BEGIN COMPILING NOT IF ." OK " DEPTH IF (.S) THEN THEN RP! CR QUERY >IN OFF INTERPRET AGAIN ; \ LOAD +LOAD THRU +THRU 030586 ART : LOAD ( n -- ) BLK @ >R >IN @ >R >IN OFF BLK ! INTERPRET R> >IN ! R> BLK ! ; : +LOAD ( n -- ) BLK @ + LOAD ; : THRU ( a/b -- ) 1+ SWAP DO I LOAD LOOP ; : +THRU ( a/b -- ) SWAP BLK @ + SWAP BLK @ + THRU ; : --> ( -- | loads following screen ) BLK @ 0= ERROR" ? Can't use from terminal!" >IN OFF 1 BLK +! ; IMMEDIATE : COLD ( -- ) ( NEW.BP ) DECIMAL CURRENT OFF CONTEXT OFF SP! ( PAGE ) ." ART-Forth 1.0 (c) 1987 A.R.T." CR LAST.BLK OFF TURNKEY.VECTOR @ ?DUP IF EXECUTE THEN QUIT ; \ File block offsets *LOAD *THRU 030186 ART 0000 CONSTANT >WORDS \ start of ART.WORDS : *LOAD ( n -- | loads from source file ) >WORDS + LOAD ; : *THRU ( start/end -- | loads range of screens from source ) SWAP >WORDS + SWAP >WORDS + THRU ; : EXTEND ( -- ) CR ." Extending System..." 127 *LOAD ; \ ' RESTART.INPUT <'> BERR.HANDLERS 16 + ! \ ' RESTART.OUTPUT <'> BERR.HANDLERS 20 + ! ( ' EXTEND ' TURNKEY.VECTOR 8+ ! ) UNIQUE.MSG ON ' QUIT ' 8+ ! +ART COLD \ EXTEND 050986 ART 128 137 *THRU \ XX CASE-ENDCASE NLIST IFTRUE-IFEND UNIQUE.MSG OFF >ASSEMBLER LOAD UNIQUE.MSG ON 138 141 *THRU \ Q-VARS UNIQUE.MSG OFF >DISASM LOAD UNIQUE.MSG ON CR ." A Little More Extending..." 142 173 *THRU \ -DUMP -VOCAB BLOCK WINDOWS SET-FENCE >OPTIMISER LOAD >DEBUG LOAD ADD$WORD (,") ADD$WORD (") ADD$WORD (.") ADD$WORD (ERROR") \ X XX ASCII 020986 ART : XX ( -- | print base ) BASE @ >R DECIMAL R@ 10 = IF ." DECIMAL " ELSE R@ 16 = IF ." HEX " ELSE R@ 2 = IF ." BINARY " ELSE R@ . ." (DECIMAL) " THEN THEN THEN R> BASE ! ; : X ( -- | swap between hex and decimal ) 10 BASE @ 10 = IF 6+ THEN BASE ! XX ; : ASCII ( -- ascii value of following char ) BL WORD 1+ C@ [COMPILE] LITERAL ; \ ENABLE DISABLE 020186 ART : DISABLE ( -- | disables following word by storing first ) \ word in the last, and a RTS in the last -FIND DUP CFA SWAP @#BYTES OVER + 2- DUP W@ = 0= ERROR" Can't disable words that don't end in a RTS!" OVER W@ SWAP W! SWAP W! ; : ENABLE ( -- | enables following word by storing last word ) \ in first, and storing a RTS in the last word -FIND DUP CFA SWAP @#BYTES OVER + 2- OVER W@ = 0= ERROR" already enabled!" DUP W@ ROT W! SWAP W! ; \ Case statement 020186 ART HEX 201E CONSTANT 6600 CONSTANT B096 CONSTANT 588E CONSTANT DECIMAL : CASE ( -- csp/4 ) ?COMP CSP @ !CSP 4 ; IMMEDIATE : OF ( 4 -- addr/5 ) 4 ?PAIRS W, W, W, HERE 0 W, W, 5 ; IMMEDIATE : ENDOF ( addr/5 -- addr/4 ) 5 ?PAIRS W, HERE 0 W, SWAP HERE OVER - SWAP W! 4 ; IMMEDIATE : ENDCASE ( csp/addr1/...addrN/4 -- ) 4 ?PAIRS W, BEGIN SP@ CSP @ = NOT WHILE HERE OVER - SWAP W! REPEAT CSP ! ; IMMEDIATE \ LIST *LIST INDEX LF ?VOC 020986 ART : LIST ( block# -- ) BLOCK 16 0 DO CR DUP I 64* + 64 TYPE LOOP DROP CR ; : *LIST ( block# -- ) >WORDS + LIST ; : INDEX ( start/end block -- ) 1+ SWAP DO CR I 4 .R ." : " I BLOCK 64 TYPE LOOP CR ; : LF ( -- | emits linefeed ) 10 EMIT ; : ?VOC ( -- | prints CURRENT & CONTEXT ) CR ." CURRENT=" CURRENT ? 3 SPACES ." CONTEXT=" CONTEXT ? ; \ FIX.LINK (FORGET) 020186 ART : SHORTEN.LINK ( nfa.addr/link# -- ) \ sets link.ptr to point to first node in link after addr 2* LINK.PTR @ + DUP W@ >R OVER R@ VOC.BASE @ + > R> AND IF ( link not zero ) DUP>R W@ VOC.BASE @ + BEGIN 2DUP > OVER W@ AND WHILE DUP W@ + REPEAT \ found first link after nfa.addr, or terminal nfa SWAP OVER < IF VOC.BASE @ - ELSE DROP 0 THEN R> W! ELSE ( link was zero ) 2DROP THEN ; : (FORGET) ( nfa -- ) FENCE @ ?DUP IF OVER CFA > ERROR" Can't forget below fence!" THEN 8+ 256 0 DO DUP I SHORTEN.LINK LOOP 8- DUP 8+ COUNT + =CELLS LAST.NFA ! CFA DP ! ; \ FORGET PURGE -LATEST ?SIZE 020886 ART : FORGET ( -- ) -FIND (FORGET) ; : PURGE ( -- | forgets following word if it exists ) FIND ?DUP IF (FORGET) THEN ; : -LATEST ( -- | removes latest word ) LATEST (FORGET) ; : ?SIZE ( -- | prints size of following word ) -FIND @#BYTES . ." bytes " ; \ Vocab traversal words 030386 ART : S.0 ( n/spaces -- ) >R DUP ABS <# #S SWAP SIGN #> R> OVER - SPACES TYPE ; : NEXT.NFA ( nfa -- next nfa ) DUP 8+ C@ 30 AND + 10+ ; : >CONTEXT ( nfa -- next entry in CONTEXT vocab ) BEGIN DUP 8+ C@ 32/ CONTEXT @ = NOT OVER @ AND WHILE NEXT.NFA REPEAT ; VARIABLE TOTAL#BYTES VARIABLE TOTAL#ENTRIES \ Vocab listing routines 020986 ART : HTAB ( col -- | tab to given column ) COL @ - 1+ SPACES ; : .#BYTES ( nfa -- ) DECIMAL @#BYTES DUP TOTAL#BYTES +! 4 .R ." bytes " HEX 1 TOTAL#ENTRIES +! ; : .STACK-IO ( nfa -- ) 7+ C@ DUP 8/ ." ( " 7 AND DUP 7 = IF DROP ." ? " ELSE . THEN ." -- " 7 AND DUP 7 = IF DROP ." ? " ELSE . THEN ." ) " ; : .IMM ( nfa -- ) ?IMMEDIATE IF ." imm " THEN ; : .WITHIN ( nfa -- ) DUP ?INLINE IF ." inline " THEN DUP ?SUBR IF ." subr " THEN ?DON'T-OPTIMISE IF ." no-opt " THEN ; \ (NLIST) NLIST NFROM 030386 ART : (NLIST) ( nfa to start listing from -- ) BASE @ HEX SWAP TOTAL#BYTES OFF TOTAL#ENTRIES OFF TAKE-KBD BEGIN >CONTEXT DUP @ ?KBD-SLOW 0= AND WHILE CR DUP CFA >REL 6 S.0 2 SPACES DUP .WORD-TYPE 15 HTAB DUP 8+ C@ 31 AND OVER 9+ SWAP TYPE 34 HTAB DUP .STACK-IO DUP .#BYTES DUP .IMM DUP .WITHIN NEXT.NFA REPEAT DROP DECIMAL CR 8 SPACES ." Total:" TOTAL#ENTRIES @ 3 .R ." entries" 18 SPACES TOTAL#BYTES @ 6 .R ." bytes " BASE ! RELEASE-KBD ; : NLIST ( -- | nlist from latest entry ) LATEST (NLIST) ; : NFROM ( -- | nlist from given entry ) -FIND (NLIST) ; \ IFTRUE OTHERWISE IFEND 020186 ART : IFEND ( -- ) ; : OTHERWISE ( -- | searches for IFEND or OTHERWISE ) BEGIN FIND CFA >REL POCKET 1+ C@ 0= ERROR" Missing IFTRUE or OTHERWISE! " [ LATEST CFA >REL ] LITERAL OVER = SWAP [ ' IFEND >REL ] LITERAL = OR UNTIL ; : IFTRUE ( flag -- ) 0= IF OTHERWISE THEN ; \ Q-VAR TO 020186 ART exit ADD.TYPE Q-VAR.TYPE ( -- ) : Q-VAR ( -- | creates a q-var of the form ) \ LEA d(A5),A0 PUSH (A0) with d offset from BP CREATE Q-VAR.TYPE LATEST CFA DP ! ASSEMBLER HERE 8+ >REL ABS 32766 > IF HERE 8+ @#L PUSH, ELSE HERE 6+ >REL A5 I) PUSH, THEN ,RTS !#BYTES , ; : TO ( n -- ) -FIND DUP CFA SWAP @#BYTES + COMPILING IF ASSEMBLER DUP>R >REL ABS 32766 > IF SP )+ R> @#L LMOVE, ELSE SP )+ R> >REL A5 I) LMOVE, THEN ELSE ! THEN ; IMMEDIATE \ ZERO SET 020186 ART exit : ZERO ( -- ) -FIND DUP CFA SWAP @#BYTES + COMPILING IF ASSEMBLER DUP>R >REL ABS 32766 > 0 D0 MOVEQ, IF D0 R> @#L LMOVE, ELSE D0 R> >REL A5 I) LMOVE, THEN ELSE OFF THEN ; IMMEDIATE : SET ( -- ) -FIND DUP CFA SWAP @#BYTES + COMPILING IF ASSEMBLER DUP>R >REL ABS 32766 > -1 D0 MOVEQ, IF D0 R> @#L LMOVE, ELSE D0 R> >REL A5 I) LMOVE, THEN ELSE ON THEN ; IMMEDIATE \ INC DEC 020186 ART exit : INC ( -- ) -FIND DUP CFA SWAP @#BYTES + COMPILING IF ASSEMBLER DUP>R >REL ABS 32766 > IF R> @#L 1 LONG ADDQ, ELSE R> >REL A5 I) 1 LONG ADDQ, THEN ELSE 1 SWAP +! THEN ; IMMEDIATE : DEC ( -- ) -FIND DUP CFA SWAP @#BYTES + COMPILING IF ASSEMBLER DUP>R >REL ABS 32766 > IF R> @#L 1 LONG SUBQ, ELSE R> >REL A5 I) 1 LONG SUBQ, THEN ELSE -1 SWAP +! THEN ; IMMEDIATE \ ADD SUB 020186 ART exit : ADD ( n -- ) -FIND DUP CFA SWAP @#BYTES + COMPILING IF ASSEMBLER DUP>R >REL ABS 32766 > D0 POP, IF R> @#L FROM D0 LONG ADD, ELSE R> >REL A5 I) FROM D0 LONG ADD, THEN ELSE +! THEN ; IMMEDIATE : SUB ( n -- ) -FIND DUP CFA SWAP @#BYTES + COMPILING IF ASSEMBLER DUP>R >REL ABS 32766 > D0 POP, IF R> @#L FROM D0 LONG SUB, ELSE R> >REL A5 I) FROM D0 LONG SUB, THEN ELSE SWAP NEGATE SWAP +! THEN ; IMMEDIATE \ BLANK 020186 ART \ Print JSR destination 030686 ART exit VARIABLE PC : ?JSR ( addr -- flag if JSR instruction ) W@ DUP <,A5.JSR.W> = SWAP = OR ; HEX : JSR.INFO ( addr -- jsr destination/instruction length ) DUP W@ <,A5.JSR.W> = IF 2+ W@ >ABS 4 ELSE 2+ @ 6 THEN ; DECIMAL : .JSR ( -- | prints jsr info ) CR PC @ 8 .R 10 SPACES ." JSR " PC @ JSR.INFO PC +! DUP LATEST LOCATE ?DUP IF ID. ELSE ." headerless" THEN 48 COL @ - SPACES . ; \ Print user variables 020986 ART exit : ?USER ( addr -- flag ) W@ <,A4.LEA> = ; CREATE USER.WORDS 8 W, ," FOLLOWER" 12 W, ," S0" 16 W, ," R0" 44 W, ," DP" 52 W, ," CONSOLE" 68 W, ," CNT" 72 W, ," COL" 76 W, ," LINE#" 80 W, ," BASE" 84 W, ," DPL" 88 W, ," HLD" 92 W, ," STATE" 96 W, ," TIB" 100 W, ," BLK" 104 W, ," >IN" 108 W, ," OFFSET" 176 W, ," CONTEXT" 180 W, ," CURRENT" 120 W, ," TRUNK" 128 W, ," FENCE" 132 W, ," CSP" 136 W, ," SCR" 140 W, ," R#" 152 W, ," ROW" 184 W, ," LAST.NFA" 188 W, ," VOC.BASE" 192 W, ," VOC.SIZE" 196 W, ," LINK.PTR" 140 W, ," LAST.BLK" 8 W, ," BLK.ADDR" 200 W, ," POCKET" 0 W, \ Print user variables 020186 ART exit : .USER ( -- | prints user name if in list, else its number ) PC @ 2+ W@ ( user# ) USER.WORDS 0 >R CR PC @ 8 .R 10 SPACES ." LEA " BEGIN 2DUP W@ DUP WHILE = IF R> DROP DUP>R THEN 2+ COUNT + =CELLS REPEAT R> ?DUP IF 2+ COUNT TYPE 2DROP ELSE DROP ." USER#" . THEN 2DROP ." ,A0" 48 COL @ - SPACES PC @ DUP 4+ PC ! DUP W@ 4 .R SPACE 2+ W@ 4 .R ; : .INFO ( nfa -- | prints stack usage, ?immediate ) DUP .STACK-IO DUP .IMM .WITHIN ; \ Print variable's name 020186 ART exit : ?VAR ( addr -- flag ) W@ <,A5.LEA> = ; : .VAR ( -- | prints variable name if valid, else address ) PC @ 2+ W@ ( var offset from BP ) >ABS DUP 8- LAST.NFA @ LOCATE ?DUP IF CR PC @ 8 .R 10 SPACES ." LEA " ID. ." ,A0" 48 COL @ - SPACES . 4 PC +! ELSE DROP 1DISASM THEN ; \ String printout routines 030686 ART exit 12 CONSTANT #$WORDS CREATE $WORDS HERE #$WORDS 4* DUP ALLOT ERASE : ADD$WORD ( -- | adds cfa of following word to table ) FIND CFA $WORDS BEGIN DUP @ WHILE 4+ REPEAT DUP #$WORDS 4* $WORDS + > ERROR" $WORD table full!" ! ; : ?$WORD ( cfa -- true flag if in $WORD table ) #$WORDS 0 DO DUP $WORDS I 4* + @ = IF DROP 0 LEAVE THEN LOOP NOT ; : .CALL ( -- | prints jsr info or string contents ) PC JSR.INFO DROP ?$WORD .JSR IF CR PC DUP 8 .R DUP C@ 1+ =CELLS OVER + TO PC 10 SPACES 34 EMIT COUNT TYPE 34 EMIT THEN ; \ Word disassembly - ?? 030486 ART exit VARIABLE ?END \ if set, then (??) terminated by key press : 1?? ( -- ) PC ?JSR IF .CALL ELSE PC ?VAR IF .VAR ELSE PC ?USER IF .USER ELSE 1DISASM THEN THEN THEN ; : (??) ( nfa -- | disassembles word ) TAKE-KBD BASE @ HEX SWAP DUP CFA DUP TO PC SWAP @#BYTES + 1- BEGIN 1?? PC OVER > ?KBD-SLOW DUP ?END ! OR UNTIL DROP BASE ! RELEASE-KBD ; \ Word disassembly - ??? 030486 ART exit : ?? ( -- | disassembles one word ) -FIND (??) ; : (???) ( nfa -- | disassembles all words from nfa down ) ?END OFF BEGIN CR CR DUP 8+ C@ 31 AND DUP>R OVER 9+ SWAP TYPE 6 SPACES DUP .INFO CR DUP (??) R> 30 AND + 10+ DUP @ 0= ?END @ OR UNTIL DROP ; : ??? ( -- | disassembles all words ) LATEST (???) ; : ???FROM ( -- | disassembles from name ) -FIND (???) ; \ BLANK 022886 ART \ $ MYSELF 020186 ART : $ ( -- | evaluates following number in HEX ) BASE @ >R HEX BL WORD BL OVER COUNT + C! NUMBER [COMPILE] LITERAL R> BASE ! ; IMMEDIATE : MYSELF ( -- | recursively calls latest word ) LATEST CFA ,JSR ; IMMEDIATE \ REBUILD.LINKS 020186 ART : ERASE.LINKS ( -- ) LINK.PTR @ 512 ERASE ; : FOLLOW.LINK ( link#*2 -- addr of last node on link or zero ) LINK.PTR @ + W@ DUP IF VOC.BASE @ + BEGIN DUP W@ DUP>R + R> 0= UNTIL THEN ; : INSERT.LINK ( nfa.addr/link#*2 -- | adds a link to nfa.addr ) DUP FOLLOW.LINK DUP IF >R DROP DUP R@ - R> W! ELSE DROP >R DUP VOC.BASE @ - R> LINK.PTR @ + W! THEN 0 SWAP W! ; ( zero link in nfa.addr ) : REBUILD.LINKS ( -- ) ERASE.LINKS LATEST BEGIN DUP DUP 8+ HASH INSERT.LINK NEXT.NFA DUP @ 0= UNTIL DROP ; \ BEHEAD AXE -VOCAB 020186 ART : (BEHEAD) ( nfa -- | removes nfa from vocab ) LATEST OVER - NEGATE >R ( count ) LATEST ( from ) SWAP DUP NEXT.NFA - NEGATE DUP LAST.NFA +! ( #removed ) OVER + ( to ) R> CMOVE> ; : BEHEAD ( nfa -- ) (BEHEAD) REBUILD.LINKS ; : AXE ( -- | beheads following word ) -FIND BEHEAD ; : -VOCAB ( -- | removes CONTEXT vocab ) CONTEXT @ 0= ERROR" Can't remove FORTH vocab!" LATEST BEGIN DUP >CONTEXT DUP @ WHILE LATEST SWAP (BEHEAD) LATEST - NEGATE + REPEAT 2DROP REBUILD.LINKS [COMPILE] FORTH ; \ ROOM 020186 ART : ROOM ( -- | displays available space ) BASE @ DECIMAL HERE BASE.PTR - CR 6 .R ." object bytes used" VOC.SIZE @ LAST.NFA @ VOC.BASE @ - - 14 SPACES 6 .R ." vocab bytes used" SP@ HERE 256 + - CR 6 .R ." object bytes available" LAST.NFA @ VOC.BASE @ - 9 SPACES 6 .R ." vocab bytes available" 2 SPACES BASE ! ; \ NOES/LINK SHOW.LINKS SHOW.LINK 020186 ART : NODES/LINK ( link# -- nodes on link | link# = 0-255 ) 2* LINK.PTR @ + W@ DUP IF VOC.BASE @ + 1 >R BEGIN DUP W@ DUP>R + R> WHILE R> 1+ >R REPEAT DROP R> THEN ; : SHOW.LINKS ( -- ) TAKE-KBD 256 0 DO I NODES/LINK CR I 3 .R ." : " DUP 4 .R SPACE 150 MIN ?DUP IF 0 DO ." *" LOOP THEN ?KBD-SLOW IF LEAVE THEN LOOP ; : SHOW.LINK ( link# -- ) 2* LINK.PTR @ + W@ ?DUP IF VOC.BASE @ + BEGIN DUP 2 SPACES ID. DUP W@ DUP>R + R> 0= UNTIL DROP THEN ; \ 1DUMP .HEADER .0R 020186 ART : .0R ( n/size -- | prints with leading zeros ) >R <# #S #> R> OVER - ?DUP IF 0 DO ." 0" LOOP THEN TYPE ; : 1DUMP ( addr -- | dumps one line ) CR 1- =CELLS DUP 8 .R 3 SPACES 08 0 DO DUP I 2* + W@ 4 .0R SPACE LOOP 2 SPACES 91 EMIT 16 0 DO DUP I + C@ 127 AND DUP 31 > IF EMIT ELSE DROP 46 EMIT THEN LOOP 93 EMIT DROP ; : .HEADER ( addr -- | prints header ) CR 1- =CELLS 12 SPACES 8 0 DO DUP I 2* + 255 AND 2 .0R 3 SPACES LOOP DROP ; \ +DUMP -DUMP 020186 ART : +DUMP ( addr/cnt -- | dumps range ) TAKE-KBD BASE @ >R HEX CR 1- =CELLS OVER .HEADER 0 DO DUP I+ 1DUMP ?KBD-SLOW IF LEAVE THEN 16 +LOOP DROP R> BASE ! RELEASE-KBD ; : -DUMP ( addr -- | dumps until key press ) TAKE-KBD BASE @ >R HEX CR 1- =CELLS DUP .HEADER BEGIN DUP 1DUMP 16 + ?KBD-SLOW UNTIL DROP R> BASE ! RELEASE-KBD ; \ BLANK 020186 ART \ #FCBS FCB.SIZE FIRST LIMIT FIRST.FCB 1024* 022886 ART 30 CONSTANT #FCBS \ # of fcbs to allocate 4 CONSTANT FCB.SIZE \ size of each fcb in bytes CREATE FIRST.FCB HERE #FCBS FCB.SIZE * DUP ALLOT ERASE \ FCB format: BLK# (2) UPDATED (2) CREATE END-OF-FCBS CODE *BUFFSIZE ( n -- n*1026 ) D0 POP, D0 D2 LMOVE, D2 TO D2 LONG ADD, 10 D1 MOVEQ, D0 D1 LONG ASL, D2 TO D0 LONG ADD, D0 PUSH, RETURN CREATE FIRST #FCBS *BUFFSIZE ALLOT CREATE LIMIT \ +BLK# PREV >BUFFER >FCB ?IN.BUFER UPDATE 030186 ART : +BLK# ( addr -- addr+offset ) ; : +UPDATE ( addr -- addr+offset ) 2+ ; 0 Q-VAR PREV : >BUFFER ( buffer# -- buffer address ) *BUFFSIZE FIRST + ; : >FCB ( fcb# -- fcb.addr ) 4* FIRST.FCB + ; : ?IN.BUFFER ( block# -- buffer# or -1 ) -1 #FCBS 0 DO OVER I >FCB +BLK# W@ = IF DROP I LEAVE THEN LOOP SWAP DROP ; : UPDATE ( -- ) -1 PREV >FCB +UPDATE W! ; : CLEAR.UPDATE ( -- ) 0 PREV >FCB +UPDATE W! ; \ NEXT.FCB EMPTY-BUFFERS @BLOCK !BLOCK 021686 ART : NEXT.FCB ( -- | increments fcb# of next fcb to use ) PREV 1+ DUP #FCBS 1- > IF DROP 0 THEN TO PREV ; : EMPTY-BUFFERS ( -- ) FIRST LIMIT 8- OVER - ERASE FIRST.FCB END-OF-FCBS 8- OVER - ERASE LAST.BLK OFF SET PREV ; : E-B ( -- ) EMPTY-BUFFERS ; EMPTY-BUFFERS : @BLOCK ( block# -- | reads from disk ) >R PREV >BUFFER R@ 1 R/W R> PREV >FCB DUP>R +BLK# W! 0 R> +UPDATE W! ; : !BLOCK ( block# -- | writes to disk ) DUP>R ?IN.BUFFER DUP 0< ERROR" !BLOCK - block not found!" >BUFFER R> 0 R/W CLEAR.UPDATE ; \ ?!BLOCK (BLOCK) FLUSH 020186 ART : ?!BLOCK ( -- | stores previous block if updated ) PREV >FCB +UPDATE W@ IF PREV >FCB +BLK# W@ !BLOCK THEN ; : (BLOCK) ( block# -- block.addr ) DUP ?IN.BUFFER DUP 0< IF DROP NEXT.FCB ?!BLOCK @BLOCK PREV ELSE SWAP DROP THEN >BUFFER ; : FLUSH ( -- ) PREV #FCBS 0 DO I TO PREV ?!BLOCK LOOP TO PREV ; \ FBLOCK 022886 ART CODE FBLOCK ( block# -- block address ) D0 GET, LAST.BLK )UP D0 LONG CMP, NE IF, D0 PUSH, >FORTH (BLOCK) >CODE D1 POP, D0 POP, D1 PUSH, D0 LAST.BLK )UP LMOVE, D1 BLK.ADDR )UP LMOVE, ELSE, BLK.ADDR )UP PUT, THEN, RETURN ' FBLOCK REVECTORS BLOCK \ SHOW.BLOCKS GET.BLOCKS 030486 ART : SHOW.BLOCKS ( -- | shows blocks in buffer ) #FCBS 0 DO FIRST.FCB I 4* + W@ . LOOP ; : GET.BLOCKS ( block#/count -- | puts blocks in buffer ) #FCBS MIN OVER + SWAP DO I BLOCK DROP LOOP ; \ BLANK 030486 ART \ BLANK 030486 ART \ BLANK 030486 ART \ BLANK 020186 ART \ Windows - format 030486 ART EXIT Window record format: Offset Size Field Name Comment ------ ---- ---------- ------- 0 2 WNDTOP window top co-ordinate 2 2 WNDLEFT window left co-ordinate 4 2 WNDBOT window bottom co-ordinate 6 2 WNDRIGHT window right co-ordinate 8 2 FORCED.CR if true, then cr at line end 10 2 COL value when last deselected 12 2 ROW value when last deselected \ Windows - NEW.WINDOW 030486 ART : +FORCED.CR ( addr -- addr+offset ) 8+ ; : + ( addr -- addr+offset ) 10 + ; : + ( addr -- addr+offset ) 12 + ; : W.BOUNDS ( top/left/bottom/right/wptr -- ) DUP>R 6+ W! R@ 4+ W! R@ 2+ W! R> W! ; : FORCE.CR ( wptr -- | forces CR on end of line ) -1 SWAP +FORCED.CR W! ; : NEW.WINDOW ( -- | builds window definition ) CREATE HERE DUP>R 14 DUP ALLOT ERASE 10 10 18 40 R> W.BOUNDS ( default window bounds ) ; \ Windows - WINDOW 030486 ART : WINDOW ( wptr -- | makes wptr the active window ) \ save current window settings WPTR @ ?DUP \ get current window pointer IF >R \ don't save old vars if no existing window @COL R@ + W! @ROW R> + W! THEN \ install new wptr settings DUP W@ WNDTOP ! DUP 2+ W@ WNDLEFT ! DUP 4+ W@ WNDBOT ! DUP 6+ W@ WNDRIGHT ! DUP +FORCED.CR W@ FORCED.CR ! DUP + W@ COL ! DUP + W@ ROW ! WPTR ! ; \ Windows - SYS.WINDOW 030486 ART WPTR OFF \ no existing window NEW.WINDOW SYS.WINDOW 0 1 24 79 SYS.WINDOW W.BOUNDS SYS.WINDOW FORCE.CR SYS.WINDOW WINDOW 0 6 VHTAB NEW.WINDOW TEST.WINDOW \ End of EXTEND load sequence \ RAM Test 050986 ART CODE READS ( addr/n -- | reads RAM n times ) D0 POP, A0 POP, BEGIN, A0 () LONG TST, D0 LOOP, NEXT END-CODE CODE WRITES ( addr/n -- | writes RAM n times ) D0 POP, A0 POP, BEGIN, D0 A0 () LONG MOVE, D0 LOOP, NEXT END-CODE hex : NIK F00000 300000 READS ; : NOK F00000 300000 WRITES ; : NIK1 E80000 300000 READS ; : NOK1 E80000 300000 WRITES ; decimal 3 +LOAD \ Vocab statistics 030486 ART CREATE FREQUENCIES HERE 256 4* DUP ALLOT ERASE VECTOR NAME>STAT# : @STATS ( -- ) FREQUENCIES 1024 ERASE LATEST BEGIN DUP NAME>STAT# 255 AND 4* FREQUENCIES + 1 SWAP +! NEXT.NFA DUP @ 0= UNTIL DROP ; : GRAPH ( -- ) TAKE-KBD 256 0 DO FREQUENCIES I 4* + @ CR I 3 .R ." : " DUP 4 .R 200 MIN 0 DO ." *" LOOP ?KBD-SLOW IF LEAVE THEN LOOP ; : USE -FIND CFA ' NAME>STAT# 8+ DUP >REL ABS 32766 > IF 2+ THEN ! ; \ Vocab statistics 030486 ART : CHI ( -- | computes chi-square for frequency table ) 0 255 0 DO FREQUENCIES I 4* + @ DUP * + LOOP . ; : STATS ( -- ) @STATS GRAPH CR ." Chi-squared: " CHI ; : INITIAL ( nfa -- n ) 9+ C@ ; : LENGTH ( nfa -- n ) 8+ C@ 31 AND ; : HASH. ( nfa -- n ) 8+ HASH 2/ ; : COMBO ( nfa -- n ) DUP 8+ C@ 1- 7 AND 32* OVER 9+ C@ 7 AND 4* OR SWAP 10+ C@ 3 AND OR ; : SUM ( nfa -- n ) 0 SWAP 8+ DUP C@ 1+ OVER + SWAP DO I C@ + LOOP ; \ RAM test 050986 ART hex F00000 CONSTANT BB 80000 CONSTANT LL E80000 CONSTANT AA : FISH LL 0 DO I BB I+ W! 2 +LOOP ; : INIT BB LL 55 FILL ; CODE W@ 0 D0 MOVEQ, A0 POP, A0 () D0 WORD MOVE, D0 PUSH, NEXT END-CODE : PIP BEGIN NIK ?TERMINAL UNTIL ; : PIP1 BEGIN NIK1 ?TERMINAL UNTIL ; : -DUMP ( n -- ) 010000 * BEGIN DUP DUP 010 + +DUMP 010 + ?KBD-SLOW UNTIL DROP ; decimal : CK LL 0 DO DUP BB I+ W@ = NOT IF I . THEN 2 +LOOP DROP ; : CK1 LL 0 DO DUP AA I+ W@ = NOT IF I . THEN 2 +LOOP DROP ; \ Machine-coded FIND 030486 ART CODE FIND ( -- nfa or zero ) ] BL WORD DUP >UC? [ A0 GET, ( $addr ) A0 () D0 BYTE MOVE, ( count ) 0 D1 MOVEQ, D1 D0 1 WORD A0 @I) BYTE MOVE, \ +trailing CONTEXT -U 2+ A4 I) D1 WORD MOVE, D1 TO D0 BYTE OR, D0 A0 () BYTE MOVE, \ search context first D0 PUSH, A0 PUSH, A0 PUSH, ] HASH [ LINK.PTR -U A4 I) A1 LONG LEA, SP )+ A1 LONG ADDA, A1 () D1 WORD MOVE, VOC.BASE -U A4 I) D1 LONG ADD, D1 PUSH, D1 PUSH, ] (FIND) [ : FIND ( -- nfa addr or zero | takes string from pocket ) R@ DUP HASH LINK.PTR @ + W@ VOC.BASE @ + DUP>R (FIND) DUP IF R>DROP R>DROP ELSE DROP R> R@ C@ 31 AND R> C! \ search forth POCKET SWAP (FIND) THEN ; \ RAM refresh timing 050986 ART : 10K-NOPS 10000 0 DO ASSEMBLER NOP, LOOP ; CODE (TEST) 10K-NOPS RETURN : TEST CR ." Test times should be between 5290 and 5460 ms." CR ." This board's time is... " ?RTC 1000 0 DO (TEST) LOOP .MS ; --> O O OOOOOO OOOOO OOOOO O O O O O O O O O O O O O O O O O O OOOOOO O OOOOOOO O O O O O O O O O O O O O O O OOOOOO O O O OOOO OOOOO O O OOOOO OOO O OOOOO OOOOO O O O O OO OO O O O O O O O O O O O O O O O O O O O O O O O O O O O O OOOOO O O OOOOO OOOOO O O O O O O O O O O O O O O O O O O O O O O O O OOOO OOOOO O O O OOO OOOOOO OOOOO O O \ Meta-compiler - load screen CR ." Loading Cross-Compiler..." CR CR CR : IT ; DECIMAL VARIABLE LABEL \ used as a label by machine-code words \ eg... HERE LABEL ! D0 POP, LABEL @ NE BCC, hex 20800 CONSTANT RAM-BASE decimal --> \ Meta-compiler - load screen : COPY.USERS \ copy user variables to high RAM RAM-BASE $ 21C + DUP>R @ STATUS R@ 512 CMOVE R> ! ; \ restore startup vector : !SNAPSHOT \ save 24k from $20800 to blocks 300-323 RAM-BASE 24 0 DO DUP 300 I+ BLOCK 1024 CMOVE UPDATE FLUSH 1024 + LOOP DROP ; : SNAP \ complete snapshot COPY.USERS !SNAPSHOT ; --> --> Threaded Forth - vocabulary format 2 bytes : relative offset to next nfa in hashed chain 1 byte : length of object code in words, max 255 3 bytes : address of object code 1 byte : D7 = subr - forces call to routine D6 = inline - forces embedding within the using word, rather than a call, speeding execution D5 = don't optimise D0-D4 = word type: code/colon/variable/constant..etc 1 byte : D7 = precedence bit D6 = reserved D3-D5 = # stack words required on entry D0-D2 = # stack words left on exit 1 byte : D0-D4 = name count D5-D7 = vocabulary# (0-7), 0=FORTH, 1=TRANSIENT n bytes : variable length name, terminating on an even address --> Threaded Forth - register usage A7 = return stack pointer A6 = parameter stack pointer A5 = pointer to start of object (constant=BASE.PTR) A4 = pointer to user area (constant=USER.PTR) Note: All short addressing other than the user area (eg/ variables) is relative to BP All other registers are available for temporary use. \ Cross-compiler activation & deactivation 031086 ART CREATE END-OF-SMUDGING : UNSMUDGE \ unsmudges all words to end-of-smudging !LINKS BEGIN NEXT-LINK DUP END-OF-SMUDGING > WHILE 4+ DUP C@ 32 AND IF 32 TOGGLE ELSE DROP THEN REPEAT DROP ; CREATE ART.FLAG 0 , \ true if in ART-Forth CREATE ALONE 0 , \ true if imm words used in new vocab CREATE OPTIMISER 0 , \ true if optimiser turned on --> \ *LOAD *THRU RETURN 031086 ART 0 CONSTANT >WORDS ( start of ART.WORDS file ) : *LOAD ( n -- | load screen from source code file ) >WORDS + LOAD ; : *THRU ( start\end -- | load range of screens from source ) 1+ SWAP DO I . I *LOAD LOOP ; : RETURN ASSEMBLER NEXT END-CODE ; CREATE LAST.IN 0 , \ used by new INTERPRET : BOOLEAN 0= 0= ; : 32* 32 * ; : 32/ 32 / ; --> \ Vocab area decleration 031086 ART 5 *LOAD 20000 VOC.SIZE ! HERE VOC.BASE ! VOC.SIZE @ ALLOT VOC.BASE @ VOC.SIZE @ ERASE VOC.BASE @ VOC.SIZE @ + 20 - LAST.NFA ! CURRENT OFF CONTEXT OFF \ zero current & context : ( -- addr ) LATEST ; : LATEST ( -- addr ) LAST.NFA @ ; --> \ LATEST +FORTH +CONTEXT BASE.PTR 022886 ART : +FORTH DROP ; : +CONTEXT DROP ; : BEEP BELL ; CREATE UNIQUE.MSG -1 , : CFA ; : CFA ( nfa -- cfa ) [ hex ] 2+ @ FFFFFF AND [ decimal ] ; : ?VOCAB ; VARIABLE BASE.PTR \ stores base of new object --> \ "LOADING.COMPILER" "LOADING.CODE" "LOADING.COLONS 022886 ART : "LOADING.COMPILER" CR CR ." Loading colon definitions to create compiler... " CR CR ; : "LOADING.CODE" CR CR ." Assembling machine-code definitions into new vocab... " CR CR ; : "LOADING.COLONS" CR CR ." Compiling colon definitions into new vocab... " CR CR ; : "FINISHED" CR ." Finished loading..." CR ; --> \ Keyboard interface 022886 ART : @KEY ( -- n ) 'KEY OVER DUP 64 AND BOOLEAN SWAP 2 AND BOOLEAN XOR IF 32 + THEN \ shift ? SWAP 4 AND \ control ? IF 31 AND THEN ; --> \ BLANK 022886 ART --> \ Assembler Macro's 022886 ART ASSEMBLER DEFINITIONS : (rp) rp () ; : (sp) sp () ; : -(rp) rp -) ; : -(sp) sp -) ; : (rp)+ rp )+ ; : (sp)+ sp )+ ; : rtop rp () ; : top sp () ; : lmove, long move, ; : rpush, -(rp) lmove, ; ( pushes ea onto rs ) : rpop, (rp)+ 2swap lmove, ; ( pulls ea from rs ) : rput, (rp) lmove, ; ( ea --> top rs item ) : rget, (rp) 2swap lmove, ; ( top rs item --> ea ) FORTH DEFINITIONS --> \ ->FORTH ->CODE <-FIND> 022886 ART : ->FORTH ASSEMBLER IP RP -) LMOVE, >FORTH ; : ->CODE ASSEMBLER [COMPILE] >CODE RP )+ IP LMOVE, ; IMMEDIATE : BL-WORD BL WORD DUP COUNT + 0 SWAP C! ; : [COMPILE] LITERAL ; IMMEDIATE : <-FIND> -FIND ; : FIND ; : >UC? DROP ; \ no need to convert to upper case, \ as all kernel words are already in UC. --> \ Words to be defined but not hidden 022886 ART : <[COMPILE]> [COMPILE] [COMPILE] ; IMMEDIATE : FORGET ; : <'> [COMPILE] ' ; IMMEDIATE : IMMEDIATE ; : SMUDGE ; : NFA ; CODE ( addr -- | calls subroutine-threaded word ) A5 RPUSH, BASE.PTR @#L A5 LMOVE, 32766 #W A5 WORD ADDA, A0 POP, A0 () JSR, RP )+ A5 LMOVE, NEXT END-CODE --> \ >ABS >REL VOC.LINKS 030186 ART "LOADING.COMPILER" : QUIT ; HEX : >ABS DUP 7FFF > IF FFFF0000 OR THEN BASE.PTR @ + 7FFE + ; : +BP BASE.PTR @ + 7FFE + ; : >REL BASE.PTR @ 7FFE + - ; DECIMAL CREATE VOC.LINKS HERE 512 DUP ALLOT ERASE VOC.LINKS LINK.PTR ! --> \ Words to be defined but not hidden 030186 ART 119 120 *THRU \ (n--n) 62 *LOAD \ inline, subr, critical.size 29 *LOAD \ (find) 54 *LOAD \ hash 37 38 *THRU \ (.") (") (,") 53 *LOAD \ LOCATE 58 59 *THRU \ ?IMM ?SUBR ?INLINE 63 69 *THRU \ ,JMP ,JSR ,LIT ,RTS ,VAR-CODE : IMMEDIATE ; 100 *LOAD \ FIND [COMPILE] --> \ (FIND") FIND" 022886 ART : (FIND") \ run-time part of FIND" DROP ( drop count ) 1- DUP HASH LINK.PTR @ + W@ VOC.BASE @ + (FIND) DUP 0= ERROR" word not found by COMPILE " ; : FIND" \ FIND" will find the following word in the new \ dictionary at compile time by appending the name string \ to the child word, then searching the new vocab when \ the child is executed at compile time. COMPILING IF COMPILE $LIT THEN 34 WORD DUP COUNT + 0 SWAP C! HERE OVER C@ 1+ =CELLS DUP ALLOT CMOVE COMPILE (FIND") ; --> \ LATEST .WORD-TYPE ?? 022886 ART : LATEST 8- ; \ so that XXX.TYPE is found in old vocab 110 *LOAD \ .word-type, add.type : LATEST LAST.NFA @ ; 85 *LOAD \ ?kbd-slow 134 136 *THRU \ stack usage display, nlist 143 149 *THRU \ word disassembly 25 28 *THRU \ do-loop & if-then constructs : CALL ( calls subroutine-threaded word ) FIND CFA ; --> \ DOCOMP COMPILE 030186 ART : DOCOMP R> DUP 4+ >R @ 4+ DUP C@ 31 AND >R PAD R@ 2+ CMOVE R> PAD C! 0 PAD COUNT + C! PAD DUP HASH LINK.PTR @ + W@ VOC.BASE @ + (FIND) DUP 0= ERROR" not found by DOCOMP" ; : COMPILE ART.FLAG @ IF FIND ,LIT FIND" " CFA ,JSR ELSE <'> DOCOMP , THEN ; --> \ Words to be defined, then hidden 022886 ART 102 103 *THRU \ ." " ," error" 105 107 *THRU \ create does> 111 117 *THRU \ constant variable user vector \ if-then begin-until do-loop : CODE \ begin machine-code definition CREATE -8 ALLOT CODE.TYPE HERE LATEST 2+ ! ( store cfa ) ENTERCODE ; : RETURN \ terminates machine-code definition ASSEMBLER RTS, CURRENT @ CONTEXT ! ?EXEC ?CSP !#BYTES ; --> \ : ; 022886 ART : NULL R> DROP ; : : !CSP CURRENT @ CONTEXT ! CREATE -8 ALLOT COLON.TYPE ( <[COMPILE]> 7 7 (N--N) SMUDGE ] ; IMMEDIATE ( *********************) PASS1 iftrue : OPTIMISE LATEST CFA HERE PASS1 #REMOVED @ NEGATE ALLOT !#BYTES ; : ; ?CSP ?COMP OPTIMISER @ IF OPTIMISE THEN SMUDGE ,RTS !#BYTES [COMPILE] [ ; IMMEDIATE otherwise : ; ?CSP ?COMP SMUDGE ,RTS !#BYTES [COMPILE] [ ; IMMEDIATE ifend --> \ *INTERPRET 022886 ART : *INTERPRET ( used during compilation of new kernel ) begin ?stack >in @ last.in ! find dup ?immediate alone @ 0= and 0= and ?dup if dup ?immediate compiling > if else pocket 1+ c@ \ was it not a null (CR) ? if cfa else drop NULL then then else last.in @ >in ! <-find> ( pfa\imm\found.flag -- ) if compiling > error" attempted to compile old word" ( else immediate old Forth word ) 4- execute else pocket number compiling if ,lit then then then again ; --> \ NEW.ABORT 060586 ART : ?ART art.flag @ if ." ART" else ." Multi" then ." -Forth" ; : NEW.ABORT ' 'interpret 4- ' interpret ! art.flag off ((abort)) ; : NEW.ERROR ' 'interpret 4- ' interpret ! art.flag off ((error)) ; : -ART ( install original interpret ) ' 'interpret 4- ' interpret ! art.flag off ' ((abort)) 4- (abort) ! ' ((error)) 4- (error) ! ; : +ART ( install new interpret ) ' *interpret 4- ' interpret ! art.flag on ' new.abort 4- (abort) ! ' new.error 4- (error) ! ; --> \ Compile colon definitions into new vocab 022886 ART : -ART ; -CURSOR : IMMEDIATE ( -- ) LATEST 7+ DUP C@ 128 OR SWAP C! ; "LOADING.CODE" UNSMUDGE RAM-BASE DP ! \ ** start 128k up ** 4 59 *THRU "LOADING.COLONS" +ART 60 109 *THRU ALONE ON 110 125 *THRU 230 290 *THRU \ load remote control routines "FINISHED" \ BLANK 022886 ART \ Assembler labels - A.R.T. 022886 ART \ These two screens create assembler register labels, up to \ 18 characters long. To use, type A0 IS [ADDR] \ NOTE: All labels must start with a square bracket! 0 Q-VAR BYTES/REG : REG ( reg#/reg.type -- | builds register entry ) CREATE HERE 16 ALLOT 16 BLANKS DOES> [ HERE 42 + ] LITERAL - BYTES/REG / 8 /MOD ; REG [D0] REG [D1] REG [D2] REG [D3] REG [D4] REG [D5] REG [D6] REG [D7] REG [A0] REG [A1] REG [A2] REG [A3] REG [A4] REG [A5] REG [A6] REG [A7] --> \ Assembler labels - A.R.T. 022886 ART ' [D0] CFA @ CONSTANT REG.CFA ' [D1] ' [D0] - TO BYTES/REG : REG>ADDR ( reg#/reg.type -- nfa.addr ) 8* + BYTES/REG * ' [D0] NFA + ; : INSERT.NAME ( reg#/reg.type/$addr -- | inserts name ) ROT ROT REG>ADDR DUP>R OVER C@ 31 AND 2+ CMOVE REG.CFA R@ COUNT + =CELLS ! R> 128 TOGGLE ; : IS ( reg#/reg.type -- | renames given register ) BL WORD INSERT.NAME ; \ PC driver \ I/O - port locations binary 00000010 CONSTANT 10000000 CONSTANT decimal \ 68008 driver hex 80000 CONSTANT DUART decimal : U2/ 2/ ; : KEY? 0 ; : @CLOCK ( -- flag | clock input value ) DUART 13 + C@ 16 AND 0= ; : @DATA ( -- flag | data input value ) DUART 13 + C@ 32 AND 0= ; \ Remote control U8 clock has same polarity as !DATA flag \ Output port is set at DUART+14, reset at DUART+15 : !DATA ( flag -- | store one bit as data out ) BOOLEAN DUART 15 + + SWAP C! ; : MS-WAIT ( time in milliseconds -- ) 0 DO 130 0 DO LOOP LOOP ; \ LED routines : >CLOCK \ wait for clock positive edge, or timeout BEGIN @CLOCK UNTIL BEGIN @CLOCK 0= UNTIL ; : !LED ( data -- | write to LED ) 0 !DATA 1 !DATA >CLOCK 1 !DATA >CLOCK \ send start bit 1 !DATA >CLOCK 0 !DATA >CLOCK \ send LED select 12 0 DO 0 !DATA >CLOCK LOOP 16 0 DO DUP 1 AND >CLOCK !DATA U2/ LOOP DROP 0 !DATA 1 MS-WAIT ; \ LED routines CREATE LED# 1 , CREATE LED.MASK 0 , CREATE LED.TABLE 26 ALLOT \ to store values of LEDs : ADD.LED \ create a word to access the button CREATE LED# @ DUP W, DUP 2* LED# ! SWAP 2* LED.TABLE + W! \ store mask in table DOES> W@ LED.MASK DUP @ ROT XOR SWAP ! ; \ LED routines \ for membrane panel 5 ADD.LED *5* 11 ADD.LED *AUTO* 0 ADD.LED *0* 1 ADD.LED *1* 4 ADD.LED *4* 2 ADD.LED *2* 3 ADD.LED *3* 12 ADD.LED *SP0* 12 ADD.LED *STANDBY* 6 ADD.LED *6* 8 ADD.LED *8* 12 ADD.LED *SP2* 9 ADD.LED *9* 10 ADD.LED *10* 7 ADD.LED *7* 12 ADD.LED *SP1* \ for button panel \ 8 ADD.LED *8* 2 ADD.LED *2* 3 ADD.LED *3* \ 9 ADD.LED *9* 11 ADD.LED *AUTO* 4 ADD.LED *4* \ 10 ADD.LED *10* 12 ADD.LED *SP0* \ 12 ADD.LED *STANDBY* 6 ADD.LED *6* 0 ADD.LED *0* \ 1 ADD.LED *1* 12 ADD.LED *TIMER* 5 ADD.LED *5* \ 7 ADD.LED *7* 12 ADD.LED *SP1* \ LED routines : !LEDS \ write LED masks to LEDs LED.MASK @ !LED ; : LEDS.OFF \ turn all LEDs off 0 !DATA 0 LED.MASK ! !LEDS ; : FLASH \ flash banks 0-5 and 6-11 LEDS.OFF *0* *1* *2* *3* *4* *5* !LEDS BEGIN *0* *1* *2* *3* *4* *5* !LEDS *6* *7* *8* *9* *10* *AUTO* !LEDS 200 MS-WAIT KEY? UNTIL LEDS.OFF ; \ LED routines CREATE BUTTON.MASK 0 , : LIGHT.RANGE ( lo\hi -- | light range of LEDs ) 0 -ROT 1+ SWAP DO LED.TABLE I 2* + W@ OR LOOP !LED ; : BLEEP \ raise OP7 for a while DUART 14 + C! 50 MS-WAIT DUART 15 + C! ; \ BUTTON routines : BUTTON># ( button.mask -- button#0-28 ) 31 0 DO DUP 0= IF DROP I LEAVE ELSE 2/ THEN LOOP 1- ; : (@BUTTON) ( -- data32 | read from switches ) 0 !DATA 1 !DATA >CLOCK 1 !DATA >CLOCK \ send start bit 0 !DATA >CLOCK 1 !DATA >CLOCK \ send buttons select 0 28 0 DO 2* >CLOCK @DATA 1 AND OR LOOP 0 !DATA BUTTON.MASK @ AND 1 MS-WAIT ; \ BUTTON routines CREATE BUTTON# 0 , CREATE BUTTON.BITS 1 , CREATE BUTTON.ARRAY 32 ALLOT : NO.BUTTON \ leave space for a null bit position BUTTON.BITS @ 2* BUTTON.BITS ! 1 BUTTON# +! ; : ADD.BUTTON ( value -- | create a word to access the button ) CREATE DUP , BUTTON# @ BUTTON.ARRAY + C! \ store value at button's pos. in array BUTTON.BITS @ BUTTON.MASK @ OR BUTTON.MASK ! NO.BUTTON DOES> @ ; \ BUTTON routines \ BUTTON routines for buttons panel exit NO.BUTTON 101 ADD.BUTTON "TIMER" 102 ADD.BUTTON "START" 103 ADD.BUTTON "ENTER" 104 ADD.BUTTON "COUNT" 6 ADD.BUTTON "6" 8 ADD.BUTTON "8" 5 ADD.BUTTON "5" 105 ADD.BUTTON "SEARCH" 106 ADD.BUTTON "PRINT" 107 ADD.BUTTON "MODE" NO.BUTTON 108 ADD.BUTTON "RESET" 1 ADD.BUTTON "1" 2 ADD.BUTTON "2" 3 ADD.BUTTON "3" 4 ADD.BUTTON "4" 109 ADD.BUTTON "RAMP" 110 ADD.BUTTON "STANDBY" NO.BUTTON NO.BUTTON 9 ADD.BUTTON "9" 10 ADD.BUTTON "10" 11 ADD.BUTTON "AUTO" 0 ADD.BUTTON "0" 7 ADD.BUTTON "7" \ BUTTON routines for membrane panel NO.BUTTON 1 ADD.BUTTON "1" 0 ADD.BUTTON "0" 2 ADD.BUTTON "2" 4 ADD.BUTTON "4" 107 ADD.BUTTON "MODE" 104 ADD.BUTTON "COUNT" 11 ADD.BUTTON "AUTO" 10 ADD.BUTTON "10" 5 ADD.BUTTON "5" 109 ADD.BUTTON "RAMP" NO.BUTTON 3 ADD.BUTTON "3" 110 ADD.BUTTON "STANDBY" 105 ADD.BUTTON "SEARCH" 9 ADD.BUTTON "9" 8 ADD.BUTTON "8" 7 ADD.BUTTON "7" 6 ADD.BUTTON "6" NO.BUTTON NO.BUTTON 101 ADD.BUTTON "TIMER" 108 ADD.BUTTON "RESET" 103 ADD.BUTTON "ENTER" 102 ADD.BUTTON "START" 106 ADD.BUTTON "PRINT" \ BUTTON routines : #>VALUE ( button# -- button value ) BUTTON.ARRAY + C@ ; : @BUTTON ( -- value | wait until button pushed ) BEGIN (@BUTTON) 0= UNTIL \ wait for all keys released BEGIN (@BUTTON) BUTTON># DUP 0< WHILE DROP REPEAT #>VALUE BLEEP ; : (KEY.RANGE) ( lo/hi -- n | get a number key in range ) SWAP 1- SWAP 1+ BEGIN 2DUP @BUTTON DUP >R > SWAP R@ < AND 0= WHILE R> DROP REPEAT 2DROP R> ; \ BUTTON routines : KEY.RANGE ( lo/hi -- value | get key in range ) 2DUP LIGHT.RANGE (KEY.RANGE) LEDS.OFF ; : ?BUTTON ( -- button# | >0 if button pressed ) (@BUTTON) BUTTON># DUP 0< NOT IF #>VALUE THEN ; \ LCD routines decimal : LEMIT ( data -- | write to LCD ) 128 XOR 0 !DATA 1 !DATA >CLOCK 1 !DATA >CLOCK \ send start bit 0 !DATA >CLOCK 0 !DATA >CLOCK \ send LCD select 21 0 DO >CLOCK LOOP 7 0 DO DUP 128 AND !DATA >CLOCK 2* LOOP 128 AND !DATA 1 MS-WAIT 0 !DATA ; : LTYPE ( addr/cnt -- ) OVER + SWAP DO I C@ LEMIT LOOP ; hex CREATE INIT$ 5 C, B0 C, 8E C, 8C C, 86 C, 81 C, CREATE HELLO1$ ," Welcome to" CREATE HELLO2$ ," BODY TRIM V1.0" decimal ( " ================" ) \ LCD routines : INIT.LCD \ initialise and clear display INIT$ COUNT LTYPE ; : C-JUSTIFY ( addr/cnt -- | centre justify text ) 16 OVER - 2/ DUP 0> IF 0 DO BL LEMIT LOOP ELSE DROP THEN LTYPE ; : C.MSG ( addr -- | print message centre justified ) INIT.LCD COUNT C-JUSTIFY ; : L.MSG ( addr -- | print message left justified ) INIT.LCD COUNT LTYPE ; \ LCD routines CREATE (STATUS) 0 , \ 0=idle, 1=running, -1=standby : .STATUS \ print machine status " Status:" L.MSG (STATUS) @ DUP 0= IF DROP " Ready" ELSE 1 = IF " Active" ELSE " Standby" THEN THEN COUNT LTYPE ; : HELLO \ print welcome message HELLO1$ C.MSG 1000 MS-WAIT 3 0 DO HELLO2$ C.MSG 300 MS-WAIT INIT.LCD LOOP 500 MS-WAIT ; \ LCD routines CREATE PROG.TIME 0 , CREATE PROGRAM# 0 , : (L.) ( n -- | print on LCD display ) DECIMAL <# #S #> LTYPE ; : L. ( n -- ) (L.) BL LEMIT ; : GET.PROGRAM \ get program number " Enter Programme" C.MSG 1 4 KEY.RANGE PROGRAM# ! ; \ GET.TIME : GET.TIME \ get time in minutes 0 11 LIGHT.RANGE 0 0 BEGIN " TIME: " L.MSG OVER 0< \ Auto mode? IF " Auto" ELSE OVER (L.) DUP L. " mins" THEN COUNT LTYPE @BUTTON DUP >R 11 < IF OVER 0< IF 2DROP 0 0 THEN THEN R@ 10 = IF SWAP 1+ 9 MIN SWAP THEN R@ 10 < IF SWAP DROP R@ THEN R@ 11 = IF DROP -1 SWAP THEN \ set auto mode R> "ENTER" = UNTIL LEDS.OFF SWAP 10 * SWAP + PROG.TIME ! ; \ Functions & variables CREATE MODE# 0 , : MODE.MSG \ print next message MODE# @ DUP 0 = IF " Program source:" ELSE DUP 1 = IF " 1: Internal" ELSE DUP 2 = IF " 2: Host computer" ELSE DUP 3 = IF " 3: ROM cartridge" ELSE " 4: Cassette" THEN THEN THEN THEN L.MSG DROP MODE# @ 1+ DUP 4 > IF DROP 1 THEN MODE# ! ; \ Functions & variables : AWAIT.BUTTON ( lo/hi -- button | wait 1/3s or until key ) -1 -ROT 20 0 DO 20 MS-WAIT OVER ?BUTTON DUP >R > NOT OVER R@ < NOT AND IF ROT DROP R> -ROT LEAVE ELSE R> DROP THEN LOOP 2DROP ; : DO.MODE \ handle mode key 1 4 LIGHT.RANGE MODE# OFF 0 BEGIN MODE.MSG DROP 1 4 AWAIT.BUTTON DUP 0> OVER 1+ MODE# @ = AND UNTIL LEDS.OFF MODE# ! ; \ Functions & variables CREATE RAMP.SPEED -1 , : DO.RAMP.SPEED \ get ramp speed " Ramp speed?" C.MSG 0 10 KEY.RANGE RAMP.SPEED ! ; \ Functions & variables CREATE WAVE# 0 , CREATE TIME 0 , \ current time CREATE TIMER 0 , \ timer status CREATE NOT.YET$ ," Not available" CREATE PULSE.COUNT 0 , : DO.PRINT \ handle printing " No Printer" C.MSG ; : DO.COUNT \ print number of pulses so far INIT.LCD BL LEMIT BL LEMIT PULSE.COUNT @ L. " pulses" COUNT LTYPE ; \ Channel output CREATE WAVE.INDEX 0 , \ for creating wave CREATE MAX.WAIT 0 , CREATE ATTACK 10 , CREATE SUSTAIN 30 , CREATE RELEASE 5 , CREATE RELAX 100 , CREATE PERIOD 1000 , CREATE REPEAT 10 , \ #times wave is repeated before relax CREATE VOLUME.TABLE 12 ALLOT \ holds channel volumes \ Channel output : NUMBER>DIGITS ( ab -- a/b | split into 1st/2nd digits ) 99 MIN 10 /MOD SWAP ; : @NUMBER ( $addr/default# -- n | get a two-digit number ) 0 9 LIGHT.RANGE SWAP >R NUMBER>DIGITS BEGIN R@ L.MSG OVER (L.) DUP L. @BUTTON DUP >R 10 < IF \ drop left digit and enter new one on right SWAP DROP R@ THEN R> "ENTER" = UNTIL LEDS.OFF R> DROP SWAP 10 * SWAP + ; \ Channel output : CUSTOM.WAVE \ create custom wave shape 500 MS-WAIT " Wave parameters:" C.MSG 1000 MS-WAIT " (Enter 0-99)" C.MSG 1000 MS-WAIT " Attack:" ATTACK @ @NUMBER 1 MAX ATTACK ! " Sustain:" SUSTAIN @ @NUMBER 1 MAX SUSTAIN ! " Release:" RELEASE @ @NUMBER 1 MAX RELEASE ! " Repeat:" REPEAT @ @NUMBER 1 MAX REPEAT ! " Relax:" RELAX @ @NUMBER 1 MAX RELAX ! " Period (1/f):" PERIOD @ 600 / @NUMBER 2 MAX 600 * PERIOD ! ; : WAVE.PARMS ( attack/sustain/release/repeat/relax -- ) 600 / PERIOD ! RELAX ! REPEAT ! RELEASE ! SUSTAIN ! ATTACK ! ; \ Channel output : WAVE.MSG \ print next message WAVE# @ DUP 5 > IF DROP 1 DUP WAVE# ! THEN DUP 0 = IF " Output wave:" ELSE DUP 1 = IF " 1: Square" ELSE DUP 2 = IF " 2: Sawtooth" ELSE DUP 3 = IF " 3: Triangle" ELSE DUP 4 = IF " 4: Pulse" ELSE " 5: Custom" THEN THEN THEN THEN THEN L.MSG DROP 1 WAVE# +! ; \ Channel output \ att sust rel repeat relax period \ === ==== === ====== ===== ====== : SQ.WAVE 1 90 1 10 100 16 WAVE.PARMS ; : SAW.WAVE 100 5 1 10 100 16 WAVE.PARMS ; : TRI.WAVE 50 5 50 10 100 16 WAVE.PARMS ; : PULSE.WAVE 5 5 10 10 100 16 WAVE.PARMS ; \ Functions & variables \ Functions & variables ( " ================" ) CREATE SET$ ," Press Start key" CREATE CHANNEL$ ," Ch" CREATE LOW$ ," lower" CREATE HIGH$ ," higher" CREATE VOL$ ," Volume:" : .VOLUME ( channel#/flag -- | set & print new volume ) RAMP.SPEED @ SWAP IF NEGATE THEN SWAP VOLUME.TABLE + DUP >R C@ + 255 MIN 0 MAX DUP R> C! VOL$ COUNT LTYPE L. ; : .CHANNEL# ( channel# -- | print channel# ) CHANNEL$ L.MSG 1+ L. ; \ I/O - port locations ( Read registers ) ( Write registers ) DUART 4 + CONSTANT IPCR DUART 4 + CONSTANT ACR DUART 5 + CONSTANT ISR DUART 5 + CONSTANT IMR DUART 6 + CONSTANT CTUR DUART 7 + CONSTANT CTLR DUART 8 + CONSTANT MR1B DUART 9 + CONSTANT SRB DUART 9 + CONSTANT CSRB DUART 10 + CONSTANT CRB DUART 11 + CONSTANT RBB DUART 11 + CONSTANT TBB DUART 12 + CONSTANT IVR DUART 13 + CONSTANT IPR DUART 13 + CONSTANT OPCR DUART 14 + CONSTANT OPR-SET DUART 15 + CONSTANT OPR-RESET \ I/O - S.?TERMINAL S.KEY S.PC> : S.?TERMINAL ( -- flag | true if character in port ) SRB C@ 1 AND ; : S.KEY ( -- char | get character from port ) BEGIN S.?TERMINAL UNTIL RBB C@ ; : S.PC> ( addr/cnt -- | get string from port ) OVER + SWAP DO S.KEY IC! LOOP ; ' S.?TERMINAL ' ?TERMINAL 8+ ! ' S.KEY ' KEY 8+ ! \ I/O - ?TX S.EMIT S.>PC : ?TX ( -- flag | true if tx buffer empty ) SRB C@ 4 AND ; : S.EMIT ( char -- ) BEGIN ?TX UNTIL TBB C! ; : S.>PC ( addr/cnt -- | write string to port ) OVER + SWAP DO IC@ S.EMIT LOOP ; ' S.EMIT ' EMIT 8+ ! ' S.>PC ' TYPE 8+ ! \ I/O testing \ Channel output hex FFFFC CONSTANT CH0 FFFFD CONSTANT CH1 FFFFE CONSTANT CH2 FFFFF CONSTANT CH3 decimal 512 CONSTANT BUF.SIZE CREATE WAVE.BUF BUF.SIZE 4+ ALLOT \ 128 entries per channel CREATE (WAVE.IRQ) 0 , CREATE INTO.RELAX 0 , \ used by interrupt routine CREATE NEXT.WAVE WAVE.BUF , \ used by interrupt routine CREATE LAST.WAVE WAVE.BUF , \ used by interrupt routine \ Wave buffer format: \ byte0=wave shape byte1=ch1 byte2=ch2 byte3=ch3 \ Channel output : @VOLUME ( channel# -- volume ) VOLUME.TABLE + C@ ; : !VOLUME ( volume/channel# -- ) VOLUME.TABLE + C! ; : SET.VOLUME ( channel# -- | create output wave from template ) DUP @VOLUME SWAP WAVE.BUF ( volume/channel#/wave.addr ) BUF.SIZE OVER + SWAP DO OVER IC@ 128 - W* 256/ 128 + OVER I+ C! 4 +LOOP 2DROP ; \ Functions & variables *** MOD *** becomes DUP SET.VOLUME : ADJUST.VOLUME ( key# -- | set volume levels ) (STATUS) @ 0= IF DROP SET$ C.MSG \ volumes can only be set when active ELSE BEGIN DUP 5 > IF 6 - 0 ELSE 1 THEN \ form channel# OVER .CHANNEL# OVER -ROT .VOLUME DUP SET.VOLUME ?BUTTON DUP 11 > OVER 0< OR >R DUP 0< NOT IF SWAP THEN DROP \ keep old or new key? R> UNTIL THEN ; \ Channel output : SET.VOLUMES \ set volume on all channels 1 SET.VOLUME 2 SET.VOLUME 3 SET.VOLUME ; : PLAY.OUTPUT \ test routine to replay wave BEGIN WAVE.BUF 1+ 128 0 DO \ #entries in table 3 0 DO DUP I+ C@ CH1 I+ C! LOOP 4+ LOOP DROP 10 MS-WAIT \ wait between pulses AGAIN ; \ Channel output : >INCREMENT ( period -- increment ) DUP IF 127 SWAP / ELSE DROP 127 THEN ; : >ATTACK \ build attack part ATTACK @ >INCREMENT 127 BUF.SIZE 0 DO DUP WAVE.BUF I+ C! OVER + DUP 255 > IF I WAVE.INDEX ! LEAVE THEN 4 +LOOP 2DROP ; \ Channel output : >SUSTAIN \ build sustain part SUSTAIN @ >R WAVE.INDEX @ R@ 4* WAVE.INDEX +! WAVE.BUF + R> 0 DO 255 OVER C! 4+ LOOP DROP ; : >RELEASE \ build release part RELEASE @ >INCREMENT 255 BUF.SIZE WAVE.INDEX @ DO DUP WAVE.BUF I+ C! OVER - DUP 128 < IF I WAVE.INDEX ! LEAVE THEN 4 +LOOP 2DROP ; \ Channel output : MIRROR.WAVE \ create negative part of cycle WAVE.INDEX @ BUF.SIZE 2/ MIN DUP 2* WAVE.INDEX ! DUP WAVE.BUF + SWAP 0 DO DUP I - C@ 255 XOR OVER I+ C! 4 +LOOP DROP ; : MAKE.WAVE \ build wave from parameters WAVE.INDEX OFF WAVE.BUF BUF.SIZE 127 FILL >ATTACK >SUSTAIN >RELEASE MIRROR.WAVE PERIOD @ DUP 256/ ( hi byte ) CTUR C! ( lo byte ) CTLR C! WAVE.INDEX @ WAVE.BUF + LAST.WAVE ! SET.VOLUMES ; \ Channel output CODE WAVE.IRQ \ timer interrupt vectored here HERE >REL (WAVE.IRQ) ! \ address of routine A0 PUSH, TIME @#L 1 LONG ADDQ, \ INTO.RELAX 2+ @#L WORD TST, EQ ( IF, ) NEXT.WAVE @#L A0 LONG MOVE, \ create wave A0 )+ CH0 @#L LONG MOVE, \ write to output channels WAVE.BUF BUF.SIZE + 4+ #L A0 LONG CMPA, EQ IF, \ RELAX 2+ @#L INTO.RELAX 2+ @#L WORD MOVE, WAVE.BUF #L A0 LONG MOVE, \ reset pointer THEN, A0 NEXT.WAVE @#L LONG MOVE, \ ELSE, INTO.RELAX @#L 1 WORD SUBQ, \ relax \ THEN, OPR-RESET #L A0 LONG MOVE, A0 () BYTE TST, \ reset timer A0 POP, RTE, RETURN \ Channel output hex : -INTS \ turn off interrupts 2600 !SR ; decimal : +TIMER \ enable timer mode PERIOD @ DUP 256/ ( hi byte ) CTUR C! ( lo byte ) CTLR C! 26 IVR C! \ vector to IRQ level 2 08 IMR C! ; \ IRQ on timer ready : CUT.OUTPUTS \ turn all channels off -INTS 127 DUP CH1 C! DUP CH2 C! CH3 C! ; \ Functions & variables hex : +INTS \ enable interrupts <,A5.JMP.W> 20A20 W! (WAVE.IRQ) @ 20A22 W! \ store a JMP WAVE(A5) WAVE.BUF NEXT.WAVE ! +TIMER 2000 !SR ; decimal : DO.STANDBY \ turn standby on/off CUT.OUTPUTS (STATUS) @ -1 (STATUS) ! .STATUS BEGIN @BUTTON DUP "STANDBY" = SWAP "START" = OR UNTIL +INTS LEDS.OFF (STATUS) ! .STATUS ; \ Channel output : DO.SEARCH \ handle searching 1 5 LIGHT.RANGE WAVE# OFF 0 BEGIN WAVE.MSG DROP 1 5 AWAIT.BUTTON DUP 0> OVER 1+ WAVE# @ = AND UNTIL LEDS.OFF DUP WAVE# ! DUP 1 = IF SQ.WAVE THEN DUP 2 = IF SAW.WAVE THEN DUP 3 = IF TRI.WAVE THEN DUP 4 = IF PULSE.WAVE THEN 5 = IF CUSTOM.WAVE THEN MAKE.WAVE ; \ DO.TEST JOKE CREATE FIRST.KEY 0 , : JOKE \ on first key = RESET only 5 0 DO " LES'S TOY" C.MSG 1 16 0 DO DUP !LED 2* LOOP DROP INIT.LCD LOOP LEDS.OFF ; : DO.TEST \ when IP1 low detected " OUTPUT TEST" C.MSG BEGIN IPR C@ 2 AND UNTIL CUT.OUTPUTS 300 MS-WAIT +INTS ; \ Functions & variables : DO.START \ start output RAMP.SPEED @ 0< IF DO.RAMP.SPEED \ set ramp speed first THEN 1 (STATUS) ! +INTS ; \ Functions & variables : DO.10 \ handle 10 key ; \ do nothing : (.TIME) ( n -- | print, possibly adding leading zero ) DUP 10 < IF 48 LEMIT THEN (L.) ; : DO.TIMER \ start/stop timer TIMER @ IF BEGIN " Time: " L.MSG TIME @ PERIOD @ * 2000000 / 60 /MOD (.TIME) " :" COUNT LTYPE (.TIME) 200 MS-WAIT ?BUTTON 0< NOT UNTIL ELSE TIMER ON " Timer Reset" C.MSG THEN ; \ Functions & variables : (RESET) \ reset all variables -INTS 127 DUP CH1 C! DUP CH2 C! CH3 C! (STATUS) OFF TIME OFF TIMER OFF PROGRAM# OFF PROG.TIME OFF MODE# OFF WAVE# OFF VOLUME.TABLE 12 ERASE PULSE.WAVE MAKE.WAVE LEDS.OFF ; : DO.RESET \ reset system (RESET) FIRST.KEY @ IF " System Reset" C.MSG ELSE JOKE THEN ; \ Functions & variables : DO.BUTTON ( button# -- | main key handler ) DUP 100 < IF DUP ADJUST.VOLUME THEN "RAMP" OVER = IF DO.RAMP.SPEED ELSE "STANDBY" OVER = IF DO.STANDBY ELSE "SEARCH" OVER = IF DO.SEARCH ELSE "MODE" OVER = IF DO.MODE ELSE "PRINT" OVER = IF DO.PRINT ELSE "COUNT" OVER = IF DO.COUNT ELSE "RESET" OVER = IF DO.RESET ELSE "TIMER" OVER = IF DO.TIMER ELSE "START" OVER = IF DO.START ELSE "ENTER" OVER = IF DO.ENTER THEN THEN THEN THEN THEN THEN THEN THEN THEN THEN DROP ; \ Functions & variables : DO.BUTTONS \ main loop (RESET) HELLO GET.PROGRAM GET.TIME BEGIN 1000 MS-WAIT .STATUS 0 BEGIN IPR C@ DUP 1 AND 0= IF DO.RESET .STATUS THEN 2 AND 0= IF DO.TEST .STATUS THEN DROP ?BUTTON DUP 0< NOT UNTIL BLEEP DO.BUTTON FIRST.KEY ON KEY? UNTIL ; : (STARTUP) \ plugged into turnkey vector \ flash LEDs 6 0 DO 1 !DATA 100 MS-WAIT 0 !DATA 100 MS-WAIT LOOP DO.BUTTONS ; \ Channel output : TEST \ startup test routine MAKE.WAVE 255 1 !VOLUME 128 2 !VOLUME 064 3 !VOLUME PLAY.OUTPUT ; ' TEST hex 20A1C decimal ! \ startup vector \ Startup : STARTUP ( -- ) DECIMAL CURRENT OFF CONTEXT OFF LAST.BLK OFF (STARTUP) QUIT ; ' STARTUP hex 20A1C decimal ! \ startup vector