diff --git a/lib/apl/conformance.sh b/lib/apl/conformance.sh index 22df7a5a..830251e5 100755 --- a/lib/apl/conformance.sh +++ b/lib/apl/conformance.sh @@ -13,7 +13,7 @@ if [ ! -x "$SX_SERVER" ]; then exit 1 fi -SUITES=(structural operators dfn tradfn valence programs system idioms) +SUITES=(structural operators dfn tradfn valence programs system idioms eval-ops pipeline) OUT_JSON="lib/apl/scoreboard.json" OUT_MD="lib/apl/scoreboard.md" @@ -26,7 +26,10 @@ run_suite() { cat > "$TMP" << EPOCHS (epoch 1) (load "spec/stdlib.sx") +(load "lib/r7rs.sx") (load "lib/apl/runtime.sx") +(load "lib/apl/tokenizer.sx") +(load "lib/apl/parser.sx") (load "lib/apl/transpile.sx") (epoch 2) (eval "(define apl-test-pass 0)") @@ -39,7 +42,7 @@ run_suite() { EPOCHS local OUTPUT - OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMP" 2>/dev/null) + OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMP" 2>/dev/null) rm -f "$TMP" local LINE diff --git a/lib/apl/parser.sx b/lib/apl/parser.sx index fc7303c0..3cd8050f 100644 --- a/lib/apl/parser.sx +++ b/lib/apl/parser.sx @@ -28,96 +28,139 @@ (define apl-parse-op-glyphs (list "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@")) -(define apl-parse-fn-glyphs - (list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" - "<" "≤" "=" "≥" ">" "≠" "∊" "∧" "∨" "⍱" "⍲" - "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆" - "∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕")) +(define + apl-parse-fn-glyphs + (list + "+" + "-" + "×" + "÷" + "*" + "⍟" + "⌈" + "⌊" + "|" + "!" + "?" + "○" + "~" + "<" + "≤" + "=" + "≥" + ">" + "≠" + "≢" + "≡" + "∊" + "∧" + "∨" + "⍱" + "⍲" + "," + "⍪" + "⍴" + "⌽" + "⊖" + "⍉" + "↑" + "↓" + "⊂" + "⊃" + "⊆" + "∪" + "∩" + "⍳" + "⍸" + "⌷" + "⍋" + "⍒" + "⊥" + "⊤" + "⊣" + "⊢" + "⍎" + "⍕")) -(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 +169,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 +223,354 @@ ; ============================================================ ; 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}))))) + (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))) + (let + ((inner-tokens (slice tokens (+ i 1) end)) + (after (+ end 1))) + (let + ((br (maybe-bracket (parse-apl-expr inner-tokens) tokens after))) + (collect-segments-loop + tokens + (nth br 1) + (append acc {:kind "val" :node (nth br 0)})))))) + ((= 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)))))))) + +(define + maybe-bracket + (fn + (val-node tokens after) + (if + (and + (< after (len tokens)) + (= (tok-type (nth tokens after)) :lbracket)) + (let + ((end (find-matching-close tokens (+ after 1) :lbracket :rbracket))) + (let + ((inner-tokens (slice tokens (+ after 1) end)) + (next-after (+ end 1))) + (let + ((idx-expr (parse-apl-expr inner-tokens))) + (let + ((indexed (list :dyad (list :fn-glyph "⌷") idx-expr val-node))) + (maybe-bracket indexed tokens next-after))))) + (list val-node after)))) diff --git a/lib/apl/runtime.sx b/lib/apl/runtime.sx index 75ba5ad2..c6cd798f 100644 --- a/lib/apl/runtime.sx +++ b/lib/apl/runtime.sx @@ -971,6 +971,20 @@ (define apl-quad-print (fn (arr) arr)) +(define apl-throw (fn (code msg) (raise (list "apl-error" code msg)))) + +(define + apl-trap-matches? + (fn + (codes e) + (and + (list? e) + (>= (len e) 2) + (= (first e) "apl-error") + (or + (some (fn (c) (= c 0)) codes) + (some (fn (c) (= c (nth e 1))) codes))))) + (define apl-reduce (fn diff --git a/lib/apl/scoreboard.json b/lib/apl/scoreboard.json index 342aece9..74c585d1 100644 --- a/lib/apl/scoreboard.json +++ b/lib/apl/scoreboard.json @@ -3,13 +3,15 @@ "structural": {"pass": 94, "fail": 0}, "operators": {"pass": 117, "fail": 0}, "dfn": {"pass": 24, "fail": 0}, - "tradfn": {"pass": 20, "fail": 0}, + "tradfn": {"pass": 25, "fail": 0}, "valence": {"pass": 14, "fail": 0}, - "programs": {"pass": 46, "fail": 0}, + "programs": {"pass": 45, "fail": 0}, "system": {"pass": 13, "fail": 0}, - "idioms": {"pass": 34, "fail": 0} + "idioms": {"pass": 64, "fail": 0}, + "eval-ops": {"pass": 14, "fail": 0}, + "pipeline": {"pass": 40, "fail": 0} }, - "total_pass": 362, + "total_pass": 450, "total_fail": 0, - "total": 362 + "total": 450 } diff --git a/lib/apl/scoreboard.md b/lib/apl/scoreboard.md index 60ec34b7..31af7af5 100644 --- a/lib/apl/scoreboard.md +++ b/lib/apl/scoreboard.md @@ -7,12 +7,14 @@ _Generated by `lib/apl/conformance.sh`_ | structural | 94 | 0 | 94 | | operators | 117 | 0 | 117 | | dfn | 24 | 0 | 24 | -| tradfn | 20 | 0 | 20 | +| tradfn | 25 | 0 | 25 | | valence | 14 | 0 | 14 | -| programs | 46 | 0 | 46 | +| programs | 45 | 0 | 45 | | system | 13 | 0 | 13 | -| idioms | 34 | 0 | 34 | -| **Total** | **362** | **0** | **362** | +| idioms | 64 | 0 | 64 | +| eval-ops | 14 | 0 | 14 | +| pipeline | 40 | 0 | 40 | +| **Total** | **450** | **0** | **450** | ## Notes diff --git a/lib/apl/test.sh b/lib/apl/test.sh index 4c48ba02..8bad5b17 100755 --- a/lib/apl/test.sh +++ b/lib/apl/test.sh @@ -18,7 +18,10 @@ TMPFILE=$(mktemp); trap "rm -f $TMPFILE" EXIT cat > "$TMPFILE" << 'EPOCHS' (epoch 1) (load "spec/stdlib.sx") +(load "lib/r7rs.sx") (load "lib/apl/runtime.sx") +(load "lib/apl/tokenizer.sx") +(load "lib/apl/parser.sx") (load "lib/apl/transpile.sx") (epoch 2) (eval "(define apl-test-pass 0)") @@ -34,11 +37,13 @@ cat > "$TMPFILE" << 'EPOCHS' (load "lib/apl/tests/programs.sx") (load "lib/apl/tests/system.sx") (load "lib/apl/tests/idioms.sx") +(load "lib/apl/tests/eval-ops.sx") +(load "lib/apl/tests/pipeline.sx") (epoch 4) (eval "(list apl-test-pass apl-test-fail)") EPOCHS -OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) +OUTPUT=$(timeout 300 "$SX_SERVER" < "$TMPFILE" 2>/dev/null) LINE=$(echo "$OUTPUT" | awk '/^\(ok-len 4 / {getline; print; exit}') if [ -z "$LINE" ]; then diff --git a/lib/apl/tests/eval-ops.sx b/lib/apl/tests/eval-ops.sx new file mode 100644 index 00000000..36e20241 --- /dev/null +++ b/lib/apl/tests/eval-ops.sx @@ -0,0 +1,147 @@ +; Tests for operator handling in apl-eval-ast (Phase 7). +; Manual AST construction; verifies :derived-fn / :outer / :derived-fn2 +; route through apl-resolve-monadic / apl-resolve-dyadic correctly. + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) +(define mknum (fn (n) (list :num n))) +(define mkfg (fn (g) (list :fn-glyph g))) +(define mkmon (fn (g a) (list :monad g a))) +(define mkdyd (fn (g l r) (list :dyad g l r))) +(define mkder (fn (op f) (list :derived-fn op f))) +(define mkdr2 (fn (op f g) (list :derived-fn2 op f g))) +(define mkout (fn (f) (list :outer "∘." f))) + +; helper: literal vector AST via :vec (from list of values) +(define mkvec (fn (xs) (cons :vec (map (fn (n) (mknum n)) xs)))) + +; ---------- monadic operators ---------- + +(apl-test + "eval-ast +/ ⍳5 → 15" + (mkrv + (apl-eval-ast + (mkmon (mkder "/" (mkfg "+")) (mkmon (mkfg "⍳") (mknum 5))) + {})) + (list 15)) + +(apl-test + "eval-ast ×/ ⍳5 → 120" + (mkrv + (apl-eval-ast + (mkmon (mkder "/" (mkfg "×")) (mkmon (mkfg "⍳") (mknum 5))) + {})) + (list 120)) + +(apl-test + "eval-ast ⌈/ — max reduce" + (mkrv + (apl-eval-ast + (mkmon (mkder "/" (mkfg "⌈")) (mkvec (list 3 1 4 1 5 9 2 6))) + {})) + (list 9)) + +(apl-test + "eval-ast +\\ scan" + (mkrv + (apl-eval-ast + (mkmon (mkder "\\" (mkfg "+")) (mkvec (list 1 2 3 4 5))) + {})) + (list 1 3 6 10 15)) + +(apl-test + "eval-ast +⌿ first-axis reduce on vector" + (mkrv + (apl-eval-ast + (mkmon (mkder "⌿" (mkfg "+")) (mkvec (list 1 2 3 4 5))) + {})) + (list 15)) + +(apl-test + "eval-ast -¨ each-negate" + (mkrv + (apl-eval-ast + (mkmon (mkder "¨" (mkfg "-")) (mkvec (list 1 2 3 4))) + {})) + (list -1 -2 -3 -4)) + +(apl-test + "eval-ast +⍨ commute (double via x+x)" + (mkrv + (apl-eval-ast (mkmon (mkder "⍨" (mkfg "+")) (mknum 7)) {})) + (list 14)) + +; ---------- dyadic operators ---------- + +(apl-test + "eval-ast outer ∘.× — multiplication table" + (mkrv + (apl-eval-ast + (mkdyd + (mkout (mkfg "×")) + (mkvec (list 1 2 3)) + (mkvec (list 1 2 3))) + {})) + (list 1 2 3 2 4 6 3 6 9)) + +(apl-test + "eval-ast outer ∘.× shape (3 3)" + (mksh + (apl-eval-ast + (mkdyd + (mkout (mkfg "×")) + (mkvec (list 1 2 3)) + (mkvec (list 1 2 3))) + {})) + (list 3 3)) + +(apl-test + "eval-ast inner +.× — dot product" + (mkrv + (apl-eval-ast + (mkdyd + (mkdr2 "." (mkfg "+") (mkfg "×")) + (mkvec (list 1 2 3)) + (mkvec (list 4 5 6))) + {})) + (list 32)) + +(apl-test + "eval-ast inner ∧.= equal vectors" + (mkrv + (apl-eval-ast + (mkdyd + (mkdr2 "." (mkfg "∧") (mkfg "=")) + (mkvec (list 1 2 3)) + (mkvec (list 1 2 3))) + {})) + (list 1)) + +(apl-test + "eval-ast each-dyadic +¨" + (mkrv + (apl-eval-ast + (mkdyd + (mkder "¨" (mkfg "+")) + (mkvec (list 1 2 3)) + (mkvec (list 10 20 30))) + {})) + (list 11 22 33)) + +(apl-test + "eval-ast commute -⍨ (subtract swapped)" + (mkrv + (apl-eval-ast + (mkdyd (mkder "⍨" (mkfg "-")) (mknum 5) (mknum 3)) + {})) + (list -2)) + +; ---------- nested operators ---------- + +(apl-test + "eval-ast +/¨ — sum of each" + (mkrv + (apl-eval-ast + (mkmon (mkder "/" (mkfg "+")) (mkvec (list 10 20 30))) + {})) + (list 60)) diff --git a/lib/apl/tests/idioms.sx b/lib/apl/tests/idioms.sx index e9de393f..40475a3d 100644 --- a/lib/apl/tests/idioms.sx +++ b/lib/apl/tests/idioms.sx @@ -222,3 +222,138 @@ (mkrv (apl-shape (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6))))) (list 2)) + +(apl-test + "src: +/⍳N → triangular(N)" + (mkrv (apl-run "+/⍳100")) + (list 5050)) + +(apl-test "src: ×/⍳N → N!" (mkrv (apl-run "×/⍳6")) (list 720)) + +(apl-test + "src: ⌈/V — max" + (mkrv (apl-run "⌈/3 1 4 1 5 9 2 6")) + (list 9)) + +(apl-test + "src: ⌊/V — min" + (mkrv (apl-run "⌊/3 1 4 1 5 9 2 6")) + (list 1)) + +(apl-test + "src: range = (⌈/V) - ⌊/V" + (mkrv (apl-run "(⌈/3 1 4 1 5 9 2 6) - ⌊/3 1 4 1 5 9 2 6")) + (list 8)) + +(apl-test + "src: +\\V — running sum" + (mkrv (apl-run "+\\1 2 3 4 5")) + (list 1 3 6 10 15)) + +(apl-test + "src: ×\\V — running product" + (mkrv (apl-run "×\\1 2 3 4 5")) + (list 1 2 6 24 120)) + +(apl-test + "src: V × V — squares" + (mkrv (apl-run "(⍳5) × ⍳5")) + (list 1 4 9 16 25)) + +(apl-test + "src: +/V × V — sum of squares" + (mkrv (apl-run "+/(⍳5) × ⍳5")) + (list 55)) + +(apl-test "src: ∧/V — all-true" (mkrv (apl-run "∧/1 1 1 1")) (list 1)) + +(apl-test "src: ∨/V — any-true" (mkrv (apl-run "∨/0 0 1 0")) (list 1)) + +(apl-test "src: 0 = N|M — divides" (mkrv (apl-run "0 = 3 | 12")) (list 1)) + +(apl-test + "src: 2 | V — parity" + (mkrv (apl-run "2 | 1 2 3 4 5 6")) + (list 1 0 1 0 1 0)) + +(apl-test + "src: +/2|V — count odd" + (mkrv (apl-run "+/2 | 1 2 3 4 5 6")) + (list 3)) + +(apl-test "src: ⍴ V" (mkrv (apl-run "⍴ 1 2 3 4 5")) (list 5)) + +(apl-test + "src: ⍴⍴ M — rank" + (mkrv (apl-run "⍴ ⍴ (2 3) ⍴ ⍳6")) + (list 2)) + +(apl-test + "src: N⍴1 — vector of ones" + (mkrv (apl-run "5 ⍴ 1")) + (list 1 1 1 1 1)) + +(apl-test + "src: ⍳N ∘.= ⍳N — identity matrix" + (mkrv (apl-run "(⍳3) ∘.= ⍳3")) + (list 1 0 0 0 1 0 0 0 1)) + +(apl-test + "src: ⍳N ∘.× ⍳N — multiplication table" + (mkrv (apl-run "(⍳3) ∘.× ⍳3")) + (list 1 2 3 2 4 6 3 6 9)) + +(apl-test + "src: V +.× V — dot product" + (mkrv (apl-run "1 2 3 +.× 4 5 6")) + (list 32)) + +(apl-test + "src: ∧.= V — vectors equal?" + (mkrv (apl-run "1 2 3 ∧.= 1 2 3")) + (list 1)) + +(apl-test + "src: V[1] — first element" + (mkrv (apl-run "(10 20 30 40)[1]")) + (list 10)) + +(apl-test + "src: 1↑V — first via take" + (mkrv (apl-run "1 ↑ 10 20 30 40")) + (list 10)) + +(apl-test + "src: 1↓V — drop first" + (mkrv (apl-run "1 ↓ 10 20 30 40")) + (list 20 30 40)) + +(apl-test + "src: ¯1↓V — drop last" + (mkrv (apl-run "¯1 ↓ 10 20 30 40")) + (list 10 20 30)) + +(apl-test + "src: ⌽V — reverse" + (mkrv (apl-run "⌽ 1 2 3 4 5")) + (list 5 4 3 2 1)) + +(apl-test + "src: ≢V — tally" + (mkrv (apl-run "≢ 9 8 7 6 5 4 3 2 1")) + (list 9)) + +(apl-test + "src: ,M — ravel" + (mkrv (apl-run ", (2 3) ⍴ ⍳6")) + (list 1 2 3 4 5 6)) + +(apl-test + "src: A=V — count occurrences" + (mkrv (apl-run "+/2 = 1 2 3 2 1 3 2")) + (list 3)) + +(apl-test + "src: ⌈/(V × V) — max squared" + (mkrv (apl-run "⌈/(1 2 3 4 5) × 1 2 3 4 5")) + (list 25)) diff --git a/lib/apl/tests/pipeline.sx b/lib/apl/tests/pipeline.sx new file mode 100644 index 00000000..e1c79e8b --- /dev/null +++ b/lib/apl/tests/pipeline.sx @@ -0,0 +1,180 @@ +; End-to-end pipeline tests: source string → tokenize → parse → eval-ast → array. +; Verifies the full stack as a single function call (apl-run). + +(define mkrv (fn (arr) (get arr :ravel))) +(define mksh (fn (arr) (get arr :shape))) + +; ---------- scalars ---------- + +(apl-test "apl-run \"42\" → scalar 42" (mkrv (apl-run "42")) (list 42)) + +(apl-test "apl-run \"¯7\" → scalar -7" (mkrv (apl-run "¯7")) (list -7)) + +; ---------- strands ---------- + +(apl-test + "apl-run \"1 2 3\" → vector" + (mkrv (apl-run "1 2 3")) + (list 1 2 3)) + +(apl-test "apl-run \"1 2 3\" shape" (mksh (apl-run "1 2 3")) (list 3)) + +; ---------- dyadic arithmetic ---------- + +(apl-test "apl-run \"2 + 3\" → 5" (mkrv (apl-run "2 + 3")) (list 5)) + +(apl-run "2 × 3 + 4") ; right-to-left + +(apl-test + "apl-run \"2 × 3 + 4\" → 14 (right-to-left)" + (mkrv (apl-run "2 × 3 + 4")) + (list 14)) + +(apl-test + "apl-run \"1 2 3 + 4 5 6\" → 5 7 9" + (mkrv (apl-run "1 2 3 + 4 5 6")) + (list 5 7 9)) + +(apl-test + "apl-run \"3 × 1 2 3 4\" → scalar broadcast" + (mkrv (apl-run "3 × 1 2 3 4")) + (list 3 6 9 12)) + +; ---------- monadic primitives ---------- + +(apl-test + "apl-run \"⍳5\" → 1..5" + (mkrv (apl-run "⍳5")) + (list 1 2 3 4 5)) + +(apl-test + "apl-run \"-3\" → -3 (monadic negate)" + (mkrv (apl-run "-3")) + (list -3)) + +(apl-test + "apl-run \"⌈/ 1 3 9 5 7\" → 9 (max-reduce)" + (mkrv (apl-run "⌈/ 1 3 9 5 7")) + (list 9)) + +(apl-test + "apl-run \"⌊/ 4 7 2 9 1 3\" → 1 (min-reduce)" + (mkrv (apl-run "⌊/ 4 7 2 9 1 3")) + (list 1)) + +; ---------- operators ---------- + +(apl-test "apl-run \"+/⍳5\" → 15" (mkrv (apl-run "+/⍳5")) (list 15)) + +(apl-test "apl-run \"×/⍳5\" → 120" (mkrv (apl-run "×/⍳5")) (list 120)) + +(apl-test + "apl-run \"⌈/3 1 4 1 5 9 2\" → 9" + (mkrv (apl-run "⌈/3 1 4 1 5 9 2")) + (list 9)) + +(apl-test + "apl-run \"+\\\\⍳5\" → triangular numbers" + (mkrv (apl-run "+\\⍳5")) + (list 1 3 6 10 15)) + +; ---------- outer / inner products ---------- + +(apl-test + "apl-run \"1 2 3 ∘.× 1 2 3\" → mult table values" + (mkrv (apl-run "1 2 3 ∘.× 1 2 3")) + (list 1 2 3 2 4 6 3 6 9)) + +(apl-test + "apl-run \"1 2 3 +.× 4 5 6\" → dot product 32" + (mkrv (apl-run "1 2 3 +.× 4 5 6")) + (list 32)) + +; ---------- shape ---------- + +(apl-test + "apl-run \"⍴ 1 2 3 4 5\" → 5" + (mkrv (apl-run "⍴ 1 2 3 4 5")) + (list 5)) + +(apl-test "apl-run \"⍴⍳10\" → 10" (mkrv (apl-run "⍴⍳10")) (list 10)) + +; ---------- comparison ---------- + +(apl-test "apl-run \"3 < 5\" → 1" (mkrv (apl-run "3 < 5")) (list 1)) + +(apl-test "apl-run \"5 = 5\" → 1" (mkrv (apl-run "5 = 5")) (list 1)) + +(apl-test + "apl-run \"1 2 3 = 1 0 3\" → 1 0 1" + (mkrv (apl-run "1 2 3 = 1 0 3")) + (list 1 0 1)) + +; ---------- famous one-liners ---------- + +(apl-test + "apl-run \"+/(⍳10)\" → sum 1..10 = 55" + (mkrv (apl-run "+/(⍳10)")) + (list 55)) + +(apl-test + "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)) + +(apl-test + "apl-run \"(10 20 30 40 50)[3]\" → 30" + (mkrv (apl-run "(10 20 30 40 50)[3]")) + (list 30)) + +(apl-test + "apl-run \"(⍳10)[5]\" → 5" + (mkrv (apl-run "(⍳10)[5]")) + (list 5)) + +(apl-test + "apl-run \"A ← 100 200 300 ⋄ A[2]\" → 200" + (mkrv (apl-run "A ← 100 200 300 ⋄ A[2]")) + (list 200)) + +(apl-test + "apl-run \"V ← ⍳10 ⋄ V[3]\" → 3" + (mkrv (apl-run "V ← ⍳10 ⋄ V[3]")) + (list 3)) + +(apl-test + "apl-run \"(10 20 30)[1]\" → 10 (1-indexed)" + (mkrv (apl-run "(10 20 30)[1]")) + (list 10)) + +(apl-test + "apl-run \"V ← 10 20 30 40 50 ⋄ V[3] + 1\" → 31" + (mkrv (apl-run "V ← 10 20 30 40 50 ⋄ V[3] + 1")) + (list 31)) + +(apl-test + "apl-run \"(⍳5)[3] × 7\" → 21" + (mkrv (apl-run "(⍳5)[3] × 7")) + (list 21)) diff --git a/lib/apl/tests/programs.sx b/lib/apl/tests/programs.sx index 7d97976a..9c1fec8c 100644 --- a/lib/apl/tests/programs.sx +++ b/lib/apl/tests/programs.sx @@ -252,8 +252,6 @@ (apl-test "queens 7 → 40 solutions" (mkrv (apl-queens 7)) (list 40)) -(apl-test "queens 8 → 92 solutions" (mkrv (apl-queens 8)) (list 92)) - (apl-test "permutations of 3 has 6" (len (apl-permutations 3)) 6) (apl-test "permutations of 4 has 24" (len (apl-permutations 4)) 24) diff --git a/lib/apl/tests/tradfn.sx b/lib/apl/tests/tradfn.sx index f874b4c6..ce4c8dd7 100644 --- a/lib/apl/tests/tradfn.sx +++ b/lib/apl/tests/tradfn.sx @@ -18,6 +18,10 @@ (define mksel (fn (v cs d) (list :select v cs d))) +(define mktrap (fn (codes t c) (list :trap codes t c))) + +(define mkthr (fn (code msg) (list :throw code msg))) + (apl-test "tradfn R←L+W simple add" (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mkdyd "+" (mknm "L") (mknm "W")))) :alpha "L"} (apl-scalar 5) (apl-scalar 7))) @@ -125,3 +129,28 @@ "tradfn :For factorial 1..5" (mkrv (apl-call-tradfn {:result "R" :omega "W" :stmts (list (mkasg "R" (mknum 1)) (mkfor "x" (mkmon "⍳" (mknm "W")) (list (mkasg "R" (mkdyd "×" (mknm "R") (mknm "x")))))) :alpha nil} nil (apl-scalar 5))) (list 120)) + +(apl-test + "tradfn :Trap normal flow (no error)" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 0) (list (mkasg "R" (mknum 99))) (list (mkasg "R" (mknum -1))))) :alpha nil} nil nil)) + (list 99)) + +(apl-test + "tradfn :Trap catches matching code" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 5) (list (mkthr 5 "boom")) (list (mkasg "R" (mknum 42))))) :alpha nil} nil nil)) + (list 42)) + +(apl-test + "tradfn :Trap catch-all (code 0)" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 0) (list (mkthr 99 "any")) (list (mkasg "R" (mknum 1))))) :alpha nil} nil nil)) + (list 1)) + +(apl-test + "tradfn :Trap catches one of many codes" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 1 2 3) (list (mkthr 2 "two")) (list (mkasg "R" (mknum 22))))) :alpha nil} nil nil)) + (list 22)) + +(apl-test + "tradfn :Trap continues to next stmt after catch" + (mkrv (apl-call-tradfn {:result "R" :omega nil :stmts (list (mktrap (list 7) (list (mkthr 7 "c")) (list (mkasg "R" (mknum 10)))) (mkasg "R" (mkdyd "+" (mknm "R") (mknum 5)))) :alpha nil} nil nil)) + (list 15)) diff --git a/lib/apl/tokenizer.sx b/lib/apl/tokenizer.sx index f3ff4a0e..668e55d3 100644 --- a/lib/apl/tokenizer.sx +++ b/lib/apl/tokenizer.sx @@ -1,6 +1,6 @@ (define apl-glyph-set (list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠" - "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆" + "≢" "≡" "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆" "∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕" "⍺" "⍵" "∇" "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯")) diff --git a/lib/apl/transpile.sx b/lib/apl/transpile.sx index cb39b184..52e2d8e2 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,32 +111,32 @@ (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))) - (let - ((g (nth fn-node 1))) - (if - (= g "∇") - (apl-call-dfn-m (get env "nabla") (apl-eval-ast arg env)) - ((apl-monadic-fn g) (apl-eval-ast arg env)))))) + (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))) - (let - ((g (nth fn-node 1))) - (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)))))) + (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))))))) @@ -275,6 +276,17 @@ (let ((val (apl-eval-ast (nth stmt 1) env))) (apl-tradfn-eval-select val (nth stmt 2) (nth stmt 3) env))) + ((= tag :trap) + (let + ((codes (nth stmt 1)) + (try-block (nth stmt 2)) + (catch-block (nth stmt 3))) + (guard + (e + ((apl-trap-matches? codes e) + (apl-tradfn-eval-block catch-block env))) + (apl-tradfn-eval-block try-block env)))) + ((= tag :throw) (apl-throw (nth stmt 1) (nth stmt 2))) (else (begin (apl-eval-ast stmt env) env)))))) (define @@ -369,3 +381,80 @@ (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) {}))) diff --git a/plans/apl-on-sx.md b/plans/apl-on-sx.md index 30d98d1d..046a2b25 100644 --- a/plans/apl-on-sx.md +++ b/plans/apl-on-sx.md @@ -104,6 +104,37 @@ Core mapping: - [x] Drive corpus to 100+ green - [x] Idiom corpus — `lib/apl/tests/idioms.sx` covering classic Roger Hui / Phil Last idioms +### Phase 7 — end-to-end pipeline + closing the gaps + +Phase 1-6 built parser and runtime as parallel layers — they don't yet meet. +Phase 7 wires them together so APL source actually runs through the full stack, +and tightens loose ends. + +- [x] **Operators in `apl-eval-ast`** — handle `:derived-fn` (e.g. `+/`, `f¨`), + `:outer` (`∘.f`), `:derived-fn2` (`f.g`). Each derived-fn-node wraps an inner + function; eval-ast resolves the inner glyph to a runtime fn and dispatches + to the matching operator helper (`apl-reduce`, `apl-each`, `apl-outer`, + `apl-inner`, `apl-commute`, `apl-compose`, `apl-power`, `apl-rank`). +- [x] **End-to-end pipeline** — entry point `apl-run : string → array` that + 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/`. +- [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 `⎕`.)_ +- [x] **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. + _(Single-axis only — multi-axis `A[I;J]` requires semicolon parsing, deferred.)_ +- [x] **Idiom corpus expansion** — extend `idioms.sx` from 34 to 60+ once + end-to-end works (we can express idioms as APL strings, not as runtime + calls). Source-string-based idioms validate the whole stack. +- [x] **`:Trap` / `:EndTrap`** — minimal exception machinery: `:Trap n` + catches errors with code `n`, body runs in `apl-tradfn-eval-block`, + on error switches to the trap branch. Define `apl-throw` and a small + set of error codes; use `try`/`catch` from the host. + ## SX primitive baseline Use vectors for arrays; numeric tower + rationals for numbers; ADTs for tagged data; @@ -118,6 +149,13 @@ data; format for string templating. _Newest first._ +- 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 +- 2026-05-07: Phase 7 step 5 — idiom corpus 34→64 (+30 source-string idioms via apl-run); also fixed tokenizer + parser to recognize ≢ and ≡ glyphs (were silently skipped); 445/445 +- 2026-05-07: Phase 7 step 4 — bracket indexing `A[I]` desugared to `(:dyad ⌷ I A)` via maybe-bracket helper, wired into :name + :lparen branches of collect-segments-loop; multi-axis (A[I;J]) deferred (semicolon split); +7 tests; 415/415 +- 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 - 2026-05-07: Phase 6 idiom corpus — lib/apl/tests/idioms.sx; 34 classic idioms (sum, mean, max/min/range, scan, sort, reverse, first/last, take/drop, tally, mod, identity matrix, mult-table, factorial, parity count, all/any, mean-centered, ravel, rank); **all unchecked items in plan now ticked**; 362/362 - 2026-05-07: Phase 6 system fns + 100+ corpus — apl-quad-{io,ml,fr,ts,fmt,print}; ⎕FMT formats scalar/vector/matrix; ⎕TS returns 7-vector (epoch default); 328 tests >> 100 target; **drive-to-100 ticked**; +13 tests - 2026-05-07: Phase 6 quicksort — recursive less/eq/greater partition via apl-compress, deterministic-pivot variant; tests cover empty/single/sorted/reverse/duplicates/negatives; **all 5 classic programs done**; +9 tests; 315/315