; Tcl-on-SX runtime evaluator
; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output}
; Requires lib/fiber.sx to be loaded first (provides make-fiber, fiber-resume, fiber-done?)

(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 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {} :current-ns "::" :coro-yield-fn nil}))

(define
  tcl-register
  (fn
    (interp name f)
    (assoc interp :commands (assoc (get interp :commands) name f))))

; --- upvar alias helpers ---

(define upvar-alias? (fn (v) (and (dict? v) (not (nil? (get v :upvar-level))))))

; take first n elements of a list
(define
  take-n
  (fn
    (lst n)
    (if
      (or (<= n 0) (= 0 (len lst)))
      (list)
      (append (list (first lst)) (take-n (rest lst) (- n 1))))))

; replace element at index i in list with val (0-based)
(define
  replace-at
  (fn
    (lst i val)
    (let
      ((go
        (fn
          (remaining j acc)
          (if
            (= 0 (len remaining))
            acc
            (go
              (rest remaining)
              (+ j 1)
              (append acc (list (if (= j i) val (first remaining)))))))))
      (go lst 0 (list)))))

; build full-stack = frame-stack + [current-frame]
(define
  tcl-full-stack
  (fn (interp)
    (append (get interp :frame-stack) (list (get interp :frame)))))

; get target frame at absolute level from full-stack
(define
  tcl-frame-nth
  (fn (full-stack level)
    (nth full-stack level)))

(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"))
        (if
          (upvar-alias? val)
          ; follow alias to target frame
          (let
            ((target-level (get val :upvar-level))
              (target-name (get val :upvar-name)))
            (let
              ((full-stack (tcl-full-stack interp)))
              (let
                ((target-frame (tcl-frame-nth full-stack target-level)))
                (let
                  ((target-val (frame-lookup target-frame target-name)))
                  (if
                    (nil? target-val)
                    (error (str "can't read \"" name "\": no such variable"))
                    target-val)))))
          val)))))

(define
  tcl-var-set
  (fn
    (interp name val)
    (let
      ((cur-val (get (get (get interp :frame) :locals) name)))
      (if
        (and (not (nil? cur-val)) (upvar-alias? cur-val))
        ; set in target frame
        (let
          ((target-level (get cur-val :upvar-level))
            (target-name (get cur-val :upvar-name)))
          (let
            ((full-stack (tcl-full-stack interp)))
            (let
              ((target-frame (tcl-frame-nth full-stack target-level)))
              (let
                ((updated-target (frame-set-top target-frame target-name val)))
                (let
                  ((new-full-stack (replace-at full-stack target-level updated-target)))
                  (let
                    ((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1)))
                      (new-current (nth new-full-stack (- (len new-full-stack) 1))))
                    (assoc interp :frame new-current :frame-stack new-frame-stack)))))))
        ; normal set in current frame top
        (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)))

; --- proc call ---

; Bind proc parameters: returns updated frame
(define
  tcl-bind-params
  (fn
    (frame params call-args)
    (if
      (= 0 (len params))
      frame
      (let
        ((pname (first params)) (rest-ps (rest params)))
        (if
          (equal? pname "args")
          ; rest param: collect remaining call-args as list string
          (frame-set-top frame "args" (tcl-list-build call-args))
          (if
            (= 0 (len call-args))
            (error (str "wrong # args: no value for parameter \"" pname "\""))
            (tcl-bind-params
              (frame-set-top frame pname (first call-args))
              rest-ps
              (rest call-args))))))))

(define
  tcl-call-proc
  (fn
    (interp proc-name proc-def call-args)
    (let
      ((param-spec (get proc-def :args))
        (body (get proc-def :body)))
      (let
        ((params (if (equal? param-spec "") (list) (tcl-list-split param-spec))))
        (let
          ((caller-stack-len (len (get interp :frame-stack)))
            (new-frame (make-frame (+ (len (get interp :frame-stack)) 1) nil)))
          (let
            ((bound-frame (tcl-bind-params new-frame params call-args)))
            (let
              ((proc-ns (let ((ns (get proc-def :ns))) (if (nil? ns) (get interp :current-ns) ns))))
              (let
              ((proc-interp
                (assoc interp
                  :frame bound-frame
                  :frame-stack (append (get interp :frame-stack) (list (get interp :frame)))
                  :output ""
                  :result ""
                  :code 0
                  :current-ns proc-ns))
                (caller-output (get interp :output)))
              (let
                ((result-interp (tcl-eval-string proc-interp body)))
                (let
                  ((code (get result-interp :code))
                    (result-val (get result-interp :result))
                    (proc-output (get result-interp :output)))
                  (let
                    ; result-stack = [updated-frame-0..updated-caller-frame]
                    ; recover updated caller frame and below-caller frames
                    ((result-stack (get result-interp :frame-stack)))
                    (let
                      ((updated-below (take-n result-stack caller-stack-len))
                        (updated-caller
                          (if
                            (> (len result-stack) caller-stack-len)
                            (nth result-stack caller-stack-len)
                            (get interp :frame))))
                      (assoc interp
                        :frame updated-caller
                        :frame-stack updated-below
                        :result result-val
                        :output (str caller-output proc-output)
                        :code (if (= code 2) 0 code)
                        :commands (get result-interp :commands))))))))))))))

(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)
                (let
                  ((proc-entry (tcl-proc-lookup cur-interp cmd-name)))
                  (if
                    (nil? proc-entry)
                    (error (str "unknown command: \"" cmd-name "\""))
                    (tcl-call-proc cur-interp (get proc-entry :name) (get proc-entry :def) cmd-args)))
                (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) "" (tcl-var-get interp name)))))
        (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-digit?
  (fn
    (c)
    (contains? (list "0" "1" "2" "3" "4" "5" "6" "7" "8" "9") c)))

(define
  tcl-expr-alpha?
  (fn
    (c)
    (contains?
      (list
        "a" "b" "c" "d" "e" "f" "g" "h" "i" "j" "k" "l" "m"
        "n" "o" "p" "q" "r" "s" "t" "u" "v" "w" "x" "y" "z"
        "A" "B" "C" "D" "E" "F" "G" "H" "I" "J" "K" "L" "M"
        "N" "O" "P" "Q" "R" "S" "T" "U" "V" "W" "X" "Y" "Z"
        "_")
      c)))

(define
  tcl-expr-op-char?
  (fn
    (c)
    (contains?
      (list "+" "-" "*" "/" "%" "!" "~" "&" "|" "^" "<" ">" "=")
      c)))

(define
  tcl-expr-ws?
  (fn (c) (or (equal? c " ") (equal? c "\t") (equal? c "\n") (equal? c "\r"))))

(define
  tcl-pow
  (fn
    (base exp)
    (if
      (= exp 0)
      1
      (* base (tcl-pow base (- exp 1))))))

(define
  tcl-num-float?
  (fn
    (s)
    (let
      loop
      ((i 0))
      (cond
        ((>= i (len s)) false)
        ((or (equal? (nth s i) ".") (equal? (nth s i) "e") (equal? (nth s i) "E"))
          true)
        (else (loop (+ i 1)))))))

(define
  tcl-parse-num
  (fn (s) (if (tcl-num-float? s) (parse-float s) (parse-int s))))

(define
  tcl-isqrt
  (fn
    (n)
    (if
      (<= n 0)
      0
      (let
        ((go (fn (x) (let ((x2 (/ (+ x (/ n x)) 2))) (if (>= x2 x) x (go x2))))))
        (go n)))))

(define
  tcl-apply-func
  (fn
    (name args)
    (let
      ((a0 (if (> (len args) 0) (parse-float (first args)) 0))
        (a1 (if (> (len args) 1) (parse-float (nth args 1)) 0)))
      (cond
        ((equal? name "abs") (str (if (< a0 0) (- 0 a0) a0)))
        ((equal? name "int") (str (truncate a0)))
        ((equal? name "double") (str a0))
        ((equal? name "round") (str (round a0)))
        ((equal? name "floor") (str (floor a0)))
        ((equal? name "ceil") (str (ceil a0)))
        ((equal? name "sqrt") (str (sqrt a0)))
        ((equal? name "pow") (str (pow a0 a1)))
        ((equal? name "max") (str (if (>= a0 a1) a0 a1)))
        ((equal? name "min") (str (if (<= a0 a1) a0 a1)))
        ((equal? name "sin") (str (sin a0)))
        ((equal? name "cos") (str (cos a0)))
        ((equal? name "tan") (str (tan a0)))
        ((equal? name "atan") (str (atan a0)))
        ((equal? name "atan2") (str (atan2 a0 a1)))
        ((equal? name "exp") (str (exp a0)))
        ((equal? name "log") (str (log a0)))
        (else (error (str "expr: unknown function: " name)))))))

(define
  tcl-apply-binop
  (fn
    (op l r)
    (let
      ((fl (tcl-num-float? l))
        (fr (tcl-num-float? r))
        (nl (tcl-parse-num l))
        (nr (tcl-parse-num r)))
      (cond
        ((equal? op "+") (str (+ nl nr)))
        ((equal? op "-") (str (- nl nr)))
        ((equal? op "*") (str (* nl nr)))
        ((equal? op "/")
          (if (or fl fr) (str (/ nl nr)) (str (truncate (/ nl nr)))))
        ((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 (< nl nr) "1" "0"))
        ((equal? op ">") (if (> nl nr) "1" "0"))
        ((equal? op "<=") (if (<= nl nr) "1" "0"))
        ((equal? op ">=") (if (>= nl nr) "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"))
        ((equal? op "**") (str (pow nl nr)))
        (else (error (str "expr: unknown op: " op)))))))

(define
  tcl-expr-tokenize
  (fn
    (s)
    (let
      ((chars (split s "")) (n (len (split s ""))))
      (let
        ((go (fn (i acc cur mode) (if (>= i n) (if (> (len cur) 0) (append acc (list cur)) acc) (let ((c (nth chars i))) (cond ((tcl-expr-ws? c) (if (> (len cur) 0) (go (+ i 1) (append acc (list cur)) "" "none") (go (+ i 1) acc "" "none"))) ((or (equal? c "(") (equal? c ")") (equal? c ",")) (let ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) (go (+ i 1) (append acc2 (list c)) "" "none"))) ((equal? c "\"") (let ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) (let ((read-str (fn (j s-acc) (if (>= j n) {:tok s-acc :next j} (let ((sc (nth chars j))) (if (equal? sc "\"") {:tok s-acc :next (+ j 1)} (read-str (+ j 1) (str s-acc sc)))))))) (let ((sr (read-str (+ i 1) ""))) (go (get sr :next) (append acc2 (list (get sr :tok))) "" "none"))))) ((tcl-expr-op-char? c) (let ((acc2 (if (and (> (len cur) 0) (not (equal? mode "op"))) (append acc (list cur)) acc)) (cur2 (if (and (> (len cur) 0) (not (equal? mode "op"))) "" cur))) (let ((next-c (if (< (+ i 1) n) (nth chars (+ i 1)) ""))) (let ((two (str c next-c))) (if (contains? (list "**" "==" "!=" "<=" ">=" "&&" "||") two) (let ((acc3 (if (> (len cur2) 0) (append acc2 (list cur2)) acc2))) (go (+ i 2) (append acc3 (list two)) "" "none")) (let ((acc3 (if (> (len cur2) 0) (append acc2 (list cur2)) acc2))) (go (+ i 1) (append acc3 (list c)) "" "none"))))))) ((tcl-expr-digit? c) (if (equal? mode "ident") (go (+ i 1) acc (str cur c) "ident") (if (or (equal? mode "num") (equal? mode "none") (equal? mode "")) (go (+ i 1) acc (str cur c) "num") (let ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) (go (+ i 1) acc2 c "num"))))) ((equal? c ".") (go (+ i 1) acc (str cur c) "num")) ((tcl-expr-alpha? c) (if (or (equal? mode "ident") (equal? mode "none") (equal? mode "")) (go (+ i 1) acc (str cur c) "ident") (let ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) (go (+ i 1) acc2 c "ident")))) (else (let ((acc2 (if (> (len cur) 0) (append acc (list cur)) acc))) (go (+ i 1) (append acc2 (list c)) "" "none")))))))))
        (go 0 (list) "" "none")))))

