forth: mixed/double-cell math (S>D M* UM* UM/MOD FM/MOD SM/REM */ */MOD); Hayes 342→446 (69%)

2026-04-24 23:25:43 +00:00
parent 3ab01b271d
commit b6810e90ab
5 changed files with 202 additions and 11 deletions
--- a/lib/forth/runtime.sx
+++ b/lib/forth/runtime.sx
@@ -285,6 +285,56 @@
      (forth-to-unsigned n forth-bits-width)
      forth-bits-width)))

+;; Double-cell helpers. Single = 32-bit signed, double = 64-bit signed
+;; represented on the data stack as (lo, hi) where hi is on top.
+;; Reassembly converts the low cell as unsigned and the high cell as
+;; signed (signed) or as unsigned (unsigned), then combines.
+(define forth-2pow32 (pow 2 32))
+(define forth-2pow64 (pow 2 64))
+
+(define
+  forth-double-from-cells-u
+  (fn
+    (lo hi)
+    (+ (forth-to-unsigned lo 32) (* (forth-to-unsigned hi 32) forth-2pow32))))
+
+(define
+  forth-double-from-cells-s
+  (fn (lo hi) (+ (forth-to-unsigned lo 32) (* hi forth-2pow32))))
+
+(define
+  forth-double-push-u
+  (fn
+    (state d)
+    (let
+      ((lo (mod d forth-2pow32)) (hi (floor (/ d forth-2pow32))))
+      (forth-push state (forth-from-unsigned lo 32))
+      (forth-push state (forth-from-unsigned hi 32)))))
+
+(define
+  forth-double-push-s
+  (fn
+    (state d)
+    (if
+      (>= d 0)
+      (forth-double-push-u state d)
+      (let
+        ((q (- 0 d)))
+        (let
+          ((qlo (mod q forth-2pow32)) (qhi (floor (/ q forth-2pow32))))
+          (if
+            (= qlo 0)
+            (begin
+              (forth-push state 0)
+              (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)))))))))
+
 (define
  forth-to-unsigned
  (fn (n w) (let ((m (pow 2 w))) (mod (+ (mod n m) m) m))))
@@ -728,4 +778,104 @@
            (or (<= dst src) (>= dst (+ src u)))
            (forth-cmove-loop s src dst u 0)
            (forth-cmove-loop-desc s src dst u (- u 1))))))
+    (forth-def-prim!
+      state
+      "S>D"
+      (fn
+        (s)
+        (let
+          ((n (forth-pop s)))
+          (forth-push s n)
+          (forth-push s (if (< n 0) -1 0)))))
+    (forth-def-prim! state "D>S" (fn (s) (forth-pop s)))
+    (forth-def-prim!
+      state
+      "M*"
+      (fn
+        (s)
+        (let
+          ((b (forth-pop s)) (a (forth-pop s)))
+          (forth-double-push-s s (* a b)))))
+    (forth-def-prim!
+      state
+      "UM*"
+      (fn
+        (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))))))
+    (forth-def-prim!
+      state
+      "UM/MOD"
+      (fn
+        (s)
+        (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)))
+            (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)))))))
+    (forth-def-prim!
+      state
+      "FM/MOD"
+      (fn
+        (s)
+        (let
+          ((n (forth-pop s)) (hi (forth-pop s)) (lo (forth-pop s)))
+          (let
+            ((d (forth-double-from-cells-s lo hi)))
+            (when (= n 0) (forth-error s "division by zero"))
+            (let
+              ((q (floor (/ d n))))
+              (let
+                ((r (- d (* q n))))
+                (forth-push s (forth-clip r))
+                (forth-push s (forth-clip q))))))))
+    (forth-def-prim!
+      state
+      "SM/REM"
+      (fn
+        (s)
+        (let
+          ((n (forth-pop s)) (hi (forth-pop s)) (lo (forth-pop s)))
+          (let
+            ((d (forth-double-from-cells-s lo hi)))
+            (when (= n 0) (forth-error s "division by zero"))
+            (let
+              ((q (forth-trunc (/ d n))))
+              (let
+                ((r (- d (* q n))))
+                (forth-push s (forth-clip r))
+                (forth-push s (forth-clip q))))))))
+    (forth-def-prim!
+      state
+      "*/"
+      (fn
+        (s)
+        (let
+          ((n3 (forth-pop s)) (n2 (forth-pop s)) (n1 (forth-pop s)))
+          (when (= n3 0) (forth-error s "division by zero"))
+          (forth-push s (forth-clip (forth-trunc (/ (* n1 n2) n3)))))))
+    (forth-def-prim!
+      state
+      "*/MOD"
+      (fn
+        (s)
+        (let
+          ((n3 (forth-pop s)) (n2 (forth-pop s)) (n1 (forth-pop s)))
+          (when (= n3 0) (forth-error s "division by zero"))
+          (let
+            ((d (* n1 n2)))
+            (let
+              ((q (forth-trunc (/ d n3))))
+              (let
+                ((r (- d (* q n3))))
+                (forth-push s (forth-clip r))
+                (forth-push s (forth-clip q))))))))
    state))
--- 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-24T22:54:53Z",
+  "generated_at": "2026-04-24T23:25:04Z",
  "chunks_available": 638,
  "chunks_fed": 638,
  "total": 638,
-  "pass": 342,
-  "fail": 4,
-  "error": 292,
-  "percent": 53,
+  "pass": 446,
+  "fail": 7,
+  "error": 185,
+  "percent": 69,
  "note": "completed"
 }
