\ AKernel.blk 23Sep88pJa A4th A Public Domain Forth system for Amiga's based on Laxen & Perry's F83 This Forth system is Public Domain. You may freely distribute copy and use it, for any legal purposes. I cannot be held responsible for any errors and/or omissions, I do not warrant this system. I bear no responsibility for any use or abuse, with or without intend. Peter J. Appelman. \ Set up target image buffer and relocation buffer. 03Jun88pJaonly 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 24Sep88pJa 32 bss: bss_keybuffer 256 bss: bss_tibbuffer 1024 bss: bss_rpstack : ]] ] ; : [[ [compile] [ ; forth immediate meta forward: definitions forward: [ \ Load kernel. 25Sep88pJa 4 114 thru [forth] warning on cr .( Unresolved references: ) cr meta .unresolved [forth] cr .( statistics: ) cr .( host dictionary usage: ) here dp0 @ - 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, next, calling ROM. 25Sep88pJaassembler label start-t 0 #) jmp <rel ( cold ) 0 #) jmp <rel ( warm ) here there #users-t 4* dup allot erase label @next ip )+ w move w )+ a0 move a0 ) jmp forth assembler definitions meta h: next >next ) jmp ; label rcallflag 0 w, hex label rcall 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 \ Forth first word, hi level word calls from code. 25Jun88pJahere-t dup 100 + current-t ! dup 116 + there <current> ! vocabulary forth forth definitions dup 108 + -relocate dup 124 + there @ dup last @ name> >body 8+ ! off 0 over 2+ !-t dup 2+ swap 24 + dup relocate !-t in-meta 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. 25Sep88pJaassembler 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 label douser-variable w ) w move >next w adda docreate bra 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 25Sep88pJaassembler hilevel meta constant hilevel <rel code @next (s -- addr ) >next sp -) move next end-code 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 label douser-defer w ) w move >next w adda dodefer bra 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. 24Sep88pJacode 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 u4/ (s n -- u/4 ) sp ) d0 move 2 # d0 lsr 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 \ Task variables. 25Sep88pJauser definitions variable dp \ dictionary pointer 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 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 defer type \ normally (type), for standard output defer key \ normally (key), for standard input defer key? \ normally (key?) defer cr \ normally crlf \ system variables. 25Sep88pJameta definitions variable sp0 \ initial parameter stack variable rp0 \ initial return stack variable dp0 \ start of usable dictionary. variable dpsize \ size of usable dictionary. variable prior \ used for dictionary searches variable state \ compiling or interpreting (0) variable warning \ if on give a warning if duplicate. 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. 01Oct88pJavariable 'tib \ address of terminal input buffer. variable width \ width of name field 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 file-link \ linked list of declared files. variable mem-link \ linked list of intuition remember keys. \ 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. 24Sep88pJacode 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; : here (s -- addr ) dp @ ; : pad (s -- addr ) here 128 + ; \ 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. 24Sep88pJa : emit (s c -- ) sp@ 3 + 1 type drop ; : crlf (s -- ) 10 emit #out off 1 #line +! ; : space (s -- ) bl emit ; : m-emits (s n char -- ) over 1 256 between if >r pad 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 \ Multi Meta stuff. 25Jun88pJa( \s ) variable <current> variable <context> here there #vocs 4* dup allot erase variable <target> -1 <target> !-t : target? (s addr -- fl ) <target> @ = ; : <definitions> <context> @ <current> ! ; : <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 dup if r> drop leave else dup then else drop end? on ['] noop 1 then ; \ dictionary finding. 25Jun88pJa4 constant #threads : find (s addr -- addr false | cfa flag ) dup c@ if prior off false #vocs 0 do drop context i 4* + @ dup target? if drop <find> else dup then ( ... ) 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 ; defer defined : (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. defer where defer ?error : (?error) (s addr len f -- ) if >r >r sp0 @ sp! r> r> space type space blk @ if >in @ blk @ where then 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. 25Jun88pJa: ,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 @ target? if <current> @ else current @ then ( ... ) 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 words, task variables. 28Sep88pJavariable #user #users-t constant #users vocabulary user <also> user definitions : allot (s n -- ) negate #user +! ; : create #users #user @ negate u4/ 1- < abort" Out of task space" [ forth ] create [ user ] #user @ , ;uses douser-variable , <rel : variable (s -- ) create 4 allot ; : defer (s -- ) variable ;uses douser-defer , <rel <empty> forth definitions meta in-meta \ defining and redefining words. 25Sep88pJavariable avoc : >is (s cfa -- data-addr ) dup @ dup [ [assembler] douser-variable meta ] literal [ <rel ] = swap dup [ [assembler] douser-defer meta ] literal [ <rel ] = swap drop or if >body @ @next + else >body then ; : (is) (s cfa -- ) r@ @ >is ! r> 4+ >r ; : is (s cfa -- ) state @ if compile (is) else ' >is ! then ; immediate \ Amiga specials, Romcalls. 23Sep88pJa 0 constant >Exec 4 constant >Dos 8 constant >Intuition 12 constant >Graphics variable libbase# 4 libbase# !-t 20 constant #libbases create libbases here there #libbases 4* dup allot erase [forth] assembler label callrom hex word w )+ rcallmask 2- @next - a3 d) move w )+ rcalloffset 2- @next - a3 d) move 0 d1 moveq w )+ d0 move 0< if FF d0 andi -1 d1 moveq then d1 rcallflag @next - a3 d) move long libbases >pcd) a0 lea i.w 0 d0 a0 di) a0 move i.l rcall @next - a3 d) jmp end-code decimal meta \ Romcalls. 04May88pJacode rmask (s 0 .. .. -- mask ) 0 d0 moveq begin sp )+ d1 move 0<> while byte 207 d1 cmpi < if 8 d1 ori then 15 d1 andi long d0 d1 bset repeat d0 sp -) move next end-code h: rmask 0 >r begin ?dup while dup 207 > if 1 else 256 then swap 7 and 0 ?do 2* loop r> or >r repeat r> ; : ^ (s n -- 'n ) 32768 or ; h: ^ 32768 or ; : (r (s -- base 0 ) base @ hex 0 ; h: (r [[ [forth] ]] base @ hex 0 ; in-meta : r) (s base 0 .. .. .. -- ) rmask swap base ! create w, w, w, ;uses callrom , <rel in-meta h: r) rmask swap [[ [forth] ]] base ! target-create [[ [assembler] callrom ]] literal ,-tr w,-t w,-t w,-t [[ in-meta ]] ; \ Exec. 03Jun88pJavocabulary Exec <also> Exec definitions >Exec dup ^ -552 (r A1 D0 r) OpenLibrary (s name vers -- lib ) dup -414 (r A1 r) CloseLibrary (s lib -- ) dup ^ -198 (r D1 D0 r) AllocMem (s flags size -- adr ) dup -210 (r A1 D0 r) FreeMem (s adr size -- ) dup ^ -330 (r D0 r) AllocSignal (s sig# -- 'sig# ) dup -336 (r D0 r) FreeSignal (s sig# -- ) dup ^ -294 (r A1 r) FindTask (s name -- task ) dup -354 (r A1 r) AddPort (s port -- ) dup -360 (r A1 r) RemPort (s port -- ) ^ -444 (r A1 A0 D1 D0 r) OpenDevice (s ioReq devname flgs unit# -- f | 0=ok ) \ Exec, Execsupport 29Apr88pJa>Exec dup -450 (r A1 r) CloseDevice (s ioReq -- ) dup -462 (r A1 r) SendIO (s ioReq -- ) dup ^ -372 (r A0 r) GetMsg (s port -- msg | 0 ) dup ^ -384 (r A0 r) WaitPort (s port -- msg ) ^ -456 (r A1 r) 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 03Jun88pJa: 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 ; <also> 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. 25Sep88pJacode (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 sp -) 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 drop #out +! ; \ 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. 29Apr88pJa: CloseConsole (s -- ) ConWriteMsg @ CloseDevice ConWriteMsg @ DeleteStdIO ConReadMsg @ DeleteStdIO ConWritePort @ DeletePort ConReadPort @ DeletePort ; : close-lib (s adr -- ) dup @ ?dup if CloseLibrary off else drop then ; : close-libs (s -- ) libbases 4+ #libbases 1- 4* bounds ?do i close-lib 4 +loop ; \ Dos library. 03Jun88pJavocabulary Dos Dos definitions 20 constant b/fcb : Open-Dos (s -- ) " dos.library" drop 0 OpenLibrary dup 0= if 200 (bye) then libbases >Dos + ! ; \ Dos library. 29Apr88pJa>Dos dup ^ -30 (r D2 D1 r) Open (s mode name -- handle ) dup -36 (r D1 r) Close (s handle -- ) dup ^ -42 (r D3 D2 D1 r) Read (s len buffer handle -- 'len ) dup ^ -48 (r D3 D2 D1 r) Write (s len buffer handle -- 'len ) dup ^ -66 (r D3 D2 D1 r) Seek (s mode pos handle -- 'pos ) ^ -132 (r r) 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 03Jun88pJa: (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 ; <also> forth definitions \ Dos 03Jun88pJa: 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 -- ) ?define 1006 over 12+ @ Open ?dup if over ! !files more close-file else 2drop then ; : define (s -- ) ?define drop ; : open (s -- ) ?define !files open-file ; : from (s -- ) ?define in-file ! open-file ; : files (s -- ) file-link begin @ ?dup while dup 16- .file repeat ; \ Intuition library. 01Oct88pJavocabulary Intuition Intuition definitions : Open-Intuition (s -- f | t=ok ) " intuition.library" drop 0 OpenLibrary ?dup if libbases >Intuition + ! true else false then ; >Intuition dup ^ -204 (r A0 r) OpenWindow (s newwindow -- window ) dup -72 (r A0 r) CloseWindow (s window -- ) dup ^ -396 (r A0 D1 D0 r) AllocRemember (s key f size -- addr ) -408 (r A0 D0 r) FreeRemember (s key f -- ) <also> forth definitions : close-mem (s -- ) mem-link begin @ ?dup while dup 4- true FreeRemember repeat ; \ Graphics vocabulary 28Sep88pJavocabulary Graphics Graphics definitions : Open-Graphics " graphics.library" drop 0 OpenLibrary ?dup 0= abort" No Graphics???" libbases >Graphics + ! ; forth definitions \ Some amiga help words. 28Sep88pJacode bset (s bit# addr -- ) sp )+ a0 move sp )+ d0 move a0 ) d0 bset next end-code code breset (s bit# addr -- ) sp )+ a0 move sp )+ d0 move a0 ) d0 bclr next end-code code btoggle (s bit# addr -- ) sp )+ a0 move sp )+ d0 move a0 ) d0 bchg next end-code code bset? (s bit# addr -- f ) sp )+ a0 move sp ) d0 move a0 ) d0 btst yes bne no bra end-code code << (s n count -- n' ) sp )+ d0 move sp ) d1 move d0 d1 lsl d1 sp ) move next end-code code >> (s n count -- n' ) sp )+ d0 move sp ) d1 move d0 d1 lsr d1 sp ) move next end-code \ Random utility. 01Oct88pJacreate randomseed hex F08A5033 ,-t E09A0E87 ,-t decimal code random (s n -- 0..n-1 ) sp )+ d4 move 0= if 1 d4 moveq then randomseed >pcd) a0 lea a0 ) d0 move 4 a0 d) d2 move 0 d1 moveq 31 d3 moveq d3 do 1 # d1 lsl 1 # d2 lsl u< if d0 d1 add then loop d1 neg d1 a0 ) move d1 swap 0 d0 moveq word d1 d0 move long d4 d0 divu word d0 clr long d0 swap d0 sp -) move next end-code code tinit (s -- ) sp )+ d0 move sp )+ ip move sp )+ d1 move 2 # d1 lsl sp d1 add d1 a0 move a0 ) a1 move d0 a0 ) move #users 4* 8+ a1 d) >next lea 44 >next d) a0 lea a0 -4 >next d) move a1 ) a1 move 4 a1 d) rp move 8 a1 d) rp adda next end-code \ "c" type strings. 28Sep88pJacode a"count (s addr -- n ) sp )+ a0 move -1 d0 moveq d0 do byte a0 )+ tst dbeq long d0 neg d0 sp -) move next end-code : (a") (s -- addr ) r> dup a"count over + even >r ; : astring (s char -- addr ) parse-word tuck here swap cmove here swap allot 0 c, align ; : a" state @ if compile (a") ascii " astring drop else ascii " astring then ; immediate \ Forgetting. 24Sep88pJavariable fence : fenced (s addr -- fl ) fence @ dp0 @ max dp0 @ dpsize @ + within ; : 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. 01Oct88pJa: (forget) (s view-addr -- ) dup fenced not abort" Below fence" file-link @ begin tonext while dup 16- (close-file) @ repeat file-link ! mem-link @ begin tonext while dup 4- true FreeRemember @ repeat mem-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. 01Oct88pJa: 4thwname (s -- addr ) " A4th V1.5.0 (01Oct88)." drop ; variable 4thw 640 w,-t 200 w,-t -1 w,-t 0 ,-t hex 21027 decimal ,-t 0 ,-t 0 ,-t ' 4thwname >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. 24Sep88pJa: ok 1 load ; : commandline (s -- ) sp0 @ dup 4+ @ swap @ dup #tib ! tib swap move bl tib #tib @ 1- + c! hex bl word number? if drop dpsize ! else 2drop >in off then decimal 2 dpsize @ AllocMem dup 0= if ." Unable to allocate dictionary. Press return " key drop dp0 off dpsize off bye then dup dp ! dp0 ! ; \ initialization, high level. 29Apr88pJa: run (s -- ) state @ if ] state @ not if interpret then else interpret then ; : quit (s -- ) [ bss_tibbuffer ] literal [ patchbss ] 'tib ! blk off [compile] [ begin rp0 @ rp! status query run state @ not if ." ok" then again ; defer boot : warm (s -- ) true abort" Warm Start" ; : cold (s -- ) boot if commandline interpret quit else 100 (bye) then ; \ initialization 01Oct88pJa: start (s -- f | t=ok ) Open-Dos Open-Intuition if 4thw OpenWindow else 0 exit then dup if dup 4thw ! OpenConsole else close-libs 0 exit then not if 4thw @ CloseWindow close-libs 0 exit then empty-buffers true ; code (bye) (s return-code -- ) sp ) d0 move sp0 >pcd) sp move 8 sp addq rts end-code : bye (s -- ) CloseConsole 4thw @ CloseWindow close-files close-mem close-libs dp0 @ dpsize @ FreeMem 0 (bye) ; \ initialization, low level. 25Sep88pJa[assembler] here start-t 8+ !-t ' warm >body >pcd) ip lea next here start-t 2+ !-t @next >pcd) a3 lea 4 sp d) a2 lea a2 ) a2 suba ' stacktop >body >pcd) a1 lea a2 a1 ) move 512 a2 d) a2 lea a2 -4 a3 d) move a0 sp -) move d0 sp -) move sp0 >pcd) a0 lea sp a0 ) move libbases >pcd) a0 lea 4 w#) a0 ) move bss_rpstack #) rp lea patchbss 1024 rp d) rp lea rp0 >pcd) a0 lea rp a0 ) move ' cold >body >pcd) ip lea next end-code in-meta \ Resident Tools 24Sep88pJa: 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 pad -- pad len ) sp )+ a0 move 4 sp d) a1 move a0 4 sp d) move sp ) d0 move 0<> if d0 ?do byte a1 )+ a0 )+ move long loop: dbmi byte 127 -1 a0 d) andi ascii _ d1 moveq word 1 d0 addq byte d0 ?do d1 a0 )+ move loop: dbra long then next end-code \ resident tools, and loading screens 24Sep88pJa: .id (s nfa -- ) count 31 and pad (.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 -- ) ?define 8+ ! ; \ Initialize task variables. 25Sep88pJahere-t [assembler] @next meta #user-t @ 4+ + dp-t ! ' crlf ,-tr ( cr ) ' (key?) ,-tr ( key? ) ' (key) ,-tr ( key ) ' (type) ,-tr ( type ) 0 ,-t ( in-file ) 0 ,-t ( file ) 0 ,-t ( hld ) 10 ,-t ( base ) 0 ,-t ( offset ) 0 ,-t ( #line ) 0 ,-t ( #out ) 0 ,-t ( dp ) dp-t ! \ Initialize, resolve forward references. 25Sep88pJa' (.") resolves <(.")> ' (") resolves <(")> ' (abort") resolves <(abort")> ' (;uses) resolves <(;uses)> ' (is) resolves <(is)> ' (;code) resolves <(;code)> [assembler] docreate meta resolves <variable> [assembler] douser-variable meta resolves <user-variable> [assembler] douser-defer meta resolves <user-defer> ' quit resolves quit ' even resolves even ' ?missing resolves ?missing ' !files resolves !files ' run resolves run ' [ resolves [ ' definitions resolves definitions ' (bye) resolves (bye) ' bye resolves bye \ Initialize variables. 25Sep88pJa 65536 dpsize !-t true warning !-t ' forth >body current dup relocate !-t ' forth >body context dup relocate !-t bss_tibbuffer 'tib tuck !-t (patchbss) 31 width !-t voc-link-t @ voc-link dup relocate !-t #user-t @ #user !-t \ Initialize deferred words 25Sep88pJa' (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 ' (defined) is defined \ Kernel for 68000 Amiga. 23Sep88pJa 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'. For a larger usable space: run Forth 18000 open Utilities.blk 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 24Sep88pJabss_keybuffer the address of 32 bytes of keybuffer. 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, next, calling ROM. 25Sep88pJastart-t allows the jumps to be patched later. The cold start entry vector. The warm start entry vector. User variables are before next routine. Next is the base pointerThe next interpreter, @next is it's address. next is a macro, which compiles a jump to next interpreter. rcallflag 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 \ Forth first word, hi level word calls from code. 25Jun88pJamust 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! 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. 25Sep88pJanest 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. douser-variable Runtime code for user variables. User var are offsets from 'next'. (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 25Sep88pJahilevel The address of hilevel calls from code words. @next Returns address of next in this task. 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. douser-defer Runtime code for user deferred words. 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. 24Sep88pJa2* Double the number on the stack. 2/ Shift n right once. u2/ Logical shift right. 4* Multiply top of the stack by 4. u4/ Unsigned divide 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 \ Task variables. 25Sep88pJaTask local variables and deferreds are local to each task. Notable differences with L&P are the absence of sp0, rp0, tos, entry, link. They are used for local round robin multitasking. This system uses Amiga-Exec. See next screen for variables not local to each task. Some restrictions using tasks are noted elsewhere. The deferred input and output words allow tasks using output to their own file/windows. The main system uses a console attached to an Intuition window. It cannot be used from a background taskThe task will have to open/create it's own. \ system variables. 25Sep88pJa sp0 Empty stack for main task. Used in aborting. rp0 Initial return stack for main task. dp0 Start of usable dictionary for main task. dpsize Size of the main task dictionary. prior Points to the last vocabulary that was searched. state True if compiling. warning Gives 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. 01Oct88pJa'tib Points to characters entered by user. 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. file-link Points to the most recently defined file. task-link Points to the most recently defined remember key. 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. 24Sep88pJamove 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 80 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. 24Sep88pJa 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. \ target dictionary handling. 02Jun88pJa<current> The current target vocabulary for Meta compiling <context> The context for target dictionary. <target> Holds the address of the target vocabulary target? (s addr -- f ) Returns a flag indicating if the address is the target flag vocabulary. <definitions> identical to definitions for <context> <find> (s addr -- addr false | cfa flag ) Identical in operation to find. But works on the <context> dictionary. This is an extra level, used mainly in meta com- piling. Can be used for other purposes. This word is called from find only. It leaves the caller, i.e. find, by a "r> drop" and a "leave". You are warned. \ dictionary finding. 03Jun88pJa#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. Will nest if @context=<target> to <context>. ?uppercase Convert the string to upper case if caps is on. defined I made this deferred in this version to allow patching(defined) Look up the next word in the input stream. Return true if it exists, otherwise false. Maybe ignore case. The default for defined \ 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. 03Jun88pJa,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. The header is linked into <current> if current=target. 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 words, task variables. 28Sep88pJa#user Index of next available task variable. #users Maximum # task variables, set throught meta compiling. user Seperate the user defining words from the rest. allot Allocate space in the task user area. create Define a word that returns the address of the next available user cell. variable Define a task type variable. defer Define a task local execution vector. \ defining and redefining words. 25Sep88pJaavoc A variable that holds the old context vocabulary. >is Convert a code field to a data field. Task variables and deferred words are calculated. (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. \ Amiga specials, Romcalls. 12Jun88pJa>Exec, >Dos and >Intuition are indices for the array 'libbases'.libbase# Holds the index (4*) for the next >... constant #libbases the size of the libbases array. libbases the array of #libbases, 20 should do. 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'. The index for the libbase is with the flag. e.g. a value returned - 1xxx xxxx nnnn nnnn no value - 0xxx xxxx nnnn nnnn \ Romcalls. 04May88pJarmask Creates a mask to be used with a movem<. On the stack it expects hex numbers representing registers ( A0 D3 etc ) It stops popping when a zero is found on the stack. The meta version is not in code, speed is not to important, at that point. ^ sets the flag in the word to indicate a value is returned. (r starts register encoding. Changes the base temporarily. r) Expects the parameters for the Rom call. Resets the base and compiles the next word as an Amiga Rom Call. The Meta versions of these words must access the host base variable. The [[ [forth] ]] sequence accomplishes it. \ Exec. 29Apr88pJaThe 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 ( Note that this way of calling ROM is almost as fast as before, with savings in memory; clearer to understand and able to decompile. ) \ 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. 29Apr88pJaCloseConsole Closes the console device. Deletes the messages and ports associated with the console. close-lib Close the library vector at the cell. Set it to null, just in case. close-libs Traverse the libbases array, closing all open libraries. Except Exec, which doesn't have to be closed. 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. 29Apr88pJaDos A vocabulary coinciding with Amiga Dos definitions. b/fcb Size of an fcb, file control block. ( Again, have deleted DosBase. If needed: libbases >Dos + will get it: infomation hiding ) Open-Dos Open the dos library, if not possible, returns to CLI. This is a basic library and we can't run without it. Others libraries 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. 01Oct88pJaIntuition Vocabulary coinciding with Amiga library. Open-Intuition Opens intuition and saves the vector, returns true if opened all right. OpenWindow The only library routines this system needs CloseWindow from Intuition. AllocRemember FreeRemember close-mem Along the line of 'close-files', to de-allocate all memory allocated under remember from intuition. \ Graphics vocabulary 28Sep88pJaGraphics The graphics vocabulary defined. Open-Graphics Opens the graphics library, aborts if not present. (?) The graphics library is not opened by the startup procedure. It is not required to run this system, but is included as it is one of the basic libraries required. \ Some amiga help words. 28Sep88pJabset - breset - btoggle - bset? Routines which operate on a bit in the byte pointed to. Bit# can be larger than 7; it is used modulo 8. << and >> Are shift operators, using the number on the top of the stack. To make programs look similar to text book examples. \ Random utility. 01Oct88pJarandomseed Seeds the random number generator. To make things more interesting store the current time in it. random (s n -- 0..n-1 ) returns a random number between 0 and n-1. Uses randomseed to create a unique sequence. By changing randomseed you generate different sequences. tinit startup code for a tasks, it is here so assembler does not have to be present. Fetch the return routine, the ip and the param.count, adjust it. Point to the upper of the stack, get remember.link addr and stick return routine there. Point to next, set task local dp to after next and rcall routines. Traverse the remember link and get the rp-size and rp. Finally start by jumping to next. \ "c" type strings. 28Sep88pJaTo handle strings, compatible with Amiga, the following can be used. In most situations the regular forth word " (quote) with an additional drop could be used. I have included these anyway. a"count Return the length of a null terminated string at address. (a") runtime of an amiga compatible string. Returns the address of the string. astring Parse the input until char is found, store the string at here and return the address. String is null terminated. a" Depending on the state, compile the amiga string into the word, when executed it will return the address of the string. When interpreting, store the string at here and return a pointer to it. \ Forgetting. 24Sep88pJafence Don't forget what is below the address in this variable.fenced 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. 01Oct88pJa(forget) Forgets part of the dictionary. Closes files, frees up memory, adjust the linked lists, of words about to be forgotten. forget Forget all headers and code before next word. \ Initialization, window specs. 24Jun88pJa4thwname Returns pointer to name of the window. 4thw Returns a pointer to an initialized newwindow structure, used to open the window. And holds the window pointer after it is opened. \ initialization, commandline, running. 24Sep88pJaok Load the current open file, by loading block 1. 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 dpsize and dp0 as well as setting dp to it. \ initialization 29Apr88pJarun Allows multiline colon compilation. quit The main loop in Forth. Gets more input from the terminal and interprets it. Responds with ok if healthy. 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. warm High level warm start routine. cold High level cold start routine. Calls boot and checks the commandline for any input, then starts the quit loop. \ initialization 01Oct88pJastart 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) Low level return to Dos routine, return code for diagnostics. codes: 100 = failure opening Intuition/window/console 200 = failure opening Dos bye Exit to Amiga dos. But first closes the console device, the window. Then closes all the open files, releases memory allocated under intuition, and the open libraries. Next returns the user dictionary to the system memory pool. \ initialization, low level. 25Sep88pJaThe 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. Set a3 to point to next routine. calculate how big the stack space is and set stacktop Set dp to within the stack for commandline processing. 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 ip to point to high level cold and jump to it. \ Resident Tools 24Sep88pJadepth 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 pad 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 task variables. 25Sep88pJaThis is accomplished by temporarily setting the target dictionary pointer to the 'user' area. Then storing the defaultsin the area. After that the target dictionary pointer is re- stored. Note that the variables are in reverse order in memory. Also the #user-t ( and #user ) actually points to the cell before thelast task variable declared. The task variables are located directly ahead of the 'next' routine. That makes the variable a negative offset from @next, which is used as a base. A seperate 'UP' is not required. Each task gets its own 'next'. \ 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. 25Sep88pJa all variables are defaulted to null, or zero, unless modified Default user usable dictionary. Warnings are on. Init current to point to forth. Init context to point to forth also. Init 'tib to the bss_tibbuffer. Full width of word names. Init the vocabulary link. ( No files declared, the file-link is zero. ) Set next task variable index. \ 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.