(define
  tcl-expr-parse-args-rest
  (fn
    (tokens acc)
    (if
      (or (= 0 (len tokens)) (equal? (first tokens) ")"))
      {:args acc :tokens tokens}
      (if
        (equal? (first tokens) ",")
        (let
          ((r (tcl-expr-parse-or (rest tokens))))
          (tcl-expr-parse-args-rest
            (get r :tokens)
            (append acc (list (get r :value)))))
        {:args acc :tokens tokens}))))

(define
  tcl-expr-parse-args
  (fn
    (tokens)
    (if
      (or (= 0 (len tokens)) (equal? (first tokens) ")"))
      {:args (list) :tokens tokens}
      (let
        ((r (tcl-expr-parse-or tokens)))
        (tcl-expr-parse-args-rest (get r :tokens) (list (get r :value)))))))

(define
  tcl-expr-parse-primary
  (fn
    (tokens)
    (if
      (= 0 (len tokens))
      (error "expr: unexpected end of expression")
      (let
        ((tok (first tokens)) (rest-toks (rest tokens)))
        (cond
          ((equal? tok "(")
            (let
              ((inner (tcl-expr-parse-or rest-toks)))
              (let
                ((after (get inner :tokens)))
                (if
                  (and
                    (> (len after) 0)
                    (equal? (first after) ")"))
                  {:tokens (rest after) :value (get inner :value)}
                  (error "expr: missing closing paren")))))
          ((and (> (len rest-toks) 0) (equal? (first rest-toks) "("))
            (let
              ((args-r (tcl-expr-parse-args (rest rest-toks))))
              (let
                ((after-args (get args-r :tokens)))
                (if
                  (and
                    (> (len after-args) 0)
                    (equal? (first after-args) ")"))
                  {:tokens (rest after-args) :value (tcl-apply-func tok (get args-r :args))}
                  (error (str "expr: missing ) after function call " tok))))))
          (else {:tokens rest-toks :value tok}))))))

(define
  tcl-expr-parse-unary
  (fn
    (tokens)
    (if
      (= 0 (len tokens))
      (error "expr: unexpected end in unary")
      (let
        ((tok (first tokens)))
        (cond
          ((equal? tok "!")
            (let ((r (tcl-expr-parse-unary (rest tokens)))) {:tokens (get r :tokens) :value (if (tcl-false? (get r :value)) "1" "0")}))
          ((equal? tok "-")
            (let ((r (tcl-expr-parse-unary (rest tokens)))) {:tokens (get r :tokens) :value (str (- 0 (tcl-parse-num (get r :value))))}))
          ((equal? tok "+") (tcl-expr-parse-unary (rest tokens)))
          (else (tcl-expr-parse-primary tokens)))))))

(define
  tcl-expr-parse-power
  (fn
    (tokens)
    (let
      ((base-r (tcl-expr-parse-unary tokens)))
      (let
        ((base-val (get base-r :value)) (rest-toks (get base-r :tokens)))
        (if
          (and
            (> (len rest-toks) 0)
            (equal? (first rest-toks) "**"))
          (let
            ((exp-r (tcl-expr-parse-power (rest rest-toks))))
            {:tokens (get exp-r :tokens) :value (str (pow (tcl-parse-num base-val) (tcl-parse-num (get exp-r :value))))})
          {:tokens rest-toks :value base-val})))))

(define
  tcl-expr-parse-multiplicative-rest
  (fn
    (tokens left)
    (if
      (or
        (= 0 (len tokens))
        (not (contains? (list "*" "/" "%") (first tokens))))
      {:tokens tokens :value left}
      (let
        ((op (first tokens)))
        (let
          ((r (tcl-expr-parse-power (rest tokens))))
          (tcl-expr-parse-multiplicative-rest
            (get r :tokens)
            (tcl-apply-binop op left (get r :value))))))))

(define
  tcl-expr-parse-multiplicative
  (fn
    (tokens)
    (let
      ((r (tcl-expr-parse-power tokens)))
      (tcl-expr-parse-multiplicative-rest (get r :tokens) (get r :value)))))

(define
  tcl-expr-parse-additive-rest
  (fn
    (tokens left)
    (if
      (or
        (= 0 (len tokens))
        (not (contains? (list "+" "-") (first tokens))))
      {:tokens tokens :value left}
      (let
        ((op (first tokens)))
        (let
          ((r (tcl-expr-parse-multiplicative (rest tokens))))
          (tcl-expr-parse-additive-rest
            (get r :tokens)
            (tcl-apply-binop op left (get r :value))))))))

(define
  tcl-expr-parse-additive
  (fn
    (tokens)
    (let
      ((r (tcl-expr-parse-multiplicative tokens)))
      (tcl-expr-parse-additive-rest (get r :tokens) (get r :value)))))

(define
  tcl-expr-parse-relational-rest
  (fn
    (tokens left)
    (if
      (or
        (= 0 (len tokens))
        (not (contains? (list "<" ">" "<=" ">=") (first tokens))))
      {:tokens tokens :value left}
      (let
        ((op (first tokens)))
        (let
          ((r (tcl-expr-parse-additive (rest tokens))))
          (tcl-expr-parse-relational-rest
            (get r :tokens)
            (tcl-apply-binop op left (get r :value))))))))

(define
  tcl-expr-parse-relational
  (fn
    (tokens)
    (let
      ((r (tcl-expr-parse-additive tokens)))
      (tcl-expr-parse-relational-rest (get r :tokens) (get r :value)))))

(define
  tcl-expr-parse-equality-rest
  (fn
    (tokens left)
    (if
      (or
        (= 0 (len tokens))
        (not (contains? (list "==" "!=") (first tokens))))
      {:tokens tokens :value left}
      (let
        ((op (first tokens)))
        (let
          ((r (tcl-expr-parse-relational (rest tokens))))
          (tcl-expr-parse-equality-rest
            (get r :tokens)
            (tcl-apply-binop op left (get r :value))))))))

(define
  tcl-expr-parse-equality
  (fn
    (tokens)
    (let
      ((r (tcl-expr-parse-relational tokens)))
      (tcl-expr-parse-equality-rest (get r :tokens) (get r :value)))))

(define
  tcl-expr-parse-and-rest
  (fn
    (tokens left)
    (if
      (or (= 0 (len tokens)) (not (equal? (first tokens) "&&")))
      {:tokens tokens :value left}
      (let
        ((r (tcl-expr-parse-equality (rest tokens))))
        (tcl-expr-parse-and-rest
          (get r :tokens)
          (tcl-apply-binop "&&" left (get r :value)))))))

(define
  tcl-expr-parse-and
  (fn
    (tokens)
    (let
      ((r (tcl-expr-parse-equality tokens)))
      (tcl-expr-parse-and-rest (get r :tokens) (get r :value)))))

(define
  tcl-expr-parse-or-rest
  (fn
    (tokens left)
    (if
      (or (= 0 (len tokens)) (not (equal? (first tokens) "||")))
      {:tokens tokens :value left}
      (let
        ((r (tcl-expr-parse-and (rest tokens))))
        (tcl-expr-parse-or-rest
          (get r :tokens)
          (tcl-apply-binop "||" left (get r :value)))))))

(define
  tcl-expr-parse-or
  (fn
    (tokens)
    (let
      ((r (tcl-expr-parse-and tokens)))
      (tcl-expr-parse-or-rest (get r :tokens) (get r :value)))))

(define
  tcl-expr-parse
  (fn
    (tokens)
    (if
      (= 0 (len tokens))
      "0"
      (get (tcl-expr-parse-or tokens) :value))))

(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)))
          (let
            ((flat (join " " (get wr :values))))
            (let ((tokens (tcl-expr-tokenize flat))) {:result (tcl-expr-parse tokens) :interp (get wr :interp)})))))))

; Parse -code name/number to integer
(define tcl-cmd-break (fn (interp args) (assoc interp :code 3)))

; Parse return options from args list
; Returns {:code N :result val :errorinfo str :errorcode str}
(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4)))

(define
  tcl-return-code-num
  (fn
    (s)
    (cond
      ((equal? s "ok") 0)
      ((equal? s "error") 1)
      ((equal? s "return") 2)
      ((equal? s "break") 3)
      ((equal? s "continue") 4)
      (else (parse-int s)))))

(define
  tcl-parse-return-opts
  (fn
    (args)
    (let
      ((go (fn (remaining code ei ec) (if (or (= 0 (len remaining)) (not (equal? (substring (first remaining) 0 1) "-"))) {:result (if (> (len remaining) 0) (first remaining) "") :errorinfo ei :errorcode ec :code code} (let ((flag (first remaining)) (rest1 (rest remaining))) (cond ((equal? flag "-code") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode ec :code code} (go (rest rest1) (tcl-return-code-num (first rest1)) ei ec))) ((equal? flag "-errorinfo") (if (= 0 (len rest1)) {:result "" :errorinfo "" :errorcode ec :code code} (go (rest rest1) code (first rest1) ec))) ((equal? flag "-errorcode") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode "" :code code} (go (rest rest1) code ei (first rest1)))) ((equal? flag "-level") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode ec :code code} (go (rest rest1) code ei ec))) (else {:result flag :errorinfo ei :errorcode ec :code code})))))))
      (go args 2 "" ""))))

; --- catch command ---
; catch script ?resultVar? ?optionsVar?
(define
  tcl-cmd-return
  (fn
    (interp args)
    (let
      ((opts (tcl-parse-return-opts args)))
      (assoc
        interp
        :result (get opts :result)
        :code (get opts :code)
        :errorinfo (get opts :errorinfo)
        :errorcode (get opts :errorcode)))))

; --- throw command ---
; throw type message
(define
  tcl-cmd-error
  (fn
    (interp args)
    (let
      ((msg (if (> (len args) 0) (first args) "error"))
        (ei (if (> (len args) 1) (nth args 1) ""))
        (ec (if (> (len args) 2) (nth args 2) "")))
      (assoc interp :result msg :code 1 :errorinfo ei :errorcode ec))))

; --- try command ---
; try script ?on code var body? ... ?finally body?
(define
  tcl-cmd-catch
  (fn
    (interp args)
    (let
      ((script (first args))
        (result-var
          (if (> (len args) 1) (nth args 1) nil))
        (opts-var (if (> (len args) 2) (nth args 2) nil)))
      (let
        ((sub-interp (assoc interp :code 0 :result "" :output ""))
          (caller-output (get interp :output)))
        (let
          ((result-interp (tcl-eval-string sub-interp script)))
          (let
            ((rc (get result-interp :code))
              (rv (get result-interp :result))
              (rei (get result-interp :errorinfo))
              (rec (get result-interp :errorcode))
              (sub-output (get result-interp :output)))
            (let
              ((merged (assoc result-interp :code 0 :result (str rc) :output (str caller-output sub-output))))
              (let
                ((after-rv (if (nil? result-var) merged (tcl-var-set merged result-var rv))))
                (let
                  ((opts-str (str "-code " rc " -errorinfo " (if (equal? rei "") "{}" rei) " -errorcode " (if (equal? rec "") "{}" rec))))
                  (let
                    ((after-opts (if (nil? opts-var) after-rv (tcl-var-set after-rv opts-var opts-str))))
                    (assoc after-opts :result (str rc))))))))))))

