rajamesandClaude Opus 5.5
353783726d
1c720ab2 was committed with hosted-check failing: with how text ended
queued, a line typed while the node waited was done before the earlier
line's answer had gone, and the pass that offers what is to be passed on
let go text that was for the node itself.
How text ended is put before the other messages waiting; a node does not
begin another text from a sender while its answer to that sender is
still with it; and what is for the node itself is not offered.
make -C v4 test and sanitize at both widths, hosted-check.
Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
684 lines
33 KiB
Plaintext
684 lines
33 KiB
Plaintext
\ 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. (A-WORD) is whom such a message seen so far is to: -1 none,
|
|
\ -2 more than one node, and then no text is begun. A NACK or a GONE for
|
|
\ this node is never held back.
|
|
: (MINE?)
|
|
0 (A-FOUND) a! ! -1 (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! @ 1 + if FIRST \ this node's own:
|
|
drop (A-WORD) a! @ (MQ-HDR) a! @ xor if SAME
|
|
drop -2 (A-WORD) a! ! jump KEEP
|
|
FIRST: drop (MQ-HDR) a! @ (A-WORD) a! ! jump KEEP
|
|
SAME: drop jump KEEP
|
|
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! @ 2 + if HOLD
|
|
drop (A-WORD) a! @ (MQ-HDR)+1 a! @ xor if HOLD
|
|
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
|
|
HOLD: drop
|
|
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 drop
|
|
(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.
|
|
: (SEND1)
|
|
push dup (PORT-FOR) if NOWAY
|
|
(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. This node is blocked reading its ports until a
|
|
\ message of type 3 comes for it from that node; every other message that
|
|
\ comes meanwhile is kept with the messages waiting. (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).
|
|
\ WHAT HAS COME ALREADY is looked through first, (A-QUEUE): the answer, a
|
|
\ NACK or a GONE may have been taken in before the wait began, while this
|
|
\ node was waiting to write, and is then with the messages waiting.
|
|
\ AND A LINE FROM THE CONSOLE BREAKS IT (7b.6): text for this node from its
|
|
\ console is kept, as any message is, the wait ends in error 21,
|
|
\ Interrupted, and the text 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.
|
|
header AWAIT
|
|
: AWAIT
|
|
(AWAIT-FROM) a! !
|
|
(A-QUEUE)
|
|
(A-FOUND) a! @ if WAIT jump (A-END)
|
|
WAIT: drop
|
|
L: (PORT)+8 b! @b (PORT)+9 b! @b (PORT) + dup b! SWAP (TAKE-HDR)
|
|
(MQ-HDR) a! @ (ME) a! @ xor if A1 drop jump KEEP
|
|
A1: drop (MQ-HDR)+2 a! @ \ for this node: its type
|
|
-1 + if TEXT -2 + if ANSWER -1 + if NACK -1 + if GONE drop jump KEEP
|
|
TEXT: drop (A-CONSOLE) (MQ-HDR)+1 a! @ xor if BREAK drop jump KEEP \ text: from the console?
|
|
BREAK: drop (TAKE-KEEP) 4 jump (A-END) \ kept, to be done next; and the wait is over
|
|
ANSWER: drop (MQ-HDR)+1 a! @ (AWAIT-FROM) a! @ xor if A3 drop jump KEEP
|
|
A3: drop (MQ-HDR)+6 a! @ -4 + if A4 drop jump KEEP
|
|
A4: drop 0 (AWAIT-FROM) a! ! @b ; \ its one word
|
|
NACK: drop (MQ-HDR)+6 a! @ -4 + if N4 drop jump KEEP
|
|
N4: drop @b (AWAIT-FROM) a! @ xor if REFUSED \ about the node waited for?
|
|
drop (REFUSED) a! @ 1 + ! jump L \ another: counted
|
|
REFUSED: drop 2 jump (A-END)
|
|
GONE: drop (MQ-HDR)+6 a! @ -4 + if G4 drop jump KEEP
|
|
G4: drop @b \ the node that is gone
|
|
(CENTRE) if NOC (MQ-HDR)+1 a! @ xor if CENTRE \ only its centre is believed
|
|
drop drop jump L
|
|
NOC: drop drop jump L
|
|
CENTRE: drop dup NO-ROUTE
|
|
(AWAIT-FROM) a! @ xor if LEFT drop jump L
|
|
LEFT: drop 3 jump (A-END)
|
|
KEEP: (TAKE-KEEP) 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@
|