\ core.v4 -- the core words the host-node capsules rest on.
\
\ Each is the definition DECOMPOSITION.md gives and the golden-model tests
\ execute (test_foundation.c, test_strings.c, test_terminal.c, test_pictured.c),
\ written here as text for the text assembler (v4/include/v4/text.h).
\
\ Constants the loader supplies:  N-1 (cell bits - 1), NODE-ERROR, CONSOLE-TX,
\ CONSOLE-RX, CONSOLE-STATUS, BASE.
\
\ ERRORS (D-18).  A word that finds an error takes its arguments off the stack
\ and stores a code in NODE-ERROR.  On a node with a prompt that store is a
\ trap: the word goes no further, and the prompt prints the message for the
\ code and ERROR (quit.v4, (RAISED)).  The codes:
\    1 Negative count        2 Not a number        3 Number too long
\    4 Not a character       5 Dictionary full     6 Name missing
\    7 Control structure mismatch     8 Control structures too deep
\   -1 the word has printed its own message

macro SWAP   over push push drop pop pop   endmacro
macro -      push inv pop + inv            endmacro      \ x y -- x-y
macro NEGATE inv 1 +                       endmacro
macro NIP    push drop pop                 endmacro

\ ---- section 4: multiply ------------------------------------------------
header UM*
: UM* ( u1 u2 -- ulo uhi )
  over 1 and inv 1 +  over 2/ and      \ u1 u2 t0       t0 = u2 2/ if u1 odd
  over a!  N-1 push                    \ A: u2          R: loop count
  push over 2/ pop                     \ u1 u2 s t0     s = u1 2/
  L: +* unext                          \ u1 u2 s hi     A: lo
  push drop pop                        \ u1 u2 hi
  2* a -if L0  drop 1 + jump L1   L0: drop   L1:  push
  over -if L2  drop dup jump L3   L2: drop 0  L3:  push
  dup -if L4  drop over 1 and jump L5   L4: drop 0  L5:
  pop + pop +  push
  and 1 and  a 2* +  pop ;

\ ---- section 5.7: doubles ------------------------------------------------
header D+
: D+ ( d1 d2 -- d3 )
  push  over push  push drop pop       \ al bl      R: bh ah
  over over xor -if L1
    drop + -if C1  jump C0
  L1: drop over -if L2
    drop + jump C1
  L2: drop +
  C0: pop pop + ;
  C1: pop pop + 1 + ;

header DNEGATE
: DNEGATE ( d -- -d )
  inv over if L1  drop push inv 1 + pop ;
  L1: drop 1 + ;

\ ---- section 5.3: bytes --------------------------------------------------
\ The shifts are written out, eight to a line, where DECOMPOSITION.md 5.3 has
\ a FOR ... UNEXT loop: a loop keeps its count on the return stack, and C@ and
\ C! are at the bottom of every chain of calls in the compiler capsule, where
\ there is not an entry to spare (D-2).  The result is the same.
macro 8/   2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/   endmacro
macro 8*   2* 2* 2* 2* 2* 2* 2* 2*   endmacro

header C@
: C@ ( baddr -- c )
  dup 2/ 2/ a!  3 and
  if K0  -1 + if K1  -1 + if K2
      drop @  8/ 8/ 8/  255 and ;
  K2: drop @  8/ 8/  255 and ;
  K1: drop @  8/  255 and ;
  K0: drop @  255 and ;

header C!
: C! ( c baddr -- )
  dup 2/ 2/ a!  3 and
  if K0  -1 + if K1  -1 + if K2
      drop  8* 8* 8*  4278190080 and  @ 4278190080 inv and + ! ;
  K2: drop  8* 8*  16711680 and  @ -16711681 and + ! ;
  K1: drop  8*  65280 and  @ -65281 and + ! ;
  K0: drop  255 and  @ -256 and + ! ;

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

\ ---- section 5.10: the console -------------------------------------------
header EMIT
: EMIT ( c -- )        CONSOLE-TX b! !b ;
header KEY
: KEY  ( -- c )
  L: CONSOLE-STATUS b! @b  if WAIT  drop  CONSOLE-RX b! @b ;
  WAIT: drop  jump L

header CR
: CR    ( -- )         10 jump EMIT
header SPACE
: SPACE ( -- )         32 jump EMIT
header COUNT
: COUNT ( baddr -- baddr+1 c )   dup C@  push 1 + pop ;
header TYPE
: TYPE  ( baddr u -- )
  -if OK  drop drop  NODE-ERROR b! 1 !b ;
  OK: if DONE  over C@ EMIT  push 1 + pop  -1 +  jump OK
  DONE: drop drop ;

\ ( x -- )   up to four characters packed in one cell, the first in the low
\ byte: how the capsule prints its own short messages, a literal at a time.
: (EMIT4)
  L: if DONE  dup EMIT  8/  jump L
  DONE: drop ;

\ ---- section 5.8: the number base ----------------------------------------
: (BASE) ( -- b )      \ BASE, or 10 when it is outside 2 .. 36
  BASE b! @b  dup -2 + -if L1  drop drop 10 ;
  L1: drop  dup -37 + -if L2  drop ;
  L2: drop drop 10 ;