From 084c520a54a28761d399d2415283beb4a07fe063 Mon Sep 17 00:00:00 2001 From: rajames Date: Thu, 15 Oct 2026 12:24:08 -0400 Subject: [PATCH] feat(v4): the ROM assembles text as text.c does -- words, labels, macros, FOR, directives, start 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 --- capsules/v4/rom/dir.f18 | 132 ++++++++++++ capsules/v4/rom/in.f18 | 6 + capsules/v4/rom/main.f18 | 26 +++ capsules/v4/rom/sym.f18 | 124 +++++++---- capsules/v4/rom/word.f18 | 390 +++++++++++++++++++++++++++++++++++ v4/tests/host_map.h | 49 +++++ v4/tests/rom_asm_cases.h | 115 +++++++++++ v4/tests/rom_harness.h | 2 +- v4/tests/test_host_rom_asm.c | 191 +++++++++++++++++ v4/tools/mkmap.c | 51 +++++ 10 files changed, 1047 insertions(+), 39 deletions(-) create mode 100644 capsules/v4/rom/dir.f18 create mode 100644 capsules/v4/rom/word.f18 create mode 100644 v4/tests/rom_asm_cases.h create mode 100644 v4/tests/test_host_rom_asm.c diff --git a/capsules/v4/rom/dir.f18 b/capsules/v4/rom/dir.f18 new file mode 100644 index 00000000..f299db09 --- /dev/null +++ b/capsules/v4/rom/dir.f18 @@ -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) diff --git a/capsules/v4/rom/in.f18 b/capsules/v4/rom/in.f18 index 2cccec5c..692c6064 100644 --- a/capsules/v4/rom/in.f18 +++ b/capsules/v4/rom/in.f18 @@ -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! ! ; diff --git a/capsules/v4/rom/main.f18 b/capsules/v4/rom/main.f18 index c8a2f587..e969b562 100644 --- a/capsules/v4/rom/main.f18 +++ b/capsules/v4/rom/main.f18 @@ -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 + diff --git a/capsules/v4/rom/sym.f18 b/capsules/v4/rom/sym.f18 index 0e9ba649..2193e8c4 100644 --- a/capsules/v4/rom/sym.f18 +++ b/capsules/v4/rom/sym.f18 @@ -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 ; diff --git a/capsules/v4/rom/word.f18 b/capsules/v4/rom/word.f18 new file mode 100644 index 00000000..4d22cf73 --- /dev/null +++ b/capsules/v4/rom/word.f18 @@ -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 diff --git a/v4/tests/host_map.h b/v4/tests/host_map.h index 00bfb3af..49886da5 100644 --- a/v4/tests/host_map.h +++ b/v4/tests/host_map.h @@ -149,6 +149,38 @@ #define ROM_PTR (OUT_W - 124) /* (SAME?), (DEFINE): where in a name */ #define ROM_I (OUT_W - 123) /* where in the token */ #define ROM_WI (OUT_W - 122) /* (WALK): which entry of a table */ +#define ROM_NREF (OUT_W - 121) /* word.f18: how many branches wait for a target */ +#define ROM_NLAB (OUT_W - 120) /* how many labels the word being assembled has */ +#define ROM_WNP (OUT_W - 119) /* cells of the word's name area used */ +#define ROM_NFOR (OUT_W - 118) /* how many FORs are open */ +#define ROM_FORS (OUT_W - 117) /* where each began, 8 cells */ +#define ROM_RDEPTH (OUT_W - 109) /* how many macros are being expanded */ +#define ROM_RPTRS (OUT_W - 108) /* where each is reading, 8 cells */ +#define ROM_T1 (OUT_W - 100) /* working cells */ +#define ROM_T2 (OUT_W - 99) +#define ROM_T3 (OUT_W - 98) +#define ROM_T4 (OUT_W - 97) +#define ROM_CFROM (OUT_W - 96) +#define ROM_CTO (OUT_W - 95) +#define ROM_CN (OUT_W - 94) +#define ROM_RAW (OUT_W - 93) /* in.f18: 1 while a token is read raw, ( and \ being names */ +#define ROM_T5 (OUT_W - 92) +#define ROM_T6 (OUT_W - 91) +#define ROM_MLEN (OUT_W - 90) /* the length of the token saved in ROM_MTEMP */ +#define ROM_ORIGIN 16 /* where the system's code begins */ +/* The ROM's other tables, used only while it assembles (cleared at `start`): in the block window, the branches + * waiting -- four cells each: the word, the line, a symbol record (or, while local, a name), 1 if local -- the + * labels of the word being assembled -- a name and an address -- and their names; in the text input buffer, a + * saved token, a character to a cell, a macro's name and its body being collected. */ +#define ROM_REFS BUF0_W /* 128 entries */ +#define ROM_REFS_MAX 128 +#define ROM_LABELS (BUF0_W + 512) /* 64 entries */ +#define ROM_WNAMES (BUF0_W + 640) /* 384 cells */ +#define ROM_WN_SIZE 384 +#define ROM_TSAVE TIB_W /* 16 cells */ +#define ROM_MTEMP (TIB_W + 16) /* 64 cells */ +#define ROM_MBODY (TIB_W + 80) /* 180 cells */ +#define ROM_MBODY_SIZE 180 /* THE ROM'S SYMBOL TABLE, used only while it assembles, in dictionary space (cleared at `start`): 256 hash heads, * then records growing up -- link, name, kind, value -- and names, as counted strings, growing down from the top. */ #define ROM_SYMH DICT_W @@ -170,6 +202,23 @@ #define ROM_ERR_NAMES 5 /* the symbol table is full: "too many names" */ #define ROM_ERR_FIT 6 /* memory is full, or a branch cannot reach: "does not fit" */ #define ROM_ERR_OPCODE 7 /* not an opcode the packer takes there */ +#define ROM_ERR_IN_MACRO 8 /* "not allowed in a macro" */ +#define ROM_ERR_MACRO 9 /* "macro without endmacro", "endmacro without macro" */ +#define ROM_ERR_LABEL_DUP 10 /* "label already defined in this word" */ +#define ROM_ERR_LABELS 11 /* "too many labels in one word" */ +#define ROM_ERR_FOR 12 /* FOR nested too deep, NEXT or UNEXT without FOR, FOR without NEXT */ +#define ROM_ERR_UNEXT 13 /* "FOR ... UNEXT must fit one instruction word and hold no literal" */ +#define ROM_ERR_TARGET 14 /* "not something to branch to" */ +#define ROM_ERR_UNDEFINED 15 /* "never defined" */ +#define ROM_ERR_BIG 16 /* "number does not fit a cell" */ +#define ROM_ERR_AMP 17 /* "& needs a word that is already defined" */ +#define ROM_ERR_FETCH_P 18 /* "write the number, not @p" */ +#define ROM_ERR_MISSING 19 /* a name, a target, a value or a string missing at the end */ +#define ROM_ERR_DEEP 20 /* "macros nested too deep" */ +#define ROM_ERR_REFS 21 /* "too many unresolved branches" */ +#define ROM_ERR_VALUE 22 /* "not a value", "not a number" */ +#define ROM_ERR_NO_START 23 /* the input ended with no start */ +#define ROM_ERR_START 24 /* start: not a word */ #define ROM_ADDR_TOP ((v4_cell)(V4_NODE_WORDS + V4_ROM_WORDS - 1u)) /* the top of the address space */ #define WORD_DEFINED (BUF0_W - 11) /* the xt of the word that is told of each new entry, or 0 */ #define WORD_FORGOTTEN (BUF0_W - 12) /* the xt of the word that is told when entries go, or 0 */ diff --git a/v4/tests/rom_asm_cases.h b/v4/tests/rom_asm_cases.h new file mode 100644 index 00000000..bd380552 --- /dev/null +++ b/v4/tests/rom_asm_cases.h @@ -0,0 +1,115 @@ +/* rom_asm_cases.h -- the texts of v4/tests/test_text.c, accepted and refused, that the ROM's language has + * (no header and no flags). Extracted once from test_text.c; each is given to text.c and to the ROM, and + * test_host_rom_asm.c requires the same outcome. */ +static const char *const rom_asm_cases[] = { + ": T 123 ;", + ": T -5 ;", + ": T $FF ;", + ": T $ff $Ab + ;", + ": T 0 ;", + ": T 1 2 3 4 5 6 7 + + + + + + ;", + ": T 4294967295 ;", + ": T -2147483648 ;", + ": T $FFFFFFFF ;", + ": T 4294967296 ;", + ": T -2147483649 ;", + ": T $100000000 ;", + ": T 18446744073709551615 ;", + ": T -9223372036854775808 ;", + ": T $FFFFFFFFFFFFFFFF ;", + ": T 18446744073709551616 ;", + ": T -9223372036854775809 ;", + ": T $10000000000000000 ;", + ": T 99999999999999999999999999 ;", + ": T VAR ;", + ": ST ( x -- ) VAR a! ! ; : LD ( -- x ) VAR a! @ ;", + "\\ a line comment\n: T ( a stack comment ) 7 \\ another\n ( and\n one over two lines ) 8 + ; \\ the end", + ": (T) 5 ; : T (T) (T) + ;", + ": T 1 ( never closed", + ": T @p ;", + ": A 3 ; : T A A + ;", + ": T A A + ; : A 4 ;", + ": T jump A : A 9 ;", + ": T call A 1 + ; : A 9 ;", + ": A 1 ; : B A A + ; : C B B + ; : T C C + ;", + ": T 5 \n : U 1 + ;", + ": T ( n -- 1|2 ) if Z drop 1 ; Z: drop 2 ;", + ": T ( n -- 0 ) L: if DONE -1 + jump L DONE: ;", + ": T ( n -- f ) -if P drop -1 ; P: drop 0 ;", + ": A ( n -- 1|2 ) if L drop 1 ; L: drop 2 ; : T ( n -- 3|4 ) if L drop 3 ; L: drop 4 ;", + ": L 50 ; : T ( n -- x ) if L drop 1 ; L: drop 2 ;", + ": L 50 ; : T ( n -- x ) L: if DONE -1 + jump L DONE: drop 3 ;", + ": L drop 50 ; : T ( n -- x ) if L drop 1 ; : U 2 ;", + ": L drop 50 ; : T ( n -- x ) if L drop 1 ;", + ": T ( n -- x ) if OUT drop 1 ; : OUT drop 77 ;", + ": T L: 1 L: 2 ;", + ": T if NOWHERE ;\n: U 1 ;", + "\n\n: T 1 MISSING + ;", + ": T jump", + ": T jump 5 ;", + ": T jump VAR ;", + ": T jump dup ;", + ": T ( n -- n+5 ) 4 FOR 1 + NEXT ;", + ": T ( n -- n*8 ) 2 FOR 2* UNEXT ;", + ": T ( n -- x ) 1 FOR 2 FOR 2* UNEXT NEXT ;", + ": T ( n -- x ) 2 FOR 2* UNEXT 1 + ;", + ": T ( n -- x ) 2 FOR dup + 2* nop UNEXT ;", + ": T 2 FOR dup + 2* nop nop nop UNEXT ;", + ": T 2 FOR 1 + UNEXT ;", + ": T NEXT ;", + ": T UNEXT ;", + ": T 3 FOR 1 + ;\n: U ;", + ": T 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR 0 FOR ;", + "macro SWAP over push push drop pop pop endmacro : T ( a b -- b ) SWAP drop ;", + "macro 1+ 1 + endmacro macro 2+ 1+ 1+ endmacro : T 2+ 2+ ;", + "macro TEN ( a comment ) 10 \\ and another\n endmacro : T TEN TEN + ;", + "macro SHL3 2 FOR 2* UNEXT endmacro : T SHL3 ;", + ": A 6 ; macro CALLS A A + endmacro : T CALLS ;", + "macro NOTHING endmacro : T 5 NOTHING ;", + "macro M L: endmacro", + "macro M : X ; endmacro", + "macro M macro N endmacro endmacro", + "macro M 1 2 3", + "macro", + ": T endmacro ;", + "macro M M endmacro : T M ;", + ": A 1 ;\n: A 2 ;", + ": VAR 1 ;", + "macro A 1 endmacro : A 2 ;", + ": dup 1 ;", + ": 12 1 ;", + ": FOR 1 ;", + "macro + 1 endmacro", + ": X: 1 ;", + ":", + ": T THIS-NAME-IS-MUCH-TOO-LONG-TO-BE-A-NAME-IN-THIS-ASSEMBLER-BY-A-WIDE-MARGIN ;", + ": Dup 3 ; : T Dup Dup + ;", + ": 2DUP over over ; : 1+ 1 + ; : T ( a b -- 2a+2b+1 ) 2DUP + + + 1+ ;", + ": T VAR+3 ;", + ": T VAR+0 VAR+10 + ;", + ": VAR+1 77 ; : T VAR+1 ;", + ": T VAR+ ;", + ": T VAR+x ;", + ": T NOPE+1 ;", + ": A 5 ; : T &A ;", + ": A 5 ; : T &A push ;", + ": T &A ; : A 5 ;", + ": T &VAR ;", + ": &X 1 ;", + ": T 1 ;", + ": T 1 ;\n: T 2 ;", + "constant SEVEN 7 constant MINUS -2 constant BIG $7F : T SEVEN MINUS + BIG + ;", + "constant K 3 : T K+2 ;", + "constant K 3 constant K 4", + "constant dup 3", + "constant K", + "constant K x", + ": constant ;", + "constant K 9 : T ; #, 5 #, -1 #, K #, K+2 #, &T \", ab \", ( \", abcde", + ": T dup #, 7 ;", + "#, x", + "#,", + "\",", + ": #, ;", + ": \", ;", +}; diff --git a/v4/tests/rom_harness.h b/v4/tests/rom_harness.h index 18c46c8b..19a1c89b 100644 --- a/v4/tests/rom_harness.h +++ b/v4/tests/rom_harness.h @@ -30,7 +30,7 @@ extern const unsigned v4_rom_32_words; /* The entry table, in its fixed order: entry i is at V4_ROM_BASE + i. */ static const char *const rom_entries[] = { "(KEY)", "(TOKEN)", "(NUMBER)", "(FIND)", "(DEFINE)", "(OPCODE)", - "(OP)", "(LIT)", "(BRANCH)", "(BRANCH>)", "(RESOLVE)", "(LABEL)" + "(OP)", "(LIT)", "(BRANCH)", "(BRANCH>)", "(RESOLVE)", "(LABEL)", "(ROM)" }; #define ROM_ENTRIES (sizeof rom_entries / sizeof rom_entries[0]) diff --git a/v4/tests/test_host_rom_asm.c b/v4/tests/test_host_rom_asm.c new file mode 100644 index 00000000..8fc55e09 --- /dev/null +++ b/v4/tests/test_host_rom_asm.c @@ -0,0 +1,191 @@ +/* test_host_rom_asm.c -- the ROM assembles text exactly as v4/src/text.c does. + * + * Plan Tasks 6 and 7. The ROM is started at its entry (12) and fed a text + * through the console, ending with `start`; text.c assembles the same text. + * Where text.c accepts it, the ROM must lay down the same words and jump to + * the word start names; where text.c refuses it, the ROM must stop at + * (ROM-FAILED) with the same class of error, on the same line. The texts + * are test_text.c's own (rom_asm_cases.h), test_text.c's four real + * definitions, and the ROM's own directives: set, here, store, start. + */ +#include "rom_harness.h" +#include "v4/text.h" +#include "rom_asm_cases.h" + +static int failures = 0, checks = 0; +#define CHECK(c,...) do{checks++; if(!(c)){failures++; printf("FAIL %s:%d: ",__FILE__,__LINE__); printf(__VA_ARGS__); printf("\n");}}while(0) + +#define VARS ((v4_cell)(V4_NODE_WORDS - 16u)) /* test_text.c's VAR */ + +static v4_node a, b; +static v4_text tx; +static char in[1u << 16]; + +/* the ROM error code for one of text.c's messages */ +static v4_cell code_of(const char *m) +{ + static const struct { const char *s; v4_cell c; } map[] = { + { "label already defined", ROM_ERR_LABEL_DUP }, { "& needs", ROM_ERR_AMP }, + { "macros nested too deep", ROM_ERR_DEEP }, { "macro without", ROM_ERR_MACRO }, + { "endmacro without", ROM_ERR_MACRO }, { "nested too deep", ROM_ERR_FOR }, + { "NEXT without", ROM_ERR_FOR }, { "FOR without", ROM_ERR_FOR }, + { "already defined", ROM_ERR_DEFINED }, { "cannot be used as a name", ROM_ERR_BAD_NAME }, + { "does not fit a cell", ROM_ERR_BIG }, { "does not fit", ROM_ERR_FIT }, + { "branch cannot reach", ROM_ERR_FIT }, { "name too long", ROM_ERR_TOO_LONG }, + { "comment not closed", ROM_ERR_COMMENT }, { "not allowed in a macro", ROM_ERR_IN_MACRO }, + { "too many labels", ROM_ERR_LABELS }, { "must fit one instruction word", ROM_ERR_UNEXT }, + { "not something to branch to", ROM_ERR_TARGET }, { "never defined", ROM_ERR_UNDEFINED }, + { "write the number", ROM_ERR_FETCH_P }, { "too many unresolved", ROM_ERR_REFS }, + { "not a value", ROM_ERR_VALUE }, { "not a number", ROM_ERR_VALUE }, + { "too many names", ROM_ERR_NAMES }, { "out of name space", ROM_ERR_NAMES }, + { "without", ROM_ERR_MISSING }, + }; + unsigned i; + for (i = 0; i < sizeof map / sizeof map[0]; i++) if (strstr(m, map[i].s)) return map[i].c; + return -1; +} + +static unsigned line_of(const char *m) +{ + unsigned l = 0; + return sscanf(m, "line %u:", &l) == 1 ? l : 0; +} + +/* Run the ROM on `text` (EOT is added). 1: it started -- P left the ROM for + * RAM; 0: it stopped at (ROM-FAILED); -1: neither within the steps allowed. */ +static int rom_run(const char *text) +{ + static long failed_lo = -1, failed_hi = -1; + size_t len = strlen(text), fed = 0; + long steps = 0; + if (failed_lo < 0) { /* where (ROM-FAILED) is: looked up once */ + FILE *f = fopen(V4_ROM_SYM, "r"); + char sym[80]; long ad, lo = -1, hi = -1; + while (f && fscanf(f, "%79s %ld", sym, &ad) == 2) if (strcmp(sym, "(ROM-FAILED)") == 0) lo = ad; + if (f) rewind(f); + while (f && fscanf(f, "%79s %ld", sym, &ad) == 2) if (ad > lo && (hi < 0 || ad < hi)) hi = ad; + if (f) fclose(f); + failed_lo = lo; failed_hi = hi < 0 ? (long)V4_ROM_BASE + (long)ROM_IMAGE_WORDS : hi; + } + rom_boot(&b); + b.p = V4_ROM_BASE + 12; + while (steps++ < 50000000L) { + if (fed <= len) fed += v4_node_console_feed(&b, text + fed, (unsigned)(len + 1 - fed)); + if (b.p < V4_ROM_BASE) return 1; + if ((long)b.p >= failed_lo && (long)b.p < failed_hi) return 0; + (void)v4_exec_step_word(&b, &rom_es, &rom_h); + if (b.stopped) return -1; + } + return -1; +} + +/* text.c and the ROM on the same text, with a word to start at after it */ +static void same(const char *text) +{ + static char ta[1u << 15]; + int okA, rb; + v4_cell w, hereA, endA; + + snprintf(ta, sizeof ta, "constant VAR %ld\nconstant N-1 %d\n%s\n: ZZEND ;\n", (long)VARS, V4_CELL_BITS - 1, text); + v4_node_reset(&a); + v4_text_begin(&tx, &a, ROM_ORIGIN); + okA = v4_text_assemble(&tx, ta) && v4_text_finish(&tx); + snprintf(in, sizeof in, "%s", ta); /* start on ZZEND's line: the ROM sees as many lines as text.c */ + in[strlen(in) - 1] = 0; + strcat(in, " start ZZEND\n\x04"); + rb = rom_run(in); + if (okA) { + hereA = v4_text_here(&tx); + endA = v4_text_word(&tx, "ZZEND"); + CHECK(rb == 1, "[%s] text.c accepts; the ROM %s (code %ld line %ld)", text, + rb == 0 ? "refused" : "did not finish", (long)b.mem[ROM_FAILED], (long)b.mem[ROM_ERRLINE] + 1); + if (rb != 1) return; + CHECK(b.p == endA, "[%s] the ROM started at ZZEND: P %ld, text.c %ld", text, (long)b.p, (long)endA); + CHECK(b.mem[ROM_HERE] == hereA, "[%s] here: ROM %ld, text.c %ld", text, (long)b.mem[ROM_HERE], (long)hereA); + for (w = ROM_ORIGIN; w < hereA; w++) if (a.mem[w] != b.mem[w]) break; + CHECK(w == hereA, "[%s] word %ld differs: text.c %lx, ROM %lx", text, (long)w, + (unsigned long)a.mem[w], (unsigned long)b.mem[w]); + } else { + const char *m = v4_text_error(&tx); + v4_cell want = code_of(m); + unsigned l = line_of(m); + CHECK(rb == 0, "[%s] text.c refuses (%s); the ROM %s", text, m, rb == 1 ? "accepted" : "did not finish"); + if (rb != 0) return; + CHECK(b.mem[ROM_FAILED] == want, "[%s] text.c: %s; ROM code %ld, want %ld", text, m, (long)b.mem[ROM_FAILED], (long)want); + if (l > 2) CHECK((unsigned)b.mem[ROM_ERRLINE] + 1u == l, "[%s] line: text.c %u, ROM %ld", text, l, (long)b.mem[ROM_ERRLINE] + 1); + } +} + + +int main(void) +{ + unsigned i; + + for (i = 0; i < sizeof rom_asm_cases / sizeof rom_asm_cases[0]; i++) same(rom_asm_cases[i]); + + /* test_text.c's four real definitions, and more of the notation together */ + same("macro SWAP over push push drop pop pop endmacro\n" + ": SWAP' ( a b -- b a ) SWAP ;\n" + ": UM/MOD ( ulo uhi ud -- urem uquot )\n" + " a! N-1 FOR\n" + " -if L0\n" + " 2* over -if L1 drop 1 + jump L2\n" + " L1: drop L2: push 2* pop\n" + " jump SUB\n" + " L0:\n" + " 2* over -if L3 drop 1 + jump L4\n" + " L3: drop L4: push 2* pop\n" + " dup a xor -if L5\n" + " drop -if NOSUB jump SUB\n" + " L5: drop dup inv a + inv -if L6\n" + " drop jump NOSUB\n" + " L6: push drop pop jump SETBIT\n" + " SUB: inv a + inv\n" + " SETBIT: push 1 + pop\n" + " NOSUB:\n" + " NEXT\n" + " SWAP ;\n" + ": C@ ( baddr -- c )\n" + " dup 2/ 2/ a! 3 and\n" + " if K0 -1 + if K1 -1 + if K2\n" + " drop @ 23 FOR 2/ UNEXT 255 and ;\n" + " K2: drop @ 15 FOR 2/ UNEXT 255 and ;\n" + " K1: drop @ 7 FOR 2/ UNEXT 255 and ;\n" + " K0: drop @ 255 and ;\n" + ": C! ( c baddr -- )\n" + " dup 2/ 2/ a! 3 and push 255 and pop\n" + " if K0 -1 + if K1 -1 + if K2\n" + " drop 23 FOR 2* UNEXT @ 4278190080 inv and + ! ;\n" + " K2: drop 15 FOR 2* UNEXT @ -16711681 and + ! ;\n" + " K1: drop 7 FOR 2* UNEXT @ -65281 and + ! ;\n" + " K0: drop @ -256 and + ! ;\n" + ": ROUNDTRIP ( c baddr -- c' ) dup push C! pop jump C@\n"); + same(": A B C ; : B jump D ; : C if E D E: ; : D ; macro TWO dup dup endmacro macro FOUR TWO TWO endmacro\n" + ": F FOUR &A VAR+3 \\ a comment\n ( and another ) ;\n#, 5 \", ( #, &F \", abcdefgh"); + + /* the ROM's own directives */ + CHECK(rom_run("set S 5 set S 9 : T S ;\nstore 7000 S store 7001 here\n#, here\n: Z ;\nstart Z\n\x04") == 1, + "set, here and store assemble: code %ld", (long)b.mem[ROM_FAILED]); + CHECK(b.mem[7000] == 9 && b.mem[7001] == 18 && b.mem[18] == 18, "set takes its last value, here is the next word: %ld %ld %ld", + (long)b.mem[7000], (long)b.mem[7001], (long)b.mem[18]); + CHECK(rom_run(": T ;\n\x04") == 0 && b.mem[ROM_FAILED] == ROM_ERR_NO_START, "no start: refused"); + CHECK(rom_run(": T ;\nconstant K 1\nstart K\n\x04") == 0 && b.mem[ROM_FAILED] == ROM_ERR_START, "start of a constant: refused"); + CHECK(rom_run(": T ;\nstart\n\x04") == 0 && b.mem[ROM_FAILED] == ROM_ERR_MISSING, "start alone: refused"); + CHECK(rom_run(": T here ;\n: Z ;\nstart Z\n\x04") == 0 && b.mem[ROM_FAILED] == ROM_ERR_TARGET, "here alone is not code"); + CHECK(rom_run("store 9000\n: Z ;\nstart Z\n\x04") == 0, "store needs two values"); + + /* a blob split over two feeds, and a forward call resolved in the second (Review Focus 1) */ + CHECK(rom_run(": A B ;\n: B 7 ;\n: Z ;\nstart Z\n\x04") == 1 && (b.mem[ROM_ORIGIN] & 0xFFFFFFFF) != 0, "a forward call across words"); + + /* the tables are cleared at start (Review Focus 4) */ + rom_run(": A B ;\n: B 7 ;\nmacro M dup endmacro\n: Z M ;\nstart Z\n\x04"); + for (i = 0; i < (unsigned)(DICT_END_W - DICT_W); i++) if (b.mem[DICT_W + (v4_cell)i] != 0) break; + CHECK(i == (unsigned)(DICT_END_W - DICT_W), "the symbol table is cleared: cell %u is not", i); + for (i = 0; i < 1024u; i++) if (b.mem[BUF0_W + (v4_cell)i] != 0) break; + CHECK(i == 1024u, "the block window is cleared: cell %u is not", i); + for (i = 0; i < 260u; i++) if (b.mem[TIB_W + (v4_cell)i] != 0) break; + CHECK(i == 260u, "the text input buffer is cleared: cell %u is not", i); + + printf("test_host_rom_asm: %d checks, %d failures\n", checks, failures); + return failures != 0; +} diff --git a/v4/tools/mkmap.c b/v4/tools/mkmap.c index 52c644d9..86db4d97 100644 --- a/v4/tools/mkmap.c +++ b/v4/tools/mkmap.c @@ -61,6 +61,57 @@ int main(void) constant("ADDR-TOP", (long)ROM_ADDR_TOP); constant("ERR-FIT", (long)ROM_ERR_FIT); constant("ERR-OPCODE", (long)ROM_ERR_OPCODE); + constant("(NREF)", (long)ROM_NREF); + constant("(NLAB)", (long)ROM_NLAB); + constant("(WNP)", (long)ROM_WNP); + constant("(NFOR)", (long)ROM_NFOR); + constant("(FORS)", (long)ROM_FORS); + constant("(RDEPTH)", (long)ROM_RDEPTH); + constant("(RPTRS)", (long)ROM_RPTRS); + constant("(T1)", (long)ROM_T1); + constant("(T2)", (long)ROM_T2); + constant("(T3)", (long)ROM_T3); + constant("(T4)", (long)ROM_T4); + constant("(CFROM)", (long)ROM_CFROM); + constant("(CTO)", (long)ROM_CTO); + constant("(CN)", (long)ROM_CN); + constant("(RAW)", (long)ROM_RAW); + constant("(T5)", (long)ROM_T5); + constant("(T6)", (long)ROM_T6); + constant("(MLEN)", (long)ROM_MLEN); + constant("(REFS)", (long)ROM_REFS); + constant("(LABELS)", (long)ROM_LABELS); + constant("(WNAMES)", (long)ROM_WNAMES); + constant("(TSAVE)", (long)ROM_TSAVE); + constant("(MTEMP)", (long)ROM_MTEMP); + constant("(MBODY)", (long)ROM_MBODY); + constant("ORIGIN", (long)ROM_ORIGIN); + constant("REFS-MAX", (long)ROM_REFS_MAX); + constant("WN-SIZE", (long)ROM_WN_SIZE); + constant("MBODY-SIZE", (long)ROM_MBODY_SIZE); + constant("DICT-W", (long)DICT_W); + constant("DICT-END", (long)DICT_END_W); + constant("BUF0", (long)BUF0_W); + constant("TIB-W", (long)TIB_W); + constant("ERR-IN-MACRO", (long)ROM_ERR_IN_MACRO); + constant("ERR-MACRO", (long)ROM_ERR_MACRO); + constant("ERR-LABEL-DUP", (long)ROM_ERR_LABEL_DUP); + constant("ERR-LABELS", (long)ROM_ERR_LABELS); + constant("ERR-FOR", (long)ROM_ERR_FOR); + constant("ERR-UNEXT", (long)ROM_ERR_UNEXT); + constant("ERR-TARGET", (long)ROM_ERR_TARGET); + constant("ERR-UNDEFINED", (long)ROM_ERR_UNDEFINED); + constant("ERR-BIG", (long)ROM_ERR_BIG); + constant("ERR-AMP", (long)ROM_ERR_AMP); + constant("ERR-FETCH-P", (long)ROM_ERR_FETCH_P); + constant("ERR-MISSING", (long)ROM_ERR_MISSING); + constant("ERR-DEEP", (long)ROM_ERR_DEEP); + constant("ERR-REFS", (long)ROM_ERR_REFS); + constant("ERR-VALUE", (long)ROM_ERR_VALUE); + constant("ERR-NO-START", (long)ROM_ERR_NO_START); + constant("ERR-START", (long)ROM_ERR_START); + constant("DSTACK-REG", (long)DSTACK_REG); + constant("RSTACK-REG", (long)RSTACK_REG); /* the cell width's constants (NUMBER) needs, written as signed cells */ constant("MSB", (long)(v4_cell)V4_MSB); constant("DEC-LIMIT", (long)(v4_cell)(~(v4_ucell)0 / 10u));