admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
cbe1cd5e446b09cdab9ae0b42102971e4a96c50e
LithosAnanake/v4/capsule/quit.v4
T
rajamesandClaude Opus 5.5 cbe1cd5e44 feat(v4.0.0): a line from the console breaks a wait 
Text for a node from its console, arriving while the node waits for an
answer (AWAIT), is kept as any message is; the wait ends in error 21,
Interrupted; and the text is then done as usual.  Console text for
another node, passing through a node that is waiting, does not end its
wait.

On the hosted program 5 AWAIT ended the program with "the node stopped".
The boot now reports that the line is waiting, the host reads the next
line and hands it over, which breaks the wait, and then has the kept line
done.  The bare-metal host does the same; it is booted in the commit that
follows.

test_host_mesh.c: 76 checks, both widths and the sanitizers.  hosted-check
types 5 AWAIT and two more lines: Interrupted, then 3 and 56.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
2026-10-07 20:16:58 -04:00

462 lines
23 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.
: (FINISH) ( s -- )
(LINE-STATUS) b! dup !b
(FLUSH-OUT)
(DONE-PORT) a! @ (GATE) (MSG)+1 a! @ !b \ to whoever sent the text
3 (HDR) 4 !b !b \ a message of type 3, four characters long: how it ended
jump (IDLE)
: (DONE)
if GO -1 + if OK
drop (RESET) 2 jump (FINISH)
OK: drop 1 jump (FINISH)
GO: drop 0 jump (FINISH)
\ ( -- ) WAITING. A node with nothing to do deals with the oldest of the
\ messages waiting (core.v4). With none waiting 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, its first word
\ from any port and the rest from the port that came on. The message's
\ text goes into TIB, which holds 1024 characters, the most a message
\ carries; one that came with a length no message has is error 12. A
\ message of type 1 for this node is text to interpret: it is done as a
\ line was, and (FINISH) reports how it ended. A message for another node
\ is passed on, (PASS-ON).
: (IDLE)
L: (PAY) \ a refusal owed is sent first (core.v4)
(MQ#) a! @ if WAIT drop jump HAVE
WAIT: 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:
(MQ@) (MSG) a! ! (MQ@) (MSG)+1 a! ! (MQ@) (MSG)+2 a! ! (MQ@) (MSG)+3 a! !
(MQ@) (MSG)+4 a! ! (MQ@) (MSG)+5 a! ! (MQ@) (MSG)+6 a! ! (MQ@) (REPLY) a! !
(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
TIB 2/ 2/ (MSG)+6 a! @ 3 + 2/ 2/ if EMPTY
-1 + FOR (MQ@) over a! ! 1 + NEXT
drop jump READ
EMPTY: drop drop
READ:
0 (MSG)+6 a! @ TIB + C! \ a zero after the text
(MSG)+6 a! @ SPAN a! !
(MSG) a! @ (ME) a! @ xor if MINE drop jump (PASS-ON)
MINE: drop
(MSG)+2 a! @ -1 + if TEXT \ for this node, and
-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 (REPLY) a! @ (ROUTE-DEFAULT) a! @ xor if CENTRE \ a node is gone, if its centre says so:
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)
\ ( -- ) A MESSAGE FOR ANOTHER NODE is passed on (MESH.md section 7): all
\ of it, as it came, to the port that leads toward that node. With no way
\ known it is let go, and (LOST) counts it.
: (PASS-ON)
(MSG) a! @ (PORT-FOR) if NOWAY
(GATE) (MSG) a! 6 FOR @+ !b UNEXT \ its seven words
(MSG)+6 a! @ 3 + 2/ 2/ if SENT
-1 + TIB 2/ 2/ a! FOR @+ !b UNEXT \ and its text
jump (IDLE)
SENT: drop jump (IDLE)
NOWAY: drop (LOST) a! @ 1 + !
(MSG)+2 a! @ -4 + -if NOT-OWED \ its sender is told, unless it is a NACK or a GONE
drop (MSG)+1 a! @ (MSG) a! @ (OWE) jump (IDLE)
NOT-OWED: drop jump (IDLE)
\ ( -- ) 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 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 what lets one of two neighbours, and one
\ only, wait to write to the other (core.v4, (GATE)).
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) !b 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. The write waits for the neighbour to read, and is not begun
\ until it may be (core.v4, (GATE)).
: (SEND-ON)
(GATE) !b \ 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 ;
\ ( 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.
\ 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! !
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 (CONSOLE) a! @ if C0 jump C1 \ text: from the console?
C0: drop (MSG)+1 a! @ \ with none told of, whoever sent the text being done
C1: (MQ-HDR)+1 a! @ xor if BREAK drop jump KEEP
BREAK: drop (TAKE-KEEP) 0 (AWAIT-FROM) a! ! NODE-ERROR b! 21 !b ; \ 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 0 (AWAIT-FROM) a! ! NODE-ERROR b! 19 !b ;
GONE: drop (MQ-HDR)+6 a! @ -4 + if G4 drop jump KEEP
G4: drop @b \ the node that is gone
(MQ-HDR)+7 a! @ (ROUTE-DEFAULT) a! @ xor if CENTRE \ only its centre is believed
drop drop jump L
CENTRE: drop dup NO-ROUTE
(AWAIT-FROM) a! @ xor if LEFT drop jump L
LEFT: drop 0 (AWAIT-FROM) a! ! NODE-ERROR b! 20 !b ;
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.
: (RAISED)
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 $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