(define
  tcl-cmd-throw
  (fn
    (interp args)
    (let
      ((ec (if (> (len args) 0) (first args) ""))
        (msg (if (> (len args) 1) (nth args 1) "")))
      (assoc interp :result msg :code 1 :errorcode ec :errorinfo ""))))

(define
  tcl-try-code-matches?
  (fn
    (code-str rc)
    (cond
      ((equal? code-str "ok") (= rc 0))
      ((equal? code-str "error") (= rc 1))
      ((equal? code-str "return") (= rc 2))
      ((equal? code-str "break") (= rc 3))
      ((equal? code-str "continue") (= rc 4))
      (else (= rc (parse-int code-str))))))

(define
  tcl-cmd-try
  (fn
    (interp args)
    (let
      ((script (first args)) (rest-args (rest args)))
      (let
        ((parse-clauses (fn (remaining acc) (if (= 0 (len remaining)) acc (let ((kw (first remaining))) (cond ((equal? kw "on") (if (< (len remaining) 4) acc (parse-clauses (slice remaining 4 (len remaining)) (append acc (list {:body (nth remaining 3) :code (nth remaining 1) :type "on" :var (nth remaining 2)}))))) ((equal? kw "finally") (if (< (len remaining) 2) acc (parse-clauses (slice remaining 2 (len remaining)) (append acc (list {:body (nth remaining 1) :type "finally"}))))) (else acc))))))
          (clauses (parse-clauses rest-args (list))))
        (let
          ((sub-interp (assoc interp :code 0 :result ""))
            (caller-output (get interp :output)))
          (let
            ((result-interp (tcl-eval-string sub-interp script)))
            (let
              ((rc (get result-interp :code))
                (rv (get result-interp :result))
                (sub-output (get result-interp :output)))
              (let
                ((find-clause (fn (cs) (if (= 0 (len cs)) nil (let ((c (first cs))) (if (and (equal? (get c :type) "on") (tcl-try-code-matches? (get c :code) rc)) c (find-clause (rest cs)))))))
                  (matched (find-clause clauses))
                  (finally-clause
                    (reduce
                      (fn
                        (acc c)
                        (if (equal? (get c :type) "finally") c acc))
                      nil
                      clauses)))
                (let
                  ((after-handler (if (nil? matched) (assoc result-interp :output (str caller-output sub-output)) (let ((handler-interp (assoc result-interp :code 0 :output (str caller-output sub-output)))) (let ((bound-interp (if (equal? (get matched :var) "") handler-interp (tcl-var-set handler-interp (get matched :var) rv)))) (tcl-eval-string bound-interp (get matched :body)))))))
                  (let
                    ((final-result (if (nil? finally-clause) after-handler (let ((fi (tcl-eval-string (assoc after-handler :code 0) (get finally-clause :body)))) (if (= (get fi :code) 0) (assoc fi :code (get after-handler :code) :result (get after-handler :result)) fi)))))
                    final-result))))))))))

