\

\

\

\

\

\

\

\

\

\

\

\

only forth also definitions hex

wordlist constant meta.1

wordlist constant target.1

wordlist constant assembler.1

wordlist constant target.only.1

0 constant opt.eof-bye ( 1 = bye on EOF, 0 = non-blocking )

1 constant opt.support-add ( support optional add instr. )

: (order) ( u wid*n n -- wid*n u n )

dup if

1- swap >r recurse over r@ xor if

1+ r> -rot exit then r> drop then ;

: -order ( wid -- ) get-order (order) nip set-order ;

: +order ( wid -- )

dup >r -order get-order r> swap 1+ set-order ;

meta.1 +order also definitions

2 constant =cell ( size of a cell in the target )

1000 constant size

1000 constant =end ( 8192 bytes, leaving half for DP-BRAM )

40 constant =stksz \ size of stacks

80 constant =buf

0008 constant =bksp \ backspace

000A constant =lf \ line feed

000D constant =cr \ carriage return

007F constant =del \ delete key

create tflash size cells here over erase allot

variable tvarp ( variable pointer )

variable tdp ( dictionary pointer )

variable tlast ( last defined word pointer )

0 tlast !

=end 240 - 2* tvarp ! ( set area where variables are stored )

variable vms 0 vms !

variable pc 1 pc !

$B8 constant polynomial \ $84 uses two taps, period 217/$D9

$FF constant period

: :m meta.1 +order also definitions : ;

: ;m postpone ; ; immediate

:m .h base @ >r hex u. r> base ! ;m

:m .d base @ >r decimal u. r> base ! ;m

:m lfsr ( state -- state )

dup 1 and ( mask off feed back )

swap 1 rshift swap ( state /= 2 )

if polynomial xor then ;m ( xor in poly if feedback set )

:m pc++ pc @ lfsr pc ! 1 vms +! ;m

:m ordering 1 period for dup u. lfsr next drop cr ;m

:m vmused

." poly> $" polynomial u. cr

." period> $" period u. cr

." vm used> " vms @ dup .d

." cells / " 2* .d ." bytes" cr ;m

.( Polynomial sequence: ) cr

ordering cr

:m there tdp @ ;m ( dictionary pointer location )

:m tvere tvarp @ ;m ( variable location )

:m tc! tflash + c! ;m

:m tc@ tflash + c@ ;m

:m t! over ff and over tc! swap 8 rshift swap 1+ tc! ;m

:m t@ dup tc@ swap 1+ tc@ 8 lshift or ;m

:m talign there 1 and tdp +! ;m

:m tc, there tc! 1 tdp +! ;m

:m t, there t! =cell tdp +! ;m

:m v, tvere t! =cell negate tvarp +! ;m

:m $literal [char] " word

count dup tc, 0 ?do count tc, loop drop talign ;m

:m tallot tdp +! ;m

:m tdrop drop ;m

:m thead

talign

there tlast @ t, tlast !

parse-word dup tc, 0 ?do count tc, loop drop talign ;m

:m hex# ( u -- addr len )

0 <# base @ >r hex =lf hold # # # # r> base ! #> ;m

:m c# ( u -- )

0 <# base @ >r hex

=lf hold

[char] , hold

# # # #

[char] x hold

[char] 0 hold

r> base ! #> ;m

:m save-hex ( <name> -- )

parse-word w/o create-file throw

there 0 do i t@ over >r hex# r> write-file throw =cell +loop

close-file throw ;m

:m save-header ( <name> -- )

parse-word w/o create-file throw

there 0 do i t@ over >r c# r> write-file throw =cell +loop

close-file throw ;m

:m save-target ( <name> -- )

parse-word w/o create-file throw >r

tflash there r@ write-file throw r> close-file ;m

:m twords ( -- : print out words in target dictionary )

cr tlast @

begin

dup tflash + =cell + count 1f and type space t@

?dup 0= until ;m

:m .stat ( -- : print out meta-compiler staats )

