\ pack.f18 -- the ROM's slot packer: how code is laid down.
\
\ The rules are v4/src/asm.c's, with text.c's branch placement
\ (DATASHEET-F18.md section 6):
\   - opcodes fill slots 0 .. 5 left to right; a full word is written out and
\     a new one begun, unused slots padded with nop
\   - a literal is @p in a slot and its value in the word after the
\     instruction word, several in the order they were given
\   - ; and ex end the word: nothing after them executes
\   - a branch ends the word, the bits to its right being its address; it is
\     put only in a slot that reaches the whole address space (ADDR-TOP),
\     otherwise in a new word; a target it cannot reach is "does not fit"
\ This is the code generator of whatever language is built on the machine
\ (MACHINE.md 2.1).  State, in the ROM's area: (HERE) the next word address,
\ (CUR) the word being built, (SLOT) its next slot, (LITS) the (NLIT)
\ literals it owes.  (PI) (RS) (RN) are working cells.  Uses A and B.

\ ( op -- f )   1 if op is a branch: jump call next if -if
: (BRANCH-OP?)
  dup -2 + if Y  drop  dup -3 + if Y  drop  dup -5 + if Y  drop
  dup -6 + if Y  drop  dup -7 + if Y  drop drop 0 ;
  Y: drop drop 1 ;

\ ( s -- m )   the address bits a branch in slot s replaces
: (MASK)
  if S0  -1 + if S1  -1 + if S2  -1 + if S3  -1 + if S4  drop 3 ;
  S0: drop $7FFFFFF ;
  S1: drop $3FFFFF ;
  S2: drop $1FFFF ;
  S3: drop $FFF ;
  S4: drop $7F ;

\ ( w s -- op )   the opcode in slot s of the instruction word w
: (SLOT-OP)
  dup 2* 2* +  inv 1 + 27 +
  S: if SD  push 2/ pop -1 +  jump S
  SD: drop  31 and ;

\ ( op -- )   op into the next slot
: (PUT-OP)
  (SLOT) a! @  dup 2* 2* +  inv 1 + 27 +
  S: if SD  push 2* pop -1 +  jump S
  SD: drop  (CUR) a! @ xor !
  (SLOT) a! @ 1 + ! ;

\ ( v -- )   v at (HERE), which then moves on; past RAM, "does not fit"
: (EMIT)
  (HERE) a! @ dup  RAM-WORDS inv 1 + +  -if FULL
  drop b! !b  (HERE) a! @ 1 + ! ;
  FULL: drop drop drop  ERR-FIT jump (FAIL)

\ ( -- )   write out the word being built, padded with nop, then its literals
: (FLUSH)
  (SLOT) a! @ if NONE  drop
  P: (SLOT) a! @ 6 xor if PADDED  drop  28 (PUT-OP)  jump P
  PADDED: drop
  (CUR) a! @ (EMIT)
  0 (PI) a! !
  L: (PI) a! @  (NLIT) a! @ xor if LD  drop
    (PI) a! @ (LITS) + a! @ (EMIT)
    (PI) a! @ 1 + !  jump L
  LD: drop
  0 (CUR) a! !  0 (SLOT) a! !  0 (NLIT) a! ! ;
  NONE: drop ;

\ ( op -- )   an opcode that is neither a branch nor @p
: (OP)
  dup -32 + -if BAD
  drop dup 8 xor if BAD
  drop dup (BRANCH-OP?) if GOOD
  BAD: drop drop  ERR-OPCODE jump (FAIL)
  GOOD: drop
  dup (PUT-OP)
  if CLOSE
  -1 + if CLOSE
  drop  (SLOT) a! @ 6 xor if CLOSE  drop ;
  CLOSE: drop  jump (FLUSH)

\ ( v -- )   @p and its value
: (LIT)
  (NLIT) a! @ (LITS) + b! !b
  (NLIT) a! @ 1 + !
  8 (PUT-OP)
  (SLOT) a! @ 6 xor if FL  drop ;
  FL: drop  jump (FLUSH)

\ ( -- )   text.c's place_branch: begin a new word unless the next slot
\ reaches the whole address space
: (PLACE)
  (SLOT) a! @ if NONE
  dup -4 + -if NEW  drop
  (MASK)  ADDR-TOP inv 1 + +  -if KEEP  drop  jump (FLUSH)
  KEEP: drop ;
  NEW: drop drop  jump (FLUSH)
  NONE: drop ;

\ ( -- addr )   end the word being built; the next word address
: (LABEL)   (FLUSH) (HERE) a! @ ;

\ ( op -- ref )   a branch whose target comes later: ref is the word it is in
: (BRANCH>)
  dup (BRANCH-OP?) if BAD  drop
  (PLACE)
  (SLOT) a! @ -4 + -if FL  drop  jump GO
  FL: drop  (FLUSH)
  GO: (HERE) a! @ push
    (PUT-OP)
    6 (SLOT) a! !
    (FLUSH)  pop ;
  BAD: drop drop  ERR-OPCODE (FAIL)  0 ;

\ ( ref target -- )   give the branch in the word at ref its target.  The
\ branch is the first branch opcode in the word; the literals before it are
\ what P has passed when it executes.  A word with no branch in slots
\ 0 .. 3 is not a ref, and is refused.
: (RESOLVE)
  (FAILED) a! @ if GO  drop drop drop ;
  GO: drop
  0 (RS) a! !  0 (RN) a! !
  L: (RS) a! @ -4 + -if BADREF  drop
    over a! @  (RS) a! @ (SLOT-OP)
    dup (BRANCH-OP?) if NB  drop drop  jump FOUND
    NB: drop  8 xor if ISLIT  drop  jump NXT
    ISLIT: drop  (RN) a! @ 1 + !
    NXT: (RS) a! @ 1 + !  jump L
  BADREF: jump (NOB)
  FOUND:
    over 1 + (RN) a! @ +
    over xor  (RS) a! @ (MASK) inv and
    if OKR  drop drop drop  ERR-FIT jump (FAIL)
  OKR: drop
    (RS) a! @ (MASK) and
    over a! @  (RS) a! @ (MASK) inv and
    xor  over a! !  drop ;

\ (a word with no branch in slots 0 .. 3 is not a ref: refused)
: (NOB)   drop drop drop  ERR-FIT jump (FAIL)

\ ( op target -- )   a branch to a known target
: (BRANCH)   push (BRANCH>) pop jump (RESOLVE)