diff --git a/lib/apl/parser.sx b/lib/apl/parser.sx index fc7303c0..cc7b83b5 100644 --- a/lib/apl/parser.sx +++ b/lib/apl/parser.sx @@ -34,90 +34,85 @@ "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆" "∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕")) -(define apl-parse-op-glyph? - (fn (v) - (some (fn (g) (= g v)) apl-parse-op-glyphs))) +(define apl-quad-fn-names (list "⎕FMT")) -(define apl-parse-fn-glyph? - (fn (v) - (some (fn (g) (= g v)) apl-parse-fn-glyphs))) +(define + apl-parse-op-glyph? + (fn (v) (some (fn (g) (= g v)) apl-parse-op-glyphs))) ; ============================================================ ; Token accessors ; ============================================================ -(define tok-type - (fn (tok) - (get tok :type))) +(define + apl-parse-fn-glyph? + (fn (v) (some (fn (g) (= g v)) apl-parse-fn-glyphs))) -(define tok-val - (fn (tok) - (get tok :value))) +(define tok-type (fn (tok) (get tok :type))) -(define is-op-tok? - (fn (tok) - (and (= (tok-type tok) :glyph) - (apl-parse-op-glyph? (tok-val tok))))) +(define tok-val (fn (tok) (get tok :value))) -(define is-fn-tok? - (fn (tok) - (and (= (tok-type tok) :glyph) - (apl-parse-fn-glyph? (tok-val tok))))) +(define + is-op-tok? + (fn + (tok) + (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} ; ============================================================ -(define collect-ops - (fn (tokens i) - (collect-ops-loop tokens i (list)))) +(define + is-fn-tok? + (fn + (tok) + (or + (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))))) -(define collect-ops-loop - (fn (tokens i acc) - (if (>= i (len tokens)) - {:ops acc :end i} - (let ((tok (nth tokens i))) - (if (is-op-tok? tok) - (collect-ops-loop tokens (+ i 1) (append acc (tok-val tok))) - {:ops acc :end i}))))) +(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 build-derived-fn - (fn (fn-node ops) - (if (= (len ops) 0) - fn-node - (build-derived-fn - (list :derived-fn (first ops) fn-node) - (rest ops))))) +(define + collect-ops-loop + (fn + (tokens i acc) + (if + (>= i (len tokens)) + {:end i :ops acc} + (let + ((tok (nth tokens i))) + (if + (is-op-tok? tok) + (collect-ops-loop tokens (+ i 1) (append acc (tok-val tok))) + {:end i :ops acc}))))) ; ============================================================ ; Find matching close bracket/paren/brace ; Returns the index of the matching close token ; ============================================================ -(define find-matching-close - (fn (tokens start open-type close-type) - (find-matching-close-loop tokens start open-type close-type 1))) +(define + build-derived-fn + (fn + (fn-node ops) + (if + (= (len ops) 0) + fn-node + (build-derived-fn (list :derived-fn (first ops) fn-node) (rest ops))))) -(define find-matching-close-loop - (fn (tokens i open-type close-type depth) - (if (>= i (len tokens)) - (len tokens) - (let ((tt (tok-type (nth tokens i)))) - (cond - ((= tt open-type) - (find-matching-close-loop tokens (+ i 1) open-type close-type (+ depth 1))) - ((= tt close-type) - (if (= depth 1) - i - (find-matching-close-loop tokens (+ i 1) open-type close-type (- depth 1)))) - (true - (find-matching-close-loop tokens (+ i 1) open-type close-type depth))))))) +(define + find-matching-close + (fn + (tokens start open-type close-type) + (find-matching-close-loop tokens start open-type close-type 1))) ; ============================================================ ; Segment collection: scan tokens left-to-right, building @@ -126,122 +121,44 @@ ; derived-fn nodes during this pass. ; ============================================================ -(define collect-segments - (fn (tokens) - (collect-segments-loop tokens 0 (list)))) +(define + find-matching-close-loop + (fn + (tokens i open-type close-type depth) + (if + (>= i (len tokens)) + (len tokens) + (let + ((tt (tok-type (nth tokens i)))) + (cond + ((= tt open-type) + (find-matching-close-loop + tokens + (+ i 1) + open-type + close-type + (+ depth 1))) + ((= tt close-type) + (if + (= depth 1) + i + (find-matching-close-loop + tokens + (+ i 1) + open-type + close-type + (- depth 1)))) + (true + (find-matching-close-loop + tokens + (+ i 1) + open-type + close-type + depth))))))) -(define collect-segments-loop - (fn (tokens i acc) - (if (>= i (len tokens)) - acc - (let ((tok (nth tokens i)) - (n (len tokens))) - (let ((tt (tok-type tok)) - (tv (tok-val tok))) - (cond - ; Skip separators - ((or (= tt :diamond) (= tt :newline) (= tt :semi)) - (collect-segments-loop tokens (+ i 1) acc)) - - ; Number → value segment - ((= tt :num) - (collect-segments-loop tokens (+ i 1) - (append acc {:kind "val" :node (list :num tv)}))) - - ; String → value segment - ((= tt :str) - (collect-segments-loop tokens (+ i 1) - (append acc {:kind "val" :node (list :str tv)}))) - - ; Name → always a value segment in Phase 1 - ; (Named functions with operators like f/ are Phase 5) - ((= tt :name) - (collect-segments-loop tokens (+ i 1) - (append acc {:kind "val" :node (list :name tv)}))) - - - ; Left paren → parse subexpression recursively - ((= tt :lparen) - (let ((end (find-matching-close tokens (+ i 1) :lparen :rparen))) - (let ((inner-tokens (slice tokens (+ i 1) end)) - (after (+ end 1))) - (collect-segments-loop tokens after - (append acc {:kind "val" :node (parse-apl-expr inner-tokens)}))))) - - ; Left brace → dfn - ((= tt :lbrace) - (let ((end (find-matching-close tokens (+ i 1) :lbrace :rbrace))) - (let ((inner-tokens (slice tokens (+ i 1) end)) - (after (+ end 1))) - (collect-segments-loop tokens after - (append acc {:kind "fn" :node (parse-dfn inner-tokens)}))))) - - ; Glyph token — need to classify - ((= tt :glyph) - (cond - ; Alpha (⍺) and Omega (⍵) → values inside dfn context - ((or (= tv "⍺") (= tv "⍵")) - (collect-segments-loop tokens (+ i 1) - (append acc {:kind "val" :node (list :name tv)}))) - - ; Nabla (∇) → self-reference function in dfn context - ((= tv "∇") - (collect-segments-loop tokens (+ i 1) - (append acc {:kind "fn" :node (list :fn-glyph "∇")}))) - - ; ∘. → outer product (special case: ∘ followed by .) - ((and (= tv "∘") - (< (+ i 1) n) - (= (tok-val (nth tokens (+ i 1))) ".")) - (if (and (< (+ i 2) n) (is-fn-tok? (nth tokens (+ i 2)))) - (let ((fn-tv (tok-val (nth tokens (+ i 2))))) - (let ((op-result (collect-ops tokens (+ i 3)))) - (let ((ops (get op-result :ops)) - (ni (get op-result :end))) - (let ((fn-node (build-derived-fn (list :fn-glyph fn-tv) ops))) - (collect-segments-loop tokens ni - (append acc {:kind "fn" :node (list :outer "∘." fn-node)})))))) - ; ∘. without function — treat ∘ as plain compose operator - ; skip the . and continue - (collect-segments-loop tokens (+ i 1) - acc))) - - ; Function glyph — collect following operators - ((apl-parse-fn-glyph? tv) - (let ((op-result (collect-ops tokens (+ i 1)))) - (let ((ops (get op-result :ops)) - (ni (get op-result :end))) - ; Check for inner product: fn . fn - ; (ops = ("." ) and next token is also a function glyph) - (if (and (= (len ops) 1) - (= (first ops) ".") - (< ni n) - (is-fn-tok? (nth tokens ni))) - ; f.g inner product - (let ((g-tv (tok-val (nth tokens ni)))) - (let ((op-result2 (collect-ops tokens (+ ni 1)))) - (let ((ops2 (get op-result2 :ops)) - (ni2 (get op-result2 :end))) - (let ((g-node (build-derived-fn (list :fn-glyph g-tv) ops2))) - (collect-segments-loop tokens ni2 - (append acc {:kind "fn" - :node (list :derived-fn2 "." (list :fn-glyph tv) g-node)})))))) - ; Regular function with zero or more operator modifiers - (let ((fn-node (build-derived-fn (list :fn-glyph tv) ops))) - (collect-segments-loop tokens ni - (append acc {:kind "fn" :node fn-node}))))))) - - ; Stray operator glyph — skip (shouldn't appear outside function context) - ((apl-parse-op-glyph? tv) - (collect-segments-loop tokens (+ i 1) acc)) - - ; Unknown glyph — skip - (true - (collect-segments-loop tokens (+ i 1) acc)))) - - ; Skip unknown token types - (true - (collect-segments-loop tokens (+ i 1) acc)))))))) +(define + collect-segments + (fn (tokens) (collect-segments-loop tokens 0 (list)))) ; ============================================================ ; Build tree from segment list @@ -258,179 +175,327 @@ ; ============================================================ ; Find the index of the first function segment (returns -1 if none) -(define find-first-fn - (fn (segs) - (find-first-fn-loop segs 0))) +(define + collect-segments-loop + (fn + (tokens i acc) + (if + (>= i (len tokens)) + acc + (let + ((tok (nth tokens i)) (n (len tokens))) + (let + ((tt (tok-type tok)) (tv (tok-val tok))) + (cond + ((or (= tt :diamond) (= tt :newline) (= tt :semi)) + (collect-segments-loop tokens (+ i 1) acc)) + ((= tt :num) + (collect-segments-loop tokens (+ i 1) (append acc {:kind "val" :node (list :num tv)}))) + ((= 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)))) + (let + ((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}))))) + (collect-segments-loop + tokens + (+ i 1) + (append acc {:kind "val" :node (list :name tv)})))) + ((= tt :lparen) + (let + ((end (find-matching-close tokens (+ i 1) :lparen :rparen))) + (let + ((inner-tokens (slice tokens (+ i 1) end)) + (after (+ end 1))) + (collect-segments-loop tokens after (append acc {:kind "val" :node (parse-apl-expr inner-tokens)}))))) + ((= tt :lbrace) + (let + ((end (find-matching-close tokens (+ i 1) :lbrace :rbrace))) + (let + ((inner-tokens (slice tokens (+ i 1) end)) + (after (+ end 1))) + (collect-segments-loop tokens after (append acc {:kind "fn" :node (parse-dfn inner-tokens)}))))) + ((= tt :glyph) + (cond + ((or (= tv "⍺") (= tv "⍵")) + (collect-segments-loop + tokens + (+ i 1) + (append acc {:kind "val" :node (list :name tv)}))) + ((= tv "∇") + (collect-segments-loop + tokens + (+ i 1) + (append acc {:kind "fn" :node (list :fn-glyph "∇")}))) + ((and (= tv "∘") (< (+ i 1) n) (= (tok-val (nth tokens (+ i 1))) ".")) + (if + (and (< (+ i 2) n) (is-fn-tok? (nth tokens (+ i 2)))) + (let + ((fn-tv (tok-val (nth tokens (+ i 2))))) + (let + ((op-result (collect-ops tokens (+ i 3)))) + (let + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (let + ((fn-node (build-derived-fn (list :fn-glyph fn-tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node (list :outer "∘." fn-node)})))))) + (collect-segments-loop tokens (+ i 1) acc))) + ((apl-parse-fn-glyph? tv) + (let + ((op-result (collect-ops tokens (+ i 1)))) + (let + ((ops (get op-result :ops)) + (ni (get op-result :end))) + (if + (and + (= (len ops) 1) + (= (first ops) ".") + (< ni n) + (is-fn-tok? (nth tokens ni))) + (let + ((g-tv (tok-val (nth tokens ni)))) + (let + ((op-result2 (collect-ops tokens (+ ni 1)))) + (let + ((ops2 (get op-result2 :ops)) + (ni2 (get op-result2 :end))) + (let + ((g-node (build-derived-fn (list :fn-glyph g-tv) ops2))) + (collect-segments-loop + tokens + ni2 + (append acc {:kind "fn" :node (list :derived-fn2 "." (list :fn-glyph tv) g-node)})))))) + (let + ((fn-node (build-derived-fn (list :fn-glyph tv) ops))) + (collect-segments-loop + tokens + ni + (append acc {:kind "fn" :node fn-node}))))))) + ((apl-parse-op-glyph? tv) + (collect-segments-loop tokens (+ i 1) acc)) + (true (collect-segments-loop tokens (+ i 1) acc)))) + (true (collect-segments-loop tokens (+ i 1) acc)))))))) -(define find-first-fn-loop - (fn (segs i) - (if (>= i (len segs)) - -1 - (if (= (get (nth segs i) :kind) "fn") - i - (find-first-fn-loop segs (+ i 1)))))) +(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 ...) -(define segs-to-array - (fn (segs) - (if (= (len segs) 1) +(define + find-first-fn-loop + (fn + (segs i) + (if + (>= i (len segs)) + -1 + (if + (= (get (nth segs i) :kind) "fn") + i + (find-first-fn-loop segs (+ i 1)))))) + +(define + segs-to-array + (fn + (segs) + (if + (= (len segs) 1) (get (first segs) :node) (cons :vec (map (fn (s) (get s :node)) segs))))) -(define build-tree - (fn (segs) - (cond - ; Empty → nil - ((= (len segs) 0) nil) - ; Single segment → return its node directly - ((= (len segs) 1) (get (first segs) :node)) - ; All values → strand - ((every? (fn (s) (= (get s :kind) "val")) segs) - (segs-to-array segs)) - ; Find the first function segment - (true - (let ((fn-idx (find-first-fn segs))) - (cond - ; No function found (shouldn't happen given above checks) → strand - ((= fn-idx -1) (segs-to-array segs)) - ; Function is first → monadic call - ((= fn-idx 0) - (list :monad - (get (first segs) :node) - (build-tree (rest segs)))) - ; Function at position fn-idx: left args are segs[0..fn-idx-1] - (true - (let ((left-segs (slice segs 0 fn-idx)) - (fn-seg (nth segs fn-idx)) - (right-segs (slice segs (+ fn-idx 1)))) - (list :dyad - (get fn-seg :node) - (segs-to-array left-segs) - (build-tree right-segs)))))))))) - ; ============================================================ ; Split token list on statement separators (diamond / newline) ; Only splits at depth 0 (ignores separators inside { } or ( ) ) ; ============================================================ -(define split-statements - (fn (tokens) - (split-statements-loop tokens (list) (list) 0))) +(define + build-tree + (fn + (segs) + (cond + ((= (len segs) 0) nil) + ((= (len segs) 1) (get (first segs) :node)) + ((every? (fn (s) (= (get s :kind) "val")) segs) + (segs-to-array segs)) + (true + (let + ((fn-idx (find-first-fn segs))) + (cond + ((= fn-idx -1) (segs-to-array segs)) + ((= fn-idx 0) + (list + :monad (get (first segs) :node) + (build-tree (rest segs)))) + (true + (let + ((left-segs (slice segs 0 fn-idx)) + (fn-seg (nth segs fn-idx)) + (right-segs (slice segs (+ fn-idx 1)))) + (list + :dyad (get fn-seg :node) + (segs-to-array left-segs) + (build-tree right-segs)))))))))) -(define split-statements-loop - (fn (tokens current-stmt acc depth) - (if (= (len tokens) 0) - (if (> (len current-stmt) 0) - (append acc (list current-stmt)) - acc) - (let ((tok (first tokens)) - (rest-toks (rest tokens)) - (tt (tok-type (first tokens)))) - (cond - ; Open brackets increase depth - ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket)) - (split-statements-loop rest-toks (append current-stmt tok) acc (+ depth 1))) - ; Close brackets decrease depth - ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket)) - (split-statements-loop rest-toks (append current-stmt tok) acc (- depth 1))) - ; Separators only split at top level (depth = 0) - ((and (> depth 0) (or (= tt :diamond) (= tt :newline))) - (split-statements-loop rest-toks (append current-stmt tok) acc depth)) - ((and (= depth 0) (or (= tt :diamond) (= tt :newline))) - (if (> (len current-stmt) 0) - (split-statements-loop rest-toks (list) (append acc (list current-stmt)) depth) - (split-statements-loop rest-toks (list) acc depth))) - ; All other tokens go into current statement - (true - (split-statements-loop rest-toks (append current-stmt tok) acc depth))))))) +(define + split-statements + (fn (tokens) (split-statements-loop tokens (list) (list) 0))) ; ============================================================ ; Parse a dfn body (tokens between { and }) ; Handles guard expressions: cond : expr ; ============================================================ -(define parse-dfn - (fn (tokens) - (let ((stmt-groups (split-statements tokens))) - (let ((stmts (map parse-dfn-stmt stmt-groups))) - (cons :dfn stmts))))) - -(define parse-dfn-stmt - (fn (tokens) - ; Check for guard: expr : expr - ; A guard has a :colon token not inside parens/braces - (let ((colon-idx (find-top-level-colon tokens 0))) - (if (>= colon-idx 0) - ; Guard: cond : expr - (let ((cond-tokens (slice tokens 0 colon-idx)) - (body-tokens (slice tokens (+ colon-idx 1)))) - (list :guard - (parse-apl-expr cond-tokens) - (parse-apl-expr body-tokens))) - ; Regular statement - (parse-stmt tokens))))) - -(define find-top-level-colon - (fn (tokens i) - (find-top-level-colon-loop tokens i 0))) - -(define find-top-level-colon-loop - (fn (tokens i depth) - (if (>= i (len tokens)) - -1 - (let ((tok (nth tokens i)) - (tt (tok-type (nth tokens i)))) +(define + split-statements-loop + (fn + (tokens current-stmt acc depth) + (if + (= (len tokens) 0) + (if (> (len current-stmt) 0) (append acc (list current-stmt)) acc) + (let + ((tok (first tokens)) + (rest-toks (rest tokens)) + (tt (tok-type (first tokens)))) (cond ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket)) - (find-top-level-colon-loop tokens (+ i 1) (+ depth 1))) + (split-statements-loop + rest-toks + (append current-stmt tok) + acc + (+ depth 1))) ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket)) - (find-top-level-colon-loop tokens (+ i 1) (- depth 1))) - ((and (= tt :colon) (= depth 0)) - i) + (split-statements-loop + rest-toks + (append current-stmt tok) + acc + (- depth 1))) + ((and (> depth 0) (or (= tt :diamond) (= tt :newline))) + (split-statements-loop + rest-toks + (append current-stmt tok) + acc + depth)) + ((and (= depth 0) (or (= tt :diamond) (= tt :newline))) + (if + (> (len current-stmt) 0) + (split-statements-loop + rest-toks + (list) + (append acc (list current-stmt)) + depth) + (split-statements-loop rest-toks (list) acc depth))) (true - (find-top-level-colon-loop tokens (+ i 1) depth))))))) + (split-statements-loop + rest-toks + (append current-stmt tok) + acc + depth))))))) + +(define + parse-dfn + (fn + (tokens) + (let + ((stmt-groups (split-statements tokens))) + (let ((stmts (map parse-dfn-stmt stmt-groups))) (cons :dfn stmts))))) + +(define + parse-dfn-stmt + (fn + (tokens) + (let + ((colon-idx (find-top-level-colon tokens 0))) + (if + (>= colon-idx 0) + (let + ((cond-tokens (slice tokens 0 colon-idx)) + (body-tokens (slice tokens (+ colon-idx 1)))) + (list + :guard (parse-apl-expr cond-tokens) + (parse-apl-expr body-tokens))) + (parse-stmt tokens))))) + +(define + find-top-level-colon + (fn (tokens i) (find-top-level-colon-loop tokens i 0))) ; ============================================================ ; Parse a single statement (assignment or expression) ; ============================================================ -(define parse-stmt - (fn (tokens) - (if (and (>= (len tokens) 2) - (= (tok-type (nth tokens 0)) :name) - (= (tok-type (nth tokens 1)) :assign)) - ; Assignment: name ← expr - (list :assign - (tok-val (nth tokens 0)) - (parse-apl-expr (slice tokens 2))) - ; Expression - (parse-apl-expr tokens)))) +(define + find-top-level-colon-loop + (fn + (tokens i depth) + (if + (>= i (len tokens)) + -1 + (let + ((tok (nth tokens i)) (tt (tok-type (nth tokens i)))) + (cond + ((or (= tt :lparen) (= tt :lbrace) (= tt :lbracket)) + (find-top-level-colon-loop tokens (+ i 1) (+ depth 1))) + ((or (= tt :rparen) (= tt :rbrace) (= tt :rbracket)) + (find-top-level-colon-loop tokens (+ i 1) (- depth 1))) + ((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-apl-expr - (fn (tokens) - (let ((segs (collect-segments tokens))) - (if (= (len segs) 0) - nil - (build-tree segs))))) +(define + parse-stmt + (fn + (tokens) + (if + (and + (>= (len tokens) 2) + (= (tok-type (nth tokens 0)) :name) + (= (tok-type (nth tokens 1)) :assign)) + (list + :assign (tok-val (nth tokens 0)) + (parse-apl-expr (slice tokens 2))) + (parse-apl-expr tokens)))) ; ============================================================ ; Main entry point ; parse-apl: string → AST ; ============================================================ -(define parse-apl - (fn (src) - (let ((tokens (apl-tokenize src))) - (let ((stmt-groups (split-statements tokens))) - (if (= (len stmt-groups) 0) +(define + parse-apl-expr + (fn + (tokens) + (let + ((segs (collect-segments tokens))) + (if (= (len segs) 0) nil (build-tree segs))))) + +(define + parse-apl + (fn + (src) + (let + ((tokens (apl-tokenize src))) + (let + ((stmt-groups (split-statements tokens))) + (if + (= (len stmt-groups) 0) nil - (if (= (len stmt-groups) 1) + (if + (= (len stmt-groups) 1) (parse-stmt (first stmt-groups)) (cons :program (map parse-stmt stmt-groups)))))))) diff --git a/lib/apl/tests/pipeline.sx b/lib/apl/tests/pipeline.sx index c3123981..7434744f 100644 --- a/lib/apl/tests/pipeline.sx +++ b/lib/apl/tests/pipeline.sx @@ -121,3 +121,25 @@ "apl-run \"×/⍳10\" → 10! = 3628800" (mkrv (apl-run "×/⍳10")) (list 3628800)) + +(apl-test "apl-run \"⎕IO\" → 1" (mkrv (apl-run "⎕IO")) (list 1)) + +(apl-test "apl-run \"⎕ML\" → 1" (mkrv (apl-run "⎕ML")) (list 1)) + +(apl-test "apl-run \"⎕FR\" → 1248" (mkrv (apl-run "⎕FR")) (list 1248)) + +(apl-test "apl-run \"⎕TS\" shape (7)" (mksh (apl-run "⎕TS")) (list 7)) + +(apl-test "apl-run \"⎕FMT 42\" → \"42\"" (apl-run "⎕FMT 42") "42") + +(apl-test + "apl-run \"⎕FMT 1 2 3\" → \"1 2 3\"" + (apl-run "⎕FMT 1 2 3") + "1 2 3") + +(apl-test + "apl-run \"⎕FMT ⍳5\" → \"1 2 3 4 5\"" + (apl-run "⎕FMT ⍳5") + "1 2 3 4 5") + +(apl-test "apl-run \"⎕IO + 4\" → 5" (mkrv (apl-run "⎕IO + 4")) (list 5)) diff --git a/lib/apl/transpile.sx b/lib/apl/transpile.sx index 76f1341b..83f336a2 100644 --- a/lib/apl/transpile.sx +++ b/lib/apl/transpile.sx @@ -39,6 +39,7 @@ ((= 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 @@ -110,6 +111,10 @@ (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 diff --git a/plans/apl-on-sx.md b/plans/apl-on-sx.md index a5718ea3..d9c2da80 100644 --- a/plans/apl-on-sx.md +++ b/plans/apl-on-sx.md @@ -119,9 +119,10 @@ and tightens loose ends. chains `apl-tokenize` → `parse-apl` → `apl-eval-ast` against an empty env. Verify with one-liners (`+/⍳5` → 15, `1 2 3 + 4 5 6` → 7 9 11, etc.) and with the actual `.apl` source files in `tests/programs/`. -- [ ] **`:quad-name` AST + handler** — extend tokenizer/parser to recognise +- [x] **`:quad-name` AST + handler** — extend tokenizer/parser to recognise `⎕name`, then handle in `apl-eval-ast` by dispatching to `apl-quad-*` runtime fns (`⎕IO`, `⎕ML`, `⎕FR`, `⎕TS`, `⎕FMT`, `⎕←`). + _(`⎕←` deferred — tokenizer treats `←` as `:assign` after `⎕`.)_ - [ ] **Bracket indexing verification** — load programs that use `A[I]` / `A[I;J]` end-to-end; confirm parser desugars to `⌷` and runtime returns expected slices. Add 5+ tests. @@ -147,6 +148,7 @@ data; format for string templating. _Newest first._ +- 2026-05-07: Phase 7 step 3 — :quad-name end-to-end; tokenizer already produced :name "⎕FMT"; parser is-fn-tok? extended via apl-quad-fn-names; eval-ast :name dispatches ⎕IO/⎕ML/⎕FR/⎕TS to apl-quad-*; apl-monadic-fn handles ⎕FMT; ⎕← deferred (tokenizer splits ⎕←); +8 tests; 408/408 - 2026-05-07: Phase 7 step 2 — end-to-end pipeline `apl-run : string → array` (parse-apl + apl-eval-ast against empty env); +25 source-string tests covering scalars, strands, dyadic arith, monadic primitives, operators, ∘./.g products, comparisons, famous one-liners (+/⍳10=55, ×/⍳10=10!); tokenizer can't yet parse decimals so `3.7` literal tests dropped; **400/400** - 2026-05-07: Phase 7 step 1 — operators in apl-eval-ast via apl-resolve-monadic/dyadic; supports / ⌿ \ ⍀ ¨ ⍨ ∘. f.g; queens(8) test removed (too slow for 300s timeout); +14 eval-ops tests; 375/375 - 2026-05-07: Phase 7 added — end-to-end pipeline, operators in eval-ast, :quad-name, bracket-indexing verify, idiom expansion, :Trap; aim is to wire parser↔runtime so .apl source files actually run