0 if

." target: " target.1 +order words cr cr

." target-only: " target.only.1 +order words cr cr

." assembler: " assembler.1 +order words cr cr

." meta: " meta.1 +order words cr cr

then

." used> " there dup ." $" .h ." / " .d cr ;m

:m .end only forth also definitions decimal ;m

:m atlast tlast @ ;m

:m tvar get-current >r meta.1 set-current

create r> set-current tvere , v, does> @ ;m

:m tconst get-current >r meta.1 set-current

create r> set-current there , t, does> @ ;m

:m label: get-current >r meta.1 set-current

create r> set-current pc @ 2* , does> @ ;m

:m tdown =cell negate and ;m

:m tnfa =cell + ;m ( pwd -- nfa : move to name field address )

:m tcfa tnfa dup c@ $1F and + =cell + tdown ;m ( pwd -- cfa )

:m compile-only tlast @ tnfa t@ $20 or tlast @ tnfa t! ;m

:m immediate tlast @ tnfa t@ $40 or tlast @ tnfa t! ;m

:m t' ' >body @ ;m ( address of word )

:m >tbody =cell + ( =cell + =cell + ) ;m

:m tv' t' >tbody ;m ( address of variable )

:m t2/ 2/ ;m

:m t2* 2* ;m

:m unlfsr period 2* there + tallot ;m

:m pc, pc @ 2* t! pc++ ;m

: jump-val 6000 ; \ jump instruction value

: rshift-val 3000 ; \ rshift instruction value

: iXOR 2/ 8000 0000 or or pc, ; \ Bitwise XOR

: iAND 2/ 8000 1000 or or pc, ; \ Bitwise AND

: iLSHIFT 2/ 8000 2000 or or pc, ; \ LSHIFT only by 1

: iRSHIFT 2/ 8000 rshift-val or or pc, ; \ RSHIFT only by 1

: iLOAD-C 2/ 4000 or pc, ; \ Load immediate

: iLOAD 2/ 8000 4000 or or pc, ; \ Load through immediate

: iSTORE-C 2/ 5000 or pc, ; \ Store acc to imm location

: iSTORE 2/ 8000 5000 or or pc, ;

: iJUMP 2/ jump-val or pc, ; \ Unconditional jump

: iPC! 2/ 8000 jump-val or or pc, ; \ Indirect Jump

: iJUMPZ 2/ 7000 or pc, ; \ Conditional Jump!

: iPC!Z 2/ 8000 7000 or or pc, ; \ Indirect Cond. Jump!

: (iLITERAL) 2* dup $F000 and 0<> abort" literal too large"

rshift-val or ;

: iLITERAL (iLITERAL) pc, ;

: branch iJUMP ;

: ?branch iJUMPZ ;

: call 2/ ( iJUMP -> ) jump-val or ;

: thread 2/ ;

: thread, thread t, ;

:m postpone t' thread, ;m

assembler.1 +order also definitions

: begin pc @ 2* ;

: until ?branch ;

: again branch ;

: if begin 0 ?branch ;

: mark begin 0 branch ;

: then begin 2/ over t@ or swap t! ;

: else mark swap then ;

: while if swap ;

: repeat branch then ;

assembler.1 -order

meta.1 +order also definitions

jump-val 1 or t, \ halt condition of VM, we start at next addr

label: entry ( previous instructions are irrelevant )

0 pc, \ entry point of VM

unlfsr

8000 tconst high \ must contain `8000`

FF00 tconst ins \ instruction mask

FFFF tconst set \ all bits set, -1

0 tconst {ip0} \ entry point of virtual machine, set later

\ These must all be zero, they are stored near the stacks

\ and line buffers towards the end of the memory and do not

\ form a part of the generated image.

0 tvar ip \ instruction pointer

0 tvar t \ temporary register

0 tvar q \ second, temporary, register

0 tvar r0 \ third, temporary, reg

0 tvar r1 \ fourth register

0 tvar r2 \ fifth register...

