admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
380f1cc6ecc0d9eda173bd883ec6cd411d76115b
LithosAnanake/v4/capsule/core.v4
T
rajamesandClaude Opus 5.5 ec817a8264 fix(v4.0.0): a waiting node goes on passing on and paying; KILL is not held by a stuck node 
Found in the five-node test, each with a check that failed first:
- A node with answers it could not give to two stuck senders began no
  text at all.  It now holds back only text from a sender whose own
  answer is still with it.
- KILL waited to tell a stuck node, and a typed line that broke it left
  the nodes after it untold.  GONE is put with the messages waiting, as
  how text ended is, and goes when it can.
- So that 'tell, then wait' still works, AWAIT does what (IDLE) does but
  for beginning text: it looks through the messages waiting, offers what
  is to be passed on and what is owed, and sleeps in the wait.  A waiting
  node no longer keeps back what passes through it.
- A node in the wait with an offer on a port that turns out to have
  nothing on it is woken and told so (which port: 2 * V4_PORTS + k); no
  error is raised on it.  (GATE) makes it error 18; (IDLE) and AWAIT let
  the message go.  Before, removing a node raised 'No one on that port'
  on the unrelated text of a neighbour that had something queued for it.

make -C v4 test and sanitize at both widths, hosted-check.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-08 01:00:33 -04:00

413 lines
18 KiB
Plaintext
Raw Blame History

