diff --git a/lib/apl/parser.sx b/lib/apl/parser.sx index fc599730..607f9c84 100644 --- a/lib/apl/parser.sx +++ b/lib/apl/parser.sx @@ -84,20 +84,46 @@ (define apl-quad-fn-names (list "⎕FMT" "⎕←")) -(define - apl-parse-op-glyph? - (fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs))) +(define apl-known-fn-names (list)) ; ============================================================ ; Token accessors ; ============================================================ +(define + apl-collect-fn-bindings + (fn + (stmt-groups) + (set! apl-known-fn-names (list)) + (for-each + (fn + (toks) + (when + (and + (>= (len toks) 3) + (= (tok-type (nth toks 0)) :name) + (= (tok-type (nth toks 1)) :assign) + (= (tok-type (nth toks 2)) :lbrace)) + (set! + apl-known-fn-names + (cons (tok-val (nth toks 0)) apl-known-fn-names)))) + stmt-groups))) + +(define + apl-parse-op-glyph? + (fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs))) + (define apl-parse-fn-glyph? (fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs))) (define tok-type (fn (tok) (get tok :type))) +; ============================================================ +; Collect trailing operators starting at index i +; Returns {:ops (op ...) :end new-i} +; ============================================================ + (define tok-val (fn (tok) (get tok :value))) (define @@ -107,8 +133,8 @@ (and (= (tok-type tok) :glyph) (apl-parse-op-glyph? (tok-val tok))))) ; ============================================================ -; Collect trailing operators starting at index i -; Returns {:ops (op ...) :end new-i} +; Build a derived-fn node by chaining operators left-to-right +; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+")))) ; ============================================================ (define @@ -119,15 +145,17 @@ (and (= (tok-type tok) :glyph) (apl-parse-fn-glyph? (tok-val tok))) (and (= (tok-type tok) :name) - (some (fn (q) (= q (tok-val tok))) apl-quad-fn-names))))) + (or + (some (fn (q) (= q (tok-val tok))) apl-quad-fn-names) + (some (fn (q) (= q (tok-val tok))) apl-known-fn-names)))))) + +; ============================================================ +; Find matching close bracket/paren/brace +; Returns the index of the matching close token +; ============================================================ (define collect-ops (fn (tokens i) (collect-ops-loop tokens i (list)))) -; ============================================================ -; Build a derived-fn node by chaining operators left-to-right -; (+/¨ → (:derived-fn "¨" (:derived-fn "/" (:fn-glyph "+")))) -; ============================================================ - (define collect-ops-loop (fn @@ -143,8 +171,10 @@ {:end i :ops acc}))))) ; ============================================================ -; Find matching close bracket/paren/brace -; Returns the index of the matching close token +; Segment collection: scan tokens left-to-right, building +; a list of {:kind "val"/"fn" :node ast} segments. +; Operators following function glyphs are merged into +; derived-fn nodes during this pass. ; ============================================================ (define @@ -163,12 +193,20 @@ (find-matching-close-loop tokens start open-type close-type 1))) ; ============================================================ -; Segment collection: scan tokens left-to-right, building -; a list of {:kind "val"/"fn" :node ast} segments. -; Operators following function glyphs are merged into -; derived-fn nodes during this pass. +; Build tree from segment list +; +; The segments are in left-to-right order. +; APL evaluates right-to-left, so the LEFTMOST function is +; the outermost (last-evaluated) node. +; +; Patterns: +; [val] → val node +; [fn val ...] → (:monad fn (build-tree rest)) +; [val fn val ...] → (:dyad fn val (build-tree rest)) +; [val val ...] → (:vec val1 val2 ...) — strand ; ============================================================ +; Find the index of the first function segment (returns -1 if none) (define find-matching-close-loop (fn @@ -208,21 +246,9 @@ collect-segments (fn (tokens) (collect-segments-loop tokens 0 (list)))) -; ============================================================ -; Build tree from segment list -; -; The segments are in left-to-right order. -; APL evaluates right-to-left, so the LEFTMOST function is -; the outermost (last-evaluated) node. -; -; Patterns: -; [val] → val node -; [fn val ...] → (:monad fn (build-tree rest)) -; [val fn val ...] → (:dyad fn val (build-tree rest)) -; [val val ...] → (:vec val1 val2 ...) — strand -; ============================================================ - -; Find the index of the first function segment (returns -1 if none) +; Build an array node from 0..n value segments +; If n=1 → return that segment's node +; If n>1 → return (:vec node1 node2 ...) (define collect-segments-loop (fn @@ -242,24 +268,38 @@ ((= tt :str) (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :str tv)}))) ((= tt :name) - (if - (some (fn (q) (= q tv)) apl-quad-fn-names) - (let - ((op-result (collect-ops tokens (+ i 1)))) + (cond + ((some (fn (q) (= q tv)) apl-quad-fn-names) (let - ((ops (get op-result :ops)) (ni (get op-result :end))) + ((op-result (collect-ops tokens (+ i 1)))) (let - ((fn-node (build-derived-fn (list :fn-glyph tv) ops))) - (collect-segments-loop - tokens - ni - (append acc {:kind "fn" :node fn-node}))))) - (let - ((br (maybe-bracket (list :name tv) tokens (+ i 1)))) - (collect-segments-loop - tokens - (nth br 1) - (append acc {:kind "val" :node (nth br 0)}))))) + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (let + ((fn-node (build-derived-fn (list :fn-glyph tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node fn-node})))))) + ((some (fn (q) (= q tv)) apl-known-fn-names) + (let + ((op-result (collect-ops tokens (+ i 1)))) + (let + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (let + ((fn-node (build-derived-fn (list :fn-name tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node fn-node})))))) + (else + (let + ((br (maybe-bracket (list :name tv) tokens (+ i 1)))) + (collect-segments-loop + tokens + (nth br 1) + (append acc {:kind "val" :node (nth br 0)})))))) ((= tt :lparen) (let ((end (find-matching-close tokens (+ i 1) :lparen :rparen))) @@ -346,9 +386,12 @@ (define find-first-fn (fn (segs) (find-first-fn-loop segs 0))) -; Build an array node from 0..n value segments -; If n=1 → return that segment's node -; If n>1 → return (:vec node1 node2 ...) + +; ============================================================ +; Split token list on statement separators (diamond / newline) +; Only splits at depth 0 (ignores separators inside { } or ( ) ) +; ============================================================ + (define find-first-fn-loop (fn @@ -370,10 +413,9 @@ (get (first segs) :node) (cons :vec (map (fn (s) (get s :node)) segs))))) - ; ============================================================ -; Split token list on statement separators (diamond / newline) -; Only splits at depth 0 (ignores separators inside { } or ( ) ) +; Parse a dfn body (tokens between { and }) +; Handles guard expressions: cond : expr ; ============================================================ (define @@ -408,11 +450,6 @@ split-statements (fn (tokens) (split-statements-loop tokens (list) (list) 0))) -; ============================================================ -; Parse a dfn body (tokens between { and }) -; Handles guard expressions: cond : expr -; ============================================================ - (define split-statements-loop (fn @@ -467,6 +504,10 @@ ((stmt-groups (split-statements tokens))) (let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts))))) +; ============================================================ +; Parse a single statement (assignment or expression) +; ============================================================ + (define parse-dfn-stmt (fn @@ -483,12 +524,17 @@ (parse-apl-expr body-tokens))) (parse-stmt tokens))))) +; ============================================================ +; Parse an expression from a flat token list +; ============================================================ + (define find-top-level-colon (fn (tokens i) (find-top-level-colon-loop tokens i 0))) ; ============================================================ -; Parse a single statement (assignment or expression) +; Main entry point +; parse-apl: string → AST ; ============================================================ (define @@ -508,10 +554,6 @@ ((and (= tt :colon) (= depth 0)) i) (true (find-top-level-colon-loop tokens (+ i 1) depth))))))) -; ============================================================ -; Parse an expression from a flat token list -; ============================================================ - (define parse-stmt (fn @@ -526,11 +568,6 @@ (parse-apl-expr (slice tokens 2))) (parse-apl-expr tokens)))) -; ============================================================ -; Main entry point -; parse-apl: string → AST -; ============================================================ - (define parse-apl-expr (fn @@ -547,13 +584,15 @@ ((tokens (apl-tokenize src))) (let ((stmt-groups (split-statements tokens))) - (if - (= (len stmt-groups) 0) - nil + (begin + (apl-collect-fn-bindings stmt-groups) (if - (= (len stmt-groups) 1) - (parse-stmt (first stmt-groups)) - (cons :program (map parse-stmt stmt-groups)))))))) + (= (len stmt-groups) 0) + nil + (if + (= (len stmt-groups) 1) + (parse-stmt (first stmt-groups)) + (cons :program (map parse-stmt stmt-groups))))))))) (define maybe-bracket diff --git a/lib/apl/tests/pipeline.sx b/lib/apl/tests/pipeline.sx index b878a15c..39d9c9fd 100644 --- a/lib/apl/tests/pipeline.sx +++ b/lib/apl/tests/pipeline.sx @@ -207,3 +207,38 @@ (apl-test "string: 'a' is rank-0 scalar" (mksh (apl-run "'a'")) (list)) (apl-test "string: 'hello' shape (5)" (mksh (apl-run "'hello'")) (list 5)) + +(apl-test + "named-fn: f ← {⍺+⍵} ⋄ 3 f 4 → 7" + (mkrv (apl-run "f ← {⍺+⍵} ⋄ 3 f 4")) + (list 7)) + +(apl-test + "named-fn monadic: sq ← {⍵×⍵} ⋄ sq 7 → 49" + (mkrv (apl-run "sq ← {⍵×⍵} ⋄ sq 7")) + (list 49)) + +(apl-test + "named-fn dyadic: hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4 → 25" + (mkrv (apl-run "hyp ← {((⍺×⍺)+⍵×⍵)} ⋄ 3 hyp 4")) + (list 25)) + +(apl-test + "named-fn: dbl ← {⍵+⍵} ⋄ dbl ⍳5" + (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ dbl ⍳5")) + (list 2 4 6 8 10)) + +(apl-test + "named-fn factorial via ∇ recursion" + (mkrv (apl-run "fact ← {0=⍵:1 ⋄ ⍵×∇⍵-1} ⋄ fact 5")) + (list 120)) + +(apl-test + "named-fn used twice in expr: dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4" + (mkrv (apl-run "dbl ← {⍵+⍵} ⋄ (dbl 3) + dbl 4")) + (list 14)) + +(apl-test + "named-fn with vector arg: neg ← {-⍵} ⋄ neg 1 2 3" + (mkrv (apl-run "neg ← {-⍵} ⋄ neg 1 2 3")) + (list -1 -2 -3)) diff --git a/lib/apl/transpile.sx b/lib/apl/transpile.sx index e17c5d88..88492881 100644 --- a/lib/apl/transpile.sx +++ b/lib/apl/transpile.sx @@ -429,6 +429,18 @@ ((f (apl-resolve-dyadic inner env))) (fn (arr) (apl-commute f arr)))) (else (error "apl-resolve-monadic: unsupported op"))))) + ((= tag :fn-name) + (let + ((nm (nth fn-node 1))) + (let + ((bound (get env nm))) + (if + (and + (list? bound) + (> (len bound) 0) + (= (first bound) :dfn)) + (fn (arg) (apl-call-dfn-m bound arg)) + (error "apl-resolve-monadic: name not bound to dfn"))))) (else (error "apl-resolve-monadic: unknown fn-node tag")))))) (define @@ -452,6 +464,18 @@ ((f (apl-resolve-dyadic inner env))) (fn (a b) (apl-commute-dyadic f a b)))) (else (error "apl-resolve-dyadic: unsupported op"))))) + ((= tag :fn-name) + (let + ((nm (nth fn-node 1))) + (let + ((bound (get env nm))) + (if + (and + (list? bound) + (> (len bound) 0) + (= (first bound) :dfn)) + (fn (a b) (apl-call-dfn bound a b)) + (error "apl-resolve-dyadic: name not bound to dfn"))))) ((= tag :outer) (let ((inner (nth fn-node 2))) diff --git a/plans/apl-on-sx.md b/plans/apl-on-sx.md index fb86d73f..cb42d734 100644 --- a/plans/apl-on-sx.md +++ b/plans/apl-on-sx.md @@ -148,7 +148,7 @@ programs run from source, and starts pushing on performance. a single `:name "⎕←"` token (don't split on the assign glyph); - string values in `apl-eval-ast` — handle `:str` (parser already produces them) by wrapping into a vector of character codes (or rank-0 string). -- [ ] **Named function definitions** — `f ← {⍺+⍵} ⋄ 1 f 2` and `2 f 3`. +- [x] **Named function definitions** — `f ← {⍺+⍵} ⋄ 1 f 2` and `2 f 3`. - parser: when `:assign`'s RHS is a `:dfn`, mark it as a function binding; - eval-ast: `:assign` of a dfn stores the dfn in env; - parser: a name in fn-position whose env value is a dfn dispatches as a fn; @@ -186,6 +186,7 @@ data; format for string templating. _Newest first._ +- 2026-05-07: Phase 8 step 2 — named function defs end-to-end via parser pre-scan; apl-known-fn-names + apl-collect-fn-bindings detect `name ← {...}` patterns; collect-segments-loop emits :fn-name for known names; resolver looks up env for :fn-name; supports recursion (∇ in named dfn); +7 tests including fact via ∇; 467/467 - 2026-05-07: Phase 8 step 1 — quick-wins bundle: decimal literals (3.7, ¯2.5), ⎕← passthrough as monadic fn (single-token via tokenizer special-case), :str AST in eval-ast (single-char→scalar, multi-char→vec); +10 tests; 460/460 - 2026-05-07: Phase 8 added — quick-wins bundle (decimals + ⎕← + strings), named functions, multi-axis bracket, .apl-files-as-tests, trains, perf - 2026-05-07: Phase 7 step 6 — :Trap exception machinery via R7RS guard; apl-throw raises tagged error, apl-trap-matches? checks codes (0=catch-all), :trap clause in apl-tradfn-eval-stmt wraps try-block with guard; :throw AST for testing; **Phase 7 complete, all unchecked plan items done**; +5 tests; 450/450