0 tvar tos \ top of stack

0 tvar rlink \ link register

=end 200 - 2* constant TERMBUF

=end 100 - dup tconst {rp0} tvar {rp}

=end 1- dup tconst {sp0} tvar {sp}

TERMBUF =buf 2* + constant =tbufend

:m tail-link

iLITERAL \ place to return to

rlink iSTORE-C \ store in link register

branch \ branch to link function

;m

:m link ( a -- : perform limited call with link register )

pc @ lfsr lfsr lfsr tail-link ;m

assembler.1 +order

label: sp-1

{sp} iLOAD-C

\ Fall-through...

label: r0bitinc

r0 iSTORE-C

\ Fall-through...

label: bitinc

1 iLITERAL

r1 iSTORE-C

\ Fall-through...

label: bitadd

opt.support-add [if]

high iLSHIFT

if \ If `iLSHIFT` is actually an add instruction

r0 iLOAD-C

r1 iLSHIFT

r0 iSTORE-C

rlink iPC!

then

r1 iLOAD-C

\ Fall-through...

label: bitloop \ Perform addition, no carry

if \ Ideally we would put carry result in variable for `um+`

r0 iAND

r2 iSTORE-C

r0 iLOAD-C

r1 iXOR

r0 iSTORE-C

r2 iLSHIFT

r1 iSTORE-C

bitloop branch

then

r0 iLOAD-C \ Return result in accumulator

rlink iPC!

label: sp+1

{sp} iLOAD-C

\ Fall-through...

label: r0bitdec

r0 iSTORE-C

\ Fall-through...

label: bitdec

set iLOAD-C

r1 iSTORE-C

bitadd branch

label: rp-1

{rp} iLOAD-C

r0bitdec branch

label: rp+1

{rp} iLOAD-C

r0bitinc branch

assembler.1 -order

: --sp sp-1 link {sp} iSTORE-C ;

: ++sp sp+1 link {sp} iSTORE-C ;

: --rp rp-1 link {rp} iSTORE-C ;

: ++rp rp+1 link {rp} iSTORE-C ;

assembler.1 +order

label: start \ Forth VM entry point

start call entry t! \ Set entry point

{sp0} iLOAD-C {sp} iSTORE-C \ Set initial v.stk ptr

{rp0} iLOAD-C {rp} iSTORE-C \ Set initial r.stk ptr

{ip0} iLOAD-C \ Load initial word to execute

ip iSTORE-C \ Set instruction pointer to word

\ -- fall-through --

label: vm ( The Forth virtual machine )

ip iLOAD-C \ load `ip`, or instruction pointer

t iSTORE-C \ save a copy

r0 iSTORE-C \ store `r0` for call to `bitinc`

bitinc link \ increment ptr to next instruction

\ result returned in accumulator

ip iSTORE-C \ `ip` points to the next instruction

t iLOAD \ load current instruction

q iSTORE-C \ Store result to `q`

ins iAND \ Mask off high bits

q iPC!Z \ Conditional Jump indirect through `q`

++rp \ increment return stack pointer

ip iLOAD-C \ load location of next instruction

{rp} iSTORE \ store return location

q iLOAD-C \ load instruction again

ip iSTORE-C \ store it `ip`, completing call

vm branch \ and do it all again!

assembler.1 -order

:m a: ( "name" -- : assembly only routine, no header )

CAFED00D

target.1 +order also definitions

create talign pc @ 2* ,

assembler.1 +order

does> @ thread, ;m

:m (a); CAFED00D <> if abort" unstructured" then

assembler.1 -order ;m

:m a; (a); vm branch ;m

a: exit ( -- : exit from current function )

label: {unnest} ( return from function call )

{rp} iLOAD

ip iSTORE-C

(a); ( fall-through )

a: rdrop ( --, R: u -- : drop top item on return stack )

label: .rdrop

--rp

a;

:m unnest {unnest} thread, ;m

:m =unnest {unnest} thread ;m

