; Tcl-on-SX runtime evaluator
; State: {:frame frame :commands cmd-table :result last-result :output accumulated-output}

(define make-frame (fn (level parent) {:level level :locals {} :parent parent}))

(define
  frame-lookup
  (fn
    (frame name)
    (if
      (nil? frame)
      nil
      (let
        ((val (get (get frame :locals) name)))
        (if (nil? val) (frame-lookup (get frame :parent) name) val)))))

(define
  frame-set-top
  (fn
    (frame name val)
    (assoc frame :locals (assoc (get frame :locals) name val))))

(define make-tcl-interp (fn () {:result "" :output "" :code 0 :frame (make-frame 0 nil) :commands {}}))

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

(define
  tcl-var-get
  (fn
    (interp name)
    (let
      ((val (frame-lookup (get interp :frame) name)))
      (if
        (nil? val)
        (error (str "can't read \"" name "\": no such variable"))
        val))))

(define
  tcl-var-set
  (fn
    (interp name val)
    (assoc interp :frame (frame-set-top (get interp :frame) name val))))

(define
  tcl-eval-parts
  (fn
    (parts interp)
    (reduce
      (fn
        (acc part)
        (let
          ((type (get part :type)) (cur-interp (get acc :interp)))
          (cond
            ((equal? type "text") {:values (append (get acc :values) (list (get part :value))) :interp cur-interp})
            ((equal? type "var") {:values (append (get acc :values) (list (tcl-var-get cur-interp (get part :name)))) :interp cur-interp})
            ((equal? type "var-arr")
              (let
                ((key-acc (tcl-eval-parts (get part :key) cur-interp)))
                (let
                  ((key (join "" (get key-acc :values)))
                    (next-interp (get key-acc :interp)))
                  {:values (append (get acc :values) (list (tcl-var-get next-interp (str (get part :name) "(" key ")")))) :interp next-interp})))
            ((equal? type "cmd")
              (let
                ((new-interp (tcl-eval-string cur-interp (get part :src))))
                {:values (append (get acc :values) (list (get new-interp :result))) :interp new-interp}))
            (else (error (str "tcl: unknown part type: " type))))))
      {:values (quote ()) :interp interp}
      parts)))

(define
  tcl-eval-word
  (fn
    (word interp)
    (let
      ((type (get word :type)))
      (cond
        ((equal? type "braced") {:interp interp :value (get word :value)})
        ((equal? type "compound")
          (let
            ((result (tcl-eval-parts (get word :parts) interp)))
            {:interp (get result :interp) :value (join "" (get result :values))}))
        ((equal? type "expand") (tcl-eval-word (get word :word) interp))
        (else (error (str "tcl: unknown word type: " type)))))))

(define
  tcl-list-split
  (fn
    (s)
    (define chars (split s ""))
    (define len-s (len chars))
    (define
      go
      (fn
        (i acc cur-item depth)
        (if
          (>= i len-s)
          (if (> (len cur-item) 0) (append acc (list cur-item)) acc)
          (let
            ((c (nth chars i)))
            (cond
              ((equal? c "{")
                (if
                  (= depth 0)
                  (go (+ i 1) acc "" (+ depth 1))
                  (go (+ i 1) acc (str cur-item c) (+ depth 1))))
              ((equal? c "}")
                (if
                  (= depth 1)
                  (go (+ i 1) (append acc (list cur-item)) "" 0)
                  (go (+ i 1) acc (str cur-item c) (- depth 1))))
              ((equal? c " ")
                (if
                  (and (= depth 0) (> (len cur-item) 0))
                  (go (+ i 1) (append acc (list cur-item)) "" 0)
                  (go
                    (+ i 1)
                    acc
                    (if (> depth 0) (str cur-item c) cur-item)
                    depth)))
              (else (go (+ i 1) acc (str cur-item c) depth)))))))
    (go 0 (list) "" 0)))

(define
  tcl-eval-words
  (fn
    (words interp)
    (reduce
      (fn
        (acc w)
        (let
          ((cur-interp (get acc :interp)))
          (if
            (equal? (get w :type) "expand")
            (let
              ((wr (tcl-eval-word (get w :word) cur-interp)))
              {:values (append (get acc :values) (tcl-list-split (get wr :value))) :interp (get wr :interp)})
            (let ((wr (tcl-eval-word w cur-interp))) {:values (append (get acc :values) (list (get wr :value))) :interp (get wr :interp)}))))
      {:values (quote ()) :interp interp}
      words)))

