giles
ac013c9381
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 42s
Replaces 3-token flat evaluator with full recursive descent parser: operator precedence, parentheses, unary ops, ** power, function calls (abs/sqrt/pow/max/min/int/double), expression tokenizer for dense syntax. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
956 lines
29 KiB
Plaintext
956 lines
29 KiB
Plaintext
; 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))))))))))))))))))))))))
|