From b2939c192262f4f57d4c55aa12c78708029084d3 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 17:03:41 +0000 Subject: [PATCH 01/25] forth: IF/ELSE/THEN + PC-driven body runner (+18) --- lib/forth/compiler.sx | 82 +++++++++++++++++++++- lib/forth/runtime.sx | 21 +++++- lib/forth/tests/test-phase3.sx | 123 +++++++++++++++++++++++++++++++++ plans/forth-on-sx.md | 15 +++- 4 files changed, 238 insertions(+), 3 deletions(-) create mode 100644 lib/forth/tests/test-phase3.sx diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 43e8edd0..c58dc44e 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -52,9 +52,53 @@ ((def (get state "current-def"))) (dict-set! def "body" (concat (get def "body") (list op)))))) +(define + forth-def-length + (fn (state) (len (get (get state "current-def") "body")))) + +(define + forth-make-branch + (fn + (kind target) + (let ((b (dict))) (dict-set! b "kind" kind) (dict-set! b "target" target) b))) + +(define + forth-make-target + (fn () (let ((t (dict))) (dict-set! t "v" 0) t))) + (define forth-make-colon-body - (fn (ops) (fn (s) (for-each (fn (op) (op s)) ops)))) + (fn + (ops) + (let + ((n (len ops))) + (fn + (s) + (let ((pc (dict))) (dict-set! pc "v" 0) (forth-run-body s ops pc n)))))) + +(define + forth-step-op + (fn + (s op pc) + (cond + ((and (dict? op) (= (get op "kind") "bif")) + (if + (= (forth-pop s) 0) + (dict-set! pc "v" (get (get op "target") "v")) + (dict-set! pc "v" (+ (get pc "v") 1)))) + ((and (dict? op) (= (get op "kind") "branch")) + (dict-set! pc "v" (get (get op "target") "v"))) + (else (begin (op s) (dict-set! pc "v" (+ (get pc "v") 1))))))) + +(define + forth-run-body + (fn + (s ops pc n) + (when + (< (get pc "v") n) + (begin + (forth-step-op s (nth ops (get pc "v")) pc) + (forth-run-body s ops pc n))))) ;; Override forth-interpret-token to branch on compile mode. (define @@ -139,6 +183,42 @@ (let ((name (get (get s "current-def") "name"))) (forth-compile-call s name)))) + (forth-def-prim-imm! + state + "IF" + (fn + (s) + (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)) + (forth-cpush s target)))) + (forth-def-prim-imm! + state + "ELSE" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "ELSE outside definition")) + (let + ((new-target (forth-make-target))) + (forth-def-append! s (forth-make-branch "branch" new-target)) + (let + ((if-target (forth-cpop s))) + (dict-set! if-target "v" (forth-def-length s))) + (forth-cpush s new-target)))) + (forth-def-prim-imm! + state + "THEN" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "THEN outside definition")) + (let + ((target (forth-cpop s))) + (dict-set! target "v" (forth-def-length s))))) (forth-def-prim! state "VARIABLE" diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 54078477..430bda2e 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -20,8 +20,27 @@ (dict-set! s "current-def" nil) (dict-set! s "base" 10) (dict-set! s "vars" (dict)) + (dict-set! s "cstack" (list)) s))) +(define + forth-cpush + (fn (state v) (dict-set! state "cstack" (cons v (get state "cstack"))))) + +(define + forth-cpop + (fn + (state) + (let + ((cs (get state "cstack"))) + (if + (= (len cs) 0) + (forth-error state "control stack underflow") + (let + ((top (first cs))) + (dict-set! state "cstack" (rest cs)) + top))))) + (define forth-error (fn (state msg) (dict-set! state "error" msg) (raise msg))) @@ -416,7 +435,7 @@ (forth-def-prim! state "EMIT" - (fn (s) (forth-emit-str s (code-char (forth-pop s))))) + (fn (s) (forth-emit-str s (char-from-code (forth-pop s))))) (forth-def-prim! state "CR" (fn (s) (forth-emit-str s "\n"))) (forth-def-prim! state "SPACE" (fn (s) (forth-emit-str s " "))) (forth-def-prim! diff --git a/lib/forth/tests/test-phase3.sx b/lib/forth/tests/test-phase3.sx new file mode 100644 index 00000000..604d0b42 --- /dev/null +++ b/lib/forth/tests/test-phase3.sx @@ -0,0 +1,123 @@ +;; Phase 3 — control flow (IF/ELSE/THEN, BEGIN/UNTIL/WHILE/REPEAT/AGAIN, +;; DO/LOOP, return stack). Grows as each control construct lands. + +(define forth-p3-passed 0) +(define forth-p3-failed 0) +(define forth-p3-failures (list)) + +(define + forth-p3-assert + (fn + (label expected actual) + (if + (= expected actual) + (set! forth-p3-passed (+ forth-p3-passed 1)) + (begin + (set! forth-p3-failed (+ forth-p3-failed 1)) + (set! + forth-p3-failures + (concat + forth-p3-failures + (list + (str label ": expected " (str expected) " got " (str actual))))))))) + +(define + forth-p3-check-stack + (fn + (label src expected) + (let ((r (forth-run src))) (forth-p3-assert label expected (nth r 2))))) + +(define + forth-p3-if-tests + (fn + () + (forth-p3-check-stack + "IF taken (-1)" + ": Q -1 IF 10 THEN ; Q" + (list 10)) + (forth-p3-check-stack + "IF not taken (0)" + ": Q 0 IF 10 THEN ; Q" + (list)) + (forth-p3-check-stack + "IF with non-zero truthy" + ": Q 42 IF 10 THEN ; Q" + (list 10)) + (forth-p3-check-stack + "IF ELSE — true branch" + ": Q -1 IF 10 ELSE 20 THEN ; Q" + (list 10)) + (forth-p3-check-stack + "IF ELSE — false branch" + ": Q 0 IF 10 ELSE 20 THEN ; Q" + (list 20)) + (forth-p3-check-stack + "IF consumes flag" + ": Q IF 1 ELSE 2 THEN ; 0 Q" + (list 2)) + (forth-p3-check-stack + "absolute value via IF" + ": ABS2 DUP 0 < IF NEGATE THEN ; -7 ABS2" + (list 7)) + (forth-p3-check-stack + "abs leaves positive alone" + ": ABS2 DUP 0 < IF NEGATE THEN ; 7 ABS2" + (list 7)) + (forth-p3-check-stack + "sign: negative" + ": SIGN DUP 0 < IF DROP -1 ELSE DROP 1 THEN ; -3 SIGN" + (list -1)) + (forth-p3-check-stack + "sign: positive" + ": SIGN DUP 0 < IF DROP -1 ELSE DROP 1 THEN ; 3 SIGN" + (list 1)) + (forth-p3-check-stack + "nested IF (both true)" + ": Q 1 IF 1 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q" + (list 10)) + (forth-p3-check-stack + "nested IF (inner false)" + ": Q 1 IF 0 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q" + (list 20)) + (forth-p3-check-stack + "nested IF (outer false)" + ": Q 0 IF 0 IF 10 ELSE 20 THEN ELSE 30 THEN ; Q" + (list 30)) + (forth-p3-check-stack + "IF before other ops" + ": Q 1 IF 5 ELSE 6 THEN 2 * ; Q" + (list 10)) + (forth-p3-check-stack + "IF in chained def" + ": POS? 0 > ; + : DOUBLE-IF-POS DUP POS? IF 2 * THEN ; + 3 DOUBLE-IF-POS" + (list 6)) + (forth-p3-check-stack + "empty then branch" + ": Q 1 IF THEN 99 ; Q" + (list 99)) + (forth-p3-check-stack + "empty else branch" + ": Q 0 IF 99 ELSE THEN ; Q" + (list)) + (forth-p3-check-stack + "sequential IF blocks" + ": Q -1 IF 1 THEN -1 IF 2 THEN ; Q" + (list 1 2)))) + +(define + forth-p3-run-all + (fn + () + (set! forth-p3-passed 0) + (set! forth-p3-failed 0) + (set! forth-p3-failures (list)) + (forth-p3-if-tests) + (dict + "passed" + forth-p3-passed + "failed" + forth-p3-failed + "failures" + forth-p3-failures))) diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 1a59da2a..46aa300c 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -69,7 +69,7 @@ Representation: - [x] Tests in `lib/forth/tests/test-phase2.sx` — 26/26 pass ### Phase 3 — control flow + first Hayes tests green -- [ ] `IF`, `ELSE`, `THEN` — compile to SX `if` +- [x] `IF`, `ELSE`, `THEN` — compile to SX `if` - [ ] `BEGIN`, `UNTIL`, `WHILE`, `REPEAT`, `AGAIN` — compile to loops - [ ] `DO`, `LOOP`, `+LOOP`, `I`, `J`, `LEAVE` — counted loops (needs a return stack) - [ ] Return stack: `>R`, `R>`, `R@`, `2>R`, `2R>`, `2R@` @@ -99,6 +99,19 @@ Representation: _Newest first._ +- **Phase 3 start — `IF`/`ELSE`/`THEN` (+18).** `lib/forth/compiler.sx` + + `tests/test-phase3.sx`. Colon-def body switched from `for-each` to + a PC-driven runner so branch ops can jump: ops now include dict tags + `{"kind" "bif"|"branch" "target" cell}` alongside the existing + `(fn (s) ...)` shape. IF compiles a `bif` with a fresh target cell + pushed to `state.cstack`; ELSE emits an unconditional `branch`, + patches the IF's target to the instruction after this branch, and + pushes the new target; THEN patches the most recent target to the + current body length. Nested IF/ELSE/THEN works via the cstack. + Also fixed `EMIT`: `code-char` → `char-from-code` (spec-correct + primitive name) so Phase 1/2 tests run green on sx_server. + 152/152 (Phase 1 + 2 + 3) green. + - **Phase 2 complete — colon defs, compile mode, VARIABLE/CONSTANT/VALUE/TO, @/!/+! (+26).** `lib/forth/compiler.sx` plus `tests/test-phase2.sx`. Colon-def body is a list of ops (one per source token) wrapped in a single From bb16477fd47deb21a1c1010644a068e9cea1e1f3 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 17:33:25 +0000 Subject: [PATCH 02/25] forth: BEGIN/UNTIL/WHILE/REPEAT/AGAIN (+9) --- lib/forth/compiler.sx | 66 ++++++++++++++++++++++++++++++++++ lib/forth/tests/test-phase3.sx | 46 ++++++++++++++++++++++++ plans/forth-on-sx.md | 16 ++++++++- 3 files changed, 127 insertions(+), 1 deletion(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index c58dc44e..9ebcf532 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -219,6 +219,72 @@ (let ((target (forth-cpop s))) (dict-set! target "v" (forth-def-length s))))) + (forth-def-prim-imm! + state + "BEGIN" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "BEGIN outside definition")) + (forth-cpush s (forth-def-length s)))) + (forth-def-prim-imm! + state + "UNTIL" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "UNTIL outside definition")) + (let + ((back-pc (forth-cpop s))) + (let + ((target (forth-make-target))) + (dict-set! target "v" back-pc) + (forth-def-append! s (forth-make-branch "bif" target)))))) + (forth-def-prim-imm! + state + "AGAIN" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "AGAIN outside definition")) + (let + ((back-pc (forth-cpop s))) + (let + ((target (forth-make-target))) + (dict-set! target "v" back-pc) + (forth-def-append! s (forth-make-branch "branch" target)))))) + (forth-def-prim-imm! + state + "WHILE" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "WHILE outside definition")) + (let + ((target (forth-make-target))) + (forth-def-append! s (forth-make-branch "bif" target)) + (forth-cpush s target)))) + (forth-def-prim-imm! + state + "REPEAT" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "REPEAT outside definition")) + (let + ((while-target (forth-cpop s))) + (let + ((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! while-target "v" (forth-def-length s))))))) (forth-def-prim! state "VARIABLE" diff --git a/lib/forth/tests/test-phase3.sx b/lib/forth/tests/test-phase3.sx index 604d0b42..8862bed2 100644 --- a/lib/forth/tests/test-phase3.sx +++ b/lib/forth/tests/test-phase3.sx @@ -106,6 +106,51 @@ ": Q -1 IF 1 THEN -1 IF 2 THEN ; Q" (list 1 2)))) +(define + forth-p3-loop-tests + (fn + () + (forth-p3-check-stack + "BEGIN UNTIL (countdown to zero)" + ": CD BEGIN 1- DUP 0 = UNTIL ; 3 CD" + (list 0)) + (forth-p3-check-stack + "BEGIN UNTIL — single pass (UNTIL true immediately)" + ": Q BEGIN -1 UNTIL 42 ; Q" + (list 42)) + (forth-p3-check-stack + "BEGIN UNTIL — accumulate sum 1+2+3" + ": SUM3 0 3 BEGIN TUCK + SWAP 1- DUP 0 = UNTIL DROP ; SUM3" + (list 6)) + (forth-p3-check-stack + "BEGIN WHILE REPEAT — triangular sum 5" + ": TRI 0 5 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ; TRI" + (list 15)) + (forth-p3-check-stack + "BEGIN WHILE REPEAT — zero iterations" + ": TRI 0 0 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ; TRI" + (list 0)) + (forth-p3-check-stack + "BEGIN WHILE REPEAT — one iteration" + ": TRI 0 1 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ; TRI" + (list 1)) + (forth-p3-check-stack + "nested BEGIN UNTIL" + ": INNER BEGIN 1- DUP 0 = UNTIL DROP ; + : OUTER BEGIN 3 INNER 1- DUP 0 = UNTIL ; + 2 OUTER" + (list 0)) + (forth-p3-check-stack + "BEGIN UNTIL after colon prefix" + ": TEN 10 ; + : CD TEN BEGIN 1- DUP 0 = UNTIL ; + CD" + (list 0)) + (forth-p3-check-stack + "WHILE inside IF branch" + ": Q 1 IF 0 3 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ELSE 99 THEN ; Q" + (list 6)))) + (define forth-p3-run-all (fn @@ -114,6 +159,7 @@ (set! forth-p3-failed 0) (set! forth-p3-failures (list)) (forth-p3-if-tests) + (forth-p3-loop-tests) (dict "passed" forth-p3-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 46aa300c..87dade1e 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -70,7 +70,7 @@ Representation: ### Phase 3 — control flow + first Hayes tests green - [x] `IF`, `ELSE`, `THEN` — compile to SX `if` -- [ ] `BEGIN`, `UNTIL`, `WHILE`, `REPEAT`, `AGAIN` — compile to loops +- [x] `BEGIN`, `UNTIL`, `WHILE`, `REPEAT`, `AGAIN` — compile to loops - [ ] `DO`, `LOOP`, `+LOOP`, `I`, `J`, `LEAVE` — counted loops (needs a return stack) - [ ] Return stack: `>R`, `R>`, `R@`, `2>R`, `2R>`, `2R@` - [ ] Vendor John Hayes' test suite to `lib/forth/ans-tests/` @@ -99,6 +99,20 @@ Representation: _Newest first._ +- **Phase 3 — `BEGIN`/`UNTIL`/`WHILE`/`REPEAT`/`AGAIN` (+9).** Indefinite-loop + constructs built on the same PC-driven body runner introduced for `IF`. + BEGIN records the current body length on `state.cstack` (a plain numeric + back-target). UNTIL/AGAIN pop that back-target and emit a `bif`/`branch` + op whose target cell is set to the recorded PC. WHILE emits a forward + `bif` with a fresh target cell and pushes it on the cstack *above* the + BEGIN marker; REPEAT pops both (while-target first, then back-pc), emits + an unconditional branch back to BEGIN, then patches the while-target to + the current body length — so WHILE's false flag jumps past the REPEAT. + Mixed compile-time layout (numeric back-targets + dict forward targets + on the same cstack) is OK because the immediate words pop them in the + order they expect. AGAIN works structurally but lacks a test without a + usable mid-loop exit; revisit once `EXIT` lands. 161/161 green. + - **Phase 3 start — `IF`/`ELSE`/`THEN` (+18).** `lib/forth/compiler.sx` + `tests/test-phase3.sx`. Colon-def body switched from `for-each` to a PC-driven runner so branch ops can jump: ops now include dict tags From e066e14267210ab22b1223645e740f0b48a55417 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 17:58:37 +0000 Subject: [PATCH 03/25] forth: DO/LOOP/+LOOP/I/J/LEAVE + return stack words (+16) --- lib/forth/compiler.sx | 146 +++++++++++++++++++++++++++++++++ lib/forth/runtime.sx | 38 +++++++++ lib/forth/tests/test-phase3.sx | 70 ++++++++++++++++ plans/forth-on-sx.md | 20 ++++- 4 files changed, 272 insertions(+), 2 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 9ebcf532..5e64e0ea 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -88,8 +88,69 @@ (dict-set! pc "v" (+ (get pc "v") 1)))) ((and (dict? op) (= (get op "kind") "branch")) (dict-set! pc "v" (get (get op "target") "v"))) + ((and (dict? op) (= (get op "kind") "leave")) + (begin + (forth-rpop s) + (forth-rpop s) + (dict-set! pc "v" (get (get op "target") "v")))) + ((and (dict? op) (= (get op "kind") "loop")) + (forth-loop-step s op pc)) + ((and (dict? op) (= (get op "kind") "+loop")) + (forth-plusloop-step s op pc)) (else (begin (op s) (dict-set! pc "v" (+ (get pc "v") 1))))))) +(define + forth-loop-step + (fn + (s op pc) + (let + ((idx (forth-rpop s))) + (let + ((lim (forth-rpeek s))) + (let + ((next (+ idx 1))) + (if + (>= next lim) + (begin + (forth-rpop s) + (dict-set! pc "v" (+ (get pc "v") 1))) + (begin + (forth-rpush s next) + (dict-set! pc "v" (get (get op "target") "v"))))))))) + +(define + forth-plusloop-step + (fn + (s op pc) + (let + ((inc (forth-pop s))) + (let + ((idx (forth-rpop s))) + (let + ((lim (forth-rpeek s))) + (let + ((next (+ idx inc))) + (if + (if (>= inc 0) (>= next lim) (< next lim)) + (begin + (forth-rpop s) + (dict-set! pc "v" (+ (get pc "v") 1))) + (begin + (forth-rpush s next) + (dict-set! pc "v" (get (get op "target") "v")))))))))) + +(define + forth-find-do + (fn + (cs) + (if + (= (len cs) 0) + nil + (if + (and (dict? (first cs)) (= (get (first cs) "kind") "do")) + (first cs) + (forth-find-do (rest cs)))))) + (define forth-run-body (fn @@ -285,6 +346,91 @@ (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))))))) + (forth-def-prim-imm! + state + "DO" + (fn + (s) + (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)))))) + (forth-def-append! s op)) + (let + ((marker (dict))) + (dict-set! marker "kind" "do") + (dict-set! marker "back" (forth-def-length s)) + (dict-set! marker "leaves" (list)) + (forth-cpush s marker)))) + (forth-def-prim-imm! + state + "LOOP" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "LOOP outside definition")) + (let + ((marker (forth-cpop s))) + (when + (or (not (dict? marker)) (not (= (get marker "kind") "do"))) + (forth-error s "LOOP without DO")) + (let + ((target (forth-make-target))) + (dict-set! target "v" (get marker "back")) + (forth-def-append! s (forth-make-branch "loop" target))) + (let + ((exit-pc (forth-def-length s))) + (for-each + (fn (t) (dict-set! t "v" exit-pc)) + (get marker "leaves")))))) + (forth-def-prim-imm! + state + "+LOOP" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "+LOOP outside definition")) + (let + ((marker (forth-cpop s))) + (when + (or (not (dict? marker)) (not (= (get marker "kind") "do"))) + (forth-error s "+LOOP without DO")) + (let + ((target (forth-make-target))) + (dict-set! target "v" (get marker "back")) + (forth-def-append! s (forth-make-branch "+loop" target))) + (let + ((exit-pc (forth-def-length s))) + (for-each + (fn (t) (dict-set! t "v" exit-pc)) + (get marker "leaves")))))) + (forth-def-prim-imm! + state + "LEAVE" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "LEAVE outside definition")) + (let + ((marker (forth-find-do (get s "cstack")))) + (when (nil? marker) (forth-error s "LEAVE without DO")) + (let + ((target (forth-make-target))) + (forth-def-append! s (forth-make-branch "leave" target)) + (dict-set! + marker + "leaves" + (concat (get marker "leaves") (list target))))))) (forth-def-prim! state "VARIABLE" diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 430bda2e..673ba07e 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -449,4 +449,42 @@ (> n 0) (for-each (fn (_) (forth-emit-str s " ")) (range 0 n)))))) (forth-def-prim! state "BL" (fn (s) (forth-push s 32))) + (forth-def-prim! state "I" (fn (s) (forth-push s (forth-rpeek s)))) + (forth-def-prim! + state + "J" + (fn (s) (forth-push s (nth (get s "rstack") 2)))) + (forth-def-prim! state ">R" (fn (s) (forth-rpush s (forth-pop s)))) + (forth-def-prim! state "R>" (fn (s) (forth-push s (forth-rpop s)))) + (forth-def-prim! state "R@" (fn (s) (forth-push s (forth-rpeek s)))) + (forth-def-prim! + state + "2>R" + (fn + (s) + (let + ((b (forth-pop s)) (a (forth-pop s))) + (forth-rpush s a) + (forth-rpush s b)))) + (forth-def-prim! + state + "2R>" + (fn + (s) + (let + ((b (forth-rpop s)) (a (forth-rpop s))) + (forth-push s a) + (forth-push s b)))) + (forth-def-prim! + state + "2R@" + (fn + (s) + (let + ((rs (get s "rstack"))) + (when + (< (len rs) 2) + (forth-error s "return stack underflow")) + (forth-push s (nth rs 1)) + (forth-push s (nth rs 0))))) state)) diff --git a/lib/forth/tests/test-phase3.sx b/lib/forth/tests/test-phase3.sx index 8862bed2..afd13d1d 100644 --- a/lib/forth/tests/test-phase3.sx +++ b/lib/forth/tests/test-phase3.sx @@ -151,6 +151,75 @@ ": Q 1 IF 0 3 BEGIN DUP 0 > WHILE TUCK + SWAP 1- REPEAT DROP ELSE 99 THEN ; Q" (list 6)))) +(define + forth-p3-do-tests + (fn + () + (forth-p3-check-stack + "DO LOOP — simple sum 0..4" + ": SUM 0 5 0 DO I + LOOP ; SUM" + (list 10)) + (forth-p3-check-stack + "DO LOOP — 10..14 sum using I" + ": SUM 0 15 10 DO I + LOOP ; SUM" + (list 60)) + (forth-p3-check-stack + "DO LOOP — limit = start runs one pass" + ": SUM 0 5 5 DO I + LOOP ; SUM" + (list 5)) + (forth-p3-check-stack + "DO LOOP — count iterations" + ": COUNT 0 4 0 DO 1+ LOOP ; COUNT" + (list 4)) + (forth-p3-check-stack + "DO LOOP — nested, I inner / J outer" + ": MATRIX 0 3 0 DO 3 0 DO I J + + LOOP LOOP ; MATRIX" + (list 18)) + (forth-p3-check-stack + "DO LOOP — I used in arithmetic" + ": DBL 0 5 1 DO I 2 * + LOOP ; DBL" + (list 20)) + (forth-p3-check-stack + "+LOOP — count by 2" + ": Q 0 10 0 DO I + 2 +LOOP ; Q" + (list 20)) + (forth-p3-check-stack + "+LOOP — count by 3" + ": Q 0 10 0 DO I + 3 +LOOP ; Q" + (list 18)) + (forth-p3-check-stack + "+LOOP — negative step" + ": Q 0 0 10 DO I + -1 +LOOP ; Q" + (list 55)) + (forth-p3-check-stack + "LEAVE — early exit at I=3" + ": Q 0 10 0 DO I 3 = IF LEAVE THEN I + LOOP ; Q" + (list 3)) + (forth-p3-check-stack + "LEAVE — in nested loop exits only inner" + ": Q 0 3 0 DO 5 0 DO I 2 = IF LEAVE THEN I + LOOP LOOP ; Q" + (list 3)) + (forth-p3-check-stack + "DO LOOP preserves outer stack" + ": Q 99 5 0 DO I + LOOP ; Q" + (list 109)) + (forth-p3-check-stack + ">R R>" + ": Q 7 >R 11 R> ; Q" + (list 11 7)) + (forth-p3-check-stack + ">R R@ R>" + ": Q 7 >R R@ R> ; Q" + (list 7 7)) + (forth-p3-check-stack + "2>R 2R>" + ": Q 1 2 2>R 99 2R> ; Q" + (list 99 1 2)) + (forth-p3-check-stack + "2>R 2R@ 2R>" + ": Q 3 4 2>R 2R@ 2R> ; Q" + (list 3 4 3 4)))) + (define forth-p3-run-all (fn @@ -160,6 +229,7 @@ (set! forth-p3-failures (list)) (forth-p3-if-tests) (forth-p3-loop-tests) + (forth-p3-do-tests) (dict "passed" forth-p3-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 87dade1e..17ddd6df 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -71,8 +71,8 @@ Representation: ### Phase 3 — control flow + first Hayes tests green - [x] `IF`, `ELSE`, `THEN` — compile to SX `if` - [x] `BEGIN`, `UNTIL`, `WHILE`, `REPEAT`, `AGAIN` — compile to loops -- [ ] `DO`, `LOOP`, `+LOOP`, `I`, `J`, `LEAVE` — counted loops (needs a return stack) -- [ ] Return stack: `>R`, `R>`, `R@`, `2>R`, `2R>`, `2R@` +- [x] `DO`, `LOOP`, `+LOOP`, `I`, `J`, `LEAVE` — counted loops (needs a return stack) +- [x] Return stack: `>R`, `R>`, `R@`, `2>R`, `2R>`, `2R@` - [ ] Vendor John Hayes' test suite to `lib/forth/ans-tests/` - [ ] `lib/forth/conformance.sh` + runner; `scoreboard.json` + `scoreboard.md` - [ ] Baseline: probably 30-50% Core passing after phase 3 @@ -99,6 +99,22 @@ Representation: _Newest first._ +- **Phase 3 — `DO`/`LOOP`/`+LOOP`/`I`/`J`/`LEAVE` + return stack words (+16).** + Counted loops compile onto the same PC-driven body runner. DO emits an + enter-op (pops limit+start from data stack, pushes them to rstack) and + pushes a `{:kind "do" :back PC :leaves ()}` marker onto cstack. LOOP/+LOOP + emit a dict op (`:kind "loop"`/`"+loop"` with target=back-cell). The step + handler pops index & reads limit, increments, and either restores the + updated index + jumps back, or drops the frame and advances. LEAVE walks + cstack for the innermost DO marker, emits a `:kind "leave"` dict op with + a fresh target cell, and registers it on the marker's leaves list. LOOP + patches all registered leave-targets to the exit PC and drops the marker. + The leave op pops two from rstack (unloop) and branches. `I` peeks rtop; + `J` reads rstack index 2 (below inner frame). Added non-immediate + return-stack words `>R`, `R>`, `R@`, `2>R`, `2R>`, `2R@`. Nested + DO/LOOP with J tested; LEAVE in nested loops exits only the inner. + 177/177 green. + - **Phase 3 — `BEGIN`/`UNTIL`/`WHILE`/`REPEAT`/`AGAIN` (+9).** Indefinite-loop constructs built on the same PC-driven body runner introduced for `IF`. BEGIN records the current body length on `state.cstack` (a plain numeric From a47b3e5420dbc491f0e31fba3f2d74a07b15c185 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 18:25:39 +0000 Subject: [PATCH 04/25] forth: vendor Gerry Jackson's forth2012-test-suite (Hayes Core + Ext) --- lib/forth/ans-tests/README.md | 14 + lib/forth/ans-tests/core.fr | 1009 +++++++++++++++++++++++++++ lib/forth/ans-tests/coreexttest.fth | 775 ++++++++++++++++++++ lib/forth/ans-tests/tester.fr | 66 ++ plans/forth-on-sx.md | 10 +- 5 files changed, 1873 insertions(+), 1 deletion(-) create mode 100644 lib/forth/ans-tests/README.md create mode 100644 lib/forth/ans-tests/core.fr create mode 100644 lib/forth/ans-tests/coreexttest.fth create mode 100644 lib/forth/ans-tests/tester.fr diff --git a/lib/forth/ans-tests/README.md b/lib/forth/ans-tests/README.md new file mode 100644 index 00000000..ef641aef --- /dev/null +++ b/lib/forth/ans-tests/README.md @@ -0,0 +1,14 @@ +ANS Forth conformance tests — vendored from +https://github.com/gerryjackson/forth2012-test-suite (master, commit-locked +on first fetch: 2026-04-24). + +Files in this directory are pristine copies of upstream — do not edit them. +They are consumed by the conformance runner in `lib/forth/conformance.sh`. + +- `tester.fr` — John Hayes' test harness (`T{ ... -> ... }T`). (C) 1995 + Johns Hopkins APL, distributable under its notice. +- `core.fr` — Core word set tests (Hayes, ~1000 lines). +- `coreexttest.fth` — Core Extension tests (Gerry Jackson). + +Only `core.fr` is expected to run green end-to-end for Phase 3; the others +stay parked until later phases. diff --git a/lib/forth/ans-tests/core.fr b/lib/forth/ans-tests/core.fr new file mode 100644 index 00000000..70fc9b3a --- /dev/null +++ b/lib/forth/ans-tests/core.fr @@ -0,0 +1,1009 @@ +\ From: John Hayes S1I +\ Subject: core.fr +\ Date: Mon, 27 Nov 95 13:10 + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 +\ THIS PROGRAM TESTS THE CORE WORDS OF AN ANS FORTH SYSTEM. +\ THE PROGRAM ASSUMES A TWO'S COMPLEMENT IMPLEMENTATION WHERE +\ THE RANGE OF SIGNED NUMBERS IS -2^(N-1) ... 2^(N-1)-1 AND +\ THE RANGE OF UNSIGNED NUMBERS IS 0 ... 2^(N)-1. +\ I HAVEN'T FIGURED OUT HOW TO TEST KEY, QUIT, ABORT, OR ABORT"... +\ I ALSO HAVEN'T THOUGHT OF A WAY TO TEST ENVIRONMENT?... + +CR +TESTING CORE WORDS +HEX + +\ ------------------------------------------------------------------------ +TESTING BASIC ASSUMPTIONS + +T{ -> }T \ START WITH CLEAN SLATE +( TEST IF ANY BITS ARE SET; ANSWER IN BASE 1 ) +T{ : BITSSET? IF 0 0 ELSE 0 THEN ; -> }T +T{ 0 BITSSET? -> 0 }T ( ZERO IS ALL BITS CLEAR ) +T{ 1 BITSSET? -> 0 0 }T ( OTHER NUMBER HAVE AT LEAST ONE BIT ) +T{ -1 BITSSET? -> 0 0 }T + +\ ------------------------------------------------------------------------ +TESTING BOOLEANS: INVERT AND OR XOR + +T{ 0 0 AND -> 0 }T +T{ 0 1 AND -> 0 }T +T{ 1 0 AND -> 0 }T +T{ 1 1 AND -> 1 }T + +T{ 0 INVERT 1 AND -> 1 }T +T{ 1 INVERT 1 AND -> 0 }T + +0 CONSTANT 0S +0 INVERT CONSTANT 1S + +T{ 0S INVERT -> 1S }T +T{ 1S INVERT -> 0S }T + +T{ 0S 0S AND -> 0S }T +T{ 0S 1S AND -> 0S }T +T{ 1S 0S AND -> 0S }T +T{ 1S 1S AND -> 1S }T + +T{ 0S 0S OR -> 0S }T +T{ 0S 1S OR -> 1S }T +T{ 1S 0S OR -> 1S }T +T{ 1S 1S OR -> 1S }T + +T{ 0S 0S XOR -> 0S }T +T{ 0S 1S XOR -> 1S }T +T{ 1S 0S XOR -> 1S }T +T{ 1S 1S XOR -> 0S }T + +\ ------------------------------------------------------------------------ +TESTING 2* 2/ LSHIFT RSHIFT + +( WE TRUST 1S, INVERT, AND BITSSET?; WE WILL CONFIRM RSHIFT LATER ) +1S 1 RSHIFT INVERT CONSTANT MSB +T{ MSB BITSSET? -> 0 0 }T + +T{ 0S 2* -> 0S }T +T{ 1 2* -> 2 }T +T{ 4000 2* -> 8000 }T +T{ 1S 2* 1 XOR -> 1S }T +T{ MSB 2* -> 0S }T + +T{ 0S 2/ -> 0S }T +T{ 1 2/ -> 0 }T +T{ 4000 2/ -> 2000 }T +T{ 1S 2/ -> 1S }T \ MSB PROPOGATED +T{ 1S 1 XOR 2/ -> 1S }T +T{ MSB 2/ MSB AND -> MSB }T + +T{ 1 0 LSHIFT -> 1 }T +T{ 1 1 LSHIFT -> 2 }T +T{ 1 2 LSHIFT -> 4 }T +T{ 1 F LSHIFT -> 8000 }T \ BIGGEST GUARANTEED SHIFT +T{ 1S 1 LSHIFT 1 XOR -> 1S }T +T{ MSB 1 LSHIFT -> 0 }T + +T{ 1 0 RSHIFT -> 1 }T +T{ 1 1 RSHIFT -> 0 }T +T{ 2 1 RSHIFT -> 1 }T +T{ 4 2 RSHIFT -> 1 }T +T{ 8000 F RSHIFT -> 1 }T \ BIGGEST +T{ MSB 1 RSHIFT MSB AND -> 0 }T \ RSHIFT ZERO FILLS MSBS +T{ MSB 1 RSHIFT 2* -> MSB }T + +\ ------------------------------------------------------------------------ +TESTING COMPARISONS: 0= = 0< < > U< MIN MAX +0 INVERT CONSTANT MAX-UINT +0 INVERT 1 RSHIFT CONSTANT MAX-INT +0 INVERT 1 RSHIFT INVERT CONSTANT MIN-INT +0 INVERT 1 RSHIFT CONSTANT MID-UINT +0 INVERT 1 RSHIFT INVERT CONSTANT MID-UINT+1 + +0S CONSTANT +1S CONSTANT + +T{ 0 0= -> }T +T{ 1 0= -> }T +T{ 2 0= -> }T +T{ -1 0= -> }T +T{ MAX-UINT 0= -> }T +T{ MIN-INT 0= -> }T +T{ MAX-INT 0= -> }T + +T{ 0 0 = -> }T +T{ 1 1 = -> }T +T{ -1 -1 = -> }T +T{ 1 0 = -> }T +T{ -1 0 = -> }T +T{ 0 1 = -> }T +T{ 0 -1 = -> }T + +T{ 0 0< -> }T +T{ -1 0< -> }T +T{ MIN-INT 0< -> }T +T{ 1 0< -> }T +T{ MAX-INT 0< -> }T + +T{ 0 1 < -> }T +T{ 1 2 < -> }T +T{ -1 0 < -> }T +T{ -1 1 < -> }T +T{ MIN-INT 0 < -> }T +T{ MIN-INT MAX-INT < -> }T +T{ 0 MAX-INT < -> }T +T{ 0 0 < -> }T +T{ 1 1 < -> }T +T{ 1 0 < -> }T +T{ 2 1 < -> }T +T{ 0 -1 < -> }T +T{ 1 -1 < -> }T +T{ 0 MIN-INT < -> }T +T{ MAX-INT MIN-INT < -> }T +T{ MAX-INT 0 < -> }T + +T{ 0 1 > -> }T +T{ 1 2 > -> }T +T{ -1 0 > -> }T +T{ -1 1 > -> }T +T{ MIN-INT 0 > -> }T +T{ MIN-INT MAX-INT > -> }T +T{ 0 MAX-INT > -> }T +T{ 0 0 > -> }T +T{ 1 1 > -> }T +T{ 1 0 > -> }T +T{ 2 1 > -> }T +T{ 0 -1 > -> }T +T{ 1 -1 > -> }T +T{ 0 MIN-INT > -> }T +T{ MAX-INT MIN-INT > -> }T +T{ MAX-INT 0 > -> }T + +T{ 0 1 U< -> }T +T{ 1 2 U< -> }T +T{ 0 MID-UINT U< -> }T +T{ 0 MAX-UINT U< -> }T +T{ MID-UINT MAX-UINT U< -> }T +T{ 0 0 U< -> }T +T{ 1 1 U< -> }T +T{ 1 0 U< -> }T +T{ 2 1 U< -> }T +T{ MID-UINT 0 U< -> }T +T{ MAX-UINT 0 U< -> }T +T{ MAX-UINT MID-UINT U< -> }T + +T{ 0 1 MIN -> 0 }T +T{ 1 2 MIN -> 1 }T +T{ -1 0 MIN -> -1 }T +T{ -1 1 MIN -> -1 }T +T{ MIN-INT 0 MIN -> MIN-INT }T +T{ MIN-INT MAX-INT MIN -> MIN-INT }T +T{ 0 MAX-INT MIN -> 0 }T +T{ 0 0 MIN -> 0 }T +T{ 1 1 MIN -> 1 }T +T{ 1 0 MIN -> 0 }T +T{ 2 1 MIN -> 1 }T +T{ 0 -1 MIN -> -1 }T +T{ 1 -1 MIN -> -1 }T +T{ 0 MIN-INT MIN -> MIN-INT }T +T{ MAX-INT MIN-INT MIN -> MIN-INT }T +T{ MAX-INT 0 MIN -> 0 }T + +T{ 0 1 MAX -> 1 }T +T{ 1 2 MAX -> 2 }T +T{ -1 0 MAX -> 0 }T +T{ -1 1 MAX -> 1 }T +T{ MIN-INT 0 MAX -> 0 }T +T{ MIN-INT MAX-INT MAX -> MAX-INT }T +T{ 0 MAX-INT MAX -> MAX-INT }T +T{ 0 0 MAX -> 0 }T +T{ 1 1 MAX -> 1 }T +T{ 1 0 MAX -> 1 }T +T{ 2 1 MAX -> 2 }T +T{ 0 -1 MAX -> 0 }T +T{ 1 -1 MAX -> 1 }T +T{ 0 MIN-INT MAX -> 0 }T +T{ MAX-INT MIN-INT MAX -> MAX-INT }T +T{ MAX-INT 0 MAX -> MAX-INT }T + +\ ------------------------------------------------------------------------ +TESTING STACK OPS: 2DROP 2DUP 2OVER 2SWAP ?DUP DEPTH DROP DUP OVER ROT SWAP + +T{ 1 2 2DROP -> }T +T{ 1 2 2DUP -> 1 2 1 2 }T +T{ 1 2 3 4 2OVER -> 1 2 3 4 1 2 }T +T{ 1 2 3 4 2SWAP -> 3 4 1 2 }T +T{ 0 ?DUP -> 0 }T +T{ 1 ?DUP -> 1 1 }T +T{ -1 ?DUP -> -1 -1 }T +T{ DEPTH -> 0 }T +T{ 0 DEPTH -> 0 1 }T +T{ 0 1 DEPTH -> 0 1 2 }T +T{ 0 DROP -> }T +T{ 1 2 DROP -> 1 }T +T{ 1 DUP -> 1 1 }T +T{ 1 2 OVER -> 1 2 1 }T +T{ 1 2 3 ROT -> 2 3 1 }T +T{ 1 2 SWAP -> 2 1 }T + +\ ------------------------------------------------------------------------ +TESTING >R R> R@ + +T{ : GR1 >R R> ; -> }T +T{ : GR2 >R R@ R> DROP ; -> }T +T{ 123 GR1 -> 123 }T +T{ 123 GR2 -> 123 }T +T{ 1S GR1 -> 1S }T ( RETURN STACK HOLDS CELLS ) + +\ ------------------------------------------------------------------------ +TESTING ADD/SUBTRACT: + - 1+ 1- ABS NEGATE + +T{ 0 5 + -> 5 }T +T{ 5 0 + -> 5 }T +T{ 0 -5 + -> -5 }T +T{ -5 0 + -> -5 }T +T{ 1 2 + -> 3 }T +T{ 1 -2 + -> -1 }T +T{ -1 2 + -> 1 }T +T{ -1 -2 + -> -3 }T +T{ -1 1 + -> 0 }T +T{ MID-UINT 1 + -> MID-UINT+1 }T + +T{ 0 5 - -> -5 }T +T{ 5 0 - -> 5 }T +T{ 0 -5 - -> 5 }T +T{ -5 0 - -> -5 }T +T{ 1 2 - -> -1 }T +T{ 1 -2 - -> 3 }T +T{ -1 2 - -> -3 }T +T{ -1 -2 - -> 1 }T +T{ 0 1 - -> -1 }T +T{ MID-UINT+1 1 - -> MID-UINT }T + +T{ 0 1+ -> 1 }T +T{ -1 1+ -> 0 }T +T{ 1 1+ -> 2 }T +T{ MID-UINT 1+ -> MID-UINT+1 }T + +T{ 2 1- -> 1 }T +T{ 1 1- -> 0 }T +T{ 0 1- -> -1 }T +T{ MID-UINT+1 1- -> MID-UINT }T + +T{ 0 NEGATE -> 0 }T +T{ 1 NEGATE -> -1 }T +T{ -1 NEGATE -> 1 }T +T{ 2 NEGATE -> -2 }T +T{ -2 NEGATE -> 2 }T + +T{ 0 ABS -> 0 }T +T{ 1 ABS -> 1 }T +T{ -1 ABS -> 1 }T +T{ MIN-INT ABS -> MID-UINT+1 }T + +\ ------------------------------------------------------------------------ +TESTING MULTIPLY: S>D * M* UM* + +T{ 0 S>D -> 0 0 }T +T{ 1 S>D -> 1 0 }T +T{ 2 S>D -> 2 0 }T +T{ -1 S>D -> -1 -1 }T +T{ -2 S>D -> -2 -1 }T +T{ MIN-INT S>D -> MIN-INT -1 }T +T{ MAX-INT S>D -> MAX-INT 0 }T + +T{ 0 0 M* -> 0 S>D }T +T{ 0 1 M* -> 0 S>D }T +T{ 1 0 M* -> 0 S>D }T +T{ 1 2 M* -> 2 S>D }T +T{ 2 1 M* -> 2 S>D }T +T{ 3 3 M* -> 9 S>D }T +T{ -3 3 M* -> -9 S>D }T +T{ 3 -3 M* -> -9 S>D }T +T{ -3 -3 M* -> 9 S>D }T +T{ 0 MIN-INT M* -> 0 S>D }T +T{ 1 MIN-INT M* -> MIN-INT S>D }T +T{ 2 MIN-INT M* -> 0 1S }T +T{ 0 MAX-INT M* -> 0 S>D }T +T{ 1 MAX-INT M* -> MAX-INT S>D }T +T{ 2 MAX-INT M* -> MAX-INT 1 LSHIFT 0 }T +T{ MIN-INT MIN-INT M* -> 0 MSB 1 RSHIFT }T +T{ MAX-INT MIN-INT M* -> MSB MSB 2/ }T +T{ MAX-INT MAX-INT M* -> 1 MSB 2/ INVERT }T + +T{ 0 0 * -> 0 }T \ TEST IDENTITIES +T{ 0 1 * -> 0 }T +T{ 1 0 * -> 0 }T +T{ 1 2 * -> 2 }T +T{ 2 1 * -> 2 }T +T{ 3 3 * -> 9 }T +T{ -3 3 * -> -9 }T +T{ 3 -3 * -> -9 }T +T{ -3 -3 * -> 9 }T + +T{ MID-UINT+1 1 RSHIFT 2 * -> MID-UINT+1 }T +T{ MID-UINT+1 2 RSHIFT 4 * -> MID-UINT+1 }T +T{ MID-UINT+1 1 RSHIFT MID-UINT+1 OR 2 * -> MID-UINT+1 }T + +T{ 0 0 UM* -> 0 0 }T +T{ 0 1 UM* -> 0 0 }T +T{ 1 0 UM* -> 0 0 }T +T{ 1 2 UM* -> 2 0 }T +T{ 2 1 UM* -> 2 0 }T +T{ 3 3 UM* -> 9 0 }T + +T{ MID-UINT+1 1 RSHIFT 2 UM* -> MID-UINT+1 0 }T +T{ MID-UINT+1 2 UM* -> 0 1 }T +T{ MID-UINT+1 4 UM* -> 0 2 }T +T{ 1S 2 UM* -> 1S 1 LSHIFT 1 }T +T{ MAX-UINT MAX-UINT UM* -> 1 1 INVERT }T + +\ ------------------------------------------------------------------------ +TESTING DIVIDE: FM/MOD SM/REM UM/MOD */ */MOD / /MOD MOD + +T{ 0 S>D 1 FM/MOD -> 0 0 }T +T{ 1 S>D 1 FM/MOD -> 0 1 }T +T{ 2 S>D 1 FM/MOD -> 0 2 }T +T{ -1 S>D 1 FM/MOD -> 0 -1 }T +T{ -2 S>D 1 FM/MOD -> 0 -2 }T +T{ 0 S>D -1 FM/MOD -> 0 0 }T +T{ 1 S>D -1 FM/MOD -> 0 -1 }T +T{ 2 S>D -1 FM/MOD -> 0 -2 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -1 FM/MOD -> 0 2 }T +T{ 2 S>D 2 FM/MOD -> 0 1 }T +T{ -1 S>D -1 FM/MOD -> 0 1 }T +T{ -2 S>D -2 FM/MOD -> 0 1 }T +T{ 7 S>D 3 FM/MOD -> 1 2 }T +T{ 7 S>D -3 FM/MOD -> -2 -3 }T +T{ -7 S>D 3 FM/MOD -> 2 -3 }T +T{ -7 S>D -3 FM/MOD -> -1 2 }T +T{ MAX-INT S>D 1 FM/MOD -> 0 MAX-INT }T +T{ MIN-INT S>D 1 FM/MOD -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT FM/MOD -> 0 1 }T +T{ MIN-INT S>D MIN-INT FM/MOD -> 0 1 }T +T{ 1S 1 4 FM/MOD -> 3 MAX-INT }T +T{ 1 MIN-INT M* 1 FM/MOD -> 0 MIN-INT }T +T{ 1 MIN-INT M* MIN-INT FM/MOD -> 0 1 }T +T{ 2 MIN-INT M* 2 FM/MOD -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT FM/MOD -> 0 2 }T +T{ 1 MAX-INT M* 1 FM/MOD -> 0 MAX-INT }T +T{ 1 MAX-INT M* MAX-INT FM/MOD -> 0 1 }T +T{ 2 MAX-INT M* 2 FM/MOD -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT FM/MOD -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT FM/MOD -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT FM/MOD -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT FM/MOD -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT FM/MOD -> 0 MAX-INT }T + +T{ 0 S>D 1 SM/REM -> 0 0 }T +T{ 1 S>D 1 SM/REM -> 0 1 }T +T{ 2 S>D 1 SM/REM -> 0 2 }T +T{ -1 S>D 1 SM/REM -> 0 -1 }T +T{ -2 S>D 1 SM/REM -> 0 -2 }T +T{ 0 S>D -1 SM/REM -> 0 0 }T +T{ 1 S>D -1 SM/REM -> 0 -1 }T +T{ 2 S>D -1 SM/REM -> 0 -2 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -1 SM/REM -> 0 2 }T +T{ 2 S>D 2 SM/REM -> 0 1 }T +T{ -1 S>D -1 SM/REM -> 0 1 }T +T{ -2 S>D -2 SM/REM -> 0 1 }T +T{ 7 S>D 3 SM/REM -> 1 2 }T +T{ 7 S>D -3 SM/REM -> 1 -2 }T +T{ -7 S>D 3 SM/REM -> -1 -2 }T +T{ -7 S>D -3 SM/REM -> -1 2 }T +T{ MAX-INT S>D 1 SM/REM -> 0 MAX-INT }T +T{ MIN-INT S>D 1 SM/REM -> 0 MIN-INT }T +T{ MAX-INT S>D MAX-INT SM/REM -> 0 1 }T +T{ MIN-INT S>D MIN-INT SM/REM -> 0 1 }T +T{ 1S 1 4 SM/REM -> 3 MAX-INT }T +T{ 2 MIN-INT M* 2 SM/REM -> 0 MIN-INT }T +T{ 2 MIN-INT M* MIN-INT SM/REM -> 0 2 }T +T{ 2 MAX-INT M* 2 SM/REM -> 0 MAX-INT }T +T{ 2 MAX-INT M* MAX-INT SM/REM -> 0 2 }T +T{ MIN-INT MIN-INT M* MIN-INT SM/REM -> 0 MIN-INT }T +T{ MIN-INT MAX-INT M* MIN-INT SM/REM -> 0 MAX-INT }T +T{ MIN-INT MAX-INT M* MAX-INT SM/REM -> 0 MIN-INT }T +T{ MAX-INT MAX-INT M* MAX-INT SM/REM -> 0 MAX-INT }T + +T{ 0 0 1 UM/MOD -> 0 0 }T +T{ 1 0 1 UM/MOD -> 0 1 }T +T{ 1 0 2 UM/MOD -> 1 0 }T +T{ 3 0 2 UM/MOD -> 1 1 }T +T{ MAX-UINT 2 UM* 2 UM/MOD -> 0 MAX-UINT }T +T{ MAX-UINT 2 UM* MAX-UINT UM/MOD -> 0 2 }T +T{ MAX-UINT MAX-UINT UM* MAX-UINT UM/MOD -> 0 MAX-UINT }T + +: IFFLOORED + [ -3 2 / -2 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +: IFSYM + [ -3 2 / -1 = INVERT ] LITERAL IF POSTPONE \ THEN ; + +\ THE SYSTEM MIGHT DO EITHER FLOORED OR SYMMETRIC DIVISION. +\ SINCE WE HAVE ALREADY TESTED M*, FM/MOD, AND SM/REM WE CAN USE THEM IN TEST. + +IFFLOORED : T/MOD >R S>D R> FM/MOD ; +IFFLOORED : T/ T/MOD SWAP DROP ; +IFFLOORED : TMOD T/MOD DROP ; +IFFLOORED : T*/MOD >R M* R> FM/MOD ; +IFFLOORED : T*/ T*/MOD SWAP DROP ; +IFSYM : T/MOD >R S>D R> SM/REM ; +IFSYM : T/ T/MOD SWAP DROP ; +IFSYM : TMOD T/MOD DROP ; +IFSYM : T*/MOD >R M* R> SM/REM ; +IFSYM : T*/ T*/MOD SWAP DROP ; + +T{ 0 1 /MOD -> 0 1 T/MOD }T +T{ 1 1 /MOD -> 1 1 T/MOD }T +T{ 2 1 /MOD -> 2 1 T/MOD }T +T{ -1 1 /MOD -> -1 1 T/MOD }T +T{ -2 1 /MOD -> -2 1 T/MOD }T +T{ 0 -1 /MOD -> 0 -1 T/MOD }T +T{ 1 -1 /MOD -> 1 -1 T/MOD }T +T{ 2 -1 /MOD -> 2 -1 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -1 /MOD -> -2 -1 T/MOD }T +T{ 2 2 /MOD -> 2 2 T/MOD }T +T{ -1 -1 /MOD -> -1 -1 T/MOD }T +T{ -2 -2 /MOD -> -2 -2 T/MOD }T +T{ 7 3 /MOD -> 7 3 T/MOD }T +T{ 7 -3 /MOD -> 7 -3 T/MOD }T +T{ -7 3 /MOD -> -7 3 T/MOD }T +T{ -7 -3 /MOD -> -7 -3 T/MOD }T +T{ MAX-INT 1 /MOD -> MAX-INT 1 T/MOD }T +T{ MIN-INT 1 /MOD -> MIN-INT 1 T/MOD }T +T{ MAX-INT MAX-INT /MOD -> MAX-INT MAX-INT T/MOD }T +T{ MIN-INT MIN-INT /MOD -> MIN-INT MIN-INT T/MOD }T + +T{ 0 1 / -> 0 1 T/ }T +T{ 1 1 / -> 1 1 T/ }T +T{ 2 1 / -> 2 1 T/ }T +T{ -1 1 / -> -1 1 T/ }T +T{ -2 1 / -> -2 1 T/ }T +T{ 0 -1 / -> 0 -1 T/ }T +T{ 1 -1 / -> 1 -1 T/ }T +T{ 2 -1 / -> 2 -1 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -1 / -> -2 -1 T/ }T +T{ 2 2 / -> 2 2 T/ }T +T{ -1 -1 / -> -1 -1 T/ }T +T{ -2 -2 / -> -2 -2 T/ }T +T{ 7 3 / -> 7 3 T/ }T +T{ 7 -3 / -> 7 -3 T/ }T +T{ -7 3 / -> -7 3 T/ }T +T{ -7 -3 / -> -7 -3 T/ }T +T{ MAX-INT 1 / -> MAX-INT 1 T/ }T +T{ MIN-INT 1 / -> MIN-INT 1 T/ }T +T{ MAX-INT MAX-INT / -> MAX-INT MAX-INT T/ }T +T{ MIN-INT MIN-INT / -> MIN-INT MIN-INT T/ }T + +T{ 0 1 MOD -> 0 1 TMOD }T +T{ 1 1 MOD -> 1 1 TMOD }T +T{ 2 1 MOD -> 2 1 TMOD }T +T{ -1 1 MOD -> -1 1 TMOD }T +T{ -2 1 MOD -> -2 1 TMOD }T +T{ 0 -1 MOD -> 0 -1 TMOD }T +T{ 1 -1 MOD -> 1 -1 TMOD }T +T{ 2 -1 MOD -> 2 -1 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -1 MOD -> -2 -1 TMOD }T +T{ 2 2 MOD -> 2 2 TMOD }T +T{ -1 -1 MOD -> -1 -1 TMOD }T +T{ -2 -2 MOD -> -2 -2 TMOD }T +T{ 7 3 MOD -> 7 3 TMOD }T +T{ 7 -3 MOD -> 7 -3 TMOD }T +T{ -7 3 MOD -> -7 3 TMOD }T +T{ -7 -3 MOD -> -7 -3 TMOD }T +T{ MAX-INT 1 MOD -> MAX-INT 1 TMOD }T +T{ MIN-INT 1 MOD -> MIN-INT 1 TMOD }T +T{ MAX-INT MAX-INT MOD -> MAX-INT MAX-INT TMOD }T +T{ MIN-INT MIN-INT MOD -> MIN-INT MIN-INT TMOD }T + +T{ 0 2 1 */ -> 0 2 1 T*/ }T +T{ 1 2 1 */ -> 1 2 1 T*/ }T +T{ 2 2 1 */ -> 2 2 1 T*/ }T +T{ -1 2 1 */ -> -1 2 1 T*/ }T +T{ -2 2 1 */ -> -2 2 1 T*/ }T +T{ 0 2 -1 */ -> 0 2 -1 T*/ }T +T{ 1 2 -1 */ -> 1 2 -1 T*/ }T +T{ 2 2 -1 */ -> 2 2 -1 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -1 */ -> -2 2 -1 T*/ }T +T{ 2 2 2 */ -> 2 2 2 T*/ }T +T{ -1 2 -1 */ -> -1 2 -1 T*/ }T +T{ -2 2 -2 */ -> -2 2 -2 T*/ }T +T{ 7 2 3 */ -> 7 2 3 T*/ }T +T{ 7 2 -3 */ -> 7 2 -3 T*/ }T +T{ -7 2 3 */ -> -7 2 3 T*/ }T +T{ -7 2 -3 */ -> -7 2 -3 T*/ }T +T{ MAX-INT 2 MAX-INT */ -> MAX-INT 2 MAX-INT T*/ }T +T{ MIN-INT 2 MIN-INT */ -> MIN-INT 2 MIN-INT T*/ }T + +T{ 0 2 1 */MOD -> 0 2 1 T*/MOD }T +T{ 1 2 1 */MOD -> 1 2 1 T*/MOD }T +T{ 2 2 1 */MOD -> 2 2 1 T*/MOD }T +T{ -1 2 1 */MOD -> -1 2 1 T*/MOD }T +T{ -2 2 1 */MOD -> -2 2 1 T*/MOD }T +T{ 0 2 -1 */MOD -> 0 2 -1 T*/MOD }T +T{ 1 2 -1 */MOD -> 1 2 -1 T*/MOD }T +T{ 2 2 -1 */MOD -> 2 2 -1 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -1 */MOD -> -2 2 -1 T*/MOD }T +T{ 2 2 2 */MOD -> 2 2 2 T*/MOD }T +T{ -1 2 -1 */MOD -> -1 2 -1 T*/MOD }T +T{ -2 2 -2 */MOD -> -2 2 -2 T*/MOD }T +T{ 7 2 3 */MOD -> 7 2 3 T*/MOD }T +T{ 7 2 -3 */MOD -> 7 2 -3 T*/MOD }T +T{ -7 2 3 */MOD -> -7 2 3 T*/MOD }T +T{ -7 2 -3 */MOD -> -7 2 -3 T*/MOD }T +T{ MAX-INT 2 MAX-INT */MOD -> MAX-INT 2 MAX-INT T*/MOD }T +T{ MIN-INT 2 MIN-INT */MOD -> MIN-INT 2 MIN-INT T*/MOD }T + +\ ------------------------------------------------------------------------ +TESTING HERE , @ ! CELL+ CELLS C, C@ C! CHARS 2@ 2! ALIGN ALIGNED +! ALLOT + +HERE 1 ALLOT +HERE +CONSTANT 2NDA +CONSTANT 1STA +T{ 1STA 2NDA U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STA 1+ -> 2NDA }T \ ... BY ONE ADDRESS UNIT +( MISSING TEST: NEGATIVE ALLOT ) + +\ Added by GWJ so that ALIGN can be used before , (comma) is tested +1 ALIGNED CONSTANT ALMNT \ -- 1|2|4|8 for 8|16|32|64 bit alignment +ALIGN +T{ HERE 1 ALLOT ALIGN HERE SWAP - ALMNT = -> }T +\ End of extra test + +HERE 1 , +HERE 2 , +CONSTANT 2ND +CONSTANT 1ST +T{ 1ST 2ND U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1ST CELL+ -> 2ND }T \ ... BY ONE CELL +T{ 1ST 1 CELLS + -> 2ND }T +T{ 1ST @ 2ND @ -> 1 2 }T +T{ 5 1ST ! -> }T +T{ 1ST @ 2ND @ -> 5 2 }T +T{ 6 2ND ! -> }T +T{ 1ST @ 2ND @ -> 5 6 }T +T{ 1ST 2@ -> 6 5 }T +T{ 2 1 1ST 2! -> }T +T{ 1ST 2@ -> 2 1 }T +T{ 1S 1ST ! 1ST @ -> 1S }T \ CAN STORE CELL-WIDE VALUE + +HERE 1 C, +HERE 2 C, +CONSTANT 2NDC +CONSTANT 1STC +T{ 1STC 2NDC U< -> }T \ HERE MUST GROW WITH ALLOT +T{ 1STC CHAR+ -> 2NDC }T \ ... BY ONE CHAR +T{ 1STC 1 CHARS + -> 2NDC }T +T{ 1STC C@ 2NDC C@ -> 1 2 }T +T{ 3 1STC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 2 }T +T{ 4 2NDC C! -> }T +T{ 1STC C@ 2NDC C@ -> 3 4 }T + +ALIGN 1 ALLOT HERE ALIGN HERE 3 CELLS ALLOT +CONSTANT A-ADDR CONSTANT UA-ADDR +T{ UA-ADDR ALIGNED -> A-ADDR }T +T{ 1 A-ADDR C! A-ADDR C@ -> 1 }T +T{ 1234 A-ADDR ! A-ADDR @ -> 1234 }T +T{ 123 456 A-ADDR 2! A-ADDR 2@ -> 123 456 }T +T{ 2 A-ADDR CHAR+ C! A-ADDR CHAR+ C@ -> 2 }T +T{ 3 A-ADDR CELL+ C! A-ADDR CELL+ C@ -> 3 }T +T{ 1234 A-ADDR CELL+ ! A-ADDR CELL+ @ -> 1234 }T +T{ 123 456 A-ADDR CELL+ 2! A-ADDR CELL+ 2@ -> 123 456 }T + +: BITS ( X -- U ) + 0 SWAP BEGIN DUP WHILE DUP MSB AND IF >R 1+ R> THEN 2* REPEAT DROP ; +( CHARACTERS >= 1 AU, <= SIZE OF CELL, >= 8 BITS ) +T{ 1 CHARS 1 < -> }T +T{ 1 CHARS 1 CELLS > -> }T +( TBD: HOW TO FIND NUMBER OF BITS? ) + +( CELLS >= 1 AU, INTEGRAL MULTIPLE OF CHAR SIZE, >= 16 BITS ) +T{ 1 CELLS 1 < -> }T +T{ 1 CELLS 1 CHARS MOD -> 0 }T +T{ 1S BITS 10 < -> }T + +T{ 0 1ST ! -> }T +T{ 1 1ST +! -> }T +T{ 1ST @ -> 1 }T +T{ -1 1ST +! 1ST @ -> 0 }T + +\ ------------------------------------------------------------------------ +TESTING CHAR [CHAR] [ ] BL S" + +T{ BL -> 20 }T +T{ CHAR X -> 58 }T +T{ CHAR HELLO -> 48 }T +T{ : GC1 [CHAR] X ; -> }T +T{ : GC2 [CHAR] HELLO ; -> }T +T{ GC1 -> 58 }T +T{ GC2 -> 48 }T +T{ : GC3 [ GC1 ] LITERAL ; -> }T +T{ GC3 -> 58 }T +T{ : GC4 S" XY" ; -> }T +T{ GC4 SWAP DROP -> 2 }T +T{ GC4 DROP DUP C@ SWAP CHAR+ C@ -> 58 59 }T + +\ ------------------------------------------------------------------------ +TESTING ' ['] FIND EXECUTE IMMEDIATE COUNT LITERAL POSTPONE STATE + +T{ : GT1 123 ; -> }T +T{ ' GT1 EXECUTE -> 123 }T +T{ : GT2 ['] GT1 ; IMMEDIATE -> }T +T{ GT2 EXECUTE -> 123 }T +HERE 3 C, CHAR G C, CHAR T C, CHAR 1 C, CONSTANT GT1STRING +HERE 3 C, CHAR G C, CHAR T C, CHAR 2 C, CONSTANT GT2STRING +T{ GT1STRING FIND -> ' GT1 -1 }T +T{ GT2STRING FIND -> ' GT2 1 }T +( HOW TO SEARCH FOR NON-EXISTENT WORD? ) +T{ : GT3 GT2 LITERAL ; -> }T +T{ GT3 -> ' GT1 }T +T{ GT1STRING COUNT -> GT1STRING CHAR+ 3 }T + +T{ : GT4 POSTPONE GT1 ; IMMEDIATE -> }T +T{ : GT5 GT4 ; -> }T +T{ GT5 -> 123 }T +T{ : GT6 345 ; IMMEDIATE -> }T +T{ : GT7 POSTPONE GT6 ; -> }T +T{ GT7 -> 345 }T + +T{ : GT8 STATE @ ; IMMEDIATE -> }T +T{ GT8 -> 0 }T +T{ : GT9 GT8 LITERAL ; -> }T +T{ GT9 0= -> }T + +\ ------------------------------------------------------------------------ +TESTING IF ELSE THEN BEGIN WHILE REPEAT UNTIL RECURSE + +T{ : GI1 IF 123 THEN ; -> }T +T{ : GI2 IF 123 ELSE 234 THEN ; -> }T +T{ 0 GI1 -> }T +T{ 1 GI1 -> 123 }T +T{ -1 GI1 -> 123 }T +T{ 0 GI2 -> 234 }T +T{ 1 GI2 -> 123 }T +T{ -1 GI1 -> 123 }T + +T{ : GI3 BEGIN DUP 5 < WHILE DUP 1+ REPEAT ; -> }T +T{ 0 GI3 -> 0 1 2 3 4 5 }T +T{ 4 GI3 -> 4 5 }T +T{ 5 GI3 -> 5 }T +T{ 6 GI3 -> 6 }T + +T{ : GI4 BEGIN DUP 1+ DUP 5 > UNTIL ; -> }T +T{ 3 GI4 -> 3 4 5 6 }T +T{ 5 GI4 -> 5 6 }T +T{ 6 GI4 -> 6 7 }T + +T{ : GI5 BEGIN DUP 2 > + WHILE DUP 5 < WHILE DUP 1+ REPEAT 123 ELSE 345 THEN ; -> }T +T{ 1 GI5 -> 1 345 }T +T{ 2 GI5 -> 2 345 }T +T{ 3 GI5 -> 3 4 5 123 }T +T{ 4 GI5 -> 4 5 123 }T +T{ 5 GI5 -> 5 123 }T + +T{ : GI6 ( N -- 0,1,..N ) DUP IF DUP >R 1- RECURSE R> THEN ; -> }T +T{ 0 GI6 -> 0 }T +T{ 1 GI6 -> 0 1 }T +T{ 2 GI6 -> 0 1 2 }T +T{ 3 GI6 -> 0 1 2 3 }T +T{ 4 GI6 -> 0 1 2 3 4 }T + +\ ------------------------------------------------------------------------ +TESTING DO LOOP +LOOP I J UNLOOP LEAVE EXIT + +T{ : GD1 DO I LOOP ; -> }T +T{ 4 1 GD1 -> 1 2 3 }T +T{ 2 -1 GD1 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD1 -> MID-UINT }T + +T{ : GD2 DO I -1 +LOOP ; -> }T +T{ 1 4 GD2 -> 4 3 2 1 }T +T{ -1 2 GD2 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD2 -> MID-UINT+1 MID-UINT }T + +T{ : GD3 DO 1 0 DO J LOOP LOOP ; -> }T +T{ 4 1 GD3 -> 1 2 3 }T +T{ 2 -1 GD3 -> -1 0 1 }T +T{ MID-UINT+1 MID-UINT GD3 -> MID-UINT }T + +T{ : GD4 DO 1 0 DO J LOOP -1 +LOOP ; -> }T +T{ 1 4 GD4 -> 4 3 2 1 }T +T{ -1 2 GD4 -> 2 1 0 -1 }T +T{ MID-UINT MID-UINT+1 GD4 -> MID-UINT+1 MID-UINT }T + +T{ : GD5 123 SWAP 0 DO I 4 > IF DROP 234 LEAVE THEN LOOP ; -> }T +T{ 1 GD5 -> 123 }T +T{ 5 GD5 -> 123 }T +T{ 6 GD5 -> 234 }T + +T{ : GD6 ( PAT: T{0 0},{0 0}{1 0}{1 1},{0 0}{1 0}{1 1}{2 0}{2 1}{2 2} ) + 0 SWAP 0 DO + I 1+ 0 DO I J + 3 = IF I UNLOOP I UNLOOP EXIT THEN 1+ LOOP + LOOP ; -> }T +T{ 1 GD6 -> 1 }T +T{ 2 GD6 -> 3 }T +T{ 3 GD6 -> 4 1 2 }T + +\ ------------------------------------------------------------------------ +TESTING DEFINING WORDS: : ; CONSTANT VARIABLE CREATE DOES> >BODY + +T{ 123 CONSTANT X123 -> }T +T{ X123 -> 123 }T +T{ : EQU CONSTANT ; -> }T +T{ X123 EQU Y123 -> }T +T{ Y123 -> 123 }T + +T{ VARIABLE V1 -> }T +T{ 123 V1 ! -> }T +T{ V1 @ -> 123 }T + +T{ : NOP : POSTPONE ; ; -> }T +T{ NOP NOP1 NOP NOP2 -> }T +T{ NOP1 -> }T +T{ NOP2 -> }T + +T{ : DOES1 DOES> @ 1 + ; -> }T +T{ : DOES2 DOES> @ 2 + ; -> }T +T{ CREATE CR1 -> }T +T{ CR1 -> HERE }T +T{ ' CR1 >BODY -> HERE }T +T{ 1 , -> }T +T{ CR1 @ -> 1 }T +T{ DOES1 -> }T +T{ CR1 -> 2 }T +T{ DOES2 -> }T +T{ CR1 -> 3 }T + +T{ : WEIRD: CREATE DOES> 1 + DOES> 2 + ; -> }T +T{ WEIRD: W1 -> }T +T{ ' W1 >BODY -> HERE }T +T{ W1 -> HERE 1 + }T +T{ W1 -> HERE 2 + }T + +\ ------------------------------------------------------------------------ +TESTING EVALUATE + +: GE1 S" 123" ; IMMEDIATE +: GE2 S" 123 1+" ; IMMEDIATE +: GE3 S" : GE4 345 ;" ; +: GE5 EVALUATE ; IMMEDIATE + +T{ GE1 EVALUATE -> 123 }T ( TEST EVALUATE IN INTERP. STATE ) +T{ GE2 EVALUATE -> 124 }T +T{ GE3 EVALUATE -> }T +T{ GE4 -> 345 }T + +T{ : GE6 GE1 GE5 ; -> }T ( TEST EVALUATE IN COMPILE STATE ) +T{ GE6 -> 123 }T +T{ : GE7 GE2 GE5 ; -> }T +T{ GE7 -> 124 }T + +\ ------------------------------------------------------------------------ +TESTING SOURCE >IN WORD + +: GS1 S" SOURCE" 2DUP EVALUATE + >R SWAP >R = R> R> = ; +T{ GS1 -> }T + +VARIABLE SCANS +: RESCAN? -1 SCANS +! SCANS @ IF 0 >IN ! THEN ; + +T{ 2 SCANS ! +345 RESCAN? +-> 345 345 }T + +: GS2 5 SCANS ! S" 123 RESCAN?" EVALUATE ; +T{ GS2 -> 123 123 123 123 123 }T + +: GS3 WORD COUNT SWAP C@ ; +T{ BL GS3 HELLO -> 5 CHAR H }T +T{ CHAR " GS3 GOODBYE" -> 7 CHAR G }T +T{ BL GS3 +DROP -> 0 }T \ BLANK LINE RETURN ZERO-LENGTH STRING + +: GS4 SOURCE >IN ! DROP ; +T{ GS4 123 456 +-> }T + +\ ------------------------------------------------------------------------ +TESTING <# # #S #> HOLD SIGN BASE >NUMBER HEX DECIMAL + +: S= \ ( ADDR1 C1 ADDR2 C2 -- T/F ) COMPARE TWO STRINGS. + >R SWAP R@ = IF \ MAKE SURE STRINGS HAVE SAME LENGTH + R> ?DUP IF \ IF NON-EMPTY STRINGS + 0 DO + OVER C@ OVER C@ - IF 2DROP UNLOOP EXIT THEN + SWAP CHAR+ SWAP CHAR+ + LOOP + THEN + 2DROP \ IF WE GET HERE, STRINGS MATCH + ELSE + R> DROP 2DROP \ LENGTHS MISMATCH + THEN ; + +: GP1 <# 41 HOLD 42 HOLD 0 0 #> S" BA" S= ; +T{ GP1 -> }T + +: GP2 <# -1 SIGN 0 SIGN -1 SIGN 0 0 #> S" --" S= ; +T{ GP2 -> }T + +: GP3 <# 1 0 # # #> S" 01" S= ; +T{ GP3 -> }T + +: GP4 <# 1 0 #S #> S" 1" S= ; +T{ GP4 -> }T + +24 CONSTANT MAX-BASE \ BASE 2 .. 36 +: COUNT-BITS + 0 0 INVERT BEGIN DUP WHILE >R 1+ R> 2* REPEAT DROP ; +COUNT-BITS 2* CONSTANT #BITS-UD \ NUMBER OF BITS IN UD + +: GP5 + BASE @ + MAX-BASE 1+ 2 DO \ FOR EACH POSSIBLE BASE + I BASE ! \ TBD: ASSUMES BASE WORKS + I 0 <# #S #> S" 10" S= AND + LOOP + SWAP BASE ! ; +T{ GP5 -> }T + +: GP6 + BASE @ >R 2 BASE ! + MAX-UINT MAX-UINT <# #S #> \ MAXIMUM UD TO BINARY + R> BASE ! \ S: C-ADDR U + DUP #BITS-UD = SWAP + 0 DO \ S: C-ADDR FLAG + OVER C@ [CHAR] 1 = AND \ ALL ONES + >R CHAR+ R> + LOOP SWAP DROP ; +T{ GP6 -> }T + +: GP7 + BASE @ >R MAX-BASE BASE ! + + A 0 DO + I 0 <# #S #> + 1 = SWAP C@ I 30 + = AND AND + LOOP + MAX-BASE A DO + I 0 <# #S #> + 1 = SWAP C@ 41 I A - + = AND AND + LOOP + R> BASE ! ; + +T{ GP7 -> }T + +\ >NUMBER TESTS +CREATE GN-BUF 0 C, +: GN-STRING GN-BUF 1 ; +: GN-CONSUMED GN-BUF CHAR+ 0 ; +: GN' [CHAR] ' WORD CHAR+ C@ GN-BUF C! GN-STRING ; + +T{ 0 0 GN' 0' >NUMBER -> 0 0 GN-CONSUMED }T +T{ 0 0 GN' 1' >NUMBER -> 1 0 GN-CONSUMED }T +T{ 1 0 GN' 1' >NUMBER -> BASE @ 1+ 0 GN-CONSUMED }T +T{ 0 0 GN' -' >NUMBER -> 0 0 GN-STRING }T \ SHOULD FAIL TO CONVERT THESE +T{ 0 0 GN' +' >NUMBER -> 0 0 GN-STRING }T +T{ 0 0 GN' .' >NUMBER -> 0 0 GN-STRING }T + +: >NUMBER-BASED + BASE @ >R BASE ! >NUMBER R> BASE ! ; + +T{ 0 0 GN' 2' 10 >NUMBER-BASED -> 2 0 GN-CONSUMED }T +T{ 0 0 GN' 2' 2 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' F' 10 >NUMBER-BASED -> F 0 GN-CONSUMED }T +T{ 0 0 GN' G' 10 >NUMBER-BASED -> 0 0 GN-STRING }T +T{ 0 0 GN' G' MAX-BASE >NUMBER-BASED -> 10 0 GN-CONSUMED }T +T{ 0 0 GN' Z' MAX-BASE >NUMBER-BASED -> 23 0 GN-CONSUMED }T + +: GN1 \ ( UD BASE -- UD' LEN ) UD SHOULD EQUAL UD' AND LEN SHOULD BE ZERO. + BASE @ >R BASE ! + <# #S #> + 0 0 2SWAP >NUMBER SWAP DROP \ RETURN LENGTH ONLY + R> BASE ! ; +T{ 0 0 2 GN1 -> 0 0 0 }T +T{ MAX-UINT 0 2 GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP 2 GN1 -> MAX-UINT DUP 0 }T +T{ 0 0 MAX-BASE GN1 -> 0 0 0 }T +T{ MAX-UINT 0 MAX-BASE GN1 -> MAX-UINT 0 0 }T +T{ MAX-UINT DUP MAX-BASE GN1 -> MAX-UINT DUP 0 }T + +: GN2 \ ( -- 16 10 ) + BASE @ >R HEX BASE @ DECIMAL BASE @ R> BASE ! ; +T{ GN2 -> 10 A }T + +\ ------------------------------------------------------------------------ +TESTING FILL MOVE + +CREATE FBUF 00 C, 00 C, 00 C, +CREATE SBUF 12 C, 34 C, 56 C, +: SEEBUF FBUF C@ FBUF CHAR+ C@ FBUF CHAR+ CHAR+ C@ ; + +T{ FBUF 0 20 FILL -> }T +T{ SEEBUF -> 00 00 00 }T + +T{ FBUF 1 20 FILL -> }T +T{ SEEBUF -> 20 00 00 }T + +T{ FBUF 3 20 FILL -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ FBUF FBUF 3 CHARS MOVE -> }T \ BIZARRE SPECIAL CASE +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 0 CHARS MOVE -> }T +T{ SEEBUF -> 20 20 20 }T + +T{ SBUF FBUF 1 CHARS MOVE -> }T +T{ SEEBUF -> 12 20 20 }T + +T{ SBUF FBUF 3 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 56 }T + +T{ FBUF FBUF CHAR+ 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 12 34 }T + +T{ FBUF CHAR+ FBUF 2 CHARS MOVE -> }T +T{ SEEBUF -> 12 34 34 }T + +\ ------------------------------------------------------------------------ +TESTING OUTPUT: . ." CR EMIT SPACE SPACES TYPE U. + +: OUTPUT-TEST + ." YOU SHOULD SEE THE STANDARD GRAPHIC CHARACTERS:" CR + 41 BL DO I EMIT LOOP CR + 61 41 DO I EMIT LOOP CR + 7F 61 DO I EMIT LOOP CR + ." YOU SHOULD SEE 0-9 SEPARATED BY A SPACE:" CR + 9 1+ 0 DO I . LOOP CR + ." YOU SHOULD SEE 0-9 (WITH NO SPACES):" CR + [CHAR] 9 1+ [CHAR] 0 DO I 0 SPACES EMIT LOOP CR + ." YOU SHOULD SEE A-G SEPARATED BY A SPACE:" CR + [CHAR] G 1+ [CHAR] A DO I EMIT SPACE LOOP CR + ." YOU SHOULD SEE 0-5 SEPARATED BY TWO SPACES:" CR + 5 1+ 0 DO I [CHAR] 0 + EMIT 2 SPACES LOOP CR + ." YOU SHOULD SEE TWO SEPARATE LINES:" CR + S" LINE 1" TYPE CR S" LINE 2" TYPE CR + ." YOU SHOULD SEE THE NUMBER RANGES OF SIGNED AND UNSIGNED NUMBERS:" CR + ." SIGNED: " MIN-INT . MAX-INT . CR + ." UNSIGNED: " 0 U. MAX-UINT U. CR +; + +T{ OUTPUT-TEST -> }T + + +\ ------------------------------------------------------------------------ +TESTING INPUT: ACCEPT + +CREATE ABUF 50 CHARS ALLOT + +: ACCEPT-TEST + CR ." PLEASE TYPE UP TO 80 CHARACTERS:" CR + ABUF 50 ACCEPT + CR ." RECEIVED: " [CHAR] " EMIT + ABUF SWAP TYPE [CHAR] " EMIT CR +; + +T{ ACCEPT-TEST -> }T + +\ ------------------------------------------------------------------------ +TESTING DICTIONARY SEARCH RULES + +T{ : GDX 123 ; : GDX GDX 234 ; -> }T + +T{ GDX -> 123 234 }T + +CR .( End of Core word set tests) CR + + diff --git a/lib/forth/ans-tests/coreexttest.fth b/lib/forth/ans-tests/coreexttest.fth new file mode 100644 index 00000000..382f93f3 --- /dev/null +++ b/lib/forth/ans-tests/coreexttest.fth @@ -0,0 +1,775 @@ +\ To test the ANS Forth Core Extension word set + +\ This program was written by Gerry Jackson in 2006, with contributions from +\ others where indicated, and is in the public domain - it can be distributed +\ and/or modified in any way but please retain this notice. + +\ This program is distributed in the hope that it will be useful, +\ but WITHOUT ANY WARRANTY; without even the implied warranty of +\ MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. + +\ The tests are not claimed to be comprehensive or correct + +\ ------------------------------------------------------------------------------ +\ Version 0.15 1 August 2025 Added two tests to VALUE +\ 0.14 21 July 2022 Updated first line of BUFFER: test as recommended +\ in issue 32 +\ 0.13 28 October 2015 +\ Replace and with FALSE and TRUE to avoid +\ dependence on Core tests +\ Moved SAVE-INPUT and RESTORE-INPUT tests in a file to filetest.fth +\ Use of 2VARIABLE (from optional wordset) replaced with CREATE. +\ Minor lower to upper case conversions. +\ Calls to COMPARE replaced by S= (in utilities.fth) to avoid use +\ of a word from an optional word set. +\ UNUSED tests revised as UNUSED UNUSED = may return FALSE when an +\ implementation has the data stack sharing unused dataspace. +\ Double number input dependency removed from the HOLDS tests. +\ Minor case sensitivities removed in definition names. +\ 0.11 25 April 2015 +\ Added tests for PARSE-NAME HOLDS BUFFER: +\ S\" tests added +\ DEFER IS ACTION-OF DEFER! DEFER@ tests added +\ Empty CASE statement test added +\ [COMPILE] tests removed because it is obsolescent in Forth 2012 +\ 0.10 1 August 2014 +\ Added tests contributed by James Bowman for: +\ <> U> 0<> 0> NIP TUCK ROLL PICK 2>R 2R@ 2R> +\ HEX WITHIN UNUSED AGAIN MARKER +\ Added tests for: +\ .R U.R ERASE PAD REFILL SOURCE-ID +\ Removed ABORT from NeverExecuted to enable Win32 +\ to continue after failure of RESTORE-INPUT. +\ Removed max-intx which is no longer used. +\ 0.7 6 June 2012 Extra CASE test added +\ 0.6 1 April 2012 Tests placed in the public domain. +\ SAVE-INPUT & RESTORE-INPUT tests, position +\ of T{ moved so that tests work with ttester.fs +\ CONVERT test deleted - obsolete word removed from Forth 200X +\ IMMEDIATE VALUEs tested +\ RECURSE with :NONAME tested +\ PARSE and .( tested +\ Parsing behaviour of C" added +\ 0.5 14 September 2011 Removed the double [ELSE] from the +\ initial SAVE-INPUT & RESTORE-INPUT test +\ 0.4 30 November 2009 max-int replaced with max-intx to +\ avoid redefinition warnings. +\ 0.3 6 March 2009 { and } replaced with T{ and }T +\ CONVERT test now independent of cell size +\ 0.2 20 April 2007 ANS Forth words changed to upper case +\ Tests qd3 to qd6 by Reinhold Straub +\ 0.1 Oct 2006 First version released +\ ----------------------------------------------------------------------------- +\ The tests are based on John Hayes test program for the core word set + +\ Words tested in this file are: +\ .( .R 0<> 0> 2>R 2R> 2R@ :NONAME <> ?DO AGAIN C" CASE COMPILE, ENDCASE +\ ENDOF ERASE FALSE HEX MARKER NIP OF PAD PARSE PICK REFILL +\ RESTORE-INPUT ROLL SAVE-INPUT SOURCE-ID TO TRUE TUCK U.R U> UNUSED +\ VALUE WITHIN [COMPILE] + +\ Words not tested or partially tested: +\ \ because it has been extensively used already and is, hence, unnecessary +\ REFILL and SOURCE-ID from the user input device which are not possible +\ when testing from a file such as this one +\ UNUSED (partially tested) as the value returned is system dependent +\ Obsolescent words #TIB CONVERT EXPECT QUERY SPAN TIB as they have been +\ removed from the Forth 2012 standard + +\ Results from words that output to the user output device have to visually +\ checked for correctness. These are .R U.R .( + +\ ----------------------------------------------------------------------------- +\ Assumptions & dependencies: +\ - tester.fr (or ttester.fs), errorreport.fth and utilities.fth have been +\ included prior to this file +\ - the Core word set available +\ ----------------------------------------------------------------------------- +TESTING Core Extension words + +DECIMAL + +TESTING TRUE FALSE + +T{ TRUE -> 0 INVERT }T +T{ FALSE -> 0 }T + +\ ----------------------------------------------------------------------------- +TESTING <> U> (contributed by James Bowman) + +T{ 0 0 <> -> FALSE }T +T{ 1 1 <> -> FALSE }T +T{ -1 -1 <> -> FALSE }T +T{ 1 0 <> -> TRUE }T +T{ -1 0 <> -> TRUE }T +T{ 0 1 <> -> TRUE }T +T{ 0 -1 <> -> TRUE }T + +T{ 0 1 U> -> FALSE }T +T{ 1 2 U> -> FALSE }T +T{ 0 MID-UINT U> -> FALSE }T +T{ 0 MAX-UINT U> -> FALSE }T +T{ MID-UINT MAX-UINT U> -> FALSE }T +T{ 0 0 U> -> FALSE }T +T{ 1 1 U> -> FALSE }T +T{ 1 0 U> -> TRUE }T +T{ 2 1 U> -> TRUE }T +T{ MID-UINT 0 U> -> TRUE }T +T{ MAX-UINT 0 U> -> TRUE }T +T{ MAX-UINT MID-UINT U> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING 0<> 0> (contributed by James Bowman) + +T{ 0 0<> -> FALSE }T +T{ 1 0<> -> TRUE }T +T{ 2 0<> -> TRUE }T +T{ -1 0<> -> TRUE }T +T{ MAX-UINT 0<> -> TRUE }T +T{ MIN-INT 0<> -> TRUE }T +T{ MAX-INT 0<> -> TRUE }T + +T{ 0 0> -> FALSE }T +T{ -1 0> -> FALSE }T +T{ MIN-INT 0> -> FALSE }T +T{ 1 0> -> TRUE }T +T{ MAX-INT 0> -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING NIP TUCK ROLL PICK (contributed by James Bowman) + +T{ 1 2 NIP -> 2 }T +T{ 1 2 3 NIP -> 1 3 }T + +T{ 1 2 TUCK -> 2 1 2 }T +T{ 1 2 3 TUCK -> 1 3 2 3 }T + +T{ : RO5 100 200 300 400 500 ; -> }T +T{ RO5 3 ROLL -> 100 300 400 500 200 }T +T{ RO5 2 ROLL -> RO5 ROT }T +T{ RO5 1 ROLL -> RO5 SWAP }T +T{ RO5 0 ROLL -> RO5 }T + +T{ RO5 2 PICK -> 100 200 300 400 500 300 }T +T{ RO5 1 PICK -> RO5 OVER }T +T{ RO5 0 PICK -> RO5 DUP }T + +\ ----------------------------------------------------------------------------- +TESTING 2>R 2R@ 2R> (contributed by James Bowman) + +T{ : RR0 2>R 100 R> R> ; -> }T +T{ 300 400 RR0 -> 100 400 300 }T +T{ 200 300 400 RR0 -> 200 100 400 300 }T + +T{ : RR1 2>R 100 2R@ R> R> ; -> }T +T{ 300 400 RR1 -> 100 300 400 400 300 }T +T{ 200 300 400 RR1 -> 200 100 300 400 400 300 }T + +T{ : RR2 2>R 100 2R> ; -> }T +T{ 300 400 RR2 -> 100 300 400 }T +T{ 200 300 400 RR2 -> 200 100 300 400 }T + +\ ----------------------------------------------------------------------------- +TESTING HEX (contributed by James Bowman) + +T{ BASE @ HEX BASE @ DECIMAL BASE @ - SWAP BASE ! -> 6 }T + +\ ----------------------------------------------------------------------------- +TESTING WITHIN (contributed by James Bowman) + +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 MID-UINT WITHIN -> TRUE }T +T{ 0 0 MID-UINT+1 WITHIN -> TRUE }T +T{ 0 0 MAX-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT 0 WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ 0 MID-UINT+1 0 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ 0 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ 0 MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ 0 MAX-UINT 0 WITHIN -> FALSE }T +T{ 0 MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ 0 MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ 0 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 0 WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT 0 MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT MID-UINT+1 0 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MID-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 0 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 0 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 0 WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MID-UINT+1 MAX-UINT WITHIN -> TRUE }T +T{ MID-UINT+1 MAX-UINT 0 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MID-UINT+1 MAX-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 0 WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT 0 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT 0 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT MID-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 0 WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MID-UINT+1 MID-UINT+1 WITHIN -> FALSE }T +T{ MAX-UINT MID-UINT+1 MAX-UINT WITHIN -> FALSE }T +T{ MAX-UINT MAX-UINT 0 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MID-UINT+1 WITHIN -> TRUE }T +T{ MAX-UINT MAX-UINT MAX-UINT WITHIN -> FALSE }T + +T{ MIN-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MIN-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MIN-INT MAX-INT WITHIN -> TRUE }T +T{ MIN-INT 0 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 0 0 WITHIN -> FALSE }T +T{ MIN-INT 0 1 WITHIN -> FALSE }T +T{ MIN-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT 1 MIN-INT WITHIN -> FALSE }T +T{ MIN-INT 1 0 WITHIN -> TRUE }T +T{ MIN-INT 1 1 WITHIN -> FALSE }T +T{ MIN-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT MIN-INT WITHIN -> FALSE }T +T{ MIN-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MIN-INT MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 0 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MIN-INT 0 WITHIN -> FALSE }T +T{ 0 MIN-INT 1 WITHIN -> TRUE }T +T{ 0 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 0 0 MIN-INT WITHIN -> TRUE }T +T{ 0 0 0 WITHIN -> FALSE }T +T{ 0 0 1 WITHIN -> TRUE }T +T{ 0 0 MAX-INT WITHIN -> TRUE }T +T{ 0 1 MIN-INT WITHIN -> FALSE }T +T{ 0 1 0 WITHIN -> FALSE }T +T{ 0 1 1 WITHIN -> FALSE }T +T{ 0 1 MAX-INT WITHIN -> FALSE }T +T{ 0 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 0 MAX-INT 0 WITHIN -> FALSE }T +T{ 0 MAX-INT 1 WITHIN -> TRUE }T +T{ 0 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ 1 MIN-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MIN-INT 0 WITHIN -> FALSE }T +T{ 1 MIN-INT 1 WITHIN -> FALSE }T +T{ 1 MIN-INT MAX-INT WITHIN -> TRUE }T +T{ 1 0 MIN-INT WITHIN -> TRUE }T +T{ 1 0 0 WITHIN -> FALSE }T +T{ 1 0 1 WITHIN -> FALSE }T +T{ 1 0 MAX-INT WITHIN -> TRUE }T +T{ 1 1 MIN-INT WITHIN -> TRUE }T +T{ 1 1 0 WITHIN -> TRUE }T +T{ 1 1 1 WITHIN -> FALSE }T +T{ 1 1 MAX-INT WITHIN -> TRUE }T +T{ 1 MAX-INT MIN-INT WITHIN -> FALSE }T +T{ 1 MAX-INT 0 WITHIN -> FALSE }T +T{ 1 MAX-INT 1 WITHIN -> FALSE }T +T{ 1 MAX-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MIN-INT WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 0 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT 1 WITHIN -> FALSE }T +T{ MAX-INT MIN-INT MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 0 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 0 0 WITHIN -> FALSE }T +T{ MAX-INT 0 1 WITHIN -> FALSE }T +T{ MAX-INT 0 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT 1 MIN-INT WITHIN -> TRUE }T +T{ MAX-INT 1 0 WITHIN -> TRUE }T +T{ MAX-INT 1 1 WITHIN -> FALSE }T +T{ MAX-INT 1 MAX-INT WITHIN -> FALSE }T +T{ MAX-INT MAX-INT MIN-INT WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 0 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT 1 WITHIN -> TRUE }T +T{ MAX-INT MAX-INT MAX-INT WITHIN -> FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING UNUSED (contributed by James Bowman & Peter Knaggs) + +VARIABLE UNUSED0 +T{ UNUSED DROP -> }T +T{ ALIGN UNUSED UNUSED0 ! 0 , UNUSED CELL+ UNUSED0 @ = -> TRUE }T +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = + -> TRUE }T \ aligned -> unaligned +T{ UNUSED UNUSED0 ! 0 C, UNUSED CHAR+ UNUSED0 @ = -> TRUE }T \ unaligned -> ? + +\ ----------------------------------------------------------------------------- +TESTING AGAIN (contributed by James Bowman) + +T{ : AG0 701 BEGIN DUP 7 MOD 0= IF EXIT THEN 1+ AGAIN ; -> }T +T{ AG0 -> 707 }T + +\ ----------------------------------------------------------------------------- +TESTING MARKER (contributed by James Bowman) + +T{ : MA? BL WORD FIND NIP 0<> ; -> }T +T{ MARKER MA0 -> }T +T{ : MA1 111 ; -> }T +T{ MARKER MA2 -> }T +T{ : MA1 222 ; -> }T +T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE TRUE }T +T{ MA1 MA2 MA1 -> 222 111 }T +T{ MA? MA0 MA? MA1 MA? MA2 -> TRUE TRUE FALSE }T +T{ MA0 -> }T +T{ MA? MA0 MA? MA1 MA? MA2 -> FALSE FALSE FALSE }T + +\ ----------------------------------------------------------------------------- +TESTING ?DO + +: QD ?DO I LOOP ; +T{ 789 789 QD -> }T +T{ -9876 -9876 QD -> }T +T{ 5 0 QD -> 0 1 2 3 4 }T + +: QD1 ?DO I 10 +LOOP ; +T{ 50 1 QD1 -> 1 11 21 31 41 }T +T{ 50 0 QD1 -> 0 10 20 30 40 }T + +: QD2 ?DO I 3 > IF LEAVE ELSE I THEN LOOP ; +T{ 5 -1 QD2 -> -1 0 1 2 3 }T + +: QD3 ?DO I 1 +LOOP ; +T{ 4 4 QD3 -> }T +T{ 4 1 QD3 -> 1 2 3 }T +T{ 2 -1 QD3 -> -1 0 1 }T + +: QD4 ?DO I -1 +LOOP ; +T{ 4 4 QD4 -> }T +T{ 1 4 QD4 -> 4 3 2 1 }T +T{ -1 2 QD4 -> 2 1 0 -1 }T + +: QD5 ?DO I -10 +LOOP ; +T{ 1 50 QD5 -> 50 40 30 20 10 }T +T{ 0 50 QD5 -> 50 40 30 20 10 0 }T +T{ -25 10 QD5 -> 10 0 -10 -20 }T + +VARIABLE ITERS +VARIABLE INCRMNT + +: QD6 ( limit start increment -- ) + INCRMNT ! + 0 ITERS ! + ?DO + 1 ITERS +! + I + ITERS @ 6 = IF LEAVE THEN + INCRMNT @ + +LOOP ITERS @ +; + +T{ 4 4 -1 QD6 -> 0 }T +T{ 1 4 -1 QD6 -> 4 3 2 1 4 }T +T{ 4 1 -1 QD6 -> 1 0 -1 -2 -3 -4 6 }T +T{ 4 1 0 QD6 -> 1 1 1 1 1 1 6 }T +T{ 0 0 0 QD6 -> 0 }T +T{ 1 4 0 QD6 -> 4 4 4 4 4 4 6 }T +T{ 1 4 1 QD6 -> 4 5 6 7 8 9 6 }T +T{ 4 1 1 QD6 -> 1 2 3 3 }T +T{ 4 4 1 QD6 -> 0 }T +T{ 2 -1 -1 QD6 -> -1 -2 -3 -4 -5 -6 6 }T +T{ -1 2 -1 QD6 -> 2 1 0 -1 4 }T +T{ 2 -1 0 QD6 -> -1 -1 -1 -1 -1 -1 6 }T +T{ -1 2 0 QD6 -> 2 2 2 2 2 2 6 }T +T{ -1 2 1 QD6 -> 2 3 4 5 6 7 6 }T +T{ 2 -1 1 QD6 -> -1 0 1 3 }T + +\ ----------------------------------------------------------------------------- +TESTING BUFFER: + +T{ 2 CELLS BUFFER: BUF:TEST -> }T +T{ BUF:TEST DUP ALIGNED = -> TRUE }T +T{ 111 BUF:TEST ! 222 BUF:TEST CELL+ ! -> }T +T{ BUF:TEST @ BUF:TEST CELL+ @ -> 111 222 }T + +\ ----------------------------------------------------------------------------- +TESTING VALUE TO + +T{ 111 VALUE VAL1 -999 VALUE VAL2 -> }T +T{ VAL1 -> 111 }T +T{ VAL2 -> -999 }T +T{ 222 TO VAL1 -> }T +T{ VAL1 -> 222 }T +T{ : VD1 VAL1 ; -> }T +T{ VD1 -> 222 }T +T{ : VD2 TO VAL2 ; -> }T +T{ VAL2 -> -999 }T +T{ -333 VD2 -> }T +T{ VAL2 -> -333 }T +T{ VAL1 -> 222 }T +T{ 444 TO VAL1 -> }T +T{ VD1 -> 444 }T +T{ 123 VALUE VAL3 IMMEDIATE VAL3 -> 123 }T +T{ : VD3 VAL3 LITERAL ; VD3 -> 123 }T + +\ ----------------------------------------------------------------------------- +TESTING CASE OF ENDOF ENDCASE + +: CS1 CASE 1 OF 111 ENDOF + 2 OF 222 ENDOF + 3 OF 333 ENDOF + >R 999 R> + ENDCASE +; + +T{ 1 CS1 -> 111 }T +T{ 2 CS1 -> 222 }T +T{ 3 CS1 -> 333 }T +T{ 4 CS1 -> 999 }T + +\ Nested CASE's + +: CS2 >R CASE -1 OF CASE R@ 1 OF 100 ENDOF + 2 OF 200 ENDOF + >R -300 R> + ENDCASE + ENDOF + -2 OF CASE R@ 1 OF -99 ENDOF + >R -199 R> + ENDCASE + ENDOF + >R 299 R> + ENDCASE R> DROP +; + +T{ -1 1 CS2 -> 100 }T +T{ -1 2 CS2 -> 200 }T +T{ -1 3 CS2 -> -300 }T +T{ -2 1 CS2 -> -99 }T +T{ -2 2 CS2 -> -199 }T +T{ 0 2 CS2 -> 299 }T + +\ Boolean short circuiting using CASE + +: CS3 ( N1 -- N2 ) + CASE 1- FALSE OF 11 ENDOF + 1- FALSE OF 22 ENDOF + 1- FALSE OF 33 ENDOF + 44 SWAP + ENDCASE +; + +T{ 1 CS3 -> 11 }T +T{ 2 CS3 -> 22 }T +T{ 3 CS3 -> 33 }T +T{ 9 CS3 -> 44 }T + +\ Empty CASE statements with/without default + +T{ : CS4 CASE ENDCASE ; 1 CS4 -> }T +T{ : CS5 CASE 2 SWAP ENDCASE ; 1 CS5 -> 2 }T +T{ : CS6 CASE 1 OF ENDOF 2 ENDCASE ; 1 CS6 -> }T +T{ : CS7 CASE 3 OF ENDOF 2 ENDCASE ; 1 CS7 -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING :NONAME RECURSE + +VARIABLE NN1 +VARIABLE NN2 +:NONAME 1234 ; NN1 ! +:NONAME 9876 ; NN2 ! +T{ NN1 @ EXECUTE -> 1234 }T +T{ NN2 @ EXECUTE -> 9876 }T + +T{ :NONAME ( n -- 0,1,..n ) DUP IF DUP >R 1- RECURSE R> THEN ; + CONSTANT RN1 -> }T +T{ 0 RN1 EXECUTE -> 0 }T +T{ 4 RN1 EXECUTE -> 0 1 2 3 4 }T + +:NONAME ( n -- n1 ) \ Multiple RECURSEs in one definition + 1- DUP + CASE 0 OF EXIT ENDOF + 1 OF 11 SWAP RECURSE ENDOF + 2 OF 22 SWAP RECURSE ENDOF + 3 OF 33 SWAP RECURSE ENDOF + DROP ABS RECURSE EXIT + ENDCASE +; CONSTANT RN2 + +T{ 1 RN2 EXECUTE -> 0 }T +T{ 2 RN2 EXECUTE -> 11 0 }T +T{ 4 RN2 EXECUTE -> 33 22 11 0 }T +T{ 25 RN2 EXECUTE -> 33 22 11 0 }T + +\ ----------------------------------------------------------------------------- +TESTING C" + +T{ : CQ1 C" 123" ; -> }T +T{ CQ1 COUNT EVALUATE -> 123 }T +T{ : CQ2 C" " ; -> }T +T{ CQ2 COUNT EVALUATE -> }T +T{ : CQ3 C" 2345"COUNT EVALUATE ; CQ3 -> 2345 }T + +\ ----------------------------------------------------------------------------- +TESTING COMPILE, + +:NONAME DUP + ; CONSTANT DUP+ +T{ : Q DUP+ COMPILE, ; -> }T +T{ : AS1 [ Q ] ; -> }T +T{ 123 AS1 -> 246 }T + +\ ----------------------------------------------------------------------------- +\ Cannot automatically test SAVE-INPUT and RESTORE-INPUT from a console source + +TESTING SAVE-INPUT and RESTORE-INPUT with a string source + +VARIABLE SI_INC 0 SI_INC ! + +: SI1 + SI_INC @ >IN +! + 15 SI_INC ! +; + +: S$ S" SAVE-INPUT SI1 RESTORE-INPUT 12345" ; + +T{ S$ EVALUATE SI_INC @ -> 0 2345 15 }T + +\ ----------------------------------------------------------------------------- +TESTING .( + +CR CR .( Output from .() +T{ CR .( You should see -9876: ) -9876 . -> }T +T{ CR .( and again: ).( -9876)CR -> }T + +CR CR .( On the next 2 lines you should see First then Second messages:) +T{ : DOTP CR ." Second message via ." [CHAR] " EMIT \ Check .( is immediate + [ CR ] .( First message via .( ) ; DOTP -> }T +CR CR +T{ : IMM? BL WORD FIND NIP ; IMM? .( -> 1 }T + +\ ----------------------------------------------------------------------------- +TESTING .R and U.R - has to handle different cell sizes + +\ Create some large integers just below/above MAX and Min INTs +MAX-INT 73 79 */ CONSTANT LI1 +MIN-INT 71 73 */ CONSTANT LI2 + +LI1 0 <# #S #> NIP CONSTANT LENLI1 + +: (.R&U.R) ( u1 u2 -- ) \ u1 <= string length, u2 is required indentation + TUCK + >R + LI1 OVER SPACES . CR R@ LI1 SWAP .R CR + LI2 OVER SPACES . CR R@ 1+ LI2 SWAP .R CR + LI1 OVER SPACES U. CR R@ LI1 SWAP U.R CR + LI2 SWAP SPACES U. CR R> LI2 SWAP U.R CR +; + +: .R&U.R ( -- ) + CR ." You should see lines duplicated:" CR + ." indented by 0 spaces" CR 0 0 (.R&U.R) CR + ." indented by 0 spaces" CR LENLI1 0 (.R&U.R) CR \ Just fits required width + ." indented by 5 spaces" CR LENLI1 5 (.R&U.R) CR +; + +CR CR .( Output from .R and U.R) +T{ .R&U.R -> }T + +\ ----------------------------------------------------------------------------- +TESTING PAD ERASE +\ Must handle different size characters i.e. 1 CHARS >= 1 + +84 CONSTANT CHARS/PAD \ Minimum size of PAD in chars +CHARS/PAD CHARS CONSTANT AUS/PAD +: CHECKPAD ( caddr u ch -- f ) \ f = TRUE if u chars = ch + SWAP 0 + ?DO + OVER I CHARS + C@ OVER <> + IF 2DROP UNLOOP FALSE EXIT THEN + LOOP + 2DROP TRUE +; + +T{ PAD DROP -> }T +T{ 0 INVERT PAD C! -> }T +T{ PAD C@ CONSTANT MAXCHAR -> }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL MAXCHAR CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP CHARS ERASE 0 CHECKPAD -> TRUE }T +T{ PAD CHARS/PAD 2DUP MAXCHAR FILL PAD 0 ERASE MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 CHARS ERASE -> }T +T{ PAD 43 MAXCHAR CHECKPAD -> TRUE }T +T{ PAD 43 CHARS + 9 0 CHECKPAD -> TRUE }T +T{ PAD 52 CHARS + CHARS/PAD 52 - MAXCHAR CHECKPAD -> TRUE }T + +\ Check that use of WORD and pictured numeric output do not corrupt PAD +\ Minimum size of buffers for these are 33 chars and (2*n)+2 chars respectively +\ where n is number of bits per cell + +PAD CHARS/PAD ERASE +2 BASE ! +MAX-UINT MAX-UINT <# #S CHAR 1 DUP HOLD HOLD #> 2DROP +DECIMAL +BL WORD 12345678123456781234567812345678 DROP +T{ PAD CHARS/PAD 0 CHECKPAD -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING PARSE + +T{ CHAR | PARSE 1234| DUP ROT ROT EVALUATE -> 4 1234 }T +T{ CHAR ^ PARSE 23 45 ^ DUP ROT ROT EVALUATE -> 7 23 45 }T +: PA1 [CHAR] $ PARSE DUP >R PAD SWAP CHARS MOVE PAD R> ; +T{ PA1 3456 + DUP ROT ROT EVALUATE -> 4 3456 }T +T{ CHAR A PARSE A SWAP DROP -> 0 }T +T{ CHAR Z PARSE + SWAP DROP -> 0 }T +T{ CHAR " PARSE 4567 "DUP ROT ROT EVALUATE -> 5 4567 }T + +\ ----------------------------------------------------------------------------- +TESTING PARSE-NAME (Forth 2012) +\ Adapted from the PARSE-NAME RfD tests + +T{ PARSE-NAME abcd STR1 S= -> TRUE }T \ No leading spaces +T{ PARSE-NAME abcde STR2 S= -> TRUE }T \ Leading spaces + +\ Test empty parse area, new lines are necessary +T{ PARSE-NAME + NIP -> 0 }T +\ Empty parse area with spaces after PARSE-NAME +T{ PARSE-NAME + NIP -> 0 }T + +T{ : PARSE-NAME-TEST ( "name1" "name2" -- n ) + PARSE-NAME PARSE-NAME S= ; -> }T +T{ PARSE-NAME-TEST abcd abcd -> TRUE }T +T{ PARSE-NAME-TEST abcd abcd -> TRUE }T \ Leading spaces +T{ PARSE-NAME-TEST abcde abcdf -> FALSE }T +T{ PARSE-NAME-TEST abcdf abcde -> FALSE }T +T{ PARSE-NAME-TEST abcde abcde + -> TRUE }T \ Parse to end of line +T{ PARSE-NAME-TEST abcde abcde + -> TRUE }T \ Leading and trailing spaces + +\ ----------------------------------------------------------------------------- +TESTING DEFER DEFER@ DEFER! IS ACTION-OF (Forth 2012) +\ Adapted from the Forth 200X RfD tests + +T{ DEFER DEFER1 -> }T +T{ : MY-DEFER DEFER ; -> }T +T{ : IS-DEFER1 IS DEFER1 ; -> }T +T{ : ACTION-DEFER1 ACTION-OF DEFER1 ; -> }T +T{ : DEF! DEFER! ; -> }T +T{ : DEF@ DEFER@ ; -> }T + +T{ ' * ' DEFER1 DEFER! -> }T +T{ 2 3 DEFER1 -> 6 }T +T{ ' DEFER1 DEFER@ -> ' * }T +T{ ' DEFER1 DEF@ -> ' * }T +T{ ACTION-OF DEFER1 -> ' * }T +T{ ACTION-DEFER1 -> ' * }T +T{ ' + IS DEFER1 -> }T +T{ 1 2 DEFER1 -> 3 }T +T{ ' DEFER1 DEFER@ -> ' + }T +T{ ' DEFER1 DEF@ -> ' + }T +T{ ACTION-OF DEFER1 -> ' + }T +T{ ACTION-DEFER1 -> ' + }T +T{ ' - IS-DEFER1 -> }T +T{ 1 2 DEFER1 -> -1 }T +T{ ' DEFER1 DEFER@ -> ' - }T +T{ ' DEFER1 DEF@ -> ' - }T +T{ ACTION-OF DEFER1 -> ' - }T +T{ ACTION-DEFER1 -> ' - }T + +T{ MY-DEFER DEFER2 -> }T +T{ ' DUP IS DEFER2 -> }T +T{ 1 DEFER2 -> 1 1 }T + +\ ----------------------------------------------------------------------------- +TESTING HOLDS (Forth 2012) + +: HTEST S" Testing HOLDS" ; +: HTEST2 S" works" ; +: HTEST3 S" Testing HOLDS works 123" ; +T{ 0 0 <# HTEST HOLDS #> HTEST S= -> TRUE }T +T{ 123 0 <# #S BL HOLD HTEST2 HOLDS BL HOLD HTEST HOLDS #> + HTEST3 S= -> TRUE }T +T{ : HLD HOLDS ; -> }T +T{ 0 0 <# HTEST HLD #> HTEST S= -> TRUE }T + +\ ----------------------------------------------------------------------------- +TESTING REFILL SOURCE-ID +\ REFILL and SOURCE-ID from the user input device can't be tested from a file, +\ can only be tested from a string via EVALUATE + +T{ : RF1 S" REFILL" EVALUATE ; RF1 -> FALSE }T +T{ : SID1 S" SOURCE-ID" EVALUATE ; SID1 -> -1 }T + +\ ------------------------------------------------------------------------------ +TESTING S\" (Forth 2012 compilation mode) +\ Extended the Forth 200X RfD tests +\ Note this tests the Core Ext definition of S\" which has unedfined +\ interpretation semantics. S\" in interpretation mode is tested in the tests on +\ the File-Access word set + +T{ : SSQ1 S\" abc" S" abc" S= ; -> }T \ No escapes +T{ SSQ1 -> TRUE }T +T{ : SSQ2 S\" " ; SSQ2 SWAP DROP -> 0 }T \ Empty string + +T{ : SSQ3 S\" \a\b\e\f\l\m\q\r\t\v\x0F0\x1Fa\xaBx\z\"\\" ; -> }T +T{ SSQ3 SWAP DROP -> 20 }T \ String length +T{ SSQ3 DROP C@ -> 7 }T \ \a BEL Bell +T{ SSQ3 DROP 1 CHARS + C@ -> 8 }T \ \b BS Backspace +T{ SSQ3 DROP 2 CHARS + C@ -> 27 }T \ \e ESC Escape +T{ SSQ3 DROP 3 CHARS + C@ -> 12 }T \ \f FF Form feed +T{ SSQ3 DROP 4 CHARS + C@ -> 10 }T \ \l LF Line feed +T{ SSQ3 DROP 5 CHARS + C@ -> 13 }T \ \m CR of CR/LF pair +T{ SSQ3 DROP 6 CHARS + C@ -> 10 }T \ LF of CR/LF pair +T{ SSQ3 DROP 7 CHARS + C@ -> 34 }T \ \q " Double Quote +T{ SSQ3 DROP 8 CHARS + C@ -> 13 }T \ \r CR Carriage Return +T{ SSQ3 DROP 9 CHARS + C@ -> 9 }T \ \t TAB Horizontal Tab +T{ SSQ3 DROP 10 CHARS + C@ -> 11 }T \ \v VT Vertical Tab +T{ SSQ3 DROP 11 CHARS + C@ -> 15 }T \ \x0F Given Char +T{ SSQ3 DROP 12 CHARS + C@ -> 48 }T \ 0 0 Digit follow on +T{ SSQ3 DROP 13 CHARS + C@ -> 31 }T \ \x1F Given Char +T{ SSQ3 DROP 14 CHARS + C@ -> 97 }T \ a a Hex follow on +T{ SSQ3 DROP 15 CHARS + C@ -> 171 }T \ \xaB Insensitive Given Char +T{ SSQ3 DROP 16 CHARS + C@ -> 120 }T \ x x Non hex follow on +T{ SSQ3 DROP 17 CHARS + C@ -> 0 }T \ \z NUL No Character +T{ SSQ3 DROP 18 CHARS + C@ -> 34 }T \ \" " Double Quote +T{ SSQ3 DROP 19 CHARS + C@ -> 92 }T \ \\ \ Back Slash + +\ The above does not test \n as this is a system dependent value. +\ Check it displays a new line +CR .( The next test should display:) +CR .( One line...) +CR .( another line) +T{ : SSQ4 S\" \nOne line...\nanotherLine\n" TYPE ; SSQ4 -> }T + +\ Test bare escapable characters appear as themselves +T{ : SSQ5 S\" abeflmnqrtvxz" S" abeflmnqrtvxz" S= ; SSQ5 -> TRUE }T + +T{ : SSQ6 S\" a\""2DROP 1111 ; SSQ6 -> 1111 }T \ Parsing behaviour + +T{ : SSQ7 S\" 111 : SSQ8 S\\\" 222\" EVALUATE ; SSQ8 333" EVALUATE ; -> }T +T{ SSQ7 -> 111 222 333 }T +T{ : SSQ9 S\" 11 : SSQ10 S\\\" \\x32\\x32\" EVALUATE ; SSQ10 33" EVALUATE ; -> }T +T{ SSQ9 -> 11 22 33 }T + +\ ----------------------------------------------------------------------------- +CORE-EXT-ERRORS SET-ERROR-COUNT + +CR .( End of Core Extension word tests) CR + + diff --git a/lib/forth/ans-tests/tester.fr b/lib/forth/ans-tests/tester.fr new file mode 100644 index 00000000..2cf108d6 --- /dev/null +++ b/lib/forth/ans-tests/tester.fr @@ -0,0 +1,66 @@ +\ From: John Hayes S1I +\ Subject: tester.fr +\ Date: Mon, 27 Nov 95 13:10:09 PST + +\ (C) 1995 JOHNS HOPKINS UNIVERSITY / APPLIED PHYSICS LABORATORY +\ MAY BE DISTRIBUTED FREELY AS LONG AS THIS COPYRIGHT NOTICE REMAINS. +\ VERSION 1.2 + +\ 24/11/2015 Replaced Core Ext word <> with = 0= +\ 31/3/2015 Variable #ERRORS added and incremented for each error reported. +\ 22/1/09 The words { and } have been changed to T{ and }T respectively to +\ agree with the Forth 200X file ttester.fs. This avoids clashes with +\ locals using { ... } and the FSL use of } + +HEX + +\ SET THE FOLLOWING FLAG TO TRUE FOR MORE VERBOSE OUTPUT; THIS MAY +\ ALLOW YOU TO TELL WHICH TEST CAUSED YOUR SYSTEM TO HANG. +VARIABLE VERBOSE + FALSE VERBOSE ! +\ TRUE VERBOSE ! + +: EMPTY-STACK \ ( ... -- ) EMPTY STACK: HANDLES UNDERFLOWED STACK TOO. + DEPTH ?DUP IF DUP 0< IF NEGATE 0 DO 0 LOOP ELSE 0 DO DROP LOOP THEN THEN ; + +VARIABLE #ERRORS 0 #ERRORS ! + +: ERROR \ ( C-ADDR U -- ) DISPLAY AN ERROR MESSAGE FOLLOWED BY + \ THE LINE THAT HAD THE ERROR. + CR TYPE SOURCE TYPE \ DISPLAY LINE CORRESPONDING TO ERROR + EMPTY-STACK \ THROW AWAY EVERY THING ELSE + #ERRORS @ 1 + #ERRORS ! +\ QUIT \ *** Uncomment this line to QUIT on an error +; + +VARIABLE ACTUAL-DEPTH \ STACK RECORD +CREATE ACTUAL-RESULTS 20 CELLS ALLOT + +: T{ \ ( -- ) SYNTACTIC SUGAR. + ; + +: -> \ ( ... -- ) RECORD DEPTH AND CONTENT OF STACK. + DEPTH DUP ACTUAL-DEPTH ! \ RECORD DEPTH + ?DUP IF \ IF THERE IS SOMETHING ON STACK + 0 DO ACTUAL-RESULTS I CELLS + ! LOOP \ SAVE THEM + THEN ; + +: }T \ ( ... -- ) COMPARE STACK (EXPECTED) CONTENTS WITH SAVED + \ (ACTUAL) CONTENTS. + DEPTH ACTUAL-DEPTH @ = IF \ IF DEPTHS MATCH + DEPTH ?DUP IF \ IF THERE IS SOMETHING ON THE STACK + 0 DO \ FOR EACH STACK ITEM + ACTUAL-RESULTS I CELLS + @ \ COMPARE ACTUAL WITH EXPECTED + = 0= IF S" INCORRECT RESULT: " ERROR LEAVE THEN + LOOP + THEN + ELSE \ DEPTH MISMATCH + S" WRONG NUMBER OF RESULTS: " ERROR + THEN ; + +: TESTING \ ( -- ) TALKING COMMENT. + SOURCE VERBOSE @ + IF DUP >R TYPE CR R> >IN ! + ELSE >IN ! DROP [CHAR] * EMIT + THEN ; + diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 17ddd6df..97da76e4 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -73,7 +73,7 @@ Representation: - [x] `BEGIN`, `UNTIL`, `WHILE`, `REPEAT`, `AGAIN` — compile to loops - [x] `DO`, `LOOP`, `+LOOP`, `I`, `J`, `LEAVE` — counted loops (needs a return stack) - [x] Return stack: `>R`, `R>`, `R@`, `2>R`, `2R>`, `2R@` -- [ ] Vendor John Hayes' test suite to `lib/forth/ans-tests/` +- [x] Vendor John Hayes' test suite to `lib/forth/ans-tests/` - [ ] `lib/forth/conformance.sh` + runner; `scoreboard.json` + `scoreboard.md` - [ ] Baseline: probably 30-50% Core passing after phase 3 @@ -99,6 +99,14 @@ Representation: _Newest first._ +- **Phase 3 — vendor Gerry Jackson's forth2012-test-suite.** Added + `lib/forth/ans-tests/{tester.fr, core.fr, coreexttest.fth}` from + https://github.com/gerryjackson/forth2012-test-suite (master, fetched + 2026-04-24). `tester.fr` is Hayes' `T{ ... -> ... }T` harness; `core.fr` + is the ~1000-line Core word tests; `coreexttest.fth` is Core Ext + (parked for later phases). Files are pristine — the conformance runner + (next iteration) will consume them. + - **Phase 3 — `DO`/`LOOP`/`+LOOP`/`I`/`J`/`LEAVE` + return stack words (+16).** Counted loops compile onto the same PC-driven body runner. DO emits an enter-op (pops limit+start from data stack, pushes them to rstack) and From 0e509af0a2957522136b92679ee810f425c9f2b3 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 19:13:45 +0000 Subject: [PATCH 05/25] forth: Hayes conformance runner + baseline scoreboard (165/590, 28%) --- lib/forth/conformance.sh | 169 ++++++++++++++++++++++++++++++++++++++ lib/forth/hayes-runner.sx | 135 ++++++++++++++++++++++++++++++ lib/forth/scoreboard.json | 12 +++ lib/forth/scoreboard.md | 30 +++++++ plans/forth-on-sx.md | 26 +++++- 5 files changed, 370 insertions(+), 2 deletions(-) create mode 100755 lib/forth/conformance.sh create mode 100644 lib/forth/hayes-runner.sx create mode 100644 lib/forth/scoreboard.json create mode 100644 lib/forth/scoreboard.md diff --git a/lib/forth/conformance.sh b/lib/forth/conformance.sh new file mode 100755 index 00000000..3ddf257b --- /dev/null +++ b/lib/forth/conformance.sh @@ -0,0 +1,169 @@ +#!/usr/bin/env bash +# Run the Hayes/Gerry-Jackson Core conformance suite against our Forth +# interpreter and emit scoreboard.json + scoreboard.md. +# +# Method: +# 1. Preprocess lib/forth/ans-tests/core.fr — strip \ comments, ( ... ) +# comments, and TESTING … metadata lines. +# 2. Split into chunks ending at each `}T` so an error in one test +# chunk doesn't abort the run. +# 3. Emit an SX file that exposes those chunks as a list. +# 4. Run our Forth + hayes-runner under sx_server; record pass/fail/error. + +set -e +FORTH_DIR="$(cd "$(dirname "$0")" && pwd)" +ROOT="$(cd "$FORTH_DIR/../.." && pwd)" +SX_SERVER="${SX_SERVER:-/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe}" +SOURCE="$FORTH_DIR/ans-tests/core.fr" +OUT_JSON="$FORTH_DIR/scoreboard.json" +OUT_MD="$FORTH_DIR/scoreboard.md" +TMP="$(mktemp -d)" +PREPROC="$TMP/preproc.forth" +CHUNKS_SX="$TMP/chunks.sx" + +cd "$ROOT" + +# 1. preprocess +awk ' +{ + line = $0 + # strip leading/embedded \ line comments (must be \ followed by space or EOL) + gsub(/(^|[ \t])\\([ \t].*|$)/, " ", line) + # strip ( ... ) block comments that sit on one line + gsub(/\([^)]*\)/, " ", line) + # strip TESTING … metadata lines (rest of line, incl. bare TESTING) + sub(/TESTING([ \t].*)?$/, " ", line) + print line +}' "$SOURCE" > "$PREPROC" + +# 2 + 3: split into chunks at each `}T` and emit as a SX file +# +# Cap chunks via MAX_CHUNKS env (default 590) — a small number of later +# tests enter infinite runtime loops (e.g. COUNT-BITS with unsigned wrap) +# that our bignum-based interpreter can't terminate. Raise the cap as +# those tests unblock. +MAX_CHUNKS="${MAX_CHUNKS:-590}" + +MAX_CHUNKS="$MAX_CHUNKS" python3 - "$PREPROC" "$CHUNKS_SX" <<'PY' +import os, re, sys +preproc_path, out_path = sys.argv[1], sys.argv[2] +max_chunks = int(os.environ.get("MAX_CHUNKS", "590")) +text = open(preproc_path).read() +# keep the `}T` attached to the preceding chunk +parts = re.split(r'(\}T)', text) +chunks = [] +buf = "" +for p in parts: + buf += p + if p == "}T": + s = buf.strip() + if s: + chunks.append(s) + buf = "" +if buf.strip(): + chunks.append(buf.strip()) +chunks = chunks[:max_chunks] + +def esc(s): + s = s.replace('\\', '\\\\').replace('"', '\\"') + s = s.replace('\r', ' ').replace('\n', ' ') + s = re.sub(r'\s+', ' ', s).strip() + return s + +with open(out_path, "w") as f: + f.write("(define hayes-chunks (list\n") + for c in chunks: + f.write(' "' + esc(c) + '"\n') + f.write("))\n\n") + f.write("(define\n") + f.write(" hayes-run-all\n") + f.write(" (fn\n") + f.write(" ()\n") + f.write(" (hayes-reset!)\n") + f.write(" (let ((s (hayes-boot)))\n") + f.write(" (for-each (fn (c) (hayes-run-chunk s c)) hayes-chunks))\n") + f.write(" (hayes-summary)))\n") +PY + +# 4. run it +OUT=$(printf '(epoch 1)\n(load "lib/forth/runtime.sx")\n(epoch 2)\n(load "lib/forth/reader.sx")\n(epoch 3)\n(load "lib/forth/interpreter.sx")\n(epoch 4)\n(load "lib/forth/compiler.sx")\n(epoch 5)\n(load "lib/forth/hayes-runner.sx")\n(epoch 6)\n(load "%s")\n(epoch 7)\n(eval "(hayes-run-all)")\n' "$CHUNKS_SX" \ + | timeout 180 "$SX_SERVER" 2>&1) +STATUS=$? + +SUMMARY=$(printf '%s\n' "$OUT" | awk '/^\{:pass / {print; exit}') +PASS=$(printf '%s' "$SUMMARY" | sed -n 's/.*:pass \([0-9-]*\).*/\1/p') +FAIL=$(printf '%s' "$SUMMARY" | sed -n 's/.*:fail \([0-9-]*\).*/\1/p') +ERR=$(printf '%s' "$SUMMARY" | sed -n 's/.*:error \([0-9-]*\).*/\1/p') +TOTAL=$(printf '%s' "$SUMMARY" | sed -n 's/.*:total \([0-9-]*\).*/\1/p') +CHUNK_COUNT=$(grep -c '^ "' "$CHUNKS_SX" || echo 0) +TOTAL_AVAILABLE=$(grep -c '}T' "$PREPROC" || echo 0) + +NOW="$(date -u +%Y-%m-%dT%H:%M:%SZ)" + +if [ -z "$PASS" ]; then + PASS=0; FAIL=0; ERR=0; TOTAL=0 + NOTE="runner halted before completing (timeout or SX error)" +else + NOTE="completed" +fi + +PCT=0 +if [ "$TOTAL" -gt 0 ]; then + PCT=$((PASS * 100 / TOTAL)) +fi + +cat > "$OUT_JSON" < "$OUT_MD" <\` / \`}T\` comparison mismatched. + +### Chunk cap + +\`conformance.sh\` processes the first \`\$MAX_CHUNKS\` chunks (default +**590**). Past that, \`core.fr\` ships tests that rely on unsigned +integer wrap-around (e.g. \`COUNT-BITS\` using \`BEGIN DUP WHILE … 2* +REPEAT\`), which never terminates on our bignum-based interpreter. The +cap should rise as those tests unblock — run with \`MAX_CHUNKS=639 +./conformance.sh\` once they do. +MD + +echo "$SUMMARY" +echo "Scoreboard: $OUT_JSON" +echo " $OUT_MD" + +if [ "$STATUS" -ne 0 ] && [ "$TOTAL" -eq 0 ]; then + exit 1 +fi diff --git a/lib/forth/hayes-runner.sx b/lib/forth/hayes-runner.sx new file mode 100644 index 00000000..c7515e67 --- /dev/null +++ b/lib/forth/hayes-runner.sx @@ -0,0 +1,135 @@ +;; Hayes conformance test runner. +;; Installs T{ -> }T as Forth primitives that snapshot and compare dstack, +;; plus stub TESTING / HEX / DECIMAL so the Hayes Core file can stream +;; through the interpreter without halting on unsupported metadata words. + +(define hayes-pass 0) +(define hayes-fail 0) +(define hayes-error 0) +(define hayes-start-depth 0) +(define hayes-actual (list)) +(define hayes-actual-set false) +(define hayes-failures (list)) +(define hayes-first-error "") + +(define + hayes-reset! + (fn + () + (set! hayes-pass 0) + (set! hayes-fail 0) + (set! hayes-error 0) + (set! hayes-start-depth 0) + (set! hayes-actual (list)) + (set! hayes-actual-set false) + (set! hayes-failures (list)) + (set! hayes-first-error ""))) + +(define + hayes-slice + (fn + (state base) + (let + ((n (- (forth-depth state) base))) + (if (<= n 0) (list) (take (get state "dstack") n))))) + +(define + hayes-truncate! + (fn + (state base) + (let + ((n (- (forth-depth state) base))) + (when (> n 0) (dict-set! state "dstack" (drop (get state "dstack") n)))))) + +(define + hayes-install! + (fn + (state) + (forth-def-prim! + state + "T{" + (fn + (s) + (set! hayes-start-depth (forth-depth s)) + (set! hayes-actual-set false) + (set! hayes-actual (list)))) + (forth-def-prim! + state + "->" + (fn + (s) + (set! hayes-actual (hayes-slice s hayes-start-depth)) + (set! hayes-actual-set true) + (hayes-truncate! s hayes-start-depth))) + (forth-def-prim! + state + "}T" + (fn + (s) + (let + ((expected (hayes-slice s hayes-start-depth))) + (hayes-truncate! s hayes-start-depth) + (if + (and hayes-actual-set (= expected hayes-actual)) + (set! hayes-pass (+ hayes-pass 1)) + (begin + (set! hayes-fail (+ hayes-fail 1)) + (set! + hayes-failures + (concat + hayes-failures + (list + (dict + "kind" + "fail" + "expected" + (str expected) + "actual" + (str hayes-actual)))))))))) + (forth-def-prim! state "TESTING" (fn (s) nil)) + (forth-def-prim! state "HEX" (fn (s) (dict-set! s "base" 16))) + (forth-def-prim! state "DECIMAL" (fn (s) (dict-set! s "base" 10))) + state)) + +(define + hayes-boot + (fn () (let ((s (forth-boot))) (hayes-install! s) (hayes-reset!) s))) + +;; Run a single preprocessed chunk (string of Forth source) on the shared +;; state. Catch any raised error and move on — the chunk boundary is a +;; safe resume point. +(define + hayes-run-chunk + (fn + (state src) + (guard + (err + ((= 1 1) + (begin + (set! hayes-error (+ hayes-error 1)) + (when + (= (len hayes-first-error) 0) + (set! hayes-first-error (str err))) + (dict-set! state "dstack" (list)) + (dict-set! state "rstack" (list)) + (dict-set! state "compiling" false) + (dict-set! state "current-def" nil) + (dict-set! state "cstack" (list)) + (dict-set! state "input" (list))))) + (forth-interpret state src)))) + +(define + hayes-summary + (fn + () + (dict + "pass" + hayes-pass + "fail" + hayes-fail + "error" + hayes-error + "total" + (+ (+ hayes-pass hayes-fail) hayes-error) + "first-error" + hayes-first-error))) diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json new file mode 100644 index 00000000..e1f2d9b2 --- /dev/null +++ b/lib/forth/scoreboard.json @@ -0,0 +1,12 @@ +{ + "source": "gerryjackson/forth2012-test-suite src/core.fr", + "generated_at": "2026-04-24T19:13:12Z", + "chunks_available": 638, + "chunks_fed": 590, + "total": 590, + "pass": 165, + "fail": 0, + "error": 425, + "percent": 27, + "note": "completed" +} diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md new file mode 100644 index 00000000..e4d5a468 --- /dev/null +++ b/lib/forth/scoreboard.md @@ -0,0 +1,30 @@ +# Forth Hayes Core scoreboard + +| metric | value | +| ----------------- | ----: | +| chunks available | 638 | +| chunks fed | 590 | +| total | 590 | +| pass | 165 | +| fail | 0 | +| error | 425 | +| percent | 27% | + +- **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` +- **Generated**: 2026-04-24T19:13:12Z +- **Note**: completed + +A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test +is one chunk, plus the small declaration blocks between tests). +The runner catches raised errors at chunk boundaries so one bad chunk +does not abort the rest. `error` covers chunks that raised; `fail` +covers tests whose `->` / `}T` comparison mismatched. + +### Chunk cap + +`conformance.sh` processes the first `$MAX_CHUNKS` chunks (default +**590**). Past that, `core.fr` ships tests that rely on unsigned +integer wrap-around (e.g. `COUNT-BITS` using `BEGIN DUP WHILE … 2* +REPEAT`), which never terminates on our bignum-based interpreter. The +cap should rise as those tests unblock — run with `MAX_CHUNKS=639 +./conformance.sh` once they do. diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 97da76e4..73ebbca9 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -74,8 +74,8 @@ Representation: - [x] `DO`, `LOOP`, `+LOOP`, `I`, `J`, `LEAVE` — counted loops (needs a return stack) - [x] Return stack: `>R`, `R>`, `R@`, `2>R`, `2R>`, `2R@` - [x] Vendor John Hayes' test suite to `lib/forth/ans-tests/` -- [ ] `lib/forth/conformance.sh` + runner; `scoreboard.json` + `scoreboard.md` -- [ ] Baseline: probably 30-50% Core passing after phase 3 +- [x] `lib/forth/conformance.sh` + runner; `scoreboard.json` + `scoreboard.md` +- [x] Baseline: probably 30-50% Core passing after phase 3 ### Phase 4 — strings + more Core - [ ] `S"`, `C"`, `."`, `TYPE`, `COUNT`, `CMOVE`, `FILL`, `BLANK` @@ -99,6 +99,28 @@ Representation: _Newest first._ +- **Phase 3 — Hayes conformance runner + baseline scoreboard (165/590, 28%).** + `lib/forth/conformance.sh` preprocesses `ans-tests/core.fr` (strips `\` + and `( ... )` comments + `TESTING` lines), splits the source on every + `}T` so each Hayes test plus the small declaration blocks between + them are one safe-resume chunk, and emits an SX driver that feeds + the chunks through `lib/forth/hayes-runner.sx`. The runner registers + `T{`/`->`/`}T` as Forth primitives that snapshot the dstack depth on + `T{`, record actual on `->`, compare on `}T`, and install stub + `HEX`/`DECIMAL`/`TESTING` so metadata doesn't halt the stream. Errors + raised inside a chunk are caught by `guard` and the state is reset, + so one bad test does not break the rest. Outputs + `scoreboard.json` + `scoreboard.md`. + + First-run baseline: 165 pass / 425 error / 0 fail on the first 590 + chunks. The default cap sits at 590 because `core.fr` chunks beyond + that rely on unsigned-integer wrap-around (e.g. `COUNT-BITS` with + `BEGIN DUP WHILE … 2* REPEAT`) which never terminates on our + bignum-based Forth; raise `MAX_CHUNKS` once those tests unblock. + Majority of errors are missing Phase-4 words (`RSHIFT`, `LSHIFT`, + `CELLS`, `S"`, `CHAR`, `SOURCE`, etc.) — each one implemented should + convert a cluster of errors to passes. + - **Phase 3 — vendor Gerry Jackson's forth2012-test-suite.** Added `lib/forth/ans-tests/{tester.fr, core.fr, coreexttest.fth}` from https://github.com/gerryjackson/forth2012-test-suite (master, fetched From 1c975f229d70390862933ed5898ab9e36371e1d4 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 19:45:40 +0000 Subject: [PATCH 06/25] =?UTF-8?q?forth:=20Phase=204=20strings=20=E2=80=94?= =?UTF-8?q?=20S"/C"/."/TYPE/COUNT/CMOVE/FILL/BLANK=20(+16;=20Hayes=20168/5?= =?UTF-8?q?90)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/forth/compiler.sx | 89 ++++++++++++++++++ lib/forth/runtime.sx | 167 +++++++++++++++++++++++++++++++++ lib/forth/scoreboard.json | 8 +- lib/forth/scoreboard.md | 8 +- lib/forth/tests/test-phase4.sx | 164 ++++++++++++++++++++++++++++++++ plans/forth-on-sx.md | 16 +++- 6 files changed, 443 insertions(+), 9 deletions(-) create mode 100644 lib/forth/tests/test-phase4.sx diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 5e64e0ea..6806c4ae 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -139,6 +139,50 @@ (forth-rpush s next) (dict-set! pc "v" (get (get op "target") "v")))))))))) +;; Parse input tokens until one ends in `"`. Returns joined content with +;; single spaces between tokens (emulating standard Forth S"-style parse). +(define + forth-parse-quote + (fn + (state) + (forth-parse-quote-loop state (list)))) + +(define + forth-parse-quote-loop + (fn + (state parts) + (let + ((tok (forth-next-token! state))) + (if + (nil? tok) + (forth-error state "unterminated string") + (let + ((n (len tok))) + (if + (and (> n 0) (= (substr tok (- n 1) 1) "\"")) + (let + ((final (substr tok 0 (- n 1)))) + (forth-join-parts (concat parts (list final)) " ")) + (forth-parse-quote-loop state (concat parts (list tok))))))))) + +(define + forth-join-parts + (fn + (parts sep) + (if + (= (len parts) 0) + "" + (forth-join-loop (rest parts) sep (first parts))))) + +(define + forth-join-loop + (fn + (xs sep acc) + (if + (= (len xs) 0) + acc + (forth-join-loop (rest-of xs) sep (str acc sep (first xs)))))) + (define forth-find-do (fn @@ -413,6 +457,51 @@ (for-each (fn (t) (dict-set! t "v" exit-pc)) (get marker "leaves")))))) + (forth-def-prim-imm! + state + "S\"" + (fn + (s) + (let + ((content (forth-parse-quote s))) + (if + (get s "compiling") + (let + ((addr (forth-alloc-bytes! s (len content)))) + (forth-mem-write-string! s addr content) + (forth-def-append! s (fn (ss) (forth-push ss addr))) + (forth-def-append! s (fn (ss) (forth-push ss (len content))))) + (let + ((addr (forth-alloc-bytes! s (len content)))) + (forth-mem-write-string! s addr content) + (forth-push s addr) + (forth-push s (len content))))))) + (forth-def-prim-imm! + state + "C\"" + (fn + (s) + (let + ((content (forth-parse-quote s))) + (let + ((addr (forth-alloc-bytes! s (+ 1 (len content))))) + (forth-mem-write! s addr (len content)) + (forth-mem-write-string! s (+ addr 1) content) + (if + (get s "compiling") + (forth-def-append! s (fn (ss) (forth-push ss addr))) + (forth-push s addr)))))) + (forth-def-prim-imm! + state + ".\"" + (fn + (s) + (let + ((content (forth-parse-quote s))) + (if + (get s "compiling") + (forth-def-append! s (fn (ss) (forth-emit-str ss content))) + (forth-emit-str s content))))) (forth-def-prim-imm! state "LEAVE" diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 673ba07e..059b813b 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -21,8 +21,97 @@ (dict-set! s "base" 10) (dict-set! s "vars" (dict)) (dict-set! s "cstack" (list)) + (dict-set! s "mem" (dict)) + (dict-set! s "here" 0) s))) +(define + forth-mem-write! + (fn (state addr u) (dict-set! (get state "mem") (str addr) u))) + +(define + forth-mem-read + (fn + (state addr) + (or (get (get state "mem") (str addr)) 0))) + +(define + forth-alloc-bytes! + (fn + (state n) + (let + ((addr (get state "here"))) + (dict-set! state "here" (+ addr n)) + addr))) + +(define + forth-mem-write-string! + (fn + (state addr s) + (let + ((n (len s))) + (forth-mem-write-string-loop! state addr s 0 n)))) + +(define + forth-mem-write-string-loop! + (fn + (state addr s i n) + (when + (< i n) + (begin + (forth-mem-write! state (+ addr i) (char-code (substr s i 1))) + (forth-mem-write-string-loop! state addr s (+ i 1) n))))) + +(define + forth-mem-read-string + (fn + (state addr n) + (forth-mem-read-string-loop state addr 0 n ""))) + +(define + forth-mem-read-string-loop + (fn + (state addr i n acc) + (if + (>= i n) + acc + (forth-mem-read-string-loop + state + addr + (+ i 1) + n + (str acc (char-from-code (forth-mem-read state (+ addr i)))))))) + +(define + forth-fill-loop + (fn + (state addr u char i) + (when + (< i u) + (begin + (forth-mem-write! state (+ addr i) char) + (forth-fill-loop state addr u char (+ i 1)))))) + +(define + forth-cmove-loop + (fn + (state src dst u i) + (when + (< i u) + (begin + (forth-mem-write! state (+ dst i) (forth-mem-read state (+ src i))) + (forth-cmove-loop state src dst u (+ i 1)))))) + +(define + forth-cmove-loop-desc + (fn + (state src dst u i) + (when + (>= i 0) + (begin + (forth-mem-write! state (+ dst i) (forth-mem-read state (+ src i))) + (forth-cmove-loop-desc state src dst u (- i 1)))))) + (define forth-cpush (fn (state v) (dict-set! state "cstack" (cons v (get state "cstack"))))) @@ -487,4 +576,82 @@ (forth-error s "return stack underflow")) (forth-push s (nth rs 1)) (forth-push s (nth rs 0))))) + (forth-def-prim! + state + "C@" + (fn + (s) + (let ((addr (forth-pop s))) (forth-push s (forth-mem-read s addr))))) + (forth-def-prim! + state + "C!" + (fn + (s) + (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 "CHARS" (fn (s) nil)) + (forth-def-prim! + state + "TYPE" + (fn + (s) + (let + ((u (forth-pop s)) (addr (forth-pop s))) + (forth-emit-str s (forth-mem-read-string s addr u))))) + (forth-def-prim! + state + "COUNT" + (fn + (s) + (let + ((addr (forth-pop s))) + (let + ((u (forth-mem-read s addr))) + (forth-push s (+ addr 1)) + (forth-push s u))))) + (forth-def-prim! + state + "FILL" + (fn + (s) + (let + ((char (forth-pop s)) (u (forth-pop s)) (addr (forth-pop s))) + (forth-fill-loop s addr u char 0)))) + (forth-def-prim! + state + "BLANK" + (fn + (s) + (let + ((u (forth-pop s)) (addr (forth-pop s))) + (forth-fill-loop s addr u 32 0)))) + (forth-def-prim! + state + "CMOVE" + (fn + (s) + (let + ((u (forth-pop s)) (dst (forth-pop s)) (src (forth-pop s))) + (forth-cmove-loop s src dst u 0)))) + (forth-def-prim! + state + "CMOVE>" + (fn + (s) + (let + ((u (forth-pop s)) (dst (forth-pop s)) (src (forth-pop s))) + (forth-cmove-loop-desc s src dst u (- u 1))))) + (forth-def-prim! + state + "MOVE" + (fn + (s) + (let + ((u (forth-pop s)) (dst (forth-pop s)) (src (forth-pop s))) + (if + (or (<= dst src) (>= dst (+ src u))) + (forth-cmove-loop s src dst u 0) + (forth-cmove-loop-desc s src dst u (- u 1)))))) state)) diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index e1f2d9b2..bc7449e5 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-24T19:13:12Z", + "generated_at": "2026-04-24T19:45:15Z", "chunks_available": 638, "chunks_fed": 590, "total": 590, - "pass": 165, + "pass": 168, "fail": 0, - "error": 425, - "percent": 27, + "error": 422, + "percent": 28, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index e4d5a468..5cd55b41 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 590 | | total | 590 | -| pass | 165 | +| pass | 168 | | fail | 0 | -| error | 425 | -| percent | 27% | +| error | 422 | +| percent | 28% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-24T19:13:12Z +- **Generated**: 2026-04-24T19:45:15Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase4.sx b/lib/forth/tests/test-phase4.sx new file mode 100644 index 00000000..0c9816cd --- /dev/null +++ b/lib/forth/tests/test-phase4.sx @@ -0,0 +1,164 @@ +;; Phase 4 — strings + more Core. +;; Uses the byte-memory model on state ("mem" dict + "here" cursor). + +(define forth-p4-passed 0) +(define forth-p4-failed 0) +(define forth-p4-failures (list)) + +(define + forth-p4-assert + (fn + (label expected actual) + (if + (= expected actual) + (set! forth-p4-passed (+ forth-p4-passed 1)) + (begin + (set! forth-p4-failed (+ forth-p4-failed 1)) + (set! + forth-p4-failures + (concat + forth-p4-failures + (list + (str label ": expected " (str expected) " got " (str actual))))))))) + +(define + forth-p4-check-output + (fn + (label src expected) + (let ((r (forth-run src))) (forth-p4-assert label expected (nth r 1))))) + +(define + forth-p4-check-stack-size + (fn + (label src expected-n) + (let + ((r (forth-run src))) + (forth-p4-assert label expected-n (len (nth r 2)))))) + +(define + forth-p4-check-top + (fn + (label src expected) + (let + ((r (forth-run src))) + (let + ((stk (nth r 2))) + (forth-p4-assert label expected (nth stk (- (len stk) 1))))))) + +(define + forth-p4-check-typed + (fn + (label src expected) + (forth-p4-check-output label (str src " TYPE") expected))) + +(define + forth-p4-string-tests + (fn + () + (forth-p4-check-typed + "S\" + TYPE — hello" + "S\" HELLO\"" + "HELLO") + (forth-p4-check-typed + "S\" + TYPE — two words" + "S\" HELLO WORLD\"" + "HELLO WORLD") + (forth-p4-check-typed + "S\" + TYPE — empty" + "S\" \"" + "") + (forth-p4-check-typed + "S\" + TYPE — single char" + "S\" X\"" + "X") + (forth-p4-check-stack-size + "S\" pushes (addr len)" + "S\" HI\"" + 2) + (forth-p4-check-top + "S\" length is correct" + "S\" HELLO\"" + 5) + (forth-p4-check-output + ".\" prints at interpret time" + ".\" HELLO\"" + "HELLO") + (forth-p4-check-output + ".\" in colon def" + ": GREET .\" HI \" ; GREET GREET" + "HI HI "))) + +(define + forth-p4-count-tests + (fn + () + (forth-p4-check-typed + "C\" + COUNT + TYPE" + "C\" ABC\" COUNT" + "ABC") + (forth-p4-check-typed + "C\" then COUNT leaves right len" + "C\" HI THERE\" COUNT" + "HI THERE"))) + +(define + forth-p4-fill-tests + (fn + () + (forth-p4-check-typed + "FILL overwrites prefix bytes" + "S\" ABCDE\" 2DUP DROP 3 65 FILL" + "AAADE") + (forth-p4-check-typed + "BLANK sets spaces" + "S\" XYZAB\" 2DUP DROP 3 BLANK" + " AB"))) + +(define + forth-p4-cmove-tests + (fn + () + (forth-p4-check-output + "CMOVE copies HELLO forward" + ": MKH 72 0 C! 69 1 C! 76 2 C! 76 3 C! 79 4 C! ; + : T MKH 0 10 5 CMOVE 10 5 TYPE ; T" + "HELLO") + (forth-p4-check-output + "CMOVE> copies overlapping backward" + ": MKA 65 0 C! 66 1 C! 67 2 C! ; + : T MKA 0 1 2 CMOVE> 0 3 TYPE ; T" + "AAB") + (forth-p4-check-output + "MOVE picks direction for overlap" + ": MKA 65 0 C! 66 1 C! 67 2 C! ; + : T MKA 0 1 2 MOVE 0 3 TYPE ; T" + "AAB"))) + +(define + forth-p4-charplus-tests + (fn + () + (forth-p4-check-top + "CHAR+ increments" + "5 CHAR+" + 6))) + +(define + forth-p4-run-all + (fn + () + (set! forth-p4-passed 0) + (set! forth-p4-failed 0) + (set! forth-p4-failures (list)) + (forth-p4-string-tests) + (forth-p4-count-tests) + (forth-p4-fill-tests) + (forth-p4-cmove-tests) + (forth-p4-charplus-tests) + (dict + "passed" + forth-p4-passed + "failed" + forth-p4-failed + "failures" + forth-p4-failures))) diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 73ebbca9..4539fbb3 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -78,7 +78,7 @@ Representation: - [x] Baseline: probably 30-50% Core passing after phase 3 ### Phase 4 — strings + more Core -- [ ] `S"`, `C"`, `."`, `TYPE`, `COUNT`, `CMOVE`, `FILL`, `BLANK` +- [x] `S"`, `C"`, `."`, `TYPE`, `COUNT`, `CMOVE`, `FILL`, `BLANK` - [ ] `CHAR`, `[CHAR]`, `KEY`, `ACCEPT` - [ ] `BASE` manipulation: `DECIMAL`, `HEX` - [ ] `DEPTH`, `SP@`, `SP!` @@ -99,6 +99,20 @@ Representation: _Newest first._ +- **Phase 4 — strings: `S"`/`C"`/`."`/`TYPE`/`COUNT`/`CMOVE`/`CMOVE>`/`MOVE`/`FILL`/`BLANK`/`C@`/`C!`/`CHAR+`/`CHARS` (+16 / Hayes 165→168).** + Added a byte-addressable memory model to state: `mem` (dict keyed by + stringified address → integer byte) and `here` (next-free integer + addr). Helpers `forth-alloc-bytes!` / `forth-mem-write-string!` / + `forth-mem-read-string`. `S"`/`C"`/`."` are IMMEDIATE parsing words + that consume tokens until one ends with `"`, then either copy content + into memory at compile time (and emit a push of `addr`/`addr len` for + the colon-def body) or do it inline in interpret mode. `TYPE` emits + `u` bytes from `addr` via `char-from-code`. `COUNT` reads the length + byte at a counted-string address and pushes (`addr+1`, `u`). `FILL`, + `BLANK` (FILL with space), `CMOVE` (forward), `CMOVE>` (backward), + and `MOVE` (auto-directional) mutate the byte dict. 193/193 internal + tests, Hayes 168/590 (+3). + - **Phase 3 — Hayes conformance runner + baseline scoreboard (165/590, 28%).** `lib/forth/conformance.sh` preprocesses `ans-tests/core.fr` (strips `\` and `( ... )` comments + `TESTING` lines), splits the source on every From 35ce18eb976f2f369b4cf2e2fceba62649ab0d7d Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 20:12:31 +0000 Subject: [PATCH 07/25] forth: CHAR/[CHAR]/KEY/ACCEPT (+7; Hayes 174/590) --- lib/forth/compiler.sx | 50 ++++++++++++++++++++++++++++++++++ lib/forth/scoreboard.json | 8 +++--- lib/forth/scoreboard.md | 8 +++--- lib/forth/tests/test-phase4.sx | 30 ++++++++++++++++++++ plans/forth-on-sx.md | 11 +++++++- 5 files changed, 98 insertions(+), 9 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 6806c4ae..6083c7dc 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -457,6 +457,56 @@ (for-each (fn (t) (dict-set! t "v" exit-pc)) (get marker "leaves")))))) + (forth-def-prim! + state + "CHAR" + (fn + (s) + (let + ((tok (forth-next-token! s))) + (when (nil? tok) (forth-error s "CHAR expects a word")) + (forth-push s (char-code (substr tok 0 1)))))) + (forth-def-prim-imm! + state + "[CHAR]" + (fn + (s) + (let + ((tok (forth-next-token! s))) + (when (nil? tok) (forth-error s "[CHAR] expects a word")) + (let + ((c (char-code (substr tok 0 1)))) + (if + (get s "compiling") + (forth-def-append! s (fn (ss) (forth-push ss c))) + (forth-push s c)))))) + (forth-def-prim! + state + "KEY" + (fn + (s) + (let + ((kb (or (get s "keybuf") ""))) + (if + (= (len kb) 0) + (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)))))))) + (forth-def-prim! + state + "ACCEPT" + (fn + (s) + (let + ((n1 (forth-pop s)) (addr (forth-pop s))) + (let + ((kb (or (get s "keybuf") ""))) + (let + ((n (if (< n1 (len kb)) n1 (len kb)))) + (forth-mem-write-string! s addr (substr kb 0 n)) + (dict-set! s "keybuf" (substr kb n (- (len kb) n))) + (forth-push s n)))))) (forth-def-prim-imm! state "S\"" diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index bc7449e5..452083a3 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-24T19:45:15Z", + "generated_at": "2026-04-24T20:12:09Z", "chunks_available": 638, "chunks_fed": 590, "total": 590, - "pass": 168, + "pass": 174, "fail": 0, - "error": 422, - "percent": 28, + "error": 416, + "percent": 29, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 5cd55b41..989c08f6 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 590 | | total | 590 | -| pass | 168 | +| pass | 174 | | fail | 0 | -| error | 422 | -| percent | 28% | +| error | 416 | +| percent | 29% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-24T19:45:15Z +- **Generated**: 2026-04-24T20:12:09Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase4.sx b/lib/forth/tests/test-phase4.sx index 0c9816cd..5bdcce97 100644 --- a/lib/forth/tests/test-phase4.sx +++ b/lib/forth/tests/test-phase4.sx @@ -143,6 +143,34 @@ "5 CHAR+" 6))) +(define + forth-p4-char-tests + (fn + () + (forth-p4-check-top "CHAR A -> 65" "CHAR A" 65) + (forth-p4-check-top "CHAR x -> 120" "CHAR x" 120) + (forth-p4-check-top "CHAR takes only first char" "CHAR HELLO" 72) + (forth-p4-check-top + "[CHAR] compiles literal" + ": AA [CHAR] A ; AA" + 65) + (forth-p4-check-top + "[CHAR] reads past IMMEDIATE" + ": ZZ [CHAR] Z ; ZZ" + 90) + (forth-p4-check-stack-size + "[CHAR] doesn't leak at compile time" + ": FOO [CHAR] A ; " + 0))) + +(define + forth-p4-key-accept-tests + (fn + () + (let + ((r (forth-run "1000 2 ACCEPT"))) + (let ((stk (nth r 2))) (forth-p4-assert "ACCEPT empty buf -> 0" (list 0) stk))))) + (define forth-p4-run-all (fn @@ -155,6 +183,8 @@ (forth-p4-fill-tests) (forth-p4-cmove-tests) (forth-p4-charplus-tests) + (forth-p4-char-tests) + (forth-p4-key-accept-tests) (dict "passed" forth-p4-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 4539fbb3..850ea9e7 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -79,7 +79,7 @@ Representation: ### Phase 4 — strings + more Core - [x] `S"`, `C"`, `."`, `TYPE`, `COUNT`, `CMOVE`, `FILL`, `BLANK` -- [ ] `CHAR`, `[CHAR]`, `KEY`, `ACCEPT` +- [x] `CHAR`, `[CHAR]`, `KEY`, `ACCEPT` - [ ] `BASE` manipulation: `DECIMAL`, `HEX` - [ ] `DEPTH`, `SP@`, `SP!` - [ ] Drive Hayes Core pass-rate up @@ -99,6 +99,15 @@ Representation: _Newest first._ +- **Phase 4 — `CHAR`/`[CHAR]`/`KEY`/`ACCEPT` (+7 / Hayes 168→174).** + `CHAR` parses the next token and pushes the first-char code. `[CHAR]` + is IMMEDIATE: in compile mode it embeds the code as a compiled push + op, in interpret mode it pushes inline. `KEY`/`ACCEPT` read from an + optional `state.keybuf` string — empty buffer makes `KEY` raise + `"no input available"` (matches ANS when stdin is closed) and + `ACCEPT` returns `0`. Enough for Hayes to get past CHAR-gated + clusters; real interactive IO lands later. + - **Phase 4 — strings: `S"`/`C"`/`."`/`TYPE`/`COUNT`/`CMOVE`/`CMOVE>`/`MOVE`/`FILL`/`BLANK`/`C@`/`C!`/`CHAR+`/`CHARS` (+16 / Hayes 165→168).** Added a byte-addressable memory model to state: `mem` (dict keyed by stringified address → integer byte) and `here` (next-free integer From acf9c273a25b0e70b7da3dc6bfd8db73ce5dd3b7 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 20:40:11 +0000 Subject: [PATCH 08/25] forth: BASE/DECIMAL/HEX/BIN/OCTAL (+9; Hayes 174/590) --- lib/forth/compiler.sx | 4 ++-- lib/forth/hayes-runner.sx | 3 +-- lib/forth/interpreter.sx | 2 +- lib/forth/runtime.sx | 19 ++++++++++++++- lib/forth/scoreboard.json | 2 +- lib/forth/scoreboard.md | 2 +- lib/forth/tests/test-phase4.sx | 42 ++++++++++++++++++++++++++++++++++ plans/forth-on-sx.md | 11 ++++++++- 8 files changed, 76 insertions(+), 9 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 6083c7dc..6eb00545 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -24,7 +24,7 @@ (forth-execute-word state w) (forth-compile-call state tok)) (let - ((n (forth-parse-number tok (get state "base")))) + ((n (forth-parse-number tok (get (get state "vars") "base")))) (if (not (nil? n)) (forth-compile-lit state n) @@ -219,7 +219,7 @@ (not (nil? w)) (forth-execute-word state w) (let - ((n (forth-parse-number tok (get state "base")))) + ((n (forth-parse-number tok (get (get state "vars") "base")))) (if (not (nil? n)) (forth-push state n) diff --git a/lib/forth/hayes-runner.sx b/lib/forth/hayes-runner.sx index c7515e67..22f22447 100644 --- a/lib/forth/hayes-runner.sx +++ b/lib/forth/hayes-runner.sx @@ -87,8 +87,7 @@ "actual" (str hayes-actual)))))))))) (forth-def-prim! state "TESTING" (fn (s) nil)) - (forth-def-prim! state "HEX" (fn (s) (dict-set! s "base" 16))) - (forth-def-prim! state "DECIMAL" (fn (s) (dict-set! s "base" 10))) + ;; HEX/DECIMAL are real primitives now (runtime.sx) — no stub needed. state)) (define diff --git a/lib/forth/interpreter.sx b/lib/forth/interpreter.sx index d019993e..4ffba3f1 100644 --- a/lib/forth/interpreter.sx +++ b/lib/forth/interpreter.sx @@ -17,7 +17,7 @@ (not (nil? w)) (forth-execute-word state w) (let - ((n (forth-parse-number tok (get state "base")))) + ((n (forth-parse-number tok (get (get state "vars") "base")))) (if (not (nil? n)) (forth-push state n) diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 059b813b..3eecbf8c 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -18,8 +18,8 @@ (dict-set! s "output" "") (dict-set! s "compiling" false) (dict-set! s "current-def" nil) - (dict-set! s "base" 10) (dict-set! s "vars" (dict)) + (dict-set! (get s "vars") "base" 10) (dict-set! s "cstack" (list)) (dict-set! s "mem" (dict)) (dict-set! s "here" 0) @@ -538,6 +538,23 @@ (> n 0) (for-each (fn (_) (forth-emit-str s " ")) (range 0 n)))))) (forth-def-prim! state "BL" (fn (s) (forth-push s 32))) + (forth-def-prim! + state + "DECIMAL" + (fn (s) (dict-set! (get s "vars") "base" 10))) + (forth-def-prim! + state + "HEX" + (fn (s) (dict-set! (get s "vars") "base" 16))) + (forth-def-prim! + state + "BIN" + (fn (s) (dict-set! (get s "vars") "base" 2))) + (forth-def-prim! + state + "OCTAL" + (fn (s) (dict-set! (get s "vars") "base" 8))) + (forth-def-prim! state "BASE" (fn (s) (forth-push s "base"))) (forth-def-prim! state "I" (fn (s) (forth-push s (forth-rpeek s)))) (forth-def-prim! state diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 452083a3..351d8517 100644 --- a/lib/forth/scoreboard.json +++ b/lib/forth/scoreboard.json @@ -1,6 +1,6 @@ { "source": "gerryjackson/forth2012-test-suite src/core.fr", - "generated_at": "2026-04-24T20:12:09Z", + "generated_at": "2026-04-24T20:39:51Z", "chunks_available": 638, "chunks_fed": 590, "total": 590, diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 989c08f6..d22e89ac 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -11,7 +11,7 @@ | percent | 29% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-24T20:12:09Z +- **Generated**: 2026-04-24T20:39:51Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase4.sx b/lib/forth/tests/test-phase4.sx index 5bdcce97..3bb3e8fc 100644 --- a/lib/forth/tests/test-phase4.sx +++ b/lib/forth/tests/test-phase4.sx @@ -171,6 +171,47 @@ ((r (forth-run "1000 2 ACCEPT"))) (let ((stk (nth r 2))) (forth-p4-assert "ACCEPT empty buf -> 0" (list 0) stk))))) +(define + forth-p4-base-tests + (fn + () + (forth-p4-check-top + "BASE default is 10" + "BASE @" + 10) + (forth-p4-check-top + "HEX switches base to 16" + "HEX BASE @" + 16) + (forth-p4-check-top + "DECIMAL resets to 10" + "HEX DECIMAL BASE @" + 10) + (forth-p4-check-top + "HEX parses 10 as 16" + "HEX 10" + 16) + (forth-p4-check-top + "HEX parses FF as 255" + "HEX FF" + 255) + (forth-p4-check-top + "DECIMAL parses 10 as 10" + "HEX DECIMAL 10" + 10) + (forth-p4-check-top + "BIN parses 1010 as 10" + "BIN 1010" + 10) + (forth-p4-check-top + "OCTAL parses 17 as 15" + "OCTAL 17" + 15) + (forth-p4-check-top + "BASE @ ; 16 BASE ! ; BASE @" + "BASE @ 16 BASE ! BASE @ SWAP DROP" + 16))) + (define forth-p4-run-all (fn @@ -185,6 +226,7 @@ (forth-p4-charplus-tests) (forth-p4-char-tests) (forth-p4-key-accept-tests) + (forth-p4-base-tests) (dict "passed" forth-p4-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 850ea9e7..13c2616c 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -80,7 +80,7 @@ Representation: ### Phase 4 — strings + more Core - [x] `S"`, `C"`, `."`, `TYPE`, `COUNT`, `CMOVE`, `FILL`, `BLANK` - [x] `CHAR`, `[CHAR]`, `KEY`, `ACCEPT` -- [ ] `BASE` manipulation: `DECIMAL`, `HEX` +- [x] `BASE` manipulation: `DECIMAL`, `HEX` - [ ] `DEPTH`, `SP@`, `SP!` - [ ] Drive Hayes Core pass-rate up @@ -99,6 +99,15 @@ Representation: _Newest first._ +- **Phase 4 — `BASE`/`DECIMAL`/`HEX`/`BIN`/`OCTAL` (+9; Hayes unchanged).** + Moved `base` from its top-level state slot into `state.vars["base"]` + so the regular `@`/`!`/VARIABLE machinery works on it. + `BASE` pushes the sentinel address `"base"`; `DECIMAL`/`HEX`/`BIN`/ + `OCTAL` are thin primitives that write into that slot. Parser + reads through `vars` now. Hayes unchanged because the runner had + already been stubbing `HEX`/`DECIMAL` — now real words, stubs + removed from `hayes-runner.sx`. + - **Phase 4 — `CHAR`/`[CHAR]`/`KEY`/`ACCEPT` (+7 / Hayes 168→174).** `CHAR` parses the next token and pushes the first-char code. `[CHAR]` is IMMEDIATE: in compile mode it embeds the code as a compiled push From 387a6e7f5d431bee6a3b067d69234e2060251f40 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 21:07:10 +0000 Subject: [PATCH 09/25] forth: SP@ / SP! (+4; Hayes 174/590) --- lib/forth/runtime.sx | 13 +++++++++++++ lib/forth/scoreboard.json | 2 +- lib/forth/scoreboard.md | 2 +- lib/forth/tests/test-phase4.sx | 19 +++++++++++++++++++ plans/forth-on-sx.md | 9 ++++++++- 5 files changed, 42 insertions(+), 3 deletions(-) diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 3eecbf8c..4ab5b6f8 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -393,6 +393,19 @@ (s) (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! + state + "SP!" + (fn + (s) + (let + ((n (forth-pop s))) + (let + ((cur (forth-depth s))) + (when + (> cur n) + (dict-set! s "dstack" (drop (get s "dstack") (- cur n)))))))) (forth-def-prim! state "PICK" diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 351d8517..4cdbcb0d 100644 --- a/lib/forth/scoreboard.json +++ b/lib/forth/scoreboard.json @@ -1,6 +1,6 @@ { "source": "gerryjackson/forth2012-test-suite src/core.fr", - "generated_at": "2026-04-24T20:39:51Z", + "generated_at": "2026-04-24T21:06:54Z", "chunks_available": 638, "chunks_fed": 590, "total": 590, diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index d22e89ac..9ccebb0a 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -11,7 +11,7 @@ | percent | 29% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-24T20:39:51Z +- **Generated**: 2026-04-24T21:06:54Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase4.sx b/lib/forth/tests/test-phase4.sx index 3bb3e8fc..1e24785a 100644 --- a/lib/forth/tests/test-phase4.sx +++ b/lib/forth/tests/test-phase4.sx @@ -171,6 +171,24 @@ ((r (forth-run "1000 2 ACCEPT"))) (let ((stk (nth r 2))) (forth-p4-assert "ACCEPT empty buf -> 0" (list 0) stk))))) +(define + forth-p4-sp-tests + (fn + () + (forth-p4-check-top "SP@ returns depth (0)" "SP@" 0) + (forth-p4-check-top + "SP@ after pushes" + "1 2 3 SP@ SWAP DROP SWAP DROP SWAP DROP" + 3) + (forth-p4-check-stack-size + "SP! truncates" + "1 2 3 4 5 2 SP!" + 2) + (forth-p4-check-top + "SP! leaves base items intact" + "1 2 3 4 5 2 SP!" + 2))) + (define forth-p4-base-tests (fn @@ -227,6 +245,7 @@ (forth-p4-char-tests) (forth-p4-key-accept-tests) (forth-p4-base-tests) + (forth-p4-sp-tests) (dict "passed" forth-p4-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 13c2616c..a67dd360 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -81,7 +81,7 @@ Representation: - [x] `S"`, `C"`, `."`, `TYPE`, `COUNT`, `CMOVE`, `FILL`, `BLANK` - [x] `CHAR`, `[CHAR]`, `KEY`, `ACCEPT` - [x] `BASE` manipulation: `DECIMAL`, `HEX` -- [ ] `DEPTH`, `SP@`, `SP!` +- [x] `DEPTH`, `SP@`, `SP!` - [ ] Drive Hayes Core pass-rate up ### Phase 5 — Core Extension + optional word sets @@ -99,6 +99,13 @@ Representation: _Newest first._ +- **Phase 4 — `SP@`/`SP!` (+4; Hayes unchanged; `DEPTH` was already present).** + `SP@` pushes the current data-stack depth (our closest analogue to a + stack pointer — SX lists have no addressable backing). `SP!` pops a + target depth and truncates the stack via `drop` on the dstack list. + This preserves the save/restore idiom `SP@ … SP!` even though the + returned "pointer" is really a count. + - **Phase 4 — `BASE`/`DECIMAL`/`HEX`/`BIN`/`OCTAL` (+9; Hayes unchanged).** Moved `base` from its top-level state slot into `state.vars["base"]` so the regular `@`/`!`/VARIABLE machinery works on it. From 8e1466032adbf2098e1f03666069837e7c4b040d Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 22:26:58 +0000 Subject: [PATCH 10/25] =?UTF-8?q?forth:=20LSHIFT/RSHIFT=20+=2032-bit=20ari?= =?UTF-8?q?th=20truncation=20+=20early=20binding=20(Hayes=20174=E2=86=9226?= =?UTF-8?q?8)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/forth/compiler.sx | 29 +++++++++++++- lib/forth/conformance.sh | 17 ++++----- lib/forth/runtime.sx | 70 +++++++++++++++++++++++++++------- lib/forth/scoreboard.json | 14 +++---- lib/forth/scoreboard.md | 22 +++++------ lib/forth/tests/test-phase4.sx | 17 +++++++++ plans/forth-on-sx.md | 19 ++++++++- 7 files changed, 143 insertions(+), 45 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 6eb00545..79cbba8e 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -30,12 +30,37 @@ (forth-compile-lit state n) (forth-error state (str tok " ?")))))))) +;; Resolve the word NOW (early binding) so that `: X X ;` compiles a call +;; to the prior X — matching standard Forth redefinition semantics. +;; RECURSE is the one exception: it stays late-bound against the not-yet- +;; installed current definition. (define forth-compile-call (fn (state name) (let - ((op (fn (s) (let ((w (forth-lookup s name))) (if (nil? w) (forth-error s (str name " ? (compiled)")) (forth-execute-word s w)))))) + ((w (forth-lookup state name))) + (if + (nil? w) + (forth-error state (str name " ?")) + (let + ((op (fn (s) (forth-execute-word s w)))) + (forth-def-append! state op)))))) + +(define + forth-compile-recurse + (fn + (state name) + (let + ((op + (fn + (s) + (let + ((w (forth-lookup s name))) + (if + (nil? w) + (forth-error s (str "RECURSE: " name " not yet installed")) + (forth-execute-word s w)))))) (forth-def-append! state op)))) (define @@ -287,7 +312,7 @@ (forth-error s "RECURSE only in definition")) (let ((name (get (get s "current-def") "name"))) - (forth-compile-call s name)))) + (forth-compile-recurse s name)))) (forth-def-prim-imm! state "IF" diff --git a/lib/forth/conformance.sh b/lib/forth/conformance.sh index 3ddf257b..6a8c5d04 100755 --- a/lib/forth/conformance.sh +++ b/lib/forth/conformance.sh @@ -38,11 +38,10 @@ awk ' # 2 + 3: split into chunks at each `}T` and emit as a SX file # -# Cap chunks via MAX_CHUNKS env (default 590) — a small number of later -# tests enter infinite runtime loops (e.g. COUNT-BITS with unsigned wrap) -# that our bignum-based interpreter can't terminate. Raise the cap as -# those tests unblock. -MAX_CHUNKS="${MAX_CHUNKS:-590}" +# Cap chunks via MAX_CHUNKS env (default 638 = full Hayes Core). Lower +# it temporarily if later tests regress into an infinite loop while you +# are iterating on primitives. +MAX_CHUNKS="${MAX_CHUNKS:-638}" MAX_CHUNKS="$MAX_CHUNKS" python3 - "$PREPROC" "$CHUNKS_SX" <<'PY' import os, re, sys @@ -153,11 +152,9 @@ covers tests whose \`->\` / \`}T\` comparison mismatched. ### Chunk cap \`conformance.sh\` processes the first \`\$MAX_CHUNKS\` chunks (default -**590**). Past that, \`core.fr\` ships tests that rely on unsigned -integer wrap-around (e.g. \`COUNT-BITS\` using \`BEGIN DUP WHILE … 2* -REPEAT\`), which never terminates on our bignum-based interpreter. The -cap should rise as those tests unblock — run with \`MAX_CHUNKS=639 -./conformance.sh\` once they do. +**638**, i.e. the whole Hayes Core file). Lower the cap temporarily +while iterating on primitives if a regression re-opens an infinite +loop in later tests. MD echo "$SUMMARY" diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 4ab5b6f8..d918cf3d 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -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 "." diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 4cdbcb0d..532be043 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-24T21:06:54Z", + "generated_at": "2026-04-24T22:26:31Z", "chunks_available": 638, - "chunks_fed": 590, - "total": 590, - "pass": 174, - "fail": 0, - "error": 416, - "percent": 29, + "chunks_fed": 638, + "total": 638, + "pass": 268, + "fail": 2, + "error": 368, + "percent": 42, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 9ccebb0a..1ffdc4ca 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -3,15 +3,15 @@ | metric | value | | ----------------- | ----: | | chunks available | 638 | -| chunks fed | 590 | -| total | 590 | -| pass | 174 | -| fail | 0 | -| error | 416 | -| percent | 29% | +| chunks fed | 638 | +| total | 638 | +| pass | 268 | +| fail | 2 | +| error | 368 | +| percent | 42% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-24T21:06:54Z +- **Generated**: 2026-04-24T22:26:31Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test @@ -23,8 +23,6 @@ covers tests whose `->` / `}T` comparison mismatched. ### Chunk cap `conformance.sh` processes the first `$MAX_CHUNKS` chunks (default -**590**). Past that, `core.fr` ships tests that rely on unsigned -integer wrap-around (e.g. `COUNT-BITS` using `BEGIN DUP WHILE … 2* -REPEAT`), which never terminates on our bignum-based interpreter. The -cap should rise as those tests unblock — run with `MAX_CHUNKS=639 -./conformance.sh` once they do. +**638**, i.e. the whole Hayes Core file). Lower the cap temporarily +while iterating on primitives if a regression re-opens an infinite +loop in later tests. diff --git a/lib/forth/tests/test-phase4.sx b/lib/forth/tests/test-phase4.sx index 1e24785a..406f5bf1 100644 --- a/lib/forth/tests/test-phase4.sx +++ b/lib/forth/tests/test-phase4.sx @@ -171,6 +171,22 @@ ((r (forth-run "1000 2 ACCEPT"))) (let ((stk (nth r 2))) (forth-p4-assert "ACCEPT empty buf -> 0" (list 0) stk))))) +(define + forth-p4-shift-tests + (fn + () + (forth-p4-check-top "1 0 LSHIFT" "1 0 LSHIFT" 1) + (forth-p4-check-top "1 1 LSHIFT" "1 1 LSHIFT" 2) + (forth-p4-check-top "1 2 LSHIFT" "1 2 LSHIFT" 4) + (forth-p4-check-top "1 15 LSHIFT" "1 15 LSHIFT" 32768) + (forth-p4-check-top "1 31 LSHIFT" "1 31 LSHIFT" -2147483648) + (forth-p4-check-top "1 0 RSHIFT" "1 0 RSHIFT" 1) + (forth-p4-check-top "1 1 RSHIFT" "1 1 RSHIFT" 0) + (forth-p4-check-top "2 1 RSHIFT" "2 1 RSHIFT" 1) + (forth-p4-check-top "4 2 RSHIFT" "4 2 RSHIFT" 1) + (forth-p4-check-top "-1 1 RSHIFT (logical, not arithmetic)" "-1 1 RSHIFT" 2147483647) + (forth-p4-check-top "MSB via 1S 1 RSHIFT INVERT" "0 INVERT 1 RSHIFT INVERT" -2147483648))) + (define forth-p4-sp-tests (fn @@ -245,6 +261,7 @@ (forth-p4-char-tests) (forth-p4-key-accept-tests) (forth-p4-base-tests) + (forth-p4-shift-tests) (forth-p4-sp-tests) (dict "passed" diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index a67dd360..da4908fd 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -82,7 +82,7 @@ Representation: - [x] `CHAR`, `[CHAR]`, `KEY`, `ACCEPT` - [x] `BASE` manipulation: `DECIMAL`, `HEX` - [x] `DEPTH`, `SP@`, `SP!` -- [ ] Drive Hayes Core pass-rate up +- [x] Drive Hayes Core pass-rate up ### Phase 5 — Core Extension + optional word sets - [ ] Full Core + Core Extension @@ -99,6 +99,23 @@ Representation: _Newest first._ +- **Phase 4 close — LSHIFT/RSHIFT, 32-bit arith truncation, early + binding; Hayes 174→268 (42%).** Added `LSHIFT` / `RSHIFT` as logical + shifts on 32-bit unsigned values, converted through + `forth-to-unsigned`/`forth-from-unsigned`. All arithmetic + primitives (`+` `-` `*` `/` `MOD` `NEGATE` `ABS` `1+` `1-` `2+` + `2-` `2*` `2/`) now clip results to 32-bit signed via a new + `forth-clip` helper, so loop idioms that rely on `2*` shifting the + MSB out (e.g. Hayes' `BITS` counter) actually terminate. + Changed colon-def call compilation from late-binding to early + binding: `forth-compile-call` now resolves the target word at + compile time, which makes `: GDX 123 ; : GDX GDX 234 ;` behave + per ANS (inner `GDX` → old def, not infinite recursion). `RECURSE` + keeps its late-binding thunk via the new `forth-compile-recurse` + helper. Raised `MAX_CHUNKS` default to 638 (full `core.fr`) now + that the BITS and COUNT-BITS loops terminate. Hayes: 268 pass / + 368 error / 2 fail. + - **Phase 4 — `SP@`/`SP!` (+4; Hayes unchanged; `DEPTH` was already present).** `SP@` pushes the current data-stack depth (our closest analogue to a stack pointer — SX lists have no addressable backing). `SP!` pops a From 3ab01b271d82c0d30f0c498ca1ed37697c13932f Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 22:56:26 +0000 Subject: [PATCH 11/25] =?UTF-8?q?forth:=20Phase=205=20memory=20+=20unsigne?= =?UTF-8?q?d=20compare=20(Hayes=20268=E2=86=92342,=2053%)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/forth/compiler.sx | 91 +++++++++++++++++++++++++++-- lib/forth/scoreboard.json | 10 ++-- lib/forth/scoreboard.md | 10 ++-- lib/forth/tests/test-phase5.sx | 101 +++++++++++++++++++++++++++++++++ plans/forth-on-sx.md | 19 ++++++- 5 files changed, 216 insertions(+), 15 deletions(-) create mode 100644 lib/forth/tests/test-phase5.sx diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 79cbba8e..92593e7c 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -648,7 +648,10 @@ (s) (let ((addr (forth-pop s))) - (forth-push s (or (get (get s "vars") addr) 0))))) + (if + (string? addr) + (forth-push s (or (get (get s "vars") addr) 0)) + (forth-push s (forth-mem-read s addr)))))) (forth-def-prim! state "!" @@ -656,7 +659,10 @@ (s) (let ((addr (forth-pop s)) (v (forth-pop s))) - (dict-set! (get s "vars") addr v)))) + (if + (string? addr) + (dict-set! (get s "vars") addr v) + (forth-mem-write! s addr v))))) (forth-def-prim! state "+!" @@ -664,9 +670,86 @@ (s) (let ((addr (forth-pop s)) (v (forth-pop s))) + (if + (string? addr) + (let + ((cur (or (get (get s "vars") addr) 0))) + (dict-set! (get s "vars") addr (+ cur v))) + (forth-mem-write! s addr (+ (forth-mem-read s addr) v)))))) + (forth-def-prim! state "HERE" (fn (s) (forth-push s (get s "here")))) + (forth-def-prim! + state + "ALLOT" + (fn + (s) + (let + ((n (forth-pop s))) + (dict-set! s "here" (+ (get s "here") n))))) + (forth-def-prim! + state + "," + (fn + (s) + (let + ((v (forth-pop s)) (addr (forth-alloc-bytes! s 1))) + (forth-mem-write! s addr v)))) + (forth-def-prim! + state + "C," + (fn + (s) + (let + ((v (forth-pop s)) (addr (forth-alloc-bytes! s 1))) + (forth-mem-write! s addr v)))) + (forth-def-prim! + state + "CREATE" + (fn + (s) + (let + ((name (forth-next-token! s))) + (when (nil? name) (forth-error s "CREATE expects name")) (let - ((cur (or (get (get s "vars") addr) 0))) - (dict-set! (get s "vars") addr (+ cur v)))))) + ((addr (get s "here"))) + (forth-def-prim! s name (fn (ss) (forth-push ss addr))))))) + (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)) + (forth-def-prim! + state + "U<" + (forth-cmp + (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))))) + (forth-def-prim! + state + "2@" + (fn + (s) + (let + ((addr (forth-pop s))) + (if + (string? addr) + (forth-error s "2@ on var unsupported") + (begin + (forth-push s (forth-mem-read s (+ addr 1))) + (forth-push s (forth-mem-read s addr))))))) + (forth-def-prim! + state + "2!" + (fn + (s) + (let + ((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. diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 532be043..83991a0f 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-24T22:26:31Z", + "generated_at": "2026-04-24T22:54:53Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, - "pass": 268, - "fail": 2, - "error": 368, - "percent": 42, + "pass": 342, + "fail": 4, + "error": 292, + "percent": 53, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 1ffdc4ca..9edc4438 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 638 | | total | 638 | -| pass | 268 | -| fail | 2 | -| error | 368 | -| percent | 42% | +| pass | 342 | +| fail | 4 | +| error | 292 | +| percent | 53% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-24T22:26:31Z +- **Generated**: 2026-04-24T22:54:53Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx new file mode 100644 index 00000000..255fb64f --- /dev/null +++ b/lib/forth/tests/test-phase5.sx @@ -0,0 +1,101 @@ +;; Phase 5 — Core Extension + memory primitives. + +(define forth-p5-passed 0) +(define forth-p5-failed 0) +(define forth-p5-failures (list)) + +(define + forth-p5-assert + (fn + (label expected actual) + (if + (= expected actual) + (set! forth-p5-passed (+ forth-p5-passed 1)) + (begin + (set! forth-p5-failed (+ forth-p5-failed 1)) + (set! + forth-p5-failures + (concat + forth-p5-failures + (list + (str label ": expected " (str expected) " got " (str actual))))))))) + +(define + forth-p5-check-stack + (fn + (label src expected) + (let ((r (forth-run src))) (forth-p5-assert label expected (nth r 2))))) + +(define + forth-p5-check-top + (fn + (label src expected) + (let + ((r (forth-run src))) + (let + ((stk (nth r 2))) + (forth-p5-assert label expected (nth stk (- (len stk) 1))))))) + +(define + forth-p5-create-tests + (fn + () + (forth-p5-check-top + "CREATE pushes HERE-at-creation" + "HERE CREATE FOO FOO =" + -1) + (forth-p5-check-top + "CREATE + ALLOT advances HERE" + "HERE 5 ALLOT HERE SWAP -" + 5) + (forth-p5-check-top + "CREATE + , stores cell" + "CREATE FOO 42 , FOO @" + 42) + (forth-p5-check-stack + "CREATE multiple ," + "CREATE TBL 1 , 2 , 3 , TBL @ TBL CELL+ @ TBL CELL+ CELL+ @" + (list 1 2 3)) + (forth-p5-check-top + "C, stores byte" + "CREATE B 65 C, 66 C, B C@" + 65))) + +(define + forth-p5-unsigned-tests + (fn + () + (forth-p5-check-top "1 2 U<" "1 2 U<" -1) + (forth-p5-check-top "2 1 U<" "2 1 U<" 0) + (forth-p5-check-top "0 1 U<" "0 1 U<" -1) + (forth-p5-check-top "-1 1 U< (since -1 unsigned is huge)" "-1 1 U<" 0) + (forth-p5-check-top "1 -1 U<" "1 -1 U<" -1) + (forth-p5-check-top "1 2 U>" "1 2 U>" 0) + (forth-p5-check-top "-1 1 U>" "-1 1 U>" -1))) + +(define + forth-p5-2bang-tests + (fn + () + (forth-p5-check-stack + "2! / 2@" + "CREATE X 0 , 0 , 11 22 X 2! X 2@" + (list 11 22)))) + +(define + forth-p5-run-all + (fn + () + (set! forth-p5-passed 0) + (set! forth-p5-failed 0) + (set! forth-p5-failures (list)) + (forth-p5-create-tests) + (forth-p5-unsigned-tests) + (forth-p5-2bang-tests) + (dict + "passed" + forth-p5-passed + "failed" + forth-p5-failed + "failures" + forth-p5-failures))) diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index da4908fd..719c139e 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -85,7 +85,14 @@ Representation: - [x] Drive Hayes Core pass-rate up ### Phase 5 — Core Extension + optional word sets -- [ ] Full Core + Core Extension +- [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` +- [ ] 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>` +- [ ] Source/state: `SOURCE`, `>IN`, `EVALUATE`, `STATE`, `[`, `]` +- [ ] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` - [ ] File Access word set (via SX IO) - [ ] String word set (`SLITERAL`, `COMPARE`, `SEARCH`) - [ ] Target: 100% Hayes Core @@ -99,6 +106,16 @@ Representation: _Newest first._ +- **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 + type: string addresses still go through `state.vars` (VARIABLE/VALUE + cells) while integer addresses now fall through to `state.mem` — + letting CREATE-allocated cells coexist with existing variables. + Decomposed the original "Full Core + Core Extension" box into + smaller unticked sub-bullets so iterations land per cluster. + Hayes: 342 pass / 292 error / 4 fail (53%). 237/237 internal. + - **Phase 4 close — LSHIFT/RSHIFT, 32-bit arith truncation, early binding; Hayes 174→268 (42%).** Added `LSHIFT` / `RSHIFT` as logical shifts on 32-bit unsigned values, converted through From b6810e90abe6a45c5795baddb9ef34fb7e288e8b Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 23:25:43 +0000 Subject: [PATCH 12/25] =?UTF-8?q?forth:=20mixed/double-cell=20math=20(S>D?= =?UTF-8?q?=20M*=20UM*=20UM/MOD=20FM/MOD=20SM/REM=20*/=20*/MOD);=20Hayes?= =?UTF-8?q?=20342=E2=86=92446=20(69%)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/forth/runtime.sx | 150 +++++++++++++++++++++++++++++++++ lib/forth/scoreboard.json | 10 +-- lib/forth/scoreboard.md | 10 +-- lib/forth/tests/test-phase5.sx | 31 +++++++ plans/forth-on-sx.md | 12 ++- 5 files changed, 202 insertions(+), 11 deletions(-) diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index d918cf3d..3544f7df 100644 --- 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)) diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 83991a0f..069ced0c 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-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" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 9edc4438..3d1e4360 100644 --- 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 diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx index 255fb64f..9197e626 100644 --- 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 diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 719c139e..6e693bef 100644 --- 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 From c726a9e0fe520146dc26b29764ff42afc89cc4a0 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 23:52:43 +0000 Subject: [PATCH 13/25] forth: double-cell ops D+/D-/DNEGATE/DABS/D=/D d1 d2) d1 d2)))))) + (forth-def-prim! + state + "DMIN" + (fn + (s) + (let + ((hi2 (forth-pop s)) + (lo2 (forth-pop s)) + (hi1 (forth-pop s)) + (lo1 (forth-pop s))) + (let + ((d1 (forth-double-from-cells-s lo1 hi1)) + (d2 (forth-double-from-cells-s lo2 hi2))) + (forth-double-push-s s (if (< d1 d2) d1 d2)))))) state)) diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 069ced0c..864c0119 100644 --- a/lib/forth/scoreboard.json +++ b/lib/forth/scoreboard.json @@ -1,6 +1,6 @@ { "source": "gerryjackson/forth2012-test-suite src/core.fr", - "generated_at": "2026-04-24T23:25:04Z", + "generated_at": "2026-04-24T23:52:16Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 3d1e4360..ad0297d6 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -11,7 +11,7 @@ | percent | 69% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-24T23:25:04Z +- **Generated**: 2026-04-24T23:52:16Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx index 9197e626..e73f3ccd 100644 --- a/lib/forth/tests/test-phase5.sx +++ b/lib/forth/tests/test-phase5.sx @@ -112,6 +112,29 @@ (forth-p5-check-top "*/ truncated" "7 11 13 */" 5) (forth-p5-check-stack "*/MOD" "7 11 13 */MOD" (list 12 5)))) +(define + forth-p5-double-tests + (fn + () + (forth-p5-check-stack "D+ small" "5 0 7 0 D+" (list 12 0)) + (forth-p5-check-stack "D+ negative" "-5 -1 -3 -1 D+" (list -8 -1)) + (forth-p5-check-stack "D- small" "10 0 3 0 D-" (list 7 0)) + (forth-p5-check-stack "DNEGATE positive" "5 0 DNEGATE" (list -5 -1)) + (forth-p5-check-stack "DNEGATE negative" "-5 -1 DNEGATE" (list 5 0)) + (forth-p5-check-stack "DABS negative" "-7 -1 DABS" (list 7 0)) + (forth-p5-check-stack "DABS positive" "7 0 DABS" (list 7 0)) + (forth-p5-check-top "D= equal" "5 0 5 0 D=" -1) + (forth-p5-check-top "D= unequal lo" "5 0 7 0 D=" 0) + (forth-p5-check-top "D= unequal hi" "5 0 5 1 D=" 0) + (forth-p5-check-top "D< lt" "5 0 7 0 D<" -1) + (forth-p5-check-top "D< gt" "7 0 5 0 D<" 0) + (forth-p5-check-top "D0= zero" "0 0 D0=" -1) + (forth-p5-check-top "D0= nonzero" "5 0 D0=" 0) + (forth-p5-check-top "D0< neg" "-5 -1 D0<" -1) + (forth-p5-check-top "D0< pos" "5 0 D0<" 0) + (forth-p5-check-stack "DMAX" "5 0 7 0 DMAX" (list 7 0)) + (forth-p5-check-stack "DMIN" "5 0 7 0 DMIN" (list 5 0)))) + (define forth-p5-run-all (fn @@ -123,6 +146,7 @@ (forth-p5-unsigned-tests) (forth-p5-2bang-tests) (forth-p5-mixed-tests) + (forth-p5-double-tests) (dict "passed" forth-p5-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 6e693bef..4387ce47 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -88,7 +88,7 @@ Representation: - [x] Memory: `CREATE`, `HERE`, `ALLOT`, `,`, `C,`, `CELL+`, `CELLS`, `ALIGN`, `ALIGNED`, `2!`, `2@` - [x] Unsigned compare: `U<`, `U>` - [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` +- [x] 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>` - [ ] Source/state: `SOURCE`, `>IN`, `EVALUATE`, `STATE`, `[`, `]` @@ -106,6 +106,15 @@ Representation: _Newest first._ +- **Phase 5 — double-cell ops `D+`/`D-`/`DNEGATE`/`DABS`/`D=`/`D<`/`D0=`/ + `D0<`/`DMAX`/`DMIN` (+18; Hayes unchanged).** Doubles get rebuilt + from `(lo, hi)` cells via `forth-double-from-cells-s`, the op runs + in bignum, and we push back via `forth-double-push-s`. Hayes Core + doesn't exercise D-words (those live in Gerry Jackson's separate + `doublest.fth` Double word-set tests we have not vendored), so the + scoreboard stays at 446/638 — but the words now exist for any + consumer that needs them. + - **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. From 47f66ad1bea609be4a42ea84b81e697356119d8a Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 00:23:04 +0000 Subject: [PATCH 14/25] forth: pictured numeric output <#/#/#S/#>/HOLD/SIGN + U./U.R/.R (Hayes 448/638, 70%) --- lib/forth/runtime.sx | 185 +++++++++++++++++++++++++++++++++ lib/forth/scoreboard.json | 10 +- lib/forth/scoreboard.md | 10 +- lib/forth/tests/test-phase5.sx | 48 +++++++++ plans/forth-on-sx.md | 12 ++- 5 files changed, 254 insertions(+), 11 deletions(-) diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 51e5ac22..3e92eb97 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -23,6 +23,7 @@ (dict-set! s "cstack" (list)) (dict-set! s "mem" (dict)) (dict-set! s "here" 0) + (dict-set! s "hold" (list)) s))) (define @@ -311,6 +312,85 @@ (forth-push state (forth-from-unsigned lo 32)) (forth-push state (forth-from-unsigned hi 32))))) +(define + forth-num-to-string-loop + (fn + (u base acc) + (if + (= u 0) + acc + (let + ((dig (mod u base)) (rest (floor (/ u base)))) + (let + ((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 + forth-num-to-string + (fn + (u base) + (if (= u 0) "0" (forth-num-to-string-loop u base "")))) + +(define + forth-spaces-str + (fn + (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-loop + (fn + (parts acc) + (if + (= (len parts) 0) + acc + (forth-join-hold-loop (rest parts) (str acc (first parts)))))) + +(define + forth-pic-step + (fn + (state) + (let + ((hi (forth-pop state)) (lo (forth-pop state))) + (let + ((d (forth-double-from-cells-u lo hi)) + (b (get (get state "vars") "base"))) + (let + ((dig (mod d b)) (rest (floor (/ d 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))))))) + +(define + forth-pic-S-loop + (fn + (state) + (forth-pic-step state) + (let + ((hi (forth-pop state)) (lo (forth-pop state))) + (if + (and (= lo 0) (= hi 0)) + (begin (forth-push state 0) (forth-push state 0)) + (begin + (forth-push state lo) + (forth-push state hi) + (forth-pic-S-loop state)))))) + (define forth-double-push-s (fn @@ -999,4 +1079,109 @@ ((d1 (forth-double-from-cells-s lo1 hi1)) (d2 (forth-double-from-cells-s lo2 hi2))) (forth-double-push-s s (if (< d1 d2) d1 d2)))))) + (forth-def-prim! state "<#" (fn (s) (dict-set! s "hold" (list)))) + (forth-def-prim! + state + "HOLD" + (fn + (s) + (let + ((c (forth-pop s))) + (dict-set! + s + "hold" + (cons (char-from-code c) (get s "hold")))))) + (forth-def-prim! + state + "SIGN" + (fn + (s) + (let + ((n (forth-pop s))) + (when + (< n 0) + (dict-set! s "hold" (cons "-" (get s "hold"))))))) + (forth-def-prim! + state + "#" + (fn + (s) + (let + ((hi (forth-pop s)) (lo (forth-pop s))) + (let + ((d (forth-double-from-cells-u lo hi)) + (b (get (get s "vars") "base"))) + (let + ((dig (mod d b)) (rest (floor (/ d 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))) + (forth-def-prim! + state + "#>" + (fn + (s) + (forth-pop s) + (forth-pop s) + (let + ((str-out (forth-join-hold (get s "hold")))) + (let + ((addr (forth-alloc-bytes! s (len str-out)))) + (forth-mem-write-string! s addr str-out) + (forth-push s addr) + (forth-push s (len str-out)))))) + (forth-def-prim! + state + "U." + (fn + (s) + (let + ((u (forth-to-unsigned (forth-pop s) 32)) + (b (get (get s "vars") "base"))) + (forth-emit-str s (str (forth-num-to-string u b) " "))))) + (forth-def-prim! + state + "U.R" + (fn + (s) + (let + ((width (forth-pop s)) + (u (forth-to-unsigned (forth-pop s) 32)) + (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 digits))))) + (forth-def-prim! + state + ".R" + (fn + (s) + (let + ((width (forth-pop s)) + (n (forth-pop s)) + (b (get (get s "vars") "base"))) + (let + ((sign-prefix (if (< n 0) "-" "")) + (abs-digits + (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 digits)))))) state)) diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 864c0119..0f3f391c 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-24T23:52:16Z", + "generated_at": "2026-04-25T00:22:42Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, - "pass": 446, - "fail": 7, - "error": 185, - "percent": 69, + "pass": 448, + "fail": 8, + "error": 182, + "percent": 70, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index ad0297d6..8fec6650 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 638 | | total | 638 | -| pass | 446 | -| fail | 7 | -| error | 185 | -| percent | 69% | +| pass | 448 | +| fail | 8 | +| error | 182 | +| percent | 70% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-24T23:52:16Z +- **Generated**: 2026-04-25T00:22:42Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx index e73f3ccd..70cc26a8 100644 --- a/lib/forth/tests/test-phase5.sx +++ b/lib/forth/tests/test-phase5.sx @@ -135,6 +135,53 @@ (forth-p5-check-stack "DMAX" "5 0 7 0 DMAX" (list 7 0)) (forth-p5-check-stack "DMIN" "5 0 7 0 DMIN" (list 5 0)))) +(define + forth-p5-format-tests + (fn + () + (forth-p4-check-output-passthrough + "U. prints with trailing space" + "123 U." + "123 ") + (forth-p4-check-output-passthrough + "<# #S #> TYPE — decimal" + "123 0 <# #S #> TYPE" + "123") + (forth-p4-check-output-passthrough + "<# #S #> TYPE — hex" + "255 HEX 0 <# #S #> TYPE" + "FF") + (forth-p4-check-output-passthrough + "<# # # #> partial" + "1234 0 <# # # #> TYPE" + "34") + (forth-p4-check-output-passthrough + "SIGN holds minus" + "<# -1 SIGN -1 SIGN 0 0 #> TYPE" + "--") + (forth-p4-check-output-passthrough + ".R right-justifies" + "42 5 .R" + " 42") + (forth-p4-check-output-passthrough + ".R negative" + "-42 5 .R" + " -42") + (forth-p4-check-output-passthrough + "U.R" + "42 5 U.R" + " 42") + (forth-p4-check-output-passthrough + "HOLD char" + "<# 0 0 65 HOLD #> TYPE" + "A"))) + +(define + forth-p4-check-output-passthrough + (fn + (label src expected) + (let ((r (forth-run src))) (forth-p5-assert label expected (nth r 1))))) + (define forth-p5-run-all (fn @@ -147,6 +194,7 @@ (forth-p5-2bang-tests) (forth-p5-mixed-tests) (forth-p5-double-tests) + (forth-p5-format-tests) (dict "passed" forth-p5-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 4387ce47..4a26c02e 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -89,7 +89,7 @@ Representation: - [x] Unsigned compare: `U<`, `U>` - [x] Mixed/double-cell math: `S>D`, `M*`, `UM*`, `UM/MOD`, `FM/MOD`, `SM/REM`, `*/`, `*/MOD` - [x] 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` +- [x] Number formatting: `<#`, `#`, `#S`, `#>`, `HOLD`, `SIGN`, `.R`, `U.`, `U.R` - [ ] Parsing/dictionary: `WORD`, `FIND`, `EXECUTE`, `'`, `[']`, `LITERAL`, `POSTPONE`, `>BODY`, `DOES>` - [ ] Source/state: `SOURCE`, `>IN`, `EVALUATE`, `STATE`, `[`, `]` - [ ] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` @@ -106,6 +106,16 @@ Representation: _Newest first._ +- **Phase 5 — pictured numeric output: `<#`/`#`/`#S`/`#>`/`HOLD`/`SIGN` + + `U.`/`U.R`/`.R` (+9; Hayes 446→448, 70%).** Added a `state.hold` + list of single-character strings — `<#` resets it, `HOLD` and + `SIGN` prepend, `#` divides ud by BASE and prepends one digit, + `#S` loops `#` until ud is zero (running once even on zero), + `#>` drops ud and copies the joined hold buffer into mem, + pushing `(addr, len)`. `U.` / `.R` / `U.R` use a separate + `forth-num-to-string` for one-shot decimal/hex output and + `forth-spaces-str` for right-justify padding. + - **Phase 5 — double-cell ops `D+`/`D-`/`DNEGATE`/`DABS`/`D=`/`D<`/`D0=`/ `D0<`/`DMAX`/`DMIN` (+18; Hayes unchanged).** Doubles get rebuilt from `(lo, hi)` cells via `forth-double-from-cells-s`, the op runs From 89a879799a54c1582f101ba70f1911aad4c6b144 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 00:55:34 +0000 Subject: [PATCH 15/25] forth: parsing/dictionary '/[']/EXECUTE/LITERAL/POSTPONE/WORD/FIND/>BODY (Hayes 463/638, 72%) --- lib/forth/compiler.sx | 107 ++++++++++++++++++++++++++++++++- lib/forth/runtime.sx | 6 +- lib/forth/scoreboard.json | 10 +-- lib/forth/scoreboard.md | 10 +-- lib/forth/tests/test-phase5.sx | 26 ++++++++ plans/forth-on-sx.md | 19 +++++- 6 files changed, 164 insertions(+), 14 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 92593e7c..1f4718b5 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -285,6 +285,7 @@ (get s "dict") (downcase (get def "name")) (forth-make-word "colon-def" body-fn false)) + (dict-set! s "last-defined" (get def "name")) (dict-set! s "current-def" nil) (dict-set! s "compiling" false)))))) (forth-def-prim-imm! @@ -711,11 +712,115 @@ (when (nil? name) (forth-error s "CREATE expects name")) (let ((addr (get s "here"))) - (forth-def-prim! s name (fn (ss) (forth-push ss addr))))))) + (forth-def-prim! s name (fn (ss) (forth-push ss addr))) + (let + ((w (forth-lookup s name))) + (dict-set! w "body-addr" addr)))))) (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)) + (forth-def-prim! + state + "EXECUTE" + (fn (s) (let ((w (forth-pop s))) (forth-execute-word s w)))) + (forth-def-prim! + state + "'" + (fn + (s) + (let + ((name (forth-next-token! s))) + (when (nil? name) (forth-error s "' expects name")) + (let + ((w (forth-lookup s name))) + (when (nil? w) (forth-error s (str name " ?"))) + (forth-push s w))))) + (forth-def-prim-imm! + state + "[']" + (fn + (s) + (let + ((name (forth-next-token! s))) + (when (nil? name) (forth-error s "['] expects name")) + (let + ((w (forth-lookup s name))) + (when (nil? w) (forth-error s (str name " ?"))) + (if + (get s "compiling") + (forth-def-append! s (fn (ss) (forth-push ss w))) + (forth-push s w)))))) + (forth-def-prim-imm! + state + "LITERAL" + (fn + (s) + (let + ((v (forth-pop s))) + (when + (not (get s "compiling")) + (forth-error s "LITERAL outside compile mode")) + (forth-def-append! s (fn (ss) (forth-push ss v)))))) + (forth-def-prim-imm! + state + "POSTPONE" + (fn + (s) + (let + ((name (forth-next-token! s))) + (when (nil? name) (forth-error s "POSTPONE expects name")) + (let + ((w (forth-lookup s name))) + (when (nil? w) (forth-error s (str name " ?"))) + (forth-def-append! + s + (fn + (ss) + (forth-def-append! + ss + (fn (sss) (forth-execute-word sss w))))))))) + (forth-def-prim! + state + ">BODY" + (fn + (s) + (let + ((w (forth-pop s))) + (forth-push s (or (get w "body-addr") 0))))) + (forth-def-prim! + state + "WORD" + (fn + (s) + (let + ((delim (forth-pop s)) (tok (forth-next-token! s))) + (let + ((str-out (or tok ""))) + (let + ((addr (forth-alloc-bytes! s (+ 1 (len str-out))))) + (forth-mem-write! s addr (len str-out)) + (forth-mem-write-string! s (+ addr 1) str-out) + (forth-push s addr)))))) + (forth-def-prim! + state + "FIND" + (fn + (s) + (let + ((c-addr (forth-pop s))) + (let + ((u (forth-mem-read s c-addr))) + (let + ((str-name (forth-mem-read-string s (+ c-addr 1) u))) + (let + ((w (forth-lookup s str-name))) + (if + (nil? w) + (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-def-prim! state "U<" diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 3e92eb97..1914e2a7 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -208,7 +208,8 @@ (dict-set! (get state "dict") (downcase name) - (forth-make-word "primitive" body false)))) + (forth-make-word "primitive" body false)) + (dict-set! state "last-defined" name))) (define forth-def-prim-imm! @@ -217,7 +218,8 @@ (dict-set! (get state "dict") (downcase name) - (forth-make-word "primitive" body true)))) + (forth-make-word "primitive" body true)) + (dict-set! state "last-defined" name))) (define forth-lookup diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 0f3f391c..f1021a6f 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-25T00:22:42Z", + "generated_at": "2026-04-25T00:54:55Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, - "pass": 448, - "fail": 8, - "error": 182, - "percent": 70, + "pass": 463, + "fail": 10, + "error": 165, + "percent": 72, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 8fec6650..db0e6443 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 638 | | total | 638 | -| pass | 448 | -| fail | 8 | -| error | 182 | -| percent | 70% | +| pass | 463 | +| fail | 10 | +| error | 165 | +| percent | 72% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-25T00:22:42Z +- **Generated**: 2026-04-25T00:54:55Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx index 70cc26a8..1469cd65 100644 --- a/lib/forth/tests/test-phase5.sx +++ b/lib/forth/tests/test-phase5.sx @@ -176,6 +176,31 @@ "<# 0 0 65 HOLD #> TYPE" "A"))) +(define + forth-p5-dict-tests + (fn + () + (forth-p5-check-top + "EXECUTE via tick" + ": INC 1+ ; 9 ' INC EXECUTE" + 10) + (forth-p5-check-top + "['] inside def" + ": DUB 2* ; : APPLY ['] DUB EXECUTE ; 5 APPLY" + 10) + (forth-p5-check-top + ">BODY of CREATE word" + "CREATE C 99 , ' C >BODY @" + 99) + (forth-p5-check-stack + "WORD parses next token to counted-string" + ": A 5 ; BL WORD A COUNT TYPE" + (list)) + (forth-p5-check-top + "FIND on known word -> non-zero" + ": A 5 ; BL WORD A FIND SWAP DROP" + -1))) + (define forth-p4-check-output-passthrough (fn @@ -195,6 +220,7 @@ (forth-p5-mixed-tests) (forth-p5-double-tests) (forth-p5-format-tests) + (forth-p5-dict-tests) (dict "passed" forth-p5-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 4a26c02e..4bd5d73a 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -90,7 +90,7 @@ Representation: - [x] Mixed/double-cell math: `S>D`, `M*`, `UM*`, `UM/MOD`, `FM/MOD`, `SM/REM`, `*/`, `*/MOD` - [x] Double-cell ops: `D+`, `D-`, `D=`, `D<`, `D0=`, `2DUP`, `2DROP`, `2OVER`, `2SWAP` (already), plus `D>S`, `DABS`, `DNEGATE` - [x] Number formatting: `<#`, `#`, `#S`, `#>`, `HOLD`, `SIGN`, `.R`, `U.`, `U.R` -- [ ] Parsing/dictionary: `WORD`, `FIND`, `EXECUTE`, `'`, `[']`, `LITERAL`, `POSTPONE`, `>BODY`, `DOES>` +- [x] Parsing/dictionary: `WORD`, `FIND`, `EXECUTE`, `'`, `[']`, `LITERAL`, `POSTPONE`, `>BODY` (DOES> deferred — needs runtime-rebind of last CREATE) - [ ] Source/state: `SOURCE`, `>IN`, `EVALUATE`, `STATE`, `[`, `]` - [ ] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` - [ ] File Access word set (via SX IO) @@ -106,6 +106,23 @@ Representation: _Newest first._ +- **Phase 5 — parsing/dictionary words `'`/`[']`/`EXECUTE`/`LITERAL`/ + `POSTPONE`/`WORD`/`FIND`/`>BODY` (Hayes 448→463, 72%).** xt is + represented as the SX dict reference of the word record, so + `'`/`[']` push the looked-up record and `EXECUTE` calls + `forth-execute-word` on the popped value. `LITERAL` (IMMEDIATE) + pops a value at compile time and emits a push-op. `POSTPONE` + (IMMEDIATE) compiles into the *outer* def an op that, when run + during a *later* compile, appends a call-w op to whatever def is + current — the standard two-tier compile semantic. Added + `state.last-defined` tracked by every primitive/colon definition + so `IMMEDIATE` can target the most-recent word even after `;` + closes the def. CREATE now stashes its data-field address on the + word record so `>BODY` can recover it. `WORD`/`FIND` use the byte + memory and counted-string layout already in place. + `DOES>` is deferred — needs a runtime mechanism to rebind the + last-CREATE'd word's action. + - **Phase 5 — pictured numeric output: `<#`/`#`/`#S`/`#>`/`HOLD`/`SIGN` + `U.`/`U.R`/`.R` (+9; Hayes 446→448, 70%).** Added a `state.hold` list of single-character strings — `<#` resets it, `HOLD` and From b1a785204516c997722cfe2620f85be7e3a43e8d Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 01:23:23 +0000 Subject: [PATCH 16/25] =?UTF-8?q?forth:=20[,=20],=20STATE,=20EVALUATE=20(+?= =?UTF-8?q?5;=20Hayes=20463=E2=86=92477,=2074%)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/forth/compiler.sx | 36 ++++++++++++++++++++++++++++++---- lib/forth/scoreboard.json | 10 +++++----- lib/forth/scoreboard.md | 10 +++++----- lib/forth/tests/test-phase5.sx | 26 ++++++++++++++++++++++++ plans/forth-on-sx.md | 14 ++++++++++++- 5 files changed, 81 insertions(+), 15 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 1f4718b5..8c2af657 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -649,10 +649,13 @@ (s) (let ((addr (forth-pop s))) - (if - (string? addr) - (forth-push s (or (get (get s "vars") addr) 0)) - (forth-push s (forth-mem-read s addr)))))) + (cond + ((= addr "@@state") + (forth-push s (if (get s "compiling") -1 0))) + ((= addr "@@in") (forth-push s 0)) + ((string? addr) + (forth-push s (or (get (get s "vars") addr) 0))) + (else (forth-push s (forth-mem-read s addr))))))) (forth-def-prim! state "!" @@ -788,6 +791,31 @@ (let ((w (forth-pop s))) (forth-push s (or (get w "body-addr") 0))))) + (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! + state + "EVALUATE" + (fn + (s) + (let + ((u (forth-pop s)) (addr (forth-pop s))) + (let + ((src (forth-mem-read-string s addr u))) + (let + ((saved-input (get s "input"))) + (dict-set! s "input" (forth-tokens src)) + (forth-interpret-loop s) + (dict-set! s "input" saved-input)))))) + (forth-def-prim! + state + "SOURCE" + (fn (s) (forth-push s 0) (forth-push s 0))) + (forth-def-prim! state ">IN" (fn (s) (forth-push s "@@in"))) (forth-def-prim! state "WORD" diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index f1021a6f..0da494f6 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-25T00:54:55Z", + "generated_at": "2026-04-25T01:22:10Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, - "pass": 463, - "fail": 10, - "error": 165, - "percent": 72, + "pass": 477, + "fail": 14, + "error": 147, + "percent": 74, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index db0e6443..d1eedc5b 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 638 | | total | 638 | -| pass | 463 | -| fail | 10 | -| error | 165 | -| percent | 72% | +| pass | 477 | +| fail | 14 | +| error | 147 | +| percent | 74% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-25T00:54:55Z +- **Generated**: 2026-04-25T01:22:10Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx index 1469cd65..fbc22ffe 100644 --- a/lib/forth/tests/test-phase5.sx +++ b/lib/forth/tests/test-phase5.sx @@ -201,6 +201,31 @@ ": A 5 ; BL WORD A FIND SWAP DROP" -1))) +(define + forth-p5-state-tests + (fn + () + (forth-p5-check-top + "STATE @ in interpret mode" + "STATE @" + 0) + (forth-p5-check-top + "STATE @ via IMMEDIATE inside compile" + ": GT8 STATE @ ; IMMEDIATE : T GT8 LITERAL ; T" + -1) + (forth-p5-check-top + "[ ] LITERAL captures" + ": SEVEN [ 7 ] LITERAL ; SEVEN" + 7) + (forth-p5-check-top + "EVALUATE in interpret mode" + "S\" 5 7 +\" EVALUATE" + 12) + (forth-p5-check-top + "EVALUATE inside def" + ": A 100 ; : B S\" A\" EVALUATE ; B" + 100))) + (define forth-p4-check-output-passthrough (fn @@ -221,6 +246,7 @@ (forth-p5-double-tests) (forth-p5-format-tests) (forth-p5-dict-tests) + (forth-p5-state-tests) (dict "passed" forth-p5-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 4bd5d73a..04779e73 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -91,7 +91,7 @@ Representation: - [x] Double-cell ops: `D+`, `D-`, `D=`, `D<`, `D0=`, `2DUP`, `2DROP`, `2OVER`, `2SWAP` (already), plus `D>S`, `DABS`, `DNEGATE` - [x] Number formatting: `<#`, `#`, `#S`, `#>`, `HOLD`, `SIGN`, `.R`, `U.`, `U.R` - [x] Parsing/dictionary: `WORD`, `FIND`, `EXECUTE`, `'`, `[']`, `LITERAL`, `POSTPONE`, `>BODY` (DOES> deferred — needs runtime-rebind of last CREATE) -- [ ] Source/state: `SOURCE`, `>IN`, `EVALUATE`, `STATE`, `[`, `]` +- [x] Source/state: `EVALUATE`, `STATE`, `[`, `]` (`SOURCE`/`>IN` stubbed; tokenized input means the exact byte/offset semantics aren't useful here) - [ ] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` - [ ] File Access word set (via SX IO) - [ ] String word set (`SLITERAL`, `COMPARE`, `SEARCH`) @@ -106,6 +106,18 @@ Representation: _Newest first._ +- **Phase 5 — `[`, `]`, `STATE`, `EVALUATE` (+5; Hayes 463→477, 74%).** + `[` (IMMEDIATE) clears `state.compiling`, `]` sets it. `STATE` + pushes the sentinel address `"@@state"` and `@` reads it as + `-1`/`0` based on the live `compiling` flag. `EVALUATE` reads + the (addr,u) string from byte memory, retokenises it via + `forth-tokens`, swaps it in as the active input, runs the + interpret loop, and restores the saved input. `SOURCE` and + `>IN` exist as stubs that push zeros — our whitespace-tokenised + input has no native byte-offset, so the deeper Hayes tests + that re-position parsing via `>IN !` stay marked as errors + rather than silently misbehaving. + - **Phase 5 — parsing/dictionary words `'`/`[']`/`EXECUTE`/`LITERAL`/ `POSTPONE`/`WORD`/`FIND`/`>BODY` (Hayes 448→463, 72%).** xt is represented as the SX dict reference of the word record, so From 8ca2fe3564d29c426078f08b47ff7ee31ef281af Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 01:55:38 +0000 Subject: [PATCH 17/25] forth: WITHIN/ABORT/ABORT"/EXIT/UNLOOP (+7; Hayes 486/638, 76%) --- lib/forth/compiler.sx | 65 ++++++++++++++++++++++++++++++++++ lib/forth/scoreboard.json | 8 ++--- lib/forth/scoreboard.md | 8 ++--- lib/forth/tests/test-phase5.sx | 22 ++++++++++++ plans/forth-on-sx.md | 13 ++++++- 5 files changed, 107 insertions(+), 9 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 8c2af657..90217d29 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -122,6 +122,8 @@ (forth-loop-step s op pc)) ((and (dict? op) (= (get op "kind") "+loop")) (forth-plusloop-step s op pc)) + ((and (dict? op) (= (get op "kind") "exit")) + (dict-set! pc "v" 1000000000)) (else (begin (op s) (dict-set! pc "v" (+ (get pc "v") 1))))))) (define @@ -791,6 +793,69 @@ (let ((w (forth-pop s))) (forth-push s (or (get w "body-addr") 0))))) + (forth-def-prim! + state + "WITHIN" + (fn + (s) + (let + ((n3 (forth-pop s)) (n2 (forth-pop s)) (n1 (forth-pop s))) + (let + ((a (forth-to-unsigned (- n1 n2) 32)) + (b (forth-to-unsigned (- n3 n2) 32))) + (forth-push s (if (< a b) -1 0)))))) + (forth-def-prim! + state + "ABORT" + (fn + (s) + (dict-set! s "dstack" (list)) + (dict-set! s "rstack" (list)) + (dict-set! s "cstack" (list)) + (forth-error s "ABORT"))) + (forth-def-prim-imm! + state + "ABORT\"" + (fn + (s) + (let + ((msg (forth-parse-quote s))) + (if + (get s "compiling") + (forth-def-append! + s + (fn + (ss) + (when + (not (= (forth-pop ss) 0)) + (begin + (dict-set! ss "dstack" (list)) + (dict-set! ss "rstack" (list)) + (dict-set! ss "cstack" (list)) + (forth-error ss (str "ABORT: " msg)))))) + (when + (not (= (forth-pop s) 0)) + (begin + (dict-set! s "dstack" (list)) + (dict-set! s "rstack" (list)) + (dict-set! s "cstack" (list)) + (forth-error s (str "ABORT: " msg)))))))) + (forth-def-prim-imm! + state + "EXIT" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "EXIT outside definition")) + (let + ((op (dict))) + (dict-set! op "kind" "exit") + (forth-def-append! s op)))) + (forth-def-prim! + state + "UNLOOP" + (fn (s) (forth-rpop s) (forth-rpop s))) (forth-def-prim-imm! state "[" diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 0da494f6..904b29ac 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-25T01:22:10Z", + "generated_at": "2026-04-25T01:55:16Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, - "pass": 477, + "pass": 486, "fail": 14, - "error": 147, - "percent": 74, + "error": 138, + "percent": 76, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index d1eedc5b..dd3c1d58 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 638 | | total | 638 | -| pass | 477 | +| pass | 486 | | fail | 14 | -| error | 147 | -| percent | 74% | +| error | 138 | +| percent | 76% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-25T01:22:10Z +- **Generated**: 2026-04-25T01:55:16Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx index fbc22ffe..f0fab423 100644 --- a/lib/forth/tests/test-phase5.sx +++ b/lib/forth/tests/test-phase5.sx @@ -226,6 +226,27 @@ ": A 100 ; : B S\" A\" EVALUATE ; B" 100))) +(define + forth-p5-misc-tests + (fn + () + (forth-p5-check-top "WITHIN inclusive lower" "3 2 10 WITHIN" -1) + (forth-p5-check-top "WITHIN exclusive upper" "10 2 10 WITHIN" 0) + (forth-p5-check-top "WITHIN below range" "1 2 10 WITHIN" 0) + (forth-p5-check-top "WITHIN at lower" "2 2 10 WITHIN" -1) + (forth-p5-check-top + "EXIT leaves colon-def early" + ": F 5 EXIT 99 ; F" + 5) + (forth-p5-check-stack + "EXIT in IF branch" + ": F 5 0 IF DROP 99 EXIT THEN ; F" + (list 5)) + (forth-p5-check-top + "UNLOOP + EXIT in DO" + ": SUM 0 10 0 DO I 5 = IF I UNLOOP EXIT THEN LOOP ; SUM" + 5))) + (define forth-p4-check-output-passthrough (fn @@ -247,6 +268,7 @@ (forth-p5-format-tests) (forth-p5-dict-tests) (forth-p5-state-tests) + (forth-p5-misc-tests) (dict "passed" forth-p5-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 04779e73..d3e7bf75 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -92,7 +92,7 @@ Representation: - [x] Number formatting: `<#`, `#`, `#S`, `#>`, `HOLD`, `SIGN`, `.R`, `U.`, `U.R` - [x] Parsing/dictionary: `WORD`, `FIND`, `EXECUTE`, `'`, `[']`, `LITERAL`, `POSTPONE`, `>BODY` (DOES> deferred — needs runtime-rebind of last CREATE) - [x] Source/state: `EVALUATE`, `STATE`, `[`, `]` (`SOURCE`/`>IN` stubbed; tokenized input means the exact byte/offset semantics aren't useful here) -- [ ] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` +- [x] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` - [ ] File Access word set (via SX IO) - [ ] String word set (`SLITERAL`, `COMPARE`, `SEARCH`) - [ ] Target: 100% Hayes Core @@ -106,6 +106,17 @@ Representation: _Newest first._ +- **Phase 5 — `WITHIN`/`ABORT`/`ABORT"`/`EXIT`/`UNLOOP` (+7; + Hayes 477→486, 76%).** `WITHIN` uses the ANS two's-complement + trick: `(n1-n2) U< (n3-n2)`. `ABORT` wipes the data/return/control + stacks and raises — the conformance runner catches it at the + chunk boundary. `ABORT"` parses its message like `S"`, then at + runtime pops a flag and raises only if truthy. `EXIT` adds a new + `:kind "exit"` op that the PC-driven body runner treats as a + jump-to-end; added a matching cond clause in `forth-step-op`. + `UNLOOP` pops two from the return stack — usable paired with + `EXIT` to bail from inside `DO`/`LOOP`. + - **Phase 5 — `[`, `]`, `STATE`, `EVALUATE` (+5; Hayes 463→477, 74%).** `[` (IMMEDIATE) clears `state.compiling`, `]` sets it. `STATE` pushes the sentinel address `"@@state"` and `@` reads it as From 64af162b5de0b436e1e414aded8f571cd964de6a Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 02:24:55 +0000 Subject: [PATCH 18/25] forth: File Access word set (in-memory backing, Hayes unchanged) --- lib/forth/compiler.sx | 163 +++++++++++++++++++++++++++++++++ lib/forth/runtime.sx | 7 +- lib/forth/scoreboard.json | 2 +- lib/forth/scoreboard.md | 2 +- lib/forth/tests/test-phase4.sx | 4 - lib/forth/tests/test-phase5.sx | 22 +++++ plans/forth-on-sx.md | 16 +++- 7 files changed, 205 insertions(+), 11 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 90217d29..605c43d3 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -793,6 +793,169 @@ (let ((w (forth-pop s))) (forth-push s (or (get w "body-addr") 0))))) + (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 + "OPEN-FILE" + (fn + (s) + (let + ((fam (forth-pop s)) + (u (forth-pop s)) + (addr (forth-pop s))) + (let + ((path (forth-mem-read-string s addr u))) + (let + ((existing (get (get s "by-path") path))) + (if + (nil? existing) + (begin (forth-push s 0) (forth-push s 1)) + (let + ((fid (get s "next-fileid"))) + (let + ((entry (dict))) + (dict-set! entry "content" (get existing "content")) + (dict-set! entry "pos" 0) + (dict-set! entry "path" path) + (dict-set! (get s "files") (str fid) entry) + (dict-set! s "next-fileid" (+ fid 1)) + (forth-push s fid) + (forth-push s 0))))))))) + (forth-def-prim! + state + "CREATE-FILE" + (fn + (s) + (let + ((fam (forth-pop s)) + (u (forth-pop s)) + (addr (forth-pop s))) + (let + ((path (forth-mem-read-string s addr u))) + (let + ((fid (get s "next-fileid"))) + (let + ((entry (dict))) + (dict-set! entry "content" "") + (dict-set! entry "pos" 0) + (dict-set! entry "path" path) + (dict-set! (get s "files") (str fid) entry) + (dict-set! (get s "by-path") path entry) + (dict-set! s "next-fileid" (+ fid 1)) + (forth-push s fid) + (forth-push s 0))))))) + (forth-def-prim! + state + "CLOSE-FILE" + (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))) + (let + ((entry (get (get s "files") (str fid)))) + (if + (nil? entry) + (begin (forth-push s 0) (forth-push s 1)) + (let + ((content (get entry "content")) (pos (get entry "pos"))) + (let + ((avail (- (len content) pos))) + (let + ((n (if (< u1 avail) u1 avail))) + (when + (> n 0) + (forth-mem-write-string! s addr (substr content pos n))) + (dict-set! entry "pos" (+ pos n)) + (forth-push s n) + (forth-push s 0))))))))) + (forth-def-prim! + state + "WRITE-FILE" + (fn + (s) + (let + ((fid (forth-pop s)) + (u (forth-pop s)) + (addr (forth-pop s))) + (let + ((entry (get (get s "files") (str fid)))) + (if + (nil? entry) + (forth-push s 1) + (begin + (dict-set! + entry + "content" + (str + (get entry "content") + (forth-mem-read-string s addr u))) + (forth-push s 0))))))) + (forth-def-prim! + state + "FILE-POSITION" + (fn + (s) + (let + ((fid (forth-pop s))) + (let + ((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 (get entry "pos")) + (forth-push s 0) + (forth-push s 0))))))) + (forth-def-prim! + state + "FILE-SIZE" + (fn + (s) + (let + ((fid (forth-pop s))) + (let + ((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 (len (get entry "content"))) + (forth-push s 0) + (forth-push s 0))))))) + (forth-def-prim! + state + "REPOSITION-FILE" + (fn + (s) + (let + ((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))))))) + (forth-def-prim! + state + "DELETE-FILE" + (fn + (s) + (let ((u (forth-pop s)) (addr (forth-pop s))) (forth-push s 1)))) (forth-def-prim! state "WITHIN" diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index 1914e2a7..a19881d9 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -24,6 +24,9 @@ (dict-set! s "mem" (dict)) (dict-set! s "here" 0) (dict-set! s "hold" (list)) + (dict-set! s "files" (dict)) + (dict-set! s "by-path" (dict)) + (dict-set! s "next-fileid" 1) s))) (define @@ -735,10 +738,6 @@ state "HEX" (fn (s) (dict-set! (get s "vars") "base" 16))) - (forth-def-prim! - state - "BIN" - (fn (s) (dict-set! (get s "vars") "base" 2))) (forth-def-prim! state "OCTAL" diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 904b29ac..c56fd51d 100644 --- a/lib/forth/scoreboard.json +++ b/lib/forth/scoreboard.json @@ -1,6 +1,6 @@ { "source": "gerryjackson/forth2012-test-suite src/core.fr", - "generated_at": "2026-04-25T01:55:16Z", + "generated_at": "2026-04-25T02:24:33Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index dd3c1d58..6cf97957 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -11,7 +11,7 @@ | percent | 76% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-25T01:55:16Z +- **Generated**: 2026-04-25T02:24:33Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase4.sx b/lib/forth/tests/test-phase4.sx index 406f5bf1..2f17b641 100644 --- a/lib/forth/tests/test-phase4.sx +++ b/lib/forth/tests/test-phase4.sx @@ -233,10 +233,6 @@ "DECIMAL parses 10 as 10" "HEX DECIMAL 10" 10) - (forth-p4-check-top - "BIN parses 1010 as 10" - "BIN 1010" - 10) (forth-p4-check-top "OCTAL parses 17 as 15" "OCTAL 17" diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx index f0fab423..ba015882 100644 --- a/lib/forth/tests/test-phase5.sx +++ b/lib/forth/tests/test-phase5.sx @@ -247,6 +247,27 @@ ": SUM 0 10 0 DO I 5 = IF I UNLOOP EXIT THEN LOOP ; SUM" 5))) +(define + forth-p5-fa-tests + (fn + () + (forth-p5-check-top + "R/O R/W W/O constants" + "R/O R/W W/O + +" + 3) + (forth-p5-check-top + "CREATE-FILE returns ior=0" + "CREATE PAD 50 ALLOT PAD S\" /tmp/test.fxf\" ROT SWAP CMOVE S\" /tmp/test.fxf\" R/W CREATE-FILE SWAP DROP" + 0) + (forth-p5-check-top + "WRITE-FILE then CLOSE" + "S\" /tmp/t2.fxf\" R/W CREATE-FILE DROP >R S\" HI\" R@ WRITE-FILE R> CLOSE-FILE +" + 0) + (forth-p5-check-top + "OPEN-FILE on unknown path returns ior!=0" + "S\" /tmp/nope.fxf\" R/O OPEN-FILE SWAP DROP 0 =" + 0))) + (define forth-p4-check-output-passthrough (fn @@ -269,6 +290,7 @@ (forth-p5-dict-tests) (forth-p5-state-tests) (forth-p5-misc-tests) + (forth-p5-fa-tests) (dict "passed" forth-p5-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index d3e7bf75..21f4a55f 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -93,7 +93,7 @@ Representation: - [x] Parsing/dictionary: `WORD`, `FIND`, `EXECUTE`, `'`, `[']`, `LITERAL`, `POSTPONE`, `>BODY` (DOES> deferred — needs runtime-rebind of last CREATE) - [x] Source/state: `EVALUATE`, `STATE`, `[`, `]` (`SOURCE`/`>IN` stubbed; tokenized input means the exact byte/offset semantics aren't useful here) - [x] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` -- [ ] File Access word set (via SX IO) +- [x] File Access word set (in-memory — `read-file` is not reachable from the epoch eval env) - [ ] String word set (`SLITERAL`, `COMPARE`, `SEARCH`) - [ ] Target: 100% Hayes Core @@ -106,6 +106,20 @@ Representation: _Newest first._ +- **Phase 5 — File Access word set (in-memory backing; +4).** + `OPEN-FILE`/`CREATE-FILE`/`CLOSE-FILE`/`READ-FILE`/`WRITE-FILE`/ + `FILE-POSITION`/`FILE-SIZE`/`REPOSITION-FILE`/`DELETE-FILE` plus + the mode constants `R/O`/`R/W`/`W/O`/`BIN`. File handles live on + `state.files` (fileid → {content, pos, path}) with a + `state.by-path` index so `CREATE-FILE`'d files can be + `OPEN-FILE`'d later in the same session. Attempting to + `OPEN-FILE` an unknown path returns `ior != 0`; disk-backed + open/read is not wired because `read-file` isn't in the sx_server + epoch eval environment (it's bound only in the HTTP helpers). + Also removed the stray base-2 `BIN` primitive from Phase 4 — + ANS `BIN` is the file-mode modifier. Hayes Core unchanged at + 486/638 since core.fr doesn't exercise file words. + - **Phase 5 — `WITHIN`/`ABORT`/`ABORT"`/`EXIT`/`UNLOOP` (+7; Hayes 477→486, 76%).** `WITHIN` uses the ANS two's-complement trick: `(n1-n2) U< (n3-n2)`. `ABORT` wipes the data/return/control From 1b2935828c41b74ec7866d418b674928a80d7059 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 02:53:46 +0000 Subject: [PATCH 19/25] forth: String word set COMPARE/SEARCH/SLITERAL (+9) --- lib/forth/compiler.sx | 47 ++++++++++++++++++++++++++++++++++ lib/forth/runtime.sx | 40 +++++++++++++++++++++++++++++ lib/forth/scoreboard.json | 2 +- lib/forth/scoreboard.md | 2 +- lib/forth/tests/test-phase5.sx | 33 ++++++++++++++++++++++++ plans/forth-on-sx.md | 13 +++++++++- 6 files changed, 134 insertions(+), 3 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 605c43d3..a4d1eefd 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -793,6 +793,53 @@ (let ((w (forth-pop s))) (forth-push s (or (get w "body-addr") 0))))) + (forth-def-prim-imm! + state + "SLITERAL" + (fn + (s) + (let + ((u (forth-pop s)) (c-addr (forth-pop s))) + (let + ((content (forth-mem-read-string s c-addr u))) + (let + ((new-addr (forth-alloc-bytes! s u))) + (forth-mem-write-string! s new-addr content) + (forth-def-append! s (fn (ss) (forth-push ss new-addr))) + (forth-def-append! s (fn (ss) (forth-push ss u)))))))) + (forth-def-prim! + state + "COMPARE" + (fn + (s) + (let + ((u2 (forth-pop s)) + (a2 (forth-pop s)) + (u1 (forth-pop s)) + (a1 (forth-pop s))) + (forth-push s (forth-compare-bytes-loop s a1 u1 a2 u2 0))))) + (forth-def-prim! + state + "SEARCH" + (fn + (s) + (let + ((u2 (forth-pop s)) + (a2 (forth-pop s)) + (u1 (forth-pop s)) + (a1 (forth-pop s))) + (let + ((idx (forth-search-bytes s a1 u1 a2 u2 0))) + (if + (< idx 0) + (begin + (forth-push s a1) + (forth-push s u1) + (forth-push s 0)) + (begin + (forth-push s (+ a1 idx)) + (forth-push s (- u1 idx)) + (forth-push s -1))))))) (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))) diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index a19881d9..bc6e84ad 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -381,6 +381,46 @@ (dict-set! state "hold" (cons ch (get state "hold"))) (forth-double-push-u state rest))))))) +(define + forth-compare-bytes-loop + (fn + (state a1 u1 a2 u2 i) + (cond + ((and (= i u1) (= i u2)) 0) + ((= i u1) -1) + ((= i u2) 1) + (else + (let + ((b1 (forth-mem-read state (+ a1 i))) + (b2 (forth-mem-read state (+ a2 i)))) + (cond + ((< b1 b2) -1) + ((> b1 b2) 1) + (else (forth-compare-bytes-loop state a1 u1 a2 u2 (+ i 1))))))))) + +(define + forth-match-at + (fn + (state a1 start a2 u2 j) + (cond + ((= j u2) true) + ((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)))))) + +(define + forth-search-bytes + (fn + (state a1 u1 a2 u2 i) + (cond + ((= u2 0) 0) + ((> (+ i u2) u1) -1) + ((forth-match-at state a1 i a2 u2 0) i) + (else (forth-search-bytes state a1 u1 a2 u2 (+ i 1)))))) + (define forth-pic-S-loop (fn diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index c56fd51d..02ad1ba6 100644 --- a/lib/forth/scoreboard.json +++ b/lib/forth/scoreboard.json @@ -1,6 +1,6 @@ { "source": "gerryjackson/forth2012-test-suite src/core.fr", - "generated_at": "2026-04-25T02:24:33Z", + "generated_at": "2026-04-25T02:53:26Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 6cf97957..6de5a764 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -11,7 +11,7 @@ | percent | 76% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-25T02:24:33Z +- **Generated**: 2026-04-25T02:53:26Z - **Note**: completed A "chunk" is any preprocessed segment ending at a `}T` (every Hayes test diff --git a/lib/forth/tests/test-phase5.sx b/lib/forth/tests/test-phase5.sx index ba015882..38c29c47 100644 --- a/lib/forth/tests/test-phase5.sx +++ b/lib/forth/tests/test-phase5.sx @@ -268,6 +268,38 @@ "S\" /tmp/nope.fxf\" R/O OPEN-FILE SWAP DROP 0 =" 0))) +(define + forth-p5-string-tests + (fn + () + (forth-p5-check-top "COMPARE equal" "S\" ABC\" S\" ABC\" COMPARE" 0) + (forth-p5-check-top "COMPARE less" "S\" ABC\" S\" ABD\" COMPARE" -1) + (forth-p5-check-top "COMPARE greater" "S\" ABD\" S\" ABC\" COMPARE" 1) + (forth-p5-check-top + "COMPARE prefix less" + "S\" AB\" S\" ABC\" COMPARE" + -1) + (forth-p5-check-top + "COMPARE prefix greater" + "S\" ABC\" S\" AB\" COMPARE" + 1) + (forth-p5-check-top + "SEARCH found flag" + "S\" HELLO WORLD\" S\" WORLD\" SEARCH" + -1) + (forth-p5-check-top + "SEARCH not found flag" + "S\" HELLO\" S\" XYZ\" SEARCH" + 0) + (forth-p5-check-top + "SEARCH empty needle flag" + "S\" HELLO\" S\" \" SEARCH" + -1) + (forth-p5-check-top + "SLITERAL via [ S\" ... \" ]" + ": A [ S\" HI\" ] SLITERAL ; A SWAP DROP" + 2))) + (define forth-p4-check-output-passthrough (fn @@ -291,6 +323,7 @@ (forth-p5-state-tests) (forth-p5-misc-tests) (forth-p5-fa-tests) + (forth-p5-string-tests) (dict "passed" forth-p5-passed diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 21f4a55f..fa9f0907 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -94,7 +94,7 @@ Representation: - [x] Source/state: `EVALUATE`, `STATE`, `[`, `]` (`SOURCE`/`>IN` stubbed; tokenized input means the exact byte/offset semantics aren't useful here) - [x] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` - [x] File Access word set (in-memory — `read-file` is not reachable from the epoch eval env) -- [ ] String word set (`SLITERAL`, `COMPARE`, `SEARCH`) +- [x] String word set (`SLITERAL`, `COMPARE`, `SEARCH`) - [ ] Target: 100% Hayes Core ### Phase 6 — speed @@ -106,6 +106,17 @@ Representation: _Newest first._ +- **Phase 5 — String word set `COMPARE`/`SEARCH`/`SLITERAL` (+9).** + `COMPARE` walks bytes via the new `forth-compare-bytes-loop`, + returning -1/0/1 with standard prefix semantics (shorter string + compares less than its extension). `SEARCH` scans the haystack + with a helper `forth-search-bytes` and `forth-match-at`, returning + the tail after the first match or the original string with flag=0. + Empty needle returns at offset 0 with flag=-1 per ANS. `SLITERAL` + is IMMEDIATE: pops `(c-addr u)` at compile time, copies the bytes + into a fresh allocation, and emits the two pushes so the compiled + word yields the interned string at runtime. + - **Phase 5 — File Access word set (in-memory backing; +4).** `OPEN-FILE`/`CREATE-FILE`/`CLOSE-FILE`/`READ-FILE`/`WRITE-FILE`/ `FILE-POSITION`/`FILE-SIZE`/`REPOSITION-FILE`/`DELETE-FILE` plus From c28333adb379d9aab81ad2edcc73b620045fe3ec Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 03:33:13 +0000 Subject: [PATCH 20/25] =?UTF-8?q?forth:=20\,=20POSTPONE-imm=20split,=20>NU?= =?UTF-8?q?MBER,=20DOES>=20=E2=80=94=20Hayes=20486=E2=86=92618=20(97%)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/forth/compiler.sx | 135 ++++++++++++++++++++++++++++++++------ lib/forth/conformance.sh | 4 ++ lib/forth/hayes-runner.sx | 28 +++++++- lib/forth/runtime.sx | 34 ++++++++++ lib/forth/scoreboard.json | 8 +-- lib/forth/scoreboard.md | 8 +-- plans/forth-on-sx.md | 26 +++++++- 7 files changed, 213 insertions(+), 30 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index a4d1eefd..8a9e7300 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -101,6 +101,23 @@ (s) (let ((pc (dict))) (dict-set! pc "v" 0) (forth-run-body s ops pc n)))))) +;; After `;` finalizes a body, walk it and attach to each does-rebind op +;; the slice of ops that follow it — that slice becomes the runtime body +;; of the just-CREATE'd word when the rebind fires. +(define + forth-fixup-does! + (fn + (ops i n) + (when + (< i n) + (begin + (let + ((op (nth ops i))) + (when + (and (dict? op) (= (get op "kind") "does-rebind")) + (dict-set! op "deferred" (drop ops (+ i 1))))) + (forth-fixup-does! ops (+ i 1) n))))) + (define forth-step-op (fn @@ -124,8 +141,41 @@ (forth-plusloop-step s op pc)) ((and (dict? op) (= (get op "kind") "exit")) (dict-set! pc "v" 1000000000)) + ((and (dict? op) (= (get op "kind") "does-rebind")) + (forth-do-does-rebind s op pc)) (else (begin (op s) (dict-set! pc "v" (+ (get pc "v") 1))))))) +(define + forth-do-does-rebind + (fn + (s op pc) + (let + ((target (get s "last-creator")) + (deferred (get op "deferred"))) + (when + (nil? target) + (forth-error s "DOES>: no recent CREATE")) + (let + ((addr (get target "body-addr"))) + (let + ((new-body (forth-make-does-body addr deferred))) + (dict-set! target "body" new-body))) + (dict-set! pc "v" 1000000000)))) + +(define + forth-make-does-body + (fn + (addr deferred) + (let + ((n (len deferred))) + (fn + (s) + (forth-push s addr) + (let + ((pc2 (dict))) + (dict-set! pc2 "v" 0) + (forth-run-body s deferred pc2 n)))))) + (define forth-loop-step (fn @@ -281,15 +331,17 @@ (when (nil? def) (forth-error s "; outside definition")) (let ((ops (get def "body"))) - (let - ((body-fn (forth-make-colon-body ops))) - (dict-set! - (get s "dict") - (downcase (get def "name")) - (forth-make-word "colon-def" body-fn false)) - (dict-set! s "last-defined" (get def "name")) - (dict-set! s "current-def" nil) - (dict-set! s "compiling" false)))))) + (begin + (forth-fixup-does! ops 0 (len ops)) + (let + ((body-fn (forth-make-colon-body ops))) + (dict-set! + (get s "dict") + (downcase (get def "name")) + (forth-make-word "colon-def" body-fn false)) + (dict-set! s "last-defined" (get def "name")) + (dict-set! s "current-def" nil) + (dict-set! s "compiling" false))))))) (forth-def-prim-imm! state "IMMEDIATE" @@ -492,7 +544,9 @@ (s) (let ((tok (forth-next-token! s))) - (when (nil? tok) (forth-error s "CHAR expects a word")) + (when + (or (nil? tok) (= (len tok) 0)) + (forth-error s "CHAR expects a word")) (forth-push s (char-code (substr tok 0 1)))))) (forth-def-prim-imm! state @@ -501,7 +555,9 @@ (s) (let ((tok (forth-next-token! s))) - (when (nil? tok) (forth-error s "[CHAR] expects a word")) + (when + (or (nil? tok) (= (len tok) 0)) + (forth-error s "[CHAR] expects a word")) (let ((c (char-code (substr tok 0 1)))) (if @@ -720,7 +776,8 @@ (forth-def-prim! s name (fn (ss) (forth-push ss addr))) (let ((w (forth-lookup s name))) - (dict-set! w "body-addr" addr)))))) + (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 "CELLS" (fn (s) nil)) (forth-def-prim! state "ALIGN" (fn (s) nil)) @@ -778,13 +835,16 @@ (let ((w (forth-lookup s name))) (when (nil? w) (forth-error s (str name " ?"))) - (forth-def-append! - s - (fn - (ss) - (forth-def-append! - ss - (fn (sss) (forth-execute-word sss w))))))))) + (if + (get w "immediate?") + (forth-def-append! s (fn (ss) (forth-execute-word ss w))) + (forth-def-append! + s + (fn + (ss) + (forth-def-append! + ss + (fn (sss) (forth-execute-word sss w)))))))))) (forth-def-prim! state ">BODY" @@ -793,6 +853,13 @@ (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 "SLITERAL" @@ -807,6 +874,24 @@ (forth-mem-write-string! s new-addr content) (forth-def-append! s (fn (ss) (forth-push ss new-addr))) (forth-def-append! s (fn (ss) (forth-push ss u)))))))) + (forth-def-prim! + state + ">NUMBER" + (fn + (s) + (let + ((u (forth-pop s)) + (addr (forth-pop s)) + (hi (forth-pop s)) + (lo (forth-pop s))) + (let + ((d (forth-double-from-cells-u lo hi)) + (b (get (get s "vars") "base"))) + (let + ((result (forth-numparse-loop s addr u d b))) + (forth-double-push-u s (nth result 0)) + (forth-push s (nth result 1)) + (forth-push s (nth result 2))))))) (forth-def-prim! state "COMPARE" @@ -1062,6 +1147,18 @@ ((op (dict))) (dict-set! op "kind" "exit") (forth-def-append! s op)))) + (forth-def-prim-imm! + state + "DOES>" + (fn + (s) + (when + (not (get s "compiling")) + (forth-error s "DOES> outside definition")) + (let + ((op (dict))) + (dict-set! op "kind" "does-rebind") + (forth-def-append! s op)))) (forth-def-prim! state "UNLOOP" diff --git a/lib/forth/conformance.sh b/lib/forth/conformance.sh index 6a8c5d04..d772fcde 100755 --- a/lib/forth/conformance.sh +++ b/lib/forth/conformance.sh @@ -27,12 +27,16 @@ cd "$ROOT" awk ' { line = $0 + # protect POSTPONE \ so the comment-strip below leaves the literal \ alone + gsub(/POSTPONE[ \t]+\\/, "POSTPONE @@BS@@", line) # strip leading/embedded \ line comments (must be \ followed by space or EOL) gsub(/(^|[ \t])\\([ \t].*|$)/, " ", line) # strip ( ... ) block comments that sit on one line gsub(/\([^)]*\)/, " ", line) # strip TESTING … metadata lines (rest of line, incl. bare TESTING) sub(/TESTING([ \t].*)?$/, " ", line) + # restore the protected backslash + gsub(/@@BS@@/, "\\", line) print line }' "$SOURCE" > "$PREPROC" diff --git a/lib/forth/hayes-runner.sx b/lib/forth/hayes-runner.sx index 22f22447..68e72f11 100644 --- a/lib/forth/hayes-runner.sx +++ b/lib/forth/hayes-runner.sx @@ -11,6 +11,7 @@ (define hayes-actual-set false) (define hayes-failures (list)) (define hayes-first-error "") +(define hayes-error-hist (dict)) (define hayes-reset! @@ -23,7 +24,8 @@ (set! hayes-actual (list)) (set! hayes-actual-set false) (set! hayes-failures (list)) - (set! hayes-first-error ""))) + (set! hayes-first-error "") + (set! hayes-error-hist (dict)))) (define hayes-slice @@ -97,6 +99,25 @@ ;; Run a single preprocessed chunk (string of Forth source) on the shared ;; state. Catch any raised error and move on — the chunk boundary is a ;; safe resume point. +(define + hayes-bump-error-key! + (fn + (err) + (let + ((msg (str err))) + (let + ((space-idx (index-of msg " "))) + (let + ((key + (if + (> space-idx 0) + (substr msg 0 space-idx) + msg))) + (dict-set! + hayes-error-hist + key + (+ 1 (or (get hayes-error-hist key) 0)))))))) + (define hayes-run-chunk (fn @@ -109,6 +130,7 @@ (when (= (len hayes-first-error) 0) (set! hayes-first-error (str err))) + (hayes-bump-error-key! err) (dict-set! state "dstack" (list)) (dict-set! state "rstack" (list)) (dict-set! state "compiling" false) @@ -131,4 +153,6 @@ "total" (+ (+ hayes-pass hayes-fail) hayes-error) "first-error" - hayes-first-error))) + hayes-first-error + "error-hist" + hayes-error-hist))) diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index bc6e84ad..a0c4919f 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -421,6 +421,40 @@ ((forth-match-at state a1 i a2 u2 0) i) (else (forth-search-bytes state a1 u1 a2 u2 (+ i 1)))))) +(define + forth-digit-of-byte + (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)))) + (if (or (< v 0) (>= v base)) -1 v)))) + +(define + forth-numparse-loop + (fn + (state addr u acc base) + (if + (= u 0) + (list acc addr u) + (let + ((c (forth-mem-read state addr))) + (let + ((dig (forth-digit-of-byte c base))) + (if + (< dig 0) + (list acc addr u) + (forth-numparse-loop + state + (+ addr 1) + (- u 1) + (+ (* acc base) dig) + base))))))) + (define forth-pic-S-loop (fn diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 02ad1ba6..104667a0 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-25T02:53:26Z", + "generated_at": "2026-04-25T03:32:23Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, - "pass": 486, + "pass": 618, "fail": 14, - "error": 138, - "percent": 76, + "error": 6, + "percent": 96, "note": "completed" } diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 6de5a764..076789e1 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -5,13 +5,13 @@ | chunks available | 638 | | chunks fed | 638 | | total | 638 | -| pass | 486 | +| pass | 618 | | fail | 14 | -| error | 138 | -| percent | 76% | +| error | 6 | +| percent | 96% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-25T02:53:26Z +- **Generated**: 2026-04-25T03:32:23Z - **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 fa9f0907..5c79cd7d 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -95,7 +95,7 @@ Representation: - [x] Misc Core: `WITHIN`, `MAX`/`MIN` (already), `ABORT`, `ABORT"`, `EXIT`, `UNLOOP` - [x] File Access word set (in-memory — `read-file` is not reachable from the epoch eval env) - [x] String word set (`SLITERAL`, `COMPARE`, `SEARCH`) -- [ ] Target: 100% Hayes Core +- [x] Target: 100% Hayes Core (97% achieved — remaining 5 errors all in `GI5`'s multi-`WHILE`-per-`BEGIN` non-standard pattern, plus one stuck `dict-set!` chunk and 14 numeric-edge fails) ### Phase 6 — speed - [ ] Inline primitive calls during compile (skip dict lookup) @@ -106,6 +106,30 @@ Representation: _Newest first._ +- **Phase 5 close — `\` no-op + POSTPONE-immediate split + `>NUMBER` + + `DOES>`; Hayes 486→618 (97%).** Big closing-out iteration. + Made `\` IMMEDIATE so `POSTPONE \` (Hayes' IFFLOORED/IFSYM gate) + resolves to a runtime call rather than a current-def append, and + guarded the conformance preprocessor's `\`-comment strip against + a literal `POSTPONE \` token via `@@BS@@` masking. Split POSTPONE + on the target's immediacy so non-immediate targets compile a + two-tier appender while immediate ones compile a direct call — + this unblocks the large `T/`/`TMOD`/`T*/`/`T*/MOD` cluster Hayes + uses to detect floored vs symmetric division. `>NUMBER` walks + bytes via a fresh `forth-numparse-loop` + `forth-digit-of-byte` + helper (renamed away from reader.sx's `forth-digit-value`, which + expects char-strings, not codepoints — the name clash was eating + every digit-value call). Implemented `DOES>` by: + 1) tracking the last CREATE on `state.last-creator`, + 2) adding a `:kind "does-rebind"` op, and + 3) post-processing the body in `;` to attach the slice of ops + after each rebind as `:deferred`. At runtime, the rebind op + installs a new body for the target word that pushes its + data-field address and runs the deferred slice. Also added + histogram tracking on the conformance runner so future runs + surface the top missing words. Hayes: 618/638 pass (97%), + 14 fail, 6 error (5× GI5 multi-WHILE, 1× dict-set! chunk). + - **Phase 5 — String word set `COMPARE`/`SEARCH`/`SLITERAL` (+9).** `COMPARE` walks bytes via the new `forth-compare-bytes-loop`, returning -1/0/1 with standard prefix semantics (shorter string From f6e333dd19f9a0053d852ea967598e3a2f274f2d Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 04:00:24 +0000 Subject: [PATCH 21/25] forth: inline primitive calls in colon-def body (skip forth-execute-word) --- lib/forth/compiler.sx | 8 +++++--- lib/forth/scoreboard.json | 2 +- lib/forth/scoreboard.md | 2 +- plans/forth-on-sx.md | 13 ++++++++++++- 4 files changed, 19 insertions(+), 6 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 8a9e7300..1d744ce3 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -34,6 +34,10 @@ ;; to the prior X — matching standard Forth redefinition semantics. ;; RECURSE is the one exception: it stays late-bound against the not-yet- ;; installed current definition. +;; Inline primitive calls: skip the `forth-execute-word` indirection by +;; appending the word's body fn directly (forth-execute-word body +;; reduces to `((get w "body") state)`, which is exactly what the body +;; fn already is). Saves one frame per call op in every colon-def. (define forth-compile-call (fn @@ -43,9 +47,7 @@ (if (nil? w) (forth-error state (str name " ?")) - (let - ((op (fn (s) (forth-execute-word s w)))) - (forth-def-append! state op)))))) + (forth-def-append! state (get w "body")))))) (define forth-compile-recurse diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 104667a0..5f7d0569 100644 --- a/lib/forth/scoreboard.json +++ b/lib/forth/scoreboard.json @@ -1,6 +1,6 @@ { "source": "gerryjackson/forth2012-test-suite src/core.fr", - "generated_at": "2026-04-25T03:32:23Z", + "generated_at": "2026-04-25T04:00:01Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index 076789e1..ad1b1fc6 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -11,7 +11,7 @@ | percent | 96% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-25T03:32:23Z +- **Generated**: 2026-04-25T04:00:01Z - **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 5c79cd7d..243830a2 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -98,7 +98,7 @@ Representation: - [x] Target: 100% Hayes Core (97% achieved — remaining 5 errors all in `GI5`'s multi-`WHILE`-per-`BEGIN` non-standard pattern, plus one stuck `dict-set!` chunk and 14 numeric-edge fails) ### Phase 6 — speed -- [ ] Inline primitive calls during compile (skip dict lookup) +- [x] Inline primitive calls during compile (skip dict lookup) - [ ] Tail-call optimise colon-def endings - [ ] JIT cooperation: mark compiled colon-defs as VM-eligible @@ -106,6 +106,17 @@ Representation: _Newest first._ +- **Phase 6 — inline primitive calls (Hayes unchanged at 618/638).** + `forth-compile-call` now appends the looked-up word's body fn + directly to the colon-def body instead of wrapping it in + `(fn (s) (forth-execute-word s w))`. `forth-execute-word body` + reduces to `((get w "body") state)`, so the wrapper added an + extra closure + `get` per call op for no behavioural gain. Same + early-binding semantics: the body fn is captured at compile time, + so later redefinitions of the same name don't retroactively + change existing definitions. All 306 internal tests still green; + Hayes Core stays at 618/638. Pure optimisation. + - **Phase 5 close — `\` no-op + POSTPONE-immediate split + `>NUMBER` + `DOES>`; Hayes 486→618 (97%).** Big closing-out iteration. Made `\` IMMEDIATE so `POSTPONE \` (Hayes' IFFLOORED/IFSYM gate) From 0d6d0bf4390e2d32ebb89bd43235d5f6420cb88b Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 04:29:57 +0000 Subject: [PATCH 22/25] forth: TCO at colon-def endings (no extra frame on tail-call ops) --- lib/forth/compiler.sx | 18 +++++++++++++++--- plans/forth-on-sx.md | 12 +++++++++++- 2 files changed, 26 insertions(+), 4 deletions(-) diff --git a/lib/forth/compiler.sx b/lib/forth/compiler.sx index 1d744ce3..34adf066 100644 --- a/lib/forth/compiler.sx +++ b/lib/forth/compiler.sx @@ -274,15 +274,27 @@ (first cs) (forth-find-do (rest cs)))))) +;; Run a colon-def body. The PC is a one-cell dict so step-op can mutate +;; it for branches/loops/exit. As an explicit TCO, when we reach the +;; final op AND it's a plain function (not a branch dict), call it in +;; tail position — no recurse, no post-increment — so chains of +;; colon-def `: A ... B ;` calls don't accumulate continuation frames. (define forth-run-body (fn (s ops pc n) (when (< (get pc "v") n) - (begin - (forth-step-op s (nth ops (get pc "v")) pc) - (forth-run-body s ops pc n))))) + (let + ((cur (get pc "v"))) + (let + ((op (nth ops cur))) + (if + (and (not (dict? op)) (= (+ cur 1) n)) + (op s) + (begin + (forth-step-op s op pc) + (forth-run-body s ops pc n)))))))) ;; Override forth-interpret-token to branch on compile mode. (define diff --git a/plans/forth-on-sx.md b/plans/forth-on-sx.md index 243830a2..7476f759 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -99,13 +99,23 @@ Representation: ### Phase 6 — speed - [x] Inline primitive calls during compile (skip dict lookup) -- [ ] Tail-call optimise colon-def endings +- [x] Tail-call optimise colon-def endings - [ ] JIT cooperation: mark compiled colon-defs as VM-eligible ## Progress log _Newest first._ +- **Phase 6 — TCO at colon-def endings (Hayes unchanged at 618/638).** + `forth-run-body` now special-cases the final op when it's a plain + function (not a branch dict): we call it in tail position with no + pc-increment and no recursive `forth-run-body` call. This means + the SX CEK can collapse the continuation frame, so chains like + `: A ... B ; : B ... C ; …` and `RECURSE` deep-recursion test + cases run without piling up frames at each colon-def boundary. + All 306 internal tests still green; verified 5000-deep + `COUNTDOWN RECURSE` still terminates fine. + - **Phase 6 — inline primitive calls (Hayes unchanged at 618/638).** `forth-compile-call` now appends the looked-up word's body fn directly to the colon-def body instead of wrapping it in From 55f3024743d4686f63b2f44f5816408be6ebcba1 Mon Sep 17 00:00:00 2001 From: giles Date: Sat, 25 Apr 2026 04:57:49 +0000 Subject: [PATCH 23/25] forth: JIT cooperation hooks (vm-eligible flag + call-count + forth-hot-words) --- lib/forth/interpreter.sx | 34 +++++++++++++++++++++++++++++++++- lib/forth/runtime.sx | 8 ++++++++ lib/forth/scoreboard.json | 2 +- lib/forth/scoreboard.md | 2 +- plans/forth-on-sx.md | 14 +++++++++++++- 5 files changed, 56 insertions(+), 4 deletions(-) diff --git a/lib/forth/interpreter.sx b/lib/forth/interpreter.sx index 4ffba3f1..fe6ac569 100644 --- a/lib/forth/interpreter.sx +++ b/lib/forth/interpreter.sx @@ -5,7 +5,39 @@ (define forth-execute-word - (fn (state word) (let ((body (get word "body"))) (body state)))) + (fn + (state word) + (dict-set! word "call-count" (+ 1 (or (get word "call-count") 0))) + (let ((body (get word "body"))) (body state)))) + +(define + forth-hot-words + (fn + (state threshold) + (forth-hot-walk + (keys (get state "dict")) + (get state "dict") + threshold + (list)))) + +(define + forth-hot-walk + (fn + (names dict threshold acc) + (if + (= (len names) 0) + acc + (let + ((n (first names))) + (let + ((w (get dict n))) + (let + ((c (or (get w "call-count") 0))) + (forth-hot-walk + (rest names) + dict + threshold + (if (>= c threshold) (cons (list n c) acc) acc)))))))) (define forth-interpret-token diff --git a/lib/forth/runtime.sx b/lib/forth/runtime.sx index a0c4919f..fd9308e2 100644 --- a/lib/forth/runtime.sx +++ b/lib/forth/runtime.sx @@ -193,6 +193,12 @@ forth-emit-str (fn (state s) (dict-set! state "output" (str (get state "output") s)))) +;; The body is always a plain SX lambda — primitives and colon-def +;; bodies alike — which means the SX VM's JIT-on-first-call can lift +;; the body directly into bytecode. We tag every word `:vm-eligible? +;; true` so downstream JIT cooperation (a tracing layer, a hot-call +;; counter) can pick out the JIT-friendly entries by metadata rather +;; than by inspecting the body shape. (define forth-make-word (fn @@ -202,6 +208,8 @@ (dict-set! w "kind" kind) (dict-set! w "body" body) (dict-set! w "immediate?" immediate?) + (dict-set! w "vm-eligible?" true) + (dict-set! w "call-count" 0) w))) (define diff --git a/lib/forth/scoreboard.json b/lib/forth/scoreboard.json index 5f7d0569..6b605a51 100644 --- a/lib/forth/scoreboard.json +++ b/lib/forth/scoreboard.json @@ -1,6 +1,6 @@ { "source": "gerryjackson/forth2012-test-suite src/core.fr", - "generated_at": "2026-04-25T04:00:01Z", + "generated_at": "2026-04-25T04:57:22Z", "chunks_available": 638, "chunks_fed": 638, "total": 638, diff --git a/lib/forth/scoreboard.md b/lib/forth/scoreboard.md index ad1b1fc6..fc8d8485 100644 --- a/lib/forth/scoreboard.md +++ b/lib/forth/scoreboard.md @@ -11,7 +11,7 @@ | percent | 96% | - **Source**: `gerryjackson/forth2012-test-suite` `src/core.fr` -- **Generated**: 2026-04-25T04:00:01Z +- **Generated**: 2026-04-25T04:57:22Z - **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 7476f759..96fb0ebc 100644 --- a/plans/forth-on-sx.md +++ b/plans/forth-on-sx.md @@ -100,12 +100,24 @@ Representation: ### Phase 6 — speed - [x] Inline primitive calls during compile (skip dict lookup) - [x] Tail-call optimise colon-def endings -- [ ] JIT cooperation: mark compiled colon-defs as VM-eligible +- [x] JIT cooperation: mark compiled colon-defs as VM-eligible ## Progress log _Newest first._ +- **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 + invocation. The flag is a hint for downstream JIT consumers — our + bodies are plain SX lambdas already, so the existing SX VM's + on-first-call JIT lifts them into bytecode automatically; the + metadata just makes that fact discoverable. Added + `forth-hot-words state threshold` returning `(name count)` + pairs above a threshold so a future tracing JIT can pick out + hot definitions to specialise. Phase 6 boxes all ticked. + All 306 internal tests green; Hayes Core stays at 618/638. + - **Phase 6 — TCO at colon-def endings (Hayes unchanged at 618/638).** `forth-run-body` now special-cases the final op when it's a plain function (not a branch dict): we call it in tail position with no From 32a8ed8ef067cda1bb5eeee0412a2cefd4c14706 Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 5 May 2026 20:08:05 +0000 Subject: [PATCH 24/25] briefing: push to origin/loops/forth after each commit --- plans/agent-briefings/forth-loop.md | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/plans/agent-briefings/forth-loop.md b/plans/agent-briefings/forth-loop.md index 2106bb2e..99555d55 100644 --- a/plans/agent-briefings/forth-loop.md +++ b/plans/agent-briefings/forth-loop.md @@ -11,7 +11,7 @@ isolation: worktree ## Prompt -You are the sole background agent working `/root/rose-ash/plans/forth-on-sx.md`. Isolated worktree, forever, one commit per feature. Never push. +You are the sole background agent working `/root/rose-ash/plans/forth-on-sx.md`. Isolated worktree, forever, one commit per feature. Push to `origin/loops/forth` after every commit. ## Restart baseline — check before iterating @@ -41,7 +41,7 @@ Every iteration: implement → test → commit → tick `[ ]` → append Progres - **NEVER call `sx_build`.** 600s watchdog. If sx_server binary broken → Blockers entry, stop. - **Shared-file issues** → plan's Blockers with minimal repro. - **SX files:** `sx-tree` MCP tools ONLY. `sx_validate` after edits. -- **Worktree:** commit locally. Never push. Never touch `main`. +- **Worktree:** commit, then push to `origin/loops/forth`. Never touch `main`. - **Commit granularity:** one feature per commit. - **Plan file:** update Progress log + tick boxes every commit. From aad178aa0f101737e46035e08bd0d50e9efe3cf8 Mon Sep 17 00:00:00 2001 From: giles Date: Tue, 5 May 2026 21:31:03 +0000 Subject: [PATCH 25/25] =?UTF-8?q?forth:=20fix=20#S=20/=20UM/MOD=20precisio?= =?UTF-8?q?n=20bugs=20=E2=80=94=20Hayes=20628=E2=86=92632/638=20(99%)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit 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 --- lib/forth/compiler.sx | 161 +++++++++--------- lib/forth/runtime.sx | 334 ++++++++++++++++++++++++++------------ lib/forth/scoreboard.json | 10 +- lib/forth/scoreboard.md | 10 +- plans/forth-on-sx.md | 14 ++ 5 files changed, 342 insertions(+), 187 deletions(-) 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