(define
  tcl-eval-cmd
  (fn
    (interp cmd)
    (let
      ((wr (tcl-eval-words (get cmd :words) interp)))
      (let
        ((words (get wr :values)) (cur-interp (get wr :interp)))
        (if
          (= 0 (len words))
          cur-interp
          (let
            ((cmd-name (first words)) (cmd-args (rest words)))
            (let
              ((cmd-fn (get (get cur-interp :commands) cmd-name)))
              (if
                (nil? cmd-fn)
                (error (str "unknown command: \"" cmd-name "\""))
                (cmd-fn cur-interp cmd-args)))))))))

(define
  tcl-eval-script
  (fn
    (interp cmds)
    (if
      (or (= 0 (len cmds)) (not (= 0 (get interp :code))))
      interp
      (tcl-eval-script (tcl-eval-cmd interp (first cmds)) (rest cmds)))))

(define
  tcl-eval-string
  (fn (interp src) (tcl-eval-script interp (tcl-parse src))))

(define
  tcl-cmd-set
  (fn
    (interp args)
    (if
      (= (len args) 1)
      (assoc interp :result (tcl-var-get interp (first args)))
      (let
        ((val (nth args 1)))
        (assoc (tcl-var-set interp (first args) val) :result val)))))

(define
  tcl-cmd-puts
  (fn
    (interp args)
    (let
      ((text (last args))
        (no-nl
          (and
            (> (len args) 1)
            (equal? (first args) "-nonewline"))))
      (let
        ((line (if no-nl text (str text "\n"))))
        (assoc interp :output (str (get interp :output) line))))))

(define
  tcl-cmd-incr
  (fn
    (interp args)
    (let
      ((name (first args))
        (delta
          (if
            (> (len args) 1)
            (parse-int (nth args 1))
            1)))
      (let
        ((new-val (str (+ (parse-int (tcl-var-get interp name)) delta))))
        (assoc (tcl-var-set interp name new-val) :result new-val)))))

(define
  tcl-cmd-append
  (fn
    (interp args)
    (let
      ((name (first args)) (suffix (join "" (rest args))))
      (let
        ((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
        (let
          ((new-val (str cur suffix)))
          (assoc (tcl-var-set interp name new-val) :result new-val))))))

(define
  tcl-true?
  (fn
    (s)
    (not
      (or (equal? s "0") (equal? s "") (equal? s "false") (equal? s "no")))))

(define tcl-false? (fn (s) (not (tcl-true? s))))

(define
  tcl-expr-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-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-int (first args)) 0))
        (a1 (if (> (len args) 1) (parse-int (nth args 1)) 0)))
      (cond
        ((equal? name "abs") (str (if (< a0 0) (- 0 a0) a0)))
        ((equal? name "int") (str a0))
        ((equal? name "double") (str a0))
        ((equal? name "round") (str a0))
        ((equal? name "floor") (str a0))
        ((equal? name "ceil") (str a0))
        ((equal? name "sqrt") (str (tcl-isqrt a0)))
        ((equal? name "pow") (str (tcl-pow a0 a1)))
        ((equal? name "max") (str (if (>= a0 a1) a0 a1)))
        ((equal? name "min") (str (if (<= a0 a1) a0 a1)))
        ((equal? name "sin") "0")
        ((equal? name "cos") "1")
        ((equal? name "tan") "0")
        (else (error (str "expr: unknown function: " name)))))))

(define
  tcl-apply-binop
  (fn
    (op l r)
    (cond
      ((equal? op "+") (str (+ (parse-int l) (parse-int r))))
      ((equal? op "-") (str (- (parse-int l) (parse-int r))))
      ((equal? op "*") (str (* (parse-int l) (parse-int r))))
      ((equal? op "/") (str (/ (parse-int l) (parse-int r))))
      ((equal? op "%") (str (mod (parse-int l) (parse-int r))))
      ((equal? op "==") (if (equal? l r) "1" "0"))
      ((equal? op "!=") (if (equal? l r) "0" "1"))
      ((equal? op "<") (if (< (parse-int l) (parse-int r)) "1" "0"))
      ((equal? op ">") (if (> (parse-int l) (parse-int r)) "1" "0"))
      ((equal? op "<=") (if (<= (parse-int l) (parse-int r)) "1" "0"))
      ((equal? op ">=") (if (>= (parse-int l) (parse-int r)) "1" "0"))
      ((equal? op "&&") (if (and (tcl-true? l) (tcl-true? r)) "1" "0"))
      ((equal? op "||") (if (or (tcl-true? l) (tcl-true? r)) "1" "0"))
      ((equal? op "**") (str (tcl-pow (parse-int l) (parse-int r))))
      (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) ")"))
                  {:value (get inner :value) :tokens (rest after)}
                  (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) ")"))
                  {:value (tcl-apply-func tok (get args-r :args)) :tokens (rest after-args)}
                  (error (str "expr: missing ) after function call " tok))))))
          (else {:value tok :tokens rest-toks}))))))