(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) "" (tcl-var-get interp name)))))
        (let
          ((quoted-items (map tcl-list-quote-elem items)))
          (let
            ((new-val (if (equal? cur "") (join " " quoted-items) (str cur " " (join " " quoted-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))))))

; Format helper: repeat char ch n times, building pad string
(define tcl-cmd-gets (fn (interp args) (assoc interp :result "")))

; Format helper: pad string s to width w
(define
  tcl-cmd-subst
  (fn (interp args) (assoc interp :result (last args))))

; Format helper: scan flag characters
(define
  tcl-fmt-make-pad
  (fn
    (ch cnt acc)
    (if
      (<= cnt 0)
      acc
      (tcl-fmt-make-pad ch (- cnt 1) (str ch acc)))))

; Format helper: scan digits for width/precision
(define
  tcl-fmt-pad
  (fn
    (s width zero-pad? left-align?)
    (let
      ((w (if (equal? width "") 0 (parse-int width))))
      (let
        ((pad-len (- w (string-length s))))
        (if
          (<= pad-len 0)
          s
          (let
            ((pad (tcl-fmt-make-pad (if zero-pad? "0" " ") pad-len "")))
            (if left-align? (str s pad) (str pad s))))))))

; Main format apply: process chars, produce output string
(define
  tcl-fmt-scan-flags
  (fn
    (chars j flags)
    (if
      (>= j (len chars))
      {:j j :flags flags}
      (let
        ((ch (nth chars j)))
        (if
          (contains? (list "-" "0" "+" " " "#") ch)
          (tcl-fmt-scan-flags chars (+ j 1) (str flags ch))
          {:j j :flags flags})))))

(define
  tcl-fmt-scan-num
  (fn
    (chars j acc-n)
    (if
      (>= j (len chars))
      {:num acc-n :j j}
      (let
        ((ch (nth chars j)))
        (if
          (tcl-expr-digit? ch)
          (tcl-fmt-scan-num chars (+ j 1) (str acc-n ch))
          {:num acc-n :j j})))))

(define
  tcl-fmt-apply
  (fn
    (chars n-len fmt-args i arg-idx acc)
    (if
      (>= i n-len)
      acc
      (let
        ((c (nth chars i)))
        (if
          (not (equal? c "%"))
          (tcl-fmt-apply
            chars
            n-len
            fmt-args
            (+ i 1)
            arg-idx
            (str acc c))
          (let
            ((i2 (+ i 1)))
            (if
              (>= i2 n-len)
              (str acc "%")
              (let
                ((c2 (nth chars i2)))
                (if
                  (equal? c2 "%")
                  (tcl-fmt-apply
                    chars
                    n-len
                    fmt-args
                    (+ i2 1)
                    arg-idx
                    (str acc "%"))
                  (let
                    ((fr (tcl-fmt-scan-flags chars i2 "")))
                    (let
                      ((flags (get fr :flags)) (j (get fr :j)))
                      (let
                        ((wr (tcl-fmt-scan-num chars j "")))
                        (let
                          ((width (get wr :num)) (j2 (get wr :j)))
                          (let
                            ((j3 (if (and (< j2 n-len) (equal? (nth chars j2) ".")) (let ((pr (tcl-fmt-scan-num chars (+ j2 1) ""))) (get pr :j)) j2)))
                            (if
                              (>= j3 n-len)
                              (str acc "?")
                              (let
                                ((type-char (nth chars j3))
                                  (cur-arg
                                    (if
                                      (< arg-idx (len fmt-args))
                                      (nth fmt-args arg-idx)
                                      "")))
                                (let
                                  ((zero-pad? (contains? (split flags "") "0"))
                                    (left-align?
                                      (contains? (split flags "") "-")))
                                  (let
                                    ((formatted (cond ((or (equal? type-char "d") (equal? type-char "i")) (tcl-fmt-pad (str (parse-int cur-arg)) width zero-pad? left-align?)) ((equal? type-char "s") (tcl-fmt-pad cur-arg width false left-align?)) ((or (equal? type-char "f") (equal? type-char "g") (equal? type-char "e")) cur-arg) ((equal? type-char "x") (str (parse-int cur-arg))) ((equal? type-char "o") (str (parse-int cur-arg))) ((equal? type-char "c") cur-arg) (else (str "%" type-char)))))
                                    (tcl-fmt-apply
                                      chars
                                      n-len
                                      fmt-args
                                      (+ j3 1)
                                      (+ arg-idx 1)
                                      (str acc formatted))))))))))))))))))))

; --- string command helpers ---

; glob match: pattern chars list, string chars list
(define
  tcl-cmd-format
  (fn
    (interp args)
    (if
      (= 0 (len args))
      (error "format: wrong # args")
      (let
        ((fmt-str (first args)) (fmt-args (rest args)))
        (let
          ((chars (split fmt-str "")) (n-len (string-length fmt-str)))
          (assoc
            interp
            :result (tcl-fmt-apply chars n-len fmt-args 0 0 "")))))))

; toupper/tolower via char tables
(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0")))

(define
  tcl-glob-match
  (fn
    (pat-chars str-chars)
    (cond
      ((and (= 0 (len pat-chars)) (= 0 (len str-chars)))
        true)
      ((= 0 (len pat-chars)) false)
      ((equal? (first pat-chars) "*")
        (let
          ((rest-pat (rest pat-chars)))
          (if
            (tcl-glob-match rest-pat str-chars)
            true
            (if
              (= 0 (len str-chars))
              false
              (tcl-glob-match pat-chars (rest str-chars))))))
      ((= 0 (len str-chars)) false)
      ((equal? (first pat-chars) "?")
        (tcl-glob-match (rest pat-chars) (rest str-chars)))
      ((equal? (first pat-chars) (first str-chars))
        (tcl-glob-match (rest pat-chars) (rest str-chars)))
      (else false))))

; strip chars from left
(define
  tcl-upcase-char
  (fn
    (c)
    (cond
      ((equal? c "a") "A")
      ((equal? c "b") "B")
      ((equal? c "c") "C")
      ((equal? c "d") "D")
      ((equal? c "e") "E")
      ((equal? c "f") "F")
      ((equal? c "g") "G")
      ((equal? c "h") "H")
      ((equal? c "i") "I")
      ((equal? c "j") "J")
      ((equal? c "k") "K")
      ((equal? c "l") "L")
      ((equal? c "m") "M")
      ((equal? c "n") "N")
      ((equal? c "o") "O")
      ((equal? c "p") "P")
      ((equal? c "q") "Q")
      ((equal? c "r") "R")
      ((equal? c "s") "S")
      ((equal? c "t") "T")
      ((equal? c "u") "U")
      ((equal? c "v") "V")
      ((equal? c "w") "W")
      ((equal? c "x") "X")
      ((equal? c "y") "Y")
      ((equal? c "z") "Z")
      (else c))))

; strip chars from right (reverse, trim left, reverse)
(define
  tcl-downcase-char
  (fn
    (c)
    (cond
      ((equal? c "A") "a")
      ((equal? c "B") "b")
      ((equal? c "C") "c")
      ((equal? c "D") "d")
      ((equal? c "E") "e")
      ((equal? c "F") "f")
      ((equal? c "G") "g")
      ((equal? c "H") "h")
      ((equal? c "I") "i")
      ((equal? c "J") "j")
      ((equal? c "K") "k")
      ((equal? c "L") "l")
      ((equal? c "M") "m")
      ((equal? c "N") "n")
      ((equal? c "O") "o")
      ((equal? c "P") "p")
      ((equal? c "Q") "q")
      ((equal? c "R") "r")
      ((equal? c "S") "s")
      ((equal? c "T") "t")
      ((equal? c "U") "u")
      ((equal? c "V") "v")
      ((equal? c "W") "w")
      ((equal? c "X") "x")
      ((equal? c "Y") "y")
      ((equal? c "Z") "z")
      (else c))))

(define
  tcl-trim-left-chars
  (fn
    (chars strip-set)
    (if
      (or
        (= 0 (len chars))
        (not (contains? strip-set (first chars))))
      chars
      (tcl-trim-left-chars (rest chars) strip-set))))

; default whitespace set
(define
  tcl-reverse-list
  (fn (lst) (reduce (fn (acc x) (append (list x) acc)) (list) lst)))

; string map: apply flat list of pairs old→new to string
(define
  tcl-trim-right-chars
  (fn
    (chars strip-set)
    (tcl-reverse-list
      (tcl-trim-left-chars (tcl-reverse-list chars) strip-set))))

; string first: index of needle in haystack starting at start
(define tcl-ws-set (list " " "\t" "\n" "\r"))

; string last: last index of needle in haystack up to end
(define
  tcl-string-map-apply
  (fn
    (s pairs)
    (if
      (< (len pairs) 2)
      s
      (let
        ((old (first pairs))
          (new-s (nth pairs 1))
          (rest-pairs (rest (rest pairs))))
        (let
          ((old-chars (split old "")) (old-len (string-length old)))
          (let
            ((go (fn (i acc) (if (>= i (string-length s)) acc (let ((chunk (if (> (+ i old-len) (string-length s)) "" (substring s i (+ i old-len))))) (if (equal? chunk old) (go (+ i old-len) (str acc new-s)) (go (+ i 1) (str acc (substring s i (+ i 1))))))))))
            (tcl-string-map-apply (go 0 "") rest-pairs)))))))

; string is: check string class
(define
  tcl-string-first
  (fn
    (needle haystack start)
    (let
      ((nl (string-length needle)) (hl (string-length haystack)))
      (if
        (= nl 0)
        (str start)
        (let
          ((go (fn (i) (if (> (+ i nl) hl) "-1" (if (equal? (substring haystack i (+ i nl)) needle) (str i) (go (+ i 1)))))))
          (go start))))))

(define
  tcl-string-last
  (fn
    (needle haystack end-idx)
    (let
      ((nl (string-length needle)) (hl (string-length haystack)))
      (let
        ((bound (if (< end-idx 0) (- hl 1) (if (>= end-idx hl) (- hl 1) end-idx))))
        (if
          (= nl 0)
          (str bound)
          (let
            ((go (fn (i) (if (< i 0) "-1" (if (and (<= (+ i nl) hl) (equal? (substring haystack i (+ i nl)) needle)) (str i) (go (- i 1)))))))
            (go (- (+ bound 1) nl))))))))


; --- list command helpers ---

; Quote a single list element: add braces if it contains a space or is empty
(define
  tcl-string-is
  (fn
    (class s)
    (let
      ((chars (split s "")) (n (string-length s)))
      (cond
        ((equal? class "integer")
          (if
            (= n 0)
            "0"
            (let
              ((start (if (or (equal? (first chars) "-") (equal? (first chars) "+")) 1 0)))
              (if
                (= start n)
                "0"
                (if
                  (reduce
                    (fn (ok c) (and ok (tcl-expr-digit? c)))
                    true
                    (slice chars start n))
                  "1"
                  "0")))))
        ((equal? class "double")
          (if
            (= n 0)
            "0"
            (if
              (reduce
                (fn
                  (ok c)
                  (and
                    ok
                    (or
                      (tcl-expr-digit? c)
                      (equal? c ".")
                      (equal? c "-")
                      (equal? c "+")
                      (equal? c "e")
                      (equal? c "E"))))
                true
                chars)
              "1"
              "0")))
        ((equal? class "alpha")
          (if
            (= n 0)
            "0"
            (if
              (reduce (fn (ok c) (and ok (tcl-expr-alpha? c))) true chars)
              "1"
              "0")))
        ((equal? class "alnum")
          (if
            (= n 0)
            "0"
            (if
              (reduce
                (fn
                  (ok c)
                  (and ok (or (tcl-expr-alpha? c) (tcl-expr-digit? c))))
                true
                chars)
              "1"
              "0")))
        ((equal? class "digit")
          (if
            (= n 0)
            "0"
            (if
              (reduce (fn (ok c) (and ok (tcl-expr-digit? c))) true chars)
              "1"
              "0")))
        ((equal? class "space")
          (if
            (= n 0)
            "1"
            (if
              (reduce (fn (ok c) (and ok (tcl-expr-ws? c))) true chars)
              "1"
              "0")))
        ((equal? class "upper")
          (if
            (= n 0)
            "0"
            (if
              (reduce
                (fn
                  (ok c)
                  (and
                    ok
                    (contains?
                      (list
                        "A"
                        "B"
                        "C"
                        "D"
                        "E"
                        "F"
                        "G"
                        "H"
                        "I"
                        "J"
                        "K"
                        "L"
                        "M"
                        "N"
                        "O"
                        "P"
                        "Q"
                        "R"
                        "S"
                        "T"
                        "U"
                        "V"
                        "W"
                        "X"
                        "Y"
                        "Z")
                      c)))
                true
                chars)
              "1"
              "0")))
        ((equal? class "lower")
          (if
            (= n 0)
            "0"
            (if
              (reduce
                (fn
                  (ok c)
                  (and
                    ok
                    (contains?
                      (list
                        "a"
                        "b"
                        "c"
                        "d"
                        "e"
                        "f"
                        "g"
                        "h"
                        "i"
                        "j"
                        "k"
                        "l"
                        "m"
                        "n"
                        "o"
                        "p"
                        "q"
                        "r"
                        "s"
                        "t"
                        "u"
                        "v"
                        "w"
                        "x"
                        "y"
                        "z")
                      c)))
                true
                chars)
              "1"
              "0")))
        ((equal? class "boolean")
          (if
            (or
              (equal? s "0")
              (equal? s "1")
              (equal? s "true")
              (equal? s "false")
              (equal? s "yes")
              (equal? s "no")
              (equal? s "on")
              (equal? s "off"))
            "1"
            "0"))
        (else "0")))))

; Build a Tcl list string from an SX list of string elements
(define
  tcl-cmd-string
  (fn
    (interp args)
    (if
      (= 0 (len args))
      (error "string: wrong # args")
      (let
        ((sub (first args)) (rest-args (rest args)))
        (cond
          ((equal? sub "length")
            (assoc interp :result (str (string-length (first rest-args)))))
          ((equal? sub "index")
            (let
              ((s (first rest-args))
                (idx (parse-int (nth rest-args 1))))
              (let
                ((n (string-length s)))
                (if
                  (or (< idx 0) (>= idx n))
                  (assoc interp :result "")
                  (assoc interp :result (substring s idx (+ idx 1)))))))
          ((equal? sub "range")
            (let
              ((s (first rest-args))
                (fi (parse-int (nth rest-args 1)))
                (li (parse-int (nth rest-args 2))))
              (let
                ((n (string-length s)))
                (let
                  ((f (if (< fi 0) 0 fi))
                    (l (if (>= li n) (- n 1) li)))
                  (if
                    (> f l)
                    (assoc interp :result "")
                    (assoc interp :result (substring s f (+ l 1))))))))
          ((equal? sub "compare")
            (let
              ((s1 (first rest-args)) (s2 (nth rest-args 1)))
              (assoc
                interp
                :result (cond ((equal? s1 s2) "0") ((< s1 s2) "-1") (else "1")))))
          ((equal? sub "match")
            (let
              ((pat (first rest-args)) (s (nth rest-args 1)))
              (assoc
                interp
                :result (if (tcl-glob-match (split pat "") (split s "")) "1" "0"))))
          ((equal? sub "toupper")
            (let
              ((s (first rest-args)))
              (assoc
                interp
                :result (join "" (map tcl-upcase-char (split s ""))))))
          ((equal? sub "tolower")
            (let
              ((s (first rest-args)))
              (assoc
                interp
                :result (join "" (map tcl-downcase-char (split s ""))))))
          ((equal? sub "trim")
            (let
              ((s (first rest-args))
                (strip-set
                  (if
                    (> (len rest-args) 1)
                    (split (nth rest-args 1) "")
                    tcl-ws-set)))
              (let
                ((chars (split s "")))
                (assoc
                  interp
                  :result (join
                    ""
                    (tcl-trim-right-chars
                      (tcl-trim-left-chars chars strip-set)
                      strip-set))))))
          ((equal? sub "trimleft")
            (let
              ((s (first rest-args))
                (strip-set
                  (if
                    (> (len rest-args) 1)
                    (split (nth rest-args 1) "")
                    tcl-ws-set)))
              (assoc
                interp
                :result (join "" (tcl-trim-left-chars (split s "") strip-set)))))
          ((equal? sub "trimright")
            (let
              ((s (first rest-args))
                (strip-set
                  (if
                    (> (len rest-args) 1)
                    (split (nth rest-args 1) "")
                    tcl-ws-set)))
              (assoc
                interp
                :result (join "" (tcl-trim-right-chars (split s "") strip-set)))))
          ((equal? sub "map")
            (let
              ((mapping (first rest-args)) (s (nth rest-args 1)))
              (assoc
                interp
                :result (tcl-string-map-apply s (tcl-list-split mapping)))))
          ((equal? sub "repeat")
            (let
              ((s (first rest-args))
                (n (parse-int (nth rest-args 1))))
              (assoc
                interp
                :result (let
                  ((go (fn (i acc) (if (>= i n) acc (go (+ i 1) (str acc s))))))
                  (go 0 "")))))
          ((equal? sub "first")
            (let
              ((needle (first rest-args))
                (haystack (nth rest-args 1))
                (start
                  (if
                    (> (len rest-args) 2)
                    (parse-int (nth rest-args 2))
                    0)))
              (assoc interp :result (tcl-string-first needle haystack start))))
          ((equal? sub "last")
            (let
              ((needle (first rest-args))
                (haystack (nth rest-args 1))
                (end-idx
                  (if
                    (> (len rest-args) 2)
                    (parse-int (nth rest-args 2))
                    -1)))
              (assoc interp :result (tcl-string-last needle haystack end-idx))))
          ((equal? sub "is")
            (let
              ((class (first rest-args)) (s (nth rest-args 1)))
              (assoc interp :result (tcl-string-is class s))))
          ((equal? sub "cat") (assoc interp :result (join "" rest-args)))
          (else (error (str "string: unknown subcommand: " sub))))))))

; Resolve "end" index to numeric value given list length
(define
  tcl-list-quote-elem
  (fn
    (elem)
    (if
      (or (equal? elem "") (contains? (split elem "") " "))
      (str "{" elem "}")
      elem)))

; Insertion sort for list commands (comparator: fn(a b) -> true if a before b)
(define
  tcl-list-build
  (fn (elems) (join " " (map tcl-list-quote-elem elems))))

(define
  tcl-end-index
  (fn (s n) (if (equal? s "end") (- n 1) (parse-int s))))

; --- list commands ---

(define
  tcl-insert-sorted
  (fn
    (lst before? x)
    (if
      (= 0 (len lst))
      (list x)
      (if
        (before? x (first lst))
        (append (list x) lst)
        (append
          (list (first lst))
          (tcl-insert-sorted (rest lst) before? x))))))

(define
  tcl-insertion-sort
  (fn
    (lst before?)
    (reduce
      (fn (sorted x) (tcl-insert-sorted sorted before? x))
      (list)
      lst)))

(define
  tcl-cmd-list
  (fn (interp args) (assoc interp :result (tcl-list-build args))))

(define
  tcl-cmd-lindex
  (fn
    (interp args)
    (let
      ((elems (tcl-list-split (first args)))
        (idx
          (tcl-end-index
            (nth args 1)
            (len (tcl-list-split (first args))))))
      (assoc
        interp
        :result (if
          (or (< idx 0) (>= idx (len elems)))
          ""
          (nth elems idx))))))

(define
  tcl-cmd-lrange
  (fn
    (interp args)
    (let
      ((elems (tcl-list-split (first args))))
      (let
        ((n (len elems))
          (fi (tcl-end-index (nth args 1) (len elems)))
          (li (tcl-end-index (nth args 2) (len elems))))
        (let
          ((f (if (< fi 0) 0 fi))
            (l (if (>= li n) (- n 1) li)))
          (assoc
            interp
            :result (if
              (> f l)
              ""
              (tcl-list-build (slice elems f (+ l 1))))))))))

(define
  tcl-cmd-llength
  (fn
    (interp args)
    (assoc interp :result (str (len (tcl-list-split (first args)))))))

(define
  tcl-cmd-lreverse
  (fn
    (interp args)
    (assoc
      interp
      :result (tcl-list-build (tcl-reverse-list (tcl-list-split (first args)))))))

(define
  tcl-cmd-lsearch
  (fn
    (interp args)
    (let
      ((exact? (and (> (len args) 2) (equal? (first args) "-exact")))
        (list-str
          (if
            (and (> (len args) 2) (equal? (first args) "-exact"))
            (nth args 1)
            (first args)))
        (value
          (if
            (and (> (len args) 2) (equal? (first args) "-exact"))
            (nth args 2)
            (nth args 1))))
      (let
        ((elems (tcl-list-split list-str)))
        (define
          find-idx
          (fn
            (lst i)
            (if
              (= 0 (len lst))
              "-1"
              (if
                (equal? (first lst) value)
                (str i)
                (find-idx (rest lst) (+ i 1))))))
        (assoc interp :result (find-idx elems 0))))))

(define
  tcl-cmd-lsort
  (fn
    (interp args)
    (define
      parse-opts
      (fn
        (remaining)
        (if
          (or
            (= 0 (len remaining))
            (not
              (equal?
                (substring (first remaining) 0 1)
                "-")))
          {:mode "ascii" :decreasing false :list-str (first remaining)}
          (if
            (equal? (first remaining) "-integer")
            (let
              ((r (parse-opts (rest remaining))))
              (assoc r :mode "integer"))
            (if
              (equal? (first remaining) "-real")
              (let
                ((r (parse-opts (rest remaining))))
                (assoc r :mode "real"))
              (if
                (equal? (first remaining) "-dictionary")
                (let
                  ((r (parse-opts (rest remaining))))
                  (assoc r :mode "dictionary"))
                (if
                  (equal? (first remaining) "-decreasing")
                  (let
                    ((r (parse-opts (rest remaining))))
                    (assoc r :decreasing true))
                  {:mode "ascii" :decreasing false :list-str (first remaining)})))))))
    (let
      ((opts (parse-opts args)))
      (let
        ((elems (tcl-list-split (get opts :list-str)))
          (mode (get opts :mode))
          (decreasing? (get opts :decreasing)))
        (let
          ((before? (if (equal? mode "integer") (fn (a b) (< (parse-int a) (parse-int b))) (fn (a b) (< a b)))))
          (let
            ((sorted (tcl-insertion-sort elems before?)))
            (assoc
              interp
              :result (tcl-list-build
                (if decreasing? (tcl-reverse-list sorted) sorted)))))))))

(define
  tcl-cmd-lreplace
  (fn
    (interp args)
    (let
      ((elems (tcl-list-split (first args))))
      (let
        ((n (len elems))
          (fi (tcl-end-index (nth args 1) n))
          (li (tcl-end-index (nth args 2) n))
          (new-elems (slice args 3 (len args))))
        (let
          ((f (if (< fi 0) 0 fi))
            (l (if (>= li (- n 1)) (- n 1) li)))
          (let
            ((before (slice elems 0 f))
              (after (slice elems (+ l 1) n)))
            (assoc
              interp
              :result (tcl-list-build
                (reduce
                  (fn (acc x) (append acc (list x)))
                  (reduce
                    (fn (acc x) (append acc (list x)))
                    before
                    new-elems)
                  after)))))))))

(define
  tcl-cmd-linsert
  (fn
    (interp args)
    (let
      ((elems (tcl-list-split (first args))))
      (let
        ((n (len elems))
          (raw-idx (nth args 1))
          (new-elems (slice args 2 (len args))))
        (let
          ((idx (if (equal? raw-idx "end") n (let ((i (parse-int raw-idx))) (if (< i 0) 0 (if (> i n) n i))))))
          (let
            ((before (slice elems 0 idx))
              (after (slice elems idx n)))
            (assoc
              interp
              :result (tcl-list-build
                (reduce
                  (fn (acc x) (append acc (list x)))
                  (reduce
                    (fn (acc x) (append acc (list x)))
                    before
                    new-elems)
                  after)))))))))

(define
  tcl-cmd-concat
  (fn
    (interp args)
    (let
      ((all-elems (reduce (fn (acc s) (append acc (tcl-list-split s))) (list) args)))
      (assoc interp :result (tcl-list-build all-elems)))))

; --- dict command helpers ---

; Parse flat dict string into SX list of [key val] pairs
(define
  tcl-cmd-split
  (fn
    (interp args)
    (let
      ((s (first args))
        (sep (if (> (len args) 1) (nth args 1) " ")))
      (let
        ((parts (if (equal? sep " ") (filter (fn (x) (not (equal? x ""))) (split s " ")) (split s sep))))
        (assoc interp :result (tcl-list-build parts))))))

; Build flat dict string from SX list of [key val] pairs
(define
  tcl-cmd-join
  (fn
    (interp args)
    (let
      ((elems (tcl-list-split (first args)))
        (sep (if (> (len args) 1) (nth args 1) " ")))
      (assoc interp :result (join sep elems)))))

; Get value for key from flat dict string; returns nil if missing
(define
  tcl-dict-to-pairs
  (fn
    (dict-str)
    (let
      ((flat (tcl-list-split dict-str)))
      (let
        ((go (fn (lst acc) (if (= 0 (len lst)) acc (if (= 1 (len lst)) (error "dict: malformed dict (odd number of elements)") (go (rest (rest lst)) (append acc (list (list (first lst) (nth lst 1))))))))))
        (go flat (list))))))

; Set key=val in flat dict string; returns new flat dict string
(define
  tcl-dict-from-pairs
  (fn
    (pairs)
    (tcl-list-build
      (reduce
        (fn
          (acc pair)
          (append
            (append acc (list (first pair)))
            (list (nth pair 1))))
        (list)
        pairs))))

; Remove key from flat dict string; returns new flat dict string
(define
  tcl-dict-get
  (fn
    (dict-str key)
    (let
      ((flat (tcl-list-split dict-str)))
      (let
        ((go (fn (lst) (if (< (len lst) 2) nil (if (equal? (first lst) key) (nth lst 1) (go (rest (rest lst))))))))
        (go flat)))))

; --- dict command ---

(define
  tcl-dict-set-pair
  (fn
    (dict-str key val)
    (let
      ((pairs (tcl-dict-to-pairs dict-str)))
      (let
        ((found? (reduce (fn (acc pair) (or acc (equal? (first pair) key))) false pairs)))
        (if
          found?
          (tcl-dict-from-pairs
            (map
              (fn
                (pair)
                (if (equal? (first pair) key) (list key val) pair))
              pairs))
          (tcl-dict-from-pairs (append pairs (list (list key val)))))))))

; --- namespace helpers ---

; Normalize a namespace name to fully-qualified form: ::ns
; Accepts: "ns", "::ns", "ns::", "::ns::", "" → "::"
(define
  tcl-dict-unset-key
  (fn
    (dict-str key)
    (tcl-dict-from-pairs
      (filter
        (fn (pair) (not (equal? (first pair) key)))
        (tcl-dict-to-pairs dict-str)))))

; Test whether string s starts with prefix p
(define
  tcl-cmd-dict
  (fn
    (interp args)
    (if
      (= 0 (len args))
      (error "dict: wrong # args")
      (let
        ((sub (first args)) (rest-args (rest args)))
        (cond
          ((equal? sub "create")
            (if
              (= 1 (mod (len rest-args) 2))
              (error "dict create: wrong # args (must be even)")
              (assoc interp :result (tcl-list-build rest-args))))
          ((equal? sub "get")
            (let
              ((dict-str (first rest-args))
                (key (nth rest-args 1)))
              (let
                ((val (tcl-dict-get dict-str key)))
                (if
                  (nil? val)
                  (error
                    (str "dict get: key \"" key "\" not known in dictionary"))
                  (assoc interp :result val)))))
          ((equal? sub "set")
            (let
              ((varname (first rest-args))
                (key (nth rest-args 1))
                (val (nth rest-args 2)))
              (let
                ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
                (let
                  ((new-dict (tcl-dict-set-pair cur key val)))
                  (assoc
                    (tcl-var-set interp varname new-dict)
                    :result new-dict)))))
          ((equal? sub "unset")
            (let
              ((varname (first rest-args))
                (key (nth rest-args 1)))
              (let
                ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
                (let
                  ((new-dict (tcl-dict-unset-key cur key)))
                  (assoc
                    (tcl-var-set interp varname new-dict)
                    :result new-dict)))))
          ((equal? sub "exists")
            (let
              ((dict-str (first rest-args))
                (key (nth rest-args 1)))
              (assoc
                interp
                :result (if (nil? (tcl-dict-get dict-str key)) "0" "1"))))
          ((equal? sub "keys")
            (let
              ((dict-str (first rest-args))
                (pattern
                  (if
                    (> (len rest-args) 1)
                    (nth rest-args 1)
                    nil)))
              (let
                ((all-keys (map first (tcl-dict-to-pairs dict-str))))
                (let
                  ((filtered (if (nil? pattern) all-keys (filter (fn (k) (tcl-glob-match (split pattern "") (split k ""))) all-keys))))
                  (assoc interp :result (tcl-list-build filtered))))))
          ((equal? sub "values")
            (let
              ((dict-str (first rest-args)))
              (assoc
                interp
                :result (tcl-list-build
                  (map
                    (fn (pair) (nth pair 1))
                    (tcl-dict-to-pairs dict-str))))))
          ((equal? sub "size")
            (let
              ((dict-str (first rest-args)))
              (assoc
                interp
                :result (str (len (tcl-dict-to-pairs dict-str))))))
          ((equal? sub "for")
            (let
              ((var-pair-str (first rest-args))
                (dict-str (nth rest-args 1))
                (body (nth rest-args 2)))
              (let
                ((var-list (tcl-list-split var-pair-str)))
                (let
                  ((kvar (first var-list))
                    (vvar (nth var-list 1)))
                  (let
                    ((pairs (tcl-dict-to-pairs dict-str)))
                    (define
                      dict-for-loop
                      (fn
                        (cur-interp ps)
                        (if
                          (= 0 (len ps))
                          cur-interp
                          (let
                            ((pair (first ps)))
                            (let
                              ((bound (tcl-var-set (tcl-var-set cur-interp kvar (first pair)) vvar (nth pair 1))))
                              (let
                                ((body-result (tcl-eval-string bound body)))
                                (let
                                  ((code (get body-result :code)))
                                  (cond
                                    ((= code 3)
                                      (assoc body-result :code 0))
                                    ((= code 2) body-result)
                                    ((= code 1) body-result)
                                    (else
                                      (dict-for-loop
                                        (assoc body-result :code 0)
                                        (rest ps)))))))))))
                    (dict-for-loop interp pairs))))))
          ((equal? sub "update")
            (let
              ((varname (first rest-args)))
              (let
                ((n (len rest-args)))
                (let
                  ((body (nth rest-args (- n 1)))
                    (kv-args (slice rest-args 1 (- n 1))))
                  (let
                    ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
                    (let
                      ((bound-interp (let ((bind-pairs (fn (i-interp remaining) (if (< (len remaining) 2) i-interp (let ((k (first remaining)) (var (nth remaining 1))) (let ((val (tcl-dict-get cur k))) (bind-pairs (tcl-var-set i-interp var (if (nil? val) "" val)) (rest (rest remaining))))))))) (bind-pairs interp kv-args))))
                      (let
                        ((body-result (tcl-eval-string bound-interp body)))
                        (let
                          ((write-back (fn (i-interp remaining new-dict) (if (< (len remaining) 2) (assoc (tcl-var-set i-interp varname new-dict) :result new-dict) (let ((k (first remaining)) (var (nth remaining 1))) (let ((new-val (frame-lookup (get body-result :frame) var))) (write-back i-interp (rest (rest remaining)) (if (nil? new-val) (tcl-dict-unset-key new-dict k) (tcl-dict-set-pair new-dict k new-val)))))))))
                          (write-back body-result kv-args cur)))))))))
          ((equal? sub "merge")
            (let
              ((merged (reduce (fn (acc dict-str) (reduce (fn (a pair) (tcl-dict-set-pair a (first pair) (nth pair 1))) acc (tcl-dict-to-pairs dict-str))) "" rest-args)))
              (assoc interp :result merged)))
          ((equal? sub "incr")
            (let
              ((varname (first rest-args))
                (key (nth rest-args 1))
                (delta
                  (if
                    (> (len rest-args) 2)
                    (parse-int (nth rest-args 2))
                    1)))
              (let
                ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
                (let
                  ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "0" v))))
                  (let
                    ((new-val (str (+ (parse-int old-val) delta))))
                    (let
                      ((new-dict (tcl-dict-set-pair cur key new-val)))
                      (assoc
                        (tcl-var-set interp varname new-dict)
                        :result new-dict)))))))
          ((equal? sub "append")
            (let
              ((varname (first rest-args))
                (key (nth rest-args 1))
                (suffix
                  (join "" (slice rest-args 2 (len rest-args)))))
              (let
                ((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp varname)))) (if (nil? v) "" v))))
                (let
                  ((old-val (let ((v (tcl-dict-get cur key))) (if (nil? v) "" v))))
                  (let
                    ((new-val (str old-val suffix)))
                    (let
                      ((new-dict (tcl-dict-set-pair cur key new-val)))
                      (assoc
                        (tcl-var-set interp varname new-dict)
                        :result new-dict)))))))
          (else (error (str "dict: unknown subcommand \"" sub "\""))))))))

