tcl: Phase 2 core commands — if/while/for/foreach/switch/break/continue/return/error/expr (+20 tests, 107 total)

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>

lib/apl/parser.sx

@@ -1,436 +0,0 @@
-; APL Parser — right-to-left expression parser
-;
-; Takes a token list (output of apl-tokenize) and produces an AST.
-; APL evaluates right-to-left with no precedence among functions.
-; Operators bind to the function immediately to their left in the source.
-;
-; AST node types:
-;   (:num n)                     number literal
-;   (:str s)                     string literal
-;   (:vec n1 n2 ...)             strand (juxtaposed literals)
-;   (:name "x")                  name reference / alpha / omega
-;   (:assign "x" expr)           assignment  x←expr
-;   (:monad fn arg)              monadic function call
-;   (:dyad fn left right)        dyadic function call
-;   (:derived-fn op fn)          derived function: f/ f¨ f⍨
-;   (:derived-fn2 "." f g)       inner product: f.g
-;   (:outer "∘." fn)             outer product: ∘.f
-;   (:fn-glyph "⍳")             function reference
-;   (:fn-name "foo")             named-function reference (dfn variable)
-;   (:dfn stmt...)               {⍺+⍵} anonymous function
-;   (:guard cond expr)           cond:expr guard inside dfn
-;   (:program stmt...)           multi-statement sequence
-
-; ============================================================
-; Glyph classification sets
-; ============================================================
-
-(define apl-parse-op-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-parse-fn-glyph?
-  (fn (v)
-    (some (fn (g) (= g v)) apl-parse-fn-glyphs)))
-
-; ============================================================
-; Token accessors
-; ============================================================
-
-(define tok-type
-  (fn (tok)
-    (get tok :type)))
-
-(define tok-val
-  (fn (tok)
-    (get tok :value)))
-
-(define is-op-tok?
-  (fn (tok)
-    (and (= (tok-type tok) :glyph)
-         (apl-parse-op-glyph? (tok-val tok)))))
-
-(define is-fn-tok?
-  (fn (tok)
-    (and (= (tok-type tok) :glyph)
-         (apl-parse-fn-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 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})))))
-
-; ============================================================
-; 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)))))
-
-; ============================================================
-; 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 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)))))))
-
-; ============================================================
-; 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 collect-segments
-  (fn (tokens)
-    (collect-segments-loop tokens 0 (list))))
-
-(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))))))))
-
-; ============================================================
-; 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-first-fn
-  (fn (segs)
-    (find-first-fn-loop segs 0)))
-
-(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))))))
-
-; 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)
-      (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 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)))))))
-
-; ============================================================
-; 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))))
-        (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 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))))
-
-; ============================================================
-; 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)))))
-
-; ============================================================
-; 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)
-          nil
-          (if (= (len stmt-groups) 1)
-            (parse-stmt (first stmt-groups))
-            (cons :program (map parse-stmt stmt-groups))))))))

lib/apl/runtime.sx

@@ -1,349 +0,0 @@
-; APL Runtime — array model + scalar primitives
-;
-; Array = SX dict {:shape (d1 d2 ...) :ravel (v1 v2 ...)}
-; Scalar: rank 0, shape (), one element in ravel
-; Vector: rank 1, shape (n), n elements in ravel
-; Matrix: rank 2, shape (r c), r*c elements in ravel
-
-; ============================================================
-; Array constructors
-; ============================================================
-
-(define make-array (fn (shape ravel) {:ravel ravel :shape shape}))
-
-(define apl-scalar (fn (v) {:ravel (list v) :shape (list)}))
-
-(define apl-vector (fn (elems) {:ravel elems :shape (list (len elems))}))
-
-; enclose — wrap any value in a rank-0 box
-(define enclose (fn (v) (apl-scalar v)))
-
-; disclose — unwrap rank-0 box, returning the first element
-(define disclose (fn (arr) (first (get arr :ravel))))
-
-; ============================================================
-; Array accessors
-; ============================================================
-
-(define array-rank (fn (arr) (len (get arr :shape))))
-
-(define scalar? (fn (arr) (= (len (get arr :shape)) 0)))
-
-(define array-ref (fn (arr i) (nth (get arr :ravel) i)))
-
-; ============================================================
-; System variables
-; ============================================================
-
-(define apl-io 1)
-
-; ============================================================
-; Broadcast engine
-; ============================================================
-
-(define
-  broadcast-monadic
-  (fn (f arr) (make-array (get arr :shape) (map f (get arr :ravel)))))
-
-(define
-  broadcast-dyadic
-  (fn
-    (f a b)
-    (cond
-      ((and (scalar? a) (scalar? b))
-        (apl-scalar (f (first (get a :ravel)) (first (get b :ravel)))))
-      ((scalar? a)
-        (let
-          ((sv (first (get a :ravel))))
-          (make-array
-            (get b :shape)
-            (map (fn (x) (f sv x)) (get b :ravel)))))
-      ((scalar? b)
-        (let
-          ((sv (first (get b :ravel))))
-          (make-array
-            (get a :shape)
-            (map (fn (x) (f x sv)) (get a :ravel)))))
-      (else
-        (if
-          (equal? (get a :shape) (get b :shape))
-          (make-array (get a :shape) (map f (get a :ravel) (get b :ravel)))
-          (error "length error: shape mismatch"))))))
-
-; ============================================================
-; Arithmetic primitives
-; ============================================================
-
-; Monadic + : identity
-(define apl-plus-m (fn (a) (broadcast-monadic (fn (x) x) a)))
-
-; Dyadic +
-(define apl-add (fn (a b) (broadcast-dyadic (fn (x y) (+ x y)) a b)))
-
-; Monadic - : negate
-(define apl-neg-m (fn (a) (broadcast-monadic (fn (x) (- 0 x)) a)))
-
-; Dyadic -
-(define apl-sub (fn (a b) (broadcast-dyadic (fn (x y) (- x y)) a b)))
-
-; Monadic × : signum
-(define
-  apl-signum
-  (fn
-    (a)
-    (broadcast-monadic
-      (fn (x) (cond ((> x 0) 1) ((< x 0) -1) (else 0)))
-      a)))
-
-; Dyadic ×
-(define apl-mul (fn (a b) (broadcast-dyadic (fn (x y) (* x y)) a b)))
-
-; Monadic ÷ : reciprocal
-(define apl-recip (fn (a) (broadcast-monadic (fn (x) (/ 1 x)) a)))
-
-; Dyadic ÷
-(define apl-div (fn (a b) (broadcast-dyadic (fn (x y) (/ x y)) a b)))
-
-; Monadic ⌈ : ceiling
-(define apl-ceil (fn (a) (broadcast-monadic (fn (x) (ceil x)) a)))
-
-; Dyadic ⌈ : max
-(define
-  apl-max
-  (fn (a b) (broadcast-dyadic (fn (x y) (if (>= x y) x y)) a b)))
-
-; Monadic ⌊ : floor
-(define apl-floor (fn (a) (broadcast-monadic (fn (x) (floor x)) a)))
-
-; Dyadic ⌊ : min
-(define
-  apl-min
-  (fn (a b) (broadcast-dyadic (fn (x y) (if (<= x y) x y)) a b)))
-
-; Monadic * : e^x
-(define apl-exp (fn (a) (broadcast-monadic (fn (x) (exp x)) a)))
-
-; Dyadic * : power
-(define apl-pow (fn (a b) (broadcast-dyadic (fn (x y) (pow x y)) a b)))
-
-; Monadic ⍟ : natural log
-(define apl-ln (fn (a) (broadcast-monadic (fn (x) (log x)) a)))
-
-; Dyadic ⍟ : log base (a⍟b = log base a of b)
-(define
-  apl-log
-  (fn (a b) (broadcast-dyadic (fn (x y) (/ (log y) (log x))) a b)))
-
-; Monadic | : absolute value
-(define
-  apl-abs
-  (fn (a) (broadcast-monadic (fn (x) (if (< x 0) (- 0 x) x)) a)))
-
-; Dyadic | : modulo (a|b = b mod a)
-(define
-  apl-mod
-  (fn
-    (a b)
-    (broadcast-dyadic
-      (fn (x y) (if (= x 0) y (- y (* x (floor (/ y x))))))
-      a
-      b)))
-
-; Monadic ! : factorial
-(define
-  apl-fact
-  (fn
-    (a)
-    (broadcast-monadic
-      (fn
-        (n)
-        (let
-          ((loop nil))
-          (begin
-            (set!
-              loop
-              (fn (i acc) (if (> i n) acc (loop (+ i 1) (* acc i)))))
-            (loop 1 1))))
-      a)))
-
-; Dyadic ! : binomial coefficient n!k  (a=n, b=k => a choose b)
-(define
-  apl-binomial
-  (fn
-    (a b)
-    (broadcast-dyadic
-      (fn
-        (n k)
-        (let
-          ((loop nil))
-          (begin
-            (set!
-              loop
-              (fn
-                (i num den)
-                (if
-                  (> i k)
-                  (/ num den)
-                  (loop (+ i 1) (* num (- (+ n 1) i)) (* den i)))))
-            (loop 1 1 1))))
-      a
-      b)))
-
-; Monadic ○ : pi times x
-(define
-  apl-pi-times
-  (fn (a) (broadcast-monadic (fn (x) (* 3.14159 x)) a)))
-
-; Dyadic ○ : trig functions (a○b, a=code, b=value)
-(define
-  apl-trig
-  (fn
-    (a b)
-    (broadcast-dyadic
-      (fn
-        (n x)
-        (cond
-          ((= n 0) (pow (- 1 (* x x)) 0.5))
-          ((= n 1) (sin x))
-          ((= n 2) (cos x))
-          ((= n 3) (tan x))
-          ((= n -1) (asin x))
-          ((= n -2) (acos x))
-          ((= n -3) (atan x))
-          (else (error "circle: unsupported trig code"))))
-      a
-      b)))
-
-; ============================================================
-; Comparison primitives (return 0 or 1)
-; ============================================================
-
-(define
-  apl-lt
-  (fn (a b) (broadcast-dyadic (fn (x y) (if (< x y) 1 0)) a b)))
-
-(define
-  apl-le
-  (fn (a b) (broadcast-dyadic (fn (x y) (if (<= x y) 1 0)) a b)))
-
-(define
-  apl-eq
-  (fn (a b) (broadcast-dyadic (fn (x y) (if (= x y) 1 0)) a b)))
-
-(define
-  apl-ge
-  (fn (a b) (broadcast-dyadic (fn (x y) (if (>= x y) 1 0)) a b)))
-
-(define
-  apl-gt
-  (fn (a b) (broadcast-dyadic (fn (x y) (if (> x y) 1 0)) a b)))
-
-(define
-  apl-ne
-  (fn (a b) (broadcast-dyadic (fn (x y) (if (= x y) 0 1)) a b)))
-
-; ============================================================
-; Logical primitives
-; ============================================================
-
-; Monadic ~ : logical not
-(define
-  apl-not
-  (fn (a) (broadcast-monadic (fn (x) (if (= x 0) 1 0)) a)))
-
-; Dyadic ∧ : logical and
-(define
-  apl-and
-  (fn
-    (a b)
-    (broadcast-dyadic
-      (fn (x y) (if (and (not (= x 0)) (not (= y 0))) 1 0))
-      a
-      b)))
-
-; Dyadic ∨ : logical or
-(define
-  apl-or
-  (fn
-    (a b)
-    (broadcast-dyadic
-      (fn (x y) (if (or (not (= x 0)) (not (= y 0))) 1 0))
-      a
-      b)))
-
-; Dyadic ⍱ : logical nor
-(define
-  apl-nor
-  (fn
-    (a b)
-    (broadcast-dyadic
-      (fn (x y) (if (or (not (= x 0)) (not (= y 0))) 0 1))
-      a
-      b)))
-
-; Dyadic ⍲ : logical nand
-(define
-  apl-nand
-  (fn
-    (a b)
-    (broadcast-dyadic
-      (fn (x y) (if (and (not (= x 0)) (not (= y 0))) 0 1))
-      a
-      b)))
-
-; ============================================================
-; Shape primitives
-; ============================================================
-
-; Monadic ⍴ : shape — returns shape as a vector array
-(define apl-shape (fn (arr) (apl-vector (get arr :shape))))
-
-; Monadic , : ravel — returns a rank-1 vector of all elements
-(define apl-ravel (fn (arr) (apl-vector (get arr :ravel))))
-
-; Monadic ≢ : tally — first dimension (1 for scalar)
-(define
-  apl-tally
-  (fn
-    (arr)
-    (if
-      (scalar? arr)
-      (apl-scalar 1)
-      (apl-scalar (first (get arr :shape))))))
-
-; Monadic ≡ : depth
-; simple number/string value → 0
-; array containing only non-arrays → 0
-; array containing arrays → 1 + max depth of elements
-(define
-  apl-depth
-  (fn
-    (arr)
-    (define item-depth nil)
-    (set!
-      item-depth
-      (fn
-        (v)
-        (if
-          (and
-            (dict? v)
-            (not (= nil (get v :shape nil)))
-            (not (= nil (get v :ravel nil))))
-          (+ 1 (first (get (apl-depth v) :ravel)))
-          0)))
-    (let
-      ((depths (map item-depth (get arr :ravel))))
-      (apl-scalar (reduce (fn (a b) (if (> a b) a b)) 0 depths)))))
-
-; Monadic ⍳ : iota — vector 1..n (with ⎕IO=1)
-(define
-  apl-iota
-  (fn
-    (n-arr)
-    (let
-      ((n (first (get n-arr :ravel))) (build nil))
-      (begin
-        (set!
-          build
-          (fn (i acc) (if (< i 1) acc (build (- i 1) (cons i acc)))))
-        (apl-vector (build n (list)))))))

