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

feat(v4.0.0): division by zero is guarded (D-15); division words in the capsule

Browse Source 
Ruled 2026-10-04: guarded, an error shown, back to the prompt.

- capsule/forth.v4: / MOD /MOD */ */MOD M/MOD, M* and S>D join the
  vocabulary.  Each dividing word tests its divisor first; zero prints
  v3's message ("/: Division by zero"), ends an open definition, prints
  ERROR and returns to the prompt from however deep.
- SM/REM here has UM/MOD written into it and keeps its signs in memory,
  and */MOD has M* written in, so that division can be used inside words
  that other words call: / from four words deep, */MOD from three.
- forth.v4 now loads after quit.v4, which the guard leaves through.
- tests: v3 transcripts for each message; /MOD, /, MOD and */MOD against
  C on every pair of edge values.

Co-Authored-By: Claude Opus 5.5 <noreply@anthropic.com>
This commit is contained in:
rajames
2026-10-04 12:23:30 -04:00
co-authored by Claude Opus 5.5
parent b3d2d56d11
commit 361dcd1148
5 changed files with 156 additions and 7 deletions
Download Patch File Download Diff File Expand all files Collapse all files
v4/capsule/forth.v4
+94 -2
View File
@@ -3,8 +3,10 @@
\
\ Each is the definition DECOMPOSITION.md gives (sections 4, 5.1 - 5.5, 5.18).
\ A word flagged inline is copied into a definition in place of a call; the
\ ones that touch the return stack are compile-only as well. Rests on core.v4
\ and compile.v4's loader constants.
\ ones that touch the return stack are compile-only as well. Rests on core.v4,
\ compile.v4's loader constants, and quit.v4, which the division words leave
\ through when the divisor is zero. (F) is three cells of scratch for
\ this file.
\ ---- stack ----
header DUP inline : DUP dup ;
@@ -49,6 +51,96 @@ header 2- inline : 2- -2 + ;
header 2* inline : TWO* 2* ;
header 2/ inline : TWO/ 2/ ;
\ ---- division (sections 4 and 5.6) ----
\ Division by zero is guarded (D-15): each word tests its divisor before it
\ does anything else, and a zero divisor prints v3's message --
\ /: Division by zero
\ -- and ends the line with ERROR, from however deep, as an address fault
\ does. Nothing is left for the word's caller: it is not returned to.
\ ( name -- ) name is up to four characters of the word's name (EMIT4)
: (DIV0)
(EMIT4) $6944203A (EMIT4) $69736976 (EMIT4) $62206E6F (EMIT4) \ ": Division b"
$657A2079 (EMIT4) $6F72 (EMIT4) CR \ "y zero"
2 jump (REPL)
\ ( d n -- rem quot ) truncating toward zero: the quotient has the sign of
\ d xor n, the remainder the sign of d. This is section 4's SM/REM with its
\ UM/MOD -- restoring division, one step a bit, the divisor in A -- written
\ into it, and the two signs kept in (F) where section 4 has them on the
\ return stack. A word that divides is then four return entries deep, not
\ eight, so division can be used inside words that other words call (D-2).
\ The answer is the same. Exact when the quotient fits a cell; its callers
\ have seen to it that n is not zero.
: SM/REM
over over xor (F) a! ! \ the quotient's sign, in its top bit
over (F)+1 a! ! \ the remainder's
-if L0 inv 1 + L0: a! \ A: |n|
-if L1 DNEGATE L1: \ |d|
N-1 FOR
-if S0
2* over -if S1 drop 1 + jump S2
S1: drop S2: push 2* pop
jump SUB
S0:
2* over -if S3 drop 1 + jump S4
S3: drop S4: push 2* pop
dup a xor -if S5
drop -if NOSUB jump SUB
S5: drop dup inv a + inv -if S6
drop jump NOSUB
S6: push drop pop jump SETBIT
SUB: inv a + inv
SETBIT: push 1 + pop
NOSUB:
NEXT
over push push drop pop pop \ urem uquot
(F)+1 a! @ -if L2 drop push inv 1 + pop jump L3 L2: drop L3:
(F) a! @ -if L4 drop inv 1 + ; L4: drop ;
header S>D
: S>D ( n -- d ) dup -if P drop -1 ; P: drop 0 ;
\ The product's sign waits in (F), not on the return stack, for the same
\ reason as SM/REM's.
header M*
: M* ( n1 n2 -- d )
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(F) a! @ -if P drop jump DNEGATE P: drop ;
\ ( n1 n2 n3 -- rem quot ) n1 * n2 as a double, divided by n3, which is
\ not zero. M* is written in, and n3 waits in (F)+2, so that the multiply
\ is as few return entries down as it can be.
: (*/MOD)
(F)+2 a! !
over over xor (F) a! ! -if A inv 1 + A: push -if B inv 1 + B: pop UM*
(F) a! @ -if P drop DNEGATE jump Q P: drop Q:
(F)+2 a! @ jump SM/REM
header /MOD
: /MOD ( n1 n2 -- rem quot )
if Z push S>D pop jump SM/REM
Z: $444F4D2F jump (DIV0)
header /
: / ( n1 n2 -- quot )
if Z push S>D pop SM/REM NIP ;
Z: $2F jump (DIV0)
header MOD
: MOD ( n1 n2 -- rem )
if Z push S>D pop SM/REM drop ;
Z: $444F4D jump (DIV0)
header */MOD
: */MOD ( n1 n2 n3 -- rem quot )
if Z jump (*/MOD)
Z: $4F4D2F2A (EMIT4) $44 jump (DIV0)
header */
: */ ( n1 n2 n3 -- quot )
if Z (*/MOD) NIP ;
Z: $2F2A jump (DIV0)
header M/MOD
: M/MOD ( d n -- rem quot )
if Z jump SM/REM
Z: $4F4D2F4D (EMIT4) $44 jump (DIV0)
\ ---- logic and comparison ----
header AND inline : AND and ;
header XOR inline : XOR xor ;
v4/tests/host_map.h
+2
View File
@@ -35,6 +35,7 @@
#define DVARS (TOP - 32) /* (D): dict.v4, 5 cells */
#define CGVARS (TOP - 48) /* (CG): codegen.v4, 14 cells */
#define CVARS (TOP - 62) /* (C): compile.v4, 10 cells */
#define FVARS (TOP - 27) /* (F): forth.v4, 3 cells */
#define QVARS (TOP - 52) /* (Q): quit.v4, 2 cells */
/* buffers (word addresses; a byte address is four times this) */
@@ -101,6 +102,7 @@ static int host_load(v4_text *tx, v4_node *n, const char *const *files, unsigned
v4_text_constant(tx, "(C)", CVARS);
v4_text_constant(tx, "(CFP)", CFP);
v4_text_constant(tx, "(Q)", QVARS);
v4_text_constant(tx, "(F)", FVARS);
v4_text_constant(tx, "CFBASE", CFS_W);
v4_text_constant(tx, "CFEND", CFS_W + CFS_CELLS);
for (i = 0; i < count; i++) {
v4/tests/test_host_compile.c
+44 -2
View File
@@ -151,6 +151,22 @@ static const programme prog[] = {
{ ": DEEP 1 IF 2 IF 3 IF 4 ELSE 5 THEN ELSE 6 THEN ELSE 7 THEN ;", "DEEP", 1, { 4 }, 1 },
{ ": TM 2* 2* 1- 2/ ;", "5 TM", 1, { 9 }, 1 },
{ ": NEG NEGATE ;", "7 NEG -7 NEG", 2, { -7, 7 }, 1 },
{ "", "7 2 / -7 2 / 7 -2 / -7 -2 /", 4, { 3, -3, -3, 3 }, 1 },
{ "", "7 2 MOD -7 2 MOD 7 -2 MOD -7 -2 MOD", 4, { 1, -1, 1, -1 }, 1 },
{ "", "7 2 /MOD -7 2 /MOD", 4, { 1, 3, -1, -3 }, 1 },
{ "", "7 -2 /MOD -7 -2 /MOD", 4, { 1, -3, -1, 3 }, 1 },
{ "", "100 7 3 */ -100 7 3 */", 2, { 233, -233 }, 1 },
{ "", "100 7 3 */MOD -100 7 3 */MOD", 4, { 1, 233, -1, -233 }, 1 },
{ "", "3 4 M* -3 4 M*", 4, { 12, 0, -12, -1 }, 1 },
{ "", "-5 S>D 5 S>D", 4, { -5, -1, 5, 0 }, 1 },
{ "", "0 5 / 0 5 MOD 1 1 /", 3, { 0, 0, 1 }, 1 },
{ ": D1 / ; : D2 D1 ; : D3 D2 ; : D4 D3 ;", "20 4 D4", 1, { 5 }, 1 },
{ ": E1 */MOD ; : E2 E1 ; : E3 E2 ;", "-100 7 3 E3", 2, { -1, -233 }, 1 },
{ ": E4 */ ; : E5 E4 ;", "-100 7 3 E5", 1, { -233 }, 1 },
{ ": E6 M* ; : E7 E6 ; : E8 E7 ;", "-3 4 E8", 2, { -12, -1 }, 1 },
{ ": AV 0 SWAP 0 DO I + LOOP 10 / ;", "10 AV", 1, { 4 }, 1 },
{ "", "1000000 1000000 M* 1000 M/MOD", 2, { 0, 1000000000 }, 0 },
{ "", "-7 S>D 2 M/MOD", 2, { -1, -3 }, 0 },
};
#define NPROG (sizeof prog / sizeof prog[0])
@@ -179,8 +195,8 @@ int main(void)
printf("v4 host compiler 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", "forth.v4" };
CHECK(host_load(&tx, &n, files, 6), "the capsule assembles");
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");
}
/* two in-line words of the test's own, to exercise the in-liner: one with
* two literals in one instruction word, one with a nop in it */
@@ -351,6 +367,32 @@ int main(void)
}
}
/* ---- /MOD, / and MOD against C, which also truncates toward zero ---- */
{
static const v4_cell v[] = { 0, 1, -1, 2, -2, 3, -7, 10, 12345, -12345, 65536, -65537, (v4_cell)V4_MSB, (v4_cell)(V4_MSB - 1u),
(v4_cell)(V4_MSB + 1u), (v4_cell)((v4_ucell)~(v4_ucell)0 / 3u) };
unsigned j, nv = (unsigned)(sizeof v / sizeof v[0]);
char line[128];
new_session();
for (i = 0; i < nv; i++)
for (j = 0; j < nv; j++) {
v4_cell q, r;
if (v[j] == 0) continue;
if (v[i] == (v4_cell)V4_MSB && v[j] == -1) continue; /* the quotient does not fit a cell */
q = v[i] / v[j]; r = v[i] % v[j];
snprintf(line, sizeof line, "%lld %lld /MOD", (long long)v[i], (long long)v[j]);
CHECK(interpret(line) && !err() && pop() == q && pop() == r && clean(), "%s", line);
snprintf(line, sizeof line, "%lld %lld / %lld %lld MOD", (long long)v[i], (long long)v[j], (long long)v[i], (long long)v[j]);
CHECK(interpret(line) && !err() && pop() == r && pop() == q && clean(), "%s", line);
/* quot * n3 + rem = n1 * n2, wherever the product fits a cell so that C can check it */
if (v[i] > -40000 && v[i] < 40000) {
v4_cell k = 177, prod = (v4_cell)((v4_ucell)v[i] * (v4_ucell)k);
snprintf(line, sizeof line, "%lld %lld %lld */MOD", (long long)v[i], (long long)k, (long long)v[j]);
CHECK(interpret(line) && !err() && pop() == prod / v[j] && pop() == prod % v[j] && clean(), "%s", line);
}
}
}
/* ---- how many values a line may have on the stack ---- */
{
char line[96];
v4/tests/test_host_quit.c
+13 -1
View File
@@ -21,6 +21,7 @@
* - control words that do not match give ERROR alone; v3 names the word.
* - QUERY takes 80 characters (FORTH-79); v3's line is 255.
* - an address outside memory says so (D-14); v3 gives ERROR alone.
* - M/MOD by zero says so (D-15); v3 gives ERROR alone.
*/
#include "v4/text.h"
#include "v4/testcode.h"
@@ -146,7 +147,18 @@ static const transcript script[] = {
{ ": P .\" two spaces \" 124 EMIT ; P\n", " two spaces | ok\nok> ", 1 },
{ "65 EMIT CR 66 EMIT\n", "A\nB ok\nok> ", 1 },
{ ": E .\" \" 65 EMIT ; E\n", "A ok\nok> ", 1 },
{ "65 EMIT 1 0 / 66 EMIT\n67 EMIT\n", "A/: Division by zero\n ERROR\nok> C ok\nok> ", 1 },
{ "1 0 MOD\n", "MOD: Division by zero\n ERROR\nok> ", 1 },
{ "1 0 /MOD\n", "/MOD: Division by zero\n ERROR\nok> ", 1 },
{ "1 1 0 */\n", "*/: Division by zero\n ERROR\nok> ", 1 },
{ "1 1 0 */MOD\n", "*/MOD: Division by zero\n ERROR\nok> ", 1 },
{ ": T 1 0 / 65 EMIT ; T 66 EMIT\n67 EMIT\n", "/: Division by zero\n ERROR\nok> C ok\nok> ", 1 },
{ "0 0 /\n7 2 / 48 + EMIT\n", "/: Division by zero\n ERROR\nok> 3 ok\nok> ", 1 },
/* v4's own */
{ "1 0 0 M/MOD\n", "M/MOD: Division by zero\n ERROR\nok> ", 0 },
{ ": Z0 0 / ; : Z1 65 EMIT 9 Z0 66 EMIT ; Z1\n: Z2 1 IF [ 5 0 MOD ]\nZ2\n",
"A/: Division by zero\n ERROR\nok> MOD: Division by zero\n ERROR\nok> UNKNOWN WORD: 'Z2'\n ERROR\nok> ", 0 },
{ ": Z3 5 0 DO 9 3 I - / DROP LOOP 65 EMIT ; Z3\n66 EMIT\n", "/: Division by zero\n ERROR\nok> B ok\nok> ", 0 },
{ ": BAD 1 NOSUCH 2 ;\nBAD\n65 EMIT\n", "UNKNOWN WORD: 'NOSUCH'\n ERROR\nok> UNKNOWN WORD: 'BAD'\n ERROR\nok> A ok\nok> ", 0 },
{ "1 ABORT\" now\" 65 EMIT\n66 EMIT\n", "now\n ok\nok> B ok\nok> ", 0 },
{ ": B1 IF LOOP ;\n65 EMIT\n", " ERROR\nok> A ok\nok> ", 0 },
@@ -172,7 +184,7 @@ 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", "forth.v4", "quit.v4" };
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");
}
CHECK(v4_text_finish(&tx), "everything is defined: %s", v4_text_error(&tx));