; Qualify a proc name relative to current-ns.
; If name already starts with :: return as-is.
; Otherwise prepend current-ns:: (or :: if current-ns is ::).
(define
  tcl-ns-normalize
  (fn
    (ns)
    (if
      (or (equal? ns "") (equal? ns "::"))
      "::"
      (let
        ((stripped (if (equal? (substring ns (- (string-length ns) 2) (string-length ns)) "::") (substring ns 0 (- (string-length ns) 2)) ns)))
        (if
          (equal? (substring stripped 0 2) "::")
          stripped
          (str "::" stripped))))))

; Look up a command by name with namespace resolution.
; Try: exact name → ::current-ns::name → ::name
(define
  tcl-starts-with?
  (fn
    (s p)
    (let
      ((pl (string-length p)) (sl (string-length s)))
      (if (> pl sl) false (equal? (substring s 0 pl) p)))))

; Get all proc names in a namespace (returns list of fully-qualified names)
(define
  tcl-qualify-name
  (fn
    (name current-ns)
    (if
      (tcl-starts-with? name "::")
      name
      (if
        (equal? current-ns "::")
        (str "::" name)
        (str current-ns "::" name)))))

; Check if a namespace exists (has any procs)
(define
  tcl-proc-lookup
  (fn
    (interp name)
    (let
      ((procs (get interp :procs)) (current-ns (get interp :current-ns)))
      (let
        ((exact (get procs name)))
        (if
          (not (nil? exact))
          {:def exact :name name}
          (let
            ((qualified (tcl-qualify-name name current-ns)))
            (let
              ((qual-def (get procs qualified)))
              (if
                (not (nil? qual-def))
                {:def qual-def :name qualified}
                (let
                  ((global-name (str "::" name)))
                  (let
                    ((global-def (get procs global-name)))
                    (if (not (nil? global-def)) {:def global-def :name global-name} nil)))))))))))