(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))))
              {:value (if (tcl-false? (get r :value)) "1" "0") :tokens (get r :tokens)}))
          ((equal? tok "-")
            (let
              ((r (tcl-expr-parse-unary (rest tokens))))
              {:value (str (- 0 (parse-int (get r :value)))) :tokens (get r :tokens)}))
          ((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))))
            {:value (str (tcl-pow (parse-int base-val) (parse-int (get exp-r :value)))) :tokens (get exp-r :tokens)})
          {:value base-val :tokens rest-toks})))))

(define
  tcl-expr-parse-multiplicative-rest
  (fn
    (tokens left)
    (if
      (or (= 0 (len tokens)) (not (contains? (list "*" "/" "%") (first tokens))))
      {:value left :tokens tokens}
      (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))))
      {:value left :tokens tokens}
      (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))))
      {:value left :tokens tokens}
      (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))))
      {:value left :tokens tokens}
      (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) "&&")))
      {:value left :tokens tokens}
      (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) "||")))
      {:value left :tokens tokens}
      (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)})))))))

(define tcl-cmd-break (fn (interp args) (assoc interp :code 3)))

(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4)))

(define
  tcl-cmd-return
  (fn
    (interp args)
    (let
      ((val (if (> (len args) 0) (last args) "")))
      (assoc (assoc interp :result val) :code 2))))

(define
  tcl-cmd-error
  (fn
    (interp args)
    (let
      ((msg (if (> (len args) 0) (first args) "error")))
      (assoc (assoc interp :result msg) :code 1))))

(define
  tcl-cmd-unset
  (fn
    (interp args)
    (reduce
      (fn
        (i name)
        (let
          ((frame (get i :frame)))
          (let
            ((new-locals (reduce (fn (acc k) (if (equal? k name) acc (assoc acc k (get (get frame :locals) k)))) {} (keys (get frame :locals)))))
            (assoc i :frame (assoc frame :locals new-locals)))))
      interp
      args)))

