LithosAnanake/v4/capsule/dict.v4

\ dict.v4 -- the dictionary: its space, its entries, and looking a name up.
\
\ DECOMPOSITION.md 5.12 and 5.13: HERE ALIGN ALLOT , C, 2, PAD LATEST, FIND ' ,
\ and the entry-field words >LINK LFA LINK> >NAME NFA NAME> CFA PFA >BODY
\ TRAVERSE SMUDGE HIDDEN.  Part of the compiler capsule: it runs on the host
\ node.  Rests on core.v4 and input.v4.
\
\ AN ENTRY.  A word's execution address (xt) is the address of its code, and
\ everything else is found from it:
\
\     name     the count byte, then the characters, four bytes to a cell,
\              padded with zeros to a whole cell
\     xt - 3   flags: 1 immediate, 2 hidden, 4 data
\     xt - 2   the word address of the name
\     xt - 1   the link: the xt of the entry before this one, 0 for the first
\     xt       the code
\
\ A name holds at most 31 characters; longer ones are cut to 31 both when
\ defined and when looked up, so 31 characters are significant (FORTH-79).
\ A "data" word is one whose code is a single call to its run-time routine,
\ with its parameter field in the cell after it: xt + 1.  For any other word
\ the parameter field is the code itself.
\
\ THE SPACE.  DP is a byte address, so that C, can pack characters; HERE is
\ the next whole cell.  An address unit is a cell (D-1): ALLOT counts cells.
\
\ Constants the loader supplies:
\   DP        word address of the variable: the next free byte
\   (LATEST)  word address of the variable: the xt of the newest entry, or 0
\   DBASE DLIMIT   byte addresses of the start and end of dictionary space
\   PAD       byte address of the scratch area for strings, 84 bytes or more
\   (D)       word address of five cells of scratch for this file
\ PAD is in line.

macro 4*  2* 2*  endmacro
macro 4/  2/ 2/  endmacro
macro OR  over inv and xor  endmacro

\ ---- the space (5.12) ------------------------------------------------------
\ These reach DP through B and leave A alone, so that , and C, can keep what
\ they are storing in A while the space is taken: nothing of theirs is then
\ on the data stack under (DP+), which itself needs three cells (D-2).

: (DERR) ( -- 0 )      NODE-ERROR b! -1 !b  0 ;

\ ( n -- flag )   move DP by n bytes if it stays inside the dictionary space
\ and say -1; otherwise leave it, set NODE-ERROR and say 0.  The two
\ subtractions are x + ~y + 1, which unlike the in-line - needs no return
\ entry: these words are called at the bottom of long chains of calls.
: (DP+)
  DP b! @b +
  dup DBASE inv + 1 + -if LOW  drop drop jump (DERR)         \ new - DBASE
  LOW: drop  dup inv DLIMIT + 1 + -if HIGH  drop drop jump (DERR)   \ DLIMIT - new
  HIGH: drop  DP b! !b  -1 ;

header HERE
: HERE  ( -- addr )    DP b! @b  3 +  4/ ;
header ALIGN
: ALIGN ( -- )         DP b! @b  3 +  -4 and  !b ;
header ALLOT
: ALLOT ( n -- )       ALIGN  4* (DP+) drop ;

\ , calls nothing: the code generator calls it from as deep as anything goes.
header ,
: ,  ( x -- )
  a!
  DP b! @b  3 + -4 and                       \ the next whole cell, as a byte address
  dup inv DLIMIT + -3 +  -if ROOM            \ DLIMIT - (it + 4)
  drop drop  NODE-ERROR b! -1 !b ;
  ROOM: drop  dup 4 + !b                     \ DP is past it
  4/ b!  a !b ;
header C,
: C, ( c -- )
  a!  1 (DP+) if FULL
  drop  a  DP b! @b -1 +  jump C!
  FULL: drop ;
header 2,
: 2, ( lo hi -- )      SWAP , , ;                       \ the low cell first, as v3

header LATEST
: LATEST ( -- xt )     (LATEST) a! @ ;

\ ---- the fields of an entry (5.13) -----------------------------------------

: (FLAGS) ( xt -- addr )    -3 + ;
header >LINK
: >LINK   ( xt -- addr )    -1 + ;
header LFA
: LFA     ( xt -- addr )    jump >LINK
header LINK>
: LINK>   ( addr -- xt )    a! @ ;
header >NAME
: >NAME   ( xt -- baddr )   -2 + a! @ 4* ;
header NFA
: NFA     ( xt -- baddr )   jump >NAME
header NAME>
: NAME>   ( baddr -- xt )   dup C@ 31 and 4 + 4/  push 4/ pop +  3 + ;
header CFA
: CFA     ( xt -- xt )      ;
header PFA
: PFA     ( xt -- addr )    dup (FLAGS) a! @ 4 and if CODE  drop 1 + ;   CODE: drop ;
header >BODY
: >BODY   ( xt -- addr )    jump PFA