\ 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 ;
\ BEGINNING A MESSAGE: THE WAIT (MESH.md section 7c). 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,
\ and a node that wrote to one that was stuck would be stuck with it. So
\ a node does not write the first word of a message. It offers it, (GATE):
\ the word is stored at the port's offer address, and the node then reads
\ the wait, where it sleeps until the offer is taken or a word comes for
\ it, whichever is first. If a word comes, that message is taken in and
\ kept with the messages waiting, and the node offers again. When the
\ offer is taken the neighbour has the first word and reads to the end:
\ the rest is written, each word waiting for it.
\ (OFFER) is the offer address of port 0, and (WAIT) the wait. (READERS)
\ is the node's look at its neighbours, a bit for each port that has one
\ waiting to read, and above those a bit for each port that has anything
\ on it at all. (NEAR) is the number of the node on each port, told by
\ whoever wires it (NEIGHBOUR, quit.v4): it is how a node knows its centre.
\
\ 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 ;
\ ( 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-SET). 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`.
\ Owed to this node itself -- its own message came back to it and was let
\ go here -- it is put with the messages waiting, as if it had come by a
\ port, in the room kept for refusals.
: (OWE)
over (ME) a! @ xor if SELF drop
(OWED#) a! @ -8 + -if NOROOM
drop (OWED#) a! @ 2* (OWED) + a!
push !+ pop !
(OWED#) a! @ 1 + ! ;
SELF: drop 1 (MQ#) a! @ + -MQ-ROOM + -if NOROOM
drop push (MQ!) (ME) a! @ (MQ!) 4 (MQ!) 0 (MQ!) 0 (MQ!) 0 (MQ!) 4 (MQ!) 0 (MQ!) pop (MQ!) ;
NOROOM: drop drop drop (LOST) a! @ 1 + ! ;
\ ( from to type -- ) a message of that type, from the one node for the
\ other, has been let go here. Whoever is waiting on it is told: its
\ sender; or, for a node's answer (type 3), the node the answer was for,
\ which is the one that waits. Nothing is owed for a NACK or a GONE.
: (TELL-OF)
dup -4 + if NOT -1 + if NOT drop
-3 + if ANSWER drop jump (OWE) \ to its sender, about whom it was for
ANSWER: drop SWAP jump (OWE) \ to whom it was for, about the node that answered
NOT: drop drop drop drop ;
\ ( port -- flag ) is there anything on that port, by its address?
: (THERE)
(PORT) - -PORTS - (READERS) b! @b SWAP jump (BIT)
\ ( 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 -1 + 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)+1 a! @ (MQ-HDR) a! @ (MQ-HDR)+2 a! @ jump (TELL-OF)
\ ( port to -- ) take in a message and keep it
: (TAKE) (TAKE-HDR) jump (TAKE-KEEP)
\ ( -- how ) THE WAIT, once. Whatever has been offered stands until
\ this returns. 0: a word came for this node instead; that whole message
\ has been taken in and kept, (TAKE), and its seven words are still in
\ (MQ-HDR). -1: an offer was taken; B is at the port it was taken on, and
\ (GATE-PORT) holds that port's address. 1: there is nothing on a port
\ that had an offer: no one will ever take it.
: (OFFERS)
(WAIT) b! @b push (PORT)+9 b! @b \ ( which ) R: the word
dup -PORTS + -if TAKEN
drop (PORT) + dup b! pop (TAKE) 0 ; \ a word, from that port: the message's first
TAKEN: dup -PORTS + -if NOONE \ ( which k x ) k: the port, by its number
drop (PORT) + (GATE-PORT) a! ! drop pop drop
(GATE-PORT) a! @ b! -1 ;
NOONE: drop drop drop pop drop 1 ;
\ ( w port -- ) BEGIN A MESSAGE: the word, its first, is offered on the
\ port, by its address, until it is taken; whatever is written to this
\ node meanwhile is taken in. B is left at the port. The two are kept in
\ (GATE-WORD) and (GATE-PORT), not on the stack: (GATE1), which is this
\ with the word already in (GATE-WORD), is run with the stack as full as
\ EMIT may be.
\ TEXT FROM THE CONSOLE for this node, coming while text it is doing waits
\ here, ends that text in error 21, Interrupted (MESH.md 7c.3); it is with
\ the messages waiting and is done next. It is how a node whose text must
\ begin a message to a node that is stuck is typed to. Not while (QUIET)
\ is set: what waits then is no text's doing.
\ With nothing on the port it is error 18.
: (GATE1) ( port -- )
(GATE-PORT) a! !
L: (GATE-WORD) a! @ (GATE-PORT) a! @ -PORTS - 4 + a! ! \ the offer
(OFFERS) if CAME -if NOONE drop ;
NOONE: drop NODE-ERROR b! 18 !b ; \ no one on that port
CAME: drop
(QUIET) a! @ if TEXTS drop jump L
TEXTS: drop
(MQ-HDR) a! @ (ME) a! @ xor if MINE drop jump L
MINE: drop
(MQ-HDR)+2 a! @ -1 + if TEXT drop jump L
TEXT: drop
(CONSOLE) a! @ if C0 jump C1
C0: drop (MSG)+1 a! @ \ no console told of: whoever sent the text being done
C1: (MQ-HDR)+1 a! @ xor if BREAK drop jump L
BREAK: drop NODE-ERROR b! 21 !b ;
: (GATE) ( w port -- ) push (GATE-WORD) a! ! pop jump (GATE1)
\ ( 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
16 !b 0 !b 0 !b ; \ how many nodes may pass it on (the TTL: MESH.md 7b); ACL tag; sequence
\ PAYING WHAT IS OWED (MESH.md 7c.3). Every refusal owed is offered at
\ once, each on the port it goes by, one to a port, with whatever the node
\ has to pass on (quit.v4, (IDLE)), and the node sleeps in the wait: so
\ one owed to a node that is stuck does not keep back one owed to a node
\ that waits for it, and the node takes in whatever is written to it
\ meanwhile. One there is no way for, or whose way is a
\ port with nothing on it, is let go and counted first. (PAY-K) has a
\ cell for each port: which refusal is offered there, counted from 1; 0,
\ none; -1, a message being passed on.
\ ( k -- ) the k-th refusal owed is done with: the last takes its place
: (PAID)
(OWED#) a! @ -1 + dup !
2* (OWED) + a! @+ @
push push 2* (OWED) + a! pop !+ pop ! ;
\ ( k -- ) the k-th refusal owed is let go if it cannot be sent at all
: (PAY-DROP)
dup 2* (OWED) + a! @ \ k to
(PORT-FOR) if NOWAY \ k port
(THERE) if GONE drop drop ;
GONE:
NOWAY: drop (LOST) a! @ 1 + ! jump (PAID)
\ ( k -- ) offer the k-th refusal owed on its port, if nothing is there yet
: (PAY-OFFER)
dup push 2* (OWED) + a! @ \ to R: k (the stack is kept shallow: this runs between lines)
dup (PORT-FOR) (PORT) - \ to n the port, by its number
dup (PAY-K) + a! @ if FREE
drop drop drop pop drop ;
FREE: drop
dup push (OFFER) + a! ! \ the message's first word, whom it is to
pop pop 1 + SWAP (PAY-K) + a! ! ;
\ ( -- ) let go every refusal owed that cannot be sent; no port has an
\ offer; then offer each that is left on its port
: (PAY-SET)
(OWED#) a! @ if NONE
-1 + FOR pop dup push (PAY-DROP) NEXT
jump CLEAR
NONE: drop
CLEAR: (PAY-K) a! PORTS-1 FOR 0 !+ NEXT
(OWED#) a! @ if NONE2
-1 + FOR pop dup push (PAY-OFFER) NEXT ;
NONE2: drop ;
\ ( k -- ) the offer of the k-th refusal owed was taken, and B is at the
\ port: its other words are written, and it is done with
: (PAY-GO)
dup 2* (OWED) + 1 + a! @ \ k about
4 (HDR) 4 !b !b \ from, type 4; four characters; about
jump (PAID)
\ ( -- ) 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-TO) a! @ (GATE-WORD) a! ! (PRINT-PORT) a! @ (GATE1)
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 ;
Reference in New Issue View Git Blame Copy Permalink