\ dir.f18 -- the ROM's directives, and the end of the system's source.
\
\ What the prebuilt nucleus's mkimage.c (gone) and text.c's header did in C
\ is said in the source with
\ these (MACHINE.md, the ROM's language).  Each is a machine notion -- an
\ address, a cell, a value -- and none is FORTH.
\   constant NAME VALUE    NAME is the number VALUE
\   set NAME VALUE         an assembler variable: may be set again
\   #, VALUE               one cell of data at the next word address
\   ", TOKEN               TOKEN, whatever its characters, as a counted string
\   store ADDR VALUE       ADDR := VALUE, anywhere in RAM
\   start NAME             the end: every branch must have its target; the
\                          tables the ROM used are cleared; then NAME runs
\ A VALUE is a number, a constant, a set variable, CONST+N, here (the next
\ word address) or &NAME of a word already defined.

\ ( -- v 1 | 0 0 )   the token as a VALUE; "not a value" if it is none
: (VALUE)
  (NUMBER) if NN
  -if NUMOK  drop drop  ERR-BIG (FAIL)  0 0 ;
  NUMOK: drop  1 ;
  NN: drop drop
  &(RESERVED) (WALK) 8 xor if HR  drop
  0 (CHAR@) 38 xor if AMPV  drop
  (FIND) if NOSYM
  dup 2 + a! @ 2 xor if CV  drop
  dup 2 + a! @ 4 xor if CV  drop
  drop  jump BAD
  CV: drop  3 + a! @  1 ;
  NOSYM: drop
    (CONST+N) if BAD0  ;
  BAD0: drop drop
  BAD: ERR-VALUE (FAIL)  0 0 ;
  HR: drop  (LABEL)  1 ;
  AMPV: drop  (TOKN) a! @ -1 + if ONEV  drop
    (TOK-SAVE)  1  (MLEN) a! @ -1 +  (TOK-SUB)
    (FIND) if BADA
    dup 2 + a! @ 1 xor if OKA  drop drop  jump BADA0
    OKA: drop  3 + a! @  1 ;
    BADA: drop
    BADA0: ERR-AMP (FAIL)  0 0 ;
    ONEV: drop  jump BAD

\ ( -- v 1 | 0 0 )   the next token as a VALUE
: (NEXT-VALUE)
  (NEXT-TOKEN) if MISS  drop  jump (VALUE)
  MISS: drop  (MISSING)  0 0 ;

: (H-CONSTANT)
  (IN-MACRO?) if OK  drop ;
  OK: drop
  (NEXT-TOKEN) if MISS  drop
  (TOK) (TSAVE) 16 (COPY)
  (NEXT-TOKEN) if MISS  drop
  (NUMBER) if NAN
  -if NUM  drop drop  ERR-BIG jump (FAIL)
  NUM: drop  (NAME-BACK)  2 jump (DEFINE)
  NAN: drop drop  ERR-VALUE jump (FAIL)
  MISS: drop  jump (MISSING)

: (H-SET)
  (IN-MACRO?) if OK  drop ;
  OK: drop
  (NEXT-TOKEN) if MISS  drop
  (TOK) (TSAVE) 16 (COPY)
  (NEXT-VALUE) if BADV  drop
  (NAME-BACK)  4 jump (DEFINE)
  BADV: drop drop ;
  MISS: drop  jump (MISSING)

\ here alone is not something to assemble: only a VALUE
: (H-HERE)   ERR-TARGET jump (FAIL)

: (H-CELL)
  (IN-MACRO?) if OK  drop ;
  OK: drop
  (NEXT-VALUE) if BADV  drop
  (LABEL) drop  jump (EMIT)
  BADV: drop drop ;

: (H-STRING)
  (IN-MACRO?) if OK  drop ;
  OK: drop
  (RAW-TOKEN) if MISS  drop
  (LABEL) drop
  (TOKN) a! @ 4 + 2/ 2/  (T1) a! !  0 (T2) a! !
  L: (T2) a! @  (T1) a! @ xor if D  drop
    (T2) a! @ (TOK) + a! @  (EMIT)
    (T2) a! @ 1 + !  jump L
  D: drop ;
  \ text.c says "without a string, or one too long" for both: missing
  MISS: drop  ERR-MISSING jump (FAIL)

\ store ADDR VALUE: ADDR must be in RAM, as text.c requires
: (H-STORE)
  (IN-MACRO?) if OK  drop ;
  OK: drop
  (NEXT-VALUE) if BADV  drop  (T1) a! !
  (NEXT-VALUE) if BADV  drop
  (T1) a! @ -if LO
  drop drop  ERR-RANGE jump (FAIL)
  LO: RAM-WORDS inv 1 + +  -if HI
  drop  (T1) a! @ b! !b ;
  HI: drop drop  ERR-RANGE jump (FAIL)
  BADV: drop drop ;

\ ( -- )   clear the tables the ROM uses only while it assembles: the symbol
\ table in dictionary space, the branches, labels and names in the block
\ window, the saved token and macro body in the text input buffer
: (CLEAR)
  DICT-W a!  DICT-END  DICT-W inv 1 + +  -1 +  FOR 0 !+ NEXT
  BUF0 a!  1023 FOR 0 !+ NEXT
  TIB-W a!  259 FOR 0 !+ NEXT
  0 (RECN) a! !  0 (POOLN) a! !  0 (NREF) a! !  0 (NLAB) a! !
  0 (WNP) a! !  0 (NFOR) a! !  0 (RDEPTH) a! ! ;

\ start NAME: the system's source has ended; NAME, a word, is where it starts
: (H-START)
  (IN-MACRO?) if OK  drop ;
  OK: drop
  (NEXT-TOKEN) if MISS  drop
  (TOK) (TSAVE) 16 (COPY)
  (END-WORD)
  (FAILED) a! @ if F0  drop ;
  F0: drop
  (NREF) a! @ if NOREF  drop
  ERR-UNDEFINED (FAIL)  (REFS) 1 + a! @  (ERRLINE) a! ! ;
  NOREF: drop
  (LABEL) drop
  (NAME-BACK)
  (FIND) if NOTW
  dup 2 + a! @ 1 xor if ISW  drop drop  jump NOTW0
  ISW: drop  3 + a! @  (T1) a! !
  \ nothing may follow start but blanks, comments and the ends of blobs,
  \ up to the end of all
  A1: (TOKEN) if A2
    drop  ERR-AFTER jump (FAIL)
  A2: drop  (FAILED) a! @ if A3  drop ;
  A3: drop  (EOF) a! @ if A1  drop
  (CLEAR)
  0 DSTACK-REG a! !  0 RSTACK-REG a! !
  (T1) a! @ push ;
  NOTW: drop
  NOTW0: ERR-START jump (FAIL)
  MISS: drop  jump (MISSING)