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 text being served is in the seven cells (MSG); (REPLY)
\ is the port it came on, by its number; (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
\ three.

\ 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 | -1 )   the port, by its number, that leads toward the node
: (WAY)
  (ROUTE#) a! @ if NONE  -1 +  (ROUTES) a!
  FOR  dup @+ xor if HIT  drop  @+ drop  NEXT
  0
  NONE: drop drop  (ROUTE-DEFAULT) a! @  if NOWAY  (PORT) - ;
  NOWAY: drop  -1 ;
  HIT: drop drop  @+  pop drop  (PORT) - ;

\ WHOLE MESSAGES (MESH.md section 7d).  A message waits on a wire, in the
\ fabric, and not in a node: each wire has a queue of whole messages each
\ way.  A node asks the fabric to look at one, take it, move it to another
\ wire, drop it, or put one on, by the six addresses after its ports:
\     (WIRE)       the port, by its number, that what follows is about
\     (WIRE-A) (WIRE-B)   what the operation needs
\     (WIRE-DO)    the operation: a store here is the asking
\     (WIRE-HOW)   how it went: 0 done, 1 no room, 2 no one on that port,
\                  3 no such message, 4 not a message
\     (WIRE-HAVE)  which wires have a message waiting, a bit to a port
\ The operations:  1 look  2 take  3 move  4 drop  5 put  6 first  7 next
\ 8 sleep  9 sleep for room  10 room.  Each is whole: all of a message
\ moves or none of it.  So a fault or an error in the middle of anything
\ here leaves no message half moved; and nothing here keeps, from one
\ operation to the next, anything a later pass does not set again for
\ itself: every pass over a wire begins by naming the wire and putting its
\ mark at its first message.
\ This replaced a ring of messages waiting in the node's own memory, a
\ list of refusals owed, and messages written and read a word at a time
\ (MESH.md 7a, 7b, 7c.6).  The ports themselves are still written a word at
\ a time for the two things that are not messages: a newborn node's
\ nucleus (PORT!, quit.v4) and a node's requests to its kernel.
\
\ THE STACKS.  All of this runs on the stacks the node's text is using.
\ (SERVE) and what it calls keep to four cells of the data stack and four
\ entries of the return stack, its own call among them; what they need
\ from one operation to the next is in cells.  (ROOM-SERVE) tries that much.

\ ( op -- how )   ask the fabric for the operation, and say how it went
: (DO)   (WIRE-DO) b! !b  (WIRE-HOW) b! @b ;

\ ( port -- )   what is asked next is about that port's wire, by its number.
\ A number that is no port's is no wire: every operation then answers 2.
: (WIRE!)   (WIRE) b! !b ;

\ ( cells port -- how )   has the port's wire that many cells free?  0: it
\ has; 1: it has not; 2: no one is on that port.  Only this node puts
\ messages on the wires that lead from it, so room found stays until it
\ uses it.
: (ROOM?)   (WIRE!)  (WIRE-A) b! !b  10 jump (DO)

\ ( -- )   ROOM FOR WHAT A WAIT DOES.  A node that waits within text -- for
\ an answer, or for room to print -- passes on meanwhile what comes for
\ other nodes, on the stacks the text has left it: four cells of the data
\ stack and four entries of the return stack, (SERVE)'s.  They are tried
\ before anything is taken off a wire or put on one: if they are not there
\ the fault comes here, and the text ends "Stack overflow" with nothing
\ half done (MESH.md 7c.7, 7d.4).
\ (ROOM-SERVE) tries just those, and is what a wait for room does each time
\ a message wakes it.  (ROOM), which AWAIT does once before it waits, tries
\ six cells, as it did when a message was read a word at a time: the wait
\ ends in an error that leaves the stack as it is, and the line from the
\ console that broke it is then done on that stack, where printing needs
\ six (MESH.md 7c.7).
: (ROOM-SERVE)
  0 0 0 0  drop drop drop drop
  0 push  0 push  0 push  0 push  pop drop  pop drop  pop drop  pop drop ;
: (ROOM)
  0 0 0 0 0 0  drop drop drop drop drop drop
  0 push  0 push  0 push  0 push  pop drop  pop drop  pop drop  pop drop ;

\ ( to type -- )   the first six words of a message this node puts, in
\ (OUT-HDR): to, from, type, and the three that are carried: how many nodes
\ may pass it on, sixteen (the TTL: MESH.md 7b.3); ACL tag; sequence.
: (HDR)
  push  (OUT-HDR) a! !+  (ME) b! @b !+  pop !+  16 !+  0 !+  0 !+ ;

\ ( text port -- how )   put the message whose seven words are in (OUT-HDR)
\ and whose text is at the word address given on the wire of the port, by
\ its number.  How it went is the fabric's answer: 0 it is on the wire.
\ THE ROOM KEPT FOR AN ANSWER.  While this node does text, (KEEP) is the
\ port its word of how the text ended will go by, and nothing else it puts
\ on that wire may take the last 8 cells: a message that would is refused
\ here, 1, as if the wire were full.  With no text being done (KEEP) is -1.
: (PUT-ON)
  push  (WIRE-B) b! !b  pop
  dup (WIRE!)
  (KEEP) a! @  xor if KEPT
  GO: drop  (OUT-HDR) (WIRE-A) b! !b  5 jump (DO)
  KEPT: drop  (OUT-HDR)+6 a! @  3 + 2/ 2/  15 +  (WIRE-A) b! !b  10 (DO)  if GO ;

\ REFUSALS (MESH.md 7b, 7d.4).  A message this node cannot pass on is
\ dropped and counted in (LOST), and whoever waits on it is told, by a
\ message of type 4, a NACK, whose one word is the node the refused message
\ was for: its sender; or, for a node's answer (type 3), the node the
\ answer was for, which is the one that waits, about the node that
\ answered.  The NACK is put at once.  If it cannot go -- no way, no one on
\ the port, no room -- it is counted in (LOST) too, and that is the end of
\ it.  Nothing is told for a NACK or for a GONE, type 5: there is no NACK
\ for a NACK.

\ ( -- )   the message the mark of the wire in (WIRE) is at, whose seven
\ words are in (IN), is refused.  A refusal for this node itself -- its own
\ message came back to it -- is counted in (REFUSED) as one that came by a
\ wire would be; or, if it is about the node this one is waiting on,
\ (A-SELF) is set for AWAIT to find (quit.v4).
\ (WIRE) is not what it was afterwards: the NACK went by another.
: (REFUSE)
  4 (DO) drop
  (LOST) a! @  1 +  !
  (IN)+2 a! @  -4 + if NOT  -1 + if NOT  2 + if ANSWER
  drop  (IN) a! @ (ONE) a! !  (IN)+1 a! @  jump TELL        \ about whom it was for; to its sender
  ANSWER: drop  (IN)+1 a! @ (ONE) a! !  (IN) a! @           \ about the node that answered; to whom the answer was for
  TELL: dup (ME) a! @  xor if SELF  drop
  dup 4 (HDR)  4 (OUT-HDR)+6 a! !
  (WAY)  (ONE) SWAP (PUT-ON)  if SENT
  drop  (LOST) a! @  1 +  ! ;
  SENT: drop ;
  SELF: drop drop
  (AWAIT-FROM) a! @ if COUNT  (ONE) a! @  xor if MINE
  COUNT: drop  (REFUSED) a! @  1 +  ! ;
  MINE: drop  1 (A-SELF) a! ! ;
  NOT: drop ;

\ ( -- )   A MESSAGE FOR ANOTHER NODE is passed on (MESH.md section 7): the
\ one the mark of the wire in (WIRE) is at, whose seven words are in (IN),
\ is moved, whole, to the wire that leads toward that node.  It is refused
\ instead if it has been passed on as often as a message may be; if there
\ is no way, or no one on the port; if that wire has no room for it; or if
\ that wire is the one room is kept on and it would take that room.
\ HOW OFTEN.  A message's fourth word is how many more nodes may pass it
\ on; a node sends it with 16, and a move takes one off.  The node that
\ finds 1 there refuses it.  A device sends it with 0, which is taken for
\ 16: so 0 down to -14 are passed on and -15 is refused.  Anything else is
\ nothing a node or a device sent, and is refused.
: (PASS)
  (IN)+3 a! @  -if POS
  14 +  -if OK  jump SPENT
  POS: if OK  -1 + if SPENT  -16 +  -if SPENT
  OK: drop
  (IN) a! @ (WAY)  dup (P-WAY) a! !
  (KEEP) a! @  xor if KEPT
  GO: drop  (P-WAY) a! @ (WIRE-A) b! !b  3 (DO)  if MOVED
  SPENT: drop  jump (REFUSE)
  MOVED: drop ;
  KEPT: drop  (IN)+6 a! @  3 + 2/ 2/  15 +  (P-WAY) a! @ (ROOM?)
  (S-WIRE) a! @ (WIRE!)  if GO  jump SPENT

\ ( -- )   ONE PASS OVER EVERY WIRE THAT HAS A MESSAGE.  What is for another
\ node is passed on, or refused; what is for this node is left where it
\ is.  Fetching (WIRE-HAVE) is what tells the fabric this node has seen
\ what had come: a sleep after this is woken only by what comes later
\ (MESH.md 7d.3).  (S-HAVE) keeps which wires they were, for whoever then
\ looks for what is this node's own, (MINE).
: (SERVE)
  (WIRE-HAVE) b! @b  dup (S-HAVE) a! !  (S-MASK) a! !
  0 (S-WIRE) a! !
  W: (S-MASK) a! @ if END
     dup 2/ !  1 and if NEXTW
     drop  (S-WIRE) a! @ (WIRE!)  6 (DO) drop
     M: (S-WIRE) a! @ (WIRE!)  (IN) (WIRE-A) b! !b  1 (DO)  if LOOKED  jump NEXTW
        LOOKED: drop
        (IN) a! @ (ME) a! @  xor if MINE  drop  (PASS)  jump M
        MINE: drop  7 (DO) drop  jump M
     NEXTW: drop  (S-WIRE) a! @  1 +  !  jump W
  END: drop ;

\ WHAT IS FOR THIS NODE is gone through after (SERVE), a message at a time:
\ (MINE0) begins, and each (MINE) puts the mark of a wire at the next
\ message for this node and its seven words in (IN).  Whoever asked then
\ takes or drops that message -- the mark is then at the one that followed
\ -- or leaves it and goes past it, (SKIP).  The wire is (S-WIRE).

\ ( -- )   begin with the wires (SERVE) found a message on
: (MINE0)   (S-HAVE) a! @ (S-MASK) a! !  -1 (S-WIRE) a! !  0 (S-ON) a! ! ;

\ ( -- flag )   the next message for this node; 0: there are no more
: (MINE)
  L: (S-ON) a! @ if WIRE
     drop  (S-WIRE) a! @ (WIRE!)  (IN) (WIRE-A) b! !b  1 (DO)  if LOOKED
     drop  0 (S-ON) a! !  jump L                                        \ this wire has no more
     LOOKED: drop  (IN) a! @ (ME) a! @  xor if HIT
     drop  7 (DO) drop  jump L
     HIT: drop  -1 ;
  WIRE: drop  (S-WIRE) a! @  1 +  !                                     \ the next wire that had one
     (S-MASK) a! @ if NONE
     dup 2/ !  1 and if NOT
     drop  (S-WIRE) a! @ (WIRE!)  6 (DO) drop  1 (S-ON) a! !  jump L
     NOT: drop  jump L
  NONE: ;

\ ( -- )   go past the message (MINE) found: it stays on its wire
: (SKIP)   (S-WIRE) a! @ (WIRE!)  7 (DO) drop ;

\ ( -- )   take the message (MINE) found, which has one word of text: its
\ seven words stay in (IN), and its word goes to (ONE)
: (TAKE1)   (S-WIRE) a! @ (WIRE!)  (IN) (WIRE-A) b! !b  (ONE) (WIRE-B) b! !b  2 (DO) drop ;

\ ( -- n )   the number of this node's console: the one it was told of, or
\ with none told of, whoever sent the text it is doing
: (A-CONSOLE)
  (CONSOLE) a! @  if C0 ;
  C0: drop  (MSG)+1 a! @ ;

\ ( -- )   A LINE FROM THE CONSOLE BREAKS A WAIT FOR ROOM (MESH.md 7d.4).
\ If text for this node from its console is on a wire, the text being
\ done ends in error 21, Interrupted; the text from the console stays
\ where it is, to be done when this one has been finished with.  Only
\ text that is still being done is broken: not once it has ended in an
\ error -- NODE-ERROR holds the code from then until the next text begins
\ -- or been finished with, (QUIET), when what waits for room is only what
\ it printed and the word of how it ended.
: (BREAK?)
  (QUIET) a! @ if TEXT  drop ;
  TEXT: drop  NODE-ERROR b! @b if CLEAN  drop ;
  CLEAN: drop  (MINE0)
  L: (MINE) if NO
     drop  (IN)+2 a! @  -1 + if T
     KEEP: drop  (SKIP)  jump L
     T: drop  (A-CONSOLE)  (IN)+1 a! @  xor if BRK  jump KEEP
     BRK: drop  NODE-ERROR b! 21 !b ;
  NO: drop ;

\ ( -- how )   WAIT UNTIL THE WIRE of the port (W-PORT) has (W-NEED) cells
\ free.  0: it has.  2: no one is on that port.  The node sleeps until
\ there is room or a message comes; woken by a message it passes on what
\ is for other nodes, (SERVE), and sleeps again.  It is the one thing a
\ node waits to put: what a text prints (MESH.md 7d.1, ruling 3).
: (WAIT-ROOM)
  L: (W-PORT) a! @ (WIRE!)  (W-NEED) a! @ (WIRE-A) b! !b  9 (DO)
     if DONE  -1 + if WOKEN  drop  2 ;
     WOKEN: drop  (ROOM-SERVE)  (SERVE)  (BREAK?)  jump L
  DONE: ;

\ ( -- )   send what has been printed, to where (PRINT-TO) says, by the port
\ (PRINT-PORT): a message of type 2, its characters four to a word, the
\ first lowest.  quit.v4 sets those two when text for this node arrives.
\ It waits for room on the wire, and for the 8 cells kept as well when the
\ wire is the one the answer goes by.  The characters are made ready in
\ (OUT-TEXT), not where they are: until the message is on the wire the
\ buffer is as it was, and a fault on the way leaves it to be sent again.
\ The three cells and two return entries this needs are tried first.
\ WITH NO ONE ON THE PORT what was printed cannot be sent.  While the text
\ is being done that is its error, 18; once it has been finished with
\ there is no one to tell: it is let go and counted in (LOST).
: (FLUSH-OUT)
  (OUT^) a! @  (OUT) xor if NONE  drop
  0 0 0  drop drop drop  0 push  0 push  pop drop  pop drop
  (OUT^) a! @  (OUT) -  3 + 2/ 2/  7 +
  (PRINT-PORT) a! @  (KEEP) a! @  xor if SAME  drop  jump NEED
  SAME: drop  8 +
  NEED: (W-NEED) a! !  (PRINT-PORT) a! @ (W-PORT) a! !
  (WAIT-ROOM) if ROOM
  drop  (QUIET) a! @ if TELL
  LOSE: drop  (OUT) (OUT^) a! !  (LOST) a! @  1 +  ! ;
  TELL: drop  NODE-ERROR b! 18 !b ;
  ROOM: drop
  (PRINT-TO) a! @  2 (HDR)
  (OUT^) a! @  (OUT) -  dup (OUT-HDR)+6 a! !
  3 + 2/ 2/  -1 +  push  (OUT-TEXT)  pop  (OUT) a!
  FOR  @+  @+ 8* +  @+ 8* 8* +  @+ 8* 8* 8* +  over b! !b  1 +  NEXT
  drop
  (OUT-TEXT)  (PRINT-PORT) a! @  (PUT-ON)  if SENT  jump LOSE
  SENT: drop  (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.
\ A BUFFER FOUND FULL is sent first.  It is full when a flush of it ended
\ in a fault -- the stack too deep to begin a message -- and what is printed
\ next is that fault's own message: put where (OUT^) points, it would go
\ past the buffer's end, and (OUT^) would never again be at the end to be
\ flushed (MESH.md 7c.6).
header EMIT
: EMIT ( c -- )
  255 and  a push  push                  \ A, and then the character, to the return stack
  (OUT^) b! @b  (OUT)+256 xor if STALE  drop  jump PUT
  STALE: drop  (FLUSH-OUT)
  PUT:
  (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 ;