Compare commits
4
Commits
443439c3d2
...
01b5bbb23f
| Author | SHA1 | Date | |
|---|---|---|---|
 rajamesandClaude Opus 5.5
|
01b5bbb23f | ||
|
rajamesandClaude Opus 5.5
|
b137678691 | ||
|
rajamesandClaude Opus 5.5
|
e178a76c36 | ||
|
rajamesandClaude Opus 5.5
|
7b42a9b6c1 |
@@ -334,7 +334,7 @@ Section numbers match the v3 primitive reference.
|
||||
| `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 | `( baddr u c -- )`: the low byte of `c`. See below. Nothing for `u = 0`; for `u < 0` nothing is written and `NODE-ERROR` is set (v3 read a negative count as a huge unsigned one). Executed on the golden model (2026-10-03), including a transcript of the v3 binary. Leaves its caller 5 data cells and 5 return entries. Clobbers `A` and, on error, `B`. |
|
||||
| `MOVE` | CAP | `( src dst u -- )`, bytes: `push over over - -if UP drop pop jump CMOVE> UP: drop pop jump CMOVE` — `CMOVE>` when `src < dst`, else `CMOVE`, so overlapping bytes are read before they are overwritten, as v3's `memmove`. The test is the sign of `src - dst`, in line. Executed on the golden model (2026-10-03), including a transcript of the v3 binary. Leaves its caller 4 data cells and 5 return entries. |
|
||||
| `MOVE` | CAP | `( addr1 addr2 n -- )` — FORTH-79 (ruled 2026-10-04): `n` cells from `addr1` to `addr2`, the cell at `addr1` first; nothing for `n <= 0`. The addresses are word addresses (D-1). `-if OK drop drop drop ; OK: if DONE push over a! @ over a! ! 1 + push 1 + pop pop -1 + jump OK DONE: drop drop drop ;` v3's `MOVE` moved bytes, in whichever direction did not overwrite what it had yet to read; that is `CMOVE` and `CMOVE>`. Executed on the golden model (2026-10-04) against C, overlapping both ways. Leaves its caller 6 data cells and 6 return entries. Clobbers `A`. |
|
||||
| `ERASE` | CAP | `0 FILL`, as `0 jump FILL`. Executed on the golden model (2026-10-03), including a transcript of the v3 binary. |
|
||||
| `CELLS` | IN | Empty (word-addressed, D-1); v3 answers 24 for `3 CELLS`. Executed on the golden model (2026-10-03). |
|
||||
|
||||
@@ -465,8 +465,8 @@ 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; `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. |
|
||||
| `.` `.R` `U.` `U.R` `D.` `D.R` | CAP | Built on pictured output and `TYPE`; definitions below. `.`, `U.` and `D.` print the number in the current base, then one space. The `.R` words right-justify it in `width` columns, print a wider number whole, pad nothing for `width <= 0`, and print no space after it: that is FORTH-79's reference word (ruled 2026-10-04); v3 printed a space after these too. 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, 2 cells: the field width of the `.R` words, and whether a blank follows the number. 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 4 return entries. Clobbers `A` and `B`. |
|
||||
@@ -501,15 +501,18 @@ return stack. `-ROT` is in line (`SWAP push SWAP pop`).
|
||||
```forth
|
||||
\ number output. ABS is in line: -if A inv 1 + A:
|
||||
: .R ( n width -- )
|
||||
(W) b! !b dup push ABS 0 <# #S pop SIGN #> \ baddr u
|
||||
TAIL: (W) b! @b -if POS drop jump OUT \ width < 0
|
||||
POS: over - SPACES \ width - u spaces
|
||||
OUT: TYPE jump SPACE
|
||||
: . ( n -- ) 0 jump .R
|
||||
: U.R ( u width -- ) (W) b! !b 0 <# #S #> jump TAIL
|
||||
: U. ( u -- ) 0 jump U.R
|
||||
: D.R ( d width -- ) (W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump TAIL
|
||||
: D. ( d -- ) 0 jump D.R
|
||||
0 (W) 1 + b! !b \ no blank after it
|
||||
BODY: (W) b! !b dup push ABS 0 <# #S pop SIGN #> \ baddr u
|
||||
TAIL: (W) b! @b -if POS drop jump OUT \ width < 0
|
||||
POS: over - SPACES \ width - u spaces
|
||||
OUT: TYPE (W) 1 + b! @b if DONE drop jump SPACE
|
||||
DONE: drop ;
|
||||
: . ( n -- ) -1 (W) 1 + b! !b 0 jump BODY \ a blank after it
|
||||
: U.R ( u width -- ) 0 (W) 1 + b! !b UBODY: (W) b! !b 0 <# #S #> jump TAIL
|
||||
: U. ( u -- ) -1 (W) 1 + b! !b 0 jump UBODY
|
||||
: D.R ( d width -- ) 0 (W) 1 + b! !b
|
||||
DBODY: (W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump TAIL
|
||||
: D. ( d -- ) -1 (W) 1 + b! !b 0 jump DBODY
|
||||
```
|
||||
|
||||
```forth
|
||||
@@ -549,8 +552,8 @@ in the variable `(DP)`, so the stacks carry only what each picture and `TYPE` ne
|
||||
sits on the return stack across a call.
|
||||
|
||||
There is one picture for signed singles, one for unsigned and one for doubles; each plain word is
|
||||
its `.R` word with a width of 0, entered by a jump, and all six share one tail, which ends in a jump
|
||||
to `SPACE`. The width is tested for sign before `width - u`, which could wrap for a very negative
|
||||
its `.R` word with a width of 0 and the blank flag set, entered by a jump past where `.R` clears
|
||||
that flag, and all six share one tail, which prints the blank only when the flag is set. The width is tested for sign before `width - u`, which could wrap for a very negative
|
||||
width and print a flood of spaces.
|
||||
|
||||
### 5.9 Strings, parsing, and input
|
||||
@@ -567,9 +570,9 @@ width and print a flood of spaces.
|
||||
| `SCAN` `SKIP` | CAP | `( baddr u c -- baddr' u' )`: `SCAN` stops at the first byte equal to the low byte of `c` (or at the end, with `u' = 0`); `SKIP` stops at the first byte not equal to it. See below. A negative count reads as 0, as v3. v3's counted-string auto-detection is not kept. Executed on the golden model (2026-10-03), including a transcript of the v3 binary. Each leaves its caller 5 data cells and 5 return entries. Clobber `A`. |
|
||||
| `(S)` | CAP | Variable, 4 cells: `COMPARE`'s two lengths; `SEARCH`'s string 2 and the whole of string 1. |
|
||||
| `BL` | IN | `32` — executed on the golden model (2026-10-04). |
|
||||
| `EXPECT` `QUERY` | CC | Built on `KEY` (DEV); source in `v4/capsule/input.v4`. `EXPECT ( baddr u -- )` as v3's `fgets`: at most `u-1` characters, stopping after a new-line (taken, not stored), then a zero; `SPAN` is the count; a line that does not fit leaves its tail to be read next; `u < 0` does nothing and sets `NODE-ERROR`. `QUERY` is `TIB #TIB EXPECT 0 >IN !` with `#TIB` 1025, as v3. Executed on the golden model's host node (2026-10-04), including results recorded from the v3 binary. Both part from FORTH-79, which takes up to `u` characters in `EXPECT` and 80 in `QUERY`: reported 2026-10-04, awaiting a ruling. `EXPECT` leaves its caller 6 data cells and 4 return entries. |
|
||||
| `EXPECT` `QUERY` | CC | Built on `KEY` (DEV); source in `v4/capsule/input.v4`. FORTH-79 (ruled 2026-10-04). `EXPECT ( baddr n -- )` stores characters from `baddr` upward until a new-line (taken, not stored) or until `n` have been received, then a zero; no action for `n <= 0`; a line longer than `n` leaves the rest to be read next. It also sets `SPAN`, which is not FORTH-79 but is v3's. `QUERY` is `TIB 80 EXPECT 0 >IN !`. v3's `EXPECT` was C's `fgets` and took `n-1` characters, and its `QUERY` took 1024. Executed on the golden model's host node (2026-10-04) against C for every size and line length. `EXPECT` leaves its caller 6 data cells and 4 return entries. |
|
||||
| `SPAN` `TIB` `>IN` `SOURCE` | CC | Interpreter state on the host node. `TIB` is the buffer's byte address and `>IN` and `SPAN` their variables' word addresses, all in line; `SOURCE ( -- baddr u )` is `TIB` and `SPAN @`, a negative `SPAN` read as 0. Executed on the golden model's host node (2026-10-04). |
|
||||
| `WORD` `ENCLOSE` | CC | Parser; source in `v4/capsule/input.v4`. `WORD ( c -- baddr )`, as v3: the next word of `TIB` delimited by `c`, as a counted string in a 64-byte buffer with a zero after it; delimiters before it are skipped and so are all those after it; a longer word is cut to 62 characters; at the end of the line the count is 0. `ENCLOSE ( baddr c -- baddr n1 n2 n3 )` on a zero-terminated string. Executed on the golden model's host node (2026-10-04) against C and the counts and `>IN` values recorded from the v3 binary (the text in v3's own buffer was corrupt in those runs: `hello` came back as `hlllo`). `WORD` parts from FORTH-79 in skipping every trailing delimiter, storing a zero where the standard stores the delimiter, and cutting at 62: reported 2026-10-04, awaiting a ruling. `WORD` leaves its caller 4 data cells and 3 return entries. |
|
||||
| `WORD` `ENCLOSE` | CC | Parser; source in `v4/capsule/input.v4`. `WORD ( c -- baddr )` is FORTH-79 (ruled 2026-10-04): characters are taken from `TIB` until the delimiter `c` or the end of the text, leading delimiters ignored, and stored as a counted string; the delimiter met (`c`, or a zero if the text ran out) is stored after them, uncounted; `>IN` is left just past it; with nothing left the count is 0. The count is a byte, so a word over 255 characters is cut to 255; the buffer is 257 bytes. v3's `WORD` skipped every delimiter after the word, always stored a zero, and cut at 62. `ENCLOSE ( baddr c -- baddr n1 n2 n3 )`, not a FORTH-79 word, works on a zero-terminated string as v3's. Executed on the golden model's host node (2026-10-04) against C, and `ENCLOSE` against values recorded from the v3 binary. `WORD` leaves its caller 4 data cells and 3 return entries. |
|
||||
| `NUMBER` `CONVERT` | CC | FORTH-79, not v3 (ruled 2026-10-04); source in `v4/capsule/input.v4`. `CONVERT ( d1 baddr1 -- d2 baddr2 )` takes the characters from `baddr1 + 1` on as digits in the current `BASE`, in either case, accumulating each into the double after multiplying it by `BASE`, and stops at the first that is not one; the double is `( lo hi )`. v3's was base 10 only, started at `baddr1`, and took the double low cell on top. `NUMBER ( baddr -- d )` is the counted string as a signed double in the current `BASE`, with an optional leading minus; anything else gives 0 and sets `NODE-ERROR`. v3's returned `( n flag )` in base 10. Executed on the golden model's host node (2026-10-04) against C in eight bases, including a digit that carries out of the low cell. `NUMBER` leaves its caller 3 data cells and 3 return entries. |
|
||||
| `S"` `(s")` `[']` | CC | Compiler words. |
|
||||
| `LITERAL` `[LITERAL]` (placeholders) | RET | The working `LITERAL` is in §5.17. |
|
||||
@@ -726,7 +729,7 @@ The storage service belongs to the Artemis role, now a device node.
|
||||
| `(?DO)` | IN | `over over xor if SKIP drop (DO) … body and loop end … jump PAST SKIP: drop drop drop PAST:` — skips the loop when index = limit, as v3. Executed on the golden model (2026-10-03). |
|
||||
| `(LOOP)` | IN | See below. Adds 1 and goes round again while index < limit, signed, as v3. Executed on the golden model (2026-10-03) against C on every pair of 14 loop ends, and sequences recorded from the v3 binary. |
|
||||
| `(+LOOP)` | IN | See below. `( n -- )`: adds `n` and goes round again while index < limit for `n >= 0`, while index >= limit for `n < 0`, as v3. Executed on the golden model (2026-10-03) against C on every pair of 14 loop ends with 11 steps, and sequences recorded from the v3 binary. Clobbers `A`. |
|
||||
| `(LEAVE)` | IN | `pop drop pop drop jump PAST` — discards the limit and index and leaves the loop at once. In a single loop this is what v3 does. v3 left the two on its return stack (index set to limit) and jumped past the loop, so a `LEAVE` in an inner loop made the outer `LOOP` count the inner loop's leftovers and stop: `: T 3 0 DO 10 0 DO I . I 1 = IF LEAVE THEN LOOP I . LOOP ;` prints `0 1 10` in v3 and `0 1 0 0 1 1 0 1 2` here. Executed on the golden model (2026-10-03) in `LOOP` and `+LOOP`, including sequences recorded from the v3 binary. |
|
||||
| `(LEAVE)` | IN | `pop pop drop dup push push` — FORTH-79 (ruled 2026-10-04): the limit is set equal to the index, so the loop ends at the next `LOOP` or `+LOOP`; the index is unchanged and the rest of the body still runs. v3's `LEAVE` left the loop at once (FORTH-83's behaviour) and, having set the index to the limit, left both on its return stack, so a `LEAVE` in an inner loop made the outer `LOOP` count the inner loop's leftovers and stop: `: T 3 0 DO 10 0 DO I . I 1 = IF LEAVE THEN LOOP I . LOOP ;` prints `0 1 10` in v3 and `0 1 0 0 1 1 0 1 2` here. Executed on the golden model (2026-10-04) in `LOOP` and `+LOOP`, up, down and with a step of 0. |
|
||||
| `I` | IN | `pop dup push` — executed on the golden model (2026-10-03). |
|
||||
| `J` | IN | `pop pop pop dup push a! push push a` — the outer index waits in `A` while the inner pair goes back, so `J` needs no return entry beyond the two loops' own (with two in-line `SWAP`s it needed one more). Executed on the golden model (2026-10-03), including a sequence recorded from the v3 binary. Clobbers `A`. |
|
||||
| `UNLOOP` | IN | `pop drop pop drop` — executed on the golden model (2026-10-03) as `UNLOOP EXIT`, including a sequence recorded from the v3 binary. |
|
||||
|
||||
+29
-23
@@ -7,12 +7,11 @@
|
||||
\ capsule: it runs on the host node. Rests on core.v4.
|
||||
\
|
||||
\ Constants the loader supplies:
|
||||
\ TIB byte address of the text input buffer, #TIB bytes long
|
||||
\ #TIB 1025: 1024 characters and a terminating zero, as v3
|
||||
\ TIB byte address of the text input buffer; QUERY fills at most 81 bytes
|
||||
\ >IN word address of the variable: offset in TIB of the next character
|
||||
\ SPAN word address of the variable: how many characters the last
|
||||
\ EXPECT or QUERY read
|
||||
\ WBUF byte address of WORD's buffer, 64 bytes
|
||||
\ WBUF byte address of WORD's buffer, 257 bytes
|
||||
\ (P) word address of six cells of scratch for this file
|
||||
\ TIB >IN SPAN and BL are in-line: written in a definition they are literals.
|
||||
|
||||
@@ -21,25 +20,26 @@ macro BL 32 endmacro
|
||||
\ ( -- baddr u ) the input buffer and how much of it is in use
|
||||
: SOURCE TIB SPAN a! @ -if P drop 0 P: ;
|
||||
|
||||
\ ( baddr u -- ) read a line into u bytes at baddr, as v3's fgets did: at
|
||||
\ most u-1 characters, stopping after a new-line, which is taken but not
|
||||
\ stored; then a zero. A line of u-1 characters or more leaves what did not
|
||||
\ fit, its new-line included, to be read next. SPAN is the number of characters stored. With u = 0
|
||||
\ nothing is read or stored; u < 0 does nothing and sets NODE-ERROR.
|
||||
\ ( baddr n -- ) FORTH-79: characters from the terminal are stored from
|
||||
\ baddr upward until a new-line or until n have been received; the new-line
|
||||
\ is taken but not stored. A zero is added after the text, so the buffer
|
||||
\ must hold n + 1 bytes. No action for n <= 0. SPAN is how many characters
|
||||
\ were stored (SPAN is not FORTH-79; v3 has it). A line longer than n leaves
|
||||
\ the rest, its new-line included, to be read next.
|
||||
: EXPECT
|
||||
-if OK drop drop NODE-ERROR b! -1 !b ;
|
||||
OK: if ZERO
|
||||
-if NN drop drop ; \ n < 0
|
||||
NN: if ZERO
|
||||
over push \ p n R: start
|
||||
L: -1 + if END \ room for the zero only
|
||||
L: if END
|
||||
push KEY dup -10 + if NL \ p c x R: start n
|
||||
drop over C! 1 + pop jump L
|
||||
drop over C! 1 + pop -1 + jump L
|
||||
NL: drop drop pop
|
||||
END: drop 0 over C! \ p
|
||||
pop - SPAN a! ! ;
|
||||
ZERO: drop drop 0 SPAN a! ! ;
|
||||
ZERO: drop drop ;
|
||||
|
||||
\ ( -- ) read a line into TIB and start at its beginning
|
||||
: QUERY TIB #TIB EXPECT 0 >IN a! ! ;
|
||||
\ ( -- ) FORTH-79: up to 80 characters, or a line, into TIB; >IN to 0.
|
||||
: QUERY TIB 80 EXPECT 0 >IN a! ! ;
|
||||
|
||||
\ ---- WORD ------------------------------------------------------------------
|
||||
\ (P)+0 the delimiter, (P)+1 the length of the text in TIB.
|
||||
@@ -56,21 +56,26 @@ macro (WLEN) (P) 1 + endmacro
|
||||
L: (LEFT) -if E drop (CH) if E drop 1 + jump L
|
||||
E: drop ;
|
||||
|
||||
\ ( c -- baddr ) the next word of TIB delimited by c, as a counted string
|
||||
\ in WBUF with a zero after it. Leading delimiters are skipped; so, as in
|
||||
\ v3, are all those that follow the word. A word longer than 62 characters
|
||||
\ is cut to 62. At the end of the text the count is 0.
|
||||
\ ( c -- baddr ) FORTH-79: characters are taken from TIB until the
|
||||
\ delimiter c or the end of the text, leading delimiters ignored, and stored
|
||||
\ in WBUF as a counted string. The delimiter met -- c, or a zero if the text
|
||||
\ ran out -- is stored after them and is not counted. >IN is left just past
|
||||
\ that delimiter. With nothing left the count is 0. The count is a byte,
|
||||
\ so a word longer than 255 characters is cut to 255.
|
||||
: WORD
|
||||
255 and (WDELIM) a! !
|
||||
SPAN a! @ -if A drop 0 A: (WLEN) a! !
|
||||
>IN a! @ -if B drop 0 B:
|
||||
(SKIP) dup push (SCAN) \ end R: start
|
||||
pop over over - \ end start len
|
||||
dup -63 + -if CAP drop jump FITS CAP: drop drop 62 FITS:
|
||||
dup -256 + -if CAP drop jump FITS CAP: drop drop 255 FITS:
|
||||
dup WBUF C!
|
||||
dup push push TIB + WBUF 1 + pop CMOVE \ end R: len
|
||||
0 pop WBUF + 1 + C!
|
||||
(SKIP) >IN a! ! WBUF ;
|
||||
(LEFT) -if RANOUT
|
||||
drop (WDELIM) a! @ pop WBUF + 1 + C! \ the delimiter after the text
|
||||
1 + >IN a! ! WBUF ;
|
||||
RANOUT: drop 0 pop WBUF + 1 + C!
|
||||
>IN a! ! WBUF ;
|
||||
|
||||
\ ---- ENCLOSE ---------------------------------------------------------------
|
||||
\ (P)+0 the delimiter, (P)+1 the string's address.
|
||||
@@ -120,7 +125,8 @@ macro (WLEN) (P) 1 + endmacro
|
||||
\ the current BASE; it may begin with a minus sign. If it is empty, is only
|
||||
\ a sign, or holds anything that is not a digit, the result is 0 and
|
||||
\ NODE-ERROR is set. The character after the string must not be a digit
|
||||
\ (WORD puts a zero there); if it is, that too is reported as an error. (P)+3 the address of its last character, (P)+4 the sign.
|
||||
\ (WORD puts the delimiter or a zero there); if it is, that too is reported
|
||||
\ as an error. (P)+3 the address of its last character, (P)+4 the sign.
|
||||
: NUMBER
|
||||
dup C@ if ERR2
|
||||
over + (P) 3 + a! ! \ baddr
|
||||
|
||||
+92
-76
@@ -5,25 +5,24 @@
|
||||
* ENCLOSE CONVERT NUMBER and the comment words. The definitions are text,
|
||||
* capsule/core.v4 and capsule/input.v4, assembled here by the text assembler.
|
||||
*
|
||||
* v3 (v3/src/word_source/string_words.c), kept:
|
||||
* EXPECT ( baddr u -- ) at most u-1 characters, stopping after a
|
||||
* new-line; a zero after them; SPAN is how many
|
||||
* QUERY a line into TIB, >IN to 0
|
||||
* WORD ( c -- baddr ) the next word of TIB as a counted string; the
|
||||
* delimiters before it and all those after it are skipped
|
||||
* ENCLOSE ( baddr c -- baddr n1 n2 n3 )
|
||||
* FORTH-79, where v3 was something else (ruled 2026-10-04):
|
||||
* These are FORTH-79 words and follow the standard (ruled 2026-10-04) where
|
||||
* v3 did something else:
|
||||
* EXPECT ( baddr n -- ) up to n characters, or to a new-line; a zero
|
||||
* after them; no action for n <= 0. v3 took n-1 (it was fgets).
|
||||
* QUERY up to 80 characters into TIB, >IN to 0. v3 took 1024.
|
||||
* WORD ( c -- baddr ) the next word of TIB as a counted string, the
|
||||
* delimiter met (or a zero at the end of the text) stored after
|
||||
* it; >IN just past that delimiter. v3 skipped every delimiter
|
||||
* after the word, stored a zero, and cut the word at 62.
|
||||
* CONVERT ( d1 baddr1 -- d2 baddr2 ) starts at baddr1 + 1, honours BASE,
|
||||
* and the double is ( lo hi ). v3 was base 10 only, started at
|
||||
* baddr1, and took the double low cell on top.
|
||||
* NUMBER ( baddr -- d ) a signed double in the current BASE; anything
|
||||
* that is not a number gives 0 and sets NODE-ERROR. v3 returned
|
||||
* ( n flag ) and read base 10 only.
|
||||
* SPAN, SOURCE, TIB and ENCLOSE are not in FORTH-79 and behave as v3's.
|
||||
*
|
||||
* The values marked "v3:" were recorded from the v3 binary on 2026-10-04.
|
||||
* v3's WORD returned the right count and left >IN right, but the text in its
|
||||
* buffer was corrupt in those runs ("hello" came back as "hlllo"), so only
|
||||
* its counts and >IN are used.
|
||||
*/
|
||||
#include "v4/text.h"
|
||||
#include "v4/testcode.h"
|
||||
@@ -48,13 +47,13 @@ static int failures = 0, checks = 0;
|
||||
#define TO_IN (TOP - 9)
|
||||
#define SPAN (TOP - 10)
|
||||
#define PVARS (TOP - 16) /* six cells */
|
||||
#define WBUF_W (TOP - 40) /* 16 cells = 64 bytes, with a cell free on each side */
|
||||
#define TIB_W (TOP - 304) /* 260 cells = 1040 bytes */
|
||||
#define SBUF_W (TOP - 384) /* 64 cells = 256 bytes for the tests' own strings */
|
||||
#define WBUF_W (TOP - 90) /* 65 cells = 260 bytes, with cells free on each side */
|
||||
#define WBUF_CELLS 65
|
||||
#define TIB_W (TOP - 360) /* 260 cells = 1040 bytes */
|
||||
#define SBUF_W (TOP - 440) /* 64 cells = 256 bytes for the tests' own strings */
|
||||
#define WBUF (WBUF_W * 4)
|
||||
#define TIB (TIB_W * 4)
|
||||
#define SBUF (SBUF_W * 4)
|
||||
#define TIB_SIZE 1025
|
||||
#define GUARD ((v4_cell)0x5EED5EED)
|
||||
|
||||
static v4_node n;
|
||||
@@ -119,11 +118,13 @@ static v4_cell pop(void) { return v4_dstack_pop(&n.ds); }
|
||||
static int clean(void) { return pop() == CANARY; }
|
||||
static int err(void) { return n.mem[NODE_ERROR] != 0; }
|
||||
|
||||
/* The counted string WORD left: its text, and that a zero follows it. */
|
||||
static int word_is(v4_cell baddr, const char *want)
|
||||
/* The counted string WORD left: its text, and after it the delimiter it met
|
||||
* (`after`), or a zero if the text ran out. */
|
||||
static int word_is(v4_cell baddr, const char *want, int after)
|
||||
{
|
||||
unsigned len = (unsigned)strlen(want);
|
||||
return baddr == WBUF && byte_at(WBUF) == len && bytes_are(WBUF + 1, want, len) && byte_at(WBUF + 1 + (v4_cell)len) == 0;
|
||||
return baddr == WBUF && byte_at(WBUF) == len && bytes_are(WBUF + 1, want, len)
|
||||
&& byte_at(WBUF + 1 + (v4_cell)len) == (unsigned char)after;
|
||||
}
|
||||
|
||||
/* Stack headroom, as in test_foundation.c. */
|
||||
@@ -234,7 +235,6 @@ int main(void)
|
||||
v4_text_constant(&tx, "CONSOLE-STATUS", CONSOLE_ST);
|
||||
v4_text_constant(&tx, "BASE", BASE);
|
||||
v4_text_constant(&tx, "TIB", TIB);
|
||||
v4_text_constant(&tx, "#TIB", TIB_SIZE);
|
||||
v4_text_constant(&tx, ">IN", TO_IN);
|
||||
v4_text_constant(&tx, "SPAN", SPAN);
|
||||
v4_text_constant(&tx, "WBUF", WBUF);
|
||||
@@ -292,27 +292,26 @@ int main(void)
|
||||
/* ---- EXPECT ---- */
|
||||
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
|
||||
|
||||
/* v3: B 8 EXPECT on "hello world this is long": SPAN 7, 68 65 6C 6C 6F 20 77 00, and
|
||||
* the rest of the line ("orld ...") still to be read */
|
||||
/* FORTH-79: up to n characters. (v3, which was fgets, stored 7 of
|
||||
* "hello world this is long" for 8 EXPECT; the standard stores 8.) */
|
||||
for (i = 0; i < 64; i++) n.mem[SBUF_W + (v4_cell)i] = 0x2A2A2A2A;
|
||||
CHECK(v4_node_console_feed(&n, "hello world this is long\n", 25) == 25, "fed");
|
||||
CHECK(run("EXPECT", 2, SBUF, 8, 0) && clean() && !err(), "v3: 8 EXPECT returns");
|
||||
CHECK(n.mem[SPAN] == 7 && bytes_are(SBUF, "hello w\0", 8) && byte_at(SBUF + 8) == 0x2A, "v3: 8 EXPECT stores \"hello w\" and a zero, SPAN 7");
|
||||
CHECK(run("KEY", 0, 0, 0, 0) && pop() == 'o', "v3: and leaves the rest of the line unread");
|
||||
CHECK(run("EXPECT", 2, SBUF, 8, 0) && clean() && !err(), "8 EXPECT returns");
|
||||
CHECK(n.mem[SPAN] == 8 && bytes_are(SBUF, "hello wo\0", 9) && byte_at(SBUF + 9) == 0x2A, "8 EXPECT stores eight characters and a zero, SPAN 8");
|
||||
CHECK(run("KEY", 0, 0, 0, 0) && pop() == 'r', "and leaves the rest of the line unread");
|
||||
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
|
||||
|
||||
/* v3: B 8 EXPECT on "hi": SPAN 2. Then B 3 EXPECT on "xyz": SPAN 2, 78 79 00, 'z' unread */
|
||||
CHECK(v4_node_console_feed(&n, "hi\nxyz\n", 7) == 7, "fed");
|
||||
CHECK(run("EXPECT", 2, SBUF, 8, 0) && clean() && n.mem[SPAN] == 2 && bytes_are(SBUF, "hi\0", 3), "v3: a short line: SPAN 2, the new-line taken, not stored");
|
||||
CHECK(run("EXPECT", 2, SBUF, 3, 0) && clean() && n.mem[SPAN] == 2 && bytes_are(SBUF, "xy\0", 3), "v3: 3 EXPECT stores two characters");
|
||||
CHECK(run("KEY", 0, 0, 0, 0) && pop() == 'z', "v3: and leaves the third unread");
|
||||
CHECK(run("EXPECT", 2, SBUF, 8, 0) && clean() && n.mem[SPAN] == 2 && bytes_are(SBUF, "hi\0", 3), "a short line: SPAN 2, the new-line taken, not stored");
|
||||
CHECK(run("EXPECT", 2, SBUF, 3, 0) && clean() && n.mem[SPAN] == 3 && bytes_are(SBUF, "xyz\0", 4), "3 EXPECT stores three characters");
|
||||
CHECK(run("KEY", 0, 0, 0, 0) && pop() == '\n', "and leaves the new-line unread");
|
||||
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
|
||||
|
||||
/* every size against every line length */
|
||||
for (t = 0; t <= 12; t++)
|
||||
for (t = 1; t <= 12; t++)
|
||||
for (i = 0; i <= 12; i++) {
|
||||
char line[16];
|
||||
unsigned want = t == 0 ? 0 : (i < t - 1 ? i : t - 1), k;
|
||||
unsigned want = i < t ? i : t, k;
|
||||
for (k = 0; k < i; k++) line[k] = (char)('A' + k);
|
||||
line[i] = '\n';
|
||||
for (k = 0; k < 64; k++) n.mem[SBUF_W + (v4_cell)k] = 0x2A2A2A2A;
|
||||
@@ -321,20 +320,29 @@ int main(void)
|
||||
n.mem[SPAN] = 99;
|
||||
CHECK(run("EXPECT", 2, SBUF + 3, (v4_cell)t, 0) && clean() && !err(), "EXPECT returns [%u,%u]", t, i);
|
||||
CHECK(n.mem[SPAN] == (v4_cell)want, "EXPECT SPAN [%u,%u]: %ld", t, i, (long)n.mem[SPAN]);
|
||||
CHECK(bytes_are(SBUF + 3, line, want) && (t == 0 || byte_at(SBUF + 3 + (v4_cell)want) == 0), "EXPECT text [%u,%u]", t, i);
|
||||
CHECK(byte_at(SBUF + 2) == 0x2A && byte_at(SBUF + 3 + (v4_cell)want + (t ? 1 : 0)) == 0x2A, "EXPECT writes nothing else [%u,%u]", t, i);
|
||||
/* what is left unread: the line's tail if it did not fit, new-line
|
||||
* included -- and, as with fgets, the new-line alone when the
|
||||
* text exactly filled the u-1 characters */
|
||||
CHECK(bytes_are(SBUF + 3, line, want) && byte_at(SBUF + 3 + (v4_cell)want) == 0, "EXPECT text [%u,%u]", t, i);
|
||||
CHECK(byte_at(SBUF + 2) == 0x2A && byte_at(SBUF + 4 + (v4_cell)want) == 0x2A, "EXPECT writes nothing else [%u,%u]", t, i);
|
||||
/* what is left unread: nothing if the new-line was reached, else
|
||||
* the rest of the line and its new-line */
|
||||
k = n.input_len - n.input_pos;
|
||||
CHECK(k == (t == 0 ? i + 1u : (i + 1u < t ? 0u : i + 1u - (t - 1u))), "EXPECT leaves %u unread [%u,%u]", k, t, i);
|
||||
CHECK(k == (i < t ? 0u : i + 1u - t), "EXPECT leaves %u unread [%u,%u]", k, t, i);
|
||||
}
|
||||
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
|
||||
n.mem[SPAN] = 5;
|
||||
CHECK(run("EXPECT", 2, SBUF, -1, 0) && clean() && err() && n.mem[SPAN] == 5, "EXPECT of a negative size sets NODE-ERROR and reads nothing");
|
||||
/* no action for n <= 0: nothing read, nothing stored, SPAN as it was, no error */
|
||||
{
|
||||
static const v4_cell none[] = { 0, -1, -100, (v4_cell)V4_MSB };
|
||||
for (i = 0; i < 4; i++) {
|
||||
for (t = 0; t < 64; t++) n.mem[SBUF_W + (v4_cell)t] = 0x2A2A2A2A;
|
||||
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
|
||||
(void)v4_node_console_feed(&n, "abc\n", 4);
|
||||
n.mem[SPAN] = 5;
|
||||
CHECK(run("EXPECT", 2, SBUF, none[i], 0) && clean() && !err() && n.mem[SPAN] == 5
|
||||
&& n.input_len - n.input_pos == 4 && byte_at(SBUF) == 0x2A, "EXPECT takes no action for n <= 0 [%u]", i);
|
||||
}
|
||||
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
|
||||
}
|
||||
|
||||
/* ---- QUERY and SOURCE ---- */
|
||||
n.mem[TIB_W - 1] = GUARD; n.mem[TIB_W + 260] = GUARD;
|
||||
n.mem[TIB_W - 1] = GUARD; n.mem[TIB_W + 21] = GUARD;
|
||||
n.mem[TO_IN] = 77;
|
||||
CHECK(v4_node_console_feed(&n, " 12 34 +\nnext line\n", 20) == 20, "fed");
|
||||
CHECK(run("QUERY", 0, 0, 0, 0) && clean() && !err(), "QUERY returns");
|
||||
@@ -342,13 +350,14 @@ int main(void)
|
||||
CHECK(run("SOURCE", 0, 0, 0, 0) && pop() == 9 && pop() == TIB && clean(), "SOURCE is TIB and SPAN @");
|
||||
CHECK(run("QUERY", 0, 0, 0, 0) && clean() && n.mem[SPAN] == 9 && bytes_are(TIB, "next line\0", 10), "the next QUERY reads the next line");
|
||||
{
|
||||
static char longline[1200];
|
||||
for (i = 0; i < 1100; i++) longline[i] = (char)('a' + i % 26);
|
||||
longline[1100] = '\n';
|
||||
CHECK(v4_node_console_feed(&n, longline, 1101) == 1101, "fed");
|
||||
CHECK(run("QUERY", 0, 0, 0, 0) && clean() && n.mem[SPAN] == 1024, "a line longer than TIB is cut at 1024 characters");
|
||||
CHECK(bytes_are(TIB, longline, 1024) && byte_at(TIB + 1024) == 0, "with a zero after them");
|
||||
CHECK(n.mem[TIB_W - 1] == GUARD && n.mem[TIB_W + 260] == GUARD, "and nothing outside TIB written");
|
||||
static char longline[200];
|
||||
for (i = 0; i < 150; i++) longline[i] = (char)('a' + i % 26);
|
||||
longline[150] = '\n';
|
||||
CHECK(v4_node_console_feed(&n, longline, 151) == 151, "fed");
|
||||
CHECK(run("QUERY", 0, 0, 0, 0) && clean() && n.mem[SPAN] == 80, "QUERY takes at most 80 characters");
|
||||
CHECK(bytes_are(TIB, longline, 80) && byte_at(TIB + 80) == 0, "with a zero after them");
|
||||
CHECK(n.mem[TIB_W - 1] == GUARD && n.mem[TIB_W + 21] == GUARD, "and nothing past the 81st byte written");
|
||||
CHECK(run("QUERY", 0, 0, 0, 0) && clean() && n.mem[SPAN] == 70 && bytes_are(TIB, longline + 80, 70), "the rest of the line is the next QUERY's");
|
||||
v4_node_console_input_attach(&n, CONSOLE_RX, CONSOLE_ST);
|
||||
}
|
||||
n.mem[SPAN] = -5;
|
||||
@@ -356,26 +365,27 @@ int main(void)
|
||||
|
||||
/* ---- WORD ---- */
|
||||
|
||||
/* v3: " hello world x": BL WORD twice, then >IN is 18 and SPAN 19; a third gives count 1, >IN 19 */
|
||||
/* FORTH-79: the delimiter met is stored after the word, and >IN is left
|
||||
* just past it. (v3 skipped all the delimiters after a word, so its
|
||||
* >IN after "world" was 18 where the standard's is 17.) */
|
||||
set_line(" hello world x");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "hello") && clean() && n.mem[TO_IN] == 11, "the first word");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "world") && clean() && n.mem[TO_IN] == 18 && n.mem[SPAN] == 19, "v3: after two words >IN is 18");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "x") && clean() && n.mem[TO_IN] == 19, "v3: the third has count 1 and >IN is 19");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "") && clean() && n.mem[TO_IN] == 19, "at the end of the line the count is 0");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "hello", ' ') && clean() && n.mem[TO_IN] == 9, "the first word; >IN is past one blank");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "world", ' ') && clean() && n.mem[TO_IN] == 17, "the second");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "x", 0) && clean() && n.mem[TO_IN] == 19, "the last word ends the text: a zero after it");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "", 0) && clean() && n.mem[TO_IN] == 19, "with nothing left the count is 0");
|
||||
|
||||
/* v3: "a b,,c d,e": SOURCE gives 10; 44 WORD twice, then >IN is 9 */
|
||||
set_line("a b,,c d,e");
|
||||
CHECK(run("WORD", 1, 44, 0, 0) && word_is(pop(), "a b") && clean() && n.mem[TO_IN] == 5, "a comma-delimited word; both commas skipped");
|
||||
CHECK(run("WORD", 1, 44, 0, 0) && word_is(pop(), "c d") && clean() && n.mem[TO_IN] == 9, "v3: after two >IN is 9");
|
||||
CHECK(run("WORD", 1, 44, 0, 0) && word_is(pop(), "e") && clean() && n.mem[TO_IN] == 10, "the last one");
|
||||
CHECK(run("WORD", 1, 44, 0, 0) && word_is(pop(), "a b", ',') && clean() && n.mem[TO_IN] == 4, "a comma-delimited word; one comma taken");
|
||||
CHECK(run("WORD", 1, 44, 0, 0) && word_is(pop(), "c d", ',') && clean() && n.mem[TO_IN] == 9, "the leading comma of the next is skipped");
|
||||
CHECK(run("WORD", 1, 44, 0, 0) && word_is(pop(), "e", 0) && clean() && n.mem[TO_IN] == 10, "the last one");
|
||||
|
||||
/* v3: "AAAA" with delimiter 65: count 0, >IN 4, count 0 */
|
||||
/* v3: "AAAA" with delimiter 65: count 0, >IN 4, count 0 -- the same in the standard */
|
||||
set_line("AAAA");
|
||||
CHECK(run("WORD", 1, 65, 0, 0) && word_is(pop(), "") && clean() && n.mem[TO_IN] == 4, "v3: a line of delimiters: count 0, >IN 4");
|
||||
CHECK(run("WORD", 1, 65, 0, 0) && word_is(pop(), "") && clean() && n.mem[TO_IN] == 4, "v3: and again");
|
||||
CHECK(run("WORD", 1, 65, 0, 0) && word_is(pop(), "", 0) && clean() && n.mem[TO_IN] == 4, "v3: a line of delimiters: count 0, >IN 4");
|
||||
CHECK(run("WORD", 1, 65, 0, 0) && word_is(pop(), "", 0) && clean() && n.mem[TO_IN] == 4, "v3: and again");
|
||||
|
||||
/* against C */
|
||||
n.mem[WBUF_W - 1] = GUARD; n.mem[WBUF_W + 16] = GUARD;
|
||||
n.mem[WBUF_W - 1] = GUARD; n.mem[WBUF_W + WBUF_CELLS] = GUARD;
|
||||
for (t = 0; t < 400; t++) {
|
||||
char line[96], tok[96];
|
||||
unsigned len = rnd() % 70, pos = 0, guard = 0;
|
||||
@@ -385,44 +395,50 @@ int main(void)
|
||||
set_line(line);
|
||||
for (;;) {
|
||||
unsigned start, end, tl;
|
||||
int after;
|
||||
while (pos < len && line[pos] == delim) pos++;
|
||||
start = pos;
|
||||
while (pos < len && line[pos] != delim) pos++;
|
||||
end = pos;
|
||||
while (pos < len && line[pos] == delim) pos++;
|
||||
after = pos < len ? delim : 0;
|
||||
if (pos < len) pos++;
|
||||
tl = end - start;
|
||||
memcpy(tok, line + start, tl);
|
||||
tok[tl] = 0;
|
||||
CHECK(run("WORD", 1, (v4_cell)(0x700 + delim), 0, 0) && word_is(pop(), tok) && clean() && !err()
|
||||
CHECK(run("WORD", 1, (v4_cell)(0x700 + delim), 0, 0) && word_is(pop(), tok, after) && clean() && !err()
|
||||
&& n.mem[TO_IN] == (v4_cell)pos, "WORD [%u] \"%s\" at %u", t, tok, pos);
|
||||
if (tl == 0 || ++guard > 80) break;
|
||||
if (pos >= len || ++guard > 80) break;
|
||||
}
|
||||
CHECK(run("WORD", 1, (v4_cell)delim, 0, 0) && word_is(pop(), "", 0) && clean() && n.mem[TO_IN] == (v4_cell)len, "WORD at the end [%u]", t);
|
||||
CHECK(bytes_are(TIB, line, len + 1u) && n.mem[SPAN] == (v4_cell)len, "WORD leaves TIB and SPAN [%u]", t);
|
||||
}
|
||||
/* a word longer than the buffer is cut to 62, and >IN still passes all of it */
|
||||
/* a word of 255 characters fits; a longer one is cut to 255, and >IN still passes all of it */
|
||||
{
|
||||
char line[200], cut[64];
|
||||
memset(line, 'w', 150); line[150] = ' '; line[151] = 'z'; line[152] = 0;
|
||||
memset(cut, 'w', 62); cut[62] = 0;
|
||||
static char line[400], cut[256];
|
||||
memset(line, 'w', 255); line[255] = ' '; line[256] = 'z'; line[257] = 0;
|
||||
memset(cut, 'w', 255); cut[255] = 0;
|
||||
set_line(line);
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), cut) && clean() && n.mem[TO_IN] == 151, "a 150-character word is cut to 62");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "z") && clean(), "and the next word is the next word");
|
||||
CHECK(n.mem[WBUF_W - 1] == GUARD && n.mem[WBUF_W + 16] == GUARD, "nothing outside WORD's buffer written");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), cut, ' ') && clean() && n.mem[TO_IN] == 256, "a 255-character word is whole");
|
||||
memset(line, 'w', 300); line[300] = ' '; line[301] = 'z'; line[302] = 0;
|
||||
set_line(line);
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), cut, ' ') && clean() && n.mem[TO_IN] == 301, "a 300-character word is cut to 255");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "z", 0) && clean(), "and the next word is the next word");
|
||||
CHECK(n.mem[WBUF_W - 1] == GUARD && n.mem[WBUF_W + WBUF_CELLS] == GUARD, "nothing outside WORD's buffer written");
|
||||
}
|
||||
set_line("abc def");
|
||||
n.mem[TO_IN] = -3;
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "abc") && clean(), "a negative >IN reads as 0");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "abc", ' ') && clean(), "a negative >IN reads as 0");
|
||||
n.mem[SPAN] = -3; n.mem[TO_IN] = 0;
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "") && clean() && n.mem[TO_IN] == 0, "a negative SPAN reads as an empty line");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "", 0) && clean() && n.mem[TO_IN] == 0, "a negative SPAN reads as an empty line");
|
||||
|
||||
/* ---- the comment words ---- */
|
||||
set_line("skip this ) kept ( and ) too");
|
||||
CHECK(run("PAREN", 0, 0, 0, 0) && clean() && n.mem[TO_IN] == 11, "( skips to after the closing parenthesis");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "kept") && clean(), "and the next word follows");
|
||||
CHECK(run("PAREN", 0, 0, 0, 0) && clean() && n.mem[TO_IN] == 11, "( skips to just after the closing parenthesis");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "kept", ' ') && clean(), "and the next word follows");
|
||||
set_line("one two three");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "one") && run("BACKSLASH", 0, 0, 0, 0) && clean() && n.mem[TO_IN] == 13,
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "one", ' ') && run("BACKSLASH", 0, 0, 0, 0) && clean() && n.mem[TO_IN] == 13,
|
||||
"\\ skips the rest of the line");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "") && clean(), "nothing is left after it");
|
||||
CHECK(run("WORD", 1, 32, 0, 0) && word_is(pop(), "", 0) && clean(), "nothing is left after it");
|
||||
|
||||
/* ---- ENCLOSE ---- */
|
||||
|
||||
|
||||
+27
-23
@@ -13,18 +13,21 @@
|
||||
* LOOP adds 1 and goes round again while index < limit, signed
|
||||
* +LOOP ( n -- ) adds n and goes round again while index < limit for
|
||||
* n >= 0, while index >= limit for n < 0
|
||||
* LEAVE leaves the loop at once
|
||||
* LEAVE FORTH-79 (ruled 2026-10-04): sets the limit equal to the
|
||||
* index, so the loop ends at the next LOOP or +LOOP; the index is
|
||||
* unchanged and the rest of the body still runs. v3's LEAVE left
|
||||
* the loop at once, which is FORTH-83's.
|
||||
* I J the index of this loop, of the loop outside it
|
||||
* UNLOOP discards the loop's limit and index, for EXIT
|
||||
* So `0 5 DO .. LOOP` runs once in v3 and here; 5.18's first (LOOP), which
|
||||
* tested for index = limit, would have gone round the whole number circle.
|
||||
*
|
||||
* Where v4 parts from v3: v3's LEAVE set the index to the limit and jumped
|
||||
* past the loop without discarding the two, which is invisible in a single
|
||||
* loop but breaks an outer one: in v3
|
||||
* v3's LEAVE also left the loop's limit and index on its return stack, which
|
||||
* is invisible in a single loop but breaks an outer one: in v3
|
||||
* : T 3 0 DO 10 0 DO I . I 1 = IF LEAVE THEN LOOP I . LOOP ;
|
||||
* prints "0 1 10" and stops, the outer LOOP having counted the inner loop's
|
||||
* leftovers. Here LEAVE discards them, and the outer loop carries on.
|
||||
* leftovers. Here the inner LOOP discards them as it ends, and the outer
|
||||
* loop carries on.
|
||||
*
|
||||
* The expected sequences marked "v3:" were recorded from the v3 binary on
|
||||
* 2026-10-03, as in test_numout.c.
|
||||
@@ -109,8 +112,9 @@ static v4_cell t_do, t_qdo, t_ploop, t_pqdo, t_nest, t_leave, t_pleave, t_nestle
|
||||
exit_ = FWD(MINUS_IF); O(DROP); O(PUSH); O(PUSH); JUMP(body); \
|
||||
HERE_(exit_); O(DROP); O(DROP); O(DROP); } while (0)
|
||||
|
||||
/* (LEAVE) pop drop pop drop jump PAST the caller resolves PAST after the loop */
|
||||
#define LEAVE_(past) do { O(RPOP); O(DROP); O(RPOP); O(DROP); (past) = FWD(JUMP); } while (0)
|
||||
/* (LEAVE) pop pop drop dup push push R: index index
|
||||
* The limit becomes the index; nothing is jumped over. */
|
||||
#define LEAVE_() do { O(RPOP); O(RPOP); O(DROP); O(DUP); O(PUSH); O(PUSH); } while (0)
|
||||
|
||||
/* I pop dup push
|
||||
* J pop pop pop dup push a! push push a
|
||||
@@ -132,7 +136,7 @@ static v4_cell t_do, t_qdo, t_ploop, t_pqdo, t_nest, t_leave, t_pleave, t_nestle
|
||||
|
||||
static void build(void)
|
||||
{
|
||||
v4_asm_ref a, b, skip, past;
|
||||
v4_asm_ref a, b, skip, past; /* past: the jump over a skipped ?DO loop */
|
||||
v4_cell body, body2;
|
||||
|
||||
/* ( limit start -- ) DO I rec LOOP */
|
||||
@@ -167,11 +171,10 @@ static void build(void)
|
||||
DO_(); body = v4_asm_label(&as);
|
||||
I_(); REC_();
|
||||
I_(); VGET(KV); O(XOR); a = FWD(IF); O(DROP); b = FWD(JUMP);
|
||||
HERE_(a); O(DROP); LEAVE_(past);
|
||||
HERE_(a); O(DROP); LEAVE_();
|
||||
HERE_(b);
|
||||
I_(); REC_();
|
||||
LOOP_(body);
|
||||
HERE_(past);
|
||||
LIT(77); VSET(LAST); O(SEMI);
|
||||
|
||||
/* ( limit start -- ) DO I rec I KV @ = IF LEAVE THEN I rec STEP @ +LOOP 77 LAST ! */
|
||||
@@ -179,11 +182,10 @@ static void build(void)
|
||||
DO_(); body = v4_asm_label(&as);
|
||||
I_(); REC_();
|
||||
I_(); VGET(KV); O(XOR); a = FWD(IF); O(DROP); b = FWD(JUMP);
|
||||
HERE_(a); O(DROP); LEAVE_(past);
|
||||
HERE_(a); O(DROP); LEAVE_();
|
||||
HERE_(b);
|
||||
I_(); REC_();
|
||||
VGET(STEP); PLOOP_(body);
|
||||
HERE_(past);
|
||||
LIT(77); VSET(LAST); O(SEMI);
|
||||
|
||||
/* ( -- ) 3 0 DO 10 0 DO I rec I 1 = IF LEAVE THEN LOOP I rec LOOP 77 LAST ! */
|
||||
@@ -194,10 +196,9 @@ static void build(void)
|
||||
body2 = v4_asm_label(&as);
|
||||
I_(); REC_();
|
||||
I_(); LIT(1); O(XOR); a = FWD(IF); O(DROP); b = FWD(JUMP);
|
||||
HERE_(a); O(DROP); LEAVE_(past);
|
||||
HERE_(a); O(DROP); LEAVE_();
|
||||
HERE_(b);
|
||||
LOOP_(body2);
|
||||
HERE_(past);
|
||||
I_(); REC_();
|
||||
LOOP_(body);
|
||||
LIT(77); VSET(LAST); O(SEMI);
|
||||
@@ -376,14 +377,17 @@ int main(void)
|
||||
/* : T 3 0 DO 12 10 DO I . J . LOOP LOOP ; 10 0 11 0 10 1 11 1 10 2 11 2 */
|
||||
CHECK(call(t_nest, 0, 0, 2, 3, 12) && SAW(10, 0, 11, 0, 10, 1, 11, 1, 10, 2, 11, 2), "v3: nested loops, I and J");
|
||||
|
||||
/* : T 10 0 DO I . I 3 = IF LEAVE THEN I . LOOP ; 0 0 1 1 2 2 3
|
||||
* : T 20 0 DO I . I 6 = IF LEAVE THEN I . 3 +LOOP 77 . ; 0 0 3 3 6 77
|
||||
* : T 0 20 DO I . I 11 = IF LEAVE THEN I . -3 +LOOP 77 . ; 20 20 17 17 14 14 11 77 */
|
||||
CHECK(call(t_leave, 0, 3, 2, 10, 0) && SAW(0, 0, 1, 1, 2, 2, 3) && n.mem[LAST] == 77, "v3: LEAVE in LOOP");
|
||||
CHECK(call(t_pleave, 3, 6, 2, 12, 0) && SAW(0, 0, 3, 3, 6) && n.mem[LAST] == 77, "LEAVE in +LOOP, limit below 16");
|
||||
CHECK(call(t_pleave, 3, 6, 2, 20, 0) && SAW(0, 0, 3, 3, 6) && n.mem[LAST] == 77, "v3: LEAVE in +LOOP, up");
|
||||
CHECK(call(t_pleave, -3, 11, 2, 0, 20) && SAW(20, 20, 17, 17, 14, 14, 11) && n.mem[LAST] == 77,
|
||||
"v3: LEAVE in +LOOP, down");
|
||||
/* FORTH-79 LEAVE: the body runs on to the loop's end with I unchanged.
|
||||
* (v3, leaving at once, printed one number fewer in each of these.)
|
||||
* : T 10 0 DO I . I 3 = IF LEAVE THEN I . LOOP ; 0 0 1 1 2 2 3 3
|
||||
* : T 20 0 DO I . I 6 = IF LEAVE THEN I . 3 +LOOP 77 . ; 0 0 3 3 6 6 77
|
||||
* : T 0 20 DO I . I 11 = IF LEAVE THEN I . -3 +LOOP 77 . ; 20 20 17 17 14 14 11 11 77 */
|
||||
CHECK(call(t_leave, 0, 3, 2, 10, 0) && SAW(0, 0, 1, 1, 2, 2, 3, 3) && n.mem[LAST] == 77, "LEAVE in LOOP");
|
||||
CHECK(call(t_pleave, 3, 6, 2, 12, 0) && SAW(0, 0, 3, 3, 6, 6) && n.mem[LAST] == 77, "LEAVE in +LOOP, limit below 16");
|
||||
CHECK(call(t_pleave, 3, 6, 2, 20, 0) && SAW(0, 0, 3, 3, 6, 6) && n.mem[LAST] == 77, "LEAVE in +LOOP, up");
|
||||
CHECK(call(t_pleave, -3, 11, 2, 0, 20) && SAW(20, 20, 17, 17, 14, 14, 11, 11) && n.mem[LAST] == 77,
|
||||
"LEAVE in +LOOP, down");
|
||||
CHECK(call(t_pleave, 0, 4, 2, 9, 4) && SAW(4, 4) && n.mem[LAST] == 77, "LEAVE ends a 0 +LOOP");
|
||||
|
||||
/* : T 10 0 DO I 3 = IF UNLOOP EXIT THEN I . LOOP 99 . ; 0 1 2 */
|
||||
CHECK(call(t_unloop, 0, 3, 2, 10, 0) && SAW(0, 1, 2) && n.mem[LAST] == 0, "v3: UNLOOP EXIT");
|
||||
@@ -441,7 +445,7 @@ int main(void)
|
||||
/* LEAVE and UNLOOP EXIT at every index of a short loop */
|
||||
for (i = 0; i < 12; i++) {
|
||||
unsigned m;
|
||||
for (m = 0, j = 0; j < 12; j++) { want[m++] = (v4_cell)j; if (j == i) break; want[m++] = (v4_cell)j; }
|
||||
for (m = 0, j = 0; j <= i; j++) { want[m++] = (v4_cell)j; want[m++] = (v4_cell)j; }
|
||||
CHECK(call(t_leave, 0, (v4_cell)i, 2, 12, 0) && saw(want, m) && n.mem[LAST] == 77, "LEAVE at %u", i);
|
||||
for (m = 0, j = 0; j < i; j++) want[m++] = (v4_cell)j;
|
||||
CHECK(call(t_unloop, 0, (v4_cell)i, 2, 12, 0) && saw(want, m) && n.mem[LAST] == 0, "UNLOOP EXIT at %u", i);
|
||||
|
||||
+49
-35
@@ -8,12 +8,11 @@
|
||||
* v3 (v3/src/word_source/format_words.c, io_words.c):
|
||||
* . U. the number in the current base, then one space
|
||||
* .R U.R ( n width -- ) the number right-justified in `width`
|
||||
* columns, then one space; a number wider than the field is
|
||||
* printed whole; width <= 0 pads nothing
|
||||
* columns; a number wider than the field is printed whole;
|
||||
* width <= 0 pads nothing. No space after it: that is the
|
||||
* FORTH-79 reference word (ruled 2026-10-04); v3 printed one.
|
||||
* D. D.R the same for a double
|
||||
* SPACES ( n -- ) n spaces, none for n <= 0
|
||||
* v3's trailing space after the .R words is not FORTH-79 but is what v3
|
||||
* prints, so it is kept.
|
||||
*
|
||||
* Where v4 parts from v3, as 5.8 already rules for pictured output:
|
||||
* - a double is ( lo hi ), high cell on top; v3's D. took the low cell on
|
||||
@@ -50,6 +49,7 @@ static int failures = 0, checks = 0;
|
||||
#define HLD ((v4_cell)(V4_NODE_WORDS - 35u))
|
||||
#define BASE ((v4_cell)(V4_NODE_WORDS - 34u))
|
||||
#define FIELD ((v4_cell)(V4_NODE_WORDS - 36u)) /* (W): the field width of the .R words */
|
||||
#define TRAIL ((v4_cell)(V4_NODE_WORDS - 37u)) /* (W)+1 in the document: whether a blank follows the number */
|
||||
#define HCAP 63
|
||||
|
||||
static v4_node n;
|
||||
@@ -287,7 +287,7 @@ static void build_pictured(void)
|
||||
static void build_output(void)
|
||||
{
|
||||
v4_asm_ref a, b;
|
||||
v4_cell l, l_tail;
|
||||
v4_cell l, l_tail, l_rbody, l_ubody, l_dbody;
|
||||
|
||||
/* : C@ ( baddr -- c ) call-free, 5.3
|
||||
* dup 2/ 2/ a! 3 and k A: word address
|
||||
@@ -366,16 +366,21 @@ static void build_output(void)
|
||||
HERE_(b);
|
||||
O(DROP); O(SEMI);
|
||||
|
||||
/* : .R ( n width -- )
|
||||
* (W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> baddr u
|
||||
/* : .R ( n width -- ) FORTH-79: no blank after it
|
||||
* 0 (W) 1 + b! !b
|
||||
* BODY: (W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> baddr u
|
||||
* TAIL: (W) b! @b -if POS drop jump OUT width < 0
|
||||
* POS: over - SPACES
|
||||
* OUT: TYPE jump SPACE
|
||||
* OUT: TYPE (W) 1 + b! @b if DONE drop jump SPACE
|
||||
* DONE: drop ;
|
||||
* The width waits in the variable (W), on neither stack, so the picture
|
||||
* runs as deep as it does on its own. A negative width is dropped before
|
||||
* the subtraction, which could otherwise wrap. U.R and D.R jump to TAIL,
|
||||
* and SPACE returns to the caller. */
|
||||
* the subtraction, which could otherwise wrap. (W)+1 says whether a blank
|
||||
* follows the number: `.` sets it and enters at BODY with a width of 0;
|
||||
* `.R` clears it. U.R and D.R jump to TAIL. */
|
||||
w_dotr = v4_asm_label(&as);
|
||||
LIT(0); VSET(TRAIL);
|
||||
l_rbody = v4_asm_label(&as);
|
||||
VSET(FIELD); O(DUP); O(PUSH);
|
||||
a = FWD(MINUS_IF); O(INV); LIT(1); O(ADD); HERE_(a);
|
||||
LIT(0); CALL(w_begin); CALL(w_hashs); O(RPOP); CALL(w_sign); CALL(w_end);
|
||||
@@ -385,30 +390,37 @@ static void build_output(void)
|
||||
HERE_(a);
|
||||
O(OVER); SUB_INLINE(); CALL(w_spaces);
|
||||
HERE_(b);
|
||||
CALL(w_type); JUMP(w_space);
|
||||
CALL(w_type); VGET(TRAIL); a = FWD(IF);
|
||||
O(DROP); JUMP(w_space);
|
||||
HERE_(a);
|
||||
O(DROP); O(SEMI);
|
||||
|
||||
/* : . ( n -- ) 0 jump .R */
|
||||
/* : . ( n -- ) -1 (W) 1 + b! !b 0 jump BODY a blank after it */
|
||||
w_dot = v4_asm_label(&as);
|
||||
LIT(0); JUMP(w_dotr);
|
||||
LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_rbody);
|
||||
|
||||
/* : U.R ( u width -- ) (W) b! !b 0 <# #S #> jump TAIL */
|
||||
/* : U.R ( u width -- ) 0 (W) 1 + b! !b UBODY: (W) b! !b 0 <# #S #> jump TAIL */
|
||||
w_udotr = v4_asm_label(&as);
|
||||
LIT(0); VSET(TRAIL);
|
||||
l_ubody = v4_asm_label(&as);
|
||||
VSET(FIELD); LIT(0); CALL(w_begin); CALL(w_hashs); CALL(w_end); JUMP(l_tail);
|
||||
|
||||
/* : U. ( u -- ) 0 jump U.R */
|
||||
/* : U. ( u -- ) -1 (W) 1 + b! !b 0 jump UBODY */
|
||||
w_udot = v4_asm_label(&as);
|
||||
LIT(0); JUMP(w_udotr);
|
||||
LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_ubody);
|
||||
|
||||
/* : D.R ( d width -- )
|
||||
* (W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump TAIL */
|
||||
* 0 (W) 1 + b! !b DBODY: (W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump TAIL */
|
||||
w_ddotr = v4_asm_label(&as);
|
||||
LIT(0); VSET(TRAIL);
|
||||
l_dbody = v4_asm_label(&as);
|
||||
VSET(FIELD); O(DUP); O(PUSH);
|
||||
a = FWD(MINUS_IF); CALL(w_dnegate); HERE_(a);
|
||||
CALL(w_begin); CALL(w_hashs); O(RPOP); CALL(w_sign); CALL(w_end); JUMP(l_tail);
|
||||
|
||||
/* : D. ( d -- ) 0 jump D.R */
|
||||
/* : D. ( d -- ) -1 (W) 1 + b! !b 0 jump DBODY */
|
||||
w_ddot = v4_asm_label(&as);
|
||||
LIT(0); JUMP(w_ddotr);
|
||||
LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_dbody);
|
||||
|
||||
/* ---- the v3 transcripts ---- */
|
||||
#define DOT(v) do { LIT(v); CALL(w_dot); } while (0)
|
||||
@@ -549,7 +561,7 @@ static void ref_digits(v4_ucell lo, v4_ucell hi, unsigned base, char *out)
|
||||
/* What is printed for the number text `num` in a field of `width`: the last
|
||||
* HCAP characters of it (D-13), padded on the left, then one space. Returns
|
||||
* whether the hold buffer overflowed. */
|
||||
static int ref_line(const char *num, v4_cell width, char *out)
|
||||
static int ref_line(const char *num, v4_cell width, int blank, char *out)
|
||||
{
|
||||
size_t len = strlen(num), pad, i;
|
||||
int over = len > HCAP;
|
||||
@@ -557,8 +569,8 @@ static int ref_line(const char *num, v4_cell width, char *out)
|
||||
pad = (width > 0 && (v4_ucell)width > len) ? (size_t)width - len : 0;
|
||||
for (i = 0; i < pad; i++) out[i] = ' ';
|
||||
memcpy(out + pad, num, len);
|
||||
out[pad + len] = ' ';
|
||||
out[pad + len + 1] = 0;
|
||||
if (blank) out[pad + len++] = ' ';
|
||||
out[pad + len] = 0;
|
||||
return over;
|
||||
}
|
||||
|
||||
@@ -600,15 +612,17 @@ int main(void)
|
||||
build_pictured();
|
||||
build_output();
|
||||
CHECK(v4_asm_ok(&as), "number-output words assemble");
|
||||
CHECK(v4_asm_label(&as) < FIELD, "code stays below the variables");
|
||||
CHECK(v4_asm_label(&as) < TRAIL, "code stays below the variables");
|
||||
printf(" code: %ld of %u words\n", (long)v4_asm_label(&as), (unsigned)V4_NODE_WORDS);
|
||||
|
||||
/* The v3 transcripts. */
|
||||
CHECK(call(t_v3a, 10, 0, 0, 0, 0) && printed("5 -5 0 123456789 [42 0 ]"), "v3: . and U.");
|
||||
CHECK(call(t_v3b, 10, 0, 0, 0, 0) && printed("[ 42 ] -42 ]123456 ]7 ]7 ] 42 ]"),
|
||||
"v3: .R and U.R");
|
||||
/* v3 printed "[ 42 ] -42 ]123456 ]7 ]7 ] 42 ]": a space after each */
|
||||
CHECK(call(t_v3b, 10, 0, 0, 0, 0) && printed("[ 42] -42]123456]7]7] 42]"),
|
||||
".R and U.R, as v3 but for the space after");
|
||||
CHECK(call(t_v3c, 10, 0, 0, 0, 0) && printed("FF -FF BEEF 100 -17 ["), "v3: HEX and OCTAL");
|
||||
CHECK(call(t_v3d, 10, 0, 0, 0, 0) && printed("[5 -5 0 77 ] -77 ]"), "v3: D. and D.R");
|
||||
/* v3 printed "[5 -5 0 77 ] -77 ]" */
|
||||
CHECK(call(t_v3d, 10, 0, 0, 0, 0) && printed("[5 -5 0 77] -77]"), "D. as v3; D.R as v3 but for the space after");
|
||||
CHECK(call(t_v3e, 10, 0, 0, 0, 0) && printed("[ ]]] ]"), "v3: SPACES");
|
||||
#if V4_CELL_BITS == 64
|
||||
CHECK(call(t_v3f, 10, 0, 0, 0, 0)
|
||||
@@ -629,12 +643,12 @@ int main(void)
|
||||
|
||||
/* . and .R */
|
||||
ref_signed((v4_ucell)v, v < 0 ? MAXU : 0, base, num);
|
||||
over = ref_line(num, 0, want);
|
||||
over = ref_line(num, 0, 1, want);
|
||||
CHECK(call(w_dot, bases[bi], 1, v, 0, 0) && printed(want),
|
||||
". base %ld [%u]: want \"%s\"", (long)bases[bi], i, want);
|
||||
CHECK(v4_node_load(&n, NODE_ERROR) == (over ? -1 : 0), ". NODE-ERROR base %ld [%u]", (long)bases[bi], i);
|
||||
for (wi = 0; wi < NWIDTH; wi++) {
|
||||
over = ref_line(num, widths[wi], want);
|
||||
over = ref_line(num, widths[wi], 0, want);
|
||||
CHECK(call(w_dotr, bases[bi], 2, v, widths[wi], 0) && printed(want),
|
||||
".R base %ld [%u] width %ld: want \"%s\"", (long)bases[bi], i, (long)widths[wi], want);
|
||||
CHECK(v4_node_load(&n, NODE_ERROR) == (over ? -1 : 0), ".R NODE-ERROR");
|
||||
@@ -642,12 +656,12 @@ int main(void)
|
||||
|
||||
/* U. and U.R */
|
||||
ref_digits((v4_ucell)v, 0, base, num);
|
||||
over = ref_line(num, 0, want);
|
||||
over = ref_line(num, 0, 1, want);
|
||||
CHECK(call(w_udot, bases[bi], 1, v, 0, 0) && printed(want),
|
||||
"U. base %ld [%u]: want \"%s\"", (long)bases[bi], i, want);
|
||||
CHECK(v4_node_load(&n, NODE_ERROR) == (over ? -1 : 0), "U. NODE-ERROR base %ld [%u]", (long)bases[bi], i);
|
||||
for (wi = 0; wi < NWIDTH; wi++) {
|
||||
over = ref_line(num, widths[wi], want);
|
||||
over = ref_line(num, widths[wi], 0, want);
|
||||
CHECK(call(w_udotr, bases[bi], 2, v, widths[wi], 0) && printed(want),
|
||||
"U.R base %ld [%u] width %ld: want \"%s\"", (long)bases[bi], i, (long)widths[wi], want);
|
||||
CHECK(v4_node_load(&n, NODE_ERROR) == (over ? -1 : 0), "U.R NODE-ERROR");
|
||||
@@ -656,12 +670,12 @@ int main(void)
|
||||
/* D. and D.R */
|
||||
for (j = 0; j < NVEC; j++) {
|
||||
ref_signed((v4_ucell)vec[i], (v4_ucell)vec[j], base, num);
|
||||
over = ref_line(num, 0, want);
|
||||
over = ref_line(num, 0, 1, want);
|
||||
CHECK(call(w_ddot, bases[bi], 2, vec[i], vec[j], 0) && printed(want),
|
||||
"D. base %ld [%u,%u]: want \"%s\"", (long)bases[bi], i, j, want);
|
||||
CHECK(v4_node_load(&n, NODE_ERROR) == (over ? -1 : 0), "D. NODE-ERROR");
|
||||
for (wi = 0; wi < NWIDTH; wi += 5) {
|
||||
over = ref_line(num, widths[wi], want);
|
||||
over = ref_line(num, widths[wi], 0, want);
|
||||
CHECK(call(w_ddotr, bases[bi], 3, vec[i], vec[j], widths[wi]) && printed(want),
|
||||
"D.R base %ld [%u,%u] width %ld: want \"%s\"",
|
||||
(long)bases[bi], i, j, (long)widths[wi], want);
|
||||
@@ -699,14 +713,14 @@ int main(void)
|
||||
CHECK(dh >= 6 && rh >= 6, "SPACES leaves room");
|
||||
headroom(".", w_dot, 1, -12345, 0, 0, "-12345 ", &dh, &rh);
|
||||
CHECK(dh >= 2 && rh >= 2, ". leaves room");
|
||||
headroom(".R", w_dotr, 2, -12345, 9, 0, " -12345 ", &dh, &rh);
|
||||
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 >= 3 && rh >= 3, "U. leaves room");
|
||||
headroom("U.R", w_udotr, 2, 12345, 9, 0, " 12345 ", &dh, &rh);
|
||||
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");
|
||||
headroom("D.R", w_ddotr, 3, -12345, -1, 9, " -12345 ", &dh, &rh);
|
||||
headroom("D.R", w_ddotr, 3, -12345, -1, 9, " -12345", &dh, &rh);
|
||||
CHECK(dh >= 2 && rh >= 2, "D.R leaves room");
|
||||
}
|
||||
|
||||
|
||||
+31
-17
@@ -56,6 +56,7 @@ static int failures = 0, checks = 0;
|
||||
#define HLD ((v4_cell)(V4_NODE_WORDS - 35u))
|
||||
#define BASE ((v4_cell)(V4_NODE_WORDS - 34u))
|
||||
#define FIELD ((v4_cell)(V4_NODE_WORDS - 36u)) /* (W): the field width of the .R words */
|
||||
#define TRAIL ((v4_cell)(V4_NODE_WORDS - 46u)) /* (W)+1 in the document: whether a blank follows the number */
|
||||
#define HCAP 63
|
||||
#define QP ((v4_cell)(V4_NODE_WORDS - 40u)) /* (QP): Q.PRINT's BASE, |q| and sign */
|
||||
#define DP ((v4_cell)(V4_NODE_WORDS - 44u)) /* (DP): DUMP's BASE, address, count, column */
|
||||
@@ -301,7 +302,7 @@ static void build_pictured(void)
|
||||
static void build_output(void)
|
||||
{
|
||||
v4_asm_ref a, b, c, d, done1, done2;
|
||||
v4_cell l, l_tail, l_line;
|
||||
v4_cell l, l_tail, l_rbody, l_ubody, l_dbody, l_line;
|
||||
|
||||
/* : C@ ( baddr -- c ) call-free, 5.3
|
||||
* dup 2/ 2/ a! 3 and k A: word address
|
||||
@@ -380,16 +381,21 @@ static void build_output(void)
|
||||
HERE_(b);
|
||||
O(DROP); O(SEMI);
|
||||
|
||||
/* : .R ( n width -- )
|
||||
* (W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> baddr u
|
||||
/* : .R ( n width -- ) FORTH-79: no blank after it
|
||||
* 0 (W) 1 + b! !b
|
||||
* BODY: (W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> baddr u
|
||||
* TAIL: (W) b! @b -if POS drop jump OUT width < 0
|
||||
* POS: over - SPACES
|
||||
* OUT: TYPE jump SPACE
|
||||
* OUT: TYPE (W) 1 + b! @b if DONE drop jump SPACE
|
||||
* DONE: drop ;
|
||||
* The width waits in the variable (W), on neither stack, so the picture
|
||||
* runs as deep as it does on its own. A negative width is dropped before
|
||||
* the subtraction, which could otherwise wrap. U.R and D.R jump to TAIL,
|
||||
* and SPACE returns to the caller. */
|
||||
* the subtraction, which could otherwise wrap. (W)+1 says whether a blank
|
||||
* follows the number: `.` sets it and enters at BODY with a width of 0;
|
||||
* `.R` clears it. U.R and D.R jump to TAIL. */
|
||||
w_dotr = v4_asm_label(&as);
|
||||
LIT(0); VSET(TRAIL);
|
||||
l_rbody = v4_asm_label(&as);
|
||||
VSET(FIELD); O(DUP); O(PUSH);
|
||||
a = FWD(MINUS_IF); O(INV); LIT(1); O(ADD); HERE_(a);
|
||||
LIT(0); CALL(w_begin); CALL(w_hashs); O(RPOP); CALL(w_sign); CALL(w_end);
|
||||
@@ -400,30 +406,37 @@ static void build_output(void)
|
||||
O(OVER); SUB_INLINE(); CALL(w_spaces);
|
||||
HERE_(b);
|
||||
l_out = v4_asm_label(&as);
|
||||
CALL(w_type); JUMP(w_space);
|
||||
CALL(w_type); VGET(TRAIL); a = FWD(IF);
|
||||
O(DROP); JUMP(w_space);
|
||||
HERE_(a);
|
||||
O(DROP); O(SEMI);
|
||||
|
||||
/* : . ( n -- ) 0 jump .R */
|
||||
/* : . ( n -- ) -1 (W) 1 + b! !b 0 jump BODY a blank after it */
|
||||
w_dot = v4_asm_label(&as);
|
||||
LIT(0); JUMP(w_dotr);
|
||||
LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_rbody);
|
||||
|
||||
/* : U.R ( u width -- ) (W) b! !b 0 <# #S #> jump TAIL */
|
||||
/* : U.R ( u width -- ) 0 (W) 1 + b! !b UBODY: (W) b! !b 0 <# #S #> jump TAIL */
|
||||
w_udotr = v4_asm_label(&as);
|
||||
LIT(0); VSET(TRAIL);
|
||||
l_ubody = v4_asm_label(&as);
|
||||
VSET(FIELD); LIT(0); CALL(w_begin); CALL(w_hashs); CALL(w_end); JUMP(l_tail);
|
||||
|
||||
/* : U. ( u -- ) 0 jump U.R */
|
||||
/* : U. ( u -- ) -1 (W) 1 + b! !b 0 jump UBODY */
|
||||
w_udot = v4_asm_label(&as);
|
||||
LIT(0); JUMP(w_udotr);
|
||||
LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_ubody);
|
||||
|
||||
/* : D.R ( d width -- )
|
||||
* (W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump TAIL */
|
||||
* 0 (W) 1 + b! !b DBODY: (W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump TAIL */
|
||||
w_ddotr = v4_asm_label(&as);
|
||||
LIT(0); VSET(TRAIL);
|
||||
l_dbody = v4_asm_label(&as);
|
||||
VSET(FIELD); O(DUP); O(PUSH);
|
||||
a = FWD(MINUS_IF); CALL(w_dnegate); HERE_(a);
|
||||
CALL(w_begin); CALL(w_hashs); O(RPOP); CALL(w_sign); CALL(w_end); JUMP(l_tail);
|
||||
|
||||
/* : D. ( d -- ) 0 jump D.R */
|
||||
/* : D. ( d -- ) -1 (W) 1 + b! !b 0 jump DBODY */
|
||||
w_ddot = v4_asm_label(&as);
|
||||
LIT(0); JUMP(w_ddotr);
|
||||
LIT(-1); VSET(TRAIL); LIT(0); JUMP(l_dbody);
|
||||
/* ---- the words under test ---- */
|
||||
|
||||
/* : CR ( -- ) 10 jump EMIT */
|
||||
@@ -445,7 +458,7 @@ static void build_output(void)
|
||||
* pop 15 FOR 2/ UNEXT HIMASK and high cell of |q| >> 16
|
||||
* #S (QP) 3 + b! @b SIGN #>
|
||||
* (QP) b! @b BASE b! !b
|
||||
* jump OUT TYPE jump SPACE, in .R
|
||||
* -1 (W) 1 + b! !b jump OUT TYPE and a blank, in .R
|
||||
* frac * 100000 / 65536 is frac * 3125 / 2048, which stays inside a
|
||||
* 32-bit cell; times 3125 is times 5 five times. HIMASK clears the top
|
||||
* 16 bits, making the 2/ shift a logical one. */
|
||||
@@ -476,6 +489,7 @@ static void build_output(void)
|
||||
LIT((v4_cell)(MAXU >> 16)); O(AND);
|
||||
CALL(w_hashs); VGET(QP + 3); CALL(w_sign); CALL(w_end);
|
||||
VGET(QP); VSET(BASE);
|
||||
LIT(-1); VSET(TRAIL);
|
||||
JUMP(l_out);
|
||||
|
||||
/* : (DB) ( -- c ) (DP) 1 + b! @b (DP) 3 + b! @b + jump C@
|
||||
@@ -793,7 +807,7 @@ int main(void)
|
||||
build_pictured();
|
||||
build_output();
|
||||
CHECK(v4_asm_ok(&as), "printing words assemble");
|
||||
CHECK(v4_asm_label(&as) < XVAR, "code stays below the variables");
|
||||
CHECK(v4_asm_label(&as) < TRAIL, "code stays below the variables");
|
||||
printf(" code: %ld of %u words\n", (long)v4_asm_label(&as) - CODE0, (unsigned)V4_NODE_WORDS);
|
||||
|
||||
/* 128 bytes to dump: every kind of byte, with v3's twenty at 0xD0. */
|
||||
|
||||
+33
-22
@@ -9,8 +9,11 @@
|
||||
* COUNT ( baddr -- baddr+1 c )
|
||||
* CMOVE ( src dst u -- ) low byte first
|
||||
* CMOVE> ( src dst u -- ) high byte first
|
||||
* MOVE ( src dst u -- ) whichever of the two does not overwrite
|
||||
* bytes it has yet to read
|
||||
* MOVE ( addr1 addr2 n -- ) FORTH-79 (ruled 2026-10-04): n cells
|
||||
* from addr1 to addr2, the cell at addr1
|
||||
* first; nothing for n <= 0. The addresses
|
||||
* are word addresses (D-1). v3's MOVE moved
|
||||
* bytes, either way round, like memmove.
|
||||
* FILL ( baddr u c -- ) the low byte of c
|
||||
* BLANK ERASE ( baddr u -- ) FILL with 32, with 0
|
||||
* -TRAILING ( baddr u -- baddr u' ) without its trailing spaces
|
||||
@@ -173,15 +176,22 @@ static void build(void)
|
||||
HERE_(b);
|
||||
O(DROP); O(DROP); O(DROP); O(SEMI);
|
||||
|
||||
/* : MOVE ( src dst u -- )
|
||||
* push over over - -if UP drop pop jump CMOVE> src < dst
|
||||
* UP: drop pop jump CMOVE
|
||||
* The sign of src - dst, the subtraction in line. */
|
||||
/* : MOVE ( addr1 addr2 n -- ) FORTH-79: cells, low address first
|
||||
* -if OK drop drop drop ; n < 0
|
||||
* OK: if DONE push addr1 addr2 R: n
|
||||
* over a! @ over a! ! 1 + push 1 + pop pop -1 + jump OK
|
||||
* DONE: drop drop drop ; */
|
||||
w_move = v4_asm_label(&as);
|
||||
O(PUSH); O(OVER); O(OVER); SUB_INLINE(); a = FWD(MINUS_IF);
|
||||
O(DROP); O(RPOP); JUMP(w_cmoveup);
|
||||
a = FWD(MINUS_IF);
|
||||
O(DROP); O(DROP); O(DROP); O(SEMI);
|
||||
HERE_(a);
|
||||
O(DROP); O(RPOP); JUMP(w_cmove);
|
||||
l = v4_asm_label(&as);
|
||||
b = FWD(IF);
|
||||
O(PUSH); O(OVER); O(BANG_A); O(FETCH_A); O(OVER); O(BANG_A); O(STORE_A);
|
||||
LIT(1); O(ADD); O(PUSH); LIT(1); O(ADD); O(RPOP); O(RPOP); LIT(-1); O(ADD);
|
||||
JUMP(l);
|
||||
HERE_(b);
|
||||
O(DROP); O(DROP); O(DROP); O(SEMI);
|
||||
|
||||
/* : FILL ( baddr u c -- )
|
||||
* -ROT c baddr u
|
||||
@@ -524,12 +534,10 @@ int main(void)
|
||||
* 20 20 20 20 2E 2E 2E 2E 00 00 00 2E 2E 2E 2E 2E
|
||||
* "ABCDEF" B 6 CMOVE B B 2 + 6 CMOVE> B B 1 + 6 CMOVE B 16 DUMP
|
||||
* 41 41 41 41 41 41 41 46 00 00 00 2E 2E 2E 2E 2E
|
||||
* B 3 + B 5 MOVE B 16 DUMP
|
||||
* 41 41 41 41 46 41 41 46 00 00 00 2E 2E 2E 2E 2E */
|
||||
* (v3 went on to B 3 + B 5 MOVE, a byte move; MOVE here is FORTH-79's and moves cells.) */
|
||||
{
|
||||
static const unsigned char d1[16] = { 0x20,0x20,0x20,0x20,0x2E,0x2E,0x2E,0x2E,0,0,0,0x2E,0x2E,0x2E,0x2E,0x2E };
|
||||
static const unsigned char d2[16] = { 0x41,0x41,0x41,0x41,0x41,0x41,0x41,0x46,0,0,0,0x2E,0x2E,0x2E,0x2E,0x2E };
|
||||
static const unsigned char d3[16] = { 0x41,0x41,0x41,0x41,0x46,0x41,0x41,0x46,0,0,0,0x2E,0x2E,0x2E,0x2E,0x2E };
|
||||
const v4_cell B = BUF + 21;
|
||||
#define STEP(word, argc, a, b, c) do { \
|
||||
CHECK(call(word, argc, a, b, c, 0) && clean() && !err(), "v3 block-copy step returns"); \
|
||||
@@ -544,8 +552,6 @@ int main(void)
|
||||
STEP(w_cmoveup, 3, B, B + 2, 6);
|
||||
STEP(w_cmove, 3, B, B + 1, 6);
|
||||
CHECK(memcmp(img + 21, d2, 16) == 0, "v3: CMOVE, CMOVE>, CMOVE");
|
||||
STEP(w_move, 3, B + 3, B, 5);
|
||||
CHECK(memcmp(img + 21, d3, 16) == 0, "v3: MOVE");
|
||||
for (i = 0; i < BUFLEN; i++)
|
||||
if ((i < 21 || i >= 37) && (i < 100 || i >= 106) && img[i] != 0x77) break;
|
||||
CHECK(i == BUFLEN, "nothing outside B was written");
|
||||
@@ -585,11 +591,16 @@ int main(void)
|
||||
if (t % 2) dst = rnd() % (BUFLEN - 48);
|
||||
else { int d = (int)(rnd() % 17) - 8; dst = (unsigned)((int)src + d < 0 ? 0 : (int)src + d); if (dst > BUFLEN - 48) dst = BUFLEN - 48; }
|
||||
random_img(0);
|
||||
CHECK(call(which == 0 ? w_cmove : which == 1 ? w_cmoveup : w_move, 3,
|
||||
BUF + (v4_cell)src, BUF + (v4_cell)dst, (v4_cell)len, 0) && clean(), "move returns [%u]", t);
|
||||
if (which == 0) for (k = 0; k < len; k++) img[dst + k] = img[src + k];
|
||||
else if (which == 1) for (k = len; k-- > 0; ) img[dst + k] = img[src + k];
|
||||
else memmove(img + dst, img + src, len);
|
||||
if (which == 2) { /* MOVE: cells, not bytes */
|
||||
len /= 4; src /= 4; dst /= 4;
|
||||
CHECK(call(w_move, 3, BUFW + (v4_cell)src, BUFW + (v4_cell)dst, (v4_cell)len, 0) && clean(), "MOVE returns [%u]", t);
|
||||
for (k = 0; k < 4 * len; k++) img[4 * dst + k] = img[4 * src + k];
|
||||
} else {
|
||||
CHECK(call(which == 0 ? w_cmove : w_cmoveup, 3,
|
||||
BUF + (v4_cell)src, BUF + (v4_cell)dst, (v4_cell)len, 0) && clean(), "move returns [%u]", t);
|
||||
if (which == 0) for (k = 0; k < len; k++) img[dst + k] = img[src + k];
|
||||
else for (k = len; k-- > 0; ) img[dst + k] = img[src + k];
|
||||
}
|
||||
CHECK(img_matches() && !err(), "%s [%u] src %u dst %u len %u",
|
||||
which == 0 ? "CMOVE" : which == 1 ? "CMOVE>" : "MOVE", t, src, dst, len);
|
||||
}
|
||||
@@ -601,8 +612,8 @@ int main(void)
|
||||
for (i = 0; i < 3; i++) {
|
||||
CHECK(call(w_cmove, 3, BUF, BUF + 50, neg[i], 0) && clean() && img_matches() && err(), "CMOVE negative count [%u]", i);
|
||||
CHECK(call(w_cmoveup, 3, BUF, BUF + 50, neg[i], 0) && clean() && img_matches() && err(), "CMOVE> negative count [%u]", i);
|
||||
CHECK(call(w_move, 3, BUF, BUF + 50, neg[i], 0) && clean() && img_matches() && err(), "MOVE negative count, up [%u]", i);
|
||||
CHECK(call(w_move, 3, BUF + 50, BUF, neg[i], 0) && clean() && img_matches() && err(), "MOVE negative count, down [%u]", i);
|
||||
CHECK(call(w_move, 3, BUFW, BUFW + 12, neg[i], 0) && clean() && img_matches() && !err(), "MOVE moves nothing for n < 0, up [%u]", i);
|
||||
CHECK(call(w_move, 3, BUFW + 12, BUFW, neg[i], 0) && clean() && img_matches() && !err(), "MOVE moves nothing for n < 0, down [%u]", i);
|
||||
CHECK(call(w_fill, 3, BUF, neg[i], 65, 0) && clean() && img_matches() && err(), "FILL negative count [%u]", i);
|
||||
CHECK(call(w_blank, 2, BUF, neg[i], 0, 0) && clean() && img_matches() && err(), "BLANK negative count [%u]", i);
|
||||
CHECK(call(w_erase, 2, BUF, neg[i], 0, 0) && clean() && img_matches() && err(), "ERASE negative count [%u]", i);
|
||||
@@ -690,7 +701,7 @@ int main(void)
|
||||
headroom("COUNT", w_count, 1, BUF + 3, 0, 0, 0, 2, 6, 6);
|
||||
headroom("CMOVE", w_cmove, 3, BUF + 3, BUF + 90, 9, 0, 0, 3, 5);
|
||||
headroom("CMOVE>", w_cmoveup, 3, BUF + 3, BUF + 90, 9, 0, 0, 3, 5);
|
||||
headroom("MOVE", w_move, 3, BUF + 3, BUF + 6, 9, 0, 0, 3, 5);
|
||||
headroom("MOVE", w_move, 3, BUFW + 1, BUFW + 9, 5, 0, 0, 4, 6);
|
||||
headroom("FILL", w_fill, 3, BUF + 3, 9, 65, 0, 0, 3, 5);
|
||||
headroom("BLANK", w_blank, 2, BUF + 3, 9, 0, 0, 0, 3, 5);
|
||||
headroom("-TRAILING", w_trailing, 2, BUF + 64, 8, 0, 0, 2, 4, 6);
|
||||
|
||||
Reference in New Issue
Block a user