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

fix(v4.0.0): .R U.R and D.R print no trailing space

Browse Source 
FORTH-79's reference .R right-justifies the number in its field and
prints nothing after it; v3 printed a space.  . U. and D. still print
their one space.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-04 08:47:29 -04:00
co-authored by Claude Opus 5.5
parent b137678691
commit 01b5bbb23f
3 changed files with 96 additions and 65 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/tests/test_numout.c
+49 -35
View File
@@ -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");
}
v4/tests/test_printing.c
+31 -17
View File
@@ -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. */