; Extract last component from qualified name ::ns::foo → foo
(define
  tcl-ns-procs
  (fn
    (procs ns)
    (let
      ((prefix (if (equal? ns "::") "::" (str ns "::"))))
      (filter
        (fn
          (k)
          (if
            (equal? ns "::")
            (and
              (tcl-starts-with? k "::")
              (not
                (tcl-starts-with?
                  (substring k 2 (string-length k))
                  "::")))
            (tcl-starts-with? k prefix)))
        (keys procs)))))

; --- proc command ---

(define
  tcl-ns-exists?
  (fn (procs ns) (> (len (tcl-ns-procs procs ns)) 0)))

; --- parse uplevel/upvar level argument ---
; Returns absolute level number.
; current-level = len(frame-stack)
(define
  tcl-ns-tail
  (fn
    (name)
    (let
      ((parts (filter (fn (p) (not (equal? p ""))) (split name ":"))))
      (if
        (= 0 (len parts))
        name
        (nth parts (- (len parts) 1))))))

; --- uplevel command ---

(define
  tcl-cmd-proc
  (fn
    (interp args)
    (let
      ((raw-name (first args))
        (arg-spec (nth args 1))
        (body (nth args 2)))
      (let
        ((name (tcl-qualify-name raw-name (get interp :current-ns))))
        (let
          ((proc-ns (let ((parts (filter (fn (p) (not (equal? p ""))) (split name ":")))) (if (<= (len parts) 1) "::" (str "::" (join "::" (take-n parts (- (len parts) 1))))))))
          (assoc
            interp
            :procs (assoc (get interp :procs) name {:args arg-spec :body body :ns proc-ns})
            :result ""))))))

; --- upvar command ---

(define
  tcl-parse-level
  (fn
    (level-str current-level)
    (if
      (equal? (substring level-str 0 1) "#")
      (parse-int (substring level-str 1 (string-length level-str)))
      (- current-level (parse-int level-str)))))

; --- global command ---

(define
  tcl-cmd-uplevel
  (fn
    (interp args)
    (let
      ((current-level (len (get interp :frame-stack))))
      (let
        ((has-level (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (let ((fst (first args))) (and (> (string-length fst) 0) (tcl-expr-digit? (substring fst 0 1)))))))
          (level-str
            (if
              (and
                (> (len args) 1)
                (or
                  (equal? (substring (first args) 0 1) "#")
                  (and
                    (> (string-length (first args)) 0)
                    (tcl-expr-digit?
                      (substring (first args) 0 1)))))
              (first args)
              "1"))
          (script
            (if
              (and
                (> (len args) 1)
                (or
                  (equal? (substring (first args) 0 1) "#")
                  (and
                    (> (string-length (first args)) 0)
                    (tcl-expr-digit?
                      (substring (first args) 0 1)))))
              (nth args 1)
              (first args))))
        (let
          ((target-level (tcl-parse-level level-str current-level)))
          (let
            ((full-stack (tcl-full-stack interp)))
            (let
              ((target-frame (tcl-frame-nth full-stack target-level)))
              (let
                ((temp-interp (assoc interp :frame target-frame :frame-stack (take-n (get interp :frame-stack) target-level) :output ""))
                  (saved-output (get interp :output)))
                (let
                  ((result-interp (tcl-eval-string temp-interp script)))
                  (let
                    ((updated-target (get result-interp :frame))
                      (new-output (get result-interp :output)))
                    (let
                      ((new-full-stack (replace-at full-stack target-level updated-target)))
                      (let
                        ((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1)))
                          (new-current
                            (nth
                              new-full-stack
                              (- (len new-full-stack) 1))))
                        (assoc
                          interp
                          :frame new-current
                          :frame-stack new-frame-stack
                          :result (get result-interp :result)
                          :output (str saved-output new-output)
                          :code (get result-interp :code))))))))))))))

; --- variable command ---

(define
  tcl-cmd-upvar
  (fn
    (interp args)
    (let
      ((current-level (len (get interp :frame-stack))))
      (let
        ((has-level (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))))
          (level-str
            (if
              (and
                (> (len args) 2)
                (or
                  (equal? (substring (first args) 0 1) "#")
                  (tcl-expr-digit?
                    (substring (first args) 0 1))))
              (first args)
              "1"))
          (pair-args
            (if
              (and
                (> (len args) 2)
                (or
                  (equal? (substring (first args) 0 1) "#")
                  (tcl-expr-digit?
                    (substring (first args) 0 1))))
              (rest args)
              args)))
        (let
          ((target-level (tcl-parse-level level-str current-level)))
          (let
            ((bind-pairs (fn (i-interp remaining) (if (< (len remaining) 2) i-interp (let ((remote-name (first remaining)) (local-name (nth remaining 1))) (let ((alias {:upvar-name remote-name :upvar-level target-level})) (bind-pairs (assoc i-interp :frame (frame-set-top (get i-interp :frame) local-name alias)) (rest (rest remaining)))))))))
            (assoc (bind-pairs interp pair-args) :result "")))))))

; --- namespace command ---

; namespace ensemble dispatch fn for a given ns and map
(define
  tcl-cmd-global
  (fn
    (interp args)
    (reduce
      (fn (i name) (tcl-cmd-upvar i (list "#0" name name)))
      interp
      args)))

(define
  tcl-cmd-variable
  (fn
    (interp args)
    (let
      ((go (fn (i remaining) (if (= 0 (len remaining)) i (let ((name (first remaining)) (rest-rem (rest remaining))) (let ((linked (tcl-cmd-upvar i (list "#0" name name)))) (if (and (> (len rest-rem) 0) (not (equal? (substring (first rest-rem) 0 1) "-"))) (let ((val (first rest-rem))) (go (assoc (tcl-var-set linked name val) :result "") (rest rest-rem))) (go linked rest-rem))))))))
      (go interp args))))

; --- info command ---

(define
  tcl-make-ensemble
  (fn
    (procs ns map-dict)
    (fn
      (interp args)
      (if
        (= 0 (len args))
        (error (str "wrong # args: ensemble \"" ns "\" requires subcommand"))
        (let
          ((subcmd (first args)) (rest-args (rest args)))
          (let
            ((target-name (tcl-dict-get map-dict subcmd)))
            (if
              (not (nil? target-name))
              (let
                ((proc-entry (tcl-proc-lookup interp target-name)))
                (if
                  (nil? proc-entry)
                  (error
                    (str "ensemble: command \"" target-name "\" not found"))
                  (tcl-call-proc
                    interp
                    (get proc-entry :name)
                    (get proc-entry :def)
                    rest-args)))
              (error
                (str
                  "unknown or ambiguous subcommand \""
                  subcmd
                  "\": must be one of "
                  (join ", " (map first (tcl-dict-to-pairs map-dict))))))))))))

; --- coroutine support ---

