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

feat(v4.0.0): number output in the capsule, and .S

Browse Source 
- capsule/numout.v4: <# # #S HOLD SIGN #>, . .R U. U.R D. D.R, ?, SPACES,
  DECIMAL HEX OCTAL -- the definitions DECOMPOSITION.md 5.8 gives and the
  mesh-node tests execute, now words of the host node's vocabulary.
- .S, which D-16 makes possible again: as v3, the depth, then every value
  from the deepest, then a new line.  It needs six cells of the stack
  free.
- tests/test_host_quit.c: printed from the prompt, with 14 more sessions
  that are transcripts of the v3 binary, and the ends of the number range
  at each cell width.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-04 18:50:12 -04:00
co-authored by Claude Opus 5.5
parent ebffa6082d
commit 644bfc0a25
4 changed files with 190 additions and 3 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/capsule/numout.v4
+118
View File
@@ -0,0 +1,118 @@
\ numout.v4 -- printing numbers: pictured output, the . words, and .S
\
\ DECOMPOSITION.md 5.8: <# # #S HOLD SIGN #> . .R U. U.R D. D.R ? SPACES
\ DECIMAL HEX OCTAL, each the definition given there and executed on the mesh
\ node by test_pictured.c, test_numout.c and test_printing.c; and .S, which
\ D-16 makes possible again. Part of the compiler capsule. Rests on core.v4
\ and forth.v4.
\
\ Constants the loader supplies:
\ HEND byte address just past the hold buffer, which is 64 bytes
\ -HFLOOR minus the lowest address HOLD may store at: -(HEND - 62)
\ HLD word address of the variable: where the picture has got to
\ (W) word address of three cells of scratch for this file:
\ (W)+0 the width a number is to be printed in
\ (W)+1 whether a blank follows it (W)+2 .S's count
macro (-ROT) SWAP push SWAP pop endmacro
\ ---- unsigned division (section 4) ----
\ One step a bit, the divisor in A. Exact for uhi < ud.
: UM/MOD ( ulo uhi ud -- urem uquot )
a! N-1 FOR
-if L0
2* over -if L1 drop 1 + jump L2
L1: drop L2: push 2* pop
jump SUB
L0:
2* over -if L3 drop 1 + jump L4
L3: drop L4: push 2* pop
dup a xor -if L5
drop -if NOSUB jump SUB
L5: drop dup inv a + inv -if L6
drop jump NOSUB
L6: push drop pop jump SETBIT
SUB: inv a + inv
SETBIT: push 1 + pop
NOSUB:
NEXT
over push push drop pop pop ;
\ ---- pictured output ----
header <#
: <# ( -- ) HEND HLD b! !b ;
header HOLD
: HOLD ( c -- )
dup -256 and if OKC drop jump ERR
OKC: drop HLD b! @b -HFLOOR + -if ROOM drop
ERR: drop NODE-ERROR b! -1 !b ;
ROOM: drop HLD b! @b -1 + dup !b jump C!
header SIGN
: SIGN ( n -- ) -if L1 drop 45 jump HOLD L1: drop ;
header #
: # ( ud1 -- ud2 )
0 (BASE) UM/MOD (-ROT) \ qhi lo rem1
(BASE) UM/MOD (-ROT) \ qlo qhi rem
dup -10 + -if L1 drop 48 + jump L2 L1: drop 55 + L2: jump HOLD
header #S
: #S ( ud -- 0 0 ) L: # over over OR if L1 drop jump L L1: drop ;
header #>
: #> ( ud -- baddr u ) drop drop HLD b! @b HEND over push inv pop + inv ;
\ ---- spaces and the number base ----
header SPACES
: SPACES ( n -- ) -if L drop ; L: if DONE SPACE -1 + jump L DONE: drop ;
header DECIMAL
: DECIMAL 10 BASE a! ! ;
header HEX
: HEX 16 BASE a! ! ;
header OCTAL
: OCTAL 8 BASE a! ! ;
\ ---- numbers ----
\ One picture for signed singles, one for unsigned, one for doubles. Each
\ plain word is its .R word with a width of 0 and the blank flag set, and all
\ six share one tail, which prints the blank only when the flag is set.
\ ( baddr u -- ) right-justified in the width, then the blank if wanted
: (.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 ;
: (.BODY) ( n width -- )
(W) b! !b dup push -if A inv 1 + A: 0 <# #S pop SIGN #> jump (.TAIL)
: (U.BODY) ( u width -- )
(W) b! !b 0 <# #S #> jump (.TAIL)
: (D.BODY) ( d width -- )
(W) b! !b dup push -if A DNEGATE A: <# #S pop SIGN #> jump (.TAIL)
header .R
: DOT-R ( n width -- ) 0 (W)+1 b! !b jump (.BODY)
header .
: DOT ( n -- ) -1 (W)+1 b! !b 0 jump (.BODY)
header U.R
: U-DOT-R ( u width -- ) 0 (W)+1 b! !b jump (U.BODY)
header U.
: U-DOT ( u -- ) -1 (W)+1 b! !b 0 jump (U.BODY)
header D.R
: D-DOT-R ( d width -- ) 0 (W)+1 b! !b jump (D.BODY)
header D.
: D-DOT ( d -- ) -1 (W)+1 b! !b 0 jump (D.BODY)
\ ( addr -- ) print what the cell holds
header ?
: QUESTION a! @ jump DOT
\ ( -- ) as v3: the depth between < and >, then every value on the stack,
\ the deepest first, each followed by a blank; then a new line. The stack is
\ left as it was. It reads each value with PICK, so it needs a few cells of
\ the stack free to work in.
header .S
: DOT-S
60 EMIT DEPTH 0 U-DOT-R 62 EMIT SPACE
DEPTH (W)+2 b! !b
L: (W)+2 b! @b if DONE
PICK DOT
(W)+2 b! @b -1 + !b jump L
DONE: drop jump CR
v4/tests/host_map.h
+8
View File
@@ -39,6 +39,8 @@
#define CVARS (TOP - 62) /* (C): compile.v4, 10 cells */
#define FVARS (TOP - 105) /* (F): forth.v4, 7 cells */
#define SVARS (TOP - 540 - (v4_cell)V4_DATA_DEPTH) /* (S): where PICK and ROLL set stack values aside, one cell for each cell of the stack */
#define WVARS (TOP - 99) /* (W): numout.v4, 3 cells */
#define HLD (TOP - 25) /* where the pictured number has got to */
#define QVARS (TOP - 52) /* (Q): quit.v4, 2 cells */
/* buffers (word addresses; a byte address is four times this) */
@@ -49,6 +51,8 @@
#define TIB_W (TOP - 440) /* the text input buffer: 260 cells = 1040 bytes */
#define PAD_W (TOP - 470) /* PAD: 21 cells = 84 bytes */
#define SBUF_W (TOP - 540) /* 64 cells for the tests' own strings */
#define HBUF_W (SVARS - 16) /* the hold buffer: 16 cells = 64 bytes */
#define HEND ((HBUF_W + 16) * 4)
#define WBUF (WBUF_W * 4)
#define TIB (TIB_W * 4)
#define PAD (PAD_W * 4)
@@ -107,6 +111,10 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned
v4_text_constant(tx, "(Q)", QVARS);
v4_text_constant(tx, "(F)", FVARS);
v4_text_constant(tx, "(S)", SVARS);
v4_text_constant(tx, "(W)", WVARS);
v4_text_constant(tx, "HLD", HLD);
v4_text_constant(tx, "HEND", HEND);
v4_text_constant(tx, "-HFLOOR", -(HEND - 62));
v4_text_constant(tx, "DSTACK-DEPTH", DSTACK_REG);
v4_text_constant(tx, "RSTACK-DEPTH", RSTACK_REG);
v4_node_stack_regs_attach(n, DSTACK_REG, RSTACK_REG);
v4/tests/test_host_quit.c
+61 -2
View File
@@ -167,7 +167,31 @@ static const transcript script[] = {
{ "5 6 7 1 0 MOD\nDEPTH 48 + EMIT\n", "MOD: Division by zero\n ERROR\nok> 3 ok\nok> ", 1 },
{ "5 6 7 1 1 0 */MOD\nDEPTH 48 + EMIT\n", "*/MOD: Division by zero\n ERROR\nok> 3 ok\nok> ", 1 },
{ "1 2 3 ABORT\nDEPTH 48 + EMIT\n", " ok\nok> 0 ok\nok> ", 1 },
{ "1 2 3 . . .\n", "3 2 1 ok\nok> ", 1 },
{ "-5 . 0 . 2147483647 .\n", "-5 0 2147483647 ok\nok> ", 1 },
{ "1 2 3 .S\n", "<3> 1 2 3 \n ok\nok> ", 1 },
{ ".S\n", "<0> \n ok\nok> ", 1 },
{ "1 2 3 .S . . .\n", "<3> 1 2 3 \n3 2 1 ok\nok> ", 1 },
{ "7 5 U.R 124 EMIT\n", " 7| ok\nok> ", 0 },
{ "HEX FF . DECIMAL 255 .\n", "FF 255 ok\nok> ", 1 },
{ "255 HEX . DECIMAL\n", "FF ok\nok> ", 1 },
{ "255 OCTAL . DECIMAL\n", "377 ok\nok> ", 1 },
{ "VARIABLE X 42 X ! X ?\n", "42 ok\nok> ", 1 },
{ "3 SPACES 65 EMIT 0 SPACES 66 EMIT -2 SPACES 67 EMIT\n", " ABC ok\nok> ", 1 },
{ "2 BASE ! 5 . DECIMAL\n", "UNKNOWN WORD: '5'\n ERROR\nok> ", 1 },
{ ": T 10 0 DO I . LOOP ; T\n", "0 1 2 3 4 5 6 7 8 9 ok\nok> ", 1 },
{ "DEPTH . 1 2 DEPTH . . .\n", "0 2 2 1 ok\nok> ", 1 },
/* v4's own */
{ "5 3 .R 124 EMIT -5 6 .R 124 EMIT 12345 2 .R 124 EMIT\n", " 5| -5|12345| ok\nok> ", 0 },
{ "1234 0 <# # # #S #> TYPE\n", "1234 ok\nok> ", 0 },
{ "-7 DUP 0< IF NEGATE THEN 0 <# #S ROT SIGN #> TYPE\n", "IF: compile-only\n ERROR\nok> ", 0 },
{ ": SN DUP DUP 0< IF NEGATE THEN 0 <# #S ROT SIGN #> TYPE ; -7 SN 7 SN\n", "-77 ok\nok> ", 0 },
{ "65 0 <# 42 HOLD #S 36 HOLD #> TYPE\n", "$65* ok\nok> ", 0 },
{ "2 BASE ! 101 1010 + . DECIMAL\n", "1111 ok\nok> ", 0 },
{ "5 0 D. -1 -1 D. 7 0 4 D.R 124 EMIT\n", "5 -1 7| ok\nok> ", 0 },
{ "36 BASE ! ZZ DECIMAL . 1295 36 BASE ! . DECIMAL\n", "1295 ZZ ok\nok> ", 0 },
{ ": S5 1 2 3 4 5 .S 2DROP 2DROP DROP .S ; S5\n", "<5> 1 2 3 4 5 \n<0> \n ok\nok> ", 0 },
{ "-1 -2 -3 .S\n", "<3> -1 -2 -3 \n ok\nok> ", 0 },
{ "1 2 3 QUIT\nDEPTH 48 + EMIT\n", "\nok> 3 ok\nok> ", 0 },
{ "65 EMIT DROP 66 EMIT\n67 EMIT\n", "AStack underflow\n ERROR\nok> C ok\nok> ", 0 },
{ "+\n1 +\nDUP\nOVER\n1 OVER\n", "Stack underflow\n ERROR\nok> Stack underflow\n ERROR\nok> Stack underflow\n ERROR\nok> "
@@ -222,8 +246,8 @@ int main(void)
printf("v4 host prompt tests: V4_CELL_BITS=%d, V4_NODE_WORDS=%u\n", V4_CELL_BITS, (unsigned)V4_NODE_WORDS);
{
static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4" };
CHECK(host_load(&tx, &n, files, 7), "the capsule assembles");
static const char *const files[] = { "core.v4", "input.v4", "dict.v4", "codegen.v4", "compile.v4", "quit.v4", "forth.v4", "numout.v4" };
CHECK(host_load(&tx, &n, files, 8), "the capsule assembles");
}
CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));
CHECK(v4_text_here(&tx) < DICT_W, "code stays below the dictionary space");
@@ -494,6 +518,41 @@ int main(void)
CHECK(d >= 3, "the prompt leaves room on the data stack");
}
/* ---- numbers at the ends of the range, which depend on the cell width ---- */
boot_bare();
#if V4_CELL_BITS == 32
CHECK(is(say("-1 U. -2147483648 . 2147483647 .\n"), "4294967295 -2147483648 2147483647 ok\nok> "), "the largest and smallest numbers");
CHECK(is(say("HEX -1 U. DECIMAL\n"), "FFFFFFFF ok\nok> ") && is(say("2 BASE ! -1 U. DECIMAL\n"), "11111111111111111111111111111111 ok\nok> "), "in hex and in binary");
#else
CHECK(is(say("-1 U.\n"), "18446744073709551615 ok\nok> "), "the largest number (as v3)");
CHECK(is(say("-9223372036854775808 . 9223372036854775807 .\n"), "-9223372036854775808 9223372036854775807 ok\nok> "), "the smallest and largest signed");
CHECK(is(say("HEX -1 U. DECIMAL\n"), "FFFFFFFFFFFFFFFF ok\nok> "), "in hex");
/* 64 binary digits are one more than the hold buffer's 63 (D-13): the last is dropped and the line is an error */
CHECK(is(say("2 BASE ! -1 U. DECIMAL\n"), "111111111111111111111111111111111111111111111111111111111111111 ERROR\nok> "), "in binary, 63 of its 64 digits and ERROR");
CHECK(is(say("9223372036854775807 2 BASE ! U. DECIMAL\n"), "111111111111111111111111111111111111111111111111111111111111111 ok\nok> "), "a 63-digit number prints whole");
#endif
/* .S works on the stack it is printing, so it needs some of it free */
{
char line[4 * V4_DATA_DEPTH + 16], want[8 * V4_DATA_DEPTH + 32];
unsigned k, m, most = 0;
for (k = 1; k < V4_DATA_DEPTH; k++) {
size_t at = 0, wt;
boot_bare();
for (m = 0; m < k; m++) at += (size_t)snprintf(line + at, sizeof line - at, "7 ");
snprintf(line + at, sizeof line - at, "\n");
if (strlen(line) > 80 || strcmp(say(line), " ok\nok> ") != 0) break;
wt = (size_t)snprintf(want, sizeof want, "<%u> ", k);
for (m = 0; m < k; m++) wt += (size_t)snprintf(want + wt, sizeof want - wt, "7 ");
snprintf(want + wt, sizeof want - wt, "\n ok\nok> ");
if (strcmp(say(".S\n"), want) != 0) break;
snprintf(want, sizeof want, "%u ok\nok> ", k);
CHECK(is(say("DEPTH .\n"), want), "after .S the %u values are still there", k);
most = k;
}
printf(" .S prints a stack of up to %u values; it needs %u cells free\n", most, (unsigned)V4_DATA_DEPTH - most);
CHECK(most + 8u >= V4_DATA_DEPTH, ".S works with all but eight cells of the stack in use");
}
/* ---- the fault table: five words, each a jump to its handler ---- */
{
static const char *const handler[] = { "(FAULT)", "(D-OVER)", "(D-UNDER)", "(R-OVER)", "(R-UNDER)" };