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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

(define
  tcl-expr-compute
  (fn
    (tokens)
    (let
      ((n (len tokens)))
      (cond
        ((= n 1) (first tokens))
        ((= n 2)
          (let
            ((op (first tokens)) (x (nth tokens 1)))
            (if
              (equal? op "!")
              (if (tcl-false? x) "1" "0")
              (error (str "expr: unknown unary op: " op)))))
        ((= n 3)
          (let
            ((l (first tokens)) (op (nth tokens 1)) (r (nth tokens 2)))
            (cond
              ((equal? op "+") (str (+ (parse-int l) (parse-int r))))
              ((equal? op "-") (str (- (parse-int l) (parse-int r))))
              ((equal? op "*") (str (* (parse-int l) (parse-int r))))
              ((equal? op "/") (str (/ (parse-int l) (parse-int r))))
              ((equal? op "%") (str (mod (parse-int l) (parse-int r))))
              ((equal? op "==") (if (equal? l r) "1" "0"))
              ((equal? op "!=") (if (equal? l r) "0" "1"))
              ((equal? op "<")
                (if (< (parse-int l) (parse-int r)) "1" "0"))
              ((equal? op ">")
                (if (> (parse-int l) (parse-int r)) "1" "0"))
              ((equal? op "<=")
                (if (<= (parse-int l) (parse-int r)) "1" "0"))
              ((equal? op ">=")
                (if (>= (parse-int l) (parse-int r)) "1" "0"))
              ((equal? op "&&")
                (if (and (tcl-true? l) (tcl-true? r)) "1" "0"))
              ((equal? op "||")
                (if (or (tcl-true? l) (tcl-true? r)) "1" "0"))
              (else (error (str "expr: unknown op: " op))))))
        (else (error (str "expr: complex expr not yet supported")))))))

(define
  tcl-expr-eval
  (fn
    (interp s)
    (let
      ((cmds (tcl-parse s)))
      (if
        (= 0 (len cmds))
        {:result "0" :interp interp}
        (let
          ((wr (tcl-eval-words (get (first cmds) :words) interp)))
          {:result (tcl-expr-compute (get wr :values)) :interp (get wr :interp)})))))

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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

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