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

forth: LSHIFT/RSHIFT + 32-bit arith truncation + early binding (Hayes 174→268)
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 22:26:58 +00:00
parent 387a6e7f5d
commit 8e1466032a
7 changed files with 143 additions and 45 deletions
Download Patch File Download Diff File Expand all files Collapse all files

70
lib/forth/runtime.sx
View File

@@ -274,6 +274,17 @@
(define forth-bits-width 32)
;; Truncate a number to the Forth 32-bit signed range (two's-complement).
;; Used by arithmetic primitives so wrap-around matches ANS semantics and
;; loop idioms that rely on MSB becoming 0 after enough shifts terminate.
(define
forth-clip
(fn
(n)
(forth-from-unsigned
(forth-to-unsigned n forth-bits-width)
forth-bits-width)))
(define
forth-to-unsigned
(fn (n w) (let ((m (pow 2 w))) (mod (+ (mod n m) m) m))))
@@ -475,11 +486,17 @@
(forth-push s d)
(forth-push s a)
(forth-push s b))))
(forth-def-prim! state "+" (forth-binop (fn (a b) (+ a b))))
(forth-def-prim! state "-" (forth-binop (fn (a b) (- a b))))
(forth-def-prim! state "*" (forth-binop (fn (a b) (* a b))))
(forth-def-prim! state "/" (forth-binop forth-div))
(forth-def-prim! state "MOD" (forth-binop forth-mod))
(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 (forth-div a b)))))
(forth-def-prim!
state
"MOD"
(forth-binop (fn (a b) (forth-clip (forth-mod a b)))))
(forth-def-prim!
state
"/MOD"
@@ -489,8 +506,8 @@
((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) (- 0 a))))
(forth-def-prim! state "ABS" (forth-unop abs))
(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"
@@ -499,12 +516,15 @@
state
"MAX"
(forth-binop (fn (a b) (if (> a b) a b))))
(forth-def-prim! state "1+" (forth-unop (fn (a) (+ a 1))))
(forth-def-prim! state "1-" (forth-unop (fn (a) (- a 1))))
(forth-def-prim! state "2+" (forth-unop (fn (a) (+ a 2))))
(forth-def-prim! state "2-" (forth-unop (fn (a) (- a 2))))
(forth-def-prim! state "2*" (forth-unop (fn (a) (* a 2))))
(forth-def-prim! state "2/" (forth-unop (fn (a) (floor (/ 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/"
(forth-unop (fn (a) (forth-clip (floor (/ a 2))))))
(forth-def-prim! state "=" (forth-cmp (fn (a b) (= a b))))
(forth-def-prim! state "<>" (forth-cmp (fn (a b) (not (= a b)))))
(forth-def-prim! state "<" (forth-cmp (fn (a b) (< a b))))
@@ -519,6 +539,30 @@
(forth-def-prim! state "OR" (forth-binop forth-bit-or))
(forth-def-prim! state "XOR" (forth-binop forth-bit-xor))
(forth-def-prim! state "INVERT" (forth-unop forth-bit-invert))
(forth-def-prim!
state
"LSHIFT"
(fn
(s)
(let
((u (forth-pop s)) (x (forth-pop s)))
(let
((ux (forth-to-unsigned x forth-bits-width)))
(let
((res (mod (* ux (pow 2 u)) (pow 2 forth-bits-width))))
(forth-push s (forth-from-unsigned res forth-bits-width)))))))
(forth-def-prim!
state
"RSHIFT"
(fn
(s)
(let
((u (forth-pop s)) (x (forth-pop s)))
(let
((ux (forth-to-unsigned x forth-bits-width)))
(let
((res (floor (/ ux (pow 2 u)))))
(forth-push s (forth-from-unsigned res forth-bits-width)))))))
(forth-def-prim!
state
"."