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