vim:ft=forth:ts=2:sw=2:expandtab

$0040 constant immediate-flag
$0080 constant visible-flag

: depth         s0 sp@ - /cell 1- ;
: rdepth        r0 rp@ - /cell 1- ;
: .s            sp@ depth 1- begin ?dup while
                  swap dup @ hex. space cell+ swap 1-
                repeat drop cr ;

: .r            rp@ rdepth 1- begin ?dup while
                  swap dup @ hex. space cell+ swap 1-
                repeat drop cr ;

: align         here aligned org ;
: link>name     2 cells + ;
: link>flags    cell+ ;
: link>         link>name dup c@ + 1+ aligned ;
: >body         4 cells + ;
: visible?      link>flags @ visible-flag and 0> ;
: immediate?    link>flags @ immediate-flag and 0> ;
: ,link         , ;
: ,call         , ;
: ,enter        $0000f92c , ;
: ,dodoes       $000cf92c , ;
: ,next         $0020ea0c , $0000fe03 , ;
: ,exit         ['] exit ,call ;

: ,dodata       $000c0f28 , $00300c0d , ,next ;
: ,docon        $000c0f2c , $00300c0d , ,next ;

: (s")          r> count 2dup + aligned >r ;

: latest-flags  ( -- addr f ) get-current @ link>flags dup @ ;
: immediate     latest-flags immediate-flag or swap ! ;
: hide          latest-flags visible-flag invert and swap ! ;
: reveal        latest-flags visible-flag or swap ! ;

: literal       postpone lit , ; immediate
: parse-name    bl word count ;

variable state

: [             false state ! ; immediate
: ]             true state ! ;
: compiling?    state @ ;
: interpreting? state @ 0= ;

: stri=         ( c-addr1 u1 c-addr2 u2 -- f )
                rot over <> if drop 2drop 0 exit then
                >r begin
                  2dup ci@= r@ 0<> and while
                  1+ swap 1+ swap
                  r> 1- >r
                repeat
                2drop r> 0=
                ;

: str=          ( c-addr1 u1 c-addr2 u2 -- f )
                rot over <> if drop 2drop 0 exit then
                >r begin
                  2dup c@ swap c@ = r@ 0<> and while
                  1+ swap 1+ swap
                  r> 1- >r
                repeat
                2drop r> 0=
                ;

: search-wordlist               ( c-addr u wid -- 0 | xt -1 | xt 1 )
                @ >r begin
                  2dup r@ link>name count stri= r@ visible? and
                  dup 0= if r> @ dup >r 0= or then
                until 2drop r>
                dup if
                  dup link>
                  swap immediate? not 1 or
                then ;

: find          0                               ( c-addr 0 )
                #order @ 0 do
                  over count                    ( c-addr 0 c-addr' u )
                  i cells context + @           ( c-addr 0 c-addr' u wid )
                  search-wordlist               ( c-addr 0; 0 | w 1 | q -1 )
                  ?dup if                       ( c-addr 0; w 1 | w -1 )
                    2swap 2drop leave           ( w 1 | w -1 )
                  then                          ( c-addr 0 )
                loop                            ( c-addr 0 | w 1 | w -1 )
                ;

: '             bl word find dup 0= if drop count type space $3F emit
                else drop then ;
: words         context @ begin @ ?dup while
                  dup link>name count type space
                repeat ;

: postpone      bl word find 0< if literal postpone ,call
                else ,call then ; immediate
: [']           ' postpone literal ; immediate

$100 buffer: (s#)

: s"            interpreting? if [char] " word count >r (s#) r@ cmove (s#) r> exit then
                postpone (s")
                [char] " word dup dup c@ 1+ here swap move
                c@ 1+ allot align ; immediate
: ."            postpone s" postpone type ; immediate

: (link)        align here get-current dup @ ,link 0 , ! ;

: <builds       (link) bl word
                dup dup c@ 1+ here swap move
                c@ 1+ allot align ;

: :             <builds ,enter hide ] ;
: ;             ,exit reveal [ ; immediate
: :noname       0 , here ,enter ] ; immediate

: create        <builds ,dodata reveal ;
: constant      <builds ,docon , reveal ;
: variable      <builds ,dodata cell allot reveal ;
: buffer:       <builds ,dodata allot reveal ;

: (does>)       here get-current @ link> #8 + org ,dodoes r> ,call org ;
: does>         postpone (does>) ; immediate
: recurse       get-current @ link> ,call ; immediate
: [char]        char postpone literal ; immediate

: value         <builds ,dodata , reveal does> @ ;
: to            bl word find 0= throw 4 cells + ! ;

: undefined     ." *** undefined deferred word called ***" bye ;
: defer         <builds ,dodata ['] undefined , reveal does> @ execute ;
: is            to ;