(define
  tcl-cmd-lappend
  (fn
    (interp args)
    (let
      ((name (first args)) (items (rest args)))
      (let
        ((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" v))))
        (let
          ((new-val (if (equal? cur "") (join " " items) (str cur " " (join " " items)))))
          (assoc (tcl-var-set interp name new-val) :result new-val))))))

(define
  tcl-cmd-eval
  (fn (interp args) (tcl-eval-string interp (join " " args))))

(define
  tcl-while-loop
  (fn
    (interp cond-str body)
    (let
      ((er (tcl-expr-eval interp cond-str)))
      (if
        (tcl-false? (get er :result))
        (get er :interp)
        (let
          ((body-result (tcl-eval-string (get er :interp) body)))
          (let
            ((code (get body-result :code)))
            (cond
              ((= code 3) (assoc body-result :code 0))
              ((= code 2) body-result)
              ((= code 1) body-result)
              (else
                (tcl-while-loop
                  (assoc body-result :code 0)
                  cond-str
                  body)))))))))

(define
  tcl-cmd-while
  (fn
    (interp args)
    (tcl-while-loop interp (first args) (nth args 1))))

(define
  tcl-cmd-if
  (fn
    (interp args)
    (let
      ((er (tcl-expr-eval interp (first args))))
      (let
        ((cond-true (tcl-true? (get er :result)))
          (new-interp (get er :interp))
          (rest-args (rest args)))
        (let
          ((adj (if (and (> (len rest-args) 0) (equal? (first rest-args) "then")) (rest rest-args) rest-args)))
          (let
            ((then-body (first adj)) (rest2 (rest adj)))
            (if
              cond-true
              (tcl-eval-string new-interp then-body)
              (cond
                ((= 0 (len rest2)) new-interp)
                ((equal? (first rest2) "else")
                  (if
                    (> (len rest2) 1)
                    (tcl-eval-string new-interp (nth rest2 1))
                    new-interp))
                ((equal? (first rest2) "elseif")
                  (tcl-cmd-if new-interp (rest rest2)))
                (else new-interp)))))))))

(define
  tcl-for-loop
  (fn
    (interp cond-str step body)
    (let
      ((er (tcl-expr-eval interp cond-str)))
      (if
        (tcl-false? (get er :result))
        (get er :interp)
        (let
          ((body-result (tcl-eval-string (get er :interp) body)))
          (let
            ((code (get body-result :code)))
            (cond
              ((= code 3) (assoc body-result :code 0))
              ((= code 2) body-result)
              ((= code 1) body-result)
              (else
                (let
                  ((step-result (tcl-eval-string (assoc body-result :code 0) step)))
                  (tcl-for-loop
                    (assoc step-result :code 0)
                    cond-str
                    step
                    body))))))))))

(define
  tcl-cmd-for
  (fn
    (interp args)
    (let
      ((init-body (first args))
        (cond-str (nth args 1))
        (step (nth args 2))
        (body (nth args 3)))
      (let
        ((init-result (tcl-eval-string interp init-body)))
        (tcl-for-loop init-result cond-str step body)))))

(define
  tcl-foreach-loop
  (fn
    (interp var-name items body)
    (if
      (= 0 (len items))
      interp
      (let
        ((body-result (tcl-eval-string (tcl-var-set interp var-name (first items)) body)))
        (let
          ((code (get body-result :code)))
          (cond
            ((= code 3) (assoc body-result :code 0))
            ((= code 2) body-result)
            ((= code 1) body-result)
            (else
              (tcl-foreach-loop
                (assoc body-result :code 0)
                var-name
                (rest items)
                body))))))))

(define
  tcl-cmd-foreach
  (fn
    (interp args)
    (let
      ((var-name (first args))
        (list-str (nth args 1))
        (body (nth args 2)))
      (tcl-foreach-loop interp var-name (tcl-list-split list-str) body))))

(define
  tcl-cmd-switch
  (fn
    (interp args)
    (let
      ((str-val (first args)) (body (nth args 1)))
      (let
        ((pairs (tcl-list-split body)))
        (define
          try-pairs
          (fn
            (ps)
            (if
              (= 0 (len ps))
              interp
              (let
                ((pat (first ps)) (bdy (nth ps 1)))
                (if
                  (or (equal? pat str-val) (equal? pat "default"))
                  (if
                    (equal? bdy "-")
                    (try-pairs (rest (rest ps)))
                    (tcl-eval-string interp bdy))
                  (try-pairs (rest (rest ps))))))))
        (try-pairs pairs)))))

(define
  tcl-cmd-expr
  (fn
    (interp args)
    (let
      ((s (join " " args)))
      (let
        ((er (tcl-expr-eval interp s)))
        (assoc (get er :interp) :result (get er :result))))))

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

(define
  tcl-cmd-subst
  (fn (interp args) (assoc interp :result (last args))))

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

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

(define
  make-default-tcl-interp
  (fn
    ()
    (let
      ((i (make-tcl-interp)))
      (let
        ((i (tcl-register i "set" tcl-cmd-set)))
        (let
          ((i (tcl-register i "puts" tcl-cmd-puts)))
          (let
            ((i (tcl-register i "incr" tcl-cmd-incr)))
            (let
              ((i (tcl-register i "append" tcl-cmd-append)))
              (let
                ((i (tcl-register i "unset" tcl-cmd-unset)))
                (let
                  ((i (tcl-register i "lappend" tcl-cmd-lappend)))
                  (let
                    ((i (tcl-register i "eval" tcl-cmd-eval)))
                    (let
                      ((i (tcl-register i "if" tcl-cmd-if)))
                      (let
                        ((i (tcl-register i "while" tcl-cmd-while)))
                        (let
                          ((i (tcl-register i "for" tcl-cmd-for)))
                          (let
                            ((i (tcl-register i "foreach" tcl-cmd-foreach)))
                            (let
                              ((i (tcl-register i "switch" tcl-cmd-switch)))
                              (let
                                ((i (tcl-register i "break" tcl-cmd-break)))
                                (let
                                  ((i (tcl-register i "continue" tcl-cmd-continue)))
                                  (let
                                    ((i (tcl-register i "return" tcl-cmd-return)))
                                    (let
                                      ((i (tcl-register i "error" tcl-cmd-error)))
                                      (let
                                        ((i (tcl-register i "expr" tcl-cmd-expr)))
                                        (let
                                          ((i (tcl-register i "gets" tcl-cmd-gets)))
                                          (let
                                            ((i (tcl-register i "subst" tcl-cmd-subst)))
                                            (let
                                              ((i (tcl-register i "format" tcl-cmd-format)))
                                              (tcl-register
                                                i
                                                "scan"
                                                tcl-cmd-scan))))))))))))))))))))))))