--- a/lib/forth/scoreboard.md
+++ b/lib/forth/scoreboard.md
@@ -5,13 +5,13 @@
 | chunks available  | 638 |
 | chunks fed        | 638 |
 | total             | 638 |
-| pass              | 342 |
-| fail              | 4 |
-| error             | 292 |
-| percent           | 53% |
+| pass              | 446 |
+| fail              | 7 |
+| error             | 185 |
+| percent           | 69% |

 - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr`
- **Generated**: 2026-04-24T22:54:53Z
+- **Generated**: 2026-04-24T23:25:04Z
 - **Note**: completed

 A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test
--- a/lib/forth/tests/test-phase5.sx
+++ b/lib/forth/tests/test-phase5.sx
@@ -82,6 +82,36 @@
      "CREATE X 0 , 0 , 11 22 X 2! X 2@"
      (list 11 22))))

+(define
+  forth-p5-mixed-tests
+  (fn
+    ()
+    (forth-p5-check-stack "S>D positive" "5 S>D" (list 5 0))
+    (forth-p5-check-stack "S>D negative" "-5 S>D" (list -5 -1))
+    (forth-p5-check-stack "S>D zero" "0 S>D" (list 0 0))
+    (forth-p5-check-top "D>S keeps low" "5 0 D>S" 5)
+    (forth-p5-check-stack "M* small positive" "3 4 M*" (list 12 0))
+    (forth-p5-check-stack "M* negative" "-3 4 M*" (list -12 -1))
+    (forth-p5-check-stack
+      "M* negative * negative"
+      "-3 -4 M*"
+      (list 12 0))
+    (forth-p5-check-stack "UM* small" "3 4 UM*" (list 12 0))
+    (forth-p5-check-stack
+      "UM/MOD: 100 0 / 5"
+      "100 0 5 UM/MOD"
+      (list 0 20))
+    (forth-p5-check-stack
+      "FM/MOD: -7 / 2 floored"
+      "-7 -1 2 FM/MOD"
+      (list 1 -4))
+    (forth-p5-check-stack
+      "SM/REM: -7 / 2 truncated"
+      "-7 -1 2 SM/REM"
+      (list -1 -3))
+    (forth-p5-check-top "*/ truncated" "7 11 13 */" 5)
+    (forth-p5-check-stack "*/MOD" "7 11 13 */MOD" (list 12 5))))
+
 (define
  forth-p5-run-all
  (fn
@@ -92,6 +122,7 @@
    (forth-p5-create-tests)
    (forth-p5-unsigned-tests)
    (forth-p5-2bang-tests)
+    (forth-p5-mixed-tests)
    (dict
      "passed"
      forth-p5-passed
--- a/plans/forth-on-sx.md
+++ b/plans/forth-on-sx.md
@@ -87,7 +87,7 @@ Representation:
 ### Phase 5 — Core Extension + optional word sets
 - [x] Memory: `CREATE`, `HERE`, `ALLOT`, `,`, `C,`, `CELL+`, `CELLS`, `ALIGN`, `ALIGNED`, `2!`, `2@`
 - [x] Unsigned compare: `U<`, `U>`
- [ ] Mixed/double-cell math: `S>D`, `M*`, `UM*`, `UM/MOD`, `FM/MOD`, `SM/REM`, `*/`, `*/MOD`
+- [x] Mixed/double-cell math: `S>D`, `M*`, `UM*`, `UM/MOD`, `FM/MOD`, `SM/REM`, `*/`, `*/MOD`
 - [ ] Double-cell ops: `D+`, `D-`, `D=`, `D<`, `D0=`, `2DUP`, `2DROP`, `2OVER`, `2SWAP` (already), plus `D>S`, `DABS`, `DNEGATE`
 - [ ] Number formatting: `<#`, `#`, `#S`, `#>`, `HOLD`, `SIGN`, `.R`, `U.`, `U.R`
 - [ ] Parsing/dictionary: `WORD`, `FIND`, `EXECUTE`, `'`, `[']`, `LITERAL`, `POSTPONE`, `>BODY`, `DOES>`
@@ -106,6 +106,16 @@ Representation:

 _Newest first._

+- **Phase 5 — mixed/double-cell math; Hayes 342→446 (69%).** Added
+  `S>D`, `D>S`, `M*`, `UM*`, `UM/MOD`, `FM/MOD`, `SM/REM`, `*/`, `*/MOD`.
+  Doubles ride on the stack as `(lo, hi)` with `hi` on top.
+  Helpers `forth-double-push-{u,s}` / `forth-double-from-cells-{u,s}`
+  split & rebuild via 32-bit unsigned mod/div, picking the negative
+  path explicitly so we don't form `2^64 + small` (float precision
+  drops at ULP=2^12 once you cross 2^64). `M*`/`UM*` use bignum
+  multiply then split; `*/`/`*/MOD` use bignum intermediate and
+  truncated division. Hayes: 446 pass / 185 error / 7 fail.
+
 - **Phase 5 — memory primitives + unsigned compare; Hayes 268→342 (53%).**
  Added `CREATE`/`HERE`/`ALLOT`/`,`/`C,`/`CELL+`/`CELLS`/`ALIGN`/`ALIGNED`/
  `2!`/`2@`/`U<`/`U>`. Generalised `@`/`!`/`+!` to dispatch on address