admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
2b587206ee3c1ec5db66ed68a7ac0a926b1c727e
LithosAnanake/v4/capsule/quit.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

682 lines
34 KiB
Plaintext
Raw Blame History

\ quit.v4 -- a line of text, interpreted; how it ends; and the words that
\ print text written in the source.
\
\ DECOMPOSITION.md 5.15 and 5.10: QUIT ABORT ABORT" (ABORT") ." (."). Part of
\ the compiler capsule. Rests on all the files before it.
\
\ A NODE IS SENT TEXT (docs/v4.0.0/MESH.md section 6). It does not read its
\ own command line and prints no prompt. A node with nothing to do waits at
\ its ports; a neighbour writes it a message; if that is text for this node
\ it is interpreted; what it printed goes back as a message, and then a
\ message saying how the text ended:
\ 1 it completed a console says " ok"
\ 2 it ended in an error the message is already printed; " ERROR"
\ 0 QUIT nothing is said
\ What a console then shows is v3's:
\ ok> 65 EMIT the console's prompt, and the line
\ A ok what the line printed, then " ok"
\ ok> NOSUCH
\ UNKNOWN WORD: 'NOSUCH'
\ ERROR
\ ok> -1 @
\ Address out of range an address fault (D-14), from any depth
\ ERROR
\ KEY, EXPECT and QUERY are FORTH-79 words that read characters, as before;
\ they are not how text reaches the node. They still read the console's
\ registers, CONSOLE-RX and CONSOLE-STATUS, and not a message.
\
\ THE STACKS are guarded (D-16): each counts what it holds, and a push onto
\ a full one or a pop from an empty one is a fault. So QUIT and ABORT, which
\ never return to whatever ran them, must empty the return stack, and ABORT
\ the data stack too. A store to RSTACK-DEPTH or DSTACK-DEPTH does that.
\
\ Constants the loader supplies:
\ (LINE-STATUS) word address of the variable: how the last text ended
\ (MSG) (REPLY) (ME) (OUT) (OUT^) see core.v4, "what a node prints"
\ (PORT) word address of the node's port 0; (PORT)+8 is "any port" and
\ (PORT)+9 the port the last read from that came on
\ (Q) word address of four cells of scratch, which system.v4 and
\ blocks.v4 use too
\ DSTACK-DEPTH RSTACK-DEPTH word addresses of the stack registers
\ ( -- ) empty the return stack. `a` is only something to store: any
\ store to the register empties the stack, and `a` needs nothing to be on
\ the data stack. One cell of the data stack is used for a moment.
macro R-CLEAR RSTACK-DEPTH b! a !b endmacro
\ ( -- ) stop compiling; forget the word being built and any open control
\ structures. A definition that was under way stays hidden.
: (RESET) 0 STATE a! ! (CG-RESET) CFBASE (CFP) a! ! ;
\ ( s -- ) the text is done with. What it printed is sent, then a message
\ saying how it ended -- 0 QUIT, 1 completed, 2 an error -- and the node waits
\ for the next. (DONE) is entered with the same number and, for an error,
\ stops compiling first; it is always jumped to, never called, by
\ something that has emptied the return stack (or by a fault, which empties
\ it). (LINE-STATUS) keeps how the last text ended.
\ THE MESSAGE SAYING HOW IT ENDED is not written here: whoever sent the
\ text may be stuck, and this node would wait on it. It is put with the
\ messages waiting and passed on from (IDLE), as any message for another
\ node is. It is put before the others, and this node does not begin
\ another text from the same sender until it has gone ((MINE?)): so what
\ one sender is told comes in the order the texts were done.
: (FINISH) ( s -- )
1 (QUIET) a! ! \ from here an error is not this text's: see (RAISED)
(LINE-STATUS) b! dup !b
(FLUSH-OUT)
1 (MQ#) a! @ + -MQ-ROOM + -if FULL \ how it ended goes with the messages waiting,
drop \ to be passed on as any is: (IDLE)
(MQ#) a! @ push \ how many cells are there before it
(MSG)+1 a! @ (MQ!) (ME) a! @ (MQ!) 3 (MQ!) \ to whoever sent the text, from this node, type 3
0 (MQ!) 0 (MQ!) 0 (MQ!) 4 (MQ!) \ four characters long
0 (DONE-PORT) a! @ - (MQ!) \ by the port that leads back, kept below zero: this node's own
(MQ!) \ how it ended
pop if FRONT -1 + FOR (MQ@) (MQ!) NEXT jump (IDLE) \ and those go round behind it: it is the oldest
FRONT: drop jump (IDLE)
FULL: drop \ no room at all: it is offered here, and the node waits
(MSG)+1 a! @ (DONE-PORT) a! @ (GATE)
3 (HDR) 4 !b !b
jump (IDLE)
: (DONE)
if GO -1 + if OK
drop (RESET) 2 jump (FINISH)
OK: drop 1 jump (FINISH)
GO: drop 0 jump (FINISH)
\ THE MESSAGES WAITING, GONE THROUGH. Three words below go through them
\ all, as (A-QUEUE) does further down: each in turn is taken from the
\ front, its eight cells into (MQ-HDR), and either used up or put at the
\ back, so that those that stay are in the order they were in. (A-LEFT)
\ is how many cells are still to be looked at, and (A-FOUND) what the pass
\ has found.
\ ( -- n ) the next of them is in (MQ-HDR); n is how many words of text
\ it has, which are still at the front
: (MQ-NEXT)
(A-HDR)
(MQ-HDR)+6 a! @ -if SIZED drop 0 jump N
SIZED: 3 + 2/ 2/
N: (A-LEFT) a! @ over 8 + - ! ;
\ ( -- port | 0 ) the port the message in (MQ-HDR) goes by: for one this
\ node made itself, (FINISH), the port kept with it, below zero; for any
\ other, the way to the node it is for
: (FWD-PORT)
(MQ-HDR)+7 a! @ -if THEIRS 0 SWAP - ;
THEIRS: drop (MQ-HDR) a! @ jump (PORT-FOR)
\ ( -- flag ) is the message in (MQ-HDR) one to pass on? One this node
\ made itself is; any other is unless it is for this node, and waits here
\ to be dealt with ((MINE?) holds text back)
: (FWD?)
(MQ-HDR)+7 a! @ -if THEIRS drop -1 ;
THEIRS: drop (MQ-HDR) a! @ (ME) a! @ xor ;
\ ( -- flag ) IS THERE ONE FOR THIS NODE? The first that is, is taken
\ out: its seven words into (MSG), the port it came on into (REPLY), its
\ text into TIB.
\ TEXT IS NOT BEGUN WHILE THE ANSWER TO ITS SENDER'S LAST IS STILL HERE:
\ a message this node made itself, (FINISH), is ahead of it, to that
\ sender. Whom each such message seen so far is to is noted in (PAY-K),
\ which nothing else is using now, and (A-WORD) is how many: at most as
\ many as there are ports, and with more than that no text is begun. A
\ NACK or a GONE for this node is never held back.
: (MINE?)
0 (A-FOUND) a! ! 0 (A-WORD) a! !
(MQ#) a! @ (A-LEFT) a! !
L: (A-LEFT) a! @ if END drop
(MQ-NEXT)
(A-FOUND) a! @ if LOOK drop jump KEEP
LOOK: drop
(MQ-HDR)+7 a! @ -if THEIRS
drop (A-WORD) a! @ -PORTS + -if MANY \ this node's own: whom it is to is noted
drop (MQ-HDR) a! @ push (A-WORD) a! @ dup 1 + ! (PAY-K) + a! pop !
jump KEEP
MANY: drop PORTS-1 2 + (A-WORD) a! ! jump KEEP \ more than can be noted
THEIRS: drop
(MQ-HDR) a! @ (ME) a! @ xor if MINE drop jump KEEP
MINE: drop
(MQ-HDR)+2 a! @ -1 + if TEXT drop jump TAKE
TEXT: drop
(A-WORD) a! @ if TAKE0 \ no answer is waiting to go
dup -PORTS + -1 + -if HOLD2 drop \ ( n count )
(MQ-HDR)+1 a! @ SWAP -1 + (PAY-K) a! \ ( n from count-1 )
FOR dup @+ xor if HIT drop NEXT
drop jump TAKE \ none of them is to this text's sender
HIT: drop drop pop drop jump KEEP
HOLD2: drop drop jump KEEP
TAKE0: drop
TAKE: 1 (A-FOUND) a! !
(MQ-HDR) a! @ (MSG) a! ! (MQ-HDR)+1 a! @ (MSG)+1 a! ! (MQ-HDR)+2 a! @ (MSG)+2 a! !
(MQ-HDR)+3 a! @ (MSG)+3 a! ! (MQ-HDR)+4 a! @ (MSG)+4 a! ! (MQ-HDR)+5 a! @ (MSG)+5 a! !
(MQ-HDR)+6 a! @ (MSG)+6 a! ! (MQ-HDR)+7 a! @ (REPLY) a! !
TIB 2/ 2/ SWAP if EMPTY
-1 + FOR (MQ@) over a! ! 1 + NEXT
drop jump L
EMPTY: drop drop jump L
KEEP: (A-BACK) (A-TEXT) jump L
END: drop (A-FOUND) a! @ ;
\ ( -- flag ) WHAT IS TO BE PASSED ON IS OFFERED (MESH.md 7c.3): for each
\ message, the first for its port, its first word is offered there, unless
\ a refusal owed is offered there already; (PAY-K) is set to -1 for that
\ port. It stays with the messages waiting until the offer is taken.
\ One that cannot go at all is let go, counted in (LOST), and whoever
\ waits on it is told (core.v4, (TELL-OF)): one with no way known; one
\ whose way is a port with nothing on it; and one that fifteen nodes have
\ passed on already. The flag is not zero if any was let go.
\ A MESSAGE IS PASSED ON BY AT MOST 16 NODES. Its fourth word says how
\ many more may; 0, as a device sends it, is taken for 16.
: (FWD-SET)
0 (A-FOUND) a! !
(MQ#) a! @ (A-LEFT) a! !
L: (A-LEFT) a! @ if END drop
(MQ-NEXT) (A-WORD) a! ! \ its words of text, kept off the stack: this runs between lines
(FWD?) if STAYS drop
(MQ-HDR)+3 a! @ if FRESH jump COUNT
FRESH: drop 16
COUNT: -1 + if REFUSE drop
(FWD-PORT) if REFUSE \ ( port )
dup (THERE) if REFUSE2 drop
(PORT) - dup (PAY-K) + a! @ if FREE \ ( p slot ) p: the port, by its number
drop drop jump KEEP
FREE: drop dup push (MQ-HDR) a! @ SWAP (OFFER) + a! ! \ whom it is to, offered
-1 pop (PAY-K) + a! !
jump KEEP
STAYS: drop
KEEP: (A-BACK) (A-WORD) a! @ (A-TEXT) jump L
REFUSE2: drop
REFUSE: drop
(A-WORD) a! @ if NOTEXT -1 + FOR (MQ@) drop NEXT jump TOLD
NOTEXT: drop
TOLD: (LOST) a! @ 1 + ! 1 (A-FOUND) a! !
(MQ-HDR)+1 a! @ (MQ-HDR) a! @ (MQ-HDR)+2 a! @ (TELL-OF) jump L
END: drop (A-FOUND) a! @ ;
\ ( -- ) THE OFFER OF ONE WAS TAKEN, on the port (GATE-PORT) holds: the
\ first of the messages waiting that goes by that port is the one. Its
\ other words are written, each waiting for the neighbour, which has its
\ first and reads to the end; and it is done with.
: (FWD-GO)
0 (A-FOUND) a! !
(MQ#) a! @ (A-LEFT) a! !
L: (A-LEFT) a! @ if END drop
(MQ-NEXT)
(A-FOUND) a! @ if LOOK drop jump KEEP
LOOK: drop
(FWD?) if KEEP1 drop
(FWD-PORT) (GATE-PORT) a! @ xor if THIS drop jump KEEP
KEEP1: drop jump KEEP
THIS: drop 1 (A-FOUND) a! !
(GATE-PORT) a! @ b!
(MQ-HDR)+1 a! @ !b (MQ-HDR)+2 a! @ !b
(MQ-HDR)+3 a! @ if FRESH jump COUNT
FRESH: drop 16
COUNT: -1 + !b \ one fewer may pass it on
(MQ-HDR)+4 a! @ !b (MQ-HDR)+5 a! @ !b (MQ-HDR)+6 a! @ !b
if NOTEXT -1 + FOR (MQ@) !b NEXT jump L
NOTEXT: drop jump L
KEEP: (A-BACK) (A-TEXT) jump L
END: drop ;
\ ( -- ) WAITING. A node with nothing to do looks through the messages
\ waiting (core.v4).
\ ONE FOR THIS NODE is dealt with, the oldest first: (MINE?). A message
\ of type 1 is text to interpret: it is done as a line was, and (FINISH)
\ reports how it ended; one that came with a length no message has is
\ error 12. A NACK is counted and a GONE from the node's centre believed.
\ WITH NONE FOR IT, what it has for other nodes, and the refusals it owes,
\ are offered, each on the port it goes by, and the node sleeps in the
\ wait (MESH.md 7c): until one is taken, and then the rest of that one is
\ written; or until a word comes for it, and then that message is taken in
\ and it looks again. A node that is stuck never takes what is offered
\ it, and holds up nothing else.
\ WITH NOTHING WAITING AND NOTHING OWED it is blocked reading its ports
\ (docs/v4.0.0/MESH.md 4.1): it executes nothing until a neighbour writes,
\ and what arrives is taken in as any message is.
: (IDLE)
L: 1 (QUIET) a! ! \ nothing here is any text's doing: see (RAISED)
(MINE?) if OTHERS drop jump HAVE
OTHERS: drop
(MQ#) a! @ (OWED#) a! @ + if BLOCK drop
(PAY-SET) (FWD-SET) if SET drop jump L \ one was let go: what is owed has changed
SET: drop
(MQ#) a! @ (OWED#) a! @ + if BLOCK drop
(OFFERS) if CAME -if CAME drop \ nothing on a port: what was for it is let go next time round
(GATE-PORT) a! @ (PORT) - (PAY-K) + a! @ \ what was offered on the port it was taken on
-if OWED drop (FWD-GO) jump L
OWED: -1 + (PAY-GO) jump L
CAME: drop jump L
BLOCK: drop (PORT)+8 b! @b (PORT)+9 b! @b (PORT) + dup b! \ ( to port ) B: the port it came on
SWAP (TAKE) jump L
HAVE:
(MSG)+6 a! @ -if SIZED
drop 0 (MSG)+6 a! ! 0 SPAN a! ! NODE-ERROR b! 12 !b \ no telling what it was
SIZED: drop
0 (MSG)+6 a! @ TIB + C! \ a zero after the text
(MSG)+6 a! @ SPAN a! !
(MSG)+2 a! @ -1 + if TEXT
-3 + if NACK -1 + if GONE drop jump (IDLE) \ neither text nor these: let go
NACK: drop (REFUSED) a! @ 1 + ! jump (IDLE) \ a message of this node's was refused: counted
GONE: drop (MSG)+6 a! @ -4 + if G4 drop jump (IDLE) \ a node is gone, if its centre says so:
G4: drop (CENTRE) if NOT (MSG)+1 a! @ xor if CENTRE drop jump (IDLE)
NOT: drop jump (IDLE)
CENTRE: drop TIB 2/ 2/ a! @ NO-ROUTE jump (IDLE) \ the way to it is forgotten
TEXT: drop
(MSG)+1 a! @ (PORT-FOR) if D0 jump D1 \ the way back to whoever sent it:
D0: drop (REPLY) a! @ \ the port it came on, if no other is known
D1: (DONE-PORT) a! !
(CONSOLE) a! @ if P0 jump P1 \ where what it prints goes: the console,
P0: drop (MSG)+1 a! @ \ or whoever sent it
P1: dup (PRINT-TO) a! !
(PORT-FOR) if Q0 jump Q1
Q0: drop (REPLY) a! @
Q1: (PRINT-PORT) a! !
jump (LINE)
\ ( -- ) THE TEXT, INTERPRETED. It is in TIB with a zero after it and its
\ length in SPAN, and the return stack is empty. It is interpreted with one
\ return entry under it, this word's call of INTERPRET; whatever is on the
\ data stack stays there.
: (LINE)
0 (QUIET) a! ! \ an error from here on is this text's
0 BLK a! ! \ the terminal, whatever was being loaded
TIB (SRC) a! ! 0 >IN a! !
0 NODE-ERROR b! !b
INTERPRET
NODE-ERROR b! @b if GOOD
drop 2 jump (DONE)
GOOD: drop 1 jump (DONE)
\ ---- the node among others (MESH.md sections 6 and 7) ---------------------------
\ Not FORTH-79 and not in v3: v3's VMs are sent to through the kernel.
\ ( node port -- ) the port, by its number, leads toward that node
header ROUTE
: ROUTE
(ROUTE#) a! @ -16 + if FULL drop
(PORT) + (ROUTE#) a! @ 2* (ROUTES) + a!
push !+ pop !+
(ROUTE#) a! @ 1 + ! ;
FULL: drop drop drop NODE-ERROR b! 12 !b ;
\ ( node port -- ) the node on the other end of the port, by its number;
\ 0: none, or a device. Whoever wires the node tells it, and tells it again
\ when the wiring changes. It is how a node knows who its centre is
\ ((CENTRE)), from whom alone it believes a GONE.
header NEIGHBOUR
: NEIGHBOUR
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (NEAR) + a! ! ;
BAD: drop drop drop NODE-ERROR b! 12 !b ;
\ ( port -- ) the port, by its number, leads toward every node not told of
header DEFAULT-ROUTE
: DEFAULT-ROUTE (PORT) + (ROUTE-DEFAULT) a! ! ;
\ ( node -- ) forget the way to that node, if one is known: what is for it
\ then goes by the way for every node not told of, if there is one. The
\ last way in the table takes its place.
header NO-ROUTE
: NO-ROUTE
(ROUTE#) a! @ if NONE -1 + (ROUTES) a!
FOR dup @+ xor if HIT drop @+ drop NEXT
drop ;
NONE: drop drop ;
HIT: drop drop pop drop
a -1 + push \ where its entry is
(ROUTE#) a! @ -1 + dup ! \ one way fewer
2* (ROUTES) + a! @+ @ \ the last entry: node port
pop a! SWAP !+ ! ;
\ ( about node type -- ) send the node a message of one word, `about`:
\ a NACK is type 4, a GONE type 5 (MESH.md 7b). With no way to the node
\ it is error 12. It is put with the messages waiting and goes from
\ (IDLE), or from AWAIT, as how text ended does ((FINISH)): so telling a
\ node that is stuck does not hold up the telling of the next. With no
\ room at all it is offered here.
: (SEND1)
push dup (PORT-FOR) if NOWAY \ ( about node port ) R: type
1 (MQ#) a! @ + -MQ-ROOM + -if FULL drop
SWAP (MQ!) (ME) a! @ (MQ!) pop (MQ!) \ to, from, type
0 (MQ!) 0 (MQ!) 0 (MQ!) 4 (MQ!) \ four characters long
0 SWAP - (MQ!) \ by that port, kept below zero: this node's own
(MQ!) ; \ about
FULL: drop (GATE) pop (HDR) 4 !b !b ;
NOWAY: drop drop drop pop drop NODE-ERROR b! 12 !b ;
\ ( n node -- ) tell the node that node n is gone. It acts on that only
\ if this node is its centre: it forgets the way to n, and if it is waiting
\ for n's answer the wait ends.
header GONE
: GONE 5 jump (SEND1)
\ ( -- ) forget every way: for when the wiring has changed
header NO-ROUTES
: NO-ROUTES 0 (ROUTE#) a! ! 0 (ROUTE-DEFAULT) a! ! ;
\ ( baddr u node port -- ) send the node u characters of text to
\ interpret, by the port given, by its address. It is on its way when this
\ returns. Its first word is offered until the neighbour takes it
\ (core.v4, (GATE)); the rest is written, each word waiting for it.
: (SEND-ON)
(GATE) \ to
1 (HDR)
dup !b \ length
3 + 2/ 2/ if NONE -1 +
FOR dup C@ over 1 + C@ 8* + over 2 + C@ 8* 8* + over 3 + C@ 8* 8* 8* + !b 4 + NEXT
drop ;
NONE: drop drop ;
\ ( baddr u node -- ) send the node u characters of text to interpret,
\ by the way this node knows to it. What it prints there goes to that
\ node's console. With no way to the node it is error 12.
header SEND
: SEND
dup (PORT-FOR) if NOWAY jump (SEND-ON)
NOWAY: drop drop drop drop NODE-ERROR b! 12 !b ;
\ ( baddr u node port -- ) the same by a port this node names, by its
\ number, whatever ways it knows: for a neighbour that has no number of
\ its own yet, to which text is sent as to node 0.
header SEND-ON
: SEND-ON
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (PORT) + jump (SEND-ON)
BAD: drop drop drop drop drop NODE-ERROR b! 12 !b ;
\ ( -- n ) the number of this node's centre: the node on the port that
\ leads to everything it has no other way to. 0: it has none, or has not
\ been told who is there (NEIGHBOUR).
: (CENTRE)
(ROUTE-DEFAULT) a! @ if NONE (PORT) - (NEAR) + a! @ ;
NONE: ;
\ ( -- 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! @ ;
\ THE MESSAGES WAITING, LOOKED THROUGH for what would end a wait. Each in
\ turn is taken from the front: its eight cells into (MQ-HDR), (A-HDR). If
\ it is the answer waited for, or a NACK or a believed GONE for this node,
\ it is used up, as it would be had it come during the wait; otherwise it
\ goes to the back, (A-BACK) and (A-TEXT), so that when all have been
\ looked at they are in the order they were in. (A-LEFT) is how many
\ cells are still to be looked at. (A-FOUND) is what was found first: 0
\ nothing, 1 the answer, its word in (A-WORD); 2 a NACK about the node
\ waited for; 3 a GONE about it; 4 text from the console, which stays
\ where it is to be done next.
: (A-HDR) (MQ-HDR) a! 7 FOR a push (MQ@) pop a! !+ NEXT ;
: (A-BACK) (MQ-HDR) a! 7 FOR @+ a push (MQ!) pop a! NEXT ;
: (A-TEXT) if NONE -1 + FOR (MQ@) (MQ!) NEXT ; NONE: drop ;
: (A-QUEUE)
0 (A-FOUND) a! !
(MQ#) a! @ (A-LEFT) a! !
L: (A-LEFT) a! @ if END drop
(A-HDR)
(MQ-HDR)+6 a! @ -if SIZED drop 0 jump N
SIZED: 3 + 2/ 2/
N: (A-LEFT) a! @ over 8 + - ! \ n: its words of text
(A-FOUND) a! @ if LOOK drop jump KEEP \ something is found: the rest only go round
LOOK: drop
(MQ-HDR) a! @ (ME) a! @ xor if MINE drop jump KEEP
MINE: drop
(MQ-HDR)+2 a! @ -1 + if TEXT -2 + if ANS -1 + if NACK -1 + if GONE drop jump KEEP
TEXT: drop (A-CONSOLE) (MQ-HDR)+1 a! @ xor if BRK drop jump KEEP
BRK: drop 4 (A-FOUND) a! ! jump KEEP
ANS: drop (MQ-HDR)+1 a! @ (AWAIT-FROM) a! @ xor if A1 drop jump KEEP
A1: drop dup -1 + if A2 drop jump KEEP
A2: drop drop (MQ@) (A-WORD) a! ! 1 (A-FOUND) a! ! jump L
NACK: drop dup -1 + if N2 drop jump KEEP
N2: drop drop (MQ@) (AWAIT-FROM) a! @ xor if N3 drop (REFUSED) a! @ 1 + ! jump L
N3: drop 2 (A-FOUND) a! ! jump L
GONE: drop dup -1 + if G2 drop jump KEEP
G2: drop (CENTRE) if NOC (MQ-HDR)+1 a! @ xor if G3 drop jump KEEP
NOC: drop jump KEEP
G3: drop drop (MQ@) dup NO-ROUTE (AWAIT-FROM) a! @ xor if G4 drop jump L
G4: drop 3 (A-FOUND) a! ! jump L
KEEP: (A-BACK) (A-TEXT) jump L
END: drop ;
\ ( what -- how | ) the wait is over, by what (A-FOUND) says: the answer's
\ word is left; anything else is an error
: (A-END)
0 (AWAIT-FROM) a! !
-1 + if ANS -1 + if REF -1 + if LEFT drop NODE-ERROR b! 21 !b ;
ANS: drop (A-WORD) a! @ ;
REF: drop NODE-ERROR b! 19 !b ;
LEFT: drop NODE-ERROR b! 20 !b ;
\ ( node -- how ) WAIT FOR THE NODE'S WORD OF HOW TEXT ENDED: 0 QUIT,
\ 1 completed, 2 an error: a message of type 3 for this node from that
\ node. (AWAIT-FROM) holds the node while it waits, and 0 otherwise.
\ THE WAIT ALSO ENDS, in an error, when the answer is not going to come
\ (MESH.md section 7b): a NACK about that node, error 19, Message refused;
\ or a GONE about it from this node's centre, error 20, Node gone. A NACK
\ about another node is counted, and a GONE about another has its way
\ forgotten, as they would be if this node were not waiting. A GONE is
\ believed only if this node's centre sent it: (CENTRE).
\ AND A LINE FROM THE CONSOLE BREAKS IT (7b.6): text for this node from its
\ console ends the wait in error 21, Interrupted, and is then done as
\ usual. It is the one way to end a wait on a node that is alive and
\ never answers, short of Hera's killing that node.
\ WHILE IT WAITS THE NODE DOES WHAT (IDLE) DOES, but for beginning text:
\ the messages waiting are looked through for what would end the wait,
\ (A-QUEUE); what it has for other nodes and the refusals it owes are
\ offered, and it sleeps in the wait (MESH.md 7c); what comes is taken in
\ and kept, and it looks again. So what passes through a node is not
\ kept back by its waiting, and what it sent before it began to wait --
\ a GONE, say -- goes.
header AWAIT
: AWAIT
(AWAIT-FROM) a! !
L: (A-QUEUE)
(A-FOUND) a! @ if WAIT jump (A-END)
WAIT: drop
(PAY-SET) (FWD-SET) if SET drop jump L \ one was let go: this node may have been told so
SET: drop
(OFFERS) if CAME -if CAME drop
(GATE-PORT) a! @ (PORT) - (PAY-K) + a! @
-if OWED drop (FWD-GO) jump L
OWED: -1 + (PAY-GO) jump L
CAME: drop jump L
\ ( w port -- ) write a cell to the port, by its number. It waits until
\ the neighbour has taken it. This is how a node is sent a capsule of F18
\ code (docs/v4.0.0/MESH.md section 5): the cells go as they are, not as a
\ message, to a node that is executing from its ports.
header PORT!
: PORT!
dup -if POS jump BAD
POS: -PORTS + -if BAD drop (PORT) + b! !b ;
BAD: drop drop drop NODE-ERROR b! 12 !b ;
\ ( -- ) WHAT IS IN THE DICTIONARY NOW IS THE SYSTEM: COLD comes back to
\ it and FORGET will not go below it. Whoever has loaded a node's capsules
\ has it do this (system.v4, (BOOT) and FENCE).
header (SEAL)
: (SEAL)
DP a! @ (BOOT) a! !
(LATEST) a! @ (BOOT)+1 a! !
DP a! @ 3 + 2/ 2/ FENCE a! ! ;
\ FORTH-79: clear the return stack, set execution mode, return control to
\ the terminal; no message is given. The data stack is left as it is.
\ NODE-ERROR, by name: how a definition written in FORTH raises an error.
\ A store of a code that is not zero is the trap of D-18 -- the word goes no
\ further, the message for the code is printed (-1: the word has printed
\ its own) and the line ends with ERROR. The codes are listed in core.v4.
header NODE-ERROR inline : NODE-ERROR' NODE-ERROR ;
header (ME) inline : (ME)' (ME) ;
header (CONSOLE) inline : (CONSOLE)' (CONSOLE) ;
header (LOST) inline : (LOST)' (LOST) ;
header (REFUSED) inline : (REFUSED)' (REFUSED) ;
header (WORD-DEFINED) inline : (WORD-DEFINED)' (WORD-DEFINED) ;
header (WORD-FORGOTTEN) inline : (WORD-FORGOTTEN)' (WORD-FORGOTTEN) ;
header QUIT
: QUIT R-CLEAR (RESET) CR 0 jump (DONE)
\ FORTH-79: clear the data and return stacks, set execution mode, return
\ control to the terminal. As v3, the line it stops ends with " ok".
\ Both are emptied before anything is called: ABORT may be run with the
\ return stack full.
header ABORT
: ABORT R-CLEAR DSTACK-DEPTH b! a !b (RESET) 1 jump (DONE)
\ ---- faults (D-14, D-16) -------------------------------------------------------
\ Where the node goes when a programme uses an address outside its memory,
\ pushes onto a full stack or pops an empty one. The opcode that faulted did
\ nothing, and both stacks have been emptied. Each handler says what happened;
\ whatever was running is abandoned, as by ABORT, and the line ends with
\ ERROR.
: (FAULT) \ "Address out of range"
$72646441 (EMIT4) $20737365 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR
2 jump (DONE)
: (D-OVER) \ "Stack overflow"
$63617453 (EMIT4) $766F206B (EMIT4) $6C667265 (EMIT4) $776F (EMIT4) CR
2 jump (DONE)
: (D-UNDER) \ "Stack underflow"
$63617453 (EMIT4) $6E75206B (EMIT4) $66726564 (EMIT4) $776F6C (EMIT4) CR
2 jump (DONE)
: (R-OVER) \ "Return stack overflow"
$75746552 (EMIT4) $73206E72 (EMIT4) $6B636174 (EMIT4) $65766F20 (EMIT4) $6F6C6672 (EMIT4) $77 (EMIT4) CR
2 jump (DONE)
: (R-UNDER) \ "Return stack underflow"
$75746552 (EMIT4) $73206E72 (EMIT4) $6B636174 (EMIT4) $646E7520 (EMIT4) $6C667265 (EMIT4) $776F (EMIT4) CR
2 jump (DONE)
\ A word has stored an error code in NODE-ERROR (D-18; the codes are listed
\ in core.v4). Print its message -- a negative code means the word printed
\ its own -- and end the line with ERROR. The return stack has been
\ emptied; the data stack is as the word left it.
\ (QUIET) is 1 while the node is doing something that is no text's doing:
\ paying a refusal, passing a message on, or sending word of how a text
\ ended. An error then has nobody to be told to -- the usual one is that
\ no one is on the port (18) -- and trying to tell it would raise it again
\ without end. So it is not told: what was being sent is let go and
\ counted, and the node goes back to waiting.
: (RAISED)
(QUIET) a! @ if SPEAK
drop (OUT) (OUT^) a! ! (LOST) a! @ 1 + ! jump (IDLE)
SPEAK: drop
NODE-ERROR b! @b
-if POS drop 2 jump (DONE)
POS: -1 + if M1 -1 + if M2 -1 + if M3 -1 + if M4
-1 + if M5 -1 + if M6 -1 + if M7 -1 + if M8 -1 + if M9
-1 + if M10 -1 + if M11 -1 + if M12 -1 + if M13 -1 + if M14
-1 + if M15 -1 + if M16 -1 + if M17 -1 + if M18
-1 + if M19 -1 + if M20 -1 + if M21
drop 2 jump (DONE)
M1: drop $6167654E (EMIT4) $65766974 (EMIT4) $756F6320 (EMIT4) $746E (EMIT4) CR 2 jump (DONE)
M2: drop $20746F4E (EMIT4) $756E2061 (EMIT4) $7265626D (EMIT4) CR 2 jump (DONE)
M3: drop $626D754E (EMIT4) $74207265 (EMIT4) $6C206F6F (EMIT4) $676E6F (EMIT4) CR 2 jump (DONE)
M4: drop $20746F4E (EMIT4) $68632061 (EMIT4) $63617261 (EMIT4) $726574 (EMIT4) CR 2 jump (DONE)
M5: drop $74636944 (EMIT4) $616E6F69 (EMIT4) $66207972 (EMIT4) $6C6C75 (EMIT4) CR 2 jump (DONE)
M6: drop $656D614E (EMIT4) $73696D20 (EMIT4) $676E6973 (EMIT4) CR 2 jump (DONE)
M7: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $696D2065 (EMIT4) $74616D73 (EMIT4) $6863 (EMIT4) CR 2 jump (DONE)
M8: drop $746E6F43 (EMIT4) $206C6F72 (EMIT4) $75727473 (EMIT4) $72757463 (EMIT4) $74207365 (EMIT4) $64206F6F (EMIT4) $706565 (EMIT4) CR 2 jump (DONE)
M9: drop $66696853 (EMIT4) $6F632074 (EMIT4) $20746E75 (EMIT4) $2074756F (EMIT4) $7220666F (EMIT4) $65676E61 (EMIT4) CR 2 jump (DONE)
M10: drop $746F7250 (EMIT4) $65746365 (EMIT4) $6F772064 (EMIT4) $6472 (EMIT4) CR 2 jump (DONE)
M11: drop $69766944 (EMIT4) $6E6F6973 (EMIT4) $20796220 (EMIT4) $6F72657A (EMIT4) CR 2 jump (DONE)
M12: drop $75677241 (EMIT4) $746E656D (EMIT4) $74756F20 (EMIT4) $20666F20 (EMIT4) $676E6172 (EMIT4) $65 (EMIT4) CR 2 jump (DONE)
M13: drop $636F6C42 (EMIT4) $756F206B (EMIT4) $666F2074 (EMIT4) $6E617220 (EMIT4) $6567 (EMIT4) CR 2 jump (DONE)
M14: drop $62206F4E (EMIT4) $6B636F6C (EMIT4) $20736920 (EMIT4) $6E696562 (EMIT4) $6F6C2067 (EMIT4) $64656461 (EMIT4) CR 2 jump (DONE)
M15: drop $65666544 (EMIT4) $64657272 (EMIT4) $726F7720 (EMIT4) $6F6E2064 (EMIT4) $65732074 (EMIT4) $74 (EMIT4) CR 2 jump (DONE)
M16: drop $20746F4E (EMIT4) $6F772061 (EMIT4) $6472 (EMIT4) CR 2 jump (DONE)
M17: drop $726F7453 (EMIT4) $20656761 (EMIT4) $75666572 (EMIT4) $646573 (EMIT4) CR 2 jump (DONE)
M18: drop (OUT) (OUT^) a! ! \ what was printed and not sent cannot be sent: it is let go
$6F206F4E (EMIT4) $6F20656E (EMIT4) $6874206E (EMIT4) $70207461 (EMIT4) $74726F (EMIT4) CR 2 jump (DONE)
M19: drop $7373654D (EMIT4) $20656761 (EMIT4) $75666572 (EMIT4) $646573 (EMIT4) CR 2 jump (DONE)
M20: drop $65646F4E (EMIT4) $6E6F6720 (EMIT4) $65 (EMIT4) CR 2 jump (DONE)
M21: drop $65746E49 (EMIT4) $70757272 (EMIT4) $646574 (EMIT4) CR 2 jump (DONE)
\ The table the loader gives the node: six words, one for each kind of
\ fault in the node's order, each a jump. A jump fills its word, so they
\ are one after another.
: (FAULTS)
jump (FAULT) jump (D-OVER) jump (D-UNDER) jump (R-OVER) jump (R-UNDER) jump (RAISED)
\ ---- text in the source ---------------------------------------------------------
\ The three run-time words have names, as v3's have, so that SEE can tell a
\ string in a definition from code; they cannot be used from the prompt.
\ ." and ABORT" take the text up to the next " , which may be none at all
\ (input.v4's (PARSE)); with no closing " it is the rest of the line. Inside a definition they lay
\ down a call to their run-time word and, after it, the text as a counted
\ string: the count byte and the characters, four to a cell, the last cell
\ filled with zeros. The run-time word finds the string by the return
\ address the call left, and returns to the cell after the string.
\ ( -- ) lay the counted string in WBUF into the dictionary, as above.
\ (Q)+0 how many bytes are still to go, (Q)+1 which is next.
: (STRING,)
(FLUSH)
WBUF C@ 1 + (Q) a! ! 0 (Q)+1 a! !
L: (Q) a! @ if DONE -1 + !
(Q)+1 a! @ dup 1 + ! WBUF + C@ C,
jump L
DONE: drop
P: DP b! @b 3 and if ALIGNED drop 0 C, jump P
ALIGNED: drop ;
\ The run time of ." : print the string after the call, go on after it.
\ It takes the return address off before it calls anything and keeps the
\ count there instead, so a word that prints text goes no deeper than one
\ that calls any other word.
header (.") compile-only
: (.")
pop 4* dup C@ \ baddr n
L: if DONE
push 1 + dup C@ EMIT pop -1 + jump L
DONE: drop 4/ 1 + push ; \ the cell after the last character
\ FORTH-79: ." text" prints the text -- now, if interpreting; when the word
\ it is compiled into runs, if compiling.
header ." immediate
: DOT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(.") (CALL,) jump (STRING,)
NOW: drop WBUF COUNT jump TYPE
\ ( flag -- ) the run time of ABORT" : if the flag is not zero print the
\ string after the call, start a new line and ABORT; otherwise go on after
\ the string.
header (ABORT") compile-only
: (ABORT")
if NO
drop pop 4* R-CLEAR COUNT TYPE CR jump ABORT
NO: drop pop 4* dup C@ + 4/ 1 + push ;
\ ( flag -- ) ABORT" text" as v3 (it is FORTH-83's, not FORTH-79's): if
\ the flag is not zero, print the text and ABORT.
header ABORT" immediate
: ABORT-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(ABORT") (CALL,) jump (STRING,)
NOW: drop if NO
drop WBUF COUNT TYPE CR jump ABORT
NO: drop ;
\ The run time of S" : leave the address and length of the string after the
\ call, and go on after it.
header (S") compile-only
: (S")
pop 4* dup C@ \ baddr n
over over + 4/ 1 + push \ the cell after the last character
push 1 + pop ; \ baddr+1 n
\ ( -- baddr u ) S" text" as v3. In a definition the text is compiled
\ into it. At the prompt it is copied to PAD, where it stays until PAD is
\ used again: WORD's buffer is overwritten by the very next word of the line.
header S" immediate
: S-QUOTE
34 (PARSE) drop
STATE a! @ if NOW
drop &(S") (CALL,) jump (STRING,)
NOW: drop WBUF+1 PAD WBUF C@ CMOVE PAD WBUF jump C@
Reference in New Issue View Git Blame Copy Permalink