LithosAnanake/v4/capsule/core.v4

\ 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, (MSG), (REPLY), (ME), (OUT),
\ (OUT^), (CONSOLE), (ROUTES), (ROUTE#), (ROUTE-DEFAULT), (PRINT-TO),
\ (PRINT-PORT).
\
\ 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
\    9 Shift count out of range      10 Protected word
\   11 Division by zero (Q./)        12 Argument out of range
\   13 Block out of range            14 No block is being loaded
\   15 Deferred word not set         16 Not a word
\   17 Storage refused               18 No one on that port
\   19 Message refused               20 Node gone
\   21 Interrupted
\   -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 -------------------------------------------
\ ---- what a node prints (docs/v4.0.0/MESH.md section 6) ------------------------
\ A node has no console of its own.  It does what a message asks, and what
\ it prints while doing it is sent as a message: to the node in (CONSOLE), or
\ if that is 0 to whoever sent the text; by the port that leads there, or if
\ this node knows of none, by the port the text came on.  A message is seven words and then its text, four
\ characters to a word:
\     to, from, type, heat and TTL, ACL tag, sequence, length in characters
\ The types:  1 text to be interpreted   2 what a node printed   3 how the
\ text ended (one word of text: 0 QUIT, 1 completed, 2 an error).
\ The header of the message being served is in the seven cells (MSG); (REPLY)
\ is the address of the port it came on; (ME) is this node's number.
\
\ Characters are kept in (OUT), 256 of them, a character to a cell, and sent
\ when it is full and when the text has been done with (quit.v4).  (OUT^)
\ is where the next goes.
\
\ THE STACK.  What prints may be run with the data stack all but full: EMIT
\ has always needed one free cell and no more, and still does -- it keeps
\ the character and A on the return stack while it works.  Sending needs
\ two.

\ FINDING THE WAY (MESH.md section 7).  A node knows its ports and nothing of
\ the shape they are wired in.  Whoever wires it tells it, for a node, which
\ port leads toward that node: the table (ROUTES), (ROUTE#) entries of a
\ node's number and a port's address; and (ROUTE-DEFAULT), the port for any
\ node that is not in the table, or 0.

\ ( node -- port | 0 )   the address of the port that leads toward the node
: (PORT-FOR)
  (ROUTE#) a! @ if NONE  -1 +  (ROUTES) a!
  FOR  dup @+ xor if HIT  drop  @+ drop  NEXT
  0
  NONE: drop drop  (ROUTE-DEFAULT) a! @ ;
  HIT: drop drop  @+  pop drop ;

\ LOOKING BEFORE WRITING (MESH.md section 7a).  A write waits until the
\ neighbour reads, and a node that is waiting to write reads nothing: two
\ neighbours that each began to write to the other would wait for ever.  So
\ a node does not begin a message until it has looked, (GATE):
\   - while any neighbour is waiting to write to it, it takes that message
\     in and keeps it with the messages waiting, to deal with when it has
\     nothing else to do;
\   - then, if the neighbour it means to write to is waiting to read, it
\     writes;
\   - and if that neighbour is not, it writes all the same when the
\     neighbour's number is the higher of the two, and otherwise looks
\     again.  Of two neighbours one only may wait to write to the other, and
\     it is the lower: so those that wait are waiting on ever higher
\     numbers, and the highest of them is not waiting to write; it is
\     looking, and takes in what is being written to it.
\ (WRITERS) and (READERS) are the node's two looks at its neighbours, a bit
\ for each port.  (NEAR) is the number of the node on each port, told by
\ whoever wires it (NEIGHBOUR, quit.v4); a port not told of -- a device's
\ -- is written to only when what is there is waiting to read.
\
\ THE MESSAGES WAITING are kept in (MQ) .. (MQ-END), one after another,
\ going round: for each its seven words, the port it came on, and its text.
\ (MQ-HEAD) is where the oldest begins, (MQ-TAIL) where the next will go,
\ (MQ#) how many cells are taken.  One that there is no room for is read to
\ its end and let go, and (LOST) counts it.

\ ( mask index -- bit )
: (BIT)
  if Z  -1 +  FOR 2/ NEXT  1 and ;
  Z: drop  1 and ;

\ ( mask -- index )   the lowest port in it; the mask is not zero
: (LOW)
  0 push
  L: dup 1 and if UP  drop drop  pop ;
  UP: drop  2/  pop 1 + push  jump L

\ ( w -- )   one more cell of the messages waiting.  B is kept.
: (MQ!)
  (MQ-TAIL) a! @ a!  !+
  a (MQ-END) xor if WRAP  drop  a  jump SET
  WRAP: drop  (MQ)
  SET: (MQ-TAIL) a! !
  (MQ#) a! @  1 +  ! ;

\ ( -- w )   the oldest cell of the messages waiting, which goes
: (MQ@)
  (MQ-HEAD) a! @ a!  @+
  a (MQ-END) xor if WRAP  drop  a  jump SET
  WRAP: drop  (MQ)
  SET: (MQ-HEAD) a! !
  (MQ#) a! @  -1 +  ! ;

\ REFUSALS (MESH.md section 7b).  A message this node has no room for, or
\ no way to pass on, is let go and counted in (LOST); and its sender is
\ told, by a message of type 4, a NACK, whose one word is the node the
\ refused message was for.  A node finds it has no room while it is taking
\ messages in so as to be free to write, where it cannot begin a message
\ of its own: so it notes what it owes, (OWE), in the eight pairs at
\ (OWED) -- whom it is owed to, and the node the message was for -- and
\ sends it when it next has nothing else to do, (PAY).  With eight owed
\ already, one more is let go and counted.  Nothing is owed for a NACK or
\ for a GONE, type 5: there is no NACK for a NACK.  The last 36 cells of
\ the messages waiting are kept for those two types, so that ordinary
\ messages cannot take all the room.

\ ( to about -- )   a refusal is owed to the node `to`, about the node `about`
: (OWE)
  (OWED#) a! @  -8 +  -if NOROOM
  drop  (OWED#) a! @  2*  (OWED) +  a!
  push  !+  pop !
  (OWED#) a! @  1 +  ! ;
  NOROOM: drop drop drop  (LOST) a! @  1 +  ! ;

\ ( port to -- )   the seven words of a message being taken in, and the
\ port, go into (MQ-HDR).  B is at the port, by its address, and `to` is
\ the message's first word, already read from it.
: (TAKE-HDR)
  (MQ-HDR) a! !+  5 FOR @b !+ UNEXT  ! ;

\ ( -- )   the message whose seven words are in (MQ-HDR) is kept with the
\ messages waiting: its text is read from the port B is at.  A length
\ below zero, or above what a message carries, is kept as -1 with no text:
\ a longer one is read to its end first, so that what follows it is not
\ taken for a message.
: (TAKE-KEEP)
  (MQ-HDR)+6 a! @  -if SIZED
  drop  -1 (MQ-HDR)+6 a! !  0  jump COUNTED
  SIZED: dup -1025 + -if LONG  drop  3 + 2/ 2/  jump COUNTED
  LONG: drop  3 + 2/ 2/  -1 +  FOR @b drop UNEXT  -1 (MQ-HDR)+6 a! !  0
  COUNTED:                                                            \ ( n )  how many words of text follow
  dup  (MQ#) a! @  +                                                  \ what it would come to
  (MQ-HDR)+2 a! @  -4 +  -if KEPT-FOR                                 \ a NACK or a GONE may use the room kept for them
  drop  -MQ-ORDINARY +  jump ROOM
  KEPT-FOR: drop  -MQ-ROOM +
  ROOM: -if FULL
  drop  push
  (MQ-HDR) a! @ (MQ!)    (MQ-HDR)+1 a! @ (MQ!)  (MQ-HDR)+2 a! @ (MQ!)  (MQ-HDR)+3 a! @ (MQ!)
  (MQ-HDR)+4 a! @ (MQ!)  (MQ-HDR)+5 a! @ (MQ!)  (MQ-HDR)+6 a! @ (MQ!)  (MQ-HDR)+7 a! @ (MQ!)
  pop  if NOTEXT  -1 +  FOR @b (MQ!) NEXT ;
  NOTEXT: drop ;
  FULL: drop  if READ  -1 +  FOR @b drop UNEXT  jump LOSE
  READ: drop
  LOSE: (LOST) a! @  1 +  !
  (MQ-HDR)+2 a! @  -4 +  -if NOT-OWED                                 \ nothing is owed for a NACK or a GONE
  drop  (MQ-HDR)+1 a! @  (MQ-HDR) a! @  jump (OWE)                    \ to whoever sent it, about whom it was for
  NOT-OWED: drop ;

\ ( port to -- )   take in a message and keep it
: (TAKE)   (TAKE-HDR)  jump (TAKE-KEEP)

\ ( port -- )   wait until a message may be begun on the port, by its
\ address, taking in whatever is being written to this node meanwhile; and
\ leave B at the port.  The port is kept in (GATE-PORT), not on the stack:
\ this is run with the stack as full as EMIT may be.
: (GATE)
  (GATE-PORT) a! !
  L: (WRITERS) b! @b  if QUIET
     (LOW)  (PORT) +  dup b!  @b (TAKE)  jump L
  QUIET: drop
     (GATE-PORT) a! @  (PORT) -  (NEAR) +  a! @  if ASK
     (ME) a! @  -  -if GO  jump ASK                                   \ its number less this node's
  GO: drop  (GATE-PORT) a! @ b! ;                                     \ the neighbour's is the higher
  ASK: drop
     (READERS) b! @b  (GATE-PORT) a! @  (PORT) -  (BIT)  if NOTYET
     drop  (GATE-PORT) a! @ b! ;                                      \ it is waiting to read
  NOTYET: drop  jump L

\ ( type -- )   words 1 to 5 of a message this node sends: from, type, and
\ the three that are carried and not used yet.  Its caller has put B at the
\ port and sent word 0, whom it is to, and sends the length and the text.
\ Each write waits for the neighbour to take it.
: (HDR)
  (ME) a! @ !b                           \ from
  !b                                     \ type
  0 !b  0 !b  0 !b ;                     \ heat and TTL, ACL tag, sequence

\ ( -- )   send one refusal this node owes, if it owes any: the one noted
\ last.  With no way to whom it is owed, it is let go and counted.
: (PAY)
  (OWED#) a! @  if NONE
  -1 +  dup !
  2*  (OWED) +  a!  @+  @                \ to about
  over (PORT-FOR)  if NOWAY
  (GATE)  over !b                        \ to
  4 (HDR)  4 !b  !b  drop ;              \ from, type 4; four characters; about
  NOWAY: drop drop drop  (LOST) a! @  1 +  ! ;
  NONE: drop ;

\ ( -- )   send what has been printed, to where (PRINT-TO) says, by the port
\ (PRINT-PORT): its length, then its characters, four to a word, the first
\ lowest.  quit.v4 sets those two when text for this node arrives.
: (FLUSH-OUT)
  (OUT^) a! @  (OUT) xor if NONE  drop
  (PRINT-PORT) a! @ (GATE)  (PRINT-TO) a! @ !b
  2 (HDR)
  (OUT^) a! @  (OUT) -  dup !b
  3 + 2/ 2/  -1 +  (OUT) a!
  FOR  @+  @+ 8* +  @+ 8* 8* +  @+ 8* 8* 8* +  !b  NEXT
  (OUT) (OUT^) a! ! ;
  NONE: drop ;

\ EMIT puts the character with what has been printed.  Everything the node
\ prints goes through EMIT.  A is kept: the words that print have always
\ been free to use it across an EMIT.  As v3, only the low 8 bits of the
\ character are printed.
header EMIT
: EMIT ( c -- )
  255 and  a push  push                  \ A, and then the character, to the return stack
  (OUT^) b! @b a!  pop !+  a !b          \ the character goes where (OUT^) points, which moves on
  a (OUT)+256 xor if FULL  drop  pop a! ;
  FULL: drop  (FLUSH-OUT)  pop a! ;
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 ;