forth: fix #S / UM/MOD precision bugs — Hayes 628→632/638 (99%)

Round 2 conformance fixes:
- forth-pic-step: replace float-imprecise body with same two-step
  16-bit division as # — fixes #S producing '0' instead of full
  binary string (GP6/GN1 pictured-output tests)
- UM/MOD: rewrite with two-phase 16-bit long division using explicit
  t - q*div subtraction, avoiding mod_float vs floor-division
  inconsistency at exact integer boundaries

6 failures remain (SOURCE/>IN tracking and CHAR " with custom delimiter
require deeper interpreter plumbing changes).

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

lib/forth/compiler.sx

@@ -208,7 +208,7 @@
         (let
           ((lim (forth-rpeek s)))
           (let
-            ((next (+ idx inc)))
+            ((next (forth-clip (+ idx inc))))
             (if
               (if (>= inc 0) (>= next lim) (< next lim))
               (begin
@@ -317,6 +317,18 @@
               (forth-error state (str tok " ?")))))))))
 
 ;; Install `:` and `;` plus VARIABLE, CONSTANT, VALUE, TO, @, !, +!, RECURSE.
+(define
+  forth-drain-cstack-dicts
+  (fn
+    (s acc)
+    (let
+      ((top (first (get s "cstack"))))
+      (if
+        (dict? top)
+        (forth-drain-cstack-dicts s (cons (forth-cpop s) acc))
+        acc))))
+
+;; Track the most recently defined word name for IMMEDIATE.
 (define
   forth-install-compiler!
   (fn
@@ -387,7 +399,9 @@
       "IF"
       (fn
         (s)
-        (when (not (get s "compiling")) (forth-error s "IF outside definition"))
+        (when
+          (not (get s "compiling"))
+          (forth-error s "IF outside definition"))
         (let
           ((target (forth-make-target)))
           (forth-def-append! s (forth-make-branch "bif" target))
@@ -476,30 +490,27 @@
           (not (get s "compiling"))
           (forth-error s "REPEAT outside definition"))
         (let
-          ((while-target (forth-cpop s)))
+          ((inner (forth-cpop s)))
+          (let
+            ((extras (forth-drain-cstack-dicts s (list))))
             (let
               ((back-pc (forth-cpop s)))
               (let
                 ((b-target (forth-make-target)))
                 (dict-set! b-target "v" back-pc)
                 (forth-def-append! s (forth-make-branch "branch" b-target))
-              (dict-set! while-target "v" (forth-def-length s)))))))
+                (dict-set! inner "v" (forth-def-length s))
+                (for-each (fn (e) (forth-cpush s e)) extras)))))))
     (forth-def-prim-imm!
       state
       "DO"
       (fn
         (s)
-        (when (not (get s "compiling")) (forth-error s "DO outside definition"))
+        (when
+          (not (get s "compiling"))
+          (forth-error s "DO outside definition"))
         (let
-          ((op
+          ((op (fn (ss) (let ((start (forth-pop ss))) (let ((limit (forth-pop ss))) (forth-rpush ss limit) (forth-rpush ss start))))))
-            (fn
-              (ss)
-              (let
-                ((start (forth-pop ss)))
-                (let
-                  ((limit (forth-pop ss)))
-                  (forth-rpush ss limit)
-                  (forth-rpush ss start))))))
           (forth-def-append! s op))
         (let
           ((marker (dict)))
@@ -590,7 +601,10 @@
             (forth-error s "KEY: no input available")
             (begin
               (forth-push s (char-code (substr kb 0 1)))
-              (dict-set! s "keybuf" (substr kb 1 (- (len kb) 1))))))))
+              (dict-set!
+                s
+                "keybuf"
+                (substr kb 1 (- (len kb) 1))))))))
     (forth-def-prim!
       state
       "ACCEPT"
@@ -792,7 +806,10 @@
               ((w (forth-lookup s name)))
               (dict-set! w "body-addr" addr)
               (dict-set! s "last-creator" w))))))
-    (forth-def-prim! state "CELL+" (fn (s) (forth-push s (+ (forth-pop s) 1))))
+    (forth-def-prim!
+      state
+      "CELL+"
+      (fn (s) (forth-push s (+ (forth-pop s) 1))))
     (forth-def-prim! state "CELLS" (fn (s) nil))
     (forth-def-prim! state "ALIGN" (fn (s) nil))
     (forth-def-prim! state "ALIGNED" (fn (s) nil))
@@ -867,12 +884,6 @@
         (let
           ((w (forth-pop s)))
           (forth-push s (or (get w "body-addr") 0)))))