; yield: inside a coroutine body, record a yielded value
(define
  tcl-cmd-namespace
  (fn
    (interp args)
    (if
      (= 0 (len args))
      (error "namespace: wrong # args")
      (let
        ((sub (first args)) (rest-args (rest args)))
        (cond
          ((equal? sub "eval")
            (let
              ((ns-raw (if (> (len rest-args) 0) (first rest-args) ""))
                (body
                  (if
                    (> (len rest-args) 1)
                    (nth rest-args 1)
                    "")))
              (let
                ((ns (let ((normalized (tcl-ns-normalize ns-raw)) (current-ns (get interp :current-ns))) (if (tcl-starts-with? ns-raw "::") normalized (if (equal? current-ns "::") normalized (str current-ns "::" (tcl-ns-tail normalized))))))
                  (saved-ns (get interp :current-ns)))
                (let
                  ((ns-interp (assoc interp :current-ns ns)))
                  (let
                    ((result-interp (tcl-eval-string ns-interp body)))
                    (assoc result-interp :current-ns saved-ns))))))
          ((equal? sub "current")
            (assoc interp :result (get interp :current-ns)))
          ((equal? sub "which")
            (let
              ((name (if (and (> (len rest-args) 0) (equal? (first rest-args) "-command")) (if (> (len rest-args) 1) (nth rest-args 1) "") (if (> (len rest-args) 0) (first rest-args) ""))))
              (let
                ((entry (tcl-proc-lookup interp name)))
                (if
                  (nil? entry)
                  (assoc interp :result "")
                  (assoc interp :result (get entry :name))))))
          ((equal? sub "exists")
            (let
              ((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) ""))))
              (assoc
                interp
                :result (if (tcl-ns-exists? (get interp :procs) ns) "1" "0"))))
          ((equal? sub "delete")
            (let
              ((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) ""))))
              (let
                ((prefix (if (equal? ns "::") "::" (str ns "::"))))
                (let
                  ((remaining-procs (reduce (fn (acc k) (if (tcl-starts-with? k prefix) acc (assoc acc k (get (get interp :procs) k)))) {} (keys (get interp :procs)))))
                  (assoc interp :procs remaining-procs :result "")))))
          ((equal? sub "export") (assoc interp :result ""))
          ((equal? sub "import")
            (let
              ((target-name (if (> (len rest-args) 0) (first rest-args) "")))
              (let
                ((tail (tcl-ns-tail target-name))
                  (entry (tcl-proc-lookup interp target-name)))
                (if
                  (nil? entry)
                  (error
                    (str "namespace import: \"" target-name "\" not found"))
                  (let
                    ((local-name (tcl-qualify-name tail (get interp :current-ns))))
                    (assoc
                      interp
                      :procs (assoc (get interp :procs) local-name (get entry :def))
                      :result ""))))))
          ((equal? sub "forget")
            (let
              ((name (if (> (len rest-args) 0) (first rest-args) "")))
              (let
                ((qualified (tcl-qualify-name name (get interp :current-ns))))
                (let
                  ((new-procs (reduce (fn (acc k) (if (equal? k qualified) acc (assoc acc k (get (get interp :procs) k)))) {} (keys (get interp :procs)))))
                  (assoc interp :procs new-procs :result "")))))
          ((equal? sub "path") (assoc interp :result ""))
          ((equal? sub "ensemble")
            (if
              (and
                (> (len rest-args) 0)
                (equal? (first rest-args) "create"))
              (let
                ((ens-args (rest rest-args))
                  (current-ns (get interp :current-ns)))
                (let
                  ((map-str (let ((go (fn (remaining) (if (< (len remaining) 2) nil (if (equal? (first remaining) "-map") (nth remaining 1) (go (rest remaining))))))) (go ens-args))))
                  (let
                    ((dispatch-map (if (nil? map-str) (let ((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns))) (reduce (fn (acc qname) (let ((tail (tcl-ns-tail qname))) (tcl-dict-set-pair acc tail qname))) "" ns-proc-names)) map-str)))
                    (let
                      ((ens-name (tcl-ns-tail current-ns))
                        (ens-fn
                          (tcl-make-ensemble
                            (get interp :procs)
                            current-ns
                            dispatch-map)))
                      (assoc
                        interp
                        :commands (assoc (get interp :commands) ens-name ens-fn)
                        :result "")))))
              (error "namespace ensemble: unknown subcommand")))
          (else (error (str "namespace: unknown subcommand \"" sub "\""))))))))

; yieldto: stub — yield empty string
(define
  tcl-cmd-info
  (fn
    (interp args)
    (if
      (= 0 (len args))
      (error "info: wrong # args")
      (let
        ((sub (first args)) (rest-args (rest args)))
        (cond
          ((equal? sub "level")
            (assoc interp :result (str (len (get interp :frame-stack)))))
          ((or (equal? sub "vars") (equal? sub "locals"))
            (let
              ((frame-locals (get (get interp :frame) :locals)))
              (assoc
                interp
                :result (tcl-list-build
                  (filter
                    (fn (k) (not (upvar-alias? (get frame-locals k))))
                    (keys frame-locals))))))
          ((equal? sub "globals")
            (let
              ((global-frame (if (= 0 (len (get interp :frame-stack))) (get interp :frame) (first (get interp :frame-stack)))))
              (let
                ((global-locals (get global-frame :locals)))
                (assoc
                  interp
                  :result (tcl-list-build
                    (filter
                      (fn (k) (not (upvar-alias? (get global-locals k))))
                      (keys global-locals)))))))
          ((equal? sub "commands")
            (assoc
              interp
              :result (tcl-list-build (keys (get interp :commands)))))
          ((equal? sub "procs")
            (let
              ((current-ns (get interp :current-ns)))
              (let
                ((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns)))
                (assoc
                  interp
                  :result (tcl-list-build (map tcl-ns-tail ns-proc-names))))))
          ((equal? sub "args")
            (let
              ((pname (first rest-args)))
              (let
                ((entry (tcl-proc-lookup interp pname)))
                (if
                  (nil? entry)
                  (error (str "info args: \"" pname "\" isn't a procedure"))
                  (assoc interp :result (get (get entry :def) :args))))))
          ((equal? sub "body")
            (let
              ((pname (first rest-args)))
              (let
                ((entry (tcl-proc-lookup interp pname)))
                (if
                  (nil? entry)
                  (error (str "info body: \"" pname "\" isn't a procedure"))
                  (assoc interp :result (get (get entry :def) :body))))))
          ((equal? sub "exists")
            (let
              ((varname (first rest-args)))
              (let
                ((val (frame-lookup (get interp :frame) varname)))
                (assoc interp :result (if (nil? val) "0" "1")))))
          ((equal? sub "hostname") (assoc interp :result "localhost"))
          ((equal? sub "script") (assoc interp :result ""))
          ((equal? sub "tclversion") (assoc interp :result "8.6"))
          (else (error (str "info: unknown subcommand \"" sub "\""))))))))

; tcl-cmd-yield: suspend the current coroutine fiber, returning val to the resumer
(define
  tcl-cmd-yield
  (fn
    (interp args)
    (let
      ((val (if (> (len args) 0) (first args) "")))
      (let
        ((yield-fn (get interp :coro-yield-fn)))
        (if
          (nil? yield-fn)
          (error "yield called outside coroutine")
          (let
            ((resume-val (yield-fn val)))
            (assoc interp :result (if (nil? resume-val) "" resume-val))))))))

; tcl-cmd-yieldto: suspend the current coroutine fiber (simplified: yields "" to resumer)
(define
  tcl-cmd-yieldto
  (fn
    (interp args)
    (let
      ((yield-fn (get interp :coro-yield-fn)))
      (if
        (nil? yield-fn)
        (error "yieldto called outside coroutine")
        (let
          ((resume-val (yield-fn "")))
          (assoc interp :result (if (nil? resume-val) "" resume-val)))))))

; --- clock command (stubs) ---

(define
  make-coro-cmd
  (fn
    (fiber)
    (fn
      (interp args)
      (let
        ((resume-val (if (> (len args) 0) (first args) "")))
        (let
          ((yielded (fiber-resume fiber resume-val)))
          (assoc interp :result (if (nil? yielded) "" yielded)))))))

; --- file I/O stubs ---

(define
  tcl-cmd-coroutine
  (fn
    (interp args)
    (if
      (< (len args) 2)
      (error "coroutine: wrong # args")
      (let
        ((coro-name (first args))
          (cmd-name (nth args 1))
          (call-args (rest (rest args))))
        (let
          ((base-interp (assoc interp :result "" :code 0 :coro-yield-fn nil)))
          (let
            ((fiber
                (make-fiber
                  (fn
                    (fiber-yield _)
                    (let
                      ((coro-interp (assoc base-interp :coro-yield-fn fiber-yield)))
                      (let
                        ((cmd-fn (get (get coro-interp :commands) cmd-name)))
                        (if
                          (nil? cmd-fn)
                          (let
                            ((proc-entry (tcl-proc-lookup coro-interp cmd-name)))
                            (if
                              (nil? proc-entry)
                              (error
                                (str "coroutine: unknown command \"" cmd-name "\""))
                              (tcl-call-proc
                                coro-interp
                                (get proc-entry :name)
                                (get proc-entry :def)
                                call-args)))
                          (cmd-fn coro-interp call-args))))))))
            (let
              ((new-commands
                  (assoc (get interp :commands) coro-name (make-coro-cmd fiber))))
              (assoc interp :commands new-commands :result ""))))))))

(define
  tcl-cmd-clock
  (fn
    (interp args)
    (if
      (= 0 (len args))
      (error "clock: wrong # args")
      (let
        ((sub (first args)) (rest-args (rest args)))
        (cond
          ((equal? sub "seconds") (assoc interp :result "0"))
          ((equal? sub "milliseconds") (assoc interp :result "0"))
          ((equal? sub "format")
            (assoc interp :result "Thu Jan  1 00:00:00 UTC 1970"))
          ((equal? sub "scan") (assoc interp :result "0"))
          (else (error (str "clock: unknown subcommand \"" sub "\""))))))))

(define tcl-cmd-open (fn (interp args) (assoc interp :result "file0")))

; gets channel ?varname?
(define tcl-cmd-close (fn (interp args) (assoc interp :result "")))

(define tcl-cmd-read (fn (interp args) (assoc interp :result "")))

(define
  tcl-cmd-gets-chan
  (fn
    (interp args)
    (if
      (> (len args) 1)
      (assoc (tcl-var-set interp (nth args 1) "") :result "-1")
      (assoc interp :result ""))))

(define tcl-cmd-eof (fn (interp args) (assoc interp :result "1")))

(define tcl-cmd-seek (fn (interp args) (assoc interp :result "")))

; file command dispatcher
(define tcl-cmd-tell (fn (interp args) (assoc interp :result "0")))

