coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

apl: dfn complete — guards, locals, ∇ recursion, ⍺← default (+9 tests, 235/235)
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m3s
Details

Browse Source
This commit is contained in:
giles
2026-05-07 01:44:19 +00:00
parent 84d210b6b3
commit 16167c5d9b
3 changed files with 212 additions and 42 deletions
Download Patch File Download Diff File Expand all files Collapse all files

85
lib/apl/transpile.sx
View File

@@ -2,12 +2,14 @@
;
; Walks parsed AST nodes and evaluates against the runtime.
; Entry points:
; apl-eval-ast : node × env → value
; apl-call-dfn : dfn-ast × ⍺ × ⍵ → value (dyadic)
; apl-call-dfn-m : dfn-ast × ⍵ → value (monadic)
; apl-eval-ast : node × env → value
; apl-eval-stmts : stmt-list × env → value (handles guards, locals, ⍺← default)
; apl-call-dfn : dfn-ast × ⍺ × ⍵ → value (dyadic)
; apl-call-dfn-m : dfn-ast × ⍵ → value (monadic)
;
; Env is a dict; ⍺ stored under key "alpha", ⍵ under "omega",
; user names under their literal name. nil means absent.
; Env is a dict; ⍺ stored under "alpha", ⍵ under "omega",
; the dfn-ast itself under "nabla" (for ∇ recursion),
; user names under their literal name.
(define
apl-monadic-fn
@@ -78,6 +80,14 @@
((= g "~") apl-without)
(else (error "no dyadic fn for glyph")))))
(define
apl-truthy?
(fn
(v)
(let
((rv (get v :ravel)))
(if (and (= (len rv) 1) (= (first rv) 0)) false true))))
(define
apl-eval-ast
(fn
@@ -106,7 +116,10 @@
((fn-node (nth node 1)) (arg (nth node 2)))
(let
((g (nth fn-node 1)))
((apl-monadic-fn g) (apl-eval-ast arg env)))))
(if
(= g "∇")
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
((apl-monadic-fn g) (apl-eval-ast arg env))))))
((= tag :dyad)
(let
((fn-node (nth node 1))
@@ -114,28 +127,64 @@
(rhs (nth node 3)))
(let
((g (nth fn-node 1)))
((apl-dyadic-fn g)
(apl-eval-ast lhs env)
(apl-eval-ast rhs env)))))
((= tag :program)
(let
((stmts (rest node)))
(reduce (fn (acc s) (apl-eval-ast s env)) nil stmts)))
(if
(= g "∇")
(apl-call-dfn
(get env "nabla")
(apl-eval-ast lhs env)
(apl-eval-ast rhs env))
((apl-dyadic-fn g)
(apl-eval-ast lhs env)
(apl-eval-ast rhs env))))))
((= tag :program) (apl-eval-stmts (rest node) env))
((= tag :dfn) node)
(else (error "apl-eval-ast: unknown node tag"))))))
(else (error (list "apl-eval-ast: unknown node tag" tag node)))))))
(define
apl-eval-stmts
(fn
(stmts env)
(if
(= (len stmts) 0)
nil
(let
((stmt (first stmts)) (more (rest stmts)))
(let
((tag (first stmt)))
(cond
((= tag :guard)
(let
((cond-val (apl-eval-ast (nth stmt 1) env)))
(if
(apl-truthy? cond-val)
(apl-eval-ast (nth stmt 2) env)
(apl-eval-stmts more env))))
((and (= tag :assign) (= (nth stmt 1) "⍺"))
(if
(get env "alpha")
(apl-eval-stmts more env)
(let
((v (apl-eval-ast (nth stmt 2) env)))
(apl-eval-stmts more (assoc env "alpha" v)))))
((= tag :assign)
(let
((v (apl-eval-ast (nth stmt 2) env)))
(apl-eval-stmts more (assoc env (nth stmt 1) v))))
((= (len more) 0) (apl-eval-ast stmt env))
(else (begin (apl-eval-ast stmt env) (apl-eval-stmts more env)))))))))
(define
apl-call-dfn
(fn
(dfn-ast alpha omega)
(let
((stmts (rest dfn-ast)) (env {:omega omega :alpha alpha}))
(reduce (fn (acc s) (apl-eval-ast s env)) nil stmts))))
((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha alpha}))
(apl-eval-stmts stmts env))))
(define
apl-call-dfn-m
(fn
(dfn-ast omega)
(let
((stmts (rest dfn-ast)) (env {:omega omega :alpha nil}))
(reduce (fn (acc s) (apl-eval-ast s env)) nil stmts))))
((stmts (rest dfn-ast)) (env {:omega omega :nabla dfn-ast :alpha nil}))
(apl-eval-stmts stmts env))))