diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 34adf066..5a66f05f 100644 --- a/lib/forth/compiler.sx +++ b/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 - ((back-pc (forth-cpop s))) + ((extras (forth-drain-cstack-dicts s (list)))) (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))))))) + ((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! 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 - (fn - (ss) - (let - ((start (forth-pop ss))) - (let - ((limit (forth-pop ss))) - (forth-rpush ss limit) - (forth-rpush ss start)))))) + ((op (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))) - (forth-double-push-u s (nth result 0)) + ((result (forth-numparse-loop s addr u (forth-from-unsigned d-lo 32) (forth-from-unsigned d-hi 32) b))) + (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)) - (u (forth-pop s)) - (addr (forth-pop s))) + ((fam (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)) - (u (forth-pop s)) - (addr (forth-pop s))) + ((fam (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 - (s) - (let ((fid (forth-pop s))) (forth-push s 0)))) + (fn (s) (let ((fid (forth-pop s))) (forth-push s 0)))) (forth-def-prim! state "READ-FILE" (fn (s) (let - ((fid (forth-pop s)) - (u1 (forth-pop s)) - (addr (forth-pop s))) + ((fid (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)) - (u (forth-pop s)) - (addr (forth-pop s))) + ((fid (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)) - (hi (forth-pop s)) - (lo (forth-pop s))) + ((fid (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 - (dict-set! entry "pos" lo) - (forth-push s 0))))))) + (begin (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! - state - "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 "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)) - (a (forth-pop s)) - (b (forth-pop s))) + ((addr (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 diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index fd9308e2..c2e16ec0 100644 --- a/lib/forth/runtime.sx +++ b/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 - (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)) diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 6b605a51..3119bf69 100644 --- a/lib/forth/scoreboard.json +++ b/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, - "fail": 14, - "error": 6, - "percent": 96, + "pass": 632, + "fail": 6, + "error": 0, + "percent": 99, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index fc8d8485..48ca20c1 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 638 | | total | 638 | -| pass | 618 | -| fail | 14 | -| error | 6 | -| percent | 96% | +| pass | 632 | +| fail | 6 | +| error | 0 | +| 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 diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 96fb0ebc..adffb2a0 100644 --- a/plans/forth-on-sx.md +++ b/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