From 16167c5d9b92650043d4214f2469cc9dbb314908 Mon Sep 17 00:00:00 2001 From: giles Date: Thu, 7 May 2026 01:44:19 +0000 Subject: [PATCH] =?UTF-8?q?apl:=20dfn=20complete=20=E2=80=94=20guards,=20l?= =?UTF-8?q?ocals,=20=E2=88=87=20recursion,=20=E2=8D=BA=E2=86=90=20default?= =?UTF-8?q?=20(+9=20tests,=20235/235)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/apl/tests/dfn.sx | 164 +++++++++++++++++++++++++++++++++++++------ lib/apl/transpile.sx | 85 +++++++++++++++++----- plans/apl-on-sx.md | 5 +- 3 files changed, 212 insertions(+), 42 deletions(-) diff --git a/lib/apl/tests/dfn.sx b/lib/apl/tests/dfn.sx index fbd58b6f..0f22ad51 100644 --- a/lib/apl/tests/dfn.sx +++ b/lib/apl/tests/dfn.sx @@ -3,65 +3,73 @@ (define rv (fn (arr) (get arr :ravel))) (define sh (fn (arr) (get arr :shape))) -(define num (fn (n) (list :num n))) -(define name (fn (s) (list :name s))) -(define fnglyph (fn (g) (list :fn-glyph g))) -(define monad (fn (g a) (list :monad (fnglyph g) a))) -(define dyad (fn (g l r) (list :dyad (fnglyph g) l r))) -(define dfn (fn (body) (list :dfn body))) -(define prog (fn (stmts) (cons :program stmts))) +(define mknum (fn (n) (list :num n))) +(define mkname (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 mkdfn1 (fn (body) (list :dfn body))) +(define mkprog (fn (stmts) (cons :program stmts))) + +(define mkasg (fn (mkname expr) (list :assign mkname expr))) + +(define mkgrd (fn (c e) (list :guard c e))) + +(define mkdfn (fn (stmts) (cons :dfn stmts))) (apl-test "eval :num literal" - (rv (apl-eval-ast (num 42) {})) + (rv (apl-eval-ast (mknum 42) {})) (list 42)) (apl-test "eval :num literal shape" - (sh (apl-eval-ast (num 42) {})) + (sh (apl-eval-ast (mknum 42) {})) (list)) (apl-test "eval :dyad +" - (rv (apl-eval-ast (dyad "+" (num 2) (num 3)) {})) + (rv (apl-eval-ast (mkdyd "+" (mknum 2) (mknum 3)) {})) (list 5)) (apl-test "eval :dyad ×" - (rv (apl-eval-ast (dyad "×" (num 6) (num 7)) {})) + (rv (apl-eval-ast (mkdyd "×" (mknum 6) (mknum 7)) {})) (list 42)) (apl-test "eval :monad - (negate)" - (rv (apl-eval-ast (monad "-" (num 7)) {})) + (rv (apl-eval-ast (mkmon "-" (mknum 7)) {})) (list -7)) (apl-test "eval :monad ⌊ (floor)" - (rv (apl-eval-ast (monad "⌊" (num 3)) {})) + (rv (apl-eval-ast (mkmon "⌊" (mknum 3)) {})) (list 3)) (apl-test "eval :name ⍵ from env" - (rv (apl-eval-ast (name "⍵") {:omega (apl-scalar 99) :alpha nil})) + (rv (apl-eval-ast (mkname "⍵") {:omega (apl-scalar 99) :alpha nil})) (list 99)) (apl-test "eval :name ⍺ from env" - (rv (apl-eval-ast (name "⍺") {:omega nil :alpha (apl-scalar 7)})) + (rv (apl-eval-ast (mkname "⍺") {:omega nil :alpha (apl-scalar 7)})) (list 7)) (apl-test "dfn {⍵+1} called monadic" (rv - (apl-call-dfn-m (dfn (dyad "+" (name "⍵") (num 1))) (apl-scalar 5))) + (apl-call-dfn-m + (mkdfn1 (mkdyd "+" (mkname "⍵") (mknum 1))) + (apl-scalar 5))) (list 6)) (apl-test "dfn {⍺+⍵} called dyadic" (rv (apl-call-dfn - (dfn (dyad "+" (name "⍺") (name "⍵"))) + (mkdfn1 (mkdyd "+" (mkname "⍺") (mkname "⍵"))) (apl-scalar 4) (apl-scalar 9))) (list 13)) @@ -70,7 +78,7 @@ "dfn {⍺×⍵} dyadic on vectors" (rv (apl-call-dfn - (dfn (dyad "×" (name "⍺") (name "⍵"))) + (mkdfn1 (mkdyd "×" (mkname "⍺") (mkname "⍵"))) (make-array (list 3) (list 1 2 3)) (make-array (list 3) (list 10 20 30)))) (list 10 40 90)) @@ -79,7 +87,7 @@ "dfn {-⍵} monadic negate" (rv (apl-call-dfn-m - (dfn (monad "-" (name "⍵"))) + (mkdfn1 (mkmon "-" (mkname "⍵"))) (make-array (list 3) (list 1 2 3)))) (list -1 -2 -3)) @@ -87,21 +95,133 @@ "dfn {⍺-⍵} dyadic subtract scalar" (rv (apl-call-dfn - (dfn (dyad "-" (name "⍺") (name "⍵"))) + (mkdfn1 (mkdyd "-" (mkname "⍺") (mkname "⍵"))) (apl-scalar 10) (apl-scalar 3))) (list 7)) (apl-test "dfn {⌈⍺,⍵} not used (just verify : missing) — ceiling of right" - (rv (apl-call-dfn-m (dfn (monad "⌈" (name "⍵"))) (apl-scalar 5))) + (rv + (apl-call-dfn-m (mkdfn1 (mkmon "⌈" (mkname "⍵"))) (apl-scalar 5))) (list 5)) (apl-test "dfn nested dyad" (rv (apl-call-dfn - (dfn (dyad "+" (name "⍺") (dyad "×" (name "⍵") (num 2)))) + (mkdfn1 + (mkdyd "+" (mkname "⍺") (mkdyd "×" (mkname "⍵") (mknum 2)))) (apl-scalar 1) (apl-scalar 3))) (list 7)) + +(apl-test + "dfn local assign x←⍵+1; ⍺×x" + (rv + (apl-call-dfn + (mkdfn + (list + (mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 1))) + (mkdyd "×" (mkname "⍺") (mkname "x")))) + (apl-scalar 3) + (apl-scalar 4))) + (list 15)) + +(apl-test + "dfn guard: 0=⍵:99; ⍵×2 (true branch)" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99)) + (mkdyd "×" (mkname "⍵") (mknum 2)))) + (apl-scalar 0))) + (list 99)) + +(apl-test + "dfn guard: 0=⍵:99; ⍵×2 (false branch)" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 99)) + (mkdyd "×" (mkname "⍵") (mknum 2)))) + (apl-scalar 5))) + (list 10)) + +(apl-test + "dfn default ⍺←10 used (monadic call)" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkasg "⍺" (mknum 10)) + (mkdyd "+" (mkname "⍺") (mkname "⍵")))) + (apl-scalar 5))) + (list 15)) + +(apl-test + "dfn default ⍺←10 ignored when ⍺ given (dyadic call)" + (rv + (apl-call-dfn + (mkdfn + (list + (mkasg "⍺" (mknum 10)) + (mkdyd "+" (mkname "⍺") (mkname "⍵")))) + (apl-scalar 100) + (apl-scalar 5))) + (list 105)) + +(apl-test + "dfn ∇ recursion: factorial via guard" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1)) + (mkdyd + "×" + (mkname "⍵") + (mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1)))))) + (apl-scalar 5))) + (list 120)) + +(apl-test + "dfn ∇ recursion: 3 → 6 (factorial)" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 0) (mkname "⍵")) (mknum 1)) + (mkdyd + "×" + (mkname "⍵") + (mkmon "∇" (mkdyd "-" (mkname "⍵") (mknum 1)))))) + (apl-scalar 3))) + (list 6)) + +(apl-test + "dfn local: x←⍵+10; y←x×2; y" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkasg "x" (mkdyd "+" (mkname "⍵") (mknum 10))) + (mkasg "y" (mkdyd "×" (mkname "x") (mknum 2))) + (mkname "y"))) + (apl-scalar 5))) + (list 30)) + +(apl-test + "dfn first guard wins: many guards" + (rv + (apl-call-dfn-m + (mkdfn + (list + (mkgrd (mkdyd "=" (mknum 1) (mkname "⍵")) (mknum 100)) + (mkgrd (mkdyd "=" (mknum 2) (mkname "⍵")) (mknum 200)) + (mkgrd (mkdyd "=" (mknum 3) (mkname "⍵")) (mknum 300)) + (mknum 0))) + (apl-scalar 2))) + (list 200)) diff --git a/lib/apl/transpile.sx b/lib/apl/transpile.sx index 580c25cb..871a69c2 100644 --- a/lib/apl/transpile.sx +++ b/lib/apl/transpile.sx @@ -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)))) diff --git a/plans/apl-on-sx.md b/plans/apl-on-sx.md index 4a396cb1..afd9808e 100644 --- a/plans/apl-on-sx.md +++ b/plans/apl-on-sx.md @@ -86,8 +86,8 @@ Core mapping: - [x] 40+ tests in `lib/apl/tests/operators.sx` ### Phase 5 — dfns + tradfns + control flow -- [ ] Dfn `{…}` with `⍺` (left arg, may be absent → niladic/monadic), `⍵` (right arg), `∇` (recurse), guards `cond:expr`, default left arg `⍺←default` -- [ ] Local assignment via `←` (lexical inside dfn) +- [x] Dfn `{…}` with `⍺` (left arg, may be absent → niladic/monadic), `⍵` (right arg), `∇` (recurse), guards `cond:expr`, default left arg `⍺←default` +- [x] Local assignment via `←` (lexical inside dfn) - [ ] Tradfn `∇` header: `R←L F R;l1;l2`, statement-by-statement, branch via `→linenum` - [ ] Dyalog control words: `:If/:Else/:EndIf`, `:While/:EndWhile`, `:For X :In V :EndFor`, `:Select/:Case/:EndSelect`, `:Trap`/`:EndTrap` - [ ] Niladic / monadic / dyadic dispatch (function valence at definition time) @@ -118,6 +118,7 @@ data; format for string templating. _Newest first._ +- 2026-05-07: Phase 5 dfn complete — apl-eval-stmts (guards, locals, ⍺←default), ∇ recursion via env "nabla"; +9 tests (factorial, guards, defaults, locals); 235/235 tests - 2026-05-07: Phase 5 dfn foundation — lib/apl/transpile.sx with apl-eval-ast (handles :num :vec :name :monad :dyad :program :dfn) + glyph→fn lookup tables; apl-call-dfn / apl-call-dfn-m bind ⍺/⍵; ∇/guards/defaults/locals pending; 226/226 tests - 2026-05-07: Phase 4 step 10 — at @ (apl-at-replace + apl-at-apply); linear-index lookup, scalar-vals broadcast; 211/211 tests - 2026-05-07: Phase 4 step 9 — rank f⍤k (apl-rank); cell decomposition + reassembly via frame/cell shapes; 201/201 tests