giles
263d9aae68
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 13s
Implements tcl-cmd-dict with create/get/set/unset/exists/keys/values/ size/for/update/merge/incr/append subcommands, plus helpers tcl-dict-to-pairs, tcl-dict-from-pairs, tcl-dict-get, tcl-dict-set-pair, tcl-dict-unset-key. Registers "dict" in make-default-tcl-interp. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
1953 lines
62 KiB
Plaintext
1953 lines
62 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")))
|
|
|
|
; --- string command helpers ---
|
|
|
|
; glob match: pattern chars list, string chars list
|
|
(define
|
|
tcl-glob-match
|
|
(fn
|
|
(pat-chars str-chars)
|
|
(cond
|
|
; both exhausted → success
|
|
((and (= 0 (len pat-chars)) (= 0 (len str-chars))) true)
|
|
; pattern exhausted but string remains → fail
|
|
((= 0 (len pat-chars)) false)
|
|
; leading * in pattern
|
|
((equal? (first pat-chars) "*")
|
|
(let
|
|
((rest-pat (rest pat-chars)))
|
|
; * can match zero chars (skip *) or consume one str char and retry
|
|
(if
|
|
(tcl-glob-match rest-pat str-chars)
|
|
true
|
|
(if
|
|
(= 0 (len str-chars))
|
|
false
|
|
(tcl-glob-match pat-chars (rest str-chars))))))
|
|
; string exhausted but pattern non-empty (and not *) → fail
|
|
((= 0 (len str-chars)) false)
|
|
; ? matches any single char
|
|
((equal? (first pat-chars) "?")
|
|
(tcl-glob-match (rest pat-chars) (rest str-chars)))
|
|
; literal match
|
|
((equal? (first pat-chars) (first str-chars))
|
|
(tcl-glob-match (rest pat-chars) (rest str-chars)))
|
|
; literal mismatch
|
|
(else false))))
|
|
|
|
; toupper/tolower via char tables
|
|
(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))))
|
|
|
|
(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))))
|
|
|
|
; strip chars from left
|
|
(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))))
|
|
|
|
; strip chars from right (reverse, trim left, reverse)
|
|
(define
|
|
tcl-reverse-list
|
|
(fn (lst) (reduce (fn (acc x) (append (list x) acc)) (list) lst)))
|
|
|
|
(define
|
|
tcl-trim-right-chars
|
|
(fn
|
|
(chars strip-set)
|
|
(tcl-reverse-list (tcl-trim-left-chars (tcl-reverse-list chars) strip-set))))
|
|
|
|
; default whitespace set
|
|
(define
|
|
tcl-ws-set
|
|
(list " " "\t" "\n" "\r"))
|
|
|
|
; string map: apply flat list of pairs old→new to string
|
|
(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 first: index of needle in haystack starting at start
|
|
(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))))))
|
|
|
|
; string last: last index of needle in haystack up to end
|
|
(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))))))))
|
|
|
|
; string is: check string class
|
|
(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")))))
|
|
|
|
(define
|
|
tcl-cmd-string
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "string: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
; string length s
|
|
((equal? sub "length")
|
|
(assoc interp :result (str (string-length (first rest-args)))))
|
|
; string index s i
|
|
((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)))))))
|
|
; string range s first last
|
|
((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))))))))
|
|
; string compare s1 s2
|
|
((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")))))
|
|
; string match pattern s
|
|
((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"))))
|
|
; string toupper s
|
|
((equal? sub "toupper")
|
|
(let
|
|
((s (first rest-args)))
|
|
(assoc
|
|
interp
|
|
:result
|
|
(join "" (map tcl-upcase-char (split s ""))))))
|
|
; string tolower s
|
|
((equal? sub "tolower")
|
|
(let
|
|
((s (first rest-args)))
|
|
(assoc
|
|
interp
|
|
:result
|
|
(join "" (map tcl-downcase-char (split s ""))))))
|
|
; string trim s ?chars?
|
|
((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))))))
|
|
; string trimleft s ?chars?
|
|
((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)))))
|
|
; string trimright s ?chars?
|
|
((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)))))
|
|
; string map mapping s
|
|
((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)))))
|
|
; string repeat s n
|
|
((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 "")))))
|
|
; string first needle haystack ?start?
|
|
((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))))
|
|
; string last needle haystack ?end?
|
|
((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))))
|
|
; string is class s
|
|
((equal? sub "is")
|
|
(let
|
|
((class (first rest-args)) (s (nth rest-args 1)))
|
|
(assoc interp :result (tcl-string-is class s))))
|
|
; string cat ?args...?
|
|
((equal? sub "cat")
|
|
(assoc interp :result (join "" rest-args)))
|
|
(else (error (str "string: unknown subcommand: " sub))))))))
|
|
|
|
|
|
; --- list command helpers ---
|
|
|
|
; Quote a single list element: add braces if it contains a space or is empty
|
|
(define
|
|
tcl-list-quote-elem
|
|
(fn
|
|
(elem)
|
|
(if
|
|
(or (equal? elem "") (contains? (split elem "") " "))
|
|
(str "{" elem "}")
|
|
elem)))
|
|
|
|
; Build a Tcl list string from an SX list of string elements
|
|
(define
|
|
tcl-list-build
|
|
(fn (elems) (join " " (map tcl-list-quote-elem elems))))
|
|
|
|
; Resolve "end" index to numeric value given list length
|
|
(define
|
|
tcl-end-index
|
|
(fn
|
|
(s n)
|
|
(if (equal? s "end") (- n 1) (parse-int s))))
|
|
|
|
; Insertion sort for list commands (comparator: fn(a b) -> true if a before b)
|
|
(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)))
|
|
|
|
; --- list commands ---
|
|
|
|
(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)))))
|
|
|
|
(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))))))
|
|
|
|
(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)))))
|
|
|
|
; --- dict command helpers ---
|
|
|
|
; Parse flat dict string into SX list of [key val] pairs
|
|
(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))))))
|
|
|
|
; Build flat dict string from SX list of [key val] pairs
|
|
(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))))
|
|
|
|
; Get value for key from flat dict string; returns nil if missing
|
|
(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)))))
|
|
|
|
; Set key=val in flat dict string; returns new flat dict string
|
|
(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)))))))))
|
|
|
|
; Remove key from flat dict string; returns new flat dict string
|
|
(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)))))
|
|
|
|
; --- dict command ---
|
|
|
|
(define
|
|
tcl-cmd-dict
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "dict: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
; dict create ?key val …?
|
|
((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))))
|
|
; dict get dict key
|
|
((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)))))
|
|
; dict set varname key val
|
|
((equal? sub "set")
|
|
(let
|
|
((varname (first rest-args))
|
|
(key (nth rest-args 1))
|
|
(val (nth rest-args 2)))
|
|
(let
|
|
((cur (let ((v (frame-lookup (get interp :frame) 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)))))
|
|
; dict unset varname key
|
|
((equal? sub "unset")
|
|
(let
|
|
((varname (first rest-args)) (key (nth rest-args 1)))
|
|
(let
|
|
((cur (let ((v (frame-lookup (get interp :frame) 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)))))
|
|
; dict exists dict key
|
|
((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"))))
|
|
; dict keys dict ?pattern?
|
|
((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))))))
|
|
; dict values dict
|
|
((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))))))
|
|
; dict size dict
|
|
((equal? sub "size")
|
|
(let
|
|
((dict-str (first rest-args)))
|
|
(assoc interp :result (str (len (tcl-dict-to-pairs dict-str))))))
|
|
; dict for {kvar vvar} dict body
|
|
((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))))))
|
|
; dict update varname key var … body
|
|
((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 (frame-lookup (get interp :frame) 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)))))))))
|
|
; dict merge ?dict…?
|
|
((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)))
|
|
; dict incr varname key ?increment?
|
|
((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 (frame-lookup (get interp :frame) 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)))))))
|
|
; dict append varname key ?string…?
|
|
((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 (frame-lookup (get interp :frame) 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 "\""))))))))
|
|
|
|
(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)))
|
|
(tcl-register i "dict" tcl-cmd-dict))))))))))))))))))))))))))))))))))))))
|