apl: control words :If/:While/:For/:Select (+10 tests, 255/255)

lib/apl/transpile.sx

@@ -189,6 +189,94 @@
       ((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha nil}))
       (apl-eval-stmts stmts env))))
 
+(define
+  apl-tradfn-eval-block
+  (fn
+    (stmts env)
+    (if
+      (= (len stmts) 0)
+      env
+      (let
+        ((stmt (first stmts)))
+        (apl-tradfn-eval-block (rest stmts) (apl-tradfn-eval-stmt stmt env))))))
+
+(define
+  apl-tradfn-eval-while
+  (fn
+    (cond-expr body env)
+    (let
+      ((cond-val (apl-eval-ast cond-expr env)))
+      (if
+        (apl-truthy? cond-val)
+        (apl-tradfn-eval-while
+          cond-expr
+          body
+          (apl-tradfn-eval-block body env))
+        env))))
+
+(define
+  apl-tradfn-eval-for
+  (fn
+    (var-name items body env)
+    (if
+      (= (len items) 0)
+      env
+      (let
+        ((env-with-var (assoc env var-name (apl-scalar (first items)))))
+        (apl-tradfn-eval-for
+          var-name
+          (rest items)
+          body
+          (apl-tradfn-eval-block body env-with-var))))))
+
+(define
+  apl-tradfn-eval-select
+  (fn
+    (val cases default-block env)
+    (if
+      (= (len cases) 0)
+      (apl-tradfn-eval-block default-block env)
+      (let
+        ((c (first cases)))
+        (let
+          ((case-val (apl-eval-ast (first c) env)))
+          (if
+            (= (first (get val :ravel)) (first (get case-val :ravel)))
+            (apl-tradfn-eval-block (rest c) env)
+            (apl-tradfn-eval-select val (rest cases) default-block env)))))))
+
+(define
+  apl-tradfn-eval-stmt
+  (fn
+    (stmt env)
+    (let
+      ((tag (first stmt)))
+      (cond
+        ((= tag :assign)
+          (assoc env (nth stmt 1) (apl-eval-ast (nth stmt 2) env)))
+        ((= tag :if)
+          (let
+            ((cond-val (apl-eval-ast (nth stmt 1) env)))
+            (if
+              (apl-truthy? cond-val)
+              (apl-tradfn-eval-block (nth stmt 2) env)
+              (apl-tradfn-eval-block (nth stmt 3) env))))
+        ((= tag :while)
+          (apl-tradfn-eval-while (nth stmt 1) (nth stmt 2) env))
+        ((= tag :for)
+          (let
+            ((iter-val (apl-eval-ast (nth stmt 2) env)))
+            (apl-tradfn-eval-for
+              (nth stmt 1)
+              (get iter-val :ravel)
+              (nth stmt 3)
+              env)))
+        ((= tag :select)
+          (let
+            ((val (apl-eval-ast (nth stmt 1) env)))
+            (apl-tradfn-eval-select val (nth stmt 2) (nth stmt 3) env)))
+        (else (begin (apl-eval-ast stmt env) env))))))
+
 (define
   apl-tradfn-loop
   (fn
@@ -208,18 +296,12 @@
                   (let
                     ((target-num (first (get target :ravel))))
                     (apl-tradfn-loop stmts target-num env result-name))))
-              ((= tag :assign)
-                (let
-                  ((v (apl-eval-ast (nth stmt 2) env)))
-                  (apl-tradfn-loop
-                    stmts
-                    (+ line 1)
-                    (assoc env (nth stmt 1) v)
-                    result-name)))
               (else
-                (begin
-                  (apl-eval-ast stmt env)
-                  (apl-tradfn-loop stmts (+ line 1) env result-name))))))))))
+                (apl-tradfn-loop
+                  stmts
+                  (+ line 1)
+                  (apl-tradfn-eval-stmt stmt env)
+                  result-name)))))))))
 
 (define
   apl-call-tradfn