lib/apl/tests/parse.sx

@@ -1,340 +0,0 @@
-(define apl-test-count 0)
-(define apl-test-pass  0)
-(define apl-test-fails (list))
-
-(define apl-test
-  (fn (name actual expected)
-    (begin
-      (set! apl-test-count (+ apl-test-count 1))
-      (if (= actual expected)
-        (set! apl-test-pass (+ apl-test-pass 1))
-        (append! apl-test-fails {:name name :actual actual :expected expected})))))
-
-(define tok-types
-  (fn (src)
-    (map (fn (t) (get t :type)) (apl-tokenize src))))
-
-(define tok-values
-  (fn (src)
-    (map (fn (t) (get t :value)) (apl-tokenize src))))
-
-(define tok-count
-  (fn (src)
-    (len (apl-tokenize src))))
-
-(define tok-type-at
-  (fn (src i)
-    (get (nth (apl-tokenize src) i) :type)))
-
-(define tok-value-at
-  (fn (src i)
-    (get (nth (apl-tokenize src) i) :value)))
-
-(apl-test "empty: no tokens"        (tok-count "")           0)
-(apl-test "empty: whitespace only"  (tok-count "   ")        0)
-(apl-test "num: zero"               (tok-values "0")         (list 0))
-(apl-test "num: positive"           (tok-values "42")        (list 42))
-(apl-test "num: large"              (tok-values "12345")     (list 12345))
-(apl-test "num: negative"           (tok-values "¯5")        (list -5))
-(apl-test "num: negative zero"      (tok-values "¯0")        (list 0))
-(apl-test "num: strand count"       (tok-count "1 2 3")      3)
-(apl-test "num: strand types"       (tok-types "1 2 3")      (list :num :num :num))
-(apl-test "num: strand values"      (tok-values "1 2 3")     (list 1 2 3))
-(apl-test "num: neg in strand"      (tok-values "1 ¯2 3")    (list 1 -2 3))
-(apl-test "str: empty"              (tok-values "''")        (list ""))
-(apl-test "str: single char"        (tok-values "'a'")       (list "a"))
-(apl-test "str: word"               (tok-values "'hello'")   (list "hello"))
-(apl-test "str: escaped quote"      (tok-values "''''")      (list "'"))
-(apl-test "str: type"               (tok-types "'abc'")      (list :str))
-(apl-test "name: simple"            (tok-values "foo")       (list "foo"))
-(apl-test "name: type"              (tok-types "foo")        (list :name))
-(apl-test "name: mixed case"        (tok-values "MyVar")     (list "MyVar"))
-(apl-test "name: with digits"       (tok-values "x1")        (list "x1"))
-(apl-test "name: system var"        (tok-values "⎕IO")       (list "⎕IO"))
-(apl-test "name: system var type"   (tok-types "⎕IO")        (list :name))
-(apl-test "glyph: plus"             (tok-types "+")          (list :glyph))
-(apl-test "glyph: plus value"       (tok-values "+")         (list "+"))
-(apl-test "glyph: iota"             (tok-values "⍳")         (list "⍳"))
-(apl-test "glyph: reduce"           (tok-values "+/")        (list "+" "/"))
-(apl-test "glyph: floor"            (tok-values "⌊")         (list "⌊"))
-(apl-test "glyph: rho"              (tok-values "⍴")         (list "⍴"))
-(apl-test "glyph: alpha omega"      (tok-types "⍺ ⍵")        (list :glyph :glyph))
-(apl-test "punct: lparen"           (tok-types "(")          (list :lparen))
-(apl-test "punct: rparen"           (tok-types ")")          (list :rparen))
-(apl-test "punct: brackets"         (tok-types "[42]")       (list :lbracket :num :rbracket))
-(apl-test "punct: braces"           (tok-types "{}")         (list :lbrace :rbrace))
-(apl-test "punct: semi"             (tok-types ";")          (list :semi))
-(apl-test "assign: arrow"           (tok-types "x←1")        (list :name :assign :num))
-(apl-test "diamond: separator"      (tok-types "1⋄2")        (list :num :diamond :num))
-(apl-test "newline: emitted"        (tok-types "1\n2")       (list :num :newline :num))
-(apl-test "comment: skipped"        (tok-count "⍝ ignore me") 0)
-(apl-test "comment: rest ignored"   (tok-count "1 ⍝ note")  1)
-(apl-test "colon: bare"             (tok-types ":")          (list :colon))
-(apl-test "keyword: If"             (tok-values ":If")       (list ":If"))
-(apl-test "keyword: type"           (tok-types ":While")     (list :keyword))
-(apl-test "keyword: EndFor"         (tok-values ":EndFor")   (list ":EndFor"))
-(apl-test "expr: +/ ⍳ 5"           (tok-types "+/ ⍳ 5")     (list :glyph :glyph :glyph :num))
-(apl-test "expr: x←42"             (tok-count "x←42")       3)
-(apl-test "expr: dfn body"          (tok-types "{⍺+⍵}")
-                                    (list :lbrace :glyph :glyph :glyph :rbrace))
-
-(define apl-tokenize-test-summary
-  (str "tokenizer " apl-test-pass "/" apl-test-count
-       (if (= (len apl-test-fails) 0) "" (str " FAILS: " apl-test-fails))))
-
-; ===========================================================================
-; Parser tests
-; ===========================================================================
-
-; Helper: parse an APL source string and return the AST
-(define parse
-  (fn (src) (parse-apl src)))
-
-; Helper: build an expected AST node using keyword-tagged lists
-(define num-node    (fn (n)       (list :num n)))
-(define str-node    (fn (s)       (list :str s)))
-(define name-node   (fn (n)       (list :name n)))
-(define fn-node     (fn (g)       (list :fn-glyph g)))
-(define fn-nm       (fn (n)       (list :fn-name n)))
-(define assign-node (fn (nm expr) (list :assign nm expr)))
-(define monad-node  (fn (f a)     (list :monad f a)))
-(define dyad-node   (fn (f l r)   (list :dyad f l r)))
-(define derived-fn  (fn (op f)    (list :derived-fn op f)))
-(define derived-fn2 (fn (op f g)  (list :derived-fn2 op f g)))
-(define outer-node  (fn (f)       (list :outer "∘." f)))
-(define guard-node  (fn (c e)     (list :guard c e)))
-
-; ---- numeric literals ----
-
-(apl-test "parse: num literal"
-  (parse "42")
-  (num-node 42))
-
-(apl-test "parse: negative num"
-  (parse "¯3")
-  (num-node -3))
-
-(apl-test "parse: zero"
-  (parse "0")
-  (num-node 0))
-
-; ---- string literals ----
-
-(apl-test "parse: str literal"
-  (parse "'hello'")
-  (str-node "hello"))
-
-(apl-test "parse: empty str"
-  (parse "''")
-  (str-node ""))
-
-; ---- name reference ----
-
-(apl-test "parse: name"
-  (parse "x")
-  (name-node "x"))
-
-(apl-test "parse: system name"
-  (parse "⎕IO")
-  (name-node "⎕IO"))
-
-; ---- strands (vec nodes) ----
-
-(apl-test "parse: strand 3 nums"
-  (parse "1 2 3")
-  (list :vec (num-node 1) (num-node 2) (num-node 3)))
-
-(apl-test "parse: strand 2 nums"
-  (parse "1 2")
-  (list :vec (num-node 1) (num-node 2)))
-
-(apl-test "parse: strand with negatives"
-  (parse "1 ¯2 3")
-  (list :vec (num-node 1) (num-node -2) (num-node 3)))
-
-; ---- assignment ----
-
-(apl-test "parse: assignment"
-  (parse "x←42")
-  (assign-node "x" (num-node 42)))
-
-(apl-test "parse: assignment with spaces"
-  (parse "x ← 42")
-  (assign-node "x" (num-node 42)))
-
-(apl-test "parse: assignment of expr"
-  (parse "r←2+3")
-  (assign-node "r" (dyad-node (fn-node "+") (num-node 2) (num-node 3))))
-
-; ---- monadic functions ----
-
-(apl-test "parse: monadic iota"
-  (parse "⍳5")
-  (monad-node (fn-node "⍳") (num-node 5)))
-
-(apl-test "parse: monadic iota with space"
-  (parse "⍳ 5")
-  (monad-node (fn-node "⍳") (num-node 5)))
-
-(apl-test "parse: monadic negate"
-  (parse "-3")
-  (monad-node (fn-node "-") (num-node 3)))
-
-(apl-test "parse: monadic floor"
-  (parse "⌊2")
-  (monad-node (fn-node "⌊") (num-node 2)))
-
-(apl-test "parse: monadic of name"
-  (parse "⍴x")
-  (monad-node (fn-node "⍴") (name-node "x")))
-
-; ---- dyadic functions ----
-
-(apl-test "parse: dyadic plus"
-  (parse "2+3")
-  (dyad-node (fn-node "+") (num-node 2) (num-node 3)))
-
-(apl-test "parse: dyadic times"
-  (parse "2×3")
-  (dyad-node (fn-node "×") (num-node 2) (num-node 3)))
-
-(apl-test "parse: dyadic with names"
-  (parse "x+y")
-  (dyad-node (fn-node "+") (name-node "x") (name-node "y")))
-
-; ---- right-to-left evaluation ----
-
-(apl-test "parse: right-to-left 2×3+4"
-  (parse "2×3+4")
-  (dyad-node (fn-node "×") (num-node 2)
-    (dyad-node (fn-node "+") (num-node 3) (num-node 4))))
-
-(apl-test "parse: right-to-left chain"
-  (parse "1+2×3-4")
-  (dyad-node (fn-node "+") (num-node 1)
-    (dyad-node (fn-node "×") (num-node 2)
-      (dyad-node (fn-node "-") (num-node 3) (num-node 4)))))
-
-; ---- parenthesized subexpressions ----
-
-(apl-test "parse: parens override order"
-  (parse "(2+3)×4")
-  (dyad-node (fn-node "×")
-    (dyad-node (fn-node "+") (num-node 2) (num-node 3))
-    (num-node 4)))
-
-(apl-test "parse: nested parens"
-  (parse "((2+3))")
-  (dyad-node (fn-node "+") (num-node 2) (num-node 3)))
-
-(apl-test "parse: paren in dyadic right"
-  (parse "2×(3+4)")
-  (dyad-node (fn-node "×") (num-node 2)
-    (dyad-node (fn-node "+") (num-node 3) (num-node 4))))
-
-; ---- operators → derived functions ----
-
-(apl-test "parse: reduce +"
-  (parse "+/x")
-  (monad-node (derived-fn "/" (fn-node "+")) (name-node "x")))
-
-(apl-test "parse: reduce iota"
-  (parse "+/⍳5")
-  (monad-node (derived-fn "/" (fn-node "+"))
-    (monad-node (fn-node "⍳") (num-node 5))))
-
-(apl-test "parse: scan"
-  (parse "+\\x")
-  (monad-node (derived-fn "\\" (fn-node "+")) (name-node "x")))
-
-(apl-test "parse: each"
-  (parse "⍳¨x")
-  (monad-node (derived-fn "¨" (fn-node "⍳")) (name-node "x")))
-
-(apl-test "parse: commute"
-  (parse "-⍨3")
-  (monad-node (derived-fn "⍨" (fn-node "-")) (num-node 3)))
-
-(apl-test "parse: stacked ops"
-  (parse "+/¨x")
-  (monad-node (derived-fn "¨" (derived-fn "/" (fn-node "+"))) (name-node "x")))
-
-; ---- outer product ----
-
-(apl-test "parse: outer product monadic"
-  (parse "∘.×")
-  (outer-node (fn-node "×")))
-
-(apl-test "parse: outer product dyadic names"
-  (parse "x ∘.× y")
-  (dyad-node (outer-node (fn-node "×")) (name-node "x") (name-node "y")))
-
-(apl-test "parse: outer product dyadic strands"
-  (parse "1 2 3 ∘.× 4 5 6")
-  (dyad-node (outer-node (fn-node "×"))
-    (list :vec (num-node 1) (num-node 2) (num-node 3))
-    (list :vec (num-node 4) (num-node 5) (num-node 6))))
-
-; ---- inner product ----
-
-(apl-test "parse: inner product"
-  (parse "+.×")
-  (derived-fn2 "." (fn-node "+") (fn-node "×")))
-
-(apl-test "parse: inner product applied"
-  (parse "a +.× b")
-  (dyad-node (derived-fn2 "." (fn-node "+") (fn-node "×"))
-    (name-node "a") (name-node "b")))
-
-; ---- dfn (anonymous function) ----
-
-(apl-test "parse: simple dfn"
-  (parse "{⍺+⍵}")
-  (list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵"))))
-
-(apl-test "parse: monadic dfn"
-  (parse "{⍵×2}")
-  (list :dfn (dyad-node (fn-node "×") (name-node "⍵") (num-node 2))))
-
-(apl-test "parse: dfn self-ref"
-  (parse "{⍵≤1:1 ⋄ ⍵×∇ ⍵-1}")
-  (list :dfn
-    (guard-node (dyad-node (fn-node "≤") (name-node "⍵") (num-node 1)) (num-node 1))
-    (dyad-node (fn-node "×") (name-node "⍵")
-      (monad-node (fn-node "∇") (dyad-node (fn-node "-") (name-node "⍵") (num-node 1))))))
-
-; ---- dfn applied ----
-
-(apl-test "parse: dfn as function"
-  (parse "{⍺+⍵} 3")
-  (monad-node
-    (list :dfn (dyad-node (fn-node "+") (name-node "⍺") (name-node "⍵")))
-    (num-node 3)))
-
-; ---- multi-statement ----
-
-(apl-test "parse: diamond separator"
-  (let ((result (parse "x←1 ⋄ x+2")))
-    (= (first result) :program))
-  true)
-
-(apl-test "parse: diamond first stmt"
-  (let ((result (parse "x←1 ⋄ x+2")))
-    (nth result 1))
-  (assign-node "x" (num-node 1)))
-
-(apl-test "parse: diamond second stmt"
-  (let ((result (parse "x←1 ⋄ x+2")))
-    (nth result 2))
-  (dyad-node (fn-node "+") (name-node "x") (num-node 2)))
-
-; ---- combined summary ----
-
-(define apl-parse-test-count (- apl-test-count 46))
-(define apl-parse-test-pass  (- apl-test-pass 46))
-
-(define apl-test-summary
-  (str
-    "tokenizer 46/46  |  "
-    "parser " apl-parse-test-pass "/" apl-parse-test-count
-    (if (= (len apl-test-fails) 0) "" (str "  FAILS: " apl-test-fails))))

lib/apl/tests/scalar.sx

@@ -1,369 +0,0 @@
-; APL scalar primitives test suite
-; Requires: lib/apl/runtime.sx
-
-; ============================================================
-; Test framework
-; ============================================================
-
-(define apl-rt-count 0)
-(define apl-rt-pass 0)
-(define apl-rt-fails (list))
-
-; Element-wise list comparison (handles both List and ListRef)
-(define
-  lists-eq
-  (fn
-    (a b)
-    (if
-      (and (= (len a) 0) (= (len b) 0))
-      true
-      (if
-        (not (= (len a) (len b)))
-        false
-        (if
-          (not (= (first a) (first b)))
-          false
-          (lists-eq (rest a) (rest b)))))))
-
-(define
-  apl-rt-test
-  (fn
-    (name actual expected)
-    (begin
-      (set! apl-rt-count (+ apl-rt-count 1))
-      (if
-        (equal? actual expected)
-        (set! apl-rt-pass (+ apl-rt-pass 1))
-        (append! apl-rt-fails {:actual actual :expected expected :name name})))))
-
-; Test that a ravel equals a plain list (handles ListRef vs List)
-(define
-  ravel-test
-  (fn
-    (name arr expected-list)
-    (begin
-      (set! apl-rt-count (+ apl-rt-count 1))
-      (let
-        ((actual (get arr :ravel)))
-        (if
-          (lists-eq actual expected-list)
-          (set! apl-rt-pass (+ apl-rt-pass 1))
-          (append! apl-rt-fails {:actual actual :expected expected-list :name name}))))))
-
-; Test a scalar ravel value (single-element list)
-(define
-  scalar-test
-  (fn (name arr expected-val) (ravel-test name arr (list expected-val))))
-
-; ============================================================
-; Array constructor tests
-; ============================================================
-
-(apl-rt-test
-  "scalar: shape is empty list"
-  (get (apl-scalar 5) :shape)
-  (list))
-
-(apl-rt-test
-  "scalar: ravel has one element"
-  (get (apl-scalar 5) :ravel)
-  (list 5))
-
-(apl-rt-test "scalar: rank 0" (array-rank (apl-scalar 5)) 0)
-
-(apl-rt-test "scalar? returns true for scalar" (scalar? (apl-scalar 5)) true)
-
-(apl-rt-test "scalar: zero" (get (apl-scalar 0) :ravel) (list 0))
-
-(apl-rt-test
-  "vector: shape is (3)"
-  (get (apl-vector (list 1 2 3)) :shape)
-  (list 3))
-
-(apl-rt-test
-  "vector: ravel matches input"
-  (get (apl-vector (list 1 2 3)) :ravel)
-  (list 1 2 3))
-
-(apl-rt-test "vector: rank 1" (array-rank (apl-vector (list 1 2 3))) 1)
-
-(apl-rt-test
-  "scalar? returns false for vector"
-  (scalar? (apl-vector (list 1 2 3)))
-  false)
-
-(apl-rt-test
-  "make-array: rank 2"
-  (array-rank (make-array (list 2 3) (list 1 2 3 4 5 6)))
-  2)
-
-(apl-rt-test
-  "make-array: shape"
-  (get (make-array (list 2 3) (list 1 2 3 4 5 6)) :shape)
-  (list 2 3))
-
-(apl-rt-test
-  "array-ref: first element"
-  (array-ref (apl-vector (list 10 20 30)) 0)
-  10)
-
-(apl-rt-test
-  "array-ref: last element"
-  (array-ref (apl-vector (list 10 20 30)) 2)
-  30)
-
-(apl-rt-test "enclose: wraps in rank-0" (scalar? (enclose 42)) true)
-
-(apl-rt-test
-  "enclose: ravel contains value"
-  (get (enclose 42) :ravel)
-  (list 42))
-
-(apl-rt-test "disclose: unwraps rank-0" (disclose (enclose 42)) 42)
-
-; ============================================================
-; Shape primitive tests
-; ============================================================
-
-(ravel-test "⍴ scalar: returns empty" (apl-shape (apl-scalar 5)) (list))
-
-(ravel-test
-  "⍴ vector: returns (3)"
-  (apl-shape (apl-vector (list 1 2 3)))
-  (list 3))
-
-(ravel-test
-  "⍴ matrix: returns (2 3)"
-  (apl-shape (make-array (list 2 3) (list 1 2 3 4 5 6)))
-  (list 2 3))
-
-(ravel-test
-  ", ravel scalar: vector of 1"
-  (apl-ravel (apl-scalar 5))
-  (list 5))
-
-(apl-rt-test
-  ", ravel vector: same elements"
-  (get (apl-ravel (apl-vector (list 1 2 3))) :ravel)
-  (list 1 2 3))
-
-(apl-rt-test
-  ", ravel matrix: all elements"
-  (get (apl-ravel (make-array (list 2 3) (list 1 2 3 4 5 6))) :ravel)
-  (list 1 2 3 4 5 6))
-
-(scalar-test "≢ tally scalar: 1" (apl-tally (apl-scalar 5)) 1)
-
-(scalar-test
-  "≢ tally vector: first dimension"
-  (apl-tally (apl-vector (list 1 2 3)))
-  3)
-
-(scalar-test
-  "≢ tally matrix: first dimension"
-  (apl-tally (make-array (list 2 3) (list 1 2 3 4 5 6)))
-  2)
-
-(scalar-test
-  "≡ depth flat vector: 0"
-  (apl-depth (apl-vector (list 1 2 3)))
-  0)
-
-(scalar-test "≡ depth scalar: 0" (apl-depth (apl-scalar 5)) 0)
-
-(scalar-test
-  "≡ depth nested (enclose in vector): 1"
-  (apl-depth (enclose (apl-vector (list 1 2 3))))
-  1)
-
-; ============================================================
-; ⍳ iota tests
-; ============================================================
-
-(apl-rt-test
-  "⍳5 shape is (5)"
-  (get (apl-iota (apl-scalar 5)) :shape)
-  (list 5))
-
-(ravel-test "⍳5 ravel is 1..5" (apl-iota (apl-scalar 5)) (list 1 2 3 4 5))
-
-(ravel-test "⍳1 ravel is (1)" (apl-iota (apl-scalar 1)) (list 1))
-
-(ravel-test "⍳0 ravel is empty" (apl-iota (apl-scalar 0)) (list))
-
-(apl-rt-test "apl-io is 1" apl-io 1)
-
-; ============================================================
-; Arithmetic broadcast tests
-; ============================================================
-
-(scalar-test
-  "+ scalar scalar: 3+4=7"
-  (apl-add (apl-scalar 3) (apl-scalar 4))
-  7)
-
-(ravel-test
-  "+ vector scalar: +10"
-  (apl-add (apl-vector (list 1 2 3)) (apl-scalar 10))
-  (list 11 12 13))
-
-(ravel-test
-  "+ scalar vector: 10+"
-  (apl-add (apl-scalar 10) (apl-vector (list 1 2 3)))
-  (list 11 12 13))
-
-(ravel-test
-  "+ vector vector"
-  (apl-add (apl-vector (list 1 2 3)) (apl-vector (list 4 5 6)))
-  (list 5 7 9))
-
-(scalar-test "- negate monadic" (apl-neg-m (apl-scalar 5)) -5)
-
-(scalar-test "- dyadic 10-3=7" (apl-sub (apl-scalar 10) (apl-scalar 3)) 7)
-
-(scalar-test "× signum positive" (apl-signum (apl-scalar 7)) 1)
-
-(scalar-test "× signum negative" (apl-signum (apl-scalar -3)) -1)
-
-(scalar-test "× signum zero" (apl-signum (apl-scalar 0)) 0)
-
-(scalar-test "× dyadic 3×4=12" (apl-mul (apl-scalar 3) (apl-scalar 4)) 12)
-
-(scalar-test "÷ reciprocal 1÷4=0.25" (apl-recip (apl-scalar 4)) 0.25)
-
-(scalar-test
-  "÷ dyadic 10÷4=2.5"
-  (apl-div (apl-scalar 10) (apl-scalar 4))
-  2.5)
-
-(scalar-test "⌈ ceiling 2.3→3" (apl-ceil (apl-scalar 2.3)) 3)
-
-(scalar-test "⌈ max 3 5 → 5" (apl-max (apl-scalar 3) (apl-scalar 5)) 5)
-
-(scalar-test "⌊ floor 2.7→2" (apl-floor (apl-scalar 2.7)) 2)
-
-(scalar-test "⌊ min 3 5 → 3" (apl-min (apl-scalar 3) (apl-scalar 5)) 3)
-
-(scalar-test "* exp monadic e^0=1" (apl-exp (apl-scalar 0)) 1)
-
-(scalar-test
-  "* pow dyadic 2^10=1024"
-  (apl-pow (apl-scalar 2) (apl-scalar 10))
-  1024)
-
-(scalar-test "⍟ ln 1=0" (apl-ln (apl-scalar 1)) 0)
-
-(scalar-test "| abs positive" (apl-abs (apl-scalar 5)) 5)
-
-(scalar-test "| abs negative" (apl-abs (apl-scalar -5)) 5)
-
-(scalar-test "| mod 3|7=1" (apl-mod (apl-scalar 3) (apl-scalar 7)) 1)
-
-(scalar-test "! factorial 5!=120" (apl-fact (apl-scalar 5)) 120)
-
-(scalar-test "! factorial 0!=1" (apl-fact (apl-scalar 0)) 1)
-
-(scalar-test
-  "! binomial 4 choose 2 = 6"
-  (apl-binomial (apl-scalar 4) (apl-scalar 2))
-  6)
-
-(scalar-test "○ pi×0=0" (apl-pi-times (apl-scalar 0)) 0)
-
-(scalar-test "○ trig sin(0)=0" (apl-trig (apl-scalar 1) (apl-scalar 0)) 0)
-
-(scalar-test "○ trig cos(0)=1" (apl-trig (apl-scalar 2) (apl-scalar 0)) 1)
-
-; ============================================================
-; Comparison tests
-; ============================================================
-
-(scalar-test "< less: 3<5 → 1" (apl-lt (apl-scalar 3) (apl-scalar 5)) 1)
-
-(scalar-test "< less: 5<3 → 0" (apl-lt (apl-scalar 5) (apl-scalar 3)) 0)
-
-(scalar-test
-  "≤ le equal: 3≤3 → 1"
-  (apl-le (apl-scalar 3) (apl-scalar 3))
-  1)
-
-(scalar-test "= eq: 5=5 → 1" (apl-eq (apl-scalar 5) (apl-scalar 5)) 1)
-
-(scalar-test "= ne: 5=6 → 0" (apl-eq (apl-scalar 5) (apl-scalar 6)) 0)
-
-(scalar-test "≥ ge: 5≥3 → 1" (apl-ge (apl-scalar 5) (apl-scalar 3)) 1)
-
-(scalar-test "> gt: 5>3 → 1" (apl-gt (apl-scalar 5) (apl-scalar 3)) 1)
-
-(scalar-test "≠ ne: 5≠3 → 1" (apl-ne (apl-scalar 5) (apl-scalar 3)) 1)
-
-(ravel-test
-  "comparison vector broadcast: 1 2 3 < 2 → 1 0 0"
-  (apl-lt (apl-vector (list 1 2 3)) (apl-scalar 2))
-  (list 1 0 0))
-
-; ============================================================
-; Logical tests
-; ============================================================
-
-(scalar-test "~ not 0 → 1" (apl-not (apl-scalar 0)) 1)
-
-(scalar-test "~ not 1 → 0" (apl-not (apl-scalar 1)) 0)
-
-(ravel-test
-  "~ not vector: 1 0 1 0 → 0 1 0 1"
-  (apl-not (apl-vector (list 1 0 1 0)))
-  (list 0 1 0 1))
-
-(scalar-test
-  "∧ and 1∧1 → 1"
-  (apl-and (apl-scalar 1) (apl-scalar 1))
-  1)
-
-(scalar-test
-  "∧ and 1∧0 → 0"
-  (apl-and (apl-scalar 1) (apl-scalar 0))
-  0)
-
-(scalar-test "∨ or 0∨1 → 1" (apl-or (apl-scalar 0) (apl-scalar 1)) 1)
-
-(scalar-test "∨ or 0∨0 → 0" (apl-or (apl-scalar 0) (apl-scalar 0)) 0)
-
-(scalar-test
-  "⍱ nor 0⍱0 → 1"
-  (apl-nor (apl-scalar 0) (apl-scalar 0))
-  1)
-
-(scalar-test
-  "⍱ nor 1⍱0 → 0"
-  (apl-nor (apl-scalar 1) (apl-scalar 0))
-  0)
-
-(scalar-test
-  "⍲ nand 1⍲1 → 0"
-  (apl-nand (apl-scalar 1) (apl-scalar 1))
-  0)
-
-(scalar-test
-  "⍲ nand 1⍲0 → 1"
-  (apl-nand (apl-scalar 1) (apl-scalar 0))
-  1)
-
-; ============================================================
-; plus-m identity test
-; ============================================================
-
-(scalar-test "+ monadic identity: +5 → 5" (apl-plus-m (apl-scalar 5)) 5)
-
-; ============================================================
-; Summary
-; ============================================================
-
-(define
-  apl-scalar-summary
-  (str
-    "scalar "
-    apl-rt-pass
-    "/"
-    apl-rt-count
-    (if (= (len apl-rt-fails) 0) "" (str " FAILS: " apl-rt-fails))))

lib/apl/tokenizer.sx

@@ -1,168 +0,0 @@
-(define apl-glyph-set
-  (list "+" "-" "×" "÷" "*" "⍟" "⌈" "⌊" "|" "!" "?" "○" "~" "<" "≤" "=" "≥" ">" "≠"
-        "∊" "∧" "∨" "⍱" "⍲" "," "⍪" "⍴" "⌽" "⊖" "⍉" "↑" "↓" "⊂" "⊃" "⊆"
-        "∪" "∩" "⍳" "⍸" "⌷" "⍋" "⍒" "⊥" "⊤" "⊣" "⊢" "⍎" "⍕"
-        "⍺" "⍵" "∇" "/" "\\" "¨" "⍨" "∘" "." "⍣" "⍤" "⍥" "@" "¯"))
-
-(define apl-glyph?
-  (fn (ch)
-    (some (fn (g) (= g ch)) apl-glyph-set)))
-
-(define apl-digit?
-  (fn (ch)
-    (and (string? ch) (>= ch "0") (<= ch "9"))))
-
-(define apl-alpha?
-  (fn (ch)
-    (and (string? ch)
-         (or (and (>= ch "a") (<= ch "z"))
-             (and (>= ch "A") (<= ch "Z"))
-             (= ch "_")))))
-
-(define apl-tokenize
-  (fn (source)
-    (let ((pos 0)
-          (src-len (len source))
-          (tokens (list)))
-
-      (define tok-push!
-        (fn (type value)
-          (append! tokens {:type type :value value})))
-
-      (define cur-sw?
-        (fn (ch)
-          (and (< pos src-len) (starts-with? (slice source pos) ch))))
-
-      (define cur-byte
-        (fn ()
-          (if (< pos src-len) (nth source pos) nil)))
-
-      (define advance!
-        (fn ()
-          (set! pos (+ pos 1))))
-
-      (define consume!
-        (fn (ch)
-          (set! pos (+ pos (len ch)))))
-
-      (define find-glyph
-        (fn ()
-          (let ((rem (slice source pos)))
-            (let ((matches (filter (fn (g) (starts-with? rem g)) apl-glyph-set)))
-              (if (> (len matches) 0) (first matches) nil)))))
-
-      (define read-digits!
-        (fn (acc)
-          (if (and (< pos src-len) (apl-digit? (cur-byte)))
-            (let ((ch (cur-byte)))
-              (begin
-                (advance!)
-                (read-digits! (str acc ch))))
-            acc)))
-
-      (define read-ident-cont!
-        (fn ()
-          (when (and (< pos src-len)
-                     (let ((ch (cur-byte)))
-                       (or (apl-alpha? ch) (apl-digit? ch))))
-            (begin
-              (advance!)
-              (read-ident-cont!)))))
-
-      (define read-string!
-        (fn (acc)
-          (cond
-            ((>= pos src-len) acc)
-            ((cur-sw? "'")
-             (if (and (< (+ pos 1) src-len) (cur-sw? "'"))
-               (begin
-                 (advance!)
-                 (advance!)
-                 (read-string! (str acc "'")))
-               (begin (advance!) acc)))
-            (true
-             (let ((ch (cur-byte)))
-               (begin
-                 (advance!)
-                 (read-string! (str acc ch))))))))
-
-      (define skip-line!
-        (fn ()
-          (when (and (< pos src-len) (not (cur-sw? "\n")))
-            (begin
-              (advance!)
-              (skip-line!)))))
-
-      (define scan!
-        (fn ()
-          (when (< pos src-len)
-            (let ((ch (cur-byte)))
-              (cond
-                ((or (= ch " ") (= ch "\t") (= ch "\r"))
-                 (begin (advance!) (scan!)))
-                ((= ch "\n")
-                 (begin (advance!) (tok-push! :newline nil) (scan!)))
-                ((cur-sw? "⍝")
-                 (begin (skip-line!) (scan!)))
-                ((cur-sw? "⋄")
-                 (begin (consume! "⋄") (tok-push! :diamond nil) (scan!)))
-                ((= ch "(")
-                 (begin (advance!) (tok-push! :lparen nil) (scan!)))
-                ((= ch ")")
-                 (begin (advance!) (tok-push! :rparen nil) (scan!)))
-                ((= ch "[")
-                 (begin (advance!) (tok-push! :lbracket nil) (scan!)))
-                ((= ch "]")
-                 (begin (advance!) (tok-push! :rbracket nil) (scan!)))
-                ((= ch "{")
-                 (begin (advance!) (tok-push! :lbrace nil) (scan!)))
-                ((= ch "}")
-                 (begin (advance!) (tok-push! :rbrace nil) (scan!)))
-                ((= ch ";")
-                 (begin (advance!) (tok-push! :semi nil) (scan!)))
-                ((cur-sw? "←")
-                 (begin (consume! "←") (tok-push! :assign nil) (scan!)))
-                ((= ch ":")
-                 (let ((start pos))
-                   (begin
-                     (advance!)
-                     (if (and (< pos src-len) (apl-alpha? (cur-byte)))
-                       (begin
-                         (read-ident-cont!)
-                         (tok-push! :keyword (slice source start pos)))
-                       (tok-push! :colon nil))
-                     (scan!))))
-                ((and (cur-sw? "¯")
-                      (< (+ pos (len "¯")) src-len)
-                      (apl-digit? (nth source (+ pos (len "¯")))))
-                 (begin
-                   (consume! "¯")
-                   (let ((digits (read-digits! "")))
-                     (tok-push! :num (- 0 (parse-int digits 0))))
-                   (scan!)))
-                ((apl-digit? ch)
-                 (begin
-                   (let ((digits (read-digits! "")))
-                     (tok-push! :num (parse-int digits 0)))
-                   (scan!)))
-                ((= ch "'")
-                 (begin
-                   (advance!)
-                   (let ((s (read-string! "")))
-                     (tok-push! :str s))
-                   (scan!)))
-                ((or (apl-alpha? ch) (cur-sw? "⎕"))
-                 (let ((start pos))
-                   (begin
-                     (if (cur-sw? "⎕") (consume! "⎕") (advance!))
-                     (read-ident-cont!)
-                     (tok-push! :name (slice source start pos))
-                     (scan!))))
-                (true
-                 (let ((g (find-glyph)))
-                   (if g
-                     (begin (consume! g) (tok-push! :glyph g) (scan!))
-                     (begin (advance!) (scan!))))))))))
-
-      (scan!)
-      tokens)))

lib/tcl/parser.sx

@@ -0,0 +1,41 @@
+; Tcl parser — thin layer over tcl-tokenize
+; Adds tcl-parse entry point and word utility fns
+
+; Entry point: parse Tcl source to a list of commands.
+; Returns same structure as tcl-tokenize.
+(define tcl-parse (fn (src) (tcl-tokenize src)))
+
+; True if word has no substitutions — value can be read statically.
+; braced words are always simple. compound words are simple when all
+; parts are plain text with no var/cmd parts.
+(define tcl-word-simple?
+  (fn (word)
+    (cond
+      ((= (get word :type) "braced") true)
+      ((= (get word :type) "compound")
+        (let ((parts (get word :parts)))
+          (every? (fn (p) (= (get p :type) "text")) parts)))
+      (else false))))
+
+; Concatenate text parts of a simple word into a single string.
+; For braced words returns :value directly.
+; For compound words with only text parts, joins them.
+; Returns nil for words with substitutions.
+(define tcl-word-literal
+  (fn (word)
+    (cond
+      ((= (get word :type) "braced") (get word :value))
+      ((= (get word :type) "compound")
+        (if (tcl-word-simple? word)
+          (join "" (map (fn (p) (get p :value)) (get word :parts)))
+          nil))
+      (else nil))))
+
+; Number of words in a parsed command.
+(define tcl-cmd-len
+  (fn (cmd) (len (get cmd :words))))
+
+; Nth word literal from a command (index 0 = command name).
+; Returns nil if word has substitutions.
+(define tcl-nth-literal
+  (fn (cmd n) (tcl-word-literal (nth (get cmd :words) n))))

lib/tcl/runtime.sx

@@ -0,0 +1,570 @@
+; Tcl-on-SX runtime evaluator
+; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output}
+
+(define make-frame (fn (level parent) {:level level :locals {} :parent parent}))
+
+(define
+  frame-lookup
+  (fn
+    (frame name)
+    (if
+      (nil? frame)
+      nil
+      (let
+        ((val (get (get frame :locals) name)))
+        (if (nil? val) (frame-lookup (get frame :parent) name) val)))))
+
+(define
+  frame-set-top
+  (fn
+    (frame name val)
+    (assoc frame :locals (assoc (get frame :locals) name val))))
+
+(define make-tcl-interp (fn () {:result "" :output "" :code 0 :frame (make-frame 0 nil) :commands {}}))
+
+(define
+  tcl-register
+  (fn
+    (interp name f)
+    (assoc interp :commands (assoc (get interp :commands) name f))))
+
+(define
+  tcl-var-get
+  (fn
+    (interp name)
+    (let
+      ((val (frame-lookup (get interp :frame) name)))
+      (if
+        (nil? val)
+        (error (str "can't read \"" name "\": no such variable"))
+        val))))
+
+(define
+  tcl-var-set
+  (fn
+    (interp name val)
+    (assoc interp :frame (frame-set-top (get interp :frame) name val))))
+
+(define
+  tcl-eval-parts
+  (fn
+    (parts interp)
+    (reduce
+      (fn
+        (acc part)
+        (let
+          ((type (get part :type)) (cur-interp (get acc :interp)))
+          (cond
+            ((equal? type "text") {:values (append (get acc :values) (list (get part :value))) :interp cur-interp})
+            ((equal? type "var") {:values (append (get acc :values) (list (tcl-var-get cur-interp (get part :name)))) :interp cur-interp})
+            ((equal? type "var-arr")
+              (let
+                ((key-acc (tcl-eval-parts (get part :key) cur-interp)))
+                (let
+                  ((key (join "" (get key-acc :values)))
+                    (next-interp (get key-acc :interp)))
+                  {:values (append (get acc :values) (list (tcl-var-get next-interp (str (get part :name) "(" key ")")))) :interp next-interp})))
+            ((equal? type "cmd")
+              (let
+                ((new-interp (tcl-eval-string cur-interp (get part :src))))
+                {:values (append (get acc :values) (list (get new-interp :result))) :interp new-interp}))
+            (else (error (str "tcl: unknown part type: " type))))))
+      {:values (quote ()) :interp interp}
+      parts)))
+
+(define
+  tcl-eval-word
+  (fn
+    (word interp)
+    (let
+      ((type (get word :type)))
+      (cond
+        ((equal? type "braced") {:interp interp :value (get word :value)})
+        ((equal? type "compound")
+          (let
+            ((result (tcl-eval-parts (get word :parts) interp)))
+            {:interp (get result :interp) :value (join "" (get result :values))}))
+        ((equal? type "expand") (tcl-eval-word (get word :word) interp))
+        (else (error (str "tcl: unknown word type: " type)))))))
+
+(define
+  tcl-list-split
+  (fn
+    (s)
+    (define chars (split s ""))
+    (define len-s (len chars))
+    (define
+      go
+      (fn
+        (i acc cur-item depth)
+        (if
+          (>= i len-s)
+          (if (> (len cur-item) 0) (append acc (list cur-item)) acc)
+          (let
+            ((c (nth chars i)))
+            (cond
+              ((equal? c "{")
+                (if
+                  (= depth 0)
+                  (go (+ i 1) acc "" (+ depth 1))
+                  (go (+ i 1) acc (str cur-item c) (+ depth 1))))
+              ((equal? c "}")
+                (if
+                  (= depth 1)
+                  (go (+ i 1) (append acc (list cur-item)) "" 0)
+                  (go (+ i 1) acc (str cur-item c) (- depth 1))))
+              ((equal? c " ")
+                (if
+                  (and (= depth 0) (> (len cur-item) 0))
+                  (go (+ i 1) (append acc (list cur-item)) "" 0)
+                  (go
+                    (+ i 1)
+                    acc
+                    (if (> depth 0) (str cur-item c) cur-item)
+                    depth)))
+              (else (go (+ i 1) acc (str cur-item c) depth)))))))
+    (go 0 (list) "" 0)))
+
+(define
+  tcl-eval-words
+  (fn
+    (words interp)
+    (reduce
+      (fn
+        (acc w)
+        (let
+          ((cur-interp (get acc :interp)))
+          (if
+            (equal? (get w :type) "expand")
+            (let
+              ((wr (tcl-eval-word (get w :word) cur-interp)))
+              {:values (append (get acc :values) (tcl-list-split (get wr :value))) :interp (get wr :interp)})
+            (let ((wr (tcl-eval-word w cur-interp))) {:values (append (get acc :values) (list (get wr :value))) :interp (get wr :interp)}))))
+      {:values (quote ()) :interp interp}
+      words)))
+
+(define
+  tcl-eval-cmd
+  (fn
+    (interp cmd)
+    (let
+      ((wr (tcl-eval-words (get cmd :words) interp)))
+      (let
+        ((words (get wr :values)) (cur-interp (get wr :interp)))
+        (if
+          (= 0 (len words))
+          cur-interp
+          (let
+            ((cmd-name (first words)) (cmd-args (rest words)))
+            (let
+              ((cmd-fn (get (get cur-interp :commands) cmd-name)))
+              (if
+                (nil? cmd-fn)
+                (error (str "unknown command: \"" cmd-name "\""))
+                (cmd-fn cur-interp cmd-args)))))))))
+
+(define
+  tcl-eval-script
+  (fn
+    (interp cmds)
+    (if
+      (or (= 0 (len cmds)) (not (= 0 (get interp :code))))
+      interp
+      (tcl-eval-script (tcl-eval-cmd interp (first cmds)) (rest cmds)))))
+
+(define
+  tcl-eval-string
+  (fn (interp src) (tcl-eval-script interp (tcl-parse src))))
+
+(define
+  tcl-cmd-set
+  (fn
+    (interp args)
+    (if
+      (= (len args) 1)
+      (assoc interp :result (tcl-var-get interp (first args)))
+      (let
+        ((val (nth args 1)))
+        (assoc (tcl-var-set interp (first args) val) :result val)))))
+
+(define
+  tcl-cmd-puts
+  (fn
+    (interp args)
+    (let
+      ((text (last args))
+        (no-nl
+          (and
+            (> (len args) 1)
+            (equal? (first args) "-nonewline"))))
+      (let
+        ((line (if no-nl text (str text "\n"))))
+        (assoc interp :output (str (get interp :output) line))))))
+
+(define
+  tcl-cmd-incr
+  (fn
+    (interp args)
+    (let
+      ((name (first args))
+        (delta
+          (if
+            (> (len args) 1)
+            (parse-int (nth args 1))
+            1)))
+      (let
+        ((new-val (str (+ (parse-int (tcl-var-get interp name)) delta))))
+        (assoc (tcl-var-set interp name new-val) :result new-val)))))
+
+(define
+  tcl-cmd-append
+  (fn
+    (interp args)
+    (let
+      ((name (first args)) (suffix (join "" (rest args))))
+      (let
+        ((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
+        (let
+          ((new-val (str cur suffix)))
+          (assoc (tcl-var-set interp name new-val) :result new-val))))))
+
+(define
+  tcl-true?
+  (fn
+    (s)
+    (not
+      (or (equal? s "0") (equal? s "") (equal? s "false") (equal? s "no")))))
+
+(define tcl-false? (fn (s) (not (tcl-true? s))))
+
+(define
+  tcl-expr-compute
+  (fn
+    (tokens)
+    (let
+      ((n (len tokens)))
+      (cond
+        ((= n 1) (first tokens))
+        ((= n 2)
+          (let
+            ((op (first tokens)) (x (nth tokens 1)))
+            (if
+              (equal? op "!")
+              (if (tcl-false? x) "1" "0")
+              (error (str "expr: unknown unary op: " op)))))
+        ((= n 3)
+          (let
+            ((l (first tokens)) (op (nth tokens 1)) (r (nth tokens 2)))
+            (cond
+              ((equal? op "+") (str (+ (parse-int l) (parse-int r))))
+              ((equal? op "-") (str (- (parse-int l) (parse-int r))))
+              ((equal? op "*") (str (* (parse-int l) (parse-int r))))
+              ((equal? op "/") (str (/ (parse-int l) (parse-int r))))
+              ((equal? op "%") (str (mod (parse-int l) (parse-int r))))
+              ((equal? op "==") (if (equal? l r) "1" "0"))
+              ((equal? op "!=") (if (equal? l r) "0" "1"))
+              ((equal? op "<")
+                (if (< (parse-int l) (parse-int r)) "1" "0"))
+              ((equal? op ">")
+                (if (> (parse-int l) (parse-int r)) "1" "0"))
+              ((equal? op "<=")
+                (if (<= (parse-int l) (parse-int r)) "1" "0"))
+              ((equal? op ">=")
+                (if (>= (parse-int l) (parse-int r)) "1" "0"))
+              ((equal? op "&&")
+                (if (and (tcl-true? l) (tcl-true? r)) "1" "0"))
+              ((equal? op "||")
+                (if (or (tcl-true? l) (tcl-true? r)) "1" "0"))
+              (else (error (str "expr: unknown op: " op))))))
+        (else (error (str "expr: complex expr not yet supported")))))))
+
+(define
+  tcl-expr-eval
+  (fn
+    (interp s)
+    (let
+      ((cmds (tcl-parse s)))
+      (if
+        (= 0 (len cmds))
+        {:result "0" :interp interp}
+        (let
+          ((wr (tcl-eval-words (get (first cmds) :words) interp)))
+          {:result (tcl-expr-compute (get wr :values)) :interp (get wr :interp)})))))
+
+(define tcl-cmd-break (fn (interp args) (assoc interp :code 3)))
+
+(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4)))
+
+(define
+  tcl-cmd-return
+  (fn
+    (interp args)
+    (let
+      ((val (if (> (len args) 0) (last args) "")))
+      (assoc (assoc interp :result val) :code 2))))
+
+(define
+  tcl-cmd-error
+  (fn
+    (interp args)
+    (let
+      ((msg (if (> (len args) 0) (first args) "error")))
+      (assoc (assoc interp :result msg) :code 1))))
+
+(define
+  tcl-cmd-unset
+  (fn
+    (interp args)
+    (reduce
+      (fn
+        (i name)
+        (let
+          ((frame (get i :frame)))
+          (let
+            ((new-locals (reduce (fn (acc k) (if (equal? k name) acc (assoc acc k (get (get frame :locals) k)))) {} (keys (get frame :locals)))))
+            (assoc i :frame (assoc frame :locals new-locals)))))
+      interp
+      args)))
+
+(define
+  tcl-cmd-lappend
+  (fn
+    (interp args)
+    (let
+      ((name (first args)) (items (rest args)))
+      (let
+        ((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
+        (let
+          ((new-val (if (equal? cur "") (join " " items) (str cur " " (join " " items)))))
+          (assoc (tcl-var-set interp name new-val) :result new-val))))))
+
+(define
+  tcl-cmd-eval
+  (fn (interp args) (tcl-eval-string interp (join " " args))))
+
+(define
+  tcl-while-loop
+  (fn
+    (interp cond-str body)
+    (let
+      ((er (tcl-expr-eval interp cond-str)))
+      (if
+        (tcl-false? (get er :result))
+        (get er :interp)
+        (let
+          ((body-result (tcl-eval-string (get er :interp) body)))
+          (let
+            ((code (get body-result :code)))
+            (cond
+              ((= code 3) (assoc body-result :code 0))
+              ((= code 2) body-result)
+              ((= code 1) body-result)
+              (else
+                (tcl-while-loop
+                  (assoc body-result :code 0)
+                  cond-str
+                  body)))))))))
+
+(define
+  tcl-cmd-while
+  (fn
+    (interp args)
+    (tcl-while-loop interp (first args) (nth args 1))))
+
+(define
+  tcl-cmd-if
+  (fn
+    (interp args)
+    (let
+      ((er (tcl-expr-eval interp (first args))))
+      (let
+        ((cond-true (tcl-true? (get er :result)))
+          (new-interp (get er :interp))
+          (rest-args (rest args)))
+        (let
+          ((adj (if (and (> (len rest-args) 0) (equal? (first rest-args) "then")) (rest rest-args) rest-args)))
+          (let
+            ((then-body (first adj)) (rest2 (rest adj)))
+            (if
+              cond-true
+              (tcl-eval-string new-interp then-body)
+              (cond
+                ((= 0 (len rest2)) new-interp)
+                ((equal? (first rest2) "else")
+                  (if
+                    (> (len rest2) 1)
+                    (tcl-eval-string new-interp (nth rest2 1))
+                    new-interp))
+                ((equal? (first rest2) "elseif")
+                  (tcl-cmd-if new-interp (rest rest2)))
+                (else new-interp)))))))))
+
+(define
+  tcl-for-loop
+  (fn
+    (interp cond-str step body)
+    (let
+      ((er (tcl-expr-eval interp cond-str)))
+      (if
+        (tcl-false? (get er :result))
+        (get er :interp)
+        (let
+          ((body-result (tcl-eval-string (get er :interp) body)))
+          (let
+            ((code (get body-result :code)))
+            (cond
+              ((= code 3) (assoc body-result :code 0))
+              ((= code 2) body-result)
+              ((= code 1) body-result)
+              (else
+                (let
+                  ((step-result (tcl-eval-string (assoc body-result :code 0) step)))
+                  (tcl-for-loop
+                    (assoc step-result :code 0)
+                    cond-str
+                    step
+                    body))))))))))
+
+(define
+  tcl-cmd-for
+  (fn
+    (interp args)
+    (let
+      ((init-body (first args))
+        (cond-str (nth args 1))
+        (step (nth args 2))
+        (body (nth args 3)))
+      (let
+        ((init-result (tcl-eval-string interp init-body)))
+        (tcl-for-loop init-result cond-str step body)))))
+
+(define
+  tcl-foreach-loop
+  (fn
+    (interp var-name items body)
+    (if
+      (= 0 (len items))
+      interp
+      (let
+        ((body-result (tcl-eval-string (tcl-var-set interp var-name (first items)) body)))
+        (let
+          ((code (get body-result :code)))
+          (cond
+            ((= code 3) (assoc body-result :code 0))
+            ((= code 2) body-result)
+            ((= code 1) body-result)
+            (else
+              (tcl-foreach-loop
+                (assoc body-result :code 0)
+                var-name
+                (rest items)
+                body))))))))
+
+(define
+  tcl-cmd-foreach
+  (fn
+    (interp args)
+    (let
+      ((var-name (first args))
+        (list-str (nth args 1))
+        (body (nth args 2)))
+      (tcl-foreach-loop interp var-name (tcl-list-split list-str) body))))
+
+(define
+  tcl-cmd-switch
+  (fn
+    (interp args)
+    (let
+      ((str-val (first args)) (body (nth args 1)))
+      (let
+        ((pairs (tcl-list-split body)))
+        (define
+          try-pairs
+          (fn
+            (ps)
+            (if
+              (= 0 (len ps))
+              interp
+              (let
+                ((pat (first ps)) (bdy (nth ps 1)))
+                (if
+                  (or (equal? pat str-val) (equal? pat "default"))
+                  (if
+                    (equal? bdy "-")
+                    (try-pairs (rest (rest ps)))
+                    (tcl-eval-string interp bdy))
+                  (try-pairs (rest (rest ps))))))))
+        (try-pairs pairs)))))
+
+(define
+  tcl-cmd-expr
+  (fn
+    (interp args)
+    (let
+      ((s (join " " args)))
+      (let
+        ((er (tcl-expr-eval interp s)))
+        (assoc (get er :interp) :result (get er :result))))))
+
+(define tcl-cmd-gets (fn (interp args) (assoc interp :result "")))
+
+(define
+  tcl-cmd-subst
+  (fn (interp args) (assoc interp :result (last args))))
+
+(define
+  tcl-cmd-format
+  (fn (interp args) (assoc interp :result (join "" args))))
+
+(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0")))
+
+(define
+  make-default-tcl-interp
+  (fn
+    ()
+    (let
+      ((i (make-tcl-interp)))
+      (let
+        ((i (tcl-register i "set" tcl-cmd-set)))
+        (let
+          ((i (tcl-register i "puts" tcl-cmd-puts)))
+          (let
+            ((i (tcl-register i "incr" tcl-cmd-incr)))
+            (let
+              ((i (tcl-register i "append" tcl-cmd-append)))
+              (let
+                ((i (tcl-register i "unset" tcl-cmd-unset)))
+                (let
+                  ((i (tcl-register i "lappend" tcl-cmd-lappend)))
+                  (let
+                    ((i (tcl-register i "eval" tcl-cmd-eval)))
+                    (let
+                      ((i (tcl-register i "if" tcl-cmd-if)))
+                      (let
+                        ((i (tcl-register i "while" tcl-cmd-while)))
+                        (let
+                          ((i (tcl-register i "for" tcl-cmd-for)))
+                          (let
+                            ((i (tcl-register i "foreach" tcl-cmd-foreach)))
+                            (let
+                              ((i (tcl-register i "switch" tcl-cmd-switch)))
+                              (let
+                                ((i (tcl-register i "break" tcl-cmd-break)))
+                                (let
+                                  ((i (tcl-register i "continue" tcl-cmd-continue)))
+                                  (let
+                                    ((i (tcl-register i "return" tcl-cmd-return)))
+                                    (let
+                                      ((i (tcl-register i "error" tcl-cmd-error)))
+                                      (let
+                                        ((i (tcl-register i "expr" tcl-cmd-expr)))
+                                        (let
+                                          ((i (tcl-register i "gets" tcl-cmd-gets)))
+                                          (let
+                                            ((i (tcl-register i "subst" tcl-cmd-subst)))
+                                            (let
+                                              ((i (tcl-register i "format" tcl-cmd-format)))
+                                              (tcl-register
+                                                i
+                                                "scan"
+                                                tcl-cmd-scan))))))))))))))))))))))))

lib/tcl/test.sh

@@ -0,0 +1,81 @@
+#!/usr/bin/env bash
+# Tcl-on-SX test runner — epoch protocol to sx_server.exe
+set -uo pipefail
+cd "$(git rev-parse --show-toplevel)"
+
+SX_SERVER="${SX_SERVER:-hosts/ocaml/_build/default/bin/sx_server.exe}"
+if [ ! -x "$SX_SERVER" ]; then
+  SX_SERVER="/root/rose-ash/hosts/ocaml/_build/default/bin/sx_server.exe"
+fi
+if [ ! -x "$SX_SERVER" ]; then echo "ERROR: sx_server.exe not found"; exit 1; fi
+
+VERBOSE="${1:-}"
+TMPFILE=$(mktemp)
+HELPER=$(mktemp --suffix=.sx)
+trap "rm -f $TMPFILE $HELPER" EXIT
+
+# Helper file: run both test suites and format a parseable summary string
+cat > "$HELPER" << 'HELPER_EOF'
+(define __pr (tcl-run-parse-tests))
+(define __er (tcl-run-eval-tests))
+(define tcl-test-summary
+  (str "PARSE:" (get __pr "passed") ":" (get __pr "failed")
+       " EVAL:" (get __er "passed") ":" (get __er "failed")))
+HELPER_EOF
+
+cat > "$TMPFILE" << EPOCHS
+(epoch 1)
+(load "lib/tcl/tokenizer.sx")
+(epoch 2)
+(load "lib/tcl/parser.sx")
+(epoch 3)
+(load "lib/tcl/tests/parse.sx")
+(epoch 4)
+(load "lib/tcl/runtime.sx")
+(epoch 5)
+(load "lib/tcl/tests/eval.sx")
+(epoch 6)
+(load "$HELPER")
+(epoch 7)
+(eval "tcl-test-summary")
+EPOCHS
+
+OUTPUT=$(timeout 30 "$SX_SERVER" < "$TMPFILE" 2>&1)
+[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
+
+# Extract summary line from epoch 7 output
+SUMMARY=$(echo "$OUTPUT" | grep -A1 "^(ok-len 7 " | tail -1 | tr -d '"')
+
+if [ -z "$SUMMARY" ]; then
+  echo "ERROR: no summary from test run"
+  echo "$OUTPUT" | tail -20
+  exit 1
+fi
+
+# Parse PARSE:N:M EVAL:N:M
+PARSE_PART=$(echo "$SUMMARY" | grep -o 'PARSE:[0-9]*:[0-9]*')
+EVAL_PART=$(echo "$SUMMARY"  | grep -o 'EVAL:[0-9]*:[0-9]*')
+
+PARSE_PASSED=$(echo "$PARSE_PART" | cut -d: -f2)
+PARSE_FAILED=$(echo "$PARSE_PART" | cut -d: -f3)
+EVAL_PASSED=$(echo "$EVAL_PART"   | cut -d: -f2)
+EVAL_FAILED=$(echo "$EVAL_PART"   | cut -d: -f3)
+
+PARSE_PASSED=${PARSE_PASSED:-0}; PARSE_FAILED=${PARSE_FAILED:-1}
+EVAL_PASSED=${EVAL_PASSED:-0};   EVAL_FAILED=${EVAL_FAILED:-1}
+
+TOTAL_PASSED=$((PARSE_PASSED + EVAL_PASSED))
+TOTAL_FAILED=$((PARSE_FAILED + EVAL_FAILED))
+TOTAL=$((TOTAL_PASSED + TOTAL_FAILED))
+
+if [ "$TOTAL_FAILED" = "0" ]; then
+  echo "ok $TOTAL_PASSED/$TOTAL tcl tests passed (parse: $PARSE_PASSED, eval: $EVAL_PASSED)"
+  exit 0
+else
+  echo "FAIL $TOTAL_PASSED/$TOTAL passed, $TOTAL_FAILED failed (parse: $PARSE_PASSED/$((PARSE_PASSED+PARSE_FAILED)), eval: $EVAL_PASSED/$((EVAL_PASSED+EVAL_FAILED)))"
+  if [ -z "$VERBOSE" ]; then
+    echo "--- output ---"
+    echo "$OUTPUT" | tail -20
+  fi
+  exit 1
+fi

lib/tcl/tests/eval.sx

@@ -0,0 +1,194 @@
+; Tcl-on-SX eval tests
+(define tcl-eval-pass 0)
+(define tcl-eval-fail 0)
+(define tcl-eval-failures (list))
+
+(define
+  tcl-eval-assert
+  (fn
+    (label expected actual)
+    (if
+      (equal? expected actual)
+      (set! tcl-eval-pass (+ tcl-eval-pass 1))
+      (begin
+        (set! tcl-eval-fail (+ tcl-eval-fail 1))
+        (append!
+          tcl-eval-failures
+          (str label ": expected=" (str expected) " got=" (str actual)))))))
+
+(define
+  tcl-run-eval-tests
+  (fn
+    ()
+    (set! tcl-eval-pass 0)
+    (set! tcl-eval-fail 0)
+    (set! tcl-eval-failures (list))
+    (define interp (fn () (make-default-tcl-interp)))
+    (define run (fn (src) (tcl-eval-string (interp) src)))
+    (define
+      ok
+      (fn (label actual expected) (tcl-eval-assert label expected actual)))
+    (define
+      ok?
+      (fn (label condition) (tcl-eval-assert label true condition)))
+    (tcl-eval-assert "set-result" "hello" (get (run "set x hello") :result))
+    (tcl-eval-assert
+      "set-stored"
+      "hello"
+      (tcl-var-get (run "set x hello") "x"))
+    (tcl-eval-assert
+      "var-sub"
+      "hello"
+      (tcl-var-get (run "set x hello\nset y $x") "y"))
+    (tcl-eval-assert
+      "puts"
+      "world\n"
+      (get (run "set x world\nputs $x") :output))
+    (tcl-eval-assert
+      "puts-nonewline"
+      "hi"
+      (get (run "puts -nonewline hi") :output))
+    (tcl-eval-assert "incr" "6" (tcl-var-get (run "set x 5\nincr x") "x"))
+    (tcl-eval-assert
+      "incr-delta"
+      "8"
+      (tcl-var-get (run "set x 5\nincr x 3") "x"))
+    (tcl-eval-assert
+      "incr-neg"
+      "7"
+      (tcl-var-get (run "set x 10\nincr x -3") "x"))
+    (tcl-eval-assert
+      "append"
+      "foobar"
+      (tcl-var-get (run "set x foo\nappend x bar") "x"))
+    (tcl-eval-assert
+      "append-new"
+      "hello"
+      (tcl-var-get (run "append x hello") "x"))
+    (tcl-eval-assert
+      "cmdsub-result"
+      "6"
+      (get (run "set x 5\nset y [incr x]") :result))
+    (tcl-eval-assert
+      "cmdsub-y"
+      "6"
+      (tcl-var-get (run "set x 5\nset y [incr x]") "y"))
+    (tcl-eval-assert
+      "cmdsub-x"
+      "6"
+      (tcl-var-get (run "set x 5\nset y [incr x]") "x"))
+    (tcl-eval-assert
+      "multi-cmd"
+      "second"
+      (get (run "set x first\nset x second") :result))
+    (tcl-eval-assert "semi-x" "1" (tcl-var-get (run "set x 1; set y 2") "x"))
+    (tcl-eval-assert "semi-y" "2" (tcl-var-get (run "set x 1; set y 2") "y"))
+    (tcl-eval-assert
+      "braced-nosub"
+      "$x"
+      (tcl-var-get (run "set x 42\nset y {$x}") "y"))
+    (tcl-eval-assert
+      "concat-word"
+      "foobar"
+      (tcl-var-get (run "set x foo\nset y ${x}bar") "y"))
+    (tcl-eval-assert
+      "set-get"
+      "world"
+      (get (run "set x world\nset x") :result))
+    (tcl-eval-assert
+      "puts-channel"
+      "hello\n"
+      (get (run "puts stdout hello") :output))
+    (ok "if-true" (get (run "set x 0\nif {1} {set x 1}") :result) "1")
+    (ok "if-false" (get (run "set x 0\nif {0} {set x 1}") :result) "0")
+    (ok
+      "if-else-t"
+      (tcl-var-get (run "if {1} {set x yes} else {set x no}") "x")
+      "yes")
+    (ok
+      "if-else-f"
+      (tcl-var-get (run "if {0} {set x yes} else {set x no}") "x")
+      "no")
+    (ok
+      "if-cmp"
+      (tcl-var-get
+        (run "set x 5\nif {$x > 3} {set r big} else {set r small}")
+        "r")
+      "big")
+    (ok
+      "while"
+      (tcl-var-get
+        (run "set i 0\nset s 0\nwhile {$i < 5} {incr i\nincr s $i}")
+        "s")
+      "15")
+    (ok
+      "while-break"
+      (tcl-var-get
+        (run "set i 0\nwhile {1} {incr i\nif {$i == 3} {break}}")
+        "i")
+      "3")
+    (ok
+      "for"
+      (tcl-var-get
+        (run "set s 0\nfor {set i 1} {$i <= 5} {incr i} {incr s $i}")
+        "s")
+      "15")
+    (ok
+      "foreach"
+      (tcl-var-get (run "set s 0\nforeach x {1 2 3 4 5} {incr s $x}") "s")
+      "15")
+    (ok
+      "foreach-list"
+      (get (run "set acc \"\"\nforeach w {hello world} {append acc $w}") :result)
+      "helloworld")
+    (ok
+      "lappend"
+      (tcl-var-get (run "lappend lst a\nlappend lst b\nlappend lst c") "lst")
+      "a b c")
+    (ok?
+      "unset-gone"
+      (let
+        ((i (run "set x 42\nunset x")))
+        (let
+          ((frame (get i :frame)))
+          (nil? (get (get frame :locals) "x")))))
+    (ok "eval" (tcl-var-get (run "eval {set x hello}") "x") "hello")
+    (ok "expr-add" (get (run "expr {3 + 4}") :result) "7")
+    (ok "expr-cmp" (get (run "expr {5 > 3}") :result) "1")
+    (ok
+      "break-stops"
+      (tcl-var-get (run "set x 0\nwhile {1} {set x 1\nbreak\nset x 99}") "x")
+      "1")
+    (ok
+      "continue"
+      (tcl-var-get
+        (run
+          "set s 0\nfor {set i 1} {$i <= 5} {incr i} {if {$i == 3} {continue}\nincr s $i}")
+        "s")
+      "12")
+    (ok
+      "switch"
+      (tcl-var-get
+        (run "set x foo\nswitch $x {{foo} {set r yes} {bar} {set r no}}")
+        "r")
+      "yes")
+    (ok
+      "switch-default"
+      (tcl-var-get
+        (run "set x baz\nswitch $x {{foo} {set r yes} default {set r other}}")
+        "r")
+      "other")
+    (ok
+      "nested-if"
+      (tcl-var-get
+        (run
+          "set x 5\nif {$x > 10} {set r big} elseif {$x > 3} {set r mid} else {set r small}")
+        "r")
+      "mid")
+    (dict
+      "passed"
+      tcl-eval-pass
+      "failed"
+      tcl-eval-fail
+      "failures"
+      tcl-eval-failures)))

lib/tcl/tests/parse.sx

@@ -0,0 +1,186 @@
+(define tcl-parse-pass 0)
+(define tcl-parse-fail 0)
+(define tcl-parse-failures (list))
+
+(define tcl-assert
+  (fn (label expected actual)
+    (if (= expected actual)
+      (set! tcl-parse-pass (+ tcl-parse-pass 1))
+      (begin
+        (set! tcl-parse-fail (+ tcl-parse-fail 1))
+        (append! tcl-parse-failures
+          (str label ": expected=" (str expected) " got=" (str actual)))))))
+
+(define tcl-first-cmd
+  (fn (src) (nth (tcl-tokenize src) 0)))
+
+(define tcl-cmd-words
+  (fn (src) (get (tcl-first-cmd src) :words)))
+
+(define tcl-word
+  (fn (src wi) (nth (tcl-cmd-words src) wi)))
+
+(define tcl-parts
+  (fn (src wi) (get (tcl-word src wi) :parts)))
+
+(define tcl-part
+  (fn (src wi pi) (nth (tcl-parts src wi) pi)))
+
+(define tcl-run-parse-tests
+  (fn ()
+    (set! tcl-parse-pass 0)
+    (set! tcl-parse-fail 0)
+    (set! tcl-parse-failures (list))
+
+    ; empty / whitespace-only
+    (tcl-assert "empty" 0 (len (tcl-tokenize "")))
+    (tcl-assert "ws-only" 0 (len (tcl-tokenize "   ")))
+    (tcl-assert "nl-only" 0 (len (tcl-tokenize "\n\n")))
+
+    ; single command word count
+    (tcl-assert "1word" 1 (len (tcl-cmd-words "set")))
+    (tcl-assert "3words" 3 (len (tcl-cmd-words "set x 1")))
+    (tcl-assert "4words" 4 (len (tcl-cmd-words "set a b c")))
+
+    ; word type — bare word is compound
+    (tcl-assert "bare-type" "compound" (get (tcl-word "set x 1" 0) :type))
+    (tcl-assert "bare-quoted" false (get (tcl-word "set x 1" 0) :quoted))
+    (tcl-assert "bare-part-type" "text" (get (tcl-part "set x 1" 0 0) :type))
+    (tcl-assert "bare-part-val" "set" (get (tcl-part "set x 1" 0 0) :value))
+    (tcl-assert "bare-part2-val" "x" (get (tcl-part "set x 1" 1 0) :value))
+    (tcl-assert "bare-part3-val" "1" (get (tcl-part "set x 1" 2 0) :value))
+
+    ; multiple commands
+    (tcl-assert "semi-sep" 2 (len (tcl-tokenize "set x 1; set y 2")))
+    (tcl-assert "nl-sep" 2 (len (tcl-tokenize "set x 1\nset y 2")))
+    (tcl-assert "multi-nl" 3 (len (tcl-tokenize "a\nb\nc")))
+
+    ; comments
+    (tcl-assert "comment-only" 0 (len (tcl-tokenize "# comment")))
+    (tcl-assert "comment-nl" 0 (len (tcl-tokenize "# comment\n")))
+    (tcl-assert "comment-then-cmd" 1 (len (tcl-tokenize "# comment\nset x 1")))
+    (tcl-assert "semi-then-comment" 1 (len (tcl-tokenize "set x 1; # comment")))
+
+    ; brace-quoted words
+    (tcl-assert "brace-type" "braced" (get (tcl-word "{hello}" 0) :type))
+    (tcl-assert "brace-value" "hello" (get (tcl-word "{hello}" 0) :value))
+    (tcl-assert "brace-spaces" "hello world" (get (tcl-word "{hello world}" 0) :value))
+    (tcl-assert "brace-nested" "a {b} c" (get (tcl-word "{a {b} c}" 0) :value))
+    (tcl-assert "brace-no-var-sub" "hello $x" (get (tcl-word "{hello $x}" 0) :value))
+    (tcl-assert "brace-no-cmd-sub" "[expr 1]" (get (tcl-word "{[expr 1]}" 0) :value))
+
+    ; double-quoted words
+    (tcl-assert "dq-type" "compound" (get (tcl-word "\"hello\"" 0) :type))
+    (tcl-assert "dq-quoted" true (get (tcl-word "\"hello\"" 0) :quoted))
+    (tcl-assert "dq-literal" "hello" (get (tcl-part "\"hello\"" 0 0) :value))
+
+    ; variable substitution in bare word
+    (tcl-assert "var-type" "var" (get (tcl-part "$x" 0 0) :type))
+    (tcl-assert "var-name" "x" (get (tcl-part "$x" 0 0) :name))
+    (tcl-assert "var-long" "long_name" (get (tcl-part "$long_name" 0 0) :name))
+
+    ; ${name} form
+    (tcl-assert "var-brace-type" "var" (get (tcl-part "${x}" 0 0) :type))
+    (tcl-assert "var-brace-name" "x" (get (tcl-part "${x}" 0 0) :name))
+
+    ; array variable substitution
+    (tcl-assert "arr-type" "var-arr" (get (tcl-part "$arr(key)" 0 0) :type))
+    (tcl-assert "arr-name" "arr" (get (tcl-part "$arr(key)" 0 0) :name))
+    (tcl-assert "arr-key-len" 1 (len (get (tcl-part "$arr(key)" 0 0) :key)))
+    (tcl-assert "arr-key-text" "key"
+      (get (nth (get (tcl-part "$arr(key)" 0 0) :key) 0) :value))
+
+    ; command substitution
+    (tcl-assert "cmd-type" "cmd" (get (tcl-part "[expr 1+1]" 0 0) :type))
+    (tcl-assert "cmd-src" "expr 1+1" (get (tcl-part "[expr 1+1]" 0 0) :src))
+
+    ; nested command substitution
+    (tcl-assert "cmd-nested-src" "expr [string length x]"
+      (get (tcl-part "[expr [string length x]]" 0 0) :src))
+
+    ; backslash substitution in double-quoted word
+    (let ((ps (tcl-parts "\"a\\nb\"" 0)))
+      (begin
+        (tcl-assert "bs-n-part0" "a" (get (nth ps 0) :value))
+        (tcl-assert "bs-n-part1" "\n" (get (nth ps 1) :value))
+        (tcl-assert "bs-n-part2" "b" (get (nth ps 2) :value))))
+
+    (let ((ps (tcl-parts "\"a\\tb\"" 0)))
+      (tcl-assert "bs-t-part1" "\t" (get (nth ps 1) :value)))
+
+    (let ((ps (tcl-parts "\"a\\\\b\"" 0)))
+      (tcl-assert "bs-bs-part1" "\\" (get (nth ps 1) :value)))
+
+    ; mixed word: text + var + text in double-quoted
+    (let ((ps (tcl-parts "\"hello $name!\"" 0)))
+      (begin
+        (tcl-assert "mixed-text0" "hello " (get (nth ps 0) :value))
+        (tcl-assert "mixed-var1-type" "var" (get (nth ps 1) :type))
+        (tcl-assert "mixed-var1-name" "name" (get (nth ps 1) :name))
+        (tcl-assert "mixed-text2" "!" (get (nth ps 2) :value))))
+
+    ; {*} expansion
+    (tcl-assert "expand-type" "expand" (get (tcl-word "{*}$list" 0) :type))
+
+    ; line continuation between words
+    (tcl-assert "cont-words" 3 (len (tcl-cmd-words "set x \\\n  1")))
+
+    ; continuation — third command word is correct
+    (tcl-assert "cont-word2-val" "1"
+      (get (tcl-part "set x \\\n  1" 2 0) :value))
+
+
+    ; --- parser helpers ---
+    ; tcl-parse is an alias for tcl-tokenize
+    (tcl-assert "parse-cmd-count" 1 (len (tcl-parse "set x 1")))
+    (tcl-assert "parse-2cmds" 2 (len (tcl-parse "set x 1; set y 2")))
+
+    ; tcl-cmd-len
+    (tcl-assert "cmd-len-3" 3 (tcl-cmd-len (nth (tcl-parse "set x 1") 0)))
+    (tcl-assert "cmd-len-1" 1 (tcl-cmd-len (nth (tcl-parse "puts") 0)))
+
+    ; tcl-word-simple? on braced word
+    (tcl-assert "simple-braced" true
+      (tcl-word-simple? (nth (get (nth (tcl-parse "{hello}") 0) :words) 0)))
+
+    ; tcl-word-simple? on bare word with no subs
+    (tcl-assert "simple-bare" true
+      (tcl-word-simple? (nth (get (nth (tcl-parse "hello") 0) :words) 0)))
+
+    ; tcl-word-simple? on word containing a var sub — false
+    (tcl-assert "simple-var-false" false
+      (tcl-word-simple? (nth (get (nth (tcl-parse "$x") 0) :words) 0)))
+
+    ; tcl-word-simple? on word containing a cmd sub — false
+    (tcl-assert "simple-cmd-false" false
+      (tcl-word-simple? (nth (get (nth (tcl-parse "[expr 1]") 0) :words) 0)))
+
+    ; tcl-word-literal on braced word
+    (tcl-assert "lit-braced" "hello world"
+      (tcl-word-literal (nth (get (nth (tcl-parse "{hello world}") 0) :words) 0)))
+
+    ; tcl-word-literal on bare word
+    (tcl-assert "lit-bare" "hello"
+      (tcl-word-literal (nth (get (nth (tcl-parse "hello") 0) :words) 0)))
+
+    ; tcl-word-literal on word with var sub returns nil
+    (tcl-assert "lit-var-nil" nil
+      (tcl-word-literal (nth (get (nth (tcl-parse "$x") 0) :words) 0)))
+
+    ; tcl-nth-literal
+    (tcl-assert "nth-lit-0" "set"
+      (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 0))
+    (tcl-assert "nth-lit-1" "x"
+      (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 1))
+    (tcl-assert "nth-lit-2" "1"
+      (tcl-nth-literal (nth (tcl-parse "set x 1") 0) 2))
+
+    ; tcl-nth-literal returns nil when word has subs
+    (tcl-assert "nth-lit-nil" nil
+      (tcl-nth-literal (nth (tcl-parse "set x $y") 0) 2))
+
+
+    (dict
+      "passed" tcl-parse-pass
+      "failed" tcl-parse-fail
+      "failures" tcl-parse-failures)))

lib/tcl/tokenizer.sx

@@ -0,0 +1,308 @@
+(define tcl-ws? (fn (c) (or (= c " ") (= c "\t") (= c "\r"))))
+
+(define tcl-alpha?
+  (fn (c)
+    (and
+      (not (= c nil))
+      (or (and (>= c "a") (<= c "z")) (and (>= c "A") (<= c "Z"))))))
+
+(define tcl-digit?
+  (fn (c) (and (not (= c nil)) (>= c "0") (<= c "9"))))
+
+(define tcl-ident-start?
+  (fn (c) (or (tcl-alpha? c) (= c "_"))))
+
+(define tcl-ident-char?
+  (fn (c) (or (tcl-ident-start? c) (tcl-digit? c))))
+
+(define tcl-tokenize
+  (fn (src)
+    (let ((pos 0) (src-len (len src)) (commands (list)))
+
+      (define char-at
+        (fn (off)
+          (if (< (+ pos off) src-len) (nth src (+ pos off)) nil)))
+
+      (define cur (fn () (char-at 0)))
+
+      (define advance! (fn (n) (set! pos (+ pos n))))
+
+      (define skip-ws!
+        (fn ()
+          (when (tcl-ws? (cur))
+            (begin (advance! 1) (skip-ws!)))))
+
+      (define skip-to-eol!
+        (fn ()
+          (when (and (< pos src-len) (not (= (cur) "\n")))
+            (begin (advance! 1) (skip-to-eol!)))))
+
+      (define skip-brace-content!
+        (fn (d)
+          (when (and (< pos src-len) (> d 0))
+            (cond
+              ((= (cur) "{") (begin (advance! 1) (skip-brace-content! (+ d 1))))
+              ((= (cur) "}") (begin (advance! 1) (skip-brace-content! (- d 1))))
+              (else (begin (advance! 1) (skip-brace-content! d)))))))
+
+      (define skip-dquote-content!
+        (fn ()
+          (when (and (< pos src-len) (not (= (cur) "\"")))
+            (begin
+              (when (= (cur) "\\") (advance! 1))
+              (when (< pos src-len) (advance! 1))
+              (skip-dquote-content!)))))
+
+      (define parse-bs
+        (fn ()
+          (advance! 1)
+          (let ((c (cur)))
+            (cond
+              ((= c nil)  "\\")
+              ((= c "n")  (begin (advance! 1) "\n"))
+              ((= c "t")  (begin (advance! 1) "\t"))
+              ((= c "r")  (begin (advance! 1) "\r"))
+              ((= c "\\") (begin (advance! 1) "\\"))
+              ((= c "[")  (begin (advance! 1) "["))
+              ((= c "]")  (begin (advance! 1) "]"))
+              ((= c "{")  (begin (advance! 1) "{"))
+              ((= c "}")  (begin (advance! 1) "}"))
+              ((= c "$")  (begin (advance! 1) "$"))
+              ((= c ";")  (begin (advance! 1) ";"))
+              ((= c "\"") (begin (advance! 1) "\""))
+              ((= c "'")  (begin (advance! 1) "'"))
+              ((= c " ")  (begin (advance! 1) " "))
+              ((= c "\n")
+                (begin
+                  (advance! 1)
+                  (skip-ws!)
+                  " "))
+              (else (begin (advance! 1) (str "\\" c)))))))
+
+      (define parse-cmd-sub
+        (fn ()
+          (advance! 1)
+          (let ((start pos) (depth 1))
+            (define scan!
+              (fn ()
+                (when (and (< pos src-len) (> depth 0))
+                  (cond
+                    ((= (cur) "[")
+                      (begin (set! depth (+ depth 1)) (advance! 1) (scan!)))
+                    ((= (cur) "]")
+                      (begin
+                        (set! depth (- depth 1))
+                        (when (> depth 0) (advance! 1))
+                        (scan!)))
+                    ((= (cur) "{")
+                      (begin (advance! 1) (skip-brace-content! 1) (scan!)))
+                    ((= (cur) "\"")
+                      (begin
+                        (advance! 1)
+                        (skip-dquote-content!)
+                        (when (= (cur) "\"") (advance! 1))
+                        (scan!)))
+                    ((= (cur) "\\")
+                      (begin (advance! 1) (when (< pos src-len) (advance! 1)) (scan!)))
+                    (else (begin (advance! 1) (scan!)))))))
+            (scan!)
+            (let ((src-text (slice src start pos)))
+              (begin
+                (when (= (cur) "]") (advance! 1))
+                {:type "cmd" :src src-text})))))
+
+      (define scan-name!
+        (fn ()
+          (when (and (< pos src-len) (not (= (cur) "}")))
+            (begin (advance! 1) (scan-name!)))))
+
+      (define scan-ns-name!
+        (fn ()
+          (cond
+            ((tcl-ident-char? (cur))
+              (begin (advance! 1) (scan-ns-name!)))
+            ((and (= (cur) ":") (= (char-at 1) ":"))
+              (begin (advance! 2) (scan-ns-name!)))
+            (else nil))))
+
+      (define scan-klit!
+        (fn ()
+          (when (and (< pos src-len)
+                     (not (= (cur) ")"))
+                     (not (= (cur) "$"))
+                     (not (= (cur) "["))
+                     (not (= (cur) "\\")))
+            (begin (advance! 1) (scan-klit!)))))
+
+      (define scan-key!
+        (fn (kp)
+          (when (and (< pos src-len) (not (= (cur) ")")))
+            (cond
+              ((= (cur) "$")
+                (begin (append! kp (parse-var-sub)) (scan-key! kp)))
+              ((= (cur) "[")
+                (begin (append! kp (parse-cmd-sub)) (scan-key! kp)))
+              ((= (cur) "\\")
+                (begin
+                  (append! kp {:type "text" :value (parse-bs)})
+                  (scan-key! kp)))
+              (else
+                (let ((kstart pos))
+                  (begin
+                    (scan-klit!)
+                    (append! kp {:type "text" :value (slice src kstart pos)})
+                    (scan-key! kp))))))))
+
+      (define parse-var-sub
+        (fn ()
+          (advance! 1)
+          (cond
+            ((= (cur) "{")
+              (begin
+                (advance! 1)
+                (let ((start pos))
+                  (begin
+                    (scan-name!)
+                    (let ((name (slice src start pos)))
+                      (begin
+                        (when (= (cur) "}") (advance! 1))
+                        {:type "var" :name name}))))))
+            ((tcl-ident-start? (cur))
+              (let ((start pos))
+                (begin
+                  (scan-ns-name!)
+                  (let ((name (slice src start pos)))
+                    (if (= (cur) "(")
+                      (begin
+                        (advance! 1)
+                        (let ((key-parts (list)))
+                          (begin
+                            (scan-key! key-parts)
+                            (when (= (cur) ")") (advance! 1))
+                            {:type "var-arr" :name name :key key-parts})))
+                      {:type "var" :name name})))))
+            (else {:type "text" :value "$"}))))
+
+      (define scan-lit!
+        (fn (stop?)
+          (when (and (< pos src-len)
+                     (not (stop? (cur)))
+                     (not (= (cur) "$"))
+                     (not (= (cur) "["))
+                     (not (= (cur) "\\")))
+            (begin (advance! 1) (scan-lit! stop?)))))
+
+      (define parse-word-parts!
+        (fn (parts stop?)
+          (when (and (< pos src-len) (not (stop? (cur))))
+            (cond
+              ((= (cur) "$")
+                (begin (append! parts (parse-var-sub)) (parse-word-parts! parts stop?)))
+              ((= (cur) "[")
+                (begin (append! parts (parse-cmd-sub)) (parse-word-parts! parts stop?)))
+              ((= (cur) "\\")
+                (begin
+                  (append! parts {:type "text" :value (parse-bs)})
+                  (parse-word-parts! parts stop?)))
+              (else
+                (let ((start pos))
+                  (begin
+                    (scan-lit! stop?)
+                    (when (> pos start)
+                      (append! parts {:type "text" :value (slice src start pos)}))
+                    (parse-word-parts! parts stop?))))))))
+
+      (define parse-brace-word
+        (fn ()
+          (advance! 1)
+          (let ((depth 1) (start pos))
+            (define scan!
+              (fn ()
+                (when (and (< pos src-len) (> depth 0))
+                  (cond
+                    ((= (cur) "{")
+                      (begin (set! depth (+ depth 1)) (advance! 1) (scan!)))
+                    ((= (cur) "}")
+                      (begin (set! depth (- depth 1)) (when (> depth 0) (advance! 1)) (scan!)))
+                    (else (begin (advance! 1) (scan!)))))))
+            (scan!)
+            (let ((value (slice src start pos)))
+              (begin
+                (when (= (cur) "}") (advance! 1))
+                {:type "braced" :value value})))))
+
+      (define parse-dquote-word
+        (fn ()
+          (advance! 1)
+          (let ((parts (list)))
+            (begin
+              (parse-word-parts! parts (fn (c) (or (= c "\"") (= c nil))))
+              (when (= (cur) "\"") (advance! 1))
+              {:type "compound" :parts parts :quoted true}))))
+
+      (define parse-bare-word
+        (fn ()
+          (let ((parts (list)))
+            (begin
+              (parse-word-parts!
+                parts
+                (fn (c) (or (tcl-ws? c) (= c "\n") (= c ";") (= c nil))))
+              {:type "compound" :parts parts :quoted false}))))
+
+      (define parse-word-no-expand
+        (fn ()
+          (cond
+            ((= (cur) "{") (parse-brace-word))
+            ((= (cur) "\"") (parse-dquote-word))
+            (else (parse-bare-word)))))
+
+      (define parse-word
+        (fn ()
+          (cond
+            ((and (= (cur) "{") (= (char-at 1) "*") (= (char-at 2) "}"))
+              (begin
+                (advance! 3)
+                {:type "expand" :word (parse-word-no-expand)}))
+            ((= (cur) "{") (parse-brace-word))
+            ((= (cur) "\"") (parse-dquote-word))
+            (else (parse-bare-word)))))
+
+      (define parse-words!
+        (fn (words)
+          (skip-ws!)
+          (cond
+            ((or (= (cur) nil) (= (cur) "\n") (= (cur) ";")) nil)
+            ((and (= (cur) "\\") (= (char-at 1) "\n"))
+              (begin (advance! 2) (skip-ws!) (parse-words! words)))
+            (else
+              (begin
+                (append! words (parse-word))
+                (parse-words! words))))))
+
+      (define skip-seps!
+        (fn ()
+          (when (< pos src-len)
+            (cond
+              ((or (tcl-ws? (cur)) (= (cur) "\n") (= (cur) ";"))
+                (begin (advance! 1) (skip-seps!)))
+              ((and (= (cur) "\\") (= (char-at 1) "\n"))
+                (begin (advance! 2) (skip-seps!)))
+              (else nil)))))
+
+      (define parse-all!
+        (fn ()
+          (skip-seps!)
+          (when (< pos src-len)
+            (cond
+              ((= (cur) "#")
+                (begin (skip-to-eol!) (parse-all!)))
+              (else
+                (let ((words (list)))
+                  (begin
+                    (parse-words! words)
+                    (when (> (len words) 0)
+                      (append! commands {:type "command" :words words}))
+                    (parse-all!))))))))
+
+      (parse-all!)
+      commands)))

plans/apl-on-sx.md

@@ -48,19 +48,19 @@ Core mapping:
 ## Roadmap
 
 ### Phase 1 — tokenizer + parser
-- [x] Tokenizer: Unicode glyphs (the full APL set: `+ - × ÷ * ⍟ ⌈ ⌊ | ! ? ○ ~ < ≤ = ≥ > ≠ ∊ ∧ ∨ ⍱ ⍲ , ⍪ ⍴ ⌽ ⊖ ⍉ ↑ ↓ ⊂ ⊃ ⊆ ∪ ∩ ⍳ ⍸ ⌷ ⍋ ⍒ ⊥ ⊤ ⊣ ⊢ ⍎ ⍕ ⍝`), operators (`/ \ ¨ ⍨ ∘ . ⍣ ⍤ ⍥ @`), numbers (`¯` for negative, `1E2`, `1J2` complex deferred), characters (`'a'`, `''` escape), strands (juxtaposition of literals: `1 2 3`), names, comments `⍝ …`
+- [ ] Tokenizer: Unicode glyphs (the full APL set: `+ - × ÷ * ⍟ ⌈ ⌊ | ! ? ○ ~ < ≤ = ≥ > ≠ ∊ ∧ ∨ ⍱ ⍲ , ⍪ ⍴ ⌽ ⊖ ⍉ ↑ ↓ ⊂ ⊃ ⊆ ∪ ∩ ⍳ ⍸ ⌷ ⍋ ⍒ ⊥ ⊤ ⊣ ⊢ ⍎ ⍕ ⍝`), operators (`/ \ ¨ ⍨ ∘ . ⍣ ⍤ ⍥ @`), numbers (`¯` for negative, `1E2`, `1J2` complex deferred), characters (`'a'`, `''` escape), strands (juxtaposition of literals: `1 2 3`), names, comments `⍝ …`
-- [x] Parser: right-to-left; classify each token as function, operator, value, or name; resolve valence positionally; dfn `{…}` body, tradfn `∇` header, guards `:`; outer product `∘.f`, inner product `f.g`, derived fns `f/ f¨ f⍨ f⍣n`
+- [ ] Parser: right-to-left; classify each token as function, operator, value, or name; resolve valence positionally; dfn `{…}` body, tradfn `∇` header, guards `:`, control words `:If :While :For …` (Dyalog-style)
-- [x] Unit tests in `lib/apl/tests/parse.sx`
+- [ ] Unit tests in `lib/apl/tests/parse.sx`
 
 ### Phase 2 — array model + scalar primitives
-- [x] Array constructor: `make-array shape ravel`, `scalar v`, `vector v…`, `enclose`/`disclose`
+- [ ] Array constructor: `make-array shape ravel`, `scalar v`, `vector v…`, `enclose`/`disclose`
-- [x] Shape arithmetic: `⍴` (shape), `,` (ravel), `≢` (tally / first-axis-length), `≡` (depth)
+- [ ] Shape arithmetic: `⍴` (shape), `,` (ravel), `≢` (tally / first-axis-length), `≡` (depth)
-- [x] Scalar arithmetic primitives broadcast: `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`
+- [ ] Scalar arithmetic primitives broadcast: `+ - × ÷ ⌈ ⌊ * ⍟ | ! ○`
-- [x] Scalar comparison primitives: `< ≤ = ≥ > ≠`
+- [ ] Scalar comparison primitives: `< ≤ = ≥ > ≠`
-- [x] Scalar logical: `~ ∧ ∨ ⍱ ⍲`
+- [ ] Scalar logical: `~ ∧ ∨ ⍱ ⍲`
-- [x] Index generator: `⍳n` (vector 1..n or 0..n-1 depending on `⎕IO`)
+- [ ] Index generator: `⍳n` (vector 1..n or 0..n-1 depending on `⎕IO`)
-- [x] `⎕IO` = 1 default (Dyalog convention)
+- [ ] `⎕IO` = 1 default (Dyalog convention)
-- [x] 40+ tests in `lib/apl/tests/scalar.sx`
+- [ ] 40+ tests in `lib/apl/tests/scalar.sx`
 
 ### Phase 3 — structural primitives + indexing
 - [ ] Reshape `⍴`, ravel `,`, transpose `⍉` (full + dyadic axis spec)
@@ -108,9 +108,7 @@ Core mapping:
 
 _Newest first._
 
-- 2026-04-26: Phase 2 complete — array model + 7 scalar primitive groups; 82/82 tests; lib/apl/runtime.sx + lib/apl/tests/scalar.sx
+- _(none yet)_
-- 2026-04-26: parser (Phase 1 step 2) — 44/44 parser tests green (90/90 total); right-to-left segment algorithm; derived fns, outer/inner product, dfns with guards, strand handling; `lib/apl/parser.sx` + `lib/apl/tests/parse.sx`
-- 2026-04-25: tokenizer (Phase 1 step 1) — 46/46 tests green; Unicode-aware starts-with? scanner for multi-byte APL glyphs; `lib/apl/tokenizer.sx` + `lib/apl/tests/parse.sx`
 
 ## Blockers
 

plans/tcl-on-sx.md

@@ -50,7 +50,7 @@ Core mapping:
 ## Roadmap
 
 ### Phase 1 — tokenizer + parser (the Dodekalogue)
-- [ ] Tokenizer applying the 12 rules:
+- [x] Tokenizer applying the 12 rules:
   1. Commands separated by `;` or newlines
   2. Words separated by whitespace within a command
   3. Double-quoted words: `\` escapes + `[…]` + `${…}` + `$var` substitution
@@ -63,12 +63,12 @@ Core mapping:
   10. Order of substitution is left-to-right, single-pass
   11. Substitutions don't recurse — substituted text is not re-parsed
   12. The result of any substitution is the value, not a new script
-- [ ] Parser: script = list of commands; command = list of words; word = literal string + list of substitutions
+- [x] Parser: script = list of commands; command = list of words; word = literal string + list of substitutions
-- [ ] Unit tests in `lib/tcl/tests/parse.sx`
+- [x] Unit tests in `lib/tcl/tests/parse.sx`
 
 ### Phase 2 — sequential eval + core commands
-- [ ] `tcl-eval-script`: walk command list, dispatch each first-word into command table
+- [x] `tcl-eval-script`: walk command list, dispatch each first-word into command table
-- [ ] Core commands: `set`, `unset`, `incr`, `append`, `lappend`, `puts`, `gets`, `expr`, `if`, `while`, `for`, `foreach`, `switch`, `break`, `continue`, `return`, `error`, `eval`, `subst`, `format`, `scan`
+- [x] Core commands: `set`, `unset`, `incr`, `append`, `lappend`, `puts`, `gets`, `expr`, `if`, `while`, `for`, `foreach`, `switch`, `break`, `continue`, `return`, `error`, `eval`, `subst`, `format`, `scan`
 - [ ] `expr` is its own mini-language — operator precedence, function calls (`sin`, `sqrt`, `pow`, `abs`, `int`, `double`), variable substitution, command substitution
 - [ ] String commands: `string length`, `string index`, `string range`, `string compare`, `string match`, `string toupper`, `string tolower`, `string trim`, `string map`, `string repeat`, `string first`, `string last`, `string is`, `string cat`
 - [ ] List commands: `list`, `lindex`, `lrange`, `llength`, `lreverse`, `lsearch`, `lsort`, `lsort -integer/-real/-dictionary`, `lreplace`, `linsert`, `concat`, `split`, `join`
@@ -120,7 +120,10 @@ Core mapping:
 
 _Newest first._
 
-- _(none yet)_
+- 2026-04-26: Phase 2 core commands — if/while/for/foreach/switch/break/continue/return/error/unset/lappend/eval/expr + :code control flow, 107 tests green (67 parse + 40 eval)
+- 2026-04-26: Phase 2 eval engine — `lib/tcl/runtime.sx`, tcl-eval-script + set/puts/incr/append, 87 tests green (67 parse + 20 eval)
+- 2026-04-25: Phase 1 parser — `lib/tcl/parser.sx`, word-simple?/word-literal helpers, 67 tests green, commit 6ee05259
+- 2026-04-25: Phase 1 tokenizer (Dodekalogue) — `lib/tcl/tokenizer.sx`, 52 tests green, commit 666e29d5
 
 ## Blockers