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 two 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) ------------------------------------------------------

: (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.
: (DP+)
  DP a! @ +
  dup DBASE - -if LOW  drop drop jump (DERR)
  LOW: drop  DLIMIT over - -if HIGH  drop drop jump (DERR)
  HIGH: drop  DP a! !  -1 ;

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

: ,  ( x -- )
  ALIGN  HERE push  4 (DP+) if FULL  drop pop a! ! ;
  FULL: drop pop drop drop ;
: C, ( c -- )
  DP a! @ push  1 (DP+) if FULL  drop pop C! ;
  FULL: drop pop drop drop ;
: 2, ( lo hi -- )      SWAP , , ;                       \ the low cell first, as v3

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

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

: (FLAGS) ( xt -- addr )    -3 + ;
: >LINK   ( xt -- addr )    -1 + ;
: LFA     ( xt -- addr )    jump >LINK
: LINK>   ( addr -- xt )    a! @ ;
: >NAME   ( xt -- baddr )   -2 + a! @ 4* ;
: NFA     ( xt -- baddr )   jump >NAME
: NAME>   ( baddr -- xt )   dup C@ 31 and 4 + 4/  push 4/ pop +  3 + ;
: CFA     ( xt -- xt )      ;
: PFA     ( xt -- addr )    dup (FLAGS) a! @ 4 and if CODE  drop 1 + ;   CODE: drop ;
: >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.
: TRAVERSE
  -if NN  drop ;
  NN: if ZERO  drop  dup C@ 31 and + 1 + ;
  ZERO: drop ;

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

\ ---- making an entry -------------------------------------------------------

\ ( baddr -- baddr )   cut the counted string to 31 characters, in place
: (CLIP)   dup C@ -32 + -if LONG  drop ;   LONG: drop  31 over C! ;

\ ( 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)
  (CLIP) dup C@ if EMPTY                     \ baddr len
  ALIGN
  dup 4 + -4 and 12 +                        \ baddr len need   bytes: name cells and three more
  dup (DP+) if FULL  drop NEGATE (DP+) drop  \ there is room; DP back where it was
  HERE (D) a! !                              \ where the name starts
  dup C,                                     \ baddr len
  L: if DONE  SWAP 1 + dup C@ C,  SWAP -1 +  jump L   \ nothing on R across C,
  DONE: drop drop
  P: DP a! @ 3 and if ALIGNED  drop 0 C,  jump P
  ALIGNED: drop
  0 ,  (D) a! @ ,  LATEST ,
  HERE (LATEST) a! ! ;
  FULL: drop drop
  EMPTY: drop drop  NODE-ERROR b! -1 !b ;

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

\ ( baddr1 baddr2 -- flag )   two counted strings are the same
: (NAME=)
  over C@ 1 +                                \ b1 b2 n     the count byte and the characters
  L: if SAME  push
     over C@ over C@ xor if EQ  drop drop drop pop drop  0 ;
     EQ: drop  1 + push 1 + pop  pop -1 +  jump L
  SAME: drop drop drop  -1 ;

\ ( baddr -- xt | 0 )   the newest visible entry named by the counted string
: (LOOKUP)
  (CLIP) (D) 1 + a! !
  LATEST
  L: if END
     dup (FLAGS) a! @ 2 and if VISIBLE  jump OLDER
     VISIBLE: drop  dup >NAME  (D) 1 + a! @  (NAME=) if OLDER  drop ;
     OLDER: drop  >LINK 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.
: 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.
: '      32 WORD (LOOKUP) if MISSING  jump PFA
  MISSING: drop jump (DERR)