(define tcl-cmd-flush (fn (interp args) (assoc interp :result "")))
(define
  tcl-cmd-array
  (fn
    (interp args)
    (if
      (= 0 (len args))
      (error "array: wrong # args")
      (let
        ((sub (first args)) (rest-args (rest args)))
        (cond
          ((equal? sub "get")
            (if (= 0 (len rest-args))
              (error "array get: wrong # args")
              (let
                ((arr-name (first rest-args))
                  (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
                (let
                  ((prefix (str arr-name "("))
                    (locals (get (get interp :frame) :locals)))
                  (let
                    ((pl (string-length prefix)))
                    (let
                      ((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
                      (let
                        ((filtered
                            (if
                              (nil? pattern)
                              arr-keys
                              (filter
                                (fn (k)
                                  (let ((kn (substring k pl (- (string-length k) 1))))
                                    (tcl-glob-match (split pattern "") (split kn ""))))
                                arr-keys))))
                        (assoc interp :result
                          (join " "
                            (reduce
                              (fn (acc k)
                                (let ((kn (substring k pl (- (string-length k) 1))))
                                  (append acc (list kn) (list (get locals k)))))
                              (list)
                              filtered))))))))))
          ((equal? sub "set")
            (if
              (< (len rest-args) 2)
              (error "array set: wrong # args")
              (let
                ((arr-name (first rest-args))
                  (flat (tcl-list-split (nth rest-args 1))))
                (let
                  loop
                  ((pairs flat) (acc interp))
                  (if
                    (< (len pairs) 2)
                    (assoc acc :result "")
                    (loop
                      (rest (rest pairs))
                      (tcl-var-set acc
                        (str arr-name "(" (first pairs) ")")
                        (nth pairs 1))))))))
          ((equal? sub "names")
            (if
              (= 0 (len rest-args))
              (error "array names: wrong # args")
              (let
                ((arr-name (first rest-args))
                  (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
                (let
                  ((prefix (str arr-name "("))
                    (locals (get (get interp :frame) :locals)))
                  (let
                    ((pl (string-length prefix)))
                    (let
                      ((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
                      (let
                        ((filtered
                            (if
                              (nil? pattern)
                              arr-keys
                              (filter
                                (fn (k)
                                  (let ((kn (substring k pl (- (string-length k) 1))))
                                    (tcl-glob-match (split pattern "") (split kn ""))))
                                arr-keys))))
                        (assoc interp :result
                          (join " " (map (fn (k) (substring k pl (- (string-length k) 1))) filtered))))))))))
          ((equal? sub "size")
            (if
              (= 0 (len rest-args))
              (error "array size: wrong # args")
              (let
                ((prefix (str (first rest-args) "("))
                  (locals (get (get interp :frame) :locals)))
                (assoc interp :result
                  (str (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))))))
          ((equal? sub "exists")
            (if
              (= 0 (len rest-args))
              (error "array exists: wrong # args")
              (let
                ((prefix (str (first rest-args) "("))
                  (locals (get (get interp :frame) :locals)))
                (assoc interp :result
                  (if (> (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))) 0) "1" "0")))))
          ((equal? sub "unset")
            (if
              (= 0 (len rest-args))
              (error "array unset: wrong # args")
              (let
                ((arr-name (first rest-args))
                  (pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
                (let
                  ((prefix (str arr-name "("))
                    (locals (get (get interp :frame) :locals)))
                  (let
                    ((pl (string-length prefix)))
                    (let
                      ((to-delete
                          (filter
                            (fn (k)
                              (if
                                (tcl-starts-with? k prefix)
                                (if
                                  (nil? pattern)
                                  true
                                  (let ((kn (substring k pl (- (string-length k) 1))))
                                    (tcl-glob-match (split pattern "") (split kn ""))))
                                false))
                            (keys locals))))
                      (let
                        ((new-locals
                            (reduce
                              (fn (acc k)
                                (if
                                  (contains? to-delete k)
                                  acc
                                  (assoc acc k (get locals k))))
                              {}
                              (keys locals))))
                        (assoc interp
                          :frame (assoc (get interp :frame) :locals new-locals)
                          :result ""))))))))
          (else (error (str "array: unknown subcommand \"" sub "\""))))))))


(define
  tcl-cmd-apply
  (fn
    (interp args)
    (if
      (< (len args) 1)
      (error "apply: wrong # args: should be "apply lambdaList ?arg ...?"")
      (let
        ((func-list (tcl-list-split (first args)))
          (call-args (rest args)))
        (if
          (< (len func-list) 2)
          (error "apply: lambdaList must be a 2 or 3 element list")
          (let
            ((param-spec (first func-list))
              (body (nth func-list 1))
              (ns (if (> (len func-list) 2) (nth func-list 2) nil)))
            (let
              ((proc-def {:args param-spec :body body :ns ns}))
              (tcl-call-proc interp "#apply" proc-def call-args))))))))


(define
  tcl-cmd-regexp
  (fn
    (interp args)
    (define parse-flags
      (fn (as nocase? all? inline?)
        (if (= 0 (len as))
          {:nocase nocase? :all all? :inline inline? :rest as}
          (cond
            ((equal? (first as) "-nocase") (parse-flags (rest as) true all? inline?))
            ((equal? (first as) "-all")    (parse-flags (rest as) nocase? true inline?))
            ((equal? (first as) "-inline") (parse-flags (rest as) nocase? all? true))
            (else {:nocase nocase? :all all? :inline inline? :rest as})))))
    (let ((pf (parse-flags args false false false)))
      (let ((nocase (get pf :nocase))
            (all-mode (get pf :all))
            (inline-mode (get pf :inline))
            (ra (get pf :rest)))
        (if (< (len ra) 2)
          (error "regexp: wrong # args")
          (let ((pattern (first ra))
                (str-val (nth ra 1))
                (var-args (if (> (len ra) 2) (rest (rest ra)) (list))))
            (let ((re (make-regexp pattern (if nocase "i" ""))))
              (if all-mode
                (assoc interp :result (str (len (regexp-match-all re str-val))))
                (if inline-mode
                  (assoc interp :result (join " " (map (fn (m) (get m :match)) (regexp-match-all re str-val))))
                  (let ((m (regexp-match re str-val)))
                    (if (nil? m)
                      (assoc interp :result "0")
                      (let ((interp2
                              (if (> (len var-args) 0)
                                (tcl-var-set interp (first var-args) (get m :match))
                                interp)))
                        (let ((interp3
                                (let loop ((vi 1) (gs (get m :groups)) (acc interp2))
                                  (if (or (= 0 (len gs)) (>= vi (len var-args))) acc
                                    (loop (+ vi 1) (rest gs)
                                          (tcl-var-set acc (nth var-args vi) (first gs)))))))
                          (assoc interp3 :result "1"))))))))))))))

(define
  tcl-cmd-regsub
  (fn
    (interp args)
    (define parse-flags
      (fn (as all? nocase?)
        (if (= 0 (len as))
          {:all all? :nocase nocase? :rest as}
          (cond
            ((equal? (first as) "-all")    (parse-flags (rest as) true nocase?))
            ((equal? (first as) "-nocase") (parse-flags (rest as) all? true))
            (else {:all all? :nocase nocase? :rest as})))))
    (let ((pf (parse-flags args false false)))
      (let ((all-mode (get pf :all))
            (nocase (get pf :nocase))
            (ra (get pf :rest)))
        (if (< (len ra) 3)
          (error "regsub: wrong # args")
          (let ((pattern (first ra))
                (str-val (nth ra 1))
                (replacement (nth ra 2))
                (var-name (if (> (len ra) 3) (nth ra 3) nil)))
            (let ((re (make-regexp pattern (if nocase "i" ""))))
              (let ((result
                      (if all-mode
                        (regexp-replace-all re str-val replacement)
                        (regexp-replace re str-val replacement))))
                (if (nil? var-name)
                  (assoc interp :result result)
                  (let ((count
                          (if all-mode
                            (len (regexp-match-all re str-val))
                            (if (nil? (regexp-match re str-val)) 0 1))))
                    (assoc (tcl-var-set interp var-name result) :result (str count))))))))))))



(define
  tcl-cmd-file
  (fn
    (interp args)
    (if
      (= 0 (len args))
      (error "file: wrong # args")
      (let
        ((sub (first args)) (rest-args (rest args)))
        (cond
          ((equal? sub "exists") (assoc interp :result "0"))
          ((equal? sub "join") (assoc interp :result (join "/" rest-args)))
          ((equal? sub "split")
            (assoc
              interp
              :result (tcl-list-build
                (filter
                  (fn (s) (not (equal? s "")))
                  (split (first rest-args) "/")))))
          ((equal? sub "tail")
            (let
              ((parts (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/"))))
              (assoc
                interp
                :result (if (= 0 (len parts)) "" (last parts)))))
          ((equal? sub "dirname")
            (let
              ((parts (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/"))))
              (assoc
                interp
                :result (if
                  (<= (len parts) 1)
                  "."
                  (str
                    "/"
                    (join "/" (take-n parts (- (len parts) 1))))))))
          ((equal? sub "extension")
            (let
              ((nm (first rest-args)))
              (let
                ((dot-idx (tcl-string-last "." nm (- (string-length nm) 1))))
                (assoc
                  interp
                  :result (if
                    (equal? dot-idx "-1")
                    ""
                    (substring nm (parse-int dot-idx) (string-length nm)))))))
          ((equal? sub "rootname")
            (let
              ((nm (first rest-args)))
              (let
                ((dot-idx (tcl-string-last "." nm (- (string-length nm) 1))))
                (assoc
                  interp
                  :result (if
                    (equal? dot-idx "-1")
                    nm
                    (substring nm 0 (parse-int dot-idx)))))))
          ((equal? sub "isfile") (assoc interp :result "0"))
          ((equal? sub "isdir") (assoc interp :result "0"))
          ((equal? sub "isdirectory") (assoc interp :result "0"))
          ((equal? sub "readable") (assoc interp :result "0"))
          ((equal? sub "writable") (assoc interp :result "0"))
          ((equal? sub "size") (assoc interp :result "0"))
          ((equal? sub "mkdir") (assoc interp :result ""))
          ((equal? sub "copy") (assoc interp :result ""))
          ((equal? sub "rename") (assoc interp :result ""))
          ((equal? sub "delete") (assoc interp :result ""))
          (else (error (str "file: unknown subcommand \"" sub "\""))))))))

(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)))
                                              (let
                                                ((i (tcl-register i "scan" tcl-cmd-scan)))
                                                (let
                                                  ((i (tcl-register i "string" tcl-cmd-string)))
                                                  (let
                                                    ((i (tcl-register i "list" tcl-cmd-list)))
                                                    (let
                                                      ((i (tcl-register i "lindex" tcl-cmd-lindex)))
                                                      (let
                                                        ((i (tcl-register i "lrange" tcl-cmd-lrange)))
                                                        (let
                                                          ((i (tcl-register i "llength" tcl-cmd-llength)))
                                                          (let
                                                            ((i (tcl-register i "lreverse" tcl-cmd-lreverse)))
                                                            (let
                                                              ((i (tcl-register i "lsearch" tcl-cmd-lsearch)))
                                                              (let
                                                                ((i (tcl-register i "lsort" tcl-cmd-lsort)))
                                                                (let
                                                                  ((i (tcl-register i "lreplace" tcl-cmd-lreplace)))
                                                                  (let
                                                                    ((i (tcl-register i "linsert" tcl-cmd-linsert)))
                                                                    (let
                                                                      ((i (tcl-register i "concat" tcl-cmd-concat)))
                                                                      (let
                                                                        ((i (tcl-register i "split" tcl-cmd-split)))
                                                                        (let
                                                                          ((i (tcl-register i "join" tcl-cmd-join)))
                                                                          (let
                                                                            ((i (tcl-register i "dict" tcl-cmd-dict)))
                                                                            (let
                                                                              ((i (tcl-register i "proc" tcl-cmd-proc)))
                                                                              (let
                                                                                ((i (tcl-register i "uplevel" tcl-cmd-uplevel)))
                                                                                (let
                                                                                  ((i (tcl-register i "upvar" tcl-cmd-upvar)))
                                                                                  (let
                                                                                    ((i (tcl-register i "global" tcl-cmd-global)))
                                                                                    (let
                                                                                      ((i (tcl-register i "variable" tcl-cmd-variable)))
                                                                                      (let
                                                                                        ((i (tcl-register i "info" tcl-cmd-info)))
                                                                                        (let
                                                                                          ((i (tcl-register i "catch" tcl-cmd-catch)))
                                                                                          (let
                                                                                            ((i (tcl-register i "throw" tcl-cmd-throw)))
                                                                                            (let
                                                                                              ((i (tcl-register i "try" tcl-cmd-try)))
                                                                                              (let
                                                                                                ((i (tcl-register i "namespace" tcl-cmd-namespace)))
                                                                                                (let
                                                                                                  ((i (tcl-register i "coroutine" tcl-cmd-coroutine)))
                                                                                                  (let
                                                                                                    ((i (tcl-register i "yield" tcl-cmd-yield)))
                                                                                                    (let
                                                                                                      ((i (tcl-register i "yieldto" tcl-cmd-yieldto)))
                                                                                                      (let
                                                                                                        ((i (tcl-register i "clock" tcl-cmd-clock)))
                                                                                                        (let
                                                                                                          ((i (tcl-register i "open" tcl-cmd-open)))
                                                                                                          (let
                                                                                                            ((i (tcl-register i "close" tcl-cmd-close)))
                                                                                                            (let
                                                                                                              ((i (tcl-register i "read" tcl-cmd-read)))
                                                                                                              (let
                                                                                                                ((i (tcl-register i "eof" tcl-cmd-eof)))
                                                                                                                (let
                                                                                                                  ((i (tcl-register i "seek" tcl-cmd-seek)))
                                                                                                                  (let
                                                                                                                    ((i (tcl-register i "tell" tcl-cmd-tell)))
                                                                                                                    (let
                                                                                                                      ((i (tcl-register i "flush" tcl-cmd-flush)))
                                                                                                                      (let ((i (tcl-register i "file" tcl-cmd-file)))
                                                                                                                      (let ((i (tcl-register i "regexp" tcl-cmd-regexp)))
                                                                                                                        (let ((i (tcl-register i "regsub" tcl-cmd-regsub))) (let ((i (tcl-register i "apply" tcl-cmd-apply))) (tcl-register i "array" tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))