From e066e14267210ab22b1223645e740f0b48a55417 Mon Sep 17 00:00:00 2001 From: giles Date: Fri, 24 Apr 2026 17:58:37 +0000 Subject: [PATCH] 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