:m :h ( "name" -- : forth only routine )

get-current >r target.1 set-current create

r> set-current CAFEBABE talign there ,

does> @ thread, ;m

:m :f

get-current >r target.1 set-current create

r> set-current talign there ,

does> @ thread, ;m

:m :t ( "name" -- : forth only routine )

>in @ thead >in !

get-current >r target.1 set-current create

r> set-current CAFEBABE talign there ,

does> @ thread, ;m

:m :to ( "name" -- : forth only, target only routine )

>in @ thead >in !

get-current >r target.only.1 set-current create r>

set-current

there ,

CAFEBABE

does> @ thread, ;m

:m structured? CAFEBABE <> if abort" unstructured" then ;

:m ;t structured? talign unnest target.only.1 -order ;

a: opPush ( pushes next value in instr stream to the stack )

++sp

tos iLOAD-C

{sp} iSTORE

ip iLOAD

tos iSTORE-C

label: IncIp

ip iLOAD-C r0 iSTORE-C bitinc link ip iSTORE-C

vm branch

(a);

a: opJumpZ ( jump if zero to next cell )

tos iLOAD-C

t iSTORE-C

{sp} iLOAD

tos iSTORE-C

--sp

t iLOAD-C

if

IncIp branch

then

(a); ( fall-through to opJump )

a: opJump ( jump to next value in instruction stream )

label: Jump ( A few instructions jump here to save space )

ip iLOAD

ip iSTORE-C

a;

a: opNext ( jump and pop top of return stack if zero )

{rp} iLOAD

if

r0 iSTORE-C

bitdec link

{rp} iSTORE

Jump branch

then

--rp ( otherwise decrement it and leave it there )

IncIp branch

(a);

:m lit opPush t, ;m

:m [char] char opPush t, ;m

:m char char opPush t, ;m