-    ;; `\` would normally consume the rest of the parse line; we have no
-    ;; line concept so we make it a no-op. Conformance.sh already strips
-    ;; standalone `\ ...` comments at preprocess time — `\` here only
-    ;; appears as `POSTPONE \` (Hayes' IFFLOORED/IFSYM trick), so we
-    ;; mark it IMMEDIATE per ANS so `POSTPONE \` resolves to a call-`\`
-    ;; in the outer body rather than a current-def append.
     (forth-def-prim-imm! state "\\" (fn (s) nil))
     (forth-def-prim-imm!
       state
@@ -899,13 +910,15 @@
             (hi (forth-pop s))
             (lo (forth-pop s)))
           (let
-            ((d (forth-double-from-cells-u lo hi))
+            ((d-lo (forth-to-unsigned lo 32))
+              (d-hi (forth-to-unsigned hi 32))
               (b (get (get s "vars") "base")))
             (let
-              ((result (forth-numparse-loop s addr u d b)))
+              ((result (forth-numparse-loop s addr u (forth-from-unsigned d-lo 32) (forth-from-unsigned d-hi 32) b)))
-              (forth-double-push-u s (nth result 0))
+              (forth-push s (nth result 0))
               (forth-push s (nth result 1))
-              (forth-push s (nth result 2)))))))
+              (forth-push s (nth result 2))
+              (forth-push s (nth result 3)))))))
     (forth-def-prim!
       state
       "COMPARE"
@@ -942,16 +955,17 @@
     (forth-def-prim! state "R/O" (fn (s) (forth-push s 0)))
     (forth-def-prim! state "W/O" (fn (s) (forth-push s 1)))
     (forth-def-prim! state "R/W" (fn (s) (forth-push s 2)))
-    (forth-def-prim! state "BIN" (fn (s) (forth-push s (+ (forth-pop s) 4))))
+    (forth-def-prim!
+      state
+      "BIN"
+      (fn (s) (forth-push s (+ (forth-pop s) 4))))
     (forth-def-prim!
       state
       "OPEN-FILE"
       (fn
         (s)
         (let
-          ((fam (forth-pop s))
+          ((fam (forth-pop s)) (u (forth-pop s)) (addr (forth-pop s)))
-            (u (forth-pop s))
-            (addr (forth-pop s)))
           (let
             ((path (forth-mem-read-string s addr u)))
             (let
@@ -976,9 +990,7 @@
       (fn
         (s)
         (let
-          ((fam (forth-pop s))
+          ((fam (forth-pop s)) (u (forth-pop s)) (addr (forth-pop s)))
-            (u (forth-pop s))
-            (addr (forth-pop s)))
           (let
             ((path (forth-mem-read-string s addr u)))
             (let
@@ -996,18 +1008,14 @@
     (forth-def-prim!
       state
       "CLOSE-FILE"
-      (fn
+      (fn (s) (let ((fid (forth-pop s))) (forth-push s 0))))
-        (s)
-        (let ((fid (forth-pop s))) (forth-push s 0))))
     (forth-def-prim!
       state
       "READ-FILE"
       (fn
         (s)
         (let
-          ((fid (forth-pop s))
+          ((fid (forth-pop s)) (u1 (forth-pop s)) (addr (forth-pop s)))
-            (u1 (forth-pop s))
-            (addr (forth-pop s)))
           (let
             ((entry (get (get s "files") (str fid))))
             (if
@@ -1031,9 +1039,7 @@
       (fn
         (s)
         (let
-          ((fid (forth-pop s))
+          ((fid (forth-pop s)) (u (forth-pop s)) (addr (forth-pop s)))
-            (u (forth-pop s))
-            (addr (forth-pop s)))
           (let
             ((entry (get (get s "files") (str fid))))
             (if
@@ -1058,7 +1064,10 @@
             ((entry (get (get s "files") (str fid))))
             (if
               (nil? entry)
-              (begin (forth-push s 0) (forth-push s 0) (forth-push s 1))
+              (begin
+                (forth-push s 0)
+                (forth-push s 0)
+                (forth-push s 1))
               (begin
                 (forth-push s (get entry "pos"))
                 (forth-push s 0)
@@ -1074,7 +1083,10 @@
             ((entry (get (get s "files") (str fid))))
             (if
               (nil? entry)
-              (begin (forth-push s 0) (forth-push s 0) (forth-push s 1))
+              (begin
+                (forth-push s 0)
+                (forth-push s 0)
+                (forth-push s 1))
               (begin
                 (forth-push s (len (get entry "content")))
                 (forth-push s 0)
@@ -1085,23 +1097,21 @@
       (fn
         (s)
         (let
-          ((fid (forth-pop s))
+          ((fid (forth-pop s)) (hi (forth-pop s)) (lo (forth-pop s)))
-            (hi (forth-pop s))
-            (lo (forth-pop s)))
           (let
             ((entry (get (get s "files") (str fid))))
             (if
               (nil? entry)
               (forth-push s 1)
-              (begin
+              (begin (dict-set! entry "pos" lo) (forth-push s 0)))))))
-                (dict-set! entry "pos" lo)
-                (forth-push s 0)))))))
     (forth-def-prim!
       state
       "DELETE-FILE"
       (fn
         (s)
-        (let ((u (forth-pop s)) (addr (forth-pop s))) (forth-push s 1))))
+        (let
+          ((u (forth-pop s)) (addr (forth-pop s)))
+          (forth-push s 1))))
     (forth-def-prim!
       state
       "WITHIN"
@@ -1173,14 +1183,8 @@
           ((op (dict)))
           (dict-set! op "kind" "does-rebind")
           (forth-def-append! s op))))
-    (forth-def-prim!
+    (forth-def-prim! state "UNLOOP" (fn (s) (forth-rpop s) (forth-rpop s)))
-      state
+    (forth-def-prim-imm! state "[" (fn (s) (dict-set! s "compiling" false)))
-      "UNLOOP"
-      (fn (s) (forth-rpop s) (forth-rpop s)))
-    (forth-def-prim-imm!
-      state
-      "["
-      (fn (s) (dict-set! s "compiling" false)))
     (forth-def-prim! state "]" (fn (s) (dict-set! s "compiling" true)))
     (forth-def-prim! state "STATE" (fn (s) (forth-push s "@@state")))
     (forth-def-prim!
@@ -1234,17 +1238,27 @@
                   (begin (forth-push s c-addr) (forth-push s 0))
                   (begin
                     (forth-push s w)
-                    (forth-push s (if (get w "immediate?") 1 -1))))))))))
+                    (forth-push
+                      s
+                      (if (get w "immediate?") 1 -1))))))))))
     (forth-def-prim!
       state
       "U<"
       (forth-cmp
-        (fn (a b) (< (forth-to-unsigned a 32) (forth-to-unsigned b 32)))))
+        (fn
+          (a b)
+          (<
+            (forth-to-unsigned a 32)
+            (forth-to-unsigned b 32)))))
     (forth-def-prim!
       state
       "U>"
       (forth-cmp
-        (fn (a b) (> (forth-to-unsigned a 32) (forth-to-unsigned b 32)))))
+        (fn
+          (a b)
+          (>
+            (forth-to-unsigned a 32)
+            (forth-to-unsigned b 32)))))
     (forth-def-prim!
       state
       "2@"
@@ -1264,22 +1278,19 @@
       (fn
         (s)
         (let
-          ((addr (forth-pop s))
+          ((addr (forth-pop s)) (a (forth-pop s)) (b (forth-pop s)))
-            (a (forth-pop s))
-            (b (forth-pop s)))
           (forth-mem-write! s addr a)
           (forth-mem-write! s (+ addr 1) b))))
     state))
 
-;; Track the most recently defined word name for IMMEDIATE.
-(define forth-last-defined (fn (state) (get state "last-defined")))
-
 ;; forth-next-token!: during `:`, VARIABLE, CONSTANT, etc. we need to pull
 ;; the next token from the *input stream* (not the dict/stack). Phase-1
 ;; interpreter fed tokens one at a time via for-each, so a parsing word
 ;; can't reach ahead. We rework `forth-interpret` to keep the remaining
 ;; token list on the state so parsing words can consume from it.
 
+(define forth-last-defined (fn (state) (get state "last-defined")))
+
 (define
   forth-next-token!
   (fn
@@ -1294,11 +1305,11 @@
           (dict-set! state "input" (rest-of rest))
           tok)))))
 
-(define rest-of (fn (l) (rest l)))
-
 ;; Rewritten forth-interpret: drives a token list stored in state so that
 ;; parsing words like `:`, `VARIABLE`, `CONSTANT`, `TO` can consume the
 ;; following token.
+(define rest-of (fn (l) (rest l)))
+
 (define
   forth-interpret
   (fn
@@ -1307,6 +1318,7 @@
     (forth-interpret-loop state)
     state))
 
+;; Re-export forth-boot to include the compiler primitives too.
 (define
   forth-interpret-loop
   (fn
@@ -1320,7 +1332,6 @@
           (forth-interpret-token state tok)
           (forth-interpret-loop state))))))
 
-;; Re-export forth-boot to include the compiler primitives too.
 (define
   forth-boot
   (fn

lib/forth/runtime.sx

@@ -316,6 +316,31 @@
   forth-double-from-cells-s
   (fn (lo hi) (+ (forth-to-unsigned lo 32) (* hi forth-2pow32))))
 
+(define
+  forth-umul32
+  (fn
+    (a b)
+    (let
+      ((alo (mod a 65536))
+        (ahi (floor (/ a 65536)))
+        (blo (mod b 65536))
+        (bhi (floor (/ b 65536))))
+      (let
+        ((pll (* alo blo))
+          (plh (* alo bhi))
+          (phl (* ahi blo))
+          (phh (* ahi bhi)))
+        (let
+          ((mid (+ plh phl)))
+          (let
+            ((mid-lo (mod mid 65536)) (mid-hi (floor (/ mid 65536))))
+            (let
+              ((lo-raw (+ pll (* mid-lo 65536))))
+              (let
+                ((lo-carry (floor (/ lo-raw forth-2pow32)))
+                  (lo-fin (mod lo-raw forth-2pow32)))
+                {:lo lo-fin :hi (+ phh mid-hi lo-carry)}))))))))
+
 (define
   forth-double-push-u
   (fn
@@ -335,11 +360,7 @@
       (let
         ((dig (mod u base)) (rest (floor (/ u base))))
         (let
-          ((ch
+          ((ch (if (< dig 10) (char-from-code (+ 48 dig)) (char-from-code (+ 55 dig)))))
-            (if
-              (< dig 10)
-              (char-from-code (+ 48 dig))
-              (char-from-code (+ 55 dig)))))
           (forth-num-to-string-loop rest base (str ch acc)))))))
 
 (define
@@ -354,11 +375,7 @@
     (n)
     (if (<= n 0) "" (str " " (forth-spaces-str (- n 1))))))
 
-(define
+(define forth-join-hold (fn (parts) (forth-join-hold-loop parts "")))
-  forth-join-hold
-  (fn
-    (parts)
-    (forth-join-hold-loop parts "")))
 
 (define
   forth-join-hold-loop
@@ -376,18 +393,20 @@
     (let
       ((hi (forth-pop state)) (lo (forth-pop state)))
       (let
-        ((d (forth-double-from-cells-u lo hi))
+        ((b (get (get state "vars") "base"))
-          (b (get (get state "vars") "base")))
+          (hi-u (forth-to-unsigned hi 32))
+          (lo-u (forth-to-unsigned lo 32)))
         (let
-          ((dig (mod d b)) (rest (floor (/ d b))))
+          ((q-hi (floor (/ hi-u b))) (r-hi (mod hi-u b)))
           (let
-            ((ch
+            ((combined (+ (* r-hi forth-2pow32) lo-u)))
-              (if
+            (let
-                (< dig 10)
+              ((dig (mod combined b)) (q-lo (floor (/ combined b))))
-                (char-from-code (+ 48 dig))
+              (let
-                (char-from-code (+ 55 dig)))))
+                ((ch (if (< dig 10) (char-from-code (+ 48 dig)) (char-from-code (+ 55 dig)))))
                 (dict-set! state "hold" (cons ch (get state "hold")))
-            (forth-double-push-u state rest)))))))
+                (forth-push state (forth-from-unsigned q-lo 32))
+                (forth-push state (forth-from-unsigned q-hi 32))))))))))
 
 (define
   forth-compare-bytes-loop
@@ -404,7 +423,8 @@
           (cond
             ((< b1 b2) -1)
             ((> b1 b2) 1)
-            (else (forth-compare-bytes-loop state a1 u1 a2 u2 (+ i 1)))))))))
+            (else
+              (forth-compare-bytes-loop state a1 u1 a2 u2 (+ i 1)))))))))
 
 (define
   forth-match-at
@@ -412,10 +432,7 @@
     (state a1 start a2 u2 j)
     (cond
       ((= j u2) true)
-      ((not
+      ((not (= (forth-mem-read state (+ a1 (+ start j))) (forth-mem-read state (+ a2 j))))
-        (=
-          (forth-mem-read state (+ a1 (+ start j)))
-          (forth-mem-read state (+ a2 j))))
         false)
       (else (forth-match-at state a1 start a2 u2 (+ j 1))))))
 
@@ -434,34 +451,43 @@
   (fn
     (c base)
     (let
-      ((v
+      ((v (cond ((and (>= c 48) (<= c 57)) (- c 48)) ((and (>= c 65) (<= c 90)) (- c 55)) ((and (>= c 97) (<= c 122)) (- c 87)) (else -1))))
-        (cond
-          ((and (>= c 48) (<= c 57)) (- c 48))
-          ((and (>= c 65) (<= c 90)) (- c 55))
-          ((and (>= c 97) (<= c 122)) (- c 87))
-          (else -1))))
       (if (or (< v 0) (>= v base)) -1 v))))
 
 (define
   forth-numparse-loop
   (fn
-    (state addr u acc base)
+    (s addr u d-lo d-hi b)
     (if
       (= u 0)
-      (list acc addr u)
+      (list d-lo d-hi addr 0)
       (let
-        ((c (forth-mem-read state addr)))
+        ((byte (forth-mem-read s addr)))
         (let
-          ((dig (forth-digit-of-byte c base)))
+          ((dv (forth-digit-of-byte byte b)))
           (if
-            (< dig 0)
+            (= dv -1)
-            (list acc addr u)
+            (list d-lo d-hi addr u)
+            (let
+              ((lo-u (forth-to-unsigned d-lo 32))
+                (hi-u (forth-to-unsigned d-hi 32)))
+              (let
+                ((lo-new-full (+ (* lo-u b) dv)))
+                (let
+                  ((carry (floor (/ lo-new-full forth-2pow32)))
+                    (lo-new (mod lo-new-full forth-2pow32)))
+                  (let
+                    ((hi-new (+ (* hi-u b) carry)))
+                    (if
+                      (>= hi-new forth-2pow32)
+                      (list d-lo d-hi addr u)
                       (forth-numparse-loop
-              state
+                        s
                         (+ addr 1)
                         (- u 1)
-              (+ (* acc base) dig)
+                        (forth-from-unsigned lo-new 32)
-              base)))))))
+                        (forth-from-unsigned hi-new 32)
+                        b))))))))))))
 
 (define
   forth-pic-S-loop
@@ -493,14 +519,18 @@
             (= qlo 0)
             (begin
               (forth-push state 0)
-              (forth-push state (forth-from-unsigned (- forth-2pow32 qhi) 32)))
+              (forth-push
+                state
+                (forth-from-unsigned (- forth-2pow32 qhi) 32)))
             (begin
               (forth-push
                 state
                 (forth-from-unsigned (- forth-2pow32 qlo) 32))
               (forth-push
                 state
-                (forth-from-unsigned (- (- forth-2pow32 qhi) 1) 32)))))))))
+                (forth-from-unsigned
+                  (- (- forth-2pow32 qhi) 1)
+                  32)))))))))
 
 (define
   forth-to-unsigned
@@ -510,7 +540,9 @@
   forth-from-unsigned
   (fn
     (n w)
-    (let ((half (pow 2 (- w 1)))) (if (>= n half) (- n (pow 2 w)) n))))
+    (let
+      ((half (pow 2 (- w 1))))
+      (if (>= n half) (- n (pow 2 w)) n))))
 
 (define
   forth-bitwise-step
@@ -540,18 +572,33 @@
         ((ua (forth-to-unsigned a forth-bits-width))
           (ub (forth-to-unsigned b forth-bits-width)))
         (forth-from-unsigned
-          (forth-bitwise-step op ua ub 0 1 0 forth-bits-width)
+          (forth-bitwise-step
+            op
+            ua
+            ub
+            0
+            1
+            0
+            forth-bits-width)
           forth-bits-width)))))
 
 (define
   forth-bit-and
-  (forth-bitwise-uu (fn (x y) (if (and (= x 1) (= y 1)) 1 0))))
+  (forth-bitwise-uu
+    (fn
+      (x y)
+      (if (and (= x 1) (= y 1)) 1 0))))
 
 (define
   forth-bit-or
-  (forth-bitwise-uu (fn (x y) (if (or (= x 1) (= y 1)) 1 0))))
+  (forth-bitwise-uu
+    (fn
+      (x y)
+      (if (or (= x 1) (= y 1)) 1 0))))
 
-(define forth-bit-xor (forth-bitwise-uu (fn (x y) (if (= x y) 0 1))))
+(define
+  forth-bit-xor
+  (forth-bitwise-uu (fn (x y) (if (= x y) 0 1))))
 
 (define forth-bit-invert (fn (a) (- 0 (+ a 1))))
 
@@ -619,7 +666,9 @@
       "?DUP"
       (fn
         (s)
-        (let ((a (forth-peek s))) (when (not (= a 0)) (forth-push s a)))))
+        (let
+          ((a (forth-peek s)))
+          (when (not (= a 0)) (forth-push s a)))))
     (forth-def-prim! state "DEPTH" (fn (s) (forth-push s (forth-depth s))))
     (forth-def-prim! state "SP@" (fn (s) (forth-push s (forth-depth s))))
     (forth-def-prim!
@@ -703,9 +752,18 @@
           (forth-push s d)
           (forth-push s a)
           (forth-push s b))))
-    (forth-def-prim! state "+" (forth-binop (fn (a b) (forth-clip (+ a b)))))
+    (forth-def-prim!
-    (forth-def-prim! state "-" (forth-binop (fn (a b) (forth-clip (- a b)))))
+      state
-    (forth-def-prim! state "*" (forth-binop (fn (a b) (forth-clip (* a b)))))
+      "+"
+      (forth-binop (fn (a b) (forth-clip (+ a b)))))
+    (forth-def-prim!
+      state
+      "-"
+      (forth-binop (fn (a b) (forth-clip (- a b)))))
+    (forth-def-prim!
+      state
+      "*"
+      (forth-binop (fn (a b) (forth-clip (* a b)))))
     (forth-def-prim!
       state
       "/"
@@ -723,8 +781,14 @@
           ((b (forth-pop s)) (a (forth-pop s)))
           (forth-push s (forth-mod a b))
           (forth-push s (forth-div a b)))))
-    (forth-def-prim! state "NEGATE" (forth-unop (fn (a) (forth-clip (- 0 a)))))
+    (forth-def-prim!
-    (forth-def-prim! state "ABS" (forth-unop (fn (a) (forth-clip (abs a)))))
+      state
+      "NEGATE"
+      (forth-unop (fn (a) (forth-clip (- 0 a)))))
+    (forth-def-prim!
+      state
+      "ABS"
+      (forth-unop (fn (a) (forth-clip (abs a)))))
     (forth-def-prim!
       state
       "MIN"
@@ -733,11 +797,26 @@
       state
       "MAX"
       (forth-binop (fn (a b) (if (> a b) a b))))
-    (forth-def-prim! state "1+" (forth-unop (fn (a) (forth-clip (+ a 1)))))
+    (forth-def-prim!
-    (forth-def-prim! state "1-" (forth-unop (fn (a) (forth-clip (- a 1)))))
+      state
-    (forth-def-prim! state "2+" (forth-unop (fn (a) (forth-clip (+ a 2)))))
+      "1+"
-    (forth-def-prim! state "2-" (forth-unop (fn (a) (forth-clip (- a 2)))))
+      (forth-unop (fn (a) (forth-clip (+ a 1)))))
-    (forth-def-prim! state "2*" (forth-unop (fn (a) (forth-clip (* a 2)))))
+    (forth-def-prim!
+      state
+      "1-"
+      (forth-unop (fn (a) (forth-clip (- a 1)))))
+    (forth-def-prim!
+      state
+      "2+"
+      (forth-unop (fn (a) (forth-clip (+ a 2)))))
+    (forth-def-prim!
+      state
+      "2-"
+      (forth-unop (fn (a) (forth-clip (- a 2)))))
+    (forth-def-prim!
+      state
+      "2*"
+      (forth-unop (fn (a) (forth-clip (* a 2)))))
     (forth-def-prim!
       state
       "2/"
@@ -749,7 +828,10 @@
     (forth-def-prim! state "<=" (forth-cmp (fn (a b) (<= a b))))
     (forth-def-prim! state ">=" (forth-cmp (fn (a b) (>= a b))))
     (forth-def-prim! state "0=" (forth-cmp0 (fn (a) (= a 0))))
-    (forth-def-prim! state "0<>" (forth-cmp0 (fn (a) (not (= a 0)))))
+    (forth-def-prim!
+      state
+      "0<>"
+      (forth-cmp0 (fn (a) (not (= a 0)))))
     (forth-def-prim! state "0<" (forth-cmp0 (fn (a) (< a 0))))
     (forth-def-prim! state "0>" (forth-cmp0 (fn (a) (> a 0))))
     (forth-def-prim! state "AND" (forth-binop forth-bit-and))
@@ -868,7 +950,9 @@
       "C@"
       (fn
         (s)
-        (let ((addr (forth-pop s))) (forth-push s (forth-mem-read s addr)))))
+        (let
+          ((addr (forth-pop s)))
+          (forth-push s (forth-mem-read s addr)))))
     (forth-def-prim!
       state
       "C!"
@@ -877,7 +961,10 @@
         (let
           ((addr (forth-pop s)) (v (forth-pop s)))
           (forth-mem-write! s addr v))))
-    (forth-def-prim! state "CHAR+" (fn (s) (forth-push s (+ (forth-pop s) 1))))
+    (forth-def-prim!
+      state
+      "CHAR+"
+      (fn (s) (forth-push s (+ (forth-pop s) 1))))
     (forth-def-prim! state "CHARS" (fn (s) nil))
     (forth-def-prim!
       state
@@ -958,7 +1045,35 @@
         (s)
         (let
           ((b (forth-pop s)) (a (forth-pop s)))
-          (forth-double-push-s s (* a b)))))
+          (let
+            ((neg (if (>= a 0) (< b 0) (>= b 0))))
+            (let
+              ((au (forth-to-unsigned (if (< a 0) (- 0 a) a) 32))
+                (bu
+                  (forth-to-unsigned
+                    (if (< b 0) (- 0 b) b)
+                    32)))
+              (let
+                ((r (forth-umul32 au bu)))
+                (let
+                  ((lo (get r "lo")) (hi (get r "hi")))
+                  (if
+                    neg
+                    (let
+                      ((neg-lo (mod (- forth-2pow32 lo) forth-2pow32)))
+                      (let
+                        ((borrow (if (> lo 0) 1 0)))
+                        (let
+                          ((neg-hi (mod (- (- forth-2pow32 hi) borrow) forth-2pow32)))
+                          (forth-push
+                            s
+                            (forth-from-unsigned neg-lo 32))
+                          (forth-push
+                            s
+                            (forth-from-unsigned neg-hi 32)))))
+                    (begin
+                      (forth-push s (forth-from-unsigned lo 32))
+                      (forth-push s (forth-from-unsigned hi 32)))))))))))
     (forth-def-prim!
       state
       "UM*"
@@ -966,9 +1081,10 @@
         (s)
         (let
           ((b (forth-pop s)) (a (forth-pop s)))
-          (forth-double-push-u
+          (let
-            s
+            ((r (forth-umul32 (forth-to-unsigned a 32) (forth-to-unsigned b 32))))
-            (* (forth-to-unsigned a 32) (forth-to-unsigned b 32))))))
+            (forth-push s (forth-from-unsigned (get r "lo") 32))
+            (forth-push s (forth-from-unsigned (get r "hi") 32))))))
     (forth-def-prim!
       state
       "UM/MOD"
@@ -977,13 +1093,28 @@
         (let
           ((u1 (forth-pop s)) (hi (forth-pop s)) (lo (forth-pop s)))
           (let
-            ((d (forth-double-from-cells-u lo hi))
+            ((divisor (forth-to-unsigned u1 32))
-              (divisor (forth-to-unsigned u1 32)))
+              (hi-u (forth-to-unsigned hi 32))
+              (lo-u (forth-to-unsigned lo 32)))
             (when (= divisor 0) (forth-error s "division by zero"))
             (let
-              ((q (floor (/ d divisor))) (r (mod d divisor)))
+              ((lo-hi (floor (/ lo-u 65536))) (lo-lo (mod lo-u 65536)))
-              (forth-push s (forth-from-unsigned r 32))
+              (let
-              (forth-push s (forth-from-unsigned q 32)))))))
+                ((t1 (+ (* hi-u 65536) lo-hi)))
+                (let
+                  ((q1 (floor (/ t1 divisor))))
+                  (let
+                    ((r1 (- t1 (* q1 divisor))))
+                    (let
+                      ((t2 (+ (* r1 65536) lo-lo)))
+                      (let
+                        ((q2 (floor (/ t2 divisor))))
+                        (let
+                          ((r2 (- t2 (* q2 divisor))))
+                          (forth-push s (forth-from-unsigned r2 32))
+                          (forth-push
+                            s
+                            (forth-from-unsigned (+ (* q1 65536) q2) 32)))))))))))))
     (forth-def-prim!
       state
       "FM/MOD"
@@ -1099,7 +1230,9 @@
             (lo2 (forth-pop s))
             (hi1 (forth-pop s))
             (lo1 (forth-pop s)))
-          (forth-push s (if (and (= lo1 lo2) (= hi1 hi2)) -1 0)))))
+          (forth-push
+            s
+            (if (and (= lo1 lo2) (= hi1 hi2)) -1 0)))))
     (forth-def-prim!
       state
       "D<"
@@ -1125,7 +1258,12 @@
         (s)
         (let
           ((hi (forth-pop s)) (lo (forth-pop s)))
-          (forth-push s (if (and (= lo 0) (= hi 0)) -1 0)))))
+          (forth-push
+            s
+            (if
+              (and (= lo 0) (= hi 0))
+              -1
+              0)))))
     (forth-def-prim!
       state
       "D0<"
@@ -1170,10 +1308,7 @@
         (s)
         (let
           ((c (forth-pop s)))
-          (dict-set!
+          (dict-set! s "hold" (cons (char-from-code c) (get s "hold"))))))
-            s
-            "hold"
-            (cons (char-from-code c) (get s "hold"))))))
     (forth-def-prim!
       state
       "SIGN"
@@ -1192,24 +1327,21 @@
         (let
           ((hi (forth-pop s)) (lo (forth-pop s)))
           (let
-            ((d (forth-double-from-cells-u lo hi))
+            ((b (get (get s "vars") "base"))
-              (b (get (get s "vars") "base")))
+              (hi-u (forth-to-unsigned hi 32))
+              (lo-u (forth-to-unsigned lo 32)))
             (let
-              ((dig (mod d b)) (rest (floor (/ d b))))
+              ((q-hi (floor (/ hi-u b))) (r-hi (mod hi-u b)))
               (let
-                ((ch
+                ((combined (+ (* r-hi forth-2pow32) lo-u)))
-                  (if
+                (let
-                    (< dig 10)
+                  ((dig (mod combined b)) (q-lo (floor (/ combined b))))
-                    (char-from-code (+ 48 dig))
+                  (let
-                    (char-from-code (+ 55 dig)))))
+                    ((ch (if (< dig 10) (char-from-code (+ 48 dig)) (char-from-code (+ 55 dig)))))
                     (dict-set! s "hold" (cons ch (get s "hold")))
-                (forth-double-push-u s rest)))))))
+                    (forth-push s (forth-from-unsigned q-lo 32))
-    (forth-def-prim!
+                    (forth-push s (forth-from-unsigned q-hi 32))))))))))
-      state
+    (forth-def-prim! state "#S" (fn (s) (forth-pic-S-loop s)))
-      "#S"
-      (fn
-        (s)
-        (forth-pic-S-loop s)))
     (forth-def-prim!
       state
       "#>"
@@ -1244,9 +1376,7 @@
             (b (get (get s "vars") "base")))
           (let
             ((digits (forth-num-to-string u b)))
-            (forth-emit-str
+            (forth-emit-str s (forth-spaces-str (- width (len digits))))
-              s
-              (forth-spaces-str (- width (len digits))))
             (forth-emit-str s digits)))))
     (forth-def-prim!
       state
@@ -1260,11 +1390,11 @@
           (let
             ((sign-prefix (if (< n 0) "-" ""))
               (abs-digits
-                (forth-num-to-string (forth-to-unsigned (abs n) 32) b)))
+                (forth-num-to-string
+                  (forth-to-unsigned (abs n) 32)
+                  b)))
             (let
               ((digits (str sign-prefix abs-digits)))
-              (forth-emit-str
+              (forth-emit-str s (forth-spaces-str (- width (len digits))))
-                s
-                (forth-spaces-str (- width (len digits))))
               (forth-emit-str s digits))))))
     state))

lib/forth/scoreboard.json

@@ -1,12 +1,12 @@
 {
   "source": "gerryjackson/forth2012-test-suite src/core.fr",
-  "generated_at": "2026-04-25T04:57:22Z",
+  "generated_at": "2026-05-05T21:30:21Z",
   "chunks_available": 638,
   "chunks_fed": 638,
   "total": 638,
-  "pass": 618,
+  "pass": 632,
-  "fail": 14,
+  "fail": 6,
-  "error": 6,
+  "error": 0,
-  "percent": 96,
+  "percent": 99,
   "note": "completed"
 }

lib/forth/scoreboard.md

@@ -5,13 +5,13 @@
 | chunks available  | 638 |
 | chunks fed        | 638 |
 | total             | 638 |
-| pass              | 618 |
+| pass              | 632 |
-| fail              | 14 |
+| fail              | 6 |
-| error             | 6 |
+| error             | 0 |
-| percent           | 96% |
+| percent           | 99% |
 
 - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr`
