\ words.v4 -- more of the FORTH vocabulary: the stack, comparison, double,
\ mixed, shift and string words that are short runs of opcodes or small loops.
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.7, 5.9)
\ and the mesh-node tests execute (test_cells.c, test_foundation.c,
\ test_strings.c), here as words of the host node's vocabulary.  Rests on
\ core.v4, forth.v4 and numout.v4.
\
\ Constants the loader supplies:
\   MAX-INT   the largest positive number: every bit but the top one
\   (X)       word address of four cells of scratch for COMPARE and SEARCH

\ ---- stack ----
header 2SWAP
: 2SWAP ( a b c d -- c d a b )   ROT push ROT pop ;
header 2OVER
: 2OVER ( a b c d -- a b c d a b )   push push over over pop pop  jump 2SWAP
header 2ROT
: 2ROT  ( a b c d e f -- c d e f a b )   push push 2SWAP pop pop  jump 2SWAP
header 2>R inline compile-only   : 2>R   SWAP push push ;
header 2R> inline compile-only   : 2R>   pop pop SWAP ;
header 2R@ inline compile-only   : 2R@   pop pop over over push push SWAP ;
header NOP inline       : NOP'    nop ;
header TRUE inline      : TRUE    -1 ;
header FALSE inline     : FALSE   0 ;
header INVERT inline    : INVERT  inv ;

\ ---- memory ----
header 2@
: 2@   ( addr -- lo hi )   a! @+ @ ;
header 2!
: 2!   ( lo hi addr -- )   a! SWAP !+ ! ;
header -!
: -!   ( n addr -- )       a! NEGATE @ + ! ;

\ ---- comparison ----
header 0<>
: 0<>   if Z  drop -1 ;   Z: ;
header 0>
: 0>    -if NN  drop 0 ;   NN: if Z  drop -1 ;   Z: ;
header <>
: <>    xor jump 0<>
header <=
: <=    GREATER jump 0=
header >=
: >=    LESS jump 0=
header U<
: U<    over over xor -if SAME  drop NIP jump 0<
        SAME: drop - jump 0<
header U>
: U>    SWAP jump U<
header ABS
: ABS   -if P  inv 1 +  P: ;
header MAX
: MAX   over over LESS  if A  drop  push drop pop ;   A: drop drop ;
header MIN
: MIN   over over LESS  if B  drop drop ;   B: drop  push drop pop ;
header WITHIN
: WITHIN ( n low high -- flag )   push over pop  LESS  push  LESS  inv  pop and ;