:m =push [ t' opPush ] literal t2/ ;m

:m =jump [ t' opJump ] literal t2/ ;m

:m =jumpz [ t' opJumpZ ] literal t2/ ;m

:m begin talign there ;m

:m until talign opJumpZ 2/ t, ;m

:m again talign opJump 2/ t, ;m

:m if opJumpZ there 0 t, ;m

:m mark opJump there 0 t, ;m

:m then there 2/ swap t! ;m

:m else mark swap then ;m

:m while if ;m

:m repeat swap again then ;m

:m aft drop mark begin swap ;m

:m next talign opNext 2/ t, ;m

a: bye pc @ 2* branch (a); ( -- : bye bye! )

a: and ( u u -- u : bit wise AND )

{sp} iLOAD

tos iAND

label: decSp tos iSTORE-C --sp vm branch

(a);

a: + \ Computing carry and making `um+` would speed things up

tos iLOAD-C

r0 iSTORE-C

{sp} iLOAD

r1 iSTORE-C

bitadd decSp 2/ tail-link

(a);

a: xor ( u u -- u : bit wise XOR )

{sp} iLOAD

tos iXOR

decSp branch

(a);

a: lls ( u -- u : shift left by one)

opt.support-add [if] ( only needed to supported `add` )

tos iLOAD-C \ Needed is shift left by one is actually `add`

tos iLSHIFT

tos iSTORE-C

a;

a: lrs ( u -- u : shift right by one )

tos iRSHIFT

tos iSTORE-C

a;

a: @ ( a -- u : load a memory address )

tos iRSHIFT

tos iSTORE-C

(a);

a: ,@ ( a -- u : load a word address )

tos iLOAD

tos iSTORE-C

a;

a: ! ( u a -- store a cell at a memory address )

tos iRSHIFT

tos iSTORE-C

(a);

a: ,! ( u a -- store a cell at a word address )

{sp} iLOAD

tos iSTORE

--sp

(a); ( fall-through )

a: drop ( u -- : drop it like it's hot )

label: .drop

{sp} iLOAD

decSp branch

(a);

a: dup ( u -- u u : duplicate item on top of stack )

++sp

tos iLOAD-C

{sp} iSTORE

a;

a: swap ( u1 u2 -- u2 u1 : swap top two stack items )

{sp} iLOAD

t iSTORE-C

tos iLOAD-C

{sp} iSTORE

t iLOAD-C

tos iSTORE-C

a;

a: >r ( u -- , R: -- u )

++rp

tos iLOAD-C

{rp} iSTORE

.drop branch

(a);

:m for talign >r begin ;m

:m =>r [ t' >r ] literal t2/ ;m

:m =next [ t' opNext ] literal t2/ ;m

label: rxchg ( exchange values with R and V stack )

tos iLOAD-C

{sp} iSTORE

{rp} iLOAD

tos iSTORE-C

rlink iPC!

a: r> ( If feels like this could be merged with `r@`... )

++sp

rxchg .rdrop 2/ tail-link

(a);

a: r@ ( -- u, R: u -- u )

++sp

rxchg vm 2/ tail-link

(a);

a: sp! ( ??? u -- ??? : set stack depth )

tos iLOAD-C

{sp} iSTORE-C

{sp} iLOAD

tos iSTORE-C

a;

a: rp! ( u -- , R: ??? --- ??? : set return stack depth )

tos iLOAD-C

{rp} iSTORE-C

.drop branch

(a);

vmused

\

assembler.1 -order

:m : :t ;m

:m ; ;t ;m

:h #1 1 lit ;t ( -- 1 : push 1 onto variable stack )

:h #-1 -1 lit ;t ( -- -1: push -1 onto variable stack )

:to + + ;t ( n n -- n )

: 1- #-1 + ; ( u -- u )

: invert #-1 xor ; ( u -- u )

: negate 1- invert ; ( n -- n : negate [twos compliment] )

: - negate + ; ( u u -- u : subtract )

: 2* lls ; ( u -- u : multiply by two )

: 2/ lrs ; ( u -- u : divide by two )

: ?dup dup if dup then ; ( u -- u u | 0 : dup if not zero )

: rshift begin ?dup while 1- swap lrs swap repeat ;

: lshift begin ?dup while 1- swap 2* swap repeat ;

:h (var) r> 2* ;t ( -- a : used in `variable` )

:h (const) r> ,@ ;t ( -- u : used in `constant` )

:m variable :t tdrop (var) 0 t, ;m ( meta-compiler `variable` )

:m constant :t tdrop (const) t, ;m ( meta-compiler `constant` )

:m hvar :h tdrop (var) 0 t, ;m ( make headerless variable )

:m hconst :h tdrop (const) t, ;m ( make headerless constant )

0 hconst #0 ( -- 0 : space saving measure, push `0` )

FF hconst #ff ( -- 255 : space saving measure, push `255` )

20 hconst bl ( -- space : push a space, 32 )

2 constant cell ( -- u: size of memory cell in bytes )

:to bye bye ; ( -- )

:to and and ; ( u u -- u )

:to xor xor ; ( u u -- u )

:to @ @ ; ( a -- u )

:to ! ! ; ( u a -- )

:to dup dup ; ( u -- u u )

:to drop drop ; ( u -- )

:to swap swap ; ( u1 u2 -- u2 u1 )

:h sp@ {sp} lit @ :f 1+ #1 + ; ( -- u )

:h rp@ {rp} lit @ 1- ; ( -- u )

: or invert swap invert and invert ;

: execute 2/ >r ; ( xt -- )

: 0= if #0 exit then #-1 ; ( u -- f )

:h bit #1 and ; ( u -- 0 | 1 )

: c@ dup @ swap bit if 8 lit rshift then :f lsb #ff and ;

: c! ( c b -- : store character at address )

dup dup >r bit if

@ lsb swap 8 lit lshift

else

@ FF00 lit and swap lsb

then or r> ! ;

variable state ( -- a : compile/interpret state variable )

variable dpl ( -- a : double cell parse variable )

variable hld ( -- a : hold space variable )

variable base ( -- a : I/O numeric radix variable )

variable >in ( -- a : Line input position )

hvar #handler ( -- a : throw/catch handler )

hvar #tib ( -- a : terminal input buffer pointer )

hvar #last ( -- a : last defined word )

hvar #h ( -- a : dictionary pointer )

: here #h @ ; ( -- u )

: hex 10 lit :f base! base ! ; ( -- : hex I/O radix )

: source TERMBUF lit #tib @ ; ( -- b u )

: last #last @ ; ( -- : last defined word )

: ] #-1 state ! ; ( -- : turn compile mode on )

: [ #0 state ! ; immediate ( -- : turn compile mode off )

: over swap dup >r swap r> ; ( u1 u2 -- u1 u2 u1 )

: nip swap drop ; ( u1 u2 -- u2 )

: tuck swap over ; ( u1 u2 -- u2 u1 u2 )

: rot >r swap r> swap ; ( u1 u2 u3 -- u2 u3 u1 )

: 2drop drop drop ; ( u u -- : drop two numbers )

: 2dup over over ; ( u1 u2 -- u1 u2 u1 u2 )

: +! tuck @ + :f swap! swap ! ; ( n a -- )

: = xor 0= ; ( u u -- f : equality )

: <> = 0= ; ( u u -- f : inequality )

: 0>= 8000 lit and 0= ; ( n -- f : greater or equal to zero )

: 0< 0>= 0= ; ( n -- f : less than zero )

: < - 0< ; ( n n -- f : signed less than )

: > swap < ; ( n n -- f : signed greater than )

: 0> #0 > ; ( n -- f : greater than zero )

: u< 2dup 0>= swap 0>= xor >r < r> xor ; ( u u -- f : )

: emit #-1 ,! ; ( c -- : output a character / byte )

opt.eof-bye [if] ( -- ch -1 | 0 : input byte )

: key? #-1 ,@ dup 0< if bye then #-1 ;

: key? #-1 ,@ dup 0>= if #-1 exit then drop #0 ;

: cell+ cell + ; ( a -- a : increment address to next cell )

: pick sp@ + ,@ ; ( ??? u -- ??? u u : )

: aligned dup bit + ; ( b -- u : align a pointer )

: align here aligned :f h! #h ! ; ( -- : align dictionary ptr )

: depth {sp0} lit @ sp@ - 1- ; ( -- u : var stack depth )

: count dup 1+ swap c@ ; ( b -- b c )

: allot aligned #h +! ; ( u -- )

: , align here ! cell allot ; ( u -- )

: abs dup 0< if negate then ; ( n -- u )

:h mux dup >r and swap r> invert and or ; ( u1 u2 sel -- u )

: max 2dup < mux ; ( n n -- n : maximum of two numbers )

: min 2dup > mux ; ( n n -- n : minimum of two numbers )

:h +string #1 over min rot over + rot rot - ; ( b u -- b u )

: catch ( xt -- exception# | 0 \ return addr on stack )

sp@ >r ( xt ) \ save data stack pointer

#handler @ >r ( xt ) \ and previous handler

rp@ #handler ! ( xt ) \ set current handler

execute ( ) \ execute returns if no throw

r> #handler ! ( ) \ restore previous handler

rdrop ( ) \ discard saved stack ptr

#0 ; ( 0 ) \ normal completion

: throw ( ??? exception# -- ??? exception# )

?dup if ( exc# ) \ 0 throw is no-op

#handler @ rp! ( exc# ) \ restore prev return stack

r> #handler ! ( exc# ) \ restore prev handler

r> swap >r ( saved-sp ) \ exc# on return stack

sp! drop r> ( exc# ) \ restore stack

then ;

: um+ 2dup + >r r@ 0>= >r ( u u -- u carry )

2dup and 0< r> or >r or 0< r> and negate r> swap ;

: um* ( u u -- ud : double cell width multiply )

#0 swap ( u1 0 u2 ) F lit

for dup um+ >r >r dup um+ r> + r>

if >r over um+ r> + then

next :f bury rot drop ;

: um/mod ( ud u -- ur uq : unsigned double cell div/mod )

?dup 0= -A lit and throw

2dup u<

if negate F lit

for >r dup um+ >r >r dup um+ r> + dup

r> r@ swap >r um+ r> or

if >r drop 1+ r> else drop then r>

next

drop swap exit

then 2drop drop #-1 dup ;

: key begin key? until ; ( -- c : get a character from UART )

: type begin dup while swap count emit swap 1- repeat 2drop ;

: cmove for aft >r dup c@ r@ c! 1+ r> 1+ then next 2drop ;

:h do$ r> r> 2* dup count + aligned 2/ >r swap >r ; ( -- a : )

:h ($) do$ ; ( -- a : do string NB. )

:h .$ do$ count type ; ( -- )

:m ." .$ $literal ;m ( meta-compiler string compilation )

:m $" ($) $literal ;m ( meta-compiler string compilation )

:h space bl emit ; ( -- : print space )

: cr .$ 2 tc, =cr tc, =lf tc, ; ( -- : print new line )

:h ktap ( bot eot cur c -- bot eot cur )

dup dup =cr lit <> >r =lf lit <> r> and if \ Not End Line?

dup =bksp lit <> >r =del lit <> r> and if \ Not Del Char?

bl

:f tap

dup emit over c! 1+ ( bot eot cur c -- bot eot cur )

exit

then

>r over r@ < dup if

=bksp lit dup emit space emit

then

r> +

exit

then drop :f nips nip dup ;

: accept ( b u -- b u : read in a line of user input )

over + over

begin

2dup xor

while

key dup bl - 5F lit u< if tap else ktap then

repeat drop over - ;

: query ( -- : get line )

source drop =buf lit accept #tib ! drop #0 :f in! >in ! ;

:h ?depth depth > -4 lit and throw ; ( u -- )

:h base? base @ ; ( -- u : numeric I/O radix )

:h spaces begin dup 0> while space 1- repeat drop ; ( +n -- )

: hold #-1 hld +! hld @ c! ; ( c -- : save char to hold )

: #> 2drop hld @ =tbufend lit over - ; ( u -- b u )

: # ( d -- d : add next character in number to hold space )

2 lit ?depth

#0 base?

( extract: )

dup >r um/mod r> swap >r um/mod r> rot ( ud ud -- ud u )

( digit: )

9 lit over < 7 lit and + [char] 0 + ( u -- c )

hold ;

: #s begin # 2dup ( d0= -> ) or 0= until ; ( d -- 0 )

: <# =tbufend lit hld ! ; ( -- )

: sign 0< if [char] - hold then ; ( n -- )

: u.r >r #0 <# #s #> r> over - spaces type ; ( u +n -- )

: u. space #0 u.r ; ( u -- )

: . dup >r abs #0 <# #s r> sign #> space type ; ( n -- )

: .s depth for aft r@ pick . then next ; ( -- )

:h -trailing ( b u -- b u : remove trailing spaces )

for

aft bl over r@ + c@ <

if r> 1+ exit then

then

next #0 ;

:h look ( b u c xt -- b u : skip until *xt* test succeeds )

swap >r rot rot

begin

dup

while

over c@ r@ - r@ bl = 4 lit pick execute

if rdrop bury exit then

+string

repeat rdrop bury ;

:h no-match if 0> exit then :f 0<> 0= 0= ; ( c1 c2 -- t )

:h match no-match invert ; ( c1 c2 -- t )

: parse ( c -- b u ; <string> : parse a string up to `c` )

>r source drop >in @ + #tib @ >in @ - r@

>r over r> swap >r >r

r@ t' no-match lit look 2dup

( b u c -- b u delta: )

r> t' match lit look swap r> - >r - r> 1+

>in +!

r> bl = if -trailing then #0 max ;

: >number ( ud b u -- ud b u : convert string to number )

begin

2dup >r >r drop c@ base? ( get next character )

( digit? -> ) >r [char] 0 - 9 lit over <

if 7 lit - dup A lit < or then dup r> u< ( c base -- u f )

0= if ( d char )

drop ( d char -- d )

r> r> ( restore string )

exit ( ..exit )

then ( d char )

swap base? um* drop rot base? um*

( d+ -> ) >r swap >r um+ r> + r> + ( accumulate digit )

r> r> ( restore string )

+string dup 0= ( advance string and test for end )

until ;

: number? ( a u -- d -1 | a u 0 : string to a number )

#-1 dpl !

base? >r

over c@ [char] - = dup >r if +string then

over c@ [char] $ = if hex +string then

>r >r #0 dup r> r>

begin

>number dup

while over c@ [char] . xor

if bury rot r> 2drop #0 r> base! exit then

1- dpl ! 1+ dpl @

repeat

2drop r> if

( dnegate -> ) invert >r invert #1 um+ r> +

then r> base! #-1 ;

: compare ( a1 u1 a2 u2 -- n : string equality )

rot

over - ?dup if nip :f nep nip nip exit then

for ( a1 a2 )

aft

count rot count rot - ?dup

if rdrop nep exit then

then

next 2drop #0 ;

:m nfa cell+ ;m ( pwd -- nfa : move word ptr to name field )

:h cfa nfa dup c@ 1F lit and + cell+ cell negate and ;

:h (find) ( a wid -- PWD PWD 1|PWD PWD -1|0 a 0 )

swap >r dup

begin

dup

while

dup nfa count 9F lit ( $1F:word-length + $80:hidden )

and r@ count compare 0=

if ( found! )

rdrop

dup ( immediate? -> ) nfa 40 lit swap @ and 0<>

#1 or negate exit

then

nips @

repeat

2drop #0 r> #0 ;

: find last (find) bury ; ( "name" -- b )

: literal state @ if =push lit , , then ; immediate ( u -- )

:h compile, 2/ align , ; ( xt -- )

:h ?found if exit then ( u f -- )

space count type [char] ? emit cr -D lit throw ;

: interpret ( b -- : find and interpret counted word )

find ?dup if

state @

if

0> if cfa execute exit then \ <- immediate word executed

cfa compile, exit \ <- compiling words are...compiled.

then

drop

dup nfa c@ bl and if -E lit throw then ( <- ?compile )

cfa execute exit \ <- if its not, execute it, then exit

then

\ not a word

dup >r count number? if rdrop \ it is a number!

dpl @ 0< if \ <- dpl will be -1 if it is a single cell num

drop \ drop high cell from `number?` for single cell

else \ <- dpl is not -1, it is a double cell number

state @ if swap then

postpone literal \ if double, execute `literal` twice

then

postpone literal exit

then

r> #0 ?found \ Could vector ?found if we wanted to

;

: word parse here dup >r 2dup ! 1+ swap cmove r> ; ( c -- b )

: words last begin ( -- : display all loaded words )

dup nfa count 1f lit and space type @ ?dup 0= until ;

:to : align here last , #last ! ( "name" -- )

bl word

dup c@ 0= -A lit and throw

count + h! align

] :f babez BABE lit ;

:to ; postpone [ ( -- : terminate a word definition )

babez <> -16 lit and throw

=unnest lit , ; immediate compile-only

:to begin align here ; immediate compile-only

:to until =jumpz lit :f j, , compile, ; immediate compile-only

:to again =jump lit j, ; immediate compile-only

:to if =jumpz lit , here #0 , ; immediate compile-only

:to then here 2/ swap! ; immediate compile-only

:to for =>r lit , here ; immediate compile-only

:to next =next lit , compile, ; immediate compile-only

:to ' bl word find ?found cfa literal ; immediate

: compile r> dup ,@ , 1+ >r ; compile-only

:to >r compile >r ; immediate compile-only