forth: DO/LOOP/+LOOP/I/J/LEAVE + return stack words (+16)

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"

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

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

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