\ ---- shifts ----
\ As v3, a count that is negative or as large as the cell is wide is an
\ error (code 9, "Shift count out of range").
header LSHIFT
: LSHIFT ( x n -- x' )
  -if NN  jump BAD
  NN: dup N-1 inv + -if BAD2  drop
  L: if DONE  -1 + push 2* pop  jump L
  DONE: drop ;
  BAD2: drop
  BAD: drop drop  NODE-ERROR b! 9 !b ;
header RSHIFT
: RSHIFT ( x n -- x' )   \ zeros come in at the top
  -if NN  jump BAD
  NN: dup N-1 inv + -if BAD2  drop
  L: if DONE  -1 + push 2/ MAX-INT and pop  jump L
  DONE: drop ;
  BAD2: drop
  BAD: drop drop  NODE-ERROR b! 9 !b ;

\ ---- doubles and mixed ----
header D-
: D-    DNEGATE jump D+
header DABS
: DABS  -if P  jump DNEGATE   P: ;
header D0=
: D0=   OR jump 0=
header D0<
: D0<   push drop pop  jump 0<
header D=
: D=    D- jump D0=
header D2*
: D2*   2* over -if P  drop 1 + jump J   P: drop   J:  push 2* pop ;
header D2/
: D2/   push a! 0 pop  +*  push drop a pop ;
header M+
: M+    S>D jump D+
header M-
: M-    S>D DNEGATE jump D+

\ ( d1 d2 -- d1 d2 flag )   the flag's top bit is set exactly when d1 < d2
: (D<)
  dup push  push over pop  over over xor if TIE
  drop over over xor -if HS  drop drop jump S1
  HS: drop push inv pop + inv
  S1: -if N1  drop -1 jump D1   N1: drop 0
  D1: pop SWAP ;
  TIE: drop drop drop  dup push  push over pop
  over over xor -if LS  drop NIP jump S2
  LS: drop push inv pop + inv
  S2: -if N2  drop -1 jump D2   N2: drop 0
  D2: pop pop ROT ;
header D<
: D<    (D<)  push drop drop drop drop pop ;
header DMAX
: DMAX  (D<) if L  drop push push drop drop pop pop ;   L: drop drop drop ;
header DMIN
: DMIN  (D<) if L  drop drop drop ;   L: drop push push drop drop pop pop ;

\ ---- strings and memory ----
header ?TERMINAL
: ?TERMINAL ( -- flag )   CONSOLE-STATUS b! @b ;

header CMOVE>
: CMOVE> ( src dst u -- )
  -if OK  drop drop drop  NODE-ERROR b! 1 !b ;
  OK: if DONE  -1 + push
      over pop dup push + C@
      over pop dup push + C!
      pop  jump OK
  DONE: drop drop drop ;

\ FORTH-79: n cells from addr1 to addr2, the cell at addr1 first.
header MOVE
: MOVE ( addr1 addr2 n -- )
  -if OK  drop drop drop ;
  OK: if DONE  push  over a! @  over a! !  1 + push 1 + pop  pop -1 +  jump OK
  DONE: drop drop drop ;

header FILL
: FILL ( baddr u c -- )
  SWAP push SWAP pop                         \ c baddr u
  -if OK  drop drop drop  NODE-ERROR b! 1 !b ;
  OK: if DONE  push  over over C!  1 +  pop -1 +  jump OK
  DONE: drop drop drop ;
header ERASE
: ERASE ( baddr u -- )   0 jump FILL
header BLANK
: BLANK ( baddr u -- )   32 jump FILL

header -TRAILING
: -TRAILING ( baddr u -- baddr u' )
  -if L  drop 0 ;
  L: if DONE  over over + -1 + C@  -32 +  if SP  drop ;
  SP: drop  -1 +  jump L
  DONE: ;

header COMPARE
: COMPARE ( a1 u1 a2 u2 -- n )
  -if A drop 0 A:  (X)+1 b! !b
  SWAP  -if B drop 0 B:  dup (X) b! !b
  (X)+1 b! @b
  over over -  -if GE  drop drop jump M
  GE: drop push drop pop
  M:
  L: if EQ  push
      over C@ over C@  -  if SAME
      -if GT  drop drop drop pop drop  -1 ;
      GT:     drop drop drop pop drop   1 ;
      SAME: drop  1 + push 1 + pop  pop -1 +  jump L
  EQ: drop drop drop  (X) b! @b  (X)+1 b! @b  -
      -if NN  drop -1 ;
      NN: if ZZ  drop 1 ;
      ZZ: ;

header SEARCH
: SEARCH ( a1 u1 a2 u2 -- a3 u3 flag )
  -if A drop 0 A:  (X)+1 b! !b  (X) b! !b
  -if B drop 0 B:  dup (X)+3 b! !b  over (X)+2 b! !b
  L: dup (X)+1 b! @b -  -if TRY
      drop drop drop  (X)+2 b! @b  (X)+3 b! @b  0 ;
  TRY: drop  over  (X) b! @b  (X)+1 b! @b
  I: if MATCH  push
      over C@ over C@ xor  if SAME
      drop drop drop pop drop  push 1 + pop -1 +  jump L
      SAME: drop  1 + push 1 + pop  pop -1 +  jump I
  MATCH: drop drop drop  -1 ;

header SCAN
: SCAN ( baddr u c -- baddr' u' )
  255 and push  -if L drop 0
  L: if DONE  over C@  pop dup push  xor  if FOUND
      drop  push 1 + pop  -1 +  jump L
  FOUND: drop
  DONE: pop drop ;
header SKIP
: SKIP ( baddr u c -- baddr' u' )
  255 and push  -if L drop 0
  L: if DONE  over C@  pop dup push  xor  if SAME  drop jump DONE
  SAME: drop  push 1 + pop  -1 +  jump L
  DONE: pop drop ;