coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

forth: fix #S / UM/MOD precision bugs — Hayes 628→632/638 (99%)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 46s
Details

Browse Source 
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>
This commit is contained in:
giles
2026-05-05 21:31:03 +00:00
parent 32a8ed8ef0
commit aad178aa0f
5 changed files with 342 additions and 187 deletions
Download Patch File Download Diff File Expand all files Collapse all files

334
lib/forth/runtime.sx
View File

@@ -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
(if
(< dig 10)
(char-from-code (+ 48 dig))
(char-from-code (+ 55 dig)))))
((ch (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
forth-join-hold
(fn
(parts)
(forth-join-hold-loop parts "")))
(define 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
(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)))))))
((combined (+ (* r-hi forth-2pow32) lo-u)))
(let
((dig (mod combined b)) (q-lo (floor (/ combined b))))
(let
((ch (if (< dig 10) (char-from-code (+ 48 dig)) (char-from-code (+ 55 dig)))))
(dict-set! state "hold" (cons ch (get state "hold")))
(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
(=
(forth-mem-read state (+ a1 (+ start j)))
(forth-mem-read state (+ a2 j))))
((not (= (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
(cond
((and (>= c 48) (<= c 57)) (- c 48))
((and (>= c 65) (<= c 90)) (- c 55))
((and (>= c 97) (<= c 122)) (- c 87))
(else -1))))
((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))))
(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)
(list acc addr u)
(forth-numparse-loop
state
(+ addr 1)
(- u 1)
(+ (* acc base) dig)
base)))))))
(= dv -1)
(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
s
(+ addr 1)
(- u 1)
(forth-from-unsigned lo-new 32)
(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! 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
"+"
(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! state "ABS" (forth-unop (fn (a) (forth-clip (abs a)))))
(forth-def-prim!
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! 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
"1+"
(forth-unop (fn (a) (forth-clip (+ a 1)))))
(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
s
(* (forth-to-unsigned a 32) (forth-to-unsigned b 32))))))
(let
((r (forth-umul32 (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)))
(forth-push s (forth-from-unsigned r 32))
(forth-push s (forth-from-unsigned q 32)))))))
((lo-hi (floor (/ lo-u 65536))) (lo-lo (mod lo-u 65536)))
(let
((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!
s
"hold"
(cons (char-from-code c) (get s "hold"))))))
(dict-set! 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
(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-def-prim!
state
"#S"
(fn
(s)
(forth-pic-S-loop s)))
((combined (+ (* r-hi forth-2pow32) lo-u)))
(let
((dig (mod combined b)) (q-lo (floor (/ combined b))))
(let
((ch (if (< dig 10) (char-from-code (+ 48 dig)) (char-from-code (+ 55 dig)))))
(dict-set! s "hold" (cons ch (get s "hold")))
(forth-push s (forth-from-unsigned q-lo 32))
(forth-push s (forth-from-unsigned q-hi 32))))))))))
(forth-def-prim! state "#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
s
(forth-spaces-str (- width (len digits))))
(forth-emit-str 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
s
(forth-spaces-str (- width (len digits))))
(forth-emit-str s (forth-spaces-str (- width (len digits))))
(forth-emit-str s digits))))))
state))