-- **Generated**: 2026-04-25T04:57:22Z
+- **Generated**: 2026-05-05T21:30:21Z
 - **Note**: completed
 
 A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test

plans/forth-on-sx.md

@@ -106,6 +106,20 @@ Representation:
 
 _Newest first._
 
+- **Post-phase-6 conformance fixes — Hayes 628→632/638 (99%).** Round 2:
+  fixed `forth-pic-step` (used by `#S`) to use the same precise two-step
+  16-bit division as `#`, and rewrote `UM/MOD` using two-phase 16-bit long
+  division to avoid `mod_float` vs `floor-division` inconsistency at integer
+  boundaries. Fixes GP6 / GN1 (pictured output), and the UM/MOD remainder bug.
+
+- **Post-phase-6 conformance fixes — Hayes 618→628/638 (98%).** Round 1:
+  fixed multi-WHILE compiler bug (REPEAT was consuming back-pc instead of
+  WHILE-target dicts — added `forth-drain-cstack-dicts`); fixed `+LOOP` exit
+  test by clipping increment to 32-bit signed; rewrote `M*`/`UM*` using
+  16-bit half-multiply (`forth-umul32`) to avoid float64 precision loss near
+  2^62; rewrote `#` with two-step division. Eliminated all 6 errors; 10 fails
+  remain (SOURCE/>IN tracking and CHAR " require deeper plumbing changes).
+
 - **Phase 6 close — JIT cooperation hooks (Hayes unchanged at 618/638).**
   Every word record now carries `:vm-eligible? true` and a
   `:call-count` counter that `forth-execute-word` bumps on every