giles
637ba4102f
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m4s
Parser: apl-quad-fn-names list; is-fn-tok? + :name clause in collect-segments-loop now route ⎕FMT through fn pipeline. Eval-ast: :name branch dispatches ⎕IO/⎕ML/⎕FR/⎕TS to apl-quad-* niladics; apl-monadic-fn handles ⎕FMT. ⎕← (print) deferred — tokenizer splits ⎕← into name + :assign.
450 lines
13 KiB
Plaintext
450 lines
13 KiB
Plaintext
; APL transpile / AST evaluator
|
||
;
|
||
; Walks parsed AST nodes and evaluates against the runtime.
|
||
; Entry points:
|
||
; 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 "alpha", ⍵ under "omega",
|
||
; the dfn-ast itself under "nabla" (for ∇ recursion),
|
||
; user names under their literal name.
|
||
|
||
(define
|
||
apl-monadic-fn
|
||
(fn
|
||
(g)
|
||
(cond
|
||
((= g "+") apl-plus-m)
|
||
((= g "-") apl-neg-m)
|
||
((= g "×") apl-signum)
|
||
((= g "÷") apl-recip)
|
||
((= g "⌈") apl-ceil)
|
||
((= g "⌊") apl-floor)
|
||
((= g "⍳") apl-iota)
|
||
((= g "|") apl-abs)
|
||
((= g "*") apl-exp)
|
||
((= g "⍟") apl-ln)
|
||
((= g "!") apl-fact)
|
||
((= g "○") apl-pi-times)
|
||
((= g "~") apl-not)
|
||
((= g "≢") apl-tally)
|
||
((= g "⍴") apl-shape)
|
||
((= g "≡") apl-depth)
|
||
((= g "⊂") apl-enclose)
|
||
((= g "⊃") apl-disclose)
|
||
((= g ",") apl-ravel)
|
||
((= g "⌽") apl-reverse)
|
||
((= g "⊖") apl-reverse-first)
|
||
((= g "⍋") apl-grade-up)
|
||
((= g "⍒") apl-grade-down)
|
||
((= g "⎕FMT") apl-quad-fmt)
|
||
(else (error "no monadic fn for glyph")))))
|
||
|
||
(define
|
||
apl-dyadic-fn
|
||
(fn
|
||
(g)
|
||
(cond
|
||
((= g "+") apl-add)
|
||
((= g "-") apl-sub)
|
||
((= g "×") apl-mul)
|
||
((= g "÷") apl-div)
|
||
((= g "⌈") apl-max)
|
||
((= g "⌊") apl-min)
|
||
((= g "*") apl-pow)
|
||
((= g "⍟") apl-log)
|
||
((= g "|") apl-mod)
|
||
((= g "!") apl-binomial)
|
||
((= g "○") apl-trig)
|
||
((= g "<") apl-lt)
|
||
((= g "≤") apl-le)
|
||
((= g "=") apl-eq)
|
||
((= g "≥") apl-ge)
|
||
((= g ">") apl-gt)
|
||
((= g "≠") apl-ne)
|
||
((= g "∧") apl-and)
|
||
((= g "∨") apl-or)
|
||
((= g "⍱") apl-nor)
|
||
((= g "⍲") apl-nand)
|
||
((= g ",") apl-catenate)
|
||
((= g "⍪") apl-catenate-first)
|
||
((= g "⍴") apl-reshape)
|
||
((= g "↑") apl-take)
|
||
((= g "↓") apl-drop)
|
||
((= g "⌷") apl-squad)
|
||
((= g "⌽") apl-rotate)
|
||
((= g "⊖") apl-rotate-first)
|
||
((= g "∊") apl-member)
|
||
((= g "⍳") apl-index-of)
|
||
((= 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
|
||
(node env)
|
||
(let
|
||
((tag (first node)))
|
||
(cond
|
||
((= tag :num) (apl-scalar (nth node 1)))
|
||
((= tag :vec)
|
||
(let
|
||
((items (rest node)))
|
||
(let
|
||
((vals (map (fn (n) (apl-eval-ast n env)) items)))
|
||
(make-array
|
||
(list (len vals))
|
||
(map (fn (v) (first (get v :ravel))) vals)))))
|
||
((= tag :name)
|
||
(let
|
||
((nm (nth node 1)))
|
||
(cond
|
||
((= nm "⍺") (get env "alpha"))
|
||
((= nm "⍵") (get env "omega"))
|
||
((= nm "⎕IO") (apl-quad-io))
|
||
((= nm "⎕ML") (apl-quad-ml))
|
||
((= nm "⎕FR") (apl-quad-fr))
|
||
((= nm "⎕TS") (apl-quad-ts))
|
||
(else (get env nm)))))
|
||
((= tag :monad)
|
||
(let
|
||
((fn-node (nth node 1)) (arg (nth node 2)))
|
||
(if
|
||
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
|
||
(apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env))
|
||
((apl-resolve-monadic fn-node env) (apl-eval-ast arg env)))))
|
||
((= tag :dyad)
|
||
(let
|
||
((fn-node (nth node 1))
|
||
(lhs (nth node 2))
|
||
(rhs (nth node 3)))
|
||
(if
|
||
(and (= (first fn-node) :fn-glyph) (= (nth fn-node 1) "∇"))
|
||
(apl-call-dfn
|
||
(get env "nabla")
|
||
(apl-eval-ast lhs env)
|
||
(apl-eval-ast rhs env))
|
||
((apl-resolve-dyadic fn-node env)
|
||
(apl-eval-ast lhs env)
|
||
(apl-eval-ast rhs env)))))
|
||
((= tag :program) (apl-eval-stmts (rest node) env))
|
||
((= tag :dfn) node)
|
||
(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 :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 :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
|
||
(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))))
|
||
(else
|
||
(apl-tradfn-loop
|
||
stmts
|
||
(+ line 1)
|
||
(apl-tradfn-eval-stmt stmt 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))))))
|
||
|
||
(define
|
||
apl-ast-mentions-list?
|
||
(fn
|
||
(lst target)
|
||
(if
|
||
(= (len lst) 0)
|
||
false
|
||
(if
|
||
(apl-ast-mentions? (first lst) target)
|
||
true
|
||
(apl-ast-mentions-list? (rest lst) target)))))
|
||
|
||
(define
|
||
apl-ast-mentions?
|
||
(fn
|
||
(node target)
|
||
(cond
|
||
((not (list? node)) false)
|
||
((= (len node) 0) false)
|
||
((and (= (first node) :name) (= (nth node 1) target)) true)
|
||
(else (apl-ast-mentions-list? (rest node) target)))))
|
||
|
||
(define
|
||
apl-dfn-valence
|
||
(fn
|
||
(dfn-ast)
|
||
(let
|
||
((body (rest dfn-ast)))
|
||
(cond
|
||
((apl-ast-mentions-list? body "⍺") :dyadic)
|
||
((apl-ast-mentions-list? body "⍵") :monadic)
|
||
(else :niladic)))))
|
||
|
||
(define
|
||
apl-tradfn-valence
|
||
(fn
|
||
(tradfn)
|
||
(cond
|
||
((get tradfn :alpha) :dyadic)
|
||
((get tradfn :omega) :monadic)
|
||
(else :niladic))))
|
||
|
||
(define
|
||
apl-call
|
||
(fn
|
||
(f alpha omega)
|
||
(cond
|
||
((and (list? f) (> (len f) 0) (= (first f) :dfn))
|
||
(if alpha (apl-call-dfn f alpha omega) (apl-call-dfn-m f omega)))
|
||
((dict? f) (apl-call-tradfn f alpha omega))
|
||
(else (error "apl-call: not a function")))))
|
||
|
||
(define
|
||
apl-resolve-monadic
|
||
(fn
|
||
(fn-node env)
|
||
(let
|
||
((tag (first fn-node)))
|
||
(cond
|
||
((= tag :fn-glyph) (apl-monadic-fn (nth fn-node 1)))
|
||
((= tag :derived-fn)
|
||
(let
|
||
((op (nth fn-node 1)) (inner (nth fn-node 2)))
|
||
(cond
|
||
((= op "/")
|
||
(let
|
||
((f (apl-resolve-dyadic inner env)))
|
||
(fn (arr) (apl-reduce f arr))))
|
||
((= op "⌿")
|
||
(let
|
||
((f (apl-resolve-dyadic inner env)))
|
||
(fn (arr) (apl-reduce-first f arr))))
|
||
((= op "\\")
|
||
(let
|
||
((f (apl-resolve-dyadic inner env)))
|
||
(fn (arr) (apl-scan f arr))))
|
||
((= op "⍀")
|
||
(let
|
||
((f (apl-resolve-dyadic inner env)))
|
||
(fn (arr) (apl-scan-first f arr))))
|
||
((= op "¨")
|
||
(let
|
||
((f (apl-resolve-monadic inner env)))
|
||
(fn (arr) (apl-each f arr))))
|
||
((= op "⍨")
|
||
(let
|
||
((f (apl-resolve-dyadic inner env)))
|
||
(fn (arr) (apl-commute f arr))))
|
||
(else (error "apl-resolve-monadic: unsupported op")))))
|
||
(else (error "apl-resolve-monadic: unknown fn-node tag"))))))
|
||
|
||
(define
|
||
apl-resolve-dyadic
|
||
(fn
|
||
(fn-node env)
|
||
(let
|
||
((tag (first fn-node)))
|
||
(cond
|
||
((= tag :fn-glyph) (apl-dyadic-fn (nth fn-node 1)))
|
||
((= tag :derived-fn)
|
||
(let
|
||
((op (nth fn-node 1)) (inner (nth fn-node 2)))
|
||
(cond
|
||
((= op "¨")
|
||
(let
|
||
((f (apl-resolve-dyadic inner env)))
|
||
(fn (a b) (apl-each-dyadic f a b))))
|
||
((= op "⍨")
|
||
(let
|
||
((f (apl-resolve-dyadic inner env)))
|
||
(fn (a b) (apl-commute-dyadic f a b))))
|
||
(else (error "apl-resolve-dyadic: unsupported op")))))
|
||
((= tag :outer)
|
||
(let
|
||
((inner (nth fn-node 2)))
|
||
(let
|
||
((f (apl-resolve-dyadic inner env)))
|
||
(fn (a b) (apl-outer f a b)))))
|
||
((= tag :derived-fn2)
|
||
(let
|
||
((f-node (nth fn-node 2)) (g-node (nth fn-node 3)))
|
||
(let
|
||
((f (apl-resolve-dyadic f-node env))
|
||
(g (apl-resolve-dyadic g-node env)))
|
||
(fn (a b) (apl-inner f g a b)))))
|
||
(else (error "apl-resolve-dyadic: unknown fn-node tag"))))))
|
||
|
||
(define apl-run (fn (src) (apl-eval-ast (parse-apl src) {})))
|