rob@idacom.uucp (Rob Chapman) (02/23/90)
( bot-Forth kernel adapted for 68k: Dec 6, 1989 Rob Chapman )
HEX
( ==== Target status ==== )
NO VARIABLE target ( target definition flag )
: TARGET ( -- ) YES target ! ?CR CR ." TARGET definitions: " CR ;
: META ( -- ) NO target ! ?CR CR ." META definitions: " CR ;
: TARGET? ( -- flag ) target @ ;
( ==== Target memory management ==== )
( data stack | return stack | dp | latest | words... )
400 CONSTANT origin# ( address of start of kernel )
DATA tspace 3000 ALLOT ( 12 kbytes target dict. space )
tspace 200 + CONSTANT tdp ( target dictionary pointer )
tspace 202 + CONSTANT tlatest ( address of latest word )
origin# 204 + tdp ! 0 tlatest ! ( initial values )
: T>HOST ( target address -- host address ) origin# - tspace + ;
: HOST>T ( host address -- target address ) tspace - origin# + ;
: THERE ( -- target here ) tdp @ ;
: TALLOT ( n -- ) tdp +! THERE origin# - 2F00 >
IF ." target space overflow " ABORT THEN ;
: TC! ( n \ taddr -- ) T>HOST C! ;
: T! ( n \ taddr -- ) T>HOST ! ;
: TC@ ( target address -- value ) T>HOST C@ ;
: T@ ( target address -- value ) T>HOST @ ;
: T+! ( n \ taddr -- ) DUP >R T@ + R> T! ;
: TC, ( char -- ) THERE TC! 1 TALLOT ;
: T, ( word -- ) THERE T! 2 TALLOT ;
: EVEN ( -- ) THERE 1 AND IF 0 TC, ENDIF ;
( ==== Dictionary searching ==== Header structure: | link | name | code ... | )
0 VARIABLE meta-start ( contains nfa of start of meta compilers )
: TL>CODE ( lfa -- cfa ) T>HOST 2 + COUNT 1F AND + DUP 1 AND + HOST>T ;
: TC>LINK ( code -- link ) T>HOST C>LINK HOST>T ;
: COMPARE ( string \ name -- flag ) 1F SAME? ;
: TFIND ( string -- cfa \ yes | -- string \ no ) tlatest @
BEGIN DUP WHILE
2DUP T>HOST 2 + COMPARE IF NIP TL>CODE YES EXIT ENDIF T@
REPEAT ;
: META-FIND ( string -- cfa \ yes | -- string \ no ) latest meta-start @ >R
BEGIN @ DUP R - WHILE
2DUP 2 + COMPARE IF SWAP R> 2DROP L>CODE YES EXIT ENDIF
REPEAT R> 2DROP NO ;
META LATEST meta-start ! ( record beginning of meta compilers )
( ==== Mini assembler for 68k ==== )
( ==== Definitions for assembler ==== )
: AHERE ( -- a ) TARGET? IF THERE ELSE HERE ENDIF ;
: A! ( n \ a -- ) TARGET? IF T! ELSE ! ENDIF ;
: A, ( word -- ) TARGET? IF T, ELSE , ENDIF ;
: A+! ( n \ a -- ) TARGET? IF T+! ELSE +! ENDIF ;
( ==== Register and mode definitions ==== )
: ** ( n \ m -- n ) FOR 2* NEXT ;
: MODE ( mode -- ) <BUILDS 8000 OR 3 ** DUP 3 ** OR ,
DOES ( reg -- ) DUP 9 ** OR R> @ OR CONSTANT IMMEDIATE ;
0 MODE Dn 1 MODE An 2 MODE An@ 3 MODE An@+
0 Dn alu 0 An ptr 0 An@ ptr@ 0 An@+ ptr@+
5 Dn index 5 An page 5 An@ page@ 5 An@+ page@+
6 Dn next 6 An sp 6 An@ sp@ 6 An@+ sp@+
7 Dn top 7 An rp 7 An@ rp@ 7 An@+ rp@+
4 MODE An-@ 5 MODE dAn@ 6 MODE +An@ 7 MODE Other
0 An-@ ptr-@ 5 dAn@ dpage@ 5 +An@ +page@ 0 Other lit@
6 An-@ sp-@ 2 Other dpc@
7 An-@ rp-@ 4 Other lit
8 base !
( ==== Masks to extract mode and register information ==== )
: UPPER ( n -- n ) 7700 AND ;
: LOWER ( n -- n ) 0077 AND ;
: MODES ( n -- n ) 0770 AND ;
: REGS ( n -- n ) 7007 AND ;
HEX
( ==== Math ==== )
: extb ( r -- ) REGS LOWER 4880 OR A, ; IMMEDIATE
: extw ( r -- ) REGS LOWER 48C0 OR A, ; IMMEDIATE
: not ( r -- ) LOWER 4640 OR A, ; IMMEDIATE
: neg ( r -- ) LOWER 4440 OR A, ; IMMEDIATE
: ALU ( n -- ) <BUILDS , IMMEDIATE
DOES> ( r \ r \ a -- ) @ >R DUP MODES ( not data?)
IF rp LITERAL OVER XOR MODES ( not areg? )
IF SWAP 100 ELSE R 80 AND ( long?) IF 140 ELSE 80 THEN ENDIF R> OR >R
ENDIF REGS UPPER SWAP LOWER OR R> OR A, ;
8040 ALU or C040 ALU and
8000 ALU orb C000 ALU andb
9040 ALU sub D040 ALU add
9080 ALU subl
: eor ( r \ r -- ) LOWER SWAP REGS UPPER OR B140 OR A, ; IMMEDIATE
: addql ( n \ r -- ) LOWER SWAP 7 AND 9 ** OR 5080 OR A, ; IMMEDIATE
: subq ( n \ r -- ) LOWER SWAP 7 AND 9 ** OR 5140 OR A, ; IMMEDIATE
: 1SHIFT ( n -- ) <BUILDS 1 9 ** OR , IMMEDIATE
DOES ( r -- ) REGS LOWER R> @ OR A, ;
E340 1SHIFT asl E240 1SHIFT asr E248 1SHIFT lsr
: mulu ( s \ d -- ) REGS UPPER SWAP LOWER OR C0C0 OR A, ; IMMEDIATE
: divu ( s \ d -- ) REGS UPPER SWAP LOWER OR 80C0 OR A, ; IMMEDIATE
( ==== Comparison ==== )
000 CONSTANT always
500 CONSTANT carry
600 CONSTANT notzero
700 CONSTANT zero
B00 CONSTANT minus
C00 CONSTANT ge
D00 CONSTANT lt
: difb ( r \ r -- ) DUP MODES ( addr? ) ?ERROR B000
SWAP REGS UPPER OR SWAP LOWER OR A, ; IMMEDIATE
: dif ( r \ r -- ) DUP MODES ( addr? ) IF B0C0 ELSE B040 ENDIF
SWAP REGS UPPER OR SWAP LOWER OR A, ; IMMEDIATE
: scc ( r \ c -- ) SWAP LOWER OR 50C0 OR A, ; IMMEDIATE
: test ( r -- ) LOWER 4A40 OR A, ; IMMEDIATE
: testb ( r -- ) LOWER 4A00 OR A, ; IMMEDIATE
: invertz ( -- ) 0A3C A, 4 A, ; IMMEDIATE ( lit ccr eorib [ 40 , ] )
( ==== Data movement ==== )
: swap ( dn -- ) REGS LOWER 4840 OR A, ; IMMEDIATE
: moveb ( r \ r -- ) UPPER SWAP LOWER OR 1000 OR A, ; IMMEDIATE
: move ( r \ r -- ) UPPER SWAP LOWER OR 3000 OR A, ; IMMEDIATE
: movel ( r \ r -- ) UPPER SWAP LOWER OR 2000 OR A, ; IMMEDIATE
: moveq ( n \ r -- ) REGS UPPER 7000 OR SWAP FF AND OR A, ; IMMEDIATE
: exg ( r \ r -- ) 2DUP XOR MODES ( mixed address and data modes? )
IF OVER MODES ( addr? ) IF SWAP ( must be: exg dn,an) ENDIF C188
ELSE DUP MODES C140 OR ENDIF
>R LOWER SWAP UPPER OR REGS R> OR A, ; IMMEDIATE
( ==== Page relative data movement ==== )
: rd, ( r \ d -- ) FF AND SWAP C ** OR A, ; IMMEDIATE
: r, ( r -- ) 0 \ rd, ; IMMEDIATE
: cfetch ( r \ r -- ) \ +page@ SWAP \ moveb \ r, ; IMMEDIATE
: cstore ( r \ r -- ) >R \ +page@ \ moveb R> \ r, ; IMMEDIATE
: fetch ( r \ r -- ) \ +page@ SWAP \ move \ r, ; IMMEDIATE
: store ( r \ r -- ) >R \ +page@ \ move R> \ r, ; IMMEDIATE
: pea ( r -- ) \ +page@ LOWER 4840 OR A, \ r, ; IMMEDIATE
: leal ( r \ r -- ) REGS UPPER SWAP LOWER OR 41C0 OR A, ; IMMEDIATE
: lea ( r \ r -- ) \ +page@ SWAP \ leal \ r, ; IMMEDIATE
( ==== Program counter ==== )
: nop ( -- ) 4E71 A, ; IMMEDIATE
: jump ( r -- ) LOWER 4EC0 OR A, ; IMMEDIATE
: jsr ( r -- ) LOWER 4E80 OR A, ; IMMEDIATE
: bsr ( disp -- ) FF AND 6100 OR A, ; IMMEDIATE
: rts ( -- ) 4E75 A, ; IMMEDIATE
: bcc ( cc -- ) 6000 OR A, ;
: ?long ( n -- n ) DUP ABS 7F U> IF ?CR ." long " ENDIF ;
: bcc> ( cc -- a ) THERE SWAP bcc ;
: <bcc ( a \ cc -- ) SWAP THERE 2 + - ?long FF AND OR bcc ;
: begin ( -- a ) THERE ;
: <br ( a -- ) always <bcc ;
: <0br ( a -- ) zero <bcc ;
: br> ( -- a ) always bcc> ;
: if ( -- a ) zero bcc> ;
: endif ( a -- ) THERE OVER 2 + - ?long FF AND SWAP A+! ;
: <dbr ( a \ dr -- ) REGS LOWER 51C8 OR A, THERE - A, ;
( ==== Tools ==== )
: PUSH ( -- n ) R> @+ >R ;
: >alu ( n -- n ) PUSH top alu move A, ;
: alu> ( n -- m ) PUSH alu top move A, ;
( ==== Automatic page register setting by using pc ==== )
: RAM ( -- ) PUSH dpc@ page leal T, THERE NEGATE T, ; SMUDGE
( ==== Meta Threader ==== )
0 VARIABLE last ( address of last compiled instruction )
: T' ( -- cfa ) BL WORD HERE TFIND 0= ?ERROR \ LITERAL ; IMMEDIATE
: TMEASURE ( -- ) tlatest @ THERE OVER TL>CODE - 2/ SWAP 2 - T+! ;
: TCALLED ( -- ) 80 tlatest @ 2 - T>HOST +BITS ;
: TCOMPILE ( cfa -- ) T>HOST DUP C>LINK 2 - @ DUP 5 U< ( # to inline)
IF FOR @+ SWAP T, NEXT DROP
ELSE DROP HOST>T DUP THERE 2 + - DUP ABS 80 U<
IF \ bsr DROP TCALLED ELSE DROP PUSH dpage@ jsr T, T, THEN
ENDIF ;
: TINSERT ( string -- ) TFIND 0= ?ERROR TCOMPILE ;
: TLITERAL ( n -- ) " DUP" TINSERT DUP ABS 80 U<
IF \ top \ moveq ELSE PUSH lit top move T, T, ENDIF ;
: ] ( -- ) TARGET? 0= IF ] EXIT ENDIF 0 last !
BEGIN BEGIN BL WORD HERE DUP C@ WHILE META-FIND
IF EXECUTE 0
ELSE THERE SWAP TFIND
IF TCOMPILE ELSE NUMBER TLITERAL ENDIF
ENDIF last !
REPEAT DROP INPUT-LINE 0 in ! AGAIN ;
( ==== Target word creators ==== )
: .NAME ( lfa -- ) 2 + COUNT 1F AND out @ OVER + 2 + 4E >
IF ?CR ENDIF TYPE 2 SPACES ;
: THEADER ( -- ) 0 T, THERE tlatest @ T, tlatest !
BL WORD HERE COUNT DUP>R 80 OR TC, THERE T>HOST R CMOVE R> TALLOT EVEN
tlatest @ T>HOST .NAME ;
: CONSTANT ( n -- ) TARGET?
IF THEADER TLITERAL TMEASURE PUSH rts T,
ELSE CONSTANT ENDIF ;
: VARIABLE ( n -- ) TARGET?
IF THEADER " DUP" TINSERT
PUSH lit top move T, THERE 0 T, TMEASURE PUSH rts T, THERE SWAP T! T,
ELSE VARIABLE ENDIF ;
: QUEUE ( #words -- ) TARGET? 0= IF QUEUE EXIT ENDIF
0 VARIABLE -2 TALLOT THERE 6 + DUP T, T, 1 + 2* DUP THERE + T, TALLOT ;
( Queues: | >insert | >remove | >end | queue... | )
: V, ( -- ) \ T' DUP TC>LINK 2 - T@ 2* 2 + + T, ; ( compile var address)
: TEXIT ( -- ) last @ ?DUP
IF T@ DUP FF00 AND 6100 =
IF DROP 1 last @ T>HOST -BITS TCALLED EXIT ENDIF
FFC0 AND 4E80 = IF 40 last @ T>HOST 1 + +BITS TCALLED EXIT ENDIF
ENDIF PUSH rts T, ;
: : ( -- ) TARGET? IF THEADER ] ELSE \ : ENDIF ;
: ; ( -- ) TMEASURE TEXIT R>DROP ; SMUDGE
: [ ( -- ) R>DROP ; SMUDGE
: \ ( -- ) BL WORD HERE TFIND IF TCOMPILE ELSE ABORT ENDIF ; SMUDGE
: EXIT ( -- ) TEXIT ; SMUDGE
: ' ( -- ) \ T' TLITERAL ; SMUDGE
: ( ( -- ) \ ( ; SMUDGE
: IMMEDIATE ( -- )
TARGET? IF 40 tlatest @ 2 + T>HOST +BITS ELSE IMMEDIATE ENDIF ;
TARGET
( ==== Stacks ==== )
: SP! ( ? -- ) lit alu move [ origin# 100 + T, ] alu sp lea ;
: RP! ( -- ) lit alu move [ origin# 1FC + T, ] alu rp lea ;
: DEPTH ( -- n ) sp alu movel page alu subl next sp-@ move top next movel
lit top move [ origin# 100 + T, ] alu top sub top asr ;
( ==== Stack Operators ==== )
: SWAP ( a \ b -- b \ a ) top next exg ;
: NUP ( a \ b -- a \ a \ b ) next sp-@ move ;
: TUCK ( a \ b -- b \ a \ b ) top sp-@ move ;
: DUP ( n -- n \ n ) NUP top next movel ;
: OVER ( a \ b -- a \ b \ a ) SWAP TUCK ;
: NIP ( a \ b -- b ) sp@+ next move ;
: DROP ( n -- ) next top movel NIP ;
: 2DUP ( a \ b -- a \ b \ a \ b ) NUP TUCK ;
: 2DROP ( a \ b -- ) sp@+ top move NIP ;
: ROT ( a \ b \ c -- b \ c \ a )
sp@ alu move next sp@ move top next movel alu top movel ;
META
( ==== Control structures ==== )
: IF ( -- addr ) >alu T' DROP TCOMPILE PUSH alu test T, if ; SMUDGE
: ENDIF ( addr -- ) endif ; SMUDGE
: ELSE ( addr -- addr ) br> SWAP endif ; SMUDGE
: THEN ( addr -- ) endif ; SMUDGE
: BEGIN ( -- addr ) begin ; SMUDGE
: UNTIL ( addr -- ) >alu T' DROP TCOMPILE PUSH alu test T, <0br ; SMUDGE
: AGAIN ( addr -- ) <br ; SMUDGE
( BEGIN ... top test if DROP ... <br endif DROP )
( BEGIN ... WHILE ... REPEAT )
: WHILE ( -- addr ) >alu if T' DROP TCOMPILE ; SMUDGE
: REPEAT ( addr \ addr -- ) SWAP <br endif T' DROP TCOMPILE ; SMUDGE
: FOR ( -- a ) PUSH index rp-@ move T, PUSH top index move T,
T' DROP TCOMPILE br> ; SMUDGE
: NEXT ( a -- ) DUP endif
2 + index LITERAL <dbr PUSH rp@+ index move A, ; SMUDGE
TARGET
( ==== Return stack primitives ==== )
: DUP>R ( n -- n ) top pea ;
: R>DROP ( -- ) [ 4 ] rp addql ;
: >R ( n -- ) DUP>R DROP ;
: R> ( -- n ) DUP rp@+ top movel page top sub ;
: R ( -- n ) DUP rp@ top movel page top sub ;
: EXECUTE ( cfa -- ) >alu DROP +page@ jsr alu r, ;
( ==== Arithmetic operators ==== )
: + ( a \ b -- c ) next top add NIP ;
: - ( a \ b -- c ) top next sub DROP ;
: AND ( a \ b -- c ) next top and NIP ;
: OR ( a \ b -- c ) next top or NIP ;
: XOR ( a \ b -- c ) next top eor NIP ;
: 2* ( n -- m ) top asl ;
: 2/ ( n -- m ) top asr ;
: U2/ ( n -- n ) top lsr ;
: NEGATE ( n -- -n ) top neg ;
: NOT ( n -- m ) top not ;
META
( ==== Optimizers ==== )
: SEQ ( n -- ) <BUILDS , ( # of bytes to compare )
DOES> ( seq -- f ) NO >R last @ ?DUP
IF T>HOST SWAP @+ SWAP R> SWAP FOR >R DIFFER? R> OR NEXT 0= NIP NIP
ELSE DROP R> ENDIF ;
6 SEQ LIT? next sp-@ move top next movel lit top move
5 SEQ SLIT? next sp-@ move top next movel 0 top moveq
: UNLIT? ( -- [n] \ f ) SLIT? IF THERE 1 - TC@ YES -6 TALLOT EXIT ENDIF
LIT? IF THERE 2 - T@ YES -8 TALLOT EXIT ENDIF NO ;
: + ( -- ) UNLIT?
IF DUP 9 U< IF \ top \ addql ELSE PUSH lit top add T, T, ENDIF
ELSE T' + TCOMPILE ENDIF ; SMUDGE
: - ( -- ) UNLIT?
IF DUP 9 U< IF \ top \ subq ELSE PUSH lit top sub T, T, ENDIF
ELSE T' - TCOMPILE ENDIF ; SMUDGE
: AND ( -- ) UNLIT?
IF PUSH lit top and T, T, ELSE T' AND TCOMPILE ENDIF ; SMUDGE
TARGET
( ==== Memory primitives ==== )
: @ ( a -- n ) top top fetch ;
: ! ( n \ a -- ) next top store 2DROP ;
: C@ ( a -- n ) top top cfetch FF AND ;
: C! ( n \ a -- ) next top cstore 2DROP ;
META
( ==== Memory optimizers ==== )
: @ ( -- ) UNLIT?
IF T' DUP TCOMPILE PUSH dpage@ top move T, T,
ELSE T' @ TCOMPILE ENDIF ; SMUDGE
: ! ( -- ) UNLIT?
IF PUSH top dpage@ move T, T, T' DROP ELSE T' ! ENDIF TCOMPILE ; SMUDGE
: C@ ( -- ) UNLIT?
IF T' DUP TCOMPILE 0 \ top \ moveq PUSH dpage@ top moveb T, T,
ELSE T' C@ TCOMPILE ENDIF ; SMUDGE
: C! ( -- ) UNLIT?
IF PUSH top dpage@ moveb T, T, T' DROP ELSE T' C! ENDIF TCOMPILE ; SMUDGE
TARGET
( ==== Incrementing/Decrementing memory operators ==== )
: @+ ( a -- n \ a+ ) NUP top next fetch 2 + ;
: @- ( a -- n \ a- ) NUP top next fetch 2 - ;
: C@+ ( a -- c \ a+ ) NUP [ 0 ] next moveq top next cfetch 1 + ;
: C@- ( a -- c \ a- ) NUP [ 0 ] next moveq top next cfetch 1 - ;
: !+ ( n \ a -- a+ ) next top store NIP 2 + ;
: !- ( n \ a -- a- ) next top store NIP 2 - ;
: C!+ ( c \ a -- a+ ) next top cstore NIP 1 + ;
: C!- ( c \ a -- a- ) next top cstore NIP 1 - ;
( ==== signed multiply and unsigned divide ==== )
: /MOD ( n \ m -- rem \ quot ) next swap next next eor next swap
top next divu next top movel next swap ;
: / ( m \ n -- quot ) next swap next next eor next swap
top next divu DROP ;
: MOD ( n \ m -- rem ) / top swap ;
: * ( n \ m -- nm* ) next top mulu NIP ;
( ==== Comparison ==== )
0 CONSTANT NO
-1 CONSTANT YES
: 0= ( n -- f ) top test top zero scc top extb ;
: 0< ( n -- f ) top test top minus scc top extb ;
: = ( n \ m -- flag ) top next dif top zero scc top extb NIP ;
: < ( n \ m -- flag ) top next dif top lt scc top extb NIP ;
: > ( n \ m -- flag ) next top dif top lt scc top extb NIP ;
: U< ( n \ m -- flag ) top next dif top carry scc top extb NIP ;
: U> ( n \ m -- flag ) next top dif top carry scc top extb NIP ;
: ABS ( n -- n ) top test ge bcc> top neg endif ;
: MAX ( n \ m -- p ) top next dif lt bcc> DROP EXIT endif NIP ;
: MIN ( n \ m -- p ) next top dif lt bcc> DROP EXIT endif NIP ;
: ?DUP ( n -- [n] \ n ) top test if DUP endif ;
( ==== Memory Manipulation ==== )
20 CONSTANT BL
: COUNT ( addr -- addr' \ count ) C@+ SWAP ;
: CMOVE ( s \ d \ count -- ) next ptr lea NIP page alu movel next page lea
FOR page@+ ptr@+ moveb NEXT alu page movel DROP ;
: <CMOVE ( src \ dest \ count -- ) >R SWAP R 1 - + SWAP R 1 - +
R> FOR >R C@- SWAP R> C!- NEXT 2DROP ;
: MOVE ( src \ dest \ count -- ) FOR >R @+ SWAP R> !+ NEXT 2DROP ;
: FILL ( addr \ count \ char -- )
>alu DROP FOR alu next cstore [ 1 ] next addql NEXT 2DROP ;
: ERASE ( addr \ count -- ) 0 FILL ;
: BLANKS ( addr \ count -- ) BL FILL ;
( ==== Memory Management ==== )
origin# 200 + CONSTANT dp ( dictionary pointer )
: +! ( n \ addr -- ) next +page@ add top r, 2DROP ;
: HERE ( -- addr ) dp @ ;
: ALLOT ( n -- ) dp +! ;
: , ( n -- ) HERE ! 2 ALLOT ;
: C, ( n -- ) HERE C! 1 ALLOT ;
: EVEN ( -- ) HERE 1 AND IF 0 C, ENDIF ;
( ==== Header Status Bits ==== )
origin# 202 + CONSTANT latest
: +BITS ( bits \ addr -- ) next +page@ orb top r, 2DROP ;
: -BITS ( bits \ addr -- ) next not next +page@ andb top r, 2DROP ;
: LATEST ( -- nfa ) latest @ ;
: IMMEDIATE ( -- ) 40 LATEST 2 + +BITS ;
: SMUDGE ( -- ) 20 LATEST 2 + +BITS ;
: RECURSE ( -- ) 20 LATEST 2 + -BITS ; IMMEDIATE
( ==== State ==== )
0 VARIABLE compile ( set to 80 if compiling; immediate words are C0 )
: ] ( -- ) 80 compile ! ;
: [ ( -- ) 0 compile ! ; IMMEDIATE
( ==== Queues ===== )
: >Q ( n \ queue -- ) top alu fetch
4 + [ 2 ] alu subq top alu dif
if alu +page@ move top [ -4 ] rd,
ELSE +page@ +page@ move top r, top [ -4 ] rd, ENDIF
next +page@ move alu [ 2 ] rd, 2DROP ;
: Q> ( queue -- n ) +page@ alu move top [ 2 ] rd,
4 + [ 2 ] alu subq top alu dif
if alu +page@ move top [ -2 ] rd,
ELSE +page@ +page@ move top r, top [ -2 ] rd, ENDIF
+page@ top move alu [ 2 ] rd, ;
: Q ( queue -- n ) +page@ top move top [ 2 ] rd, @ ;
: 0Q ( queue -- ) +page@ +page@ move top r, top [ 2 ] rd, DROP ;
: Q? ( queue -- n )
@+ @+ >R SWAP - DUP 0< IF R @ R> - + 2/ EXIT ENDIF R>DROP 2/ ;
( ==== BARON Tasker ==== )
80 QUEUE peasantq ( maximum of 80H peasants )
: >BARON ( cfa -- ) peasantq >Q ;
: BARON ( -- ) peasantq Q> EXECUTE ;
: KILL ( cfa -- ) peasantq DUP Q?
FOR DUP>R Q> 2DUP - IF R >Q ELSE DROP ENDIF R> NEXT 2DROP ;
: RUN ( cfa -- ) DUP KILL >BARON ;
( ==== Forth character I/O ==== )
100 QUEUE keyq ( 256; enough for one string )
100 QUEUE emitq ( 256; enough for one string )
0 VARIABLE out ( characters output since last cr )
: KEY? ( -- flag ) keyq Q? ;
: KEY ( -- char ) BEGIN KEY? 0= WHILE BARON REPEAT keyq Q> ;
: ?WAIT ( -- ) BEGIN emitq Q? 100 = WHILE BARON REPEAT ;
: EMIT ( char -- ) >R ?WAIT out @
R A - IF R 8 = IF 1 - ELSE R D = IF DROP 0 ELSE 1 +
ENDIF ENDIF ENDIF out ! R> emitq >Q ;
: CR ( -- ) D EMIT A EMIT ;
: SPACE ( -- ) BL EMIT ;
: SPACES ( n -- ) 0 MAX FOR SPACE NEXT ;
: TYPE ( addr \ count -- ) FOR C@+ SWAP EMIT NEXT DROP ;
( ==== Numerical Output ==== )
10 VARIABLE base
: HEX ( -- ) 10 base ! ;
: BIN ( -- ) 2 base ! ;
: DECIMAL ( -- ) A base ! ;
: PAD ( -- addr ) HERE 50 + ;
: HOLD ( char -- ) -1 PAD +! PAD @ C! ;
: <# ( -- ) PAD DUP ! ;
: #> ( n -- addr \ count ) DROP PAD @ PAD OVER - ;
: SIGN ( m \ n -- n ) SWAP 0< IF 2D HOLD ENDIF ;
: # ( n -- n ) base @ /MOD SWAP 9 OVER < IF 7 + ENDIF 30 + HOLD ;
: #S ( n -- n ) BEGIN # DUP 0= UNTIL ;
: .R ( n \ m -- ) >R <# base @ A = IF DUP ABS #S SIGN ELSE #S ENDIF #>
R> OVER - SPACES TYPE ;
: . ( n -- ) 0 .R SPACE ;
( ==== Parser ==== )
0 VARIABLE tib 52 TALLOT ( tib points to terminal input buffer )
0 VARIABLE in ( index into TIB )
: INPUT ( -- addr ) DUP dpage@ top move V, tib dpage@ top add V, in ;
: +IN ( addr -- ) dpage@ ptr move V, tib dpage@ ptr add V, in ptr top sub
lit alu move V, in top +page@ add alu r, DROP ;
: SKIP ( char -- ) INPUT top ptr lea
begin ptr@+ alu moveb if next alu difb invertz endif notzero <bcc
page ptr subl [ 1 ] ptr subq ptr top move NIP +IN ;
: SCAN ( char -- ) INPUT top ptr lea
begin ptr@+ alu moveb if next alu difb endif notzero <bcc
page ptr subl alu testb notzero bcc> [ 1 ] ptr subq endif
ptr top move NIP +IN ;
: PARSE ( char -- ) INPUT top ptr lea HERE NIP
begin ptr@+ alu moveb
if 1 + alu top cstore next alu difb endif
notzero <bcc
alu testb if 1 - ELSE [ 1 ] ptr subq endif
HERE - HERE C! page ptr subl ptr top move +IN ;
: WORD ( char -- ) DUP SKIP PARSE ;
: ( ( -- ) 29 SCAN ; IMMEDIATE
( ==== Word compiler ==== )
: PUSH ( -- n ) DUP lit top move ;
: C>LINK ( code -- link ) BEGIN 2 - DUP C@ 80 AND UNTIL 2 - ;
: L>CODE ( link -- code ) 2 + C@+ SWAP 1F AND + EVEN ;
: COMPILE ( cfa -- ) DUP C>LINK 2 - @ DUP 6 U< ( # to inline)
IF FOR @+ SWAP , NEXT DROP ELSE DROP \ PUSH dpage@ jsr , , ENDIF ;
( ==== Strings ==== )
: QUOTE ( -- ) 22 PARSE HERE C@ 1 + ALLOT EVEN ;
: (") ( -- addr ) R DUP C@ 2 + -2 AND R> + >R ;
: " ( -- [addr] ) compile @
IF ' (") COMPILE ELSE HERE ENDIF QUOTE ; IMMEDIATE
: (.") ( -- ) R COUNT DUP 2 + -2 AND R> + >R TYPE ;
: ." ( -- ) compile @ IF ' (.") COMPILE QUOTE
ELSE 22 PARSE HERE COUNT TYPE ENDIF ; IMMEDIATE
META
: ." ( -- ) T' (.") TCOMPILE 22 WORD HERE
COUNT >R R TC, THERE T>HOST R CMOVE R> TALLOT EVEN ; SMUDGE
TARGET
( ==== Errors ==== )
: ABORT ( -- ) RP! ;
: ERROR ( -- ) HERE COUNT TYPE ." <- eh?" ABORT ;
: ?ERROR ( flag -- ) IF ERROR ENDIF ;
( ==== Number Conversion ==== )
: DIGIT ( char -- n \ flag )
30 - DUP 9 > IF 7 - DUP A < OR ENDIF DUP base @ U< ;
: NUMBER ( string -- n ) COUNT >R COUNT 2D = TUCK
IF R> 1 - >R ELSE 1 - ENDIF 0 SWAP
R> FOR C@+ >R DIGIT NOT ?ERROR SWAP base @ * + R> NEXT DROP
SWAP IF NEGATE ENDIF ;
( ==== Dictionary Searching ==== )
: C>LINK ( code -- link ) BEGIN 2 - DUP C@ 80 AND UNTIL 2 - ;
: L>CODE ( link -- code ) 2 + C@+ SWAP 1F AND + DUP 1 AND + ;
: DIFFER? ( a \ a -- a+ \ a+ \ f )
+page@ alu moveb next r, [ 1 ] next addql DUP
+page@ top moveb next r, [ 1 ] next addql alu top eor top extb ;
: BIT-DIFFER? ( a \ a \ mask -- a+ \ a+ \ f ) >R DIFFER? R> AND ;
: SAME? ( string \ name \ mask -- flag ) BIT-DIFFER? IF 2DROP NO EXIT ENDIF
OVER 1 - C@
FOR DIFFER? IF 2DROP NO rp@+ index move EXIT ENDIF NEXT 2DROP YES ;
: COMPARE ( string \ name -- flag ) 3F SAME? ;
: SEARCH? ( string \ >list -- lfa \ yes | -- string \ no )
BEGIN @ ?DUP WHILE 2DUP 2 + COMPARE IF NIP YES EXIT ENDIF REPEAT NO ;
: FIND? ( -- cfa \ status | -- string \ no ) BL WORD
HERE latest SEARCH? DUP IF DROP DUP L>CODE SWAP 2 + C@ E0 AND ENDIF ;
: ?FIND ( -- addr ) FIND? 0= ?ERROR ;
( ==== Interpreter ==== )
: \ ( -- ) ?FIND COMPILE ; IMMEDIATE
: LITERAL ( n -- ) compile @ IF ' PUSH COMPILE , ENDIF ; IMMEDIATE
: ' ( -- pfa ) ?FIND \ LITERAL ; IMMEDIATE
: INTERPRET ( -- )
BEGIN
BEGIN FIND? ?DUP WHILE
compile @ = IF COMPILE ELSE EXECUTE ENDIF
REPEAT
DUP C@ WHILE NUMBER \ LITERAL REPEAT DROP ;
( ==== Key collector ==== )
: ?CR ( -- ) dpage@ test V, out if CR endif ;
: PROMPT ( -- ) ?CR compile @ IF ." : " ELSE ." 68k: " ENDIF ;
: PREPARE ( key -- key ) DUP 1A >
IF out @ 4E < IF DUP INPUT C!+ +IN ELSE DROP 7 ENDIF EXIT ENDIF
DUP D = IF DROP 0 0 INPUT C! EXIT ENDIF
DUP 8 = IF in @ ?DUP IF 1 - in ! ELSE DROP 7 ENDIF EXIT ENDIF
DROP 7 ;
: COLLECTOR ( -- )
KEY? IF KEY PREPARE ?DUP
IF EMIT ELSE SPACE 0 in ! INTERPRET 0 in ! PROMPT ENDIF
ENDIF ' COLLECTOR >BARON ;
( ==== SIO access on page 1 ==== )
: SIO ( -- ) lit page movel [ 1 T, tspace T, ( insert real sio addr here) ] ;
: SIO@ ( a -- c ) SIO C@ RAM ;
: SIO! ( c \ a -- ) SIO C! RAM ;
( ==== SIO chip: DUART SCN2681 with a 3.6864mhz crystal ==== )
: RESET-SIO ( -- ) SIO ( set page reg. to base address of sio chip )
10 DUP 02 C! 0A C! ( command register: reset MR pointer )
20 DUP 02 C! 0A C! ( reset receiver )
30 DUP 02 C! 0A C! ( reset transmitter )
40 DUP 02 C! 0A C! ( reset error status )
50 DUP 02 C! 0A C! ( reset break status )
13 DUP 00 C! 08 C! ( mode register 1: 8bits no parity )
07 DUP 00 C! 08 C! ( mode register 2: 1 stop bit )
BB DUP 01 C! 09 C! ( 9600 baud )
05 DUP 02 C! 0A C! ( enable transmitter/receiver )
24 05 C! ( interrupt mask register: channel breaks; channel b input )
FF 0F C! ( reset output port bits ) RAM ;
( ==== SIO porta primitives ==== )
: RX? ( -- flag ) 01 SIO@ 1 AND ;
: TX? ( -- flag ) 01 SIO@ 8 AND ;
: TX ( char -- ) 03 SIO! ;
: RX ( -- char ) 03 SIO@ ;
( ==== Sio port servicing ==== )
0 VARIABLE sio-in ( points to queue used to hold input )
0 VARIABLE sio-out ( points to queue used to hold output )
: POLL-SIO ( -- ) RX? IF RX sio-in @ >Q ENDIF
sio-out @ Q? IF TX? IF sio-out @ Q> TX THEN ENDIF ' POLL-SIO >BARON ;
( ==== Control loop ==== )
: INIT ( -- ) keyq 0Q 0 in ! tib 2 + tib ! 0 INPUT C! RESET-SIO
keyq sio-in ! emitq sio-out ! ' POLL-SIO RUN ' COLLECTOR RUN ;
: QUIT ( -- ) RAM SP! RP! R>DROP ' QUIT >R ( for error return ) \ [
INIT CR PROMPT BEGIN BARON AGAIN ;
( ==== Conditionals ==== )
: 0BRANCH ( n -- ) >alu DROP alu test zero bcc ;
: BRANCH ( -- ) always bcc ;
: IF ( -- addr ) ' 0BRANCH COMPILE HERE 0 , ; IMMEDIATE
: ENDIF ( addr -- ) HERE OVER - SWAP ! ; IMMEDIATE
: ELSE ( addr -- addr ) ' BRANCH COMPILE HERE 0 , SWAP \ ENDIF ; IMMEDIATE
: THEN ( addr -- ) \ ENDIF ; IMMEDIATE
: BEGIN ( -- addr ) HERE ; IMMEDIATE
: UNTIL ( addr -- ) ' 0BRANCH COMPILE HERE - , ; IMMEDIATE
: AGAIN ( addr -- ) ' BRANCH COMPILE HERE - , ; IMMEDIATE
: WHILE ( -- addr ) \ IF ; IMMEDIATE
: REPEAT ( addr \ addr -- ) SWAP \ AGAIN \ ENDIF ; IMMEDIATE
: (FOR) ( n -- ) index rp-@ move top index move DROP BRANCH ;
: (NEXT) ( -- ) [ 0 ] index <dbr rp@+ index move ;
: FOR ( -- a ) ' (FOR) COMPILE HERE 0 , ; IMMEDIATE
: NEXT ( a -- ) DUP \ ENDIF 2 +
' (NEXT) COMPILE HERE 4 - DUP>R - R> ! ; IMMEDIATE
( ==== Defining Words ==== )
: CALLED ( -- ) 80 latest @ 2 - +BITS ;
: MEASURE ( -- ) latest @ HERE OVER L>CODE - 2/ SWAP 2 - ! ;
: ?UNIQUE ( -- ) FIND? IF HERE COUNT TYPE ." is not unique. "
ELSE DUP C@ 0= ?ERROR ENDIF DROP ;
: HEADER ( -- ) EVEN 0 , HERE latest @ , ?UNIQUE latest !
HERE C@ DUP 80 OR C, ALLOT EVEN ;
: FORGET ( -- ) ?FIND C>LINK DUP @ latest ! HERE - 2 - ALLOT ;
: EXIT ( -- ) rts ;
: : ( -- ) HEADER SMUDGE \ ] ;
: ; ( -- ) MEASURE ' EXIT COMPILE \ [ \ RECURSE ; IMMEDIATE
: DATA ( -- ) \ : ' PUSH COMPILE HERE 0 , \ ; HERE SWAP ! ;
: VARIABLE ( n -- ) DATA , ;
: CONSTANT ( n -- ) \ : \ LITERAL \ ; ;
: <BUILDS ( -- ) HEADER CALLED ' ERROR COMPILE ;
: DOES ( -- ) R> LATEST L>CODE 2 + ! ;
: DOES> ( -- addr ) ' DOES COMPILE ' R> COMPILE ; IMMEDIATE
: QUEUE ( #words -- ) ( Queues: | >insert | >remove | >end | queue... | )
DATA HERE 6 + DUP , , 1 + 2* DUP HERE + , ALLOT ;
( ==== File Loader: FF emitted to request a line of input ==== )
: INPUT-LINE ( -- ) FF EMIT ( signal for input )
0 in ! INPUT BEGIN KEY DUP D - WHILE SWAP C!+ REPEAT DROP 0 SWAP C! ;
: LD ( -- ) BEGIN INPUT-LINE INTERPRET AGAIN ;
( ==== Version ==== )
: VERSION ( -- ) ." 68k-Forth V.14" ; ( derived from 68k-Forth V.13 )
( ==== End of kernel ==== )
CR THERE origin# - .D ." bytes." META
QUIT