diff --git a/docs/v4.0.0/DECOMPOSITION.md b/docs/v4.0.0/DECOMPOSITION.md index 4aee96d2..829cbf5b 100644 --- a/docs/v4.0.0/DECOMPOSITION.md +++ b/docs/v4.0.0/DECOMPOSITION.md @@ -331,7 +331,7 @@ Section numbers match the v3 primitive reference. | `-!` | CAP | `a! NEGATE @ + !` | | `2@` | CAP | `a! @+ @` (low cell at `addr`, high at `addr+1`, as in v3) | | `2!` | CAP | `a! SWAP !+ !` | -| `C@` | CAP | See below (D-1). Executed on the golden model (2026-10-03). | +| `C@` | CAP | See below (D-1). Call-free. Executed on the golden model (2026-10-03). Leaves its caller 8 data cells and 7 return entries. | | `C!` | CAP | See below (D-1). Call-free. Executed on the golden model (2026-10-03). | | `FILL` | CAP | See below. | | `MOVE` | CAP | `push 2DUP U< IF pop CMOVE> ELSE pop CMOVE THEN` | @@ -342,8 +342,16 @@ Section numbers match the v3 primitive reference. \ byte access on a word-addressed node, little-endian: four bytes to a cell at \ either cell width (so compiled code is the same, D-9), byte address = 4 * word \ address + byte index. `@` and `!` inside are the opcodes, addressing through A. +\ C@ is call-free, like C!: one case per byte position, the cell shifted down +\ with a 2/ loop and masked. It replaces a version built on LSHIFT, RSHIFT and +\ SWAP calls, which was correct but left its caller 4 return-stack entries. : C@ ( baddr -- c ) - dup 3 and 3 LSHIFT SWAP 2 RSHIFT a! @ SWAP RSHIFT 255 and ; + dup 2/ 2/ a! 3 and \ k A: word address + if K0 -1 + if K1 -1 + if K2 + drop @ 23 FOR 2/ UNEXT 255 and ; \ byte 3 + K2: drop @ 15 FOR 2/ UNEXT 255 and ; \ byte 2 + K1: drop @ 7 FOR 2/ UNEXT 255 and ; \ byte 1 + K0: drop @ 255 and ; \ byte 0 \ C! is call-free: one case per byte position. The byte is shifted up with a \ 2* loop, that byte of the cell cleared with a constant mask, and the two added. @@ -454,11 +462,11 @@ All output reaches the console through `EMIT` (DEV). | --- | --- | --- | | `<#` `#` `#S` `HOLD` `SIGN` `#>` | CAP | Pictured output over `UM/MOD` and a 64-byte hold buffer, filled backwards from its end `HEND` through the pointer `HLD`. Standard stack effects (v3 took its double low cell on top, and its tolerant `#>` popped `ud` only if present; neither is kept). Otherwise v3's behaviour: digits `0`–`9` then `A`–`Z`; `BASE` outside 2–36 reads as 10; 63 characters; `HOLD` of a value outside 0–255 or into a full buffer stores nothing and sets `NODE-ERROR` (D-13). Definitions below. Executed on the golden model (2026-10-03) against a C reference in bases 2, 3, 8, 10, 16, 36 and four invalid ones. `<# #S #>` leaves its caller 4 data cells and 3 return entries; the signed picture `dup push ABS 0 <# #S pop SIGN #>` leaves 2 return entries. `#`, `#S`, `HOLD` and `SIGN` clobber `A` and `B`. | | `HLD` | CAP | Variable: byte address of the first held character. `HLD ( -- addr )` is the variable's word address, a literal. Not a v3 word. Executed on the golden model (2026-10-03): after `<#` and each `HOLD` or `#`, `HLD @` is the address `#>` returns. | -| `.` `.R` `U.` `U.R` `D.` `D.R` | CAP | Built on pictured output and `TYPE`; definitions below. As v3: the number in the current base, then one space; the `.R` words right-justify it in `width` columns first, print a wider number whole, and pad nothing for `width <= 0`. (The space after the `.R` words is not FORTH-79; it is what v3 prints.) Where v4 parts from v3: a double is `( lo hi )`, where v3's `D.` took the low cell on top; `D.` prints the whole double, where v3 printed `DOUBLE-OVERFLOW` unless it fitted one signed cell (they agree whenever it does); printing honours the `BASE` variable, where v3 printed in a host copy that only `DECIMAL`, `HEX` and `OCTAL` set, so `n BASE !` changed v3's input base but not its output; and the number is built in the 63-character hold buffer, so a longer one — a 64-bit cell in base 2, a large double in a small base — loses its leading characters and sets `NODE-ERROR` (D-13), where v3 printed from a private 80-character buffer. Executed on the golden model (2026-10-03) against a C reference in the ten bases of the pictured-output test and eleven field widths, and against five transcripts of the v3 binary (a sixth, the extreme cells, at 64-bit cells). Each leaves its caller 4 data cells and 2 return entries. All clobber `A` and `B`. | +| `.` `.R` `U.` `U.R` `D.` `D.R` | CAP | Built on pictured output and `TYPE`; definitions below. As v3: the number in the current base, then one space; the `.R` words right-justify it in `width` columns first, print a wider number whole, and pad nothing for `width <= 0`. (The space after the `.R` words is not FORTH-79; it is what v3 prints.) Where v4 parts from v3: a double is `( lo hi )`, where v3's `D.` took the low cell on top; `D.` prints the whole double, where v3 printed `DOUBLE-OVERFLOW` unless it fitted one signed cell (they agree whenever it does); printing honours the `BASE` variable, where v3 printed in a host copy that only `DECIMAL`, `HEX` and `OCTAL` set, so `n BASE !` changed v3's input base but not its output; and the number is built in the 63-character hold buffer, so a longer one — a 64-bit cell in base 2, a large double in a small base — loses its leading characters and sets `NODE-ERROR` (D-13), where v3 printed from a private 80-character buffer. Executed on the golden model (2026-10-03) against a C reference in the ten bases of the pictured-output test and eleven field widths, and against five transcripts of the v3 binary (a sixth, the extreme cells, at 64-bit cells). Each leaves its caller 4 data cells; `U.` and `U.R` leave 3 return entries, the signed words 2, their sign waiting on the return stack. All clobber `A` and `B`. | | `(W)` | CAP | Variable: the field width of the `.R` words. Like `BASE` and `HLD`, it lives in node memory, so the width is on neither stack while the picture runs. | | `.S` | RET | No visible stack pointer (D-2). | | `?` | CAP | `( addr -- )`: `a! @ jump .` — the cell at word address `addr` (D-1), printed as `.` prints it. Executed on the golden model (2026-10-03), including a transcript of the v3 binary. Leaves its caller 4 data cells and 2 return entries. Clobbers `A` and `B`. | -| `DUMP` | CAP | `( baddr u -- )`: `u` bytes from byte address `baddr`, sixteen to a line, in v3's format: the address in hex, `": "`, each byte as two hex digits and a space (three spaces where the line runs out), `" \|"`, the bytes as characters with `.` for anything outside 32–126, `"\|"` and a new line. Always hex, whatever `BASE` is, and `BASE` is put back. The address is two hex digits per byte of a cell — 8 at 32-bit cells, 16 at 64, which is v3's width. Nothing for `u = 0`; for `u < 0` nothing is printed and `NODE-ERROR` is set, as `TYPE` does, where v3 raised its error flag. Addresses are not range-checked (open, `node.h`). Definition below. Executed on the golden model (2026-10-03) against a C reference at six alignments and every length 0–50, and at 64-bit cells against a transcript of the v3 binary, byte for byte. Leaves its caller 4 data cells and 2 return entries. Clobbers `A` and `B`. | +| `DUMP` | CAP | `( baddr u -- )`: `u` bytes from byte address `baddr`, sixteen to a line, in v3's format: the address in hex, `": "`, each byte as two hex digits and a space (three spaces where the line runs out), `" \|"`, the bytes as characters with `.` for anything outside 32–126, `"\|"` and a new line. Always hex, whatever `BASE` is, and `BASE` is put back. The address is two hex digits per byte of a cell — 8 at 32-bit cells, 16 at 64, which is v3's width. Nothing for `u = 0`; for `u < 0` nothing is printed and `NODE-ERROR` is set, as `TYPE` does, where v3 raised its error flag. Addresses are not range-checked (open, `node.h`). Definition below. Executed on the golden model (2026-10-03) against a C reference at six alignments and every length 0–50, and at 64-bit cells against a transcript of the v3 binary, byte for byte. Leaves its caller 4 data cells and 4 return entries. Clobbers `A` and `B`. | | `(DP)` | CAP | Variable, 4 cells: `DUMP`'s saved `BASE`, address, count and column. | | `BASE` | CAP | Variable. `BASE ( -- addr )` is its word address (D-1), a literal. Executed on the golden model (2026-10-03). Storing to it changes what is printed, which it did not in v3 (see `.`). | | `DECIMAL` `HEX` `OCTAL` | CAP | `10 BASE !`, `16 BASE !`, `8 BASE !`, with `!` in line as `a! !`. Executed on the golden model (2026-10-03), including a transcript of the v3 binary. Each leaves its caller 8 data cells and 8 return entries. Clobber `A`. | @@ -577,7 +585,7 @@ width and print a flood of spaces. | `EMIT` | DEV | Console service: one-character message. Until the mesh exists it is a store to the `CONSOLE-TX` register (§7): `CONSOLE-TX b! !b`. As in v3, the low byte of the cell is the character. Executed on the golden model (2026-10-03). Clobbers `B`. | | `KEY` | DEV | Console service: blocking receive. | | `?TERMINAL` | DEV | Console service: non-blocking status. | -| `TYPE` | CAP | `( baddr u -- )`. Loop of `C@ EMIT`, or one string message to the console node: `-if OK drop drop NODE-ERROR b! -1 !b ; OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK DONE: drop drop ;` — nothing for `u = 0`; for `u < 0` nothing is printed and `NODE-ERROR` is set, where v3 printed nothing and raised its error flag. The address range is not checked (out-of-range addressing is still open, `node.h`). Executed on the golden model (2026-10-03). Leaves its caller 4 data cells and 3 return entries, the depth being `C@`'s as written. Clobbers `A` and `B`. | +| `TYPE` | CAP | `( baddr u -- )`. Loop of `C@ EMIT`, or one string message to the console node: `-if OK drop drop NODE-ERROR b! -1 !b ; OK: if DONE over C@ EMIT push 1 + pop -1 + jump OK DONE: drop drop ;` — nothing for `u = 0`; for `u < 0` nothing is printed and `NODE-ERROR` is set, where v3 printed nothing and raised its error flag. The address range is not checked (out-of-range addressing is still open, `node.h`). Executed on the golden model (2026-10-03). Leaves its caller 6 data cells and 6 return entries. Clobbers `A` and `B`. | | `CR` | CAP | `10 EMIT`, as `10 jump EMIT` — executed on the golden model (2026-10-03). Character 10, as v3; the console turns it into a new line. | | `SPACE` | CAP | `BL EMIT`, as `32 jump EMIT` — executed on the golden model (2026-10-03). | | `SPACES` | CAP | `( n -- )`: `-if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;` — `n` spaces, none for `n <= 0`, as v3. Executed on the golden model (2026-10-03), including a transcript of the v3 binary. Leaves its caller 7 data cells and 7 return entries. Clobbers `B`. | @@ -768,7 +776,7 @@ word. Per D-10 it occupies two cells on a 64-bit node too. Per D-8, v4 Q values | `Q.TO-INT` | CAP | `push a! 0 pop 15 FOR +* UNEXT drop drop a` — the same `+*` shift, 16 bits at every cell width, leaving the low cell in `A`. Rounds toward minus infinity, as v3's arithmetic shift does (−1.5 gives −2). Executed on the golden model (2026-10-02): v3's `q48_to_u64` exactly at 64-bit cells, its low cell at 32. Clobbers `A`. | | `Q.1` `Q.0` `Q.SCALE` | IN | Double-cell constants, placed in line as two literals, low cell first: `Q.1` and `Q.SCALE` are `65536 0` (1.0), `Q.0` is `0 0`. v3's are 65536, 0 and 65536. Executed on the golden model (2026-10-03): the values match v3's, `Q.1 Q.TO-INT` is 1, `1 Q.FROM-INT` is `Q.1`, and `q Q.1 Q.*` and `q Q.0 Q.+` return `q`. | | `Q.=` `Q.<` `Q.>` `Q.0=` `Q.MAX` `Q.MIN` | CAP | `D=`, `D<`, `2SWAP D<` (for `Q.>`), `D0=`, `DMAX`, `DMIN`. Signed (D-8); v3 compared unsigned, so v3 agrees only when both values have the same sign. Executed on the golden model (2026-10-02). `Q.>` was given here as `SWAP D<`, which swaps single cells, not Q values, and gave a wrong answer in 11702 of 20169 test cases. | -| `Q.PRINT` | CAP | `( q -- )`: the integer part, a point, the five digits `floor(frac * 100000 / 65536)`, then one space, as v3; always decimal, whatever `BASE` is, and `BASE` is put back. Signed (D-8): a negative value prints `-` and its magnitude (−1.5 prints `-1.50000`), where v3 printed it as a large unsigned number. `dup (QP) 3 + b! !b -if A DNEGATE A: (QP) 2 + b! !b dup (QP) 1 + b! !b BASE b! @b (QP) b! !b 10 BASE b! !b 65535 and 4 FOR dup 2* 2* + UNEXT 10 FOR 2/ UNEXT 0 <# # # # # # drop drop 46 HOLD (QP) 1 + b! @b (QP) 2 + b! @b dup push push a! 0 pop 15 FOR +* UNEXT drop drop a pop 15 FOR 2/ UNEXT HIMASK and #S (QP) 3 + b! @b SIGN #> (QP) b! @b BASE b! !b jump OUT` — `OUT` is the `TYPE jump SPACE` at the end of `.R`. The fraction is `frac * 3125 / 2048`, which stays inside a 32-bit cell where `frac * 100000` would not; times 3125 is times 5 five times. The integer part is `|q|` shifted right 16 as a double: its low cell by `Q.TO-INT`'s `+*` shift in line, its high cell by `2/` and `HIMASK`, which clears the top 16 bits. Executed on the golden model (2026-10-03) against a C reference, on every seventh fraction, and against a transcript of the v3 binary for non-negative values. Leaves its caller 4 data cells and 2 return entries. Clobbers `A` and `B`. | +| `Q.PRINT` | CAP | `( q -- )`: the integer part, a point, the five digits `floor(frac * 100000 / 65536)`, then one space, as v3; always decimal, whatever `BASE` is, and `BASE` is put back. Signed (D-8): a negative value prints `-` and its magnitude (−1.5 prints `-1.50000`), where v3 printed it as a large unsigned number. `dup (QP) 3 + b! !b -if A DNEGATE A: (QP) 2 + b! !b dup (QP) 1 + b! !b BASE b! @b (QP) b! !b 10 BASE b! !b 65535 and 4 FOR dup 2* 2* + UNEXT 10 FOR 2/ UNEXT 0 <# # # # # # drop drop 46 HOLD (QP) 1 + b! @b (QP) 2 + b! @b dup push push a! 0 pop 15 FOR +* UNEXT drop drop a pop 15 FOR 2/ UNEXT HIMASK and #S (QP) 3 + b! @b SIGN #> (QP) b! @b BASE b! !b jump OUT` — `OUT` is the `TYPE jump SPACE` at the end of `.R`. The fraction is `frac * 3125 / 2048`, which stays inside a 32-bit cell where `frac * 100000` would not; times 3125 is times 5 five times. The integer part is `|q|` shifted right 16 as a double: its low cell by `Q.TO-INT`'s `+*` shift in line, its high cell by `2/` and `HIMASK`, which clears the top 16 bits. Executed on the golden model (2026-10-03) against a C reference, on every seventh fraction, and against a transcript of the v3 binary for non-negative values. Leaves its caller 4 data cells and 3 return entries. Clobbers `A` and `B`. | | `(QP)` | CAP | Variable, 4 cells: `Q.PRINT`'s saved `BASE`, `|q|` and the sign. | ### 5.27 Inference engine diff --git a/v4/tests/test_foundation.c b/v4/tests/test_foundation.c index 6acb5aaa..40431c28 100644 --- a/v4/tests/test_foundation.c +++ b/v4/tests/test_foundation.c @@ -1354,11 +1354,16 @@ static void build(void) O(DROP); O(DROP); O(SEMI); } - /* Byte access on a word-addressed node (D-1), 5.3 (C@ as written): four + /* Byte access on a word-addressed node (D-1), 5.3: four * bytes to a cell, little-endian; a byte address is 4 * word address + * byte index. `@` and `!` here are the opcodes, addressing through A. - * : C@ ( baddr -- c ) - * dup 3 and 3 LSHIFT SWAP 2 RSHIFT a! @ SWAP RSHIFT 255 and ; + * : C@ ( baddr -- c ) call-free + * dup 2/ 2/ a! 3 and k A: word address + * if K0 -1 + if K1 -1 + if K2 + * drop @ 23 FOR 2/ UNEXT 255 and ; byte 3 + * K2: drop @ 15 FOR 2/ UNEXT 255 and ; byte 2 + * K1: drop @ 7 FOR 2/ UNEXT 255 and ; byte 1 + * K0: drop @ 255 and ; byte 0 * : C! ( c baddr -- ) call-free * dup 2/ 2/ a! 3 and push 255 and pop c' k A: word address * if K0 -1 + if K1 -1 + if K2 @@ -1369,9 +1374,29 @@ static void build(void) * One case per byte position: the byte is shifted up, that byte of the * cell cleared with a constant mask, and the two added. */ w_cfetch = v4_asm_label(&as); - O(DUP); LIT(3); O(AND); LIT(3); CALL(w_lshift); - CALL(w_swap); LIT(2); CALL(w_rshift); O(BANG_A); O(FETCH_A); - CALL(w_swap); CALL(w_rshift); LIT(255); O(AND); O(SEMI); + { + v4_asm_ref f0, f1, f2; + O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A); LIT(3); O(AND); + f0 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); f1 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); f2 = v4_asm_branch_fwd(&as, V4_OP_IF); + O(DROP); O(FETCH_A); LIT(23); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f2, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(15); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f1, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(7); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f0, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(255); O(AND); O(SEMI); + } { v4_asm_ref k0, k1, k2; @@ -2674,7 +2699,7 @@ int main(void) CHECK(call(w_rshift, 2, vec[i], (v4_cell)c, 0) && left1((v4_cell)r), "RSHIFT [%u,%u]", i, c); } - /* C@ and C! as written: every byte of two adjacent words, several + /* C@ and C!: every byte of two adjacent words, several * values, the other bytes and the neighbouring words left alone. */ { static const v4_ucell cv[] = { 0, 1, 0x41, 0x7F, 0x80, 0xFF, 0x1FF, 0xABCD }; @@ -2830,6 +2855,7 @@ int main(void) static const v4_cell cf_args[][4] = { { (V4_NODE_WORDS - 47) * 4 + 3, 0, 0, 0 }, { (V4_NODE_WORDS - 47) * 4, 0, 0, 0 } }; static const v4_cell cs_args[][4] = { { 0x41, (V4_NODE_WORDS - 47) * 4 + 3, 0, 0 }, { 0xFF, (V4_NODE_WORDS - 47) * 4, 0, 0 } }; headroom("C@", w_cfetch, 1, cf_args, 2, 1, &dh, &rh); + CHECK(dh >= 7 && rh >= 7, "C@ is call-free"); headroom("C!", w_cstore, 2, cs_args, 2, 0, &dh, &rh); headroom("SM/REM", w_smrem, 3, smrem_args, 5, 2, &dh, &rh); CHECK(rh >= 1, "SM/REM leaves room for /MOD's return address"); diff --git a/v4/tests/test_numout.c b/v4/tests/test_numout.c index 9d66477b..3eacabf1 100644 --- a/v4/tests/test_numout.c +++ b/v4/tests/test_numout.c @@ -289,12 +289,37 @@ static void build_output(void) v4_asm_ref a, b; v4_cell l, l_tail; - /* : C@ ( baddr -- c ) as written in 5.3 - * dup 3 and 3 LSHIFT SWAP 2 RSHIFT a! @ SWAP RSHIFT 255 and ; */ + /* : C@ ( baddr -- c ) call-free, 5.3 + * dup 2/ 2/ a! 3 and k A: word address + * if K0 -1 + if K1 -1 + if K2 + * drop @ 23 FOR 2/ UNEXT 255 and ; byte 3 + * K2: drop @ 15 FOR 2/ UNEXT 255 and ; byte 2 + * K1: drop @ 7 FOR 2/ UNEXT 255 and ; byte 1 + * K0: drop @ 255 and ; byte 0 */ w_cfetch = v4_asm_label(&as); - O(DUP); LIT(3); O(AND); LIT(3); CALL(w_lshift); - CALL(w_swap); LIT(2); CALL(w_rshift); O(BANG_A); O(FETCH_A); - CALL(w_swap); CALL(w_rshift); LIT(255); O(AND); O(SEMI); + { + v4_asm_ref f0, f1, f2; + O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A); LIT(3); O(AND); + f0 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); f1 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); f2 = v4_asm_branch_fwd(&as, V4_OP_IF); + O(DROP); O(FETCH_A); LIT(23); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f2, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(15); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f1, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(7); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f0, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(255); O(AND); O(SEMI); + } /* : DNEGATE ( d -- -d ) inv over if L1 drop push inv 1 + pop ; L1: drop 1 + ; */ w_dnegate = v4_asm_label(&as); @@ -677,7 +702,7 @@ int main(void) headroom(".R", w_dotr, 2, -12345, 9, 0, " -12345 ", &dh, &rh); CHECK(dh >= 2 && rh >= 2, ".R leaves room"); headroom("U.", w_udot, 1, 12345, 0, 0, "12345 ", &dh, &rh); - CHECK(dh >= 2 && rh >= 2, "U. leaves room"); + CHECK(dh >= 3 && rh >= 3, "U. leaves room"); headroom("U.R", w_udotr, 2, 12345, 9, 0, " 12345 ", &dh, &rh); headroom("D.", w_ddot, 2, -12345, -1, 0, "-12345 ", &dh, &rh); CHECK(dh >= 2 && rh >= 2, "D. leaves room"); diff --git a/v4/tests/test_printing.c b/v4/tests/test_printing.c index f51499de..372bc318 100644 --- a/v4/tests/test_printing.c +++ b/v4/tests/test_printing.c @@ -303,12 +303,37 @@ static void build_output(void) v4_asm_ref a, b, c, d, done1, done2; v4_cell l, l_tail, l_line; - /* : C@ ( baddr -- c ) as written in 5.3 - * dup 3 and 3 LSHIFT SWAP 2 RSHIFT a! @ SWAP RSHIFT 255 and ; */ + /* : C@ ( baddr -- c ) call-free, 5.3 + * dup 2/ 2/ a! 3 and k A: word address + * if K0 -1 + if K1 -1 + if K2 + * drop @ 23 FOR 2/ UNEXT 255 and ; byte 3 + * K2: drop @ 15 FOR 2/ UNEXT 255 and ; byte 2 + * K1: drop @ 7 FOR 2/ UNEXT 255 and ; byte 1 + * K0: drop @ 255 and ; byte 0 */ w_cfetch = v4_asm_label(&as); - O(DUP); LIT(3); O(AND); LIT(3); CALL(w_lshift); - CALL(w_swap); LIT(2); CALL(w_rshift); O(BANG_A); O(FETCH_A); - CALL(w_swap); CALL(w_rshift); LIT(255); O(AND); O(SEMI); + { + v4_asm_ref f0, f1, f2; + O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A); LIT(3); O(AND); + f0 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); f1 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); f2 = v4_asm_branch_fwd(&as, V4_OP_IF); + O(DROP); O(FETCH_A); LIT(23); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f2, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(15); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f1, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(7); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f0, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(255); O(AND); O(SEMI); + } /* : DNEGATE ( d -- -d ) inv over if L1 drop push inv 1 + pop ; L1: drop 1 + ; */ w_dnegate = v4_asm_label(&as); @@ -934,10 +959,10 @@ int main(void) headroom("?", w_query, 1, XVAR, 0, "-12345 ", &dh, &rh); CHECK(dh >= 2 && rh >= 2, "? leaves room"); headroom("Q.PRINT", w_qprint, 2, -98304, -1, "-1.50000 ", &dh, &rh); - CHECK(dh >= 2 && rh >= 2, "Q.PRINT leaves room"); + CHECK(dh >= 3 && rh >= 3, "Q.PRINT leaves room"); ref_dump(DATA_BADDR + 3, 21, want); headroom("DUMP", w_dump, 2, DATA_BADDR + 3, 21, want, &dh, &rh); - CHECK(dh >= 2 && rh >= 2, "DUMP leaves room"); + CHECK(dh >= 3 && rh >= 4, "DUMP leaves room"); } CHECK(v4_node_guards_intact(&n), "guards intact"); diff --git a/v4/tests/test_terminal.c b/v4/tests/test_terminal.c index 359ab414..fafbf3f1 100644 --- a/v4/tests/test_terminal.c +++ b/v4/tests/test_terminal.c @@ -15,6 +15,7 @@ * as the text between "System initialization complete." and "Goodbye!". * * On a node of its own, like test_pictured.c. SWAP, LSHIFT, RSHIFT and C@ + * (call-free, so it no longer uses the other three) * are assembled again here as they are in test_foundation.c. */ #include "v4/asm.h" @@ -91,12 +92,37 @@ static void build(void) HERE_(a); O(DROP); O(DROP); O(SEMI); - /* : C@ ( baddr -- c ) - * dup 3 and 3 LSHIFT SWAP 2 RSHIFT a! @ SWAP RSHIFT 255 and ; */ + /* : C@ ( baddr -- c ) call-free, 5.3 + * dup 2/ 2/ a! 3 and k A: word address + * if K0 -1 + if K1 -1 + if K2 + * drop @ 23 FOR 2/ UNEXT 255 and ; byte 3 + * K2: drop @ 15 FOR 2/ UNEXT 255 and ; byte 2 + * K1: drop @ 7 FOR 2/ UNEXT 255 and ; byte 1 + * K0: drop @ 255 and ; byte 0 */ w_cfetch = v4_asm_label(&as); - O(DUP); LIT(3); O(AND); LIT(3); CALL(w_lshift); - CALL(w_swap); LIT(2); CALL(w_rshift); O(BANG_A); O(FETCH_A); - CALL(w_swap); CALL(w_rshift); LIT(255); O(AND); O(SEMI); + { + v4_asm_ref f0, f1, f2; + O(DUP); O(TWO_SLASH); O(TWO_SLASH); O(BANG_A); LIT(3); O(AND); + f0 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); f1 = v4_asm_branch_fwd(&as, V4_OP_IF); + LIT(-1); O(ADD); f2 = v4_asm_branch_fwd(&as, V4_OP_IF); + O(DROP); O(FETCH_A); LIT(23); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f2, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(15); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f1, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(7); O(PUSH); + (void)v4_asm_label(&as); + O(TWO_SLASH); O(UNEXT); + LIT(255); O(AND); O(SEMI); + v4_asm_resolve(&as, f0, v4_asm_label(&as)); + O(DROP); O(FETCH_A); LIT(255); O(AND); O(SEMI); + } /* ---- terminal output, 5.10 ---- */ @@ -272,7 +298,7 @@ int main(void) CHECK(dh >= 7 && rh >= 7, "EMIT leaves room"); headroom("CR", w_cr, 0, 0, 0, "\n", 1, &dh, &rh); headroom("TYPE", w_type, 2, STR_BADDR + 17, 9, text + 17, 9, &dh, &rh); - CHECK(dh >= 2 && rh >= 2, "TYPE leaves room"); + CHECK(dh >= 5 && rh >= 6, "TYPE leaves room"); } CHECK(v4_node_guards_intact(&n), "guards intact");