apl: tradfn ∇ header — line-numbered stmts + :branch goto (+10 tests, 245/245)

lib/apl/test.sh

@@ -29,6 +29,7 @@ cat > "$TMPFILE" << 'EPOCHS'
 (load "lib/apl/tests/structural.sx")
 (load "lib/apl/tests/operators.sx")
 (load "lib/apl/tests/dfn.sx")
+(load "lib/apl/tests/tradfn.sx")
 (epoch 4)
 (eval "(list apl-test-pass apl-test-fail)")
 EPOCHS

lib/apl/tests/tradfn.sx

@@ -0,0 +1,65 @@
+; Tests for apl-call-tradfn (manual structure construction).
+
+(define mkrv (fn (arr) (get arr :ravel)))
+(define mksh (fn (arr) (get arr :shape)))
+(define mknum (fn (n) (list :num n)))
+(define mknm (fn (s) (list :name s)))
+(define mkfg (fn (g) (list :fn-glyph g)))
+(define mkmon (fn (g a) (list :monad (mkfg g) a)))
+(define mkdyd (fn (g l r) (list :dyad (mkfg g) l r)))
+(define mkasg (fn (n e) (list :assign n e)))
+(define mkbr (fn (e) (list :branch e)))
+
+(apl-test
+  "tradfn R←L+W simple add"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 5) (apl-scalar 7)))
+  (list 12))
+
+(apl-test
+  "tradfn R←L×W"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 6) (apl-scalar 7)))
+  (list 42))
+
+(apl-test
+  "tradfn monadic R←-W"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkmon "-" (mknm "W")))) :alpha nil} nil (apl-scalar 9)))
+  (list -9))
+
+(apl-test
+  "tradfn →0 exits early"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknm "W")) (mkbr (mknum 0)) (mkasg "R" (mknum 999))) :alpha nil} nil (apl-scalar 7)))
+  (list 7))
+
+(apl-test
+  "tradfn branch to line 3 skips line 2"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 3)) (mkasg "R" (mknum 999)) (mkasg "R" (mknum 42))) :alpha nil} nil (apl-scalar 0)))
+  (list 42))
+
+(apl-test
+  "tradfn local var t←W+1; R←t×2"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "t" (mkdyd "+" (mknm "W") (mknum 1))) (mkasg "R" (mkdyd "×" (mknm "t") (mknum 2)))) :alpha nil} nil (apl-scalar 5)))
+  (list 12))
+
+(apl-test
+  "tradfn vector args"
+  (mkrv
+    (apl-call-tradfn
+      {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"}
+      (make-array (list 3) (list 1 2 3))
+      (make-array (list 3) (list 10 20 30))))
+  (list 11 22 33))
+
+(apl-test
+  "tradfn unset result returns nil"
+  (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkbr (mknum 0))) :alpha nil} nil (apl-scalar 5))
+  nil)
+
+(apl-test
+  "tradfn run-off end returns result"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "×" (mknm "W") (mknum 3)))) :alpha nil} nil (apl-scalar 7)))
+  (list 21))
+
+(apl-test
+  "tradfn loop sum 1+2+...+5 via branch"
+  (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "i" (mknum 1)) (mkasg "R" (mknum 0)) (mkasg "R" (mkdyd "+" (mknm "R") (mknm "i"))) (mkasg "i" (mkdyd "+" (mknm "i") (mknum 1))) (mkbr (mkdyd "×" (mkdyd "≤" (mknm "i") (mknm "W")) (mknum 3)))) :alpha nil} nil (apl-scalar 5)))
+  (list 15))

lib/apl/transpile.sx

@@ -188,3 +188,50 @@
     (let
       ((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha nil}))
       (apl-eval-stmts stmts env))))
+
+(define
+  apl-tradfn-loop
+  (fn
+    (stmts line env result-name)
+    (cond
+      ((= line 0) (get env result-name))
+      ((> line (len stmts)) (get env result-name))
+      (else
+        (let
+          ((stmt (nth stmts (- line 1))))
+          (let
+            ((tag (first stmt)))
+            (cond
+              ((= tag :branch)
+                (let
+                  ((target (apl-eval-ast (nth stmt 1) env)))
+                  (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))))))))))
+
+(define
+  apl-call-tradfn
+  (fn
+    (tradfn alpha omega)
+    (let
+      ((stmts (get tradfn :stmts))
+        (result-name (get tradfn :result))
+        (alpha-name (get tradfn :alpha))
+        (omega-name (get tradfn :omega)))
+      (let
+        ((env-a (if alpha-name (assoc {} alpha-name alpha) {})))
+        (let
+          ((env-ao (if omega-name (assoc env-a omega-name omega) env-a)))
+          (apl-tradfn-loop stmts 1 env-ao result-name))))))