admin/LithosAnanake
1
1
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

feat(v4): the ROM assembles text as text.c does -- words, labels, macros, FOR, directives, start

Browse Source 
word.f18: (NEXT-TOKEN) reads the console or a macro being expanded; labels,
branches by name (a label of the word, or a word, now or later), the
table of branches waiting, end of word, FOR/NEXT/UNEXT, macros, &NAME,
CONST+N, and (ONE), which dispatches a token.  A forward branch to a name
not yet defined waits on a placeholder symbol, filled in by (DEFINE).
dir.f18: constant set here #, ", store, and start, which resolves, clears
the tables the ROM used and runs the word it names.  main.f18: the ROM
itself, entry 12; on an error it stops at (ROM-FAILED) with the code and
line in its state, for the loader to report.  sym.f18 generalized: any
counted string, placeholders, a hash of only a name's own cells.

test_host_rom_asm.c gives test_text.c's own texts (accepted and refused),
its four real definitions and the ROM's directives to text.c and to the
ROM: the same words, the same errors on the same lines, at both widths.
The ROM is 2036 words.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-15 12:24:08 -04:00
co-authored by Claude Opus 5.5
parent c233cb6536
commit 084c520a54
10 changed files with 1047 additions and 39 deletions
Download Patch File Download Diff File Expand all files Collapse all files
capsules/v4/rom/dir.f18
+132
View File
@@ -0,0 +1,132 @@
\ dir.f18 -- the ROM's directives, and the end of the system's source.
\
\ What mkimage.c and text.c's header did in C is said in the source with
\ these (MACHINE.md, the ROM's language). Each is a machine notion -- an
\ address, a cell, a value -- and none is FORTH.
\ constant NAME VALUE NAME is the number VALUE
\ set NAME VALUE an assembler variable: may be set again
\ #, VALUE one cell of data at the next word address
\ ", TOKEN TOKEN, whatever its characters, as a counted string
\ store ADDR VALUE ADDR := VALUE, anywhere in RAM
\ start NAME the end: every branch must have its target; the
\ tables the ROM used are cleared; then NAME runs
\ A VALUE is a number, a constant, a set variable, CONST+N, here (the next
\ word address) or &NAME of a word already defined.
\ ( -- v 1 | 0 0 ) the token as a VALUE; "not a value" if it is none
: (VALUE)
(NUMBER) if NN
-if NUMOK drop drop ERR-BIG (FAIL) 0 0 ;
NUMOK: drop 1 ;
NN: drop drop
&(RESERVED) (WALK) 8 xor if HR drop
0 (CHAR@) 38 xor if AMPV drop
(FIND) if NOSYM
dup 2 + a! @ 2 xor if CV drop
dup 2 + a! @ 4 xor if CV drop
drop jump BAD
CV: drop 3 + a! @ 1 ;
NOSYM: drop
(CONST+N) if BAD0 ;
BAD0: drop drop
BAD: ERR-VALUE (FAIL) 0 0 ;
HR: drop (LABEL) 1 ;
AMPV: drop (TOKN) a! @ -1 + if ONEV drop
(TOK-SAVE) 1 (MLEN) a! @ -1 + (TOK-SUB)
(FIND) if BADA
dup 2 + a! @ 1 xor if OKA drop drop jump BADA0
OKA: drop 3 + a! @ 1 ;
BADA: drop
BADA0: ERR-AMP (FAIL) 0 0 ;
ONEV: drop jump BAD
\ ( -- v 1 | 0 0 ) the next token as a VALUE
: (NEXT-VALUE)
(NEXT-TOKEN) if MISS drop jump (VALUE)
MISS: drop ERR-MISSING (FAIL) 0 0 ;
: (H-CONSTANT)
(IN-MACRO?) if OK drop ;
OK: drop
(NEXT-TOKEN) if MISS drop
(TOK) (TSAVE) 16 (COPY)
(NEXT-TOKEN) if MISS drop
(NUMBER) if NAN
-if NUM drop drop ERR-BIG jump (FAIL)
NUM: drop (NAME-BACK) 2 jump (DEFINE)
NAN: drop drop ERR-VALUE jump (FAIL)
MISS: drop ERR-MISSING jump (FAIL)
: (H-SET)
(IN-MACRO?) if OK drop ;
OK: drop
(NEXT-TOKEN) if MISS drop
(TOK) (TSAVE) 16 (COPY)
(NEXT-VALUE) if BADV drop
(NAME-BACK) 4 jump (DEFINE)
BADV: drop drop ;
MISS: drop ERR-MISSING jump (FAIL)
\ here alone is not something to assemble: only a VALUE
: (H-HERE) ERR-TARGET jump (FAIL)
: (H-CELL)
(IN-MACRO?) if OK drop ;
OK: drop
(NEXT-VALUE) if BADV drop
(LABEL) drop jump (EMIT)
BADV: drop drop ;
: (H-STRING)
(IN-MACRO?) if OK drop ;
OK: drop
(RAW-TOKEN) if MISS drop
(LABEL) drop
(TOKN) a! @ 4 + 2/ 2/ (T1) a! ! 0 (T2) a! !
L: (T2) a! @ (T1) a! @ xor if D drop
(T2) a! @ (TOK) + a! @ (EMIT)
(T2) a! @ 1 + ! jump L
D: drop ;
MISS: drop ERR-MISSING jump (FAIL)
: (H-STORE)
(IN-MACRO?) if OK drop ;
OK: drop
(NEXT-VALUE) if BADV drop (T1) a! !
(NEXT-VALUE) if BADV drop
(T1) a! @ b! !b ;
BADV: drop drop ;
\ ( -- ) clear the tables the ROM uses only while it assembles: the symbol
\ table in dictionary space, the branches, labels and names in the block
\ window, the saved token and macro body in the text input buffer
: (CLEAR)
DICT-W a! DICT-END DICT-W inv 1 + + -1 + FOR 0 !+ NEXT
BUF0 a! 1023 FOR 0 !+ NEXT
TIB-W a! 259 FOR 0 !+ NEXT
0 (RECN) a! ! 0 (POOLN) a! ! 0 (NREF) a! ! 0 (NLAB) a! !
0 (WNP) a! ! 0 (NFOR) a! ! 0 (RDEPTH) a! ! ;
\ start NAME: the system's source has ended
: (H-START)
(IN-MACRO?) if OK drop ;
OK: drop
(NEXT-TOKEN) if MISS drop
(TOK) (TSAVE) 16 (COPY)
(END-WORD)
(FAILED) a! @ if F0 drop ;
F0: drop
(NREF) a! @ if NOREF drop
ERR-UNDEFINED (FAIL) (REFS) 1 + a! @ (ERRLINE) a! ! ;
NOREF: drop
(LABEL) drop
(NAME-BACK)
(FIND) if NOTW
dup 2 + a! @ 1 xor if ISW drop drop jump NOTW0
ISW: drop 3 + a! @ (T1) a! !
(CLEAR)
0 DSTACK-REG a! ! 0 RSTACK-REG a! !
(T1) a! @ push ;
NOTW: drop
NOTW0: ERR-START jump (FAIL)
MISS: drop ERR-MISSING jump (FAIL)
capsules/v4/rom/in.f18
+6
View File
@@ -17,6 +17,7 @@
\ (EOF) non-zero once EOT has been read
\ (FAILED) 0, or the code of the error that stopped the ROM
\ (ERRLINE) (LINE) when it failed
\ (RAW) 1 while a token is read raw: ( and \ are then names
\ Every routine here uses A.
\ ( -- c ) wait for a character, then take it
@@ -78,6 +79,8 @@
drop jump READ
TEND: drop (BACK)
(TOKN) a! @ (TOK) a! @ xor !
(RAW) a! @ if COOKED drop (TOKN) a! @ ;
COOKED: drop
(TOKN) a! @ 1 xor if ONE
drop (TOKN) a! @ ;
ONE: drop 0 (CHAR@)
@@ -103,3 +106,6 @@
NL: drop drop (LF+) jump SKIP
SP: drop drop jump SKIP
LONG: drop drop ERR-TOO-LONG (FAIL) 0 ;
\ ( -- len ) the next token, raw: ( and \ are names, not comments
: (RAW-TOKEN) 1 (RAW) a! ! (TOKEN) 0 (RAW) a! ! ;
capsules/v4/rom/main.f18
+26
View File
@@ -19,3 +19,29 @@
jump (BRANCH>) \ 9 ( op -- ref )
jump (RESOLVE) \ 10 ( ref target -- )
jump (LABEL) \ 11 ( -- addr )
jump (ROM) \ 12 the ROM itself: where the machine starts
\ ( -- ) the state the ROM begins from: code goes to ORIGIN, nothing read,
\ nothing defined
: (INIT)
(CLEAR)
ORIGIN (HERE) a! ! 0 (CUR) a! ! 0 (SLOT) a! ! 0 (NLIT) a! !
0 (FAILED) a! ! 0 (ERRLINE) a! ! 0 (LINE) a! ! 0 (EOF) a! !
0 (PEEK) a! ! 0 (RAW) a! ! ;
\ the ROM: assemble the system's source from the console until its start
\ runs it; on an error, stop at (ROM-FAILED) with the error's code in
\ (FAILED) and its line in (ERRLINE), for the loader to report
: (ROM)
(INIT)
L: (NEXT-TOKEN) if END drop
(ONE)
(FAILED) a! @ if L0 drop jump (ROM-FAILED)
L0: drop jump L
END: drop
(FAILED) a! @ if NS drop jump (ROM-FAILED)
NS: drop ERR-NO-START (FAIL) jump (ROM-FAILED)
: (ROM-FAILED)
H: jump H
capsules/v4/rom/sym.f18
+86 -38
View File
@@ -1,28 +1,33 @@
\ sym.f18 -- the ROM's symbol table.
\
\ A name the ROM assembles is given a kind and a value: 1 a word (its
\ address), 2 a constant, 3 a macro, 4 a set variable. The rules are
\ address), 2 a constant, 3 a macro, 4 a set variable. Kind 0 is a name
\ only branched to so far: a placeholder that the forward branches to it
\ wait on (word.f18), which (DEFINE) fills in. The rules are
\ v4/src/text.c's define: a name may not be an opcode, a reserved word, a
\ label (NAME:), a number or start with &; nothing is defined twice, except
\ that a set variable may be set again.
\ that a set variable may be set again and a placeholder be defined.
\
\ The table is used only while the ROM assembles, and lives in dictionary
\ space: 256 hash heads at (SYMH); records of four cells -- link, name,
\ kind, value -- growing up from SYMREC; names, as counted strings, growing
\ kind, value -- growing up from SYMREC; names and macro bodies, growing
\ down from POOLTOP. When the two would meet, "too many names". (RECN) and
\ (POOLN) count the cells used, so an empty table is all zeroes. Names are
\ compared as the token is held, a counted string, a cell at a time.
\ counted strings, the form the token is held in, compared a cell at a time.
\ (REC) (CNT) (PTR) (I) (WI) are working cells. Every routine uses A; some B.
\ ( addr -- f ) 1 if the counted string at addr is the token
: (SAME?)
(PTR) a! ! (TOK) (I) a! !
(TOKN) a! @ 4 + 2/ 2/
\ ( p q -- f ) 1 if the counted strings at p and q are the same
: (SAME2?)
(I) a! ! (PTR) a! !
(PTR) a! @ a! @ 255 and 4 + 2/ 2/
L: (PTR) a! @ b! @b (I) a! @ a! @ xor if EQ drop drop 0 ;
EQ: drop (PTR) a! @ 1 + ! (I) a! @ 1 + !
-1 + if DONE jump L
DONE: drop 1 ;
\ ( addr -- f ) 1 if the counted string at addr is the token
: (SAME?) (TOK) jump (SAME2?)
\ ( table -- i | -1 ) which counted string of a table the token is; the
\ table ends with a zero cell
: (WALK)
@@ -52,27 +57,82 @@
\ ( -- op | -1 ) which opcode the token names
: (OPCODE) &(MNEMONICS) jump (WALK)
\ ( -- h ) the token's hash, 0 .. 255, from its first two cells
: (HASH)
(TOK) a! @+ @ xor
dup 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ +
\ ( -- f ) 1 if the token is a reserved word
: (RESERVED?) &(RESERVED) (WALK) -if Y drop 0 ;
Y: drop 1 ;
\ ( p -- h ) the hash, 0 .. 255, of the counted string at p, from its
\ first cell, and its second if the name runs into it (4 characters or more:
\ the cell after a shorter name is not its own)
: (HASH-AT)
a! @+ dup 255 and -4 + -if TWO drop jump MIX
TWO: drop @ xor
MIX: dup 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ +
dup 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ 2/ +
255 and ;
\ ( -- rec | 0 ) the newest record whose name is the token
: (FIND)
(HASH) (SYMH) + a! @
\ ( p -- rec | 0 ) the newest record whose name is the counted string at p,
\ placeholders included
: (FIND-AT)
dup (T3) a! ! (HASH-AT) (SYMH) + a! @
L: if NONE
dup (REC) a! ! 1 + a! @ (SAME?) if NO
dup (REC) a! ! 1 + a! @ (T3) a! @ (SAME2?) if NO
drop (REC) a! @ ;
NO: drop (REC) a! @ a! @ jump L
NONE: ;
\ ( -- rec | 0 ) the token's record, placeholders included
: (FIND0) (TOK) jump (FIND-AT)
\ ( -- rec | 0 ) the token's record, if it has been defined
: (FIND)
(FIND0) if NONE
dup 2 + a! @ if PH drop ;
PH: drop drop 0 ;
NONE: ;
\ ( n -- addr | 0 ) n cells of the pool, below what it holds; 0 if they
\ would meet the records ("too many names")
: (ALLOC)
dup (CNT) a! !
POOLTOP (POOLN) a! @ inv 1 + + (CNT) a! @ inv 1 + +
dup SYMREC (RECN) a! @ + 4 + inv 1 + +
-if ROOM drop drop drop ERR-NAMES (FAIL) 0 ;
ROOM: drop push drop
(POOLN) a! @ (CNT) a! @ + (POOLN) a! !
pop ;
\ ( from to n -- ) copy n cells, n at least 1
: (COPY)
(CN) a! ! (CTO) a! ! (CFROM) a! !
L: (CN) a! @ if D drop
(CFROM) a! @ a! @ (CTO) a! @ b! !b
(CFROM) a! @ 1 + ! (CTO) a! @ 1 + ! (CN) a! @ -1 + ! jump L
D: drop ;
\ ( value kind p -- rec | 0 ) a new record for the counted string at p,
\ the name copied into the pool; 0 if there is no room
: (NEW-REC)
dup (T3) a! !
a! @ 255 and 4 + 2/ 2/ (ALLOC)
if FULL
dup (T4) a! !
push (T3) a! @ pop (T3) a! @ a! @ 255 and 4 + 2/ 2/ (COPY)
SYMREC (RECN) a! @ + (REC) a! !
(T4) a! @ (REC) a! @ 1 + a! !
(REC) a! @ 2 + a! !
(REC) a! @ 3 + a! !
(T4) a! @ (HASH-AT) (SYMH) + dup a! @ (REC) a! @ a! !
(REC) a! @ over a! ! drop
(RECN) a! @ 4 + !
(REC) a! @ ;
FULL: drop drop drop 0 ;
\ ( -- f ) 1 if the token cannot be a name
: (BADNAME?)
(OPCODE) -if BAD
drop &(RESERVED) (WALK) -if BAD
drop (NUMBER) push drop pop if NOTNUM drop 1 ;
drop (RESERVED?) if NOTRES drop 1 ;
NOTRES: drop (NUMBER) push drop pop if NOTNUM drop 1 ;
NOTNUM: drop 0 (CHAR@) 38 xor if AMP
drop (TOKN) a! @ -1 + if ONE
(CHAR@) 58 xor if COLON drop 0 ;
@@ -81,30 +141,18 @@
AMP: drop 1 ;
BAD: drop 1 ;
\ ( value kind -- ) give the token a kind and a value
\ ( value kind -- ) give the token a kind and a value. A placeholder is
\ filled in, and the branches waiting on it are told (word.f18, (DEFINED)).
: (DEFINE)
(BADNAME?) if OKNAME drop drop drop ERR-BAD-NAME jump (FAIL)
OKNAME: drop
(FIND) if NEW
(FIND0) if NEW
dup 2 + a! @ if FILL drop
over 4 xor if K4 drop drop drop drop ERR-DEFINED jump (FAIL)
K4: drop 2 + a! @ 4 xor if BOTH drop drop drop ERR-DEFINED jump (FAIL)
BOTH: drop drop (REC) a! @ 3 + a! ! ;
NEW: drop
(TOKN) a! @ 4 + 2/ 2/ (CNT) a! !
POOLTOP (POOLN) a! @ inv 1 + + (CNT) a! @ inv 1 + +
dup SYMREC (RECN) a! @ + 4 + inv 1 + +
-if ROOM drop drop drop drop ERR-NAMES jump (FAIL)
ROOM: drop
dup (PTR) a! ! (TOK) (I) a! ! (CNT) a! @
C: (I) a! @ a! @ (PTR) a! @ b! !b
(PTR) a! @ 1 + ! (I) a! @ 1 + !
-1 + if CD jump C
CD: drop
(POOLN) a! @ (CNT) a! @ + (POOLN) a! !
SYMREC (RECN) a! @ + (REC) a! !
(REC) a! @ 1 + a! !
(REC) a! @ 2 + a! !
FILL: drop dup (REC) a! !
2 + a! !
(REC) a! @ 3 + a! !
(HASH) (SYMH) + dup a! @ (REC) a! @ a! !
(REC) a! @ over a! ! drop
(RECN) a! @ 4 + ! ;
(REC) a! @ jump (DEFINED)
NEW: drop (TOK) (NEW-REC) drop ;
capsules/v4/rom/word.f18
+390
View File
@@ -0,0 +1,390 @@
\ word.f18 -- the ROM assembles words: names, labels, branches, macros, FOR.
\
\ The rules are v4/src/text.c's one_token, end_word and branch:
\ : NAME a word begins at the next instruction word
\ NAME: a label of the word being assembled
\ jump X call X if X -if X next X
\ a branch to X: a label of this word, before or after the
\ branch, if it has one of that name; otherwise a word
\ X a call to the word X, defined already or later
\ &X the address of the word X, already defined, as a literal
\ 123 $FF CONST CONST+N a literal
\ a macro its tokens, read in its place
\ FOR ... NEXT FOR ... UNEXT
\ A branch to a label not yet seen waits, local to its word, in the table
\ of branches (REFS); when the word ends, a name that is not a label of it
\ must be a word, and the branch then waits on that name's symbol -- a
\ placeholder if it has none yet (sym.f18) -- until it is defined.
\
\ State, in the ROM's area: (NREF) (NLAB) (WNP) (NFOR) (FORS) (RDEPTH)
\ (RPTRS). Tables, used only while assembling: (REFS) four cells an entry
\ -- the word, the line, a symbol record (or, while local, a name), 1 if
\ local; (LABELS) a name and an address; (WNAMES) the word's names. Uses
\ A and B, and the working cells (T1) .. (T6), (MLEN).
\ ---- reading: the console, or a macro being expanded ----------------------
\ ( -- len ) the next token, from the innermost macro being expanded, or
\ from the console. A macro's body is its tokens as counted strings, then
\ a zero cell.
: (NEXT-TOKEN)
L: (RDEPTH) a! @ if SRC
-1 + (RPTRS) + dup (T1) a! ! a! @
dup a! @ if EOM
255 and dup (TOKN) a! !
4 + 2/ 2/ dup (T2) a! !
push (TOK) pop (COPY)
(T1) a! @ a! @ (T2) a! @ + (T1) a! @ a! !
(TOKN) a! @ ;
EOM: drop drop (RDEPTH) a! @ -1 + ! jump L
SRC: drop jump (TOKEN)
\ ---- the token, taken apart ------------------------------------------------
\ ( -- ) save the token's characters, a character to a cell, in (MTEMP)
: (TOK-SAVE)
(TOKN) a! @ (MLEN) a! ! 0 (T5) a! !
L: (T5) a! @ (MLEN) a! @ xor if D drop
(T5) a! @ (CHAR@) (T5) a! @ (MTEMP) + b! !b
(T5) a! @ 1 + ! jump L
D: drop ;
\ ( start len -- ) the token becomes characters start .. start+len-1 of
\ the one saved by (TOK-SAVE)
: (TOK-SUB)
(T6) a! ! (T5) a! !
(TOK) a! 15 FOR 0 !+ NEXT
0 (TOKN) a! !
L: (T6) a! @ if D drop
(T5) a! @ (MTEMP) + a! @ (PUT)
(T5) a! @ 1 + ! (T6) a! @ -1 + ! jump L
D: drop (TOKN) a! @ (TOK) a! @ xor ! ;
\ ( -- f ) 1 if the token is a label's definition: NAME:
: (LABELFORM?)
(TOKN) a! @ -1 + if NO
(CHAR@) 58 xor if YES drop 0 ;
YES: drop 1 ;
NO: drop 0 ;
\ ---- the word's names: labels, and names branched to before they are seen --
\ ( -- p | 0 ) the token, copied into the word's name area
: (WNAME)
(TOKN) a! @ 4 + 2/ 2/ (T6) a! !
(WNP) a! @ (T6) a! @ + WN-SIZE inv 1 + + -1 + -if FULL drop
(WNAMES) (WNP) a! @ +
(TOK) over (T6) a! @ (COPY)
(WNP) a! @ (T6) a! @ + (WNP) a! ! ;
FULL: drop ERR-NAMES (FAIL) 0 ;
\ ( -- addr | -1 ) the address of the word's label named by the token
: (LAB-FIND)
0 (T5) a! !
L: (T5) a! @ (NLAB) a! @ xor if NONE drop
(T5) a! @ 2* (LABELS) + a! @ (SAME?) if NO
drop (T5) a! @ 2* (LABELS) + 1 + a! @ ;
NO: drop (T5) a! @ 1 + ! jump L
NONE: drop -1 ;
\ ---- the branches waiting for a target -------------------------------------
\ ( word sym local -- ) one more branch waiting
: (REF-ADD)
(NREF) a! @ REFS-MAX inv 1 + + -if FULL drop
(NREF) a! @ 2* 2* (REFS) + (T5) a! !
(T5) a! @ 3 + a! !
(T5) a! @ 2 + a! !
(T5) a! @ a! !
(LINE) a! @ (T5) a! @ 1 + a! !
(NREF) a! @ 1 + ! ;
FULL: drop drop drop drop ERR-REFS jump (FAIL)
\ ( i target -- ) the waiting branch i gets its target, and stops waiting:
\ the last entry takes its place. A branch that cannot reach is reported
\ at the line it was written on.
: (REF-RESOLVE)
(T4) a! !
2* 2* (REFS) + dup (T3) a! !
a! @ (T4) a! @ (RESOLVE)
(FAILED) a! @ if OK drop
(T3) a! @ 1 + a! @ (ERRLINE) a! ! ;
OK: drop
(NREF) a! @ -1 + dup (NREF) a! !
2* 2* (REFS) + (T3) a! @ 4 (COPY) ;
\ ( addr -- ) a label has been defined at addr: the branches in this word
\ waiting on its name, the token, get it
: (LOCAL-RESOLVE)
(T1) a! ! 0 (T2) a! !
L: (T2) a! @ (NREF) a! @ xor if DONE drop
(FAILED) a! @ if GO drop ;
GO: drop
(T2) a! @ 2* 2* (REFS) +
dup 3 + a! @ if SKIP drop
2 + a! @ (SAME?) if NX
drop (T2) a! @ (T1) a! @ (REF-RESOLVE) jump L
SKIP: drop drop jump NX1
NX: drop
NX1: (T2) a! @ 1 + ! jump L
DONE: drop ;
\ ( rec -- ) the symbol rec has been defined (sym.f18, (DEFINE)): if it is
\ a word, the branches waiting on it get its address
: (DEFINED)
dup 2 + a! @ 1 xor if W drop drop ;
W: drop (T1) a! ! 0 (T2) a! !
L: (T2) a! @ (NREF) a! @ xor if DONE drop
(FAILED) a! @ if GO drop ;
GO: drop
(T2) a! @ 2* 2* (REFS) +
dup 3 + a! @ if NL drop drop jump NX
NL: drop 2 + a! @ (T1) a! @ xor if MATCH drop jump NX
MATCH: drop (T2) a! @ (T1) a! @ 3 + a! @ (REF-RESOLVE) jump L
NX: (T2) a! @ 1 + ! jump L
DONE: drop ;
\ ( -- ) the word being assembled ends: a FOR left open is an error; the
\ branches still local to it wait on their names' symbols, unless the name
\ is a word, which they then get; its labels and names go.
: (END-WORD)
(NFOR) a! @ if F0 drop 0 (NFOR) a! ! ERR-FOR jump (FAIL)
F0: drop
0 (T1) a! !
L: (T1) a! @ (NREF) a! @ xor if DONE drop
(FAILED) a! @ if GO drop ;
GO: drop
(T1) a! @ 2* 2* (REFS) +
dup 3 + a! @ if SKIP drop
0 over 3 + a! !
dup 2 + a! @ (FIND-AT)
if MK
dup 2 + a! @ 1 xor if RES drop
over 2 + a! ! drop jump NX
RES: drop push drop (T1) a! @ pop 3 + a! @ (REF-RESOLVE) jump L
MK: drop dup 2 + a! @ push 0 0 pop (NEW-REC)
over 2 + a! ! drop jump NX
SKIP: drop drop
NX: (T1) a! @ 1 + ! jump L
DONE: drop
0 (NLAB) a! ! 0 (WNP) a! ! ;
\ ---- branches by name ------------------------------------------------------
\ ( op local -- ) a branch to the name in the token. local: written after
\ a branch mnemonic, so it may be a label of this word, before or after.
: (BRANCH-NAME)
(T6) a! !
(T6) a! @ if CHK
drop (LAB-FIND) -if TOLAB drop jump CHK1
TOLAB: jump (BRANCH)
CHK: drop
(FIND) if CHK0
dup 2 + a! @ 1 xor if NOW drop drop jump BAD
NOW: drop 3 + a! @ jump (BRANCH)
CHK0: drop
CHK1:
(FIND) if C2
2 + a! @ 1 xor if C3 drop jump BAD
C3: drop jump C4
C2: drop
C4: (OPCODE) -if BAD1 drop
(RESERVED?) if C5 drop jump BAD
C5: drop (LABELFORM?) if C6 drop jump BAD
C6: drop (NUMBER) push drop pop if C7 drop jump BAD
C7: drop
(T6) a! @ if GLOBAL drop
(BRANCH>) (WNAME) 1 jump (REF-ADD)
GLOBAL: drop
(BRANCH>) (FIND0) if NEWPH
0 jump (REF-ADD)
NEWPH: drop 0 0 (TOK) (NEW-REC) 0 jump (REF-ADD)
BAD1: drop
BAD: drop ERR-TARGET jump (FAIL)
\ ---- labels ----------------------------------------------------------------
\ ( addr -- ) a label of this word, named by the token, at addr; the
\ branches already waiting on it get it
: (LAB-ADD)
(LAB-FIND) -if DUP drop
(NLAB) a! @ -64 + -if FULL drop
(WNAME) if FAILP
(NLAB) a! @ 2* (LABELS) + a! !
dup (NLAB) a! @ 2* (LABELS) + 1 + a! !
(NLAB) a! @ 1 + !
jump (LOCAL-RESOLVE)
DUP: drop drop ERR-LABEL-DUP jump (FAIL)
FULL: drop drop ERR-LABELS jump (FAIL)
FAILP: drop drop ;
\ ( -- ) NAME: -- a label at the next instruction word
: (LABEL-DEF)
(TOK-SAVE) 0 (MLEN) a! @ -1 + (TOK-SUB)
(LABEL) jump (LAB-ADD)
\ ---- FOR ... NEXT, FOR ... UNEXT --------------------------------------------
: (H-FOR)
(NFOR) a! @ -8 + -if DEEP drop
29 (OP) (LABEL) (NFOR) a! @ (FORS) + a! !
(NFOR) a! @ 1 + ! ;
DEEP: drop ERR-FOR jump (FAIL)
: (H-NEXT)
(NFOR) a! @ if NONE
-1 + dup (NFOR) a! ! (FORS) + a! @
push 5 pop jump (BRANCH)
NONE: drop ERR-FOR jump (FAIL)
\ unext repeats the word it is in: it must still be the word the body
\ began, with a slot left, owing no literal
: (H-UNEXT)
(NFOR) a! @ if NONE
-1 + dup (NFOR) a! ! (FORS) + a! @
(HERE) a! @ xor if SAMEW drop jump BAD
SAMEW: drop
(SLOT) a! @ if BAD0
-6 + -if BAD0 drop
(NLIT) a! @ if OK drop jump BAD
OK: drop 4 jump (OP)
BAD0: drop
BAD: ERR-UNEXT jump (FAIL)
NONE: drop ERR-FOR jump (FAIL)
\ ---- macros ----------------------------------------------------------------
\ ( -- ) restore the name (TSAVE) holds into the token
: (NAME-BACK) (TSAVE) (TOK) 16 (COPY) (TOK) a! @ 255 and (TOKN) a! ! ;
\ ( -- f ) 0 if not in a macro; else "not allowed in a macro", and 1
: (IN-MACRO?)
(RDEPTH) a! @ if NO drop ERR-IN-MACRO (FAIL) 1 ;
NO: ;
\ macro NAME ... endmacro: the tokens between, as counted strings, then a
\ zero cell, into the pool; NAME the macro, its value where they are. One
\ left open is reported at the line it began on, as text.c reports it.
: (H-MACRO)
(IN-MACRO?) if OK drop ;
OK: drop
(LINE) a! @ (T4) a! !
(NEXT-TOKEN) if NONAME drop
(TOK) (TSAVE) 16 (COPY)
0 (T1) a! !
L: (NEXT-TOKEN) if EOF drop
&(RESERVED) (WALK)
dup -2 + if END drop
dup if BAD2 drop
-1 + if BAD1 drop
(LABELFORM?) if APP drop jump BAD
APP: drop
(TOKN) a! @ 4 + 2/ 2/ dup (T2) a! !
(T1) a! @ + 1 + MBODY-SIZE inv 1 + + -1 + -if FULLM drop
(TOK) (MBODY) (T1) a! @ + (T2) a! @ (COPY)
(T1) a! @ (T2) a! @ + (T1) a! !
jump L
END: drop drop
0 (MBODY) (T1) a! @ + b! !b
(T1) a! @ 1 + (ALLOC) if FAILP
(MBODY) over (T1) a! @ 1 + (COPY)
(NAME-BACK)
3 jump (DEFINE)
FAILP: drop ;
BAD2: drop
BAD1: drop
BAD: ERR-IN-MACRO jump (FAIL)
FULLM: drop ERR-NAMES jump (FAIL)
EOF: drop ERR-MACRO (FAIL) (T4) a! @ (ERRLINE) a! ! ;
NONAME: drop ERR-MACRO jump (FAIL)
: (H-ENDMACRO) ERR-MACRO jump (FAIL)
\ ( body -- ) read a macro's tokens in its place
: (USE-MACRO)
(RDEPTH) a! @ -8 + -if DEEP drop
(RDEPTH) a! @ (RPTRS) + a! !
(RDEPTH) a! @ 1 + ! ;
DEEP: drop drop ERR-DEEP jump (FAIL)
\ ---- CONST+N ---------------------------------------------------------------
\ ( -- v 1 | 0 0 ) the token as a constant and a number after its last +;
\ if it is not one, the token is left as it was
: (CONST+N)
(TOK-SAVE)
(MLEN) a! @ -1 + (T1) a! !
L: (T1) a! @ -if GO drop jump NOPE
GO: (MTEMP) + a! @ 43 xor if FOUND drop
(T1) a! @ -1 + ! jump L
FOUND: drop
(T1) a! @ if NOPE0 drop
(T1) a! @ (MLEN) a! @ -1 + xor if NOPE0 drop
0 (T1) a! @ (TOK-SUB)
(FIND) if NOPE0
dup 2 + a! @ 2 xor if ISC drop drop jump NOPE
ISC: drop 3 + a! @ (T2) a! !
(T1) a! @ 1 + (MLEN) a! @ (T1) a! @ inv 1 + + -1 + (TOK-SUB)
(NUMBER) 1 xor if OKN drop drop jump NOPE
OKN: drop (T2) a! @ + 1 ;
NOPE0: drop
NOPE: 0 (MLEN) a! @ (TOK-SUB) 0 0 ;
\ ---- one token -------------------------------------------------------------
\ the reserved words' handlers, in (RESERVED)'s order
: (DISPATCH)
jump (H-COLON) jump (H-MACRO) jump (H-ENDMACRO)
jump (H-FOR) jump (H-NEXT) jump (H-UNEXT)
jump (H-CONSTANT) jump (H-SET) jump (H-HERE)
jump (H-CELL) jump (H-STRING) jump (H-STORE)
jump (H-START)
\ : NAME end the word before, and begin NAME at the next instruction word
: (H-COLON)
(IN-MACRO?) if OK drop ;
OK: drop
(NEXT-TOKEN) if NONAME drop
(END-WORD) (LABEL) 1 jump (DEFINE)
NONAME: drop ERR-MISSING jump (FAIL)
\ ( -- ) assemble the token
: (ONE)
&(RESERVED) (WALK) -if RES drop
(LABELFORM?) if NLD drop jump (LABEL-DEF)
NLD: drop
(OPCODE) -if OPC drop
0 (CHAR@) 38 xor if AMP drop
AFTERAMP:
(NUMBER) if NN
-if NUMOK drop drop ERR-BIG jump (FAIL)
NUMOK: drop jump (LIT)
NN: drop drop
(FIND) if NOSYM
dup 2 + a! @
dup 3 xor if MAC drop
dup 2 xor if CV drop
4 xor if CV0
drop drop 3 0 jump (BRANCH-NAME)
MAC: drop drop 3 + a! @ jump (USE-MACRO)
CV: drop drop 3 + a! @ jump (LIT)
CV0: drop 3 + a! @ jump (LIT)
NOSYM: drop
(CONST+N) if CALL drop jump (LIT)
CALL: drop drop 3 0 jump (BRANCH-NAME)
RES: &(DISPATCH) + push ;
OPC: dup 8 xor if FP drop
dup (BRANCH-OP?) if PLAIN drop
(NEXT-TOKEN) if NOTGT drop
1 jump (BRANCH-NAME)
PLAIN: drop jump (OP)
FP: drop drop ERR-FETCH-P jump (FAIL)
NOTGT: drop drop ERR-MISSING jump (FAIL)
AMP: drop (TOKN) a! @ -1 + if ONECH drop
(TOK-SAVE) 1 (MLEN) a! @ -1 + (TOK-SUB)
(FIND) if BADA
dup 2 + a! @ 1 xor if OKA drop drop jump BADA0
OKA: drop 3 + a! @ jump (LIT)
BADA: drop
BADA0: ERR-AMP jump (FAIL)
ONECH: drop jump AFTERAMP