\ Amiga. 26Feb88pJa A Forth system for Amiga's based on Laxen & Perry's F83 Peter Appelman 1460 Ghent Ave apt 704 Burlington Ontario, Canada L7S-1X7 ( GEnie address: P.APPELMAN) legal: This is a public domain system, and may be freely distributed and copied, as long as the author is given credit and no copyright notice is placed upon it. \ Set up target image buffer and relocation buffer. 03Feb88pJaonly forth also meta also definitions warning off 0 dp-t ! 32 1024 * constant tsize forth variable Rbuffer tsize 16+ 16 / allot forth ' Rbuffer is 'Rbuffer 'Rbuffer tsize 16 / erase in-meta : get-target 65536 tsize [ Exec ] AllocMem ?dup 0= [ forth ] abort" not enough memory for target! " 9 4* + ['] target-origin >body ! ; : free-target target-origin 9 4* - tsize [ Exec ] FreeMem ; in-meta get-target 2 load 3 load \ Allocate block storage bss, misc forward references 03Feb88pJa 32 bss: bss_keybuffer 256 bss: bss_stdbuffer 256 bss: bss_tibbuffer 1024 bss: bss_rpstack : ]] ] ; : [[ [compile] [ ; forth immediate meta forward: definitions forward: [ \ Load kernel. 03Feb88pJa4 114 thru [forth] warning on cr .( Unresolved references: ) cr meta .unresolved [forth] cr .( statistics: ) cr .( host dictionary usage: ) here dp 4+ @ - u. cr .( last target code addr: ) meta here . [forth] cr .( Now save the target by typing: Save-target <name> ) cr .( and free up the buffer : free-target ) cr .( Then return to dos by typing : bye ) meta \ Boot vectors and 'next' interpreter. 22Jan88pJaassembler label start-t 0 #) jmp <rel 0 #) jmp <rel label @next ip )+ w move w )+ a0 move a0 ) jmp forth assembler definitions meta h: next >next ) jmp ; here-t dup 100 + current-t ! vocabulary forth forth definitions dup 108 + -relocate 0 over 2+ !-t dup 2+ swap 24 + dup relocate !-t in-meta \ Amiga rom calls, hi level word calls from code. 22Jan88pJaassembler label rcallflag 0 w, label rcall hex a0 d0 move start-t 6 + beq 9C rp -) movem> 3 sp )+ movem< label rcallmask rp sp -) move rp ) a6 move 100 a6 d) jsr label rcalloffset sp )+ rp move 3900 rp )+ movem< word rcallflag >pcd) d3 move long 0<> if d0 sp -) move then next decimal label hilevel ip rp -) move sp )+ ip move next end-code code (;c) ip sp -) move rp )+ ip move rts end-code \ Run time code for defining words. 23Jan88pJaassembler label nest ip rp -) move w ip move next code exit rp )+ ip move next code unnest ' exit @-t ' unnest !-t end-code assembler label dodoes ip rp -) move sp )+ ip move label docreate w sp -) move next label doconstant w ) sp -) move next code (lit) (s -- n ) ip )+ sp -) move next end-code \ Meta, defining words. 23Jan88pJat: literal (s n -- ) [target] (lit) ,-t t; t: dliteral (s d -- ) [target] (lit) ,-t [target] (lit) ,-t t; t: ascii (s -- ) [compile] ascii [[ transition ]] literal [meta] t; t: ['] (s -- ) 't >body @ [[ transition ]] literal <rel [meta] t; : constant (s -- n ) recreate [[ assembler doconstant ]] literal ,-tr dup ,-t constant ; \ Meta, Identify numbers and forward references. 23Jan88pJaforward: <(;code)> t: does> (s -- here-t ) [forward] <(;code)> here-t does-op w,-t [[ assembler dodoes ]] literal ,-tr t; : numeric (s -- ) [forth] here [meta] number dpl @ 1+ if [[ transition ]] dliteral [meta] else drop [[ transition ]] literal [meta] then ; : undefined (s -- ) here-t 0 ,-t in-forward [forth] create [meta] transition [forth] , false , [meta] does> forward-code ; \ Meta, compiling loop. 23Jan88pJa[forth] variable t-in meta : ] (s -- ) state-t on in-transition begin end? @ if cr query end? off then >in @ t-in ! defined if execute else count numeric? if numeric else t-in @ >in ! undefined then then state-t @ 0= until ; t: [ in-meta state-t off t; t: ; [target] unnest [[ transition ]] [ t; : c: [[ assembler ]] hilevel #) jsr <rel meta ] ; t: ;c [target] (;c) [[ transition ]] [ assembler t; in-meta t: ;code [forward] <(;code)> [[ transition ]] [ assembler t; in-meta : : target-create [[ assembler nest ]] literal ,-tr ] ; \ Runtime control structures, branching. 23Jan88pJacode branch (s -- ) ip ) ip move next end-code code ?branch (s f -- ) sp )+ tst ' branch @-t beq 4 ip addq next end-code \ Meta, branching. 23Jan88pJat: begin ?<mark t; t: again [target] branch ?<resolve t; t: until [target] ?branch ?<resolve t; t: if [target] ?branch ?>mark t; t: then ?>resolve t; t: else [target] branch ?>mark 2swap ?>resolve t; t: while [[ transition ]] if t; t: repeat 2swap [[ transition ]] again then t; \ Runtime control structures, looping 23Jan88pJacode (loop) (s -- ) 1 rp ) addq ' branch @-t bvc label loop-end 8 rp addq 4 rp addq 4 ip addq next end-code code (+loop) (s n -- ) sp )+ d0 move d0 rp ) add ' branch @-t bvc loop-end bra end-code \ looping cont. 23Jan88pJacode (do) (s lim init -- ) sp )+ d0 move sp )+ d1 move label do-common ip )+ rp -) move hex 80000000 d1 addi decimal d1 rp -) move d1 d0 sub d0 rp -) move next end-code code (?do) (s lim init -- ) sp )+ d0 move sp )+ d1 move d0 d1 cmp do-common bne ' branch @-t bra end-code code bounds (s addr len -- lim first ) sp )+ d0 move sp ) d1 move d0 sp ) add d1 sp -) move next end-code \ Meta, looping. 23Jan88pJat: ?do [target] (?do) ?>mark t; t: do [target] (do) ?>mark t; t: loop [target] (loop) 2dup 4+ ?<resolve ?>resolve t; t: +loop [target] (+loop) 2dup 4+ ?<resolve ?>resolve t; \ Execution control 23Jan88pJaassembler @next meta constant @next <rel assembler hilevel meta constant hilevel <rel code execute (s cfa -- ) sp )+ w move w )+ a0 move a0 ) jmp end-code code perform (s 'cfa -- ) sp )+ w move label dodefer w )+ w move w )+ a0 move a0 ) jmp end-code code go (s addr -- ) rts end-code code noop (s -- ) nop nop nop next end-code \ looping control. 16Feb88pJacode i (s -- n ) rp ) d0 move 4 rp d) d0 add d0 sp -) move next end-code code j (s -- n ) 12 rp d) d0 move 16 rp d) d0 add d0 sp -) move next end-code code (leave) (s -- ) 8 rp addq rp )+ ip move next end-code code (?leave) (s f-- ) sp )+ tst ' (leave) @-t bne next end-code t: leave [target] (leave) t; t: ?leave [target] (?leave) t; \ Memory operators. 23Jan88pJacode @ (s addr -- n ) sp ) a0 move a0 ) sp ) move next end-code code ! (s n addr -- ) sp )+ a0 move sp )+ a0 ) move next end-code code w@ (s addr -- w ) d0 clr sp ) a0 move word a0 ) d0 move long d0 sp ) move next end-code code w! (s w addr -- ) sp )+ a0 move sp )+ d0 move word d0 a0 ) move long next end-code \ and block moves. 23Jan88pJacode c@ (s addr -- c ) d0 clr sp ) a0 move byte a0 ) d0 move long d0 sp ) move next end-code code c! (s c addr -- ) sp )+ a0 move sp )+ d0 move byte d0 a0 ) move long next end-code hex code cmove (s from to count -- ) 301 sp )+ movem< d0 ?do byte a1 )+ a0 )+ move long loop: dbra next end-code code cmove> (s from to count -- ) 301 sp )+ movem< d0 a0 adda d0 a1 adda d0 ?do byte a1 -) a0 -) move long loop: dbra next end-code decimal \ Stack manipulations, stack pointers. 23Jan88pJacode sp@ (s -- addr ) sp sp -) move next end-code code sp! (s n -- ) sp )+ sp move next end-code code rp@ (s -- addr ) rp sp -) move next end-code code rp! (s n -- ) sp )+ rp move next end-code \ stack manipulations 23Jan88pJacode drop (s n -- ) 4 sp addq next end-code code dup (s n -- n n ) sp ) sp -) move next end-code code swap (s n1 n2 -- n2 n1 ) sp )+ d0 move sp ) d1 move d0 sp ) move d1 sp -) move next end-code code over (s n1 n2 -- n1 n2 n1 ) 4 sp d) sp -) move next end-code \ stack manipulations 23Jan88pJacode tuck (s n1 n2 -- n2 n1 n2 ) hex 0003 sp )+ movem< d0 d2 move E000 sp -) movem> next end-code decimal code nip (s n1 n2 -- n2 ) sp )+ sp ) move next end-code code rot (s n1 n2 n3 -- n2 n3 n1 ) sp )+ d1 move sp )+ d2 move sp )+ d0 move hex E000 sp -) movem> next end-code decimal code -rot (s n1 n2 n3 -- n3 n1 n2 ) sp )+ d2 move sp )+ d0 move sp )+ d1 move hex E000 sp -) movem> next end-code decimal \ stack manipulations 23Jan88pJacode flip (s n -- n' ) sp ) d0 move d0 swap d0 sp ) move next end-code code cflip (s n -- n' ) word 2 sp d) d0 move 8 # d0 rol d0 2 sp d) move long next end-code code ?dup (s n -- [n] n ) sp ) tst 0<> if sp ) sp -) move then next end-code \ stack manipulations 24Jan88pJacode r> (s -- n ) rp )+ sp -) move next end-code code >r (s n -- ) sp )+ rp -) move next end-code code r@ (s -- n ) rp ) sp -) move next end-code code pick (s Nm..N2 N1 k -- Nm..N2 N1 Nk ) sp )+ d0 move 2 # d0 lsl 0 d0 sp di) sp -) move next c; code roll (s nm..n2 n1 k -- ????? ) sp )+ d1 move d1 d0 move 2 # d0 lsl sp a0 move d0 a0 adda a0 ) sp -) move a0 a1 move 4 a1 addq d1 do a0 -) a1 -) move loop 4 sp addq next end-code \ Logical operations. 24Jan88pJacode and (s n1 n2 -- n3 ) sp )+ d0 move d0 sp ) and next end-code code or (s n1 n2 -- n3 ) sp )+ d0 move d0 sp ) or next end-code code xor (s n1 n2 -- n3 ) sp )+ d0 move d0 sp ) eor next end-code code not (s n1 -- n1' ) sp ) not next end-code 0 constant false -1 constant true \ logical operations. 24Jan88pJacode cset (s b addr -- ) sp )+ a0 move sp )+ d0 move byte d0 a0 ) or long next end-code code creset (s b addr -- ) sp )+ a0 move sp )+ d0 move byte d0 not d0 a0 ) and long next end-code code ctoggle (s b addr -- ) sp )+ a0 move sp )+ d0 move byte d0 a0 ) eor long next end-code code on (s addr -- ) sp )+ a0 move -1 d0 moveq d0 a0 ) move next end-code code off (s addr -- ) sp )+ a0 move 0 d0 moveq d0 a0 ) move next end-code \ Arithmatic operations. 24Jan88pJacode + (s n1 n2 -- n3 ) sp )+ d0 move d0 sp ) add next end-code code negate (s n -- n' ) sp ) neg next end-code code - (s n1 n2 -- n3 ) sp )+ d0 move d0 sp ) sub next end-code code abs (s n -- |n| ) sp ) tst 0< if sp ) neg then next end-code code +! (s n addr -- ) sp )+ a0 move sp )+ d0 move d0 a0 ) add next end-code 0 constant 0 1 constant 1 2 constant 2 3 constant 3 4 constant 4 -1 constant -1 \ arithmatic operations. 24Jan88pJacode 2* (s n -- 2*n ) sp ) d0 move 1 # d0 asl d0 sp ) move next end-code code 2/ (s n -- n/2 ) sp ) d0 move 1 # d0 asr d0 sp ) move next end-code code u2/ (s n -- u/2 ) sp ) d0 move 1 # d0 lsr d0 sp ) move next end-code code 4* (s n -- 4*n ) sp ) d0 move 2 # d0 asl d0 sp ) move next end-code code 8* (s n -- 8*n ) sp ) d0 move 3 # d0 asl d0 sp ) move next end-code code 16* (s n -- 16*n ) sp ) d0 move 4 # d0 asl d0 sp ) move next end-code \ arithmatic operations. 24Jan88pJacode 1+ 1 sp ) addq next end-code code 1- 1 sp ) subq next end-code code 2+ 2 sp ) addq next end-code code 2- 2 sp ) subq next end-code code 4+ 4 sp ) addq next end-code code 4- 4 sp ) subq next end-code code 8+ 8 sp ) addq next end-code code 8- 8 sp ) subq next end-code code 12+ 12 d0 moveq d0 sp ) add next end-code code 16+ 16 d0 moveq d0 sp ) add next end-code code 16- 16 d0 moveq d0 sp ) sub next end-code \ arithmatic operations. Unsigned multiply. 24Jan88pJaassembler label mulusub 0 d4 moveq 0 d5 moveq word d0 d4 move d4 swap d0 swap d0 d5 move long d4 d2 add d5 d3 addx rts code um* (s n1 n2 -- d ) 3 sp ) movem< 0 d2 moveq word -1 # d2 move long d2 d0 cmp u<= if d2 d1 cmp u<= if d0 d1 mulu 0 d0 moveq 3 sp ) movem> next then then 0 d2 moveq 0 d3 moveq word 2 sp d) d0 move 6 sp d) d1 move long d1 d0 mulu d0 d2 move word 2 sp d) d0 move 4 sp d) d1 move d1 d0 mulu mulusub bsr sp ) d0 move 6 sp d) d1 move d1 d0 mulu mulusub bsr sp ) d0 move 4 sp d) d1 move d1 d0 mulu long d0 d3 add d2 4 sp d) move d3 sp ) move next end-code decimal \ arithmatic operations. division routine. 26Jan88pJacode um/mod (s d n -- rem dquotient ) hex sp )+ d0 move sp )+ d3 move sp )+ d2 move FFFF # d1 move d0 tst 0= if d0 sp -) move -1 w#) pea -1 w#) pea next then d3 tst 0= if d0 d2 cmp u< if d2 sp -) move 0 w#) pea 0 w#) pea next then d1 d0 cmp u<= if d1 d2 cmp word u> if d2 swap d2 d3 move d0 d3 divu d3 d1 move d1 swap d2 swap then d2 d3 move d0 d3 divu d3 d1 move d3 clr d3 swap long d3 sp -) move d1 sp -) move 0 w#) pea next then then 0 d6 moveq 0 d7 moveq 0 d1 moveq word d6 sp -) move long d6 a0 move d3 tst 0>= if begin word 1 a0 addq 1 sp ) subq long 1 # d2 lsl 1 # d3 roxl 0< until then decimal \ arithmatic operations. division routine. 26Jan88pJa 1 # d3 lsr 1 # d2 roxr 1 # d7 roxr word 1 a0 subq 1 sp ) addq long d2 d4 move d3 d5 move begin word 1 sp ) addq long 1 # d0 lsl 1 # d1 roxl 0< until 1 # d1 lsr 1 # d0 roxr word 1 sp ) subq long 0>= if begin d0 d2 sub d1 d3 subx 16 eori>ccr u>= if d2 d4 move d3 d5 move else d4 d2 move d5 d3 move then 1 # d6 roxl 1 # d7 roxl 1 # d2 roxl 1 # d3 roxl word 1 a0 addq 1 sp ) subq long 0>= while d2 d4 move d3 d5 move repeat word 1 a0 subq long then word a0 d0 move long d0 ?do 1 # d5 lsr 1 # d4 roxr loop: dbra word sp )+ tst long d4 sp -) move d6 sp -) move d7 sp -) move next end-code ( phoo!!! that's a long one ) \ Comparison operations. 25Jan88pJaassembler label yes -1 d0 moveq d0 sp ) move next label no sp ) clr next end-code code 0< (s n -- f ) sp ) tst yes bmi no bra end-code code 0= (s n -- f ) sp ) tst yes beq no bra end-code code 0> (s n -- f ) sp ) tst yes bgt no bra end-code code 0<> (s n -- f ) sp ) tst yes bne no bra end-code code < (s n1 n2 -- f ) sp )+ d0 move sp ) d0 cmp yes bgt no bra end-code code = (s n1 n2 -- f ) sp )+ d0 move sp ) d0 cmp yes beq no bra end-code \ comparison operations. 25Jan88pJacode > (s n1 n2 -- f ) sp )+ d0 move sp ) d0 cmp yes blt no bra end-code code <> (s n1 n2 -- f ) sp )+ d0 move sp ) d0 cmp yes bne no bra end-code code u< (s n1 n2 -- f ) sp )+ d0 move sp ) d0 cmp yes bhi no bra end-code code u> (s n1 n2 -- f ) sp )+ d0 move sp ) d0 cmp yes bcs no bra end-code code ?negate (s n1 n2 -- n1 ) sp )+ d0 move 0< if sp ) neg then next end-code code min (s n1 n2 -- n3 ) sp )+ d0 move sp ) d0 cmp < if d0 sp ) move then next end-code \ comparison operations and conversion. 25Jan88pJacode max (s n1 n2 -- n3 ) sp )+ d0 move sp ) d0 cmp > if d0 sp ) move then next end-code code between (s n min max -- f ) sp )+ d0 move sp )+ d1 move sp ) d2 move d2 d1 cmp no bgt d2 d0 cmp no blt yes bra end-code code within (s n min max -- f ) 1 sp ) subq ' between @-t bra end-code code w>s (s w -- n ) sp ) d0 move d0 ext d0 sp ) move next end-code code s>d (s n -- d ) 0 d0 moveq sp ) tst 0< if 1 d0 subq then d0 sp -) move next end-code \ Double operations, memory. 26Jan88pJacode 2@ (s addr -- d ) sp ) a0 move 4 a0 d) sp ) move a0 ) sp -) move next end-code code 2! (s d addr -- ) sp )+ a0 move sp )+ a0 )+ move sp )+ a0 ) move next end-code \ double operations, stack. 26Jan88pJacode 2drop (s d -- ) 8 sp addq next end-code code 2dup (s d1 -- d1 d1 ) 4 sp d) sp -) move 4 sp d) sp -) move next end-code code 2swap (s d1 d2 -- d2 d1 ) hex 000F sp )+ movem< d0 d2 exg d1 d3 exg F000 sp -) movem> next end-code decimal code 2over (s d1 d2 -- d1 d2 d1 ) 12 sp d) sp -) move 12 sp d) sp -) move next end-code code 3dup (s a b c -- a b c a b c ) 12 sp d) a0 lea a0 -) sp -) move a0 -) sp -) move a0 -) sp -) move next end-code \ double operations, arithmatic. 26Jan88pJacode d+ (s d1 d2 -- dsum ) sp )+ d1 move sp )+ d0 move sp )+ d2 move d0 sp ) add d2 d1 addx d1 sp -) move next end-code code dnegate (s d -- d ) 4 sp d) neg sp ) negx next end-code code dabs (s d -- |d| ) sp ) tst ' dnegate @-t bmi next end-code code d2* (s d -- d*2 ) sp )+ d1 move sp ) d0 move 1 # d0 lsl 1 # d1 roxl d0 sp ) move d1 sp -) move next end-code code d2/ (s d -- d/2 ) sp )+ d1 move sp ) d0 move 1 # d0 asr 1 # d1 roxr d0 sp ) move d1 sp -) move next end-code \ double operations, arithmatic. 26Jan88pJacode d- (s d1 d2 -- d3 ) sp )+ d1 move sp )+ d0 move sp )+ d3 move d0 sp ) sub d1 d3 subx d3 sp -) move next end-code code ?dnegate (s d n -- d ) sp )+ tst ' dnegate @-t bmi next end-code code d= (s d1 d2 -- f ) sp )+ d0 move sp )+ d2 move sp )+ d1 move sp ) d3 move d0 d1 cmp no bne d2 d3 cmp no bne yes bra end-code \ Mixed mode arithmatic. 26Jan88pJacode *d (s n1 n2 -- d ) sp )+ d0 move sp )+ d1 move d0 d2 move d1 d2 eor d2 rp -) move d1 sp -) move 0< if sp ) neg then d0 sp -) move 0< if sp ) neg then c: um* ;c rp )+ sp -) move ' ?dnegate @-t bra end-code code m/mod (s d n -- rem quot ) sp )+ d0 move 0<> if d0 rp -) move sp ) d1 move d0 d1 eor d1 rp -) move d0 rp -) move sp ) tst 0< if 4 sp d) neg sp ) negx then rp ) sp -) move 0< if sp ) neg then c: um/mod ;c 4 sp addq rp )+ d0 move 0< if 4 sp d) neg then rp )+ d0 move 0< if sp ) neg 4 sp d) tst 0<> if 1 sp ) subq rp ) d0 move 4 sp d) d0 sub d0 4 sp d) move then then rp )+ tst then next end-code \ 32 bit multiply and divide. 26Jan88pJa: * (s n1 n2 -- n3 ) um* drop ; code /mod (s n1 n2 -- rem quot ) 0 d0 moveq sp )+ d1 move sp ) tst 0< if d0 neg then d0 sp -) move d1 sp -) move ' m/mod @-t bra end-code : / (s n1 n2 -- n3 ) /mod nip ; : mod (s n1 n2 -- mod ) /mod drop ; : */mod (s n1 n2 -- rem quot ) >r *d r> m/mod ; : */ (s n1 n2 -- quot ) */mod nip ; \ (spare) 26Jan88pJa \ System variables. 26Jan88pJavariable sp0 \ initial parameter stack variable rp0 \ initial return stack variable dp \ dictionary pointer bss_stdbuffer dp !-t patchbss 0 ,-t 65536 ,-t variable #out \ number of characters emitted variable #line \ number of lines emitted variable offset \ relative to absolute disk block 0 variable base \ for number in/output 10 base !-t variable hld \ points to last char held in pad variable file \ points to fcb of currently open file variable in-file \ points to fcb of currently open infile \ system variables. 26Jan88pJadefer type \ normally (type), for standard output defer key \ normally (key), for standard input defer key? \ normally (key?) defer cr \ normally crlf variable prior \ used for dictionary searches variable state \ compiling or interpreting (0) variable warning \ if on give a warning if duplicate. -1 warning !-t variable dpl \ number input punctuation. variable last \ points to nfa of last definition. variable csp \ holds stack pointer for error checking. variable current \ vocabulary which gets definitions. 12 constant #vocs \ number of vocabularies to search. variable context \ vocabulary search array here there #vocs 4* dup allot erase \ system variables. 26Jan88pJavariable 'tib \ address of terminal input buffer. bss_tibbuffer 'tib !-t patchbss variable width \ width of name field 31 width !-t variable scr \ screen last listed or edited. variable r# \ editing cursor position. variable blk \ block number to interpret variable >in \ offset into input stream variable span \ number of characters expected. variable #tib \ number of characters to interpret. variable end? \ true if input stream exhausted. variable voc-link \ points to newest vocabulary variable lib-link \ linked list of declared Amiga libraries. variable file-link \ linked list of declared files. \ Strings. 18Feb88pJa32 constant bl 8 constant bs 7 constant bell variable caps code fill (s star-addr count char -- ) hex 0103 sp )+ movem< d1 ?do byte d0 a0 )+ move long loop: dbra next end-code decimal code erase (s addr len -- ) 0 w#) pea ' fill @-t bra end-code code blank (s addr len -- ) 32 w#) pea ' fill @-t bra end-code code count (s addr -- addr+1 len ) 0 d0 moveq sp ) a0 move byte a0 )+ d0 move long a0 sp ) move d0 sp -) move next end-code code length (s addr -- addr+2 len ) 0 d0 moveq sp ) a0 move word a0 )+ d0 move long a0 sp ) move d0 sp -) move next end-code \ strings. 27Jan88pJacode move (s from to len -- ) 4 sp d) d0 move 8 sp d) d0 cmp ' cmove> @-t bhi ' cmove @-t bra end-code assembler label >upper byte ascii a d4 cmpi u>= if ascii z d4 cmpi u<= if 32 d4 subi then then long rts code upc (s char -- char' ) sp ) d4 move >upper bsr d4 sp ) move next c; code upper (s addr len -- ) sp )+ d0 move sp )+ a0 move d0 ?do byte a0 ) d4 move >upper bsr d4 a0 )+ move long loop: dbra next c; code here dp >pcd) sp -) move next end-code code pad 112 d0 moveq dp >pcd) d0 add d0 sp -) move next end-code \ strings. 27Jan88pJacode -trailing (s addr len -- addr len' ) sp )+ d0 move 0<> if sp ) a0 move i.w byte -1 d0 a0 di) tst long i.l 0= if 1 d0 subq then d0 a0 adda 32 d1 moveq 4 ori>ccr d0 ?do byte a0 -) d1 cmp long loop: dbne word 1 d0 addq long then d0 sp -) move next end-code code comp (s addr1 addr2 len -- -1|0|1 ) hex 301 decimal sp )+ movem< -1 w#) pea 4 ori>ccr d0 ?do byte a0 )+ a1 )+ cmpm long loop: dbne u>= if 0<> if 1 sp ) addq then 1 sp ) addq then next end-code \ strings. 27Jan88pJacode caps-comp (s addr1 addr2 len -- -1|0|1 ) hex 301 decimal sp )+ movem< -1 w#) pea 4 ori>ccr d0 ?do byte a0 )+ d4 move >upper bsr d4 d1 move a1 )+ d4 move >upper bsr d1 d4 cmp long loop: dbne u>= if 0<> if 1 sp ) addq then 1 sp ) addq then next end-code code compare (s addr1 addr2 len -- -1|0|1 ) caps >pcd) d0 move ' comp @-t beq ' caps-comp @-t bra end-code \ Terminal output. 27Jan88pJabss_stdbuffer constant stdbuffer patchbss : emit (s c -- ) stdbuffer c! stdbuffer 1 type ; : crlf (s -- ) 10 emit #out off 1 #line +! ; : space (s -- ) bl emit ; : m-emits (s n char -- ) over 1 256 between if >r stdbuffer swap 2dup r> fill type else 2drop then ; : spaces (s n -- ) bl m-emits ; : backspaces (s n -- ) bs m-emits ; : beep (s -- ) noop ; \ System dependent control characters. 27Jan88pJa: bs-in (s n c -- 0|n-1 ) drop dup if 1- bs else bell then emit ; : (del-in) (s n c -- 0|n-1 ) drop dup if 1- bs emit space bs else bell then emit ; : back-up (s n c -- 0 ) drop dup backspaces dup spaces backspaces 0 ; : cr-in (s m a n c -- m a m ) drop span ! over bl emit ; : (char) (s a n char -- a n+1 ) 3dup emit + c! 1+ ; defer char defer del-in \ Terminal input. 27Jan88pJacreate ccmap here 4+ , 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 1 c, 0 c, 0 c, 0 c, 0 c, 2 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 3 c, 0 c, 0 c, 3 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, 0 c, create cc-forth ' char , ' bs-in , ' cr-in , ' back-up , create cc cc-forth , \ terminal input. 27Jan88pJa: expect (s addr len -- ) dup span ! swap 0 begin 2 pick over - while key dup bl < if dup ccmap @ + c@ 4* cc @ + perform else dup 127 = if del-in else char then then repeat 2drop drop ; : tib (s -- addr ) 'tib @ ; : query (s -- ) tib 79 expect span @ #tib ! blk off >in off ; \ Block IO. 18Feb88pJa 4 constant #buffers 1024 constant b/buf #buffers b/buf * bss: bss_diskbuffers bss_diskbuffers constant 'buffers patchbss 16 constant b/bhead \ bufferheader: variable disk-error \ block#-fcb-'buffer-flag variable >buffers 5 b/bhead * allot >buffers 5 b/bhead * + constant >end <rel : buffer# (s n -- addr ) 16* >buffers + ; : >update (s -- addr ) 1 buffer# 12+ ; defer read-block \ defined in dos area defer write-block \ block IO. 27Jan88pJa: .file (s fcb -- ) \ for fcb definitions see dos dup @ if 12+ @ 1- count type space else drop ." ?? " then ; : file? (s -- ) file @ .file ; : switch (s -- ) file @ in-file @ file ! in-file ! ; : capacity (s -- n ) file @ 4+ @ 1+ b/buf / ; : latest? (s n fcb -- fcb n | a f ) disk-error off swap 2dup 1 buffer# 2@ d= if 2drop 1 buffer# 8+ @ false r> drop then ; : absent? (s n fcb -- true | adr false ) latest? false #buffers 1+ 2 do drop 2dup i buffer# 2@ d= if 2drop i leave else false then loop ?dup if buffer# dup >buffers 16 cmove >r >buffers dup 16+ over r> swap - cmove> 1 buffer# 8+ @ false else >buffers 2! true then ; \ block IO. 27Jan88pJa: update (s -- ) >update on ; : discard (s -- ) >update off 1 buffer# on ; : missing (s -- ) >end 4- @ 0< if >end 4- off >end 16- write-block then >end 8- @ >buffers 8+ ! 1 >buffers 12+ ! >buffers dup 16+ #buffers 16* cmove> ; : (buffer) (s n fcb -- a ) absent? if missing 1 buffer# 8+ @ then ; : buffer (s n -- a ) file @ (buffer) ; : (block) (s n fcb -- a ) (buffer) >update @ 0> if 1 buffer# dup read-block 12+ off then ; : block (s n -- a ) file @ (block) ; : in-block (s n -- a ) in-file @ (block) ; \ block IO. 28Jan88pJa: empty-buffers (s -- ) 'buffers #buffers 1024 * erase >buffers #buffers 1+ 16* erase 'buffers 1 buffer# #buffers 0 do dup on 8+ 2dup ! swap b/buf + swap 8+ loop 2drop ; : save-buffers (s -- ) 1 buffer# #buffers 0 do dup @ 1+ if dup 12+ @ 0< if dup write-block dup 12+ off then 16+ then loop drop ; : flush (s -- ) save-buffers empty-buffers ; : view# (s -- addr ) file @ 8+ ; : (load) (s n -- ) file @ >r blk @ >r >in @ >r >in off blk ! in-file @ file ! run r> >in ! r> blk ! r> !files ; defer load \ Number input. 28Jan88pJacode digit (s char base -- n true | char false ) sp ) d0 move 4 sp d) d4 move >upper bsr byte ascii 0 d4 subi no bmi 10 d4 cmpi >= if 7 d4 subq 10 d4 cmpi no bcs then d4 d0 cmp no bls long d4 4 sp d) move yes bra end-code : double? (s -- f ) dpl @ 1+ 0<> ; : convert (s ud1 addr1 -- ud2 addr2 ) begin 1+ dup >r c@ base @ digit while swap base @ um* drop rot base @ um* d+ double? if 1 dpl +! then r> repeat drop r> ; \ number input. 28Jan88pJa: (number?) (s addr -- d f ) 0 0 rot dup 1+ c@ ascii - = dup >r - dpl on begin convert dup c@ ascii , ascii / between while dpl off repeat -rot r> if dnegate then rot c@ 0= ; : number? (s addr -- d f ) false over count bounds ?do i c@ base @ digit nip if drop true leave then loop if (number?) else drop 0 0 false then ; : (number) (s addr -- d ) number? not ?missing ; defer number \ Number output. 28Jan88pJa: hold (s char -- ) -1 hld +! hld @ c! ; : <# (s -- ) pad hld ! ; : #> (s d -- addr len ) 2drop hld @ pad over - ; : sign (s n -- ) 0< if ascii - hold then ; : # (s d -- d ) base @ um/mod rot 9 over < if 7 + then ascii 0 + hold ; : #s (s d -- d ) begin # 2dup or 0= until ; : decimal 10 base ! ; : octal 8 base ! ; : hex 16 base ! ; : binary 2 base ! ; \ number output. 28Jan88pJa: (u.) (s u -- a l ) 0 <# #s #> ; : u. (s u -- ) (u.) type space ; : u.r (s u l -- ) >r (u.) r> over - spaces type ; : (.) (s n -- a l ) dup abs 0 <# #s rot sign #> ; : . (s n -- ) (.) type space ; : .r (s n l -- ) >r (.) r> over - spaces type ; : (ud.) (s ud -- a l ) <# #s #> ; : ud. (s ud -- ) (ud.) type space ; : ud.r (s ud l -- ) >r (ud.) r> over - spaces type ; : (d.) (s d -- a l ) tuck dabs <# #s rot sign #> ; : d. (s d -- ) (d.) type space ; : d.r (s d l -- ) >r (d.) r> over - spaces type ; \ Parsing. 28Jan88pJacode skip (s addr len char -- addr' len' ) hex 103 decimal sp )+ movem< 4 ori>ccr d1 ?do byte a0 )+ d0 cmp long loop: dbne word 1 d1 addq long 0<> if 1 a0 subq then a0 sp -) move d1 sp -) move next end-code code scan (s addr len char -- addr' len' ) hex 103 decimal sp )+ movem< binary 11011 decimal andi>ccr d1 ?do byte a0 )+ d0 cmp long loop: dbeq word 1 d1 addq long 0<> if 1 a0 subq then a0 sp -) move d1 sp -) move next end-code : /string (s addr len n -- addr' len' ) over min rot over + -rot - ; : place (s addr len to -- ) 3dup 1+ swap move c! drop ; \ parsing. 28Jan88pJa: (source) (s -- addr len ) blk @ ?dup if block b/buf else tib #tib @ then ; defer source : parse-word (s char -- addr len ) >r source tuck >in @ /string r@ skip over swap r> scan >r over - rot r> dup 0<> + - >in ! ; : parse (s char -- addr len ) >r source >in @ /string over swap r> scan >r over - dup r> 0<> - >in +! ; \ parsing. 28Jan88pJa: 'word (s -- addr ) here ; : word (s char -- addr ) parse-word 'word place 'word dup count + 0 swap c! ; : .( (s -- ) ascii ) parse type ; immediate : ( (s -- ) ascii ) parse 2drop ; immediate : \s (s -- ) end? on ; immediate \ Dictionary. 30Jan88pJa: done? (s n -- f ) state @ <> end? @ or end? off ; code traverse (s addr dir -- addr' ) sp )+ d0 move sp )+ a0 move begin d0 a0 adda byte a0 ) tst long 0< until a0 sp -) move next end-code \ : forth-83 (s -- ) forth definitions ; \ dictionary. 31Jan88pJa: n>link 4- ; : l>name 4+ ; : body> 4- ; : name> 1 traverse 1+ even ; : link> l>name name> ; : >body 4+ ; : >name -1 traverse -1 traverse ; : >link >name n>link ; : >view >link 2- ; : view> 2+ link> ; code hash (s string voc-prt -- thread ) sp )+ d0 move sp ) a0 move 1 a0 addq 3 d1 moveq byte a0 ) d1 and long 2 # d1 asl d1 d0 add d0 sp ) move next end-code \ dictionary finding. 30Jan88pJacode (find) (s here lfa -- here false | cfa flag ) sp ) d0 move d0 a0 move no beq begin 4 sp d) a1 move 4 a0 d) a2 lea byte a1 )+ d1 move a2 )+ d2 move d2 d1 eor hex 3F decimal d1 andi 0= if begin a1 )+ d1 move a2 )+ d2 move d2 d1 eor 1 # d1 lsl 0= if 2swap u< until word a2 d0 move 1 # d0 lsr u< if long 1 a2 addq then a2 4 sp d) move 64 d0 moveq byte 4 a0 d) d0 and long yes beq 1 d0 moveq d0 sp ) move next then then long a0 ) d0 move d0 a0 move 0= until no bra end-code \ dictionary finding. 30Jan88pJa4 constant #threads : find (s addr -- addr false | cfa flag ) dup c@ if prior off false #vocs 0 do drop context i 4* + @ dup if dup prior @ over prior ! = if drop false else over swap hash @ (find) dup ?leave then then loop else drop end? on ['] noop 1 then ; : ?uppercase caps @ if dup count upper then ; : defined (s -- here 0 | cfa [ -1| 1 ] ) bl word ?uppercase find ; \ Interpreter. 30Jan88pJa0 constant stacktop : ?stack (s -- ) sp@ sp0 @ swap u< abort" Stack Underflow" sp@ stacktop u< abort" Stack Overflow" ; defer status : interpret (s -- ) begin ?stack defined if execute else number double? not if drop then then false done? until ; \ Compiler. 30Jan88pJa: allot (s n -- ) dp +! ; : , (s n -- ) here ! 4 allot ; : w, (s w -- ) here w! 2 allot ; : c, (s c -- ) here c! 1 allot ; : align (s -- ) here 1 and if 0 c, then ; : even (s addr -- addr' ) dup 1 and + ; : compile (s -- ) r> dup 4+ >r @ , ; : immediate (s -- ) 64 last @ cset ; : literal (s n -- ) compile (lit) , ; immediate : dliteral (s d -- ) swap [compile] literal [compile] literal ; immediate : ascii (s -- n ) bl word 1+ c@ state @ if [compile] literal then ; immediate : control (s -- n) bl word 1+ c@ 31 and state @ if [compile] literal then ; immediate \ Compiler. 30Jan88pJa: crash (s -- ) true abort" Uninitialized execution vector." ; : ?missing (s f -- ) if 'word count type true abort" ?" then ; : ' (s -- cfa ) defined 0= ?missing ; : ['] (s -- ) ' [compile] literal ; immediate : [compile] (s -- ) ' , ; immediate : (") (s -- addr len ) r> count 2dup + even >r ; : (.") (s -- ) r> count 2dup + even >r type ; : ," (s -- ) ascii " parse 1+ tuck 'word place allot 0 c, align ; : ." (s -- ) compile (.") ," ; immediate : " (s -- ) compile (") ," ; immediate \ compiler. 31Jan88pJadefer where defer ?error : (?error) (s addr len f -- ) if >r >r sp0 @ sp! blk @ if >in @ blk @ where then r> r> space type space quit else 2drop then ; : (abort") (s f -- ) r@ count rot ?error r> count + even >r ; : abort" (s -- ) compile (abort") ," ; immediate : abort (s -- ) true abort" " ; \ Structures. 30Jan88pJa: ?condition (s f -- ) not abort" Conditionals Wrong" ; : >mark (s -- addr ) here 0 , ; : >resolve (s addr -- ) here swap ! ; : <mark (s -- addr ) here ; : <resolve (s addr -- ) , ; : ?>mark (s -- f addr ) true >mark ; : ?>resolve (s f addr -- ) swap ?condition >resolve ; : ?<mark (s -- f addr ) true <mark ; : ?<resolve (s f addr -- ) swap ?condition <resolve ; : leave compile (leave) ; immediate : ?leave compile (?leave) ; immediate \ structures. 30Jan88pJa: begin ?<mark ; immediate : then ?>resolve ; immediate : do compile (do) ?>mark ; immediate : ?do compile (?do) ?>mark ; immediate : loop compile (loop) 2dup 4+ ?<resolve ?>resolve ; immediate : +loop compile (+loop) 2dup 4+ ?<resolve ?>resolve ; immediate : until compile ?branch ?<resolve ; immediate : again compile branch ?<resolve ; immediate : repeat 2swap [compile] again [compile] then ; immediate : if compile ?branch ?>mark ; immediate : else compile branch ?>mark 2swap ?>resolve ; immediate : while [compile] if ; immediate \ Defining words. 30Jan88pJa: ,view (s -- ) blk @ dup if view# @ 4096 * + then w, ; : "create (s str -- ) count here even 2+ 4+ place align ,view here 0 , here last ! here warning @ if find if here count type ." isn't unique " then drop here then current @ hash dup @ here 4- rot ! swap ! here dup c@ width @ min 2dup + -rot 1+ allot align 128 swap cset 128 swap cset compile [ [forth] assembler docreate , meta <rel ] ; : create (s -- ) bl word ?uppercase "create ; \ defining words. 31Jan88pJa: !csp (s -- ) sp@ csp ! ; : ?csp (s -- ) sp@ csp @ <> abort" Stack changed." ; : hide (s -- ) last @ dup n>link @ swap current @ hash ! ; : reveal (s -- ) last @ dup n>link swap current @ hash ! ; : (;uses) (s -- ) r> @ last @ name> ! ; vocabulary assembler : ;uses (s -- ) ?csp compile (;uses) [compile] [ reveal assembler ; immediate : (;code) (s -- ) r> last @ name> ! ; : ;code (s -- ) ?csp compile (;code) [compile] [ reveal assembler ; immediate \ defining words. 31Jan88pJa: does> (s -- ) compile (;code) 20153 ( jsr ) w, [ [assembler] dodoes meta ] literal [ <rel ] , ; immediate : [ (s -- ) state off ; immediate : ] (s -- ) state on begin ?stack defined dup if 0> if execute else , then else drop number double? if [compile] dliteral else drop [compile] literal then then true done? until ; : : (s -- ) !csp current @ context ! create hide ] ;uses nest , <rel : ; (s -- ) ?csp compile unnest reveal [compile] [ ; immediate \ defining words. 18Feb88pJa: recursive (s -- ) reveal ; immediate : constant (s n -- ) create , ;uses doconstant , <rel ( mark as relocated ) : variable (s -- ) create 0 , ;uses docreate , <rel : defer (s -- ) create ['] crash , ;uses dodefer , <rel dodefer resolves <defer> : vocabulary (s -- ) create #threads 0 do 0 , loop here voc-link @ , voc-link ! does> context ! ; resolves <vocabulary> : definitions (s -- ) context @ current ! ; \ defining and redefining words. 30Jan88pJavariable avoc : (is) (s cfa -- ) r@ @ >body ! r> 4+ >r ; : is (s cfa -- ) state @ if compile (is) else ' >body ! then ; immediate \ (spare) 30Jan88pJa \ (spare) 30Jan88pJa \ Amiga specials, Exec. 31Jan88pJa: librarybase (s -- ) create 0 , here lib-link @ , lib-link ! ; h: librarybase variable here-t lib-link @-t ,-tr lib-link dup relocate !-t ; [forth] assembler label callrom rcallmask 2- >pcd) a1 lea word w )+ a1 ) move long rcalloffset 2- >pcd) a1 lea word w )+ a1 ) move long rcallflag >pcd) a1 lea word w )+ a1 ) move long rcall bra end-code meta vocabulary Exec Exec definitions variable ExecBase [assembler] label execbased ExecBase >pcd) a0 move callrom bra end-code \ Exec. 31Jan88pJa: execcall (s flag offset mask -- ) create w, w, w, ;uses execbased , <rel h: execcall target-create [[ [assembler] execbased ]] literal ,-tr w,-t w,-t w,-t [[ in-meta ]] ; -1 -552 binary 1000000001 decimal execcall OpenLibrary (s libname version -- lib-vector ) 0 -414 binary 1000000000 decimal execcall CloseLibrary (s library -- ) -1 -198 binary 11 decimal execcall AllocMem (s requirements bytesize -- addr ) 0 -210 binary 1000000001 decimal execcall FreeMem (s memblock bytesize -- ) -1 -330 binary 1 decimal execcall AllocSignal (s signalnumber -- signalnumber' ) \ Exec. 31Jan88pJa 0 -336 binary 1 decimal execcall FreeSignal (s signalnumber -- ) -1 -294 binary 1000000000 decimal execcall FindTask (s name -- task ) 0 -354 binary 1000000000 decimal execcall AddPort (s port -- ) 0 -360 binary 1000000000 decimal execcall RemPort (s port -- ) -1 -444 binary 1100000011 decimal execcall OpenDevice (s ioReq devname flgs unit# -- f |0=ok ) 0 -450 binary 1000000000 decimal execcall CloseDevice (s ioReq -- ) 0 -462 binary 1000000000 decimal execcall SendIO (s ioReq -- ) \ Exec, Execsupport 31Jan88pJa -1 -372 binary 0100000000 decimal execcall GetMsg (s port -- msg | 0 ) -1 -384 binary 0100000000 decimal execcall WaitPort (s port -- msg ) -1 -456 binary 1000000000 decimal execcall DoIO (s ioReq -- f | 0=ok ) code NewList (s header -- ) sp )+ a0 move a0 a0 ) move 4 a0 ) addq 4 a0 d) clr a0 8 a0 d) move next end-code code setport (s pri name signal port task -- port ) sp )+ d0 move sp )+ a0 move d0 16 a0 d) move 7 sp )+ movem< byte d0 15 a0 d) move long d1 10 a0 d) move byte d2 9 a0 d) move 4 # 8 a0 d) move 0 # 14 a0 d) move long a0 sp -) move next end-code \ Exec, Execsupport 31Jan88pJa: CreatePort (s name priv -- port | 0 ) -1 AllocSignal -1 over = if drop 2drop exit then 65537 34 AllocMem ?dup 0= if FreeSignal 2drop exit then >r >r over r> r> 0 FindTask setport tuck swap 0= if 20 + NewList else AddPort then ; code DeletePort (s port -- ) sp ) a0 move 10 a0 d) tst 0<> if a0 sp -) move c: RemPort ;c sp ) a0 move then -1 d0 moveq byte d0 8 a0 d) move long d0 20 a0 d) move 0 d0 moveq byte 15 a0 d) d0 move long d0 sp -) move c: FreeSignal ;c 34 w#) pea c: FreeMem ;c next end-code \ Exec, Execsupport 31Jan88pJa: CreateExtIO (s port size -- IORequest ) over 0= if 2drop 0 exit then 65537 over AllocMem ?dup 0= if 2drop 0 exit then dup >r 5 over 8+ c! 18 + w! r@ 14 + ! r> ; code DeleteExtIO (s IORequest -- ) sp ) d0 move d0 a0 move 0<> if -1 d0 moveq byte d0 8 a0 d) move long d0 20 a0 d) move d0 24 a0 d) move 0 d0 moveq word 18 a0 d) d0 move long d0 sp -) move c: FreeMem ;c then next end-code : DeleteStdIO (s IORequest -- ) DeleteExtIO ; : CreateStdIO (s port -- IOStdRequest | 0 ) 48 CreateExtIO ; forth definitions \ Console device. 31Jan88pJavariable ConWritePort variable ConReadPort variable ConWriteMsg variable ConReadMsg code QueRead (s request buffer -- ) sp )+ d0 move sp ) a0 move d0 40 a0 d) move 1 d0 moveq d0 36 a0 d) move 2 d0 moveq word d0 28 a0 d) move long c: SendIO ;c next end-code code (key?) (s -- f) d0 sp -) move ConReadPort >pcd) a0 move 20 a0 d) a0 move a0 ) tst no beq yes bra end-code \ Console device. 31Jan88pJacode (key) (s -- char ) begin ConReadPort >pcd) sp -) move c: GetMsg ;c sp )+ tst 0= while ConReadPort >pcd) sp -) move c: WaitPort ;c 4 sp addq repeat ConReadMsg >pcd) a0 move bss_keybuffer #) a1 lea patchbss 0 d0 moveq byte a1 ) d0 move long d0 sp -) move a0 sp -) move a1 sp -) move ' QueRead @-t bra end-code code (type) (s addr len -- ) sp )+ d0 move sp )+ a0 move d0 rp -) move ConWriteMsg >pcd) a1 move d0 36 a1 d) move a0 40 a1 d) move 3 d0 moveq word d0 28 a1 d) move long a1 sp -) move c: DoIO ;c rp )+ d0 move 4 sp addq d0 #out #) add <rel next end-code \ Console device. 31Jan88pJa: MakeConStuff (s -- f | t=ok ) " 4thcon.write" drop 0 CreatePort dup 0<> if dup ConWritePort ! CreateStdIO dup 0<> if ConWriteMsg ! " 4thcon.read" drop 0 CreatePort dup 0<> if dup ConReadPort ! CreateStdIO dup 0<> if ConReadMsg ! true then then then then ; : OpenConsole (s window -- ) MakeConStuff 0= if 0 exit then ConWriteMsg @ tuck 40 + ! dup " console.device" drop 0 0 OpenDevice 0<> if drop 0 exit then 20 + dup @ swap 4+ @ ConReadMsg @ 24 + tuck ! 4- ! ConReadMsg @ [ bss_keybuffer ] literal [ patchbss ] QueRead true ; \ Console device, closing libs. 31Jan88pJa: CloseConsole (s -- ) ConWriteMsg @ CloseDevice ConWriteMsg @ DeleteStdIO ConReadMsg @ DeleteStdIO ConWritePort @ DeletePort ConReadPort @ DeletePort ; : close-lib (s lib-list-ptr -- ) 4- dup @ ?dup if CloseLibrary off else drop then ; : close-libs (s -- ) lib-link begin @ ?dup while dup close-lib repeat ; \ Dos library. 01Feb88pJavocabulary Dos Dos definitions 20 constant b/fcb librarybase DosBase [assembler] label dosbased DosBase >pcd) a0 move callrom bra end-code : doscall (s flag offset mask -- ) create w, w, w, ;uses dosbased , <rel h: doscall target-create [[ [assembler] dosbased ]] literal ,-tr w,-t w,-t w,-t [[ in-meta ]] ; : Open-Dos (s -- ) " dos.library" drop 0 OpenLibrary dup 0= abort" Unable to open Dos" DosBase ! ; \ Dos library. 19Feb88pJa -1 -30 binary 00000110 decimal doscall Open (s accessmode name -- filehandle ) 0 -36 binary 00000010 decimal doscall Close (s filehandle -- ) -1 -42 binary 00001110 decimal doscall Read (s lenght buffer file -- length' ) -1 -48 binary 00001110 decimal doscall Write (s length buffer file -- length' ) -1 -66 binary 00001110 decimal doscall Seek (s mode position file -- oldposition ) -1 -132 binary 00000000 decimal doscall IoErr (s -- error ) \ Dos 01Feb88pJa: !files (s fcb -- ) dup file ! in-file ! ; : disk-abort (s fcb a n -- ) type ." in " .file abort ; : ?disk-error (s fcb n -- ) dup disk-error ! 0< if " Disk error# " disk-abort else drop then ; : in-range (s charpos fcb -- ) tuck 4+ @ dup -1 = -rot u> or dup disk-error ! if " Out of Range " disk-abort then drop ; : seek (s bheader -- ) dup 4+ @ dup @ rot over 0= if 2drop true else @ 1024 * swap over 3 pick in-range -1 -rot Seek then ?disk-error ; \ Dos 31Jan88pJa: file-read (s bheader -- ) dup seek dup 4+ @ swap 8+ @ over @ b/buf -rot Read ?disk-error ; : file-write (s bheader -- ) dup seek dup 4+ @ swap 8+ @ over @ b/buf -rot Write ?disk-error ; : file-size (s fcb -- n ) @ dup 1 0 rot Seek -1 swap rot Seek 1- ; : open-file (s -- ) in-file @ dup @ if drop exit then 1005 over 12+ @ Open ?dup 0= if " Open error " disk-abort then over ! dup file-size swap 4+ ! ; \ Dos 01Feb88pJa: (close-file) (s fcb -- ) dup @ ?dup if Close then off ; : !fcb (s -- ) 0 , -1 , 0 , here 0 , here file-link @ , file-link ! bl word count caps @ if 2dup upper then here dup >r -rot 1+ tuck r> place allot 0 c, align 1+ swap ! ; : file: (s -- fcb ) >in @ create >in ! here !fcb does> !files ; drop : ?define (s -- fcb ) >in @ defined if nip >body else drop >in ! file: then ; forth definitions \ Dos 15Feb88pJa: more (s n -- ) \ carefull no stack checking!! capacity swap bounds ?do b/buf file @ 4+ +! i buffer b/buf blank update save-buffers loop ; : close-file (s -- ) save-buffers file @ (close-file) ; : close-files (s -- ) flush file-link begin @ ?dup while dup 16- (close-file) repeat ; : create-file (s #blocks -- ) [ Dos ] ?define 1006 over 12+ @ Open ?dup if over ! !files more close-file else 2drop then ; : define (s -- ) [ Dos ] ?define drop ; : open (s -- ) [ Dos ] ?define !files open-file ; : from (s -- ) [ Dos ] ?define in-file ! open-file ; : files (s -- ) file-link begin @ ?dup while dup 16- .file repeat ; \ (spare) 01Feb88pJa \ Intuition library. 01Feb88pJavocabulary Intuition Intuition definitions librarybase IntuitionBase : Open-Intuition (s -- f | t=ok ) " intuition.library" drop 0 OpenLibrary ?dup if IntuitionBase ! true else false then ; : Close-Intuition (s -- ) IntuitionBase @ IntuitionBase off CloseLibrary ; [assembler] label intuitionbased IntuitionBase >pcd) a0 move callrom bra end-code : intuitioncall (s flag offset mask -- ) create w, w, w, ;uses intuitionbased , <rel h: intuitioncall target-create [[ [assembler] intuitionbased ]] literal ,-tr w,-t w,-t w,-t [[ in-meta ]] ; \ Intuition library. 31Jan88pJa -1 -204 binary 100000000 decimal intuitioncall OpenWindow (s newwindow -- window ) 0 -72 binary 100000000 decimal intuitioncall CloseWindow (s window -- ) forth definitions \ Forgetting. 01Feb88pJacode fenced (s addr -- fl ) sp ) d0 move dp 4+ >pcd) a0 lea a0 )+ d0 sub no bmi a0 )+ d0 sub yes bmi no bra end-code : trim (s faddr voc-addr -- ) #threads 0 do 2dup @ begin 2dup dup fenced -rot u> not and while @ repeat nip over ! 4+ loop 2drop ; : tonext (s faddr linkpointer -- faddr linkpointer fl ) 2dup dup fenced -rot u< and ; \ forgetting. 01Feb88pJa: (forget) (s view-addr -- ) dup fenced not abort" Below fence" lib-link @ begin tonext while dup close-lib @ repeat lib-link ! file-link @ begin tonext while dup 16- (close-file) @ repeat file-link ! voc-link @ begin tonext while @ repeat dup voc-link ! begin dup while 2dup #threads 4* - trim @ repeat drop dp ! ; : forget (s -- ) bl word dup current @ hash @ (find) 0= ?missing >view (forget) ; \ Initialization, window specs. 01Feb88pJa: windowname (s -- addr ) " Forth" drop ; variable Window 640 w,-t 200 w,-t -1 w,-t 0 ,-t hex 21027 decimal ,-t 0 ,-t 0 ,-t ' windowname >body 4+ 1+ ,-tr 0 ,-t 0 ,-t 100 w,-t 40 w,-t 640 w,-t 400 w,-t 1 w,-t \ initialization, commandline, running. 19Feb88pJa: ok 1 load ; code (bye) (s return-code -- ) sp ) d0 move sp0 >pcd) sp move 8 sp addq rts end-code : commandline (s -- ) sp0 @ dup 4+ @ swap @ dup #tib ! tib swap move bl tib #tib @ 1- + c! hex bl word number? if drop dp 8+ ! else 2drop >in off then decimal 2 dp 8+ @ AllocMem dup 0= if 300 (bye) then dp 2dup ! 4+ ! ; : run (s -- ) state @ if ] state @ not if interpret then else interpret then ; \ initialization 01Feb88pJa: quit (s -- ) [ bss_tibbuffer ] literal [ patchbss ] 'tib ! blk off [compile] [ begin rp0 @ rp! status query run state @ not if ." ok" then again ; : warm (s -- ) true abort" Warm Start" ; defer boot : cold (s -- ) boot if commandline interpret quit then 100 (bye) ; \ initialization 01Feb88pJa: start (s -- f | t=ok ) Open-Dos Open-Intuition if Window OpenWindow else 0 exit then dup if dup Window ! OpenConsole else Close-Intuition 0 exit then not if Window @ CloseWindow Close-Intuition 0 exit then empty-buffers true ; : bye (s -- ) CloseConsole Window @ CloseWindow close-files close-libs dp 4+ dup @ swap 4+ @ FreeMem 0 (bye) ; \ initialization, low level. 01Feb88pJa[assembler] here start-t 8+ !-t ' warm >body >pcd) ip lea next here start-t 2+ !-t sp d1 move 4 sp d) d1 sub ' stacktop >body >pcd) a1 lea d1 a1 ) move a0 sp -) move d0 sp -) move sp0 >pcd) a0 lea sp a0 ) move ExecBase >pcd) a0 lea 4 w#) a0 ) move bss_rpstack #) rp lea patchbss 1024 # rp adda rp0 >pcd) a0 lea rp a0 ) move @next >pcd) a3 lea ' cold >body >pcd) ip lea next end-code in-meta \ Resident Tools 01Feb88pJa: depth (s -- n ) sp@ sp0 @ swap - 4 / ; : .s (s -- ) depth ?dup if 0 do depth i - 1- pick 10 u.r space key? ?leave loop else ." Empty " then ; code (.id) (s addr len -- addr' len ) sp ) d0 move 0<> if bss_stdbuffer #) a0 lea patchbss 4 sp d) a1 move a0 4 sp d) move d0 ?do byte a1 )+ a0 )+ move long loop: dbmi 1 a0 subq 127 d1 moveq byte d1 a0 )+ and ascii _ d1 moveq 1 d0 addq d0 ?do d1 a0 )+ move loop: dbra long then next end-code \ resident tools, and loading screens 23Feb88pJa: .id (s nfa -- ) count 31 and (.id) type space ; 64 constant c/l 16 constant l/scr : \ (s -- ) >in @ negate c/l mod >in +! ; immediate : (s (s -- ) [compile] ( ; immediate : ? (s -- ) @ . ; : ?enough (s n -- ) depth 1- > abort" Not enough Parameters" ; : thru (s n1 n2 -- ) 2 ?enough 1+ swap ?do i load loop ; : +thru (s n1 n2 -- ) blk @ + swap blk @ + swap thru ; : --> (s -- ) >in off 1 blk +! ; immediate : views (s n -- ) [ Dos ] ?define 8+ ! ; \ (spare) 23Feb88pJa \ (spare) 23Feb88pJa \ (spare) 23Feb88pJa \ Initialize, resolve forward references. 01Feb88pJa' (.") resolves <(.")> ' (") resolves <(")> ' (abort") resolves <(abort")> ' (;uses) resolves <(;uses)> ' (is) resolves <(is)> ' (;code) resolves <(;code)> [assembler] docreate meta resolves <variable> ' quit resolves quit ' even resolves even ' ?missing resolves ?missing ' !files resolves !files ' run resolves run ' [ resolves [ ' definitions resolves definitions \ Initialize variables. 01Feb88pJa ' forth >body current dup relocate !-t ' forth >body context dup relocate !-t voc-link-t @ voc-link dup relocate !-t \ Initialize deferred words 19Feb88pJa' (type) is type ' (key) is key ' (key?) is key? ' crlf is cr ' (char) is char ' (del-in) is del-in ' file-read is read-block ' file-write is write-block ' (load) is load ' (number) is number ' (source) is source ' cr is status ' noop is where ' (?error) is ?error ' start is boot \ Kernel for 68000 Amiga. 16Feb88pJa After the file is Meta compiled, save the target by typing: Save-target <name> then free up the target image buffer by entering: free-target At that point you can exit with 'bye' and fire up the new targete.g. Forth A000 open Utilities.blk ok This would start Forth, assign $A000 bytes of user dictionary and open the file Utilities.blk, and load it via 'ok'. \ Set up target image buffer and relocation buffer. 16Feb88pJa Target dictionary pointer starts at 0, no offset. Target image buffer size, 'tsize', currently 32k and enough. Rbuffer is a bit array for relocation information. The Meta word 'Rbuffer points to this buffer get-target Gets a tsize'd hunk of memory, to use as target image, if available. Sets the 'target-origin' to the address +36 bytes. These are used for a header when saving. free-target Returns the hunk of memory, must free it or the Amiga will loose the use of that hunk until next reset. load the rest of the preamble. \ Allocate block storage bss, misc forward references 16Feb88pJabss_keybuffer the address of 32 bytes of keybuffer. bss_stdbuffer the address of 256 bytes of output buffer bss_tibbuffer the address of 256 bytes of line input buffer. bss_rpstack the address of 1k bytes of return stack ]] Must be able to access underlying Forth's ] [[ Same for [. definitions To avoid finding definitions in the 'only' vocab. [ To avoid finding [ in the transition vocabulary. \ Load kernel. 16Feb88pJa I preserve an entiry screen for loading. When making a stand alone application, I like to have a choice of what is included in the system. Eventually will look like: .. .. thru ( runtime ) .. .. thru ( low level ) .. .. thru ( variables ) .. .. thru ( numbers ) .. .. thru ( parsing ) etc etc... \ Boot vectors and 'next' interpreter. 16Feb88pJastart-t allows the jumps to be patched later. The cold start entry vector. The warm start entry vector. The next interpreter, @next is it's address. next is a macro, which compiles a jump to next interpreter. must set 'current-t' temporarily to any address but 0 (hi Guru) forth is the vocabulary where most of the words are defined. must mark the temporary current to not relocated. set the link of forth to 0 set the 2nd link of vocabulary forth to point to itself All that is very implication specific, take care if any of this is changed! \ Amiga rom calls, hi level word calls from code. 16Feb88pJarcallflag Rom call flag, if set Amiga Rom routine returns valuercall Call an Amiga Rom routine. The caller sets the mask for movem< to the registers involved and sets the jump offset to the Rom routine offset. Returns a value if 'rcallflag' is set before this routine is entered. Expects an Amiga Library base vector in a0, and test for a 0 vector, that is the Library was not yet opened. The labels 'rcallmask' and 'rcalloffset' point to 2+ the locations which should be altered before calling this routine hilevel runtime support, call high level words from code words(;c) returns from a highlevel call to code again. \ Run time code for defining words. 23Jan88pJanest The runtime code for : It pushes the current ip onto the return stack and sets the ip to point to the pfa . exit Terminates a highlevel word, by popping the return stack and putting it in the ip. unnest Same as exit. Compiled by ; to help decompiling. dodoes Runtime portion of defining words. Do a nest then get the address from the stack. docreate Runtime portion for variables, points to its own parameter field. Also for create. doconstant Runtime portion for constants, get value from parameter field. (lit) Runtime code for literals, fetches inline long. \ Meta, defining words. 16Feb88pJaliteral Now that code field of (lit) is known, define literal. dliteral Both literal and dliteral are transition word, ie immediate. ascii compile the next character as a literal. ['] Compile the code field of the next word as a literal. constant Define a constant in the target. We also save its value in meta for use during interpretation. \ Meta, Identify numbers and forward references. 16Feb88pJa<(;code)> Forward reference for code to patch code field. does> Compile the code field for (;code) and a jsr instruction to the runtime for does, called dodoes. Leaves the address for patching. numeric Make a number out of this word and compile it as either a single or double precision literal. Numeric is only called if the word is known to be a number. undefined Creates a forward reference "on the fly". The symbol is kept in the forward vocabulary and it is initialized to unresolved. When executed it either compiles itself or links into a backwards pointing chain of forward references. \ Meta, compiling loop. 16Feb88pJat-in To save the input stream pointer for later. ] Start compiling into the Target system. Always seach transition before target for immediate words. If word is found, execute it. It must compile itself. If word is not found, convert it to a number it it is numeric, otherwise it is a forward reference. [ Sets state-t to false to exit the Meta compiling loop above. ; Compile code field of exit and stop compiling. c: Start hi level compilation during code definitions. ;c Exit hi level comp. and continue code definition. ;code Start assembling runtime portion of a defining word. : Create a target word and set its code field to nest. \ Runtime control structures, branching. 16Feb88pJabranch Performs an unconditional branch. Using absolute addresses. ?branch Branch if f is false, otherwise skip over the inline address. \ Meta, branching. 16Feb88pJaThese are the Meta versions of the structured conditionals found in Forth. They must compile the correct run time branch instruction, and then mark and resolve either forward or backward branches. These are very analogous to the regular conditionals in Forth. Since they are in the transition vocabulary, which is searched before the target vocabulary, theywill be executed instead of the target versions of these words which are defined much later. \ Runtime control structures, looping 16Feb88pJa(loop) Runtime for loop. Branches back to the beginning to the loop if more iterations to do. Otherwise it exits. The loop counter is incremented. (+loop) Increment the loop counter by the value on the stack and decide whether or not to loop again. \ looping cont. 16Feb88pJa(do) The runtime code compiled by 'do'. Pushes the inline address onto the return stack along with values needed by (loop). (?do) The runtime code compiled by ?do. the difference between ?do and do is that ?do will not perform any iterations if the initial index is equal to the final index. bounds Given the address and length, make it ok for do...loop. \ Meta, looping. 16Feb88pJaThese are again the Transition versions of the immediate words for looping. They compile the correct runtime code and then mark and resolve the various branches. \ Execution control 16Feb88pJa@next The address of the inner interpreter. hilevel The address of hilevel calls from code words. execute The word whose code field is stored on the stack. perform The word whose code field is stored at the address pointed to by the number on the stack. Same as @ execute. dodefer The runtime code for deferred words. Fetches the code field and executes it. go Execute code at the given address. noop Does nothing, can be patched with a long jump. \ looping control. 16Feb88pJai Returns the current loop index. j Returns the index of the inner loop in nested do...loops. (leave) Does an immediate exit of a do...loop structure. Unlike other Forth' which wait until the next loop execution.(?leave) Leaves if the flag on the stack is true. Continues if not. leave To be compatible with 83-standard. ?leave \ Memory operators. 16Feb88pJa@ Fetch a 32 bit value from address. ! Store a 32 bit value at address. w@ Fetch a 16 bit value from address. w! Store a 16 bit value at address. \ and block moves. 16Feb88pJac@ Fetch an 8 bit value from address. c! Store an 8 bit values at address. cmove Move a set of bytes from the from address to the to address. Count is limited to 64k, and bytes are moved from low to high address, with possible overlap. cmove> The same as cmove, but bytes are moved in the opposite direction. From the high addresses to low addresses. \ Stack manipulations, stack pointers. 17Feb88pJasp@ Return the address of the next entry on the parameter stack. sp! Sets the parameter stack pointer to the specified value. rp@ Return the address of the next entry on the return stack. rp! Sets the return stack pointer to the specified value. \ stack manipulations 17Feb88pJadrop Throw away the top element of the stack. dup duplicate the top element of the stack. swap Exchange the top two elements on the stack. over Copy the second element to the top. \ stack manipulations 17Feb88pJatuck Tuck the first element under the second one. nip Drop the second element from the stack. rot Rotate the top three elements, bringing the third to the top. -rot The inverse of rot. Rotates the top element to third place. \ stack manipulations 17Feb88pJaflip Exchange the hi and low words of n. cflip Exchange the hi and low character of the low word in n. ?dup Duplicate the top of the stack if it is non-zero. \ stack manipulations 17Feb88pJar> Pops a value off the return stack and pushes it onto the parameter stack. >r Pops a value off the parameter stack and pushes it onto the return stack. r@ Copies the value on the return stack to the parameter stack pick Copies an element to the top of the stack. 0 pick is dup 1 pick is over. roll (s nm..n2 n1 k -- ????? ) Examples: 1 roll is the same as swap , 2 roll is rot. \ Logical operations. 17Feb88pJaand Returns bitwise and of n1 and n2 on the stack. or Returns bitwise or of n1 and n2 on the stack. xor Returns bitwise exclusive or of n1 and n2 on the stack. not Does a ones complement of the top. Equivalent to -1 xor. true false Constants for clarity. \ logical operations. 17Feb88pJacset Set the contents of address so that the bits that are 1 in n are also 1 in address. Equivalent to dup c@ rot or swap c! creset Sets the contents of addr so that the bits that are 1 in n are zero in address. ctoggle Flip the bits in address by the value n. Equivalent to dup c@ rot xor swap c! on Set the contents of address to true. off Set the contents of address to false. \ Arithmatic operations. 17Feb88pJa+ Add the top two numbers on the stack and return the result. negate Returns twos compliment of n. - Subtracts n2 from n1 and returns the result. abs Return the absolute value of n. +! Increment the value at address by n. -1 0 1 2 3 4 Are frequently used constants. \ arithmatic operations. 17Feb88pJa2* Double the number on the stack. 2/ Shift n right once. u2/ Logical shift right. 4* Multiply top of the stack by 4. 8* Multiply top of the stack by 8. 16* Multiply top of the stack by 16. \ arithmatic operations. 17Feb88pJa1+ Add 1 to tos. 1- subtract 1 from tos. 2+ Add 2 to tos. next 2- subtract 2 from tos. 4+ etc.. 4- 8+ 8- 12+ 16+ 16- \ arithmatic operations. Unsigned multiply. 17Feb88pJamulusub Subroutine, adds d0 *(2^16) to double number in registers d3-d2, d3 has the most significant number. um* Returns the double multiplication of two singles. This is the basic multiplication primitive in Forth. It takes two unsigned 32bit singles and returns an unsigned 64bit result. All other multiplication functions are derived from this primitive one. \ arithmatic operations. division routine. 17Feb88pJaum/mod This is the division primitive in Forth. All other division operations are derived from it. It takes a double number, d, and divides by a single number n1. It leaves a remainder and a double quotient on the stack. Checks for size operand and tries to be efficient. If you can figure it out, you can probably come up with a better version. (And send me a copy) \ arithmatic operations. division routine. 17Feb88pJaThis is a continuation of um/mod. Since it is a code word, I can split it up over two screens, it is not proper Forth to do this. But, I wrote this in assembler before, and up to now I haven't had the time to properly decompose it. Someday I will factor it and make it understandable. \ Comparison operations. 17Feb88pJayes no Two common routines, they change the top of the stack to either true or false. 0< Returns true if top is negative, ie sign bit is on. 0= Returns true if top is zero, false otherwise. 0> Returns true if top is positive and non zero. 0<> Returns true if top is not zero. < Compare the top two elements on the stack as signed numbers and return true if n1 < n2. = Compare the top two elements on the stack return true if n1 = n2. \ comparison operations. 17Feb88pJa> Compare the top two elements on the stack as signed numbers return true if n1 > n2. <> Compare the top two elements on the stack return true if n1 <> n2. u< Compare the top two elements on the stack as unsigned #'s return true if n1 < n2 unsigned. u> Compare the top two elements on the stack as unsigned #'s return true if n1 > n2 unsigned. ?negate Negate the second element if the top is negative. min Return the minimum of n1 and n2. \ comparison operations and conversion. 17Feb88pJamax Return the maximum of n1 and n2. between Return true if min <= n1 <= max, otherwise false. within Return true if min <= n1 < max, otherwise false. w>s Extend top of the stack to a single. From 16 to 32 bits. s>d Extend the top element to a double. From 32 to 64 bits. \ Double operations, memory. 17Feb88pJa2@ Fetch a 64 bit value from address. 2! Store a 64 bit value at address. \ double operations, stack. 17Feb88pJa2drop Drop the top two elements of the stack. 2dup Duplicate top tow elements of the stack. 2swap Swap the top two pairs of numbers on the stack. 2over Copy the second pair of numbers over the top pair. 3dup Duplicate the top three elements of the stack. \ double operations, arithmatic. 17Feb88pJad+ Add the two double precision numbers on the stack and return the result as a double precision number. dnegate Save as negate except for double precision numbers. dabs Return the absolute value of the 64 bit integer on the stack.d2* 64 bit left shift. d2/ 64 bit right shift. Equivalent to divide by 2. \ double operations, arithmatic. 17Feb88pJad- Subtract the two double precision numbers. ?dnegate Negate the double number if the top is negative. d= Compare the top two double numbers. True if d1 = d2. ( You can add some of the other double comparisons, I don't use them ). \ Mixed mode arithmatic. 17Feb88pJa*d Multiplies two singles and leaves a double. m/mod Divides a double by a single, leaving a single quotient and a single remainder. Division is floored. \ 32 bit multiply and divide. 17Feb88pJa* Return multiplication of n1 and n2. /mod Return remainder and quotient of n1 and n2 / Return quotient of n1 / n2 mod Return remainder of n1 / n2. */mod Internally accuracy to 64 bits. Returns quotient and remainder of n1*n2/n3 */ Internally kept to 64 bits. Returns quotient of n1*n2/n3. \ (spare) 18Feb88pJa \ System variables. 18Feb88pJasp0 Empty parameter stack, I don't use local multitasking rp0 Empty return stack. ( as opposed to F83 ) dp Next available location in the dictionary. At startup uses bss_stdbuffer. Then will be set to user dict. The size and start of which is saved in the two following cells. #out #line Number of lines and characters after cr and ff. offset Added to block references. base The current number base for in/output, default is decimal hld Points to a converted character during # output file Having both input and output fcb's in-file allows copying etc. \ system variables. 18Feb88pJatype key key? and cr are all deferred and allow the Amiga interface layer to be specified later. prior Points to the last vocabulary that was searched. state True if compiling. warning Defaults to on, giving a warning if a duplicate word name is chosen. dpl The decimal point location for numeric input. last Points to the name of the most recently created word. csp Used for compile time error checking. current New words are added to the current vocabulary. #vocs The number of elements in the search order array. context The array specifying the search order. \ system variables. 18Feb88pJa'tib Points to characters entered by user. Defaults to bss_tibbuffer ( note the use of patchbss to force bss reloc.)width Number of characters to keep in name field. scr Holds the screen number last listed or edited. r# The cursor position during editing. blk If non-zero, the block number we are interpreting. >in Number of characters interpreted this far. span Number of characters input by expect. #tib Used by word, when interpreting from the terminal. end? True if input stream exhausted, false otherwise. voc-link Points to the most recently defined vocabulary. lib-link Points to the most recently defined Amiga library. file-link Points to the most recently defined file. These links are important when forgetting words. The amiga needs it's files explicitly closed, 'bye' does it for you. \ Strings. 18Feb88pJabl bs bell Names for blank, backspace and bell. caps I like case sensitive words. Set to true for all caps. Watchout will need : CAPS caps ; and 0 CAPS ! fill Fill memory starting at start address with character. This is limited to 64k bytes in length. erase Fill the string with zeros. blank Fill the string with blanks. count Return the byte at address and the address + 1 Useful for strings. length Return the word at address and the address + 2 \ strings. 18Feb88pJamove Move the specified bytes without overlap, 64k limit! >upper Subroutine to convert character in d4 to upper. upc Convert a character to upper case. upper Convert the string in place, to upper case. here Return the address of the top of the dictionary. pad Floating temporary storage area. Hex 70 bytes above here. \ strings. 18Feb88pJa-trailing Returns the address and length of the given string ignoring trailing blanks. In this system, more complicated, because of a trailing zero byte after each string. comp String compare, limited to 64k length. Returns: -1 if str1 < str2, 0 if str1 = str2, +1 if str1 > str2. \ strings. 18Feb88pJacaps-comp Same as comp, but converts each character to upper case before comparison. Returns the same numbers according to the comparison results as above. see comp. compare Performs a string compare, consideres caps in the comparison. \ Terminal output. 18Feb88pJastdbuffer is set to bss_stdbuffer, must fix meta relocation emit Prints one character on the screen, uses type. crlf Amiga dependent end of line, default for cr. space Print a space on the terminal. m-emits Fill the output buffer with n characters, and type them on the terminal. spaces Print n spaces on the terminal, limited to 256 spaces. backspaces Print n backspaces, also limited to 256. beep Beeps are a kettle of fish on Amiga's. \ System dependent control characters. 18Feb88pJabs-in If at beginning of line, beep, otherwise back up 1. (del-in) If at beginning of line, beep, otherwise back up and erase 1.back-up Wipe out the current line by overwriting it with spaces. cr-in Finish input and remember the number of chars in span. (char) Process an ordinary character by appending it to the buffer. char is usually (char). Executed for most characters. del-in is usually (del-in). Executed for delete characters. \ Terminal input. 18Feb88pJaKeypresses are used to index into a table of routines. Normally this is 'char', for control characters it is del-in etc. The indirection is double. The first table is a map of byte sized indices, these point to an entry in the second table, where the routines are found. This allows for multiple changes. ccmap Is a variable holding it's address+4, and can be changed to another map, to alter the keyboard control characters. To change it back to this map: ccmap dup 4+ swap ! cc Is also a variable holding cc-forth currently. This too can be changed to any user defined table; create mymap ' char , ' del-in , etc... mymap cc ! to put it back to normal: cc-forth cc ! \ terminal input. 18Feb88pJaexpect Gets a string from the terminal, limits it to length, puts it in the buffer at addr. Performs line editing according to the cc table. Saves the amount of characters in 'span'. tib Leaves address of text input buffer. query Gets more input from the user and place it at tib. Limited to 79 characters, to allow a border around the window. Number of characters is in #tib. \ Block IO. 18Feb88pJa#buffers Number of block buffers in use. b/buf Size of a block buffer. bss_diskbuffers is a block storage section 'buffers Pointer to the first location of the diskbuffers. b/bhead Number of bytes in a buffer header. (Info on buffers)disk-error Holds error number from dos call. >buffers The buffer headers, need 5 of 'm, one for copying. >end Points to one cell past the last buffer header. buffer# Return the address of buffer number n. >update Return the address of the update flag for # 1 buffer read-block write-block Will be defined in Dos area. An buffer header is: cell1 : block number cell2 : fcb address. cell3 : buffer pointer cell4 : update flag. \ block IO. 18Feb88pJa.file Print file name in fcb at the address on the stack. file? Print current output file name. switch Exchange the in-file and file. capacity Return number of blocks in the current file. latest? For increased performance check to see if the block needed is the first one on the list. If it is exit the CALLER namely absent? otherwise return as nothing had happened. absent? Search thru the block/buffer list for a match. If it is found, bring the block packet to the top of the list and return a false flag and the address of the buffer. If the block is not found, return true, indicating it is absent, and no second parameter in that case. \ block IO. 18Feb88pJaupdate Mark the most recently used buffer as modified. discard Mark the most recently used buffer as unread. missing Writes the least recently used buffer to disk if it was modified, and moves all of the buffer pointers up by one, making the first one available for the new block. It then assigns the newly available buffer to the new block. (buffer) Assigns a buffer to the specified block in the given file. No disk read is performed. Leaves the buffer address. buffer Assings a buffer to block n leaves the buffer address. (block) Leaves the address of a buffer containing the given block in the given file. Reads the disk if necessary. block Leaves the address of a buffer containing the given block. Reads the disk if necessary. in-block Like block, but for the in-file. \ block IO. 18Feb88pJaempty-buffers First wipe out the data in the buffers. Next initialize the buffer pointers to point to the right addresses in memory and set all of the update flags to unmodified. save-buffers Write back all of the updated buffers to disk, and mark them as unmodified. Use this whenever you are worried about crashing or losing data. flush Save and empties the buffers. view# Returns address of the view# field for this file. (load) Load the screen number that is on the stack. The input stream is diverted from the terminal to the disk. load Interpret a screen as if it were typed in. \ Number input. 18Feb88pJadigit Returns a flag indicating whether or not the character is a valid digit in the given base. If so, returns converted value and true, otherwise returns char and false. Characters are converted to upper case, before tested. double? Returns non-zero if period was encountered. convert Starting with the unsigned double number ud1 and the string at adr1, convert the string to a number in the current base. Leave result and address of unconvertable digit on stack. \ number input. 18Feb88pJa(number?) Given a string containing at least one digit, convert it to a number. number? Convert the count delimited string at addr to a double number. Number? takes into account a leading minus sign, and stores a pointer to the last delimiter in dpl. String must end in a 0 byte. Leaves a true flag if successful. (number) Convert the string ending in a 0, to a number. number Convert a string to a number. Normally (number). This is the end of the search in the vocabulary array context. \ Number output. 18Feb88pJahold Save the character for numeric output. <# Start numeric conversion. #> Terminate numeric conversion. sign If n is negative insert a minus sign into the string. # Convert a single digit in the current base. #s Convert a number until it is finished. decimal All subsequent numeric IO will be in decimal. octal All subsequent numeric IO will be in octal. hex All subsequent numeric IO will be in hexadecimal. binary All subsequent numeric IO will be in binary. \ number output. 18Feb88pJa(u.) Convert an unsigned 32 bit number to a string. u. Output as an unsigned single number with trailing space. u.r Output as an unsigned single number right justified. (.) Convert a signed 32 bit number to a string. . Output as a signed single number with a trailing space. .r Output as a signed single number right justified. (ud.) Convert an unsigned double number to a string. ud. Output as an unsigned double number with a trailing space.ud.r Output as an unsigned double number right justified. (d.) Convert a signed double number to a string. d. Output as a signed double number with a trailing space. d.r Output as a signed double number right justified. \ Parsing. 18Feb88pJaskip Given the address and length of a string, and a character to look for, run through the string while we continue to find the character. Leave the address of the mismatch and the length of the remaining string. scan Given the address and length of a string, and a character to look for, run through the string until we find the character Leave the address of the match and the length of the remaining string. /string Index into the string by n. Returns addr+n and len-n. place Move the characters at from to to with a preceding byte of len \ parsing. 18Feb88pJa(source) Returns the string to be scanned. This is the default value of the deferred word source. source Return a string from the current input stream. parse-word Scan the input stream until char is encountered. Skip over leading chars. Update >in pointer. Leaves the address and length of the enclosed string. parse Scan the input stream until char is encountered. Update >in pointer. Leaves the address and length of the enclosed string. \ parsing. 18Feb88pJa'word Leaves the same address as word, or here in this system.word Parse the input stream for char and return a count delimited string at here. Note there is always a null following it. .( Type the following string on the terminal. ( Forth comment character, input is skipped until next ). \s Comment to end of the screen. \ Dictionary. 18Feb88pJadone? True if the input stream is exhausted or state doesn't match.traverse Run through a name field in the specified direction. Terminate when a byte whose high order bit is on is detected. Since this is NOT Forth 83 compatible, I have commented it out. \ dictionary. 18Feb88pJan>link Go from name field to link field. l>name Go from link field to name field. body> Go from body to code field. name> Go from name field to code field. link> Go from link field to code field. >body Go from code field to body. >name Go from code field to name field. >link Go from code field to link field. >view Go from code field to view field. view> Go from view field to code field. hash Given a string address and a pointer to a set of vocabulary chains, returns the actual thread. Uses the first character of the string to determine which thread. \ dictionary finding. 18Feb88pJa(find) Does a search of the dictionary based on a pointer to a vocabulary thread and a string. If it finds the string in the chain, it returns a pointer to the CFA field inside the header. This field contains the code field address of the body. If it was an immediate word the flag returned is a 1. If it is non-immediate the flag returned is a -1. If the name was not found, the string address is returned along with a flag of zero. Note that links point to links, and are absolute addresses. \ dictionary finding. 18Feb88pJa#threads The number of seperate linked lists per vocabulary. find Run through the vocabulary list searching for the name whose address is supplied on the stack. If the name is found, return the code field address of the name and a non-zero flag The flag is -1 if the word is non-immediate and 1 if it is immediate. If the name is not found, the string address is returned along with a false flag. ?uppercase Convert the string to upper case if caps is on. defined Look up the next word in the input scream. Return true if it exists, otherwise false. Maybe ignore case. \ Interpreter. 18Feb88pJastacktop Initialized at startup, used for stack checking. ?stack Check for parameter stack underflow or overflow and issue appropriate error message if detected. status Indicate current status of the system. Defaults to cr. interpret The Forth interpret loop. If the next word is defined execute it, otherwise convert it to a number and push it onto the stack. \ Compiler. 18Feb88pJaallot Allocate more space in the dictionary. , Store the tos in the next dictionary cell. w, Same as , but uses 16 bits. c, Same as , but uses 8 bits. align Align the dictionary pointer very important, right Guru?even Makes the top of the stack an even number. compile Compile the following word when this def. executes. immediate Mark the last header as an immediate word. literal Compile the single integer from the stack as a literaldliteral Compile the double integer from the stack as a literal. ascii Compile the next character in the input stream as a literal Ascii character. control Compile the next character in the input stream as a literal Ascii control character. \ Compiler. 18Feb88pJacrash Default routine called by execution vectors. ?missing Tell user the word does not exist. ' Return the code field address of the next word. ['] Like ' only used while compiling. [compile] Force compilation of an immediate word. (") Return the address and length of the inline string. (.") Type the inline string. Skip over it. ," Adds the text upto the next " to the dictionary. The text has a null appended, to ease Amiga calls. ." Compile the string to be typed out later. " Compile the string return pointer later. \ compiler. 18Feb88pJawhere Deferred, used in the editor to set the cursor position. ?error Maybe indicate an error. Change this to alter abort" (?error) Default for ?error. Conditionally execute where and type a message. Where can vector e.g. to the editor. (abort") The runtime code compiled by abort". Uses error, and updates return stack. abort" (s -- ) If the flag is true, issue an error message and quit. abort Stop the system and indicate an error. \ Structures. 18Feb88pJa?condition Simple compile time error checking. Usually adequate.>mark Set up for a forward branch. >resolve Resolve a forward branch. <mark Set up for a backwards branch. <resolve Resolve a backwards branch. ?>mark Set up a forward branch with error checking. ?>resolve Resolve a forward branch with error checking. ?<mark Set up a backward branch with error checking. ?<resolve Resolve a backward branch with error checking. leave Immediate for (leave) same as 83 standard. ?leave idem. \ structures. 18Feb88pJaThese are the compiling words needed to properly compile the Forth Conditional Structures. Each of them is immediate and they must compile their runtime routines along with whatever addresses they need. A modest amount of error checking is done. if you want to rip out the error checking change the ?> and ?< words to > and < words, and all of the 2dup's to dup'sand the 2swap's to swap's. \ Defining words. 18Feb88pJa,view Calculate and compile the view field of the header. "create Use the string at str to make a header, and initialize the code field. First we lay down the view field. Next we lay down an empty link field. We set up 'last' so that it points to our name field, and check for duplicates. Next we link ourselves into the correct thread and delimit the name field bits. Finally lay down the code field. In this system, with a 68000, we also need to align the dictionary while creating this header. create Make a header for the next word in the input stream. \ defining words. 18Feb88pJa!csp Save the current stack level for error checking. ?csp Issue error messge if stack has changed. hide Removes the last definition from the header dictionary. reveal Replaces the last definition in the header dictionary. (;uses) Set the code field to the contents of following cell. assembler Define the vocabulary, to be filled in later. ;uses Similar to the traditional ;code except used when the runtime code has been previously defined. (;code) Set the code field to the address of the following. ;code Used for defining the runtime portion of a defining word in low level code. \ defining words. 18Feb88pJadoes> Specifies the runtime of a defining word in high level Forth. [ Stop compiling and start interpreting. ] The compiling loop. First sets Compile State. Looks up the next word in the input stream and executes it if it is immediate, otherwise compiles it. If the word is not found, converts it to a number single or double, depending on any punctuation. Continues until input stream is empty or state changes. : Defines a colon definition. The definition is hidden until it is completed, or the user desires recursion. ; Terminates a colon definition. Compiles the runtime code to remove a nesting level, and changes state so that compila- tion will terminate. \ defining words. 18Feb88pJarecursive Allow the current definition to call itself. constant A defining word that creates constants. At runtime the value of the constant is placed on the stack. variable A defining word to create variables. At runtime the address of the variable is placed on the stack. defer Defining word for execution vectors. These are initialy set to display an error message. They are initialized by 'is'. vocabulary Define a new Forth vocabulary. Voc-link is a chain in temporal order and used by forget. At runtime a vocabulary changes the search order by setting context. definitions Subsequent definitions will be placed into current. \ defining and redefining words. 18Feb88pJaavoc A variable that holds the old context vocabulary. (is) The runtime for 'is', sets the deferred word following to the address on the stack. is Sets the deferred word following to the address on the stack. This is simpler then F83, since I have no local multitasking. \ Amiga specials, Exec. 19Feb88pJalibrarybase Defining word for Amiga library bases. I link them in a list, so forgetting and byeing can close the libraries automatically and exit clean to Dos. And the Meta version for Meta compiling. callrom Takes the info saved in the word defining a call to a Rom routine. Alters rcall to jump to said routine, with the proper register loaded from the stack. Will return a value if the flag is set. This is common to all libraries. For rcall see the routine after 'next'. Exec A vocabulary to coincide with Exec rom call words. ExecBase Since Exec doesn't have to be closed, it's not linkedexecbased Common routine for exec romcalls, loads the register with the base vector and jumps to the rom calling routine. \ Exec. 19Feb88pJaexeccall Creates a word which will call an Exec library Rom routine. The flag indicates a returned value (true), the off- set is the routine's offset, the mask is a register mask as used in a movem< instruction. The bit assignment is: # 15.....8 7....0 a7.....a0 d7...d0 I did not make it pretty, it can be. E.g. define a few words to set bits in TOS to make it readable. 0 a1 d1 d0 The Meta version of execcall is defined by 'h:'. The Rom calls defined here and on the next few screens, are the minimum required to get this system running. It is clear that more are required, but I leave that up to you. \ Exec. 19Feb88pJaThe Exec Rom routines defined are: OpenLibrary CloseLibrary Get Amiga library vectors. AllocMem FreeMem Get some memory from Amiga's Exec. AllocSignal FreeSignal Signals for tasks synchronization. Findtask Get a vector to a task. AddPort RemPort How tasks communicate. OpenDevice CloseDevice Here to open a console device SendIO DoIO A and synchronous IO to a device. GetMsg Get input from a port/device WaitPort Wait until a signal arrives at a port \ Exec, Execsupport 19Feb88pJaSince this system doesn't require linking to Amiga's routine, the execsupport routines must be provided, again only what is needed for this system. NewList Creates pointers for an Amiga list. setport Not an Exec support function, initializes a port structure. \ Exec, Execsupport 19Feb88pJaCreatePort Creates a port structure for current task with a signal and a signal action. If a name is given the port is made public. DeletePort Deletes port structure created with CreatePort. Releases memory and signal. \ Exec, Execsupport 19Feb88pJaCreateExtIO Allocates memory and initializes the iorequest structure of size byte length. DeleteExtIO Frees up an IO request as allocated by CreateExtIO. DeleteStdIO Allocates and initializes a new I/O request block. CreateStdIO Free memory allocate for I/O request. \ Console device. 19Feb88pJaConWritePort Variables to hold ports and message structure ConReadPort pointers, needed to use a console device. ConWriteMsg ConReadMsg QueRead Starts an asynchronous read request for a byte of data from the console device. It will 'wake' up this task, if one arrives and this task happens to be waiting. (key?) Returns true if a key is available. Checks the port for any messages attached to it, doesn't use WaitPort etc. \ Console device. 19Feb88pJa(key) Return next character from the console. Waits for it, puts this task to sleep, if none available. If one comes through, starts the next asynchronous read on the console. (type) Type the string at the console, also adds number of characters to #out, for cursor positioning. \ Console device. 19Feb88pJaMakeConStuff Sets up the ports and messages to read and write to a console device. OpenConsole Opens a console in the given window. Sets the write message and clones the device in the read message. AND, immediately queues up a read request using the external buffer keybuffer. \ Console device, closing libs. 19Feb88pJaCloseConsole Closes the console device. Deletes the messages and ports associated with the console. close-lib Close the library vector at the cell before the pointer. Set it to null, just in case. close-libs Traverse the library linked list, closing all libraries open. Called by the word bye, just before exiting the system to Amiga Dos. You can call it too if you like to see the Guru. \ Dos library. 19Feb88pJaDos A vocabulary coinciding with Amiga Dos definitions. b/fcb Size of an fcb, file control block. DosBase Amiga library base. Linked in a list. dosbased Fetches the dosbase vector for a call to the Rom routine. doscall Define a word that calls an Amiga Dos library routine ( And the Meta version ) Open-Dos Open the dos library, if not possible, abort. This is a basic library and we can't run without it. Others are optional. Called in the initialization routine. \ Dos library. 19Feb88pJaOpen Close The Dos routines, opening/closing files. Read Write Reading and Writing Seek and Seeking IoErr IoErr for the results. FCB's in this system are virtually identical to F83, except 32 bit of course. If you are familiar with the above, you will haveno problem with these: 0: file-handle 12: 'name 4: size-1, or -1 16: linked-list. 8: view# 20+ name \ Dos 19Feb88pJa!files Set both file pointers to the specified fcb. disk-abort Print error message and file name. ?disk-error Report a disk error if one exists. in-range Makes sure the disk access is within range. Issues error message if it isn't. seek Sets the file position to the block specified in the buffer header. Aborts if a problem occurs. \ Dos 19Feb88pJafile-read Read a block from a file, buffer header knows what and where. The default for deferred word read-block. file-write Write a block to a file, buffer header specifies where. The default for deferred word write-block. file-size Determines the file size by seeking to end. open-file Opens the current file, issues warning if not found. Determines file size and saves it in fcb. Can be called on an open file. \ Dos 19Feb88pJa(close-file) Close the file in the given fcb. !fcb Set up an fcb, link it into a list, for auto closing on exit save the name at the end of the fcb, and set the 'name in the fcb to it. Place a zero at the end for compatability with Amiga and align dictionary. file: Create a word, as a file, allocate an fcb and the filename. Leaves the address of the fcb (NOTE drop is Meta stuff) ?define Define the next word as a file if it doesn't already exists. Leave the address of the file control block. Note: file names can be anything, eg df1:test/file, as long as the length is less then 31, the size of Forth's words. \ Dos 19Feb88pJamore Extend the size of the current file by n blocks. close-file Close the current file. close-files Traverse the linked list of files and close every one of them. Use either before testing new words. create-file Creates a new file containing given number of blocks. Deletes old files with the same name and closes the new one. define Define the word following as a file without opening. open Open the following file and make it the current file. from Open the following file and make it the current input filefiles Prints a list of all defined open files, prints ?? for closed files. \ Intuition library. 19Feb88pJaIntuition Vocabulary coinciding with Amiga library. IntuitionBase The library vector. Linked in a list. Open-Intuition Opens intuition and saves the vector, returns true if opened all right. Close-Intuition Closes the intuition library. intuitionbased Fetches the library vector for a Rom routine call. intuitioncall Defines a word that calls an Intuition Library routine. ( and the Meta counterpart ) \ Intuition library. 19Feb88pJaOpenWindow The only two library routines this system needs CloseWindow from Intuition. \ Forgetting. 19Feb88pJafenced Returns true if address is in the user dictionary range. Only words there may be forgotten. trim Adjusts the 4 linked lists in a vocabulary, so they are all less then a specified value, faddr. tonext Used in forgetting. Returns true if the linkpointer is within the fenced area and larger then the faddr. \ forgetting. 19Feb88pJa(forget) Forgets part of the dicionary. Adjusts library links, closing them if necessary, closes files and adjusts the file linked list before the words referring to files are forgotten. If, for some reason, seperate headers are used, the word changes, but functionally performs identically. Must release headers and code. forget Forget all headers and code before next word. \ Initialization, window specs. 19Feb88pJawindowname Returns pointer to name of the window. Window Returns a pointer to an initialized newwindow structure, used to open the window. \ initialization, commandline, running. 19Feb88pJaok Load the current open file, by loading block 1. (bye) Low level return to Dos routine, return code for diagnostics.commandline A special routine, it puts the remainder of the command line in the terminal input buffer 'tib', and sets #tib. It then checks to see if the first word is a number and uses this number (in hex) as the size of the user dictionary, and allocates it, saving the size and pointer in the two cells after dp. run Allows multiline colon compilation. \ initialization 19Feb88pJaquit The main loop in Forth. Gets more input from the terminal and interprets it. Responds with ok if healthy. warm High level warm start routine. boot The very first high level word executed on cold start. make this something else if you want. Defaults to start. Returns a true flag if all is ok. cold High level cold start routine. Calls boot and checks the commandline for any input, then starts the quit loop. \ initialization 19Feb88pJastart Default for boot, must return t/f flag, true for ok. Opens Dos, Opens Intuition opens a window and a console. Cleans up if that fails at any point. bye Exit to Amiga dos. But first closes the console device, the window. Then closes all the open files, and the open libraries. Next returns the user dictionary to the system memory pool. \ initialization, low level. 19Feb88pJaThe low level start routines. Set the warm start vector to point to here. Jumps to high level warm word. Set cold start vector to point to here. calculate how big the stack space is and set stacktop save the string information from the commandline and set the stack sp0 address Get the execbase and set it. Get the address of the return stack, add the size set rp0 to it, set a3 to point to next, so next ) jmp is fast. set ip to point to high level cold and jump to it. \ Resident Tools 19Feb88pJadepth returns the number of items on the parameter stack. .s Display the contents of the parameter stack non destructively. (.id) Primitive word to display the id of a word. Given the address and the length, moves the word to stdbuffer and pads it with underlines. Returns the address and length of the string to type. \ resident tools, and loading screens 23Feb88pJa.id Display a Forth word pointed to by tos. c/l Constants for editing screen and block size. Character l/scr per line and lines per screen. \ Comment word. Ignore the rest of the line. (s Used for stack comments. Behaves just like ( ? Displays the contents of an address. ?enough (s n -- ) Issue an error message if too few parameters on the stack. thru (s n1 n2 -- ) Load a bunch of screens. +thru (s n1 n2 -- ) Load a bunch of screens ralative to the current. --> Load the next screen. views make the next file viewnumber n. \ Initialize, resolve forward references. 19Feb88pJaWe must resolve the forward references that were required in the Meta Compiler. These are all run time code which wasn't known at the time the meta compiling version was defined. These are all either defining words or special case immediate words. These are forward references that were generated in the course of compiling the system source. Make sure these are updated if you change the system. ( or guru time is here for sure ) \ Initialize variables. 19Feb88pJa Initialize the current vocabulary to point to forth Initialize the context vocabulary to point to forth initialize the vocabulary link \ Initialize deferred words 19Feb88pJaIn order to run, we must initialize all of the deferred words that were defined to something meaningful. Deferred words are also known as execution vectors.
