forth.fs_working

( This File is to be executed by bfc - a legs forth cross compiler.
 bfc is not a true forth, as it lacks true extendable immediate mode.
 you will notice that regular old "exit" finishes most definitions,
 but not all - As a few definitions are allowed to "fall-through" to
 the next defined words.

 Words ending in ' are prime words - these are the original "doers" of
 defered words, that can be redefined later - which is most of the
 global variables state, cp, dh, and the replaceable parts of the
 "outer interpreter".  Legs uses an inherent Direct Threaded Code , or
 DTC model, and words are not natively redirectable without adding a
 wrapper word.
 
 You will notice a lack of text output words.  We don't need them for
 this file - we're just trying to produce a self-hosting forth and a
 few extension hooks for now, nothing more.  bfc provides a basic
 debugger allowing one to debug this code without defining output words.

)



p: ff debug \ toggle debugging

: dovar pull exit			\ the variable "doer"
: cell+	cell + exit			\ increments by a cell
: char+ char + exit			\ increments by a char
: !+    over ! cell+ exit ( a x -- a )	\ stores and inc. a
: c!+   over c! char+ exit    	     	\ cstores and inc. a
: @+    dup cell+ swap @ exit ( a -- a x ) \ fetches and inc. address
: c@+   dup char+ swap c@ exit 	      	\ cfetches and inc. address
: cp0	4 exit	      			\ starting cp value
: cp'   cp0 exit			\ compilation pointer
: cp 	cp' exit  			\ compilation pointer
: here	cp @ exit			\ current compilation pointer
: , 	here swap !+ cp ! exit		\ appends cell
: c,	here swap c!+ cp ! exit		\ appends char
: 0=	if 0 else -1 then exit		\ tests for 0
: 0<    mint and if -1 else 0 then exit \ tests for negative
: neg	com 1+ exit			\ negate
: -	neg + exit			\ subtract
: bl?	21 - 0< exit    		\ tests for whitespace
: rot	push swap pull swap exit	\ rotates top three cells
: 3drop	drop				\ drops three cells
: 2drop drop drop exit			\ drops two cells
: 2dup	over over exit			\ dups two cells
: tuck	swap over exit			\ tuck TOS under NOS
: nip	swap drop exit			\ removes NOS from stack
: -rot  rot rot exit                    \ bury TOS three deep
: u<	2dup xor 0< if nip 0< exit then - 0< exit
: state dovar # -1 exit		   	\ state of compiler
: ekey  key dup emit exit     		\ gets a key and echoes 
: +!	tuck @ + swap ! exit ( x a -- )	\ increment var by x

: tib ( -- a ) \ address of text input buffer
    here 100 + exit

: word' ( -- ca ) \ get next word from input stream
	tib 0 !+ 
	begin ekey dup bl? while drop repeat
	begin c!+ 1 tib +! ekey dup bl? until 2drop tib exit 

: word  word' exit 

: unloop
    pull pull drop push exit 

: s=	( ca ca -- f ) \ compares string for equality
  	@+ rot @+ rot over - if 3drop 0 exit then
	for c@+ rot c@+ rot - if 2drop 0 unloop exit then
	next 2drop -1 exit

     
( 
Dictionary Format

offset	size	what
0	2	link
2	2	xt
4	2	flags
6	?	ca of name

)

: dh		6 exit		\ dictionary head
: latest	dh @ exit	\ latest word
: >name		cell+ 		\ returns ca of entry
: >flag		cell+ 		\ returns address of flags of entry
: >xt		cell+ exit	\ returns address of xt of entry

: dfind  ( ca lh -- da )	\ find dictionary struct, or 0 if not found
	@ begin dup while 2dup >name s= if nip exit then @ repeat nip exit

: find  ( ca -- ca 0 | xt 1 | xt -1 ) \ find and xt
  	dup dh dfind dup 0= if exit then
	nip dup >xt @ swap >flag @ if 1 else -1 then exit 

: [		-1 state ! exit immediate

: ]		0 state ! exit 


: ?dup ( x -- ? ) \ duplicates TOS if TOS is not zero
  dup if dup then exit

: s,  ( ca -- )           \ compile string
  @+ dup , for c@+ c, next drop exit

: header' ( "name" -- )	    \ makes a header
    here latest , dh !
    here 0 dup , , 
    word s,
    here swap !
exit

: header  header' exit

: :            ( -- )       \ make a definition
  header ] exit

: ; immediate ( -- ) 
  lit exit , [ exit

: within ( a b c -- ) \ returns true if a is between b and c
     over - push - pull u< exit


: atou ( c -- x ) \ convert asci to a int - -1 on conversion err
     dup 2f 3a within if 30 - exit then
     dup 60 67 within if 57 - exit then
     drop -1 exit       

: >num' ( ca -- n f )
  @+ over c@ 2d - 0= if 1- swap char+ swap -1 else 0 then -rot
  0 swap for shl shl shl shl swap c@+ 
  atou dup 0< if 2drop nip 0 unloop exit then
  rot + next nip swap if neg then -1 exit

: >num  >num' exit 

: wnf' ( ca -- )
  3f emit d emit drop begin again exit

: wnf wnf' exit

: \ begin ekey d - 0= until exit immediate

: interpret ( -- ) \ interprets source until error or out of words
    begin
     	word dup @ 0= if drop exit then
        find ?dup if ( xt 1 | xt -1 )
	    0< 0= state @ or if exec else , then
	else ( ca )
            dup >num if 
	    	 nip state @ 0= if lit lit , , then
	    else
                 drop wnf exit
            then 
        then 
    again
     

: quit
  memz rp!
    begin
     	word find ?dup if ( xt 1 | xt -1 )
	    0< 0= state @ or if exec else , then
	else ( ca )
            dup >num if 
	    	 nip state @ 0= if lit lit , , then
	    else
                 drop wnf quit
            then 
        then 
    again
;