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

forth: mixed/double-cell math (S>D M* UM* UM/MOD FM/MOD SM/REM */ */MOD); Hayes 342→446 (69%)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Details

Browse Source
This commit is contained in:
giles
2026-04-24 23:25:43 +00:00
parent 3ab01b271d
commit b6810e90ab
5 changed files with 202 additions and 11 deletions
Download Patch File Download Diff File Expand all files Collapse all files

150
lib/forth/runtime.sx
View File

@@ -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))