forth: IF/ELSE/THEN + PC-driven body runner (+18)

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"