\ ( baddr n -- baddr' )   as v3: for n > 0, from a name's count byte to the
\ byte after its last character; otherwise the address unchanged.
header TRAVERSE
: TRAVERSE
  -if NN  drop ;
  NN: if ZERO  drop  dup C@ 31 and + 1 + ;
  ZERO: drop ;

header SMUDGE
: SMUDGE ( -- )   LATEST if NONE  (FLAGS) a! @ 2 xor ! ;   NONE: drop ;
header HIDDEN
: HIDDEN ( -- )   LATEST if NONE  (FLAGS) a! @ 2 OR  ! ;   NONE: drop ;

\ ---- making an entry -------------------------------------------------------
\ (D)+0 where the name starts   (D)+1 the name being looked up
\ (D)+2 the name being copied, or the entry being looked at
\ (D)+3 a count

\ ( -- bytes )   what an entry for a name of (D)+3 characters takes: its name
\ cells and three more
: (NEED)   (D)+3 a! @  4 + -4 and  12 + ;

\ ( baddr -- )   an entry for the counted string at baddr; its code starts at
\ HERE afterwards.  An empty name, or no room, makes nothing and sets
\ NODE-ERROR.
: (HEADER)
  dup (D)+2 a! !                             \ (CLIP), in line
  C@ -32 + -if LONG  drop jump CLIPPED
  LONG: drop  31 (D)+2 a! @ C!
  CLIPPED:
  (D)+2 a! @ C@ if EMPTY                     \ len
  (D)+3 a! !
  ALIGN
  (NEED) (DP+) if FULL  drop                 \ there is room;
  (NEED) NEGATE (DP+) drop                   \ DP back where it was
  HERE (D) a! !                              \ where the name starts
  (D)+3 a! @ C,
  L: (D)+3 a! @ if DONE  -1 + !
     (D)+2 a! @ 1 + dup !  C@ C,
     jump L
  DONE: drop
  P: DP b! @b 3 and if ALIGNED  drop 0 C,  jump P
  ALIGNED: drop
  0 ,  (D) a! @ ,  LATEST ,
  HERE (LATEST) a! ! ;
  FULL: drop ;                               \ (DP+) has set NODE-ERROR
  EMPTY: drop  NODE-ERROR b! -1 !b ;

\ ---- looking a name up -----------------------------------------------------

\ ( baddr -- xt | 0 )   the newest visible entry named by the counted string.
\ Written out in one piece -- the string cut to 31, each entry's flags and
\ name fetched, the two names compared byte by byte -- so that the only call
\ it makes is C@: it is called from the interpreter for every word of every
\ line, with the user's return stack beneath it.
: (LOOKUP)
  dup (D)+1 a! !                             \ cut the string to 31 characters
  C@ -32 + -if LONG  drop jump CUT
  LONG: drop  31 (D)+1 a! @ C!
  CUT:
  LATEST
  L: if END
     (D)+2 a! !
     (D)+2 a! @ -3 + a! @ 2 and if VISIBLE  drop jump OLDER
     VISIBLE: drop
     (D)+2 a! @ -2 + a! @ 4*  (D) a! !       \ its name
     (D)+1 a! @ C@ 1 +  (D)+3 a! !           \ the count byte and the characters
     C: (D)+3 a! @ if SAME  -1 + dup !       \ k
        dup (D) a! @ + C@                    \ k c1
        SWAP (D)+1 a! @ + C@                 \ c1 c2
        xor if EQ  drop jump OLDER
        EQ: drop jump C
     SAME: drop  (D)+2 a! @ ;
     OLDER: (D)+2 a! @ -1 + a! @  jump L
  END: ;

\ ( -- xt | 0 )   FORTH-79: the compilation address of the next word in the
\ input stream, or 0 if it is not in the dictionary.
header FIND
: FIND   32 WORD jump (LOOKUP)

\ ( -- addr )   FORTH-79: the parameter field address of the next word in the
\ input stream.  Not found is an error: 0, and NODE-ERROR is set.  This is '
\ when interpreting; compile.v4 adds what ' does when compiling.
: (')    32 WORD (LOOKUP) if MISSING  jump PFA
  MISSING: drop jump (DERR)