giles
23c44cf6cf
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Has been cancelled
Implements namespace eval, current, which, exists, delete, export, import, forget, path, and ensemble create (auto-map + -map). Procs defined inside namespace eval are stored as fully-qualified names (::ns::proc), resolved relative to the calling namespace at lookup time. Proc bodies execute in their defining namespace so sibling calls work without qualification. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2876 lines
97 KiB
Plaintext
2876 lines
97 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 :errorinfo "" :errorcode "" :frame (make-frame 0 nil) :frame-stack (list) :procs {} :commands {} :current-ns "::"}))
|
|
|
|
(define
|
|
tcl-register
|
|
(fn
|
|
(interp name f)
|
|
(assoc interp :commands (assoc (get interp :commands) name f))))
|
|
|
|
; --- upvar alias helpers ---
|
|
|
|
(define upvar-alias? (fn (v) (and (dict? v) (not (nil? (get v :upvar-level))))))
|
|
|
|
; take first n elements of a list
|
|
(define
|
|
take-n
|
|
(fn
|
|
(lst n)
|
|
(if
|
|
(or (<= n 0) (= 0 (len lst)))
|
|
(list)
|
|
(append (list (first lst)) (take-n (rest lst) (- n 1))))))
|
|
|
|
; replace element at index i in list with val (0-based)
|
|
(define
|
|
replace-at
|
|
(fn
|
|
(lst i val)
|
|
(let
|
|
((go
|
|
(fn
|
|
(remaining j acc)
|
|
(if
|
|
(= 0 (len remaining))
|
|
acc
|
|
(go
|
|
(rest remaining)
|
|
(+ j 1)
|
|
(append acc (list (if (= j i) val (first remaining)))))))))
|
|
(go lst 0 (list)))))
|
|
|
|
; build full-stack = frame-stack + [current-frame]
|
|
(define
|
|
tcl-full-stack
|
|
(fn (interp)
|
|
(append (get interp :frame-stack) (list (get interp :frame)))))
|
|
|
|
; get target frame at absolute level from full-stack
|
|
(define
|
|
tcl-frame-nth
|
|
(fn (full-stack level)
|
|
(nth full-stack level)))
|
|
|
|
(define
|
|
tcl-var-get
|
|
(fn
|
|
(interp name)
|
|
(let
|
|
((val (frame-lookup (get interp :frame) name)))
|
|
(if
|
|
(nil? val)
|
|
(error (str "can't read \"" name "\": no such variable"))
|
|
(if
|
|
(upvar-alias? val)
|
|
; follow alias to target frame
|
|
(let
|
|
((target-level (get val :upvar-level))
|
|
(target-name (get val :upvar-name)))
|
|
(let
|
|
((full-stack (tcl-full-stack interp)))
|
|
(let
|
|
((target-frame (tcl-frame-nth full-stack target-level)))
|
|
(let
|
|
((target-val (frame-lookup target-frame target-name)))
|
|
(if
|
|
(nil? target-val)
|
|
(error (str "can't read \"" name "\": no such variable"))
|
|
target-val)))))
|
|
val)))))
|
|
|
|
(define
|
|
tcl-var-set
|
|
(fn
|
|
(interp name val)
|
|
(let
|
|
((cur-val (get (get (get interp :frame) :locals) name)))
|
|
(if
|
|
(and (not (nil? cur-val)) (upvar-alias? cur-val))
|
|
; set in target frame
|
|
(let
|
|
((target-level (get cur-val :upvar-level))
|
|
(target-name (get cur-val :upvar-name)))
|
|
(let
|
|
((full-stack (tcl-full-stack interp)))
|
|
(let
|
|
((target-frame (tcl-frame-nth full-stack target-level)))
|
|
(let
|
|
((updated-target (frame-set-top target-frame target-name val)))
|
|
(let
|
|
((new-full-stack (replace-at full-stack target-level updated-target)))
|
|
(let
|
|
((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1)))
|
|
(new-current (nth new-full-stack (- (len new-full-stack) 1))))
|
|
(assoc interp :frame new-current :frame-stack new-frame-stack)))))))
|
|
; normal set in current frame top
|
|
(assoc interp :frame (frame-set-top (get interp :frame) name val))))))
|
|
|
|
(define
|
|
tcl-eval-parts
|
|
(fn
|
|
(parts interp)
|
|
(reduce
|
|
(fn
|
|
(acc part)
|
|
(let
|
|
((type (get part :type)) (cur-interp (get acc :interp)))
|
|
(cond
|
|
((equal? type "text") {:values (append (get acc :values) (list (get part :value))) :interp cur-interp})
|
|
((equal? type "var") {:values (append (get acc :values) (list (tcl-var-get cur-interp (get part :name)))) :interp cur-interp})
|
|
((equal? type "var-arr")
|
|
(let
|
|
((key-acc (tcl-eval-parts (get part :key) cur-interp)))
|
|
(let
|
|
((key (join "" (get key-acc :values)))
|
|
(next-interp (get key-acc :interp)))
|
|
{:values (append (get acc :values) (list (tcl-var-get next-interp (str (get part :name) "(" key ")")))) :interp next-interp})))
|
|
((equal? type "cmd")
|
|
(let
|
|
((new-interp (tcl-eval-string cur-interp (get part :src))))
|
|
{:values (append (get acc :values) (list (get new-interp :result))) :interp new-interp}))
|
|
(else (error (str "tcl: unknown part type: " type))))))
|
|
{:values (quote ()) :interp interp}
|
|
parts)))
|
|
|
|
(define
|
|
tcl-eval-word
|
|
(fn
|
|
(word interp)
|
|
(let
|
|
((type (get word :type)))
|
|
(cond
|
|
((equal? type "braced") {:interp interp :value (get word :value)})
|
|
((equal? type "compound")
|
|
(let
|
|
((result (tcl-eval-parts (get word :parts) interp)))
|
|
{:interp (get result :interp) :value (join "" (get result :values))}))
|
|
((equal? type "expand") (tcl-eval-word (get word :word) interp))
|
|
(else (error (str "tcl: unknown word type: " type)))))))
|
|
|
|
(define
|
|
tcl-list-split
|
|
(fn
|
|
(s)
|
|
(define chars (split s ""))
|
|
(define len-s (len chars))
|
|
(define
|
|
go
|
|
(fn
|
|
(i acc cur-item depth)
|
|
(if
|
|
(>= i len-s)
|
|
(if (> (len cur-item) 0) (append acc (list cur-item)) acc)
|
|
(let
|
|
((c (nth chars i)))
|
|
(cond
|
|
((equal? c "{")
|
|
(if
|
|
(= depth 0)
|
|
(go (+ i 1) acc "" (+ depth 1))
|
|
(go (+ i 1) acc (str cur-item c) (+ depth 1))))
|
|
((equal? c "}")
|
|
(if
|
|
(= depth 1)
|
|
(go (+ i 1) (append acc (list cur-item)) "" 0)
|
|
(go (+ i 1) acc (str cur-item c) (- depth 1))))
|
|
((equal? c " ")
|
|
(if
|
|
(and (= depth 0) (> (len cur-item) 0))
|
|
(go (+ i 1) (append acc (list cur-item)) "" 0)
|
|
(go
|
|
(+ i 1)
|
|
acc
|
|
(if (> depth 0) (str cur-item c) cur-item)
|
|
depth)))
|
|
(else (go (+ i 1) acc (str cur-item c) depth)))))))
|
|
(go 0 (list) "" 0)))
|
|
|
|
(define
|
|
tcl-eval-words
|
|
(fn
|
|
(words interp)
|
|
(reduce
|
|
(fn
|
|
(acc w)
|
|
(let
|
|
((cur-interp (get acc :interp)))
|
|
(if
|
|
(equal? (get w :type) "expand")
|
|
(let
|
|
((wr (tcl-eval-word (get w :word) cur-interp)))
|
|
{:values (append (get acc :values) (tcl-list-split (get wr :value))) :interp (get wr :interp)})
|
|
(let ((wr (tcl-eval-word w cur-interp))) {:values (append (get acc :values) (list (get wr :value))) :interp (get wr :interp)}))))
|
|
{:values (quote ()) :interp interp}
|
|
words)))
|
|
|
|
; --- proc call ---
|
|
|
|
; Bind proc parameters: returns updated frame
|
|
(define
|
|
tcl-bind-params
|
|
(fn
|
|
(frame params call-args)
|
|
(if
|
|
(= 0 (len params))
|
|
frame
|
|
(let
|
|
((pname (first params)) (rest-ps (rest params)))
|
|
(if
|
|
(equal? pname "args")
|
|
; rest param: collect remaining call-args as list string
|
|
(frame-set-top frame "args" (tcl-list-build call-args))
|
|
(if
|
|
(= 0 (len call-args))
|
|
(error (str "wrong # args: no value for parameter \"" pname "\""))
|
|
(tcl-bind-params
|
|
(frame-set-top frame pname (first call-args))
|
|
rest-ps
|
|
(rest call-args))))))))
|
|
|
|
(define
|
|
tcl-call-proc
|
|
(fn
|
|
(interp proc-name proc-def call-args)
|
|
(let
|
|
((param-spec (get proc-def :args))
|
|
(body (get proc-def :body)))
|
|
(let
|
|
((params (if (equal? param-spec "") (list) (tcl-list-split param-spec))))
|
|
(let
|
|
((caller-stack-len (len (get interp :frame-stack)))
|
|
(new-frame (make-frame (+ (len (get interp :frame-stack)) 1) nil)))
|
|
(let
|
|
((bound-frame (tcl-bind-params new-frame params call-args)))
|
|
(let
|
|
((proc-ns (let ((ns (get proc-def :ns))) (if (nil? ns) (get interp :current-ns) ns))))
|
|
(let
|
|
((proc-interp
|
|
(assoc interp
|
|
:frame bound-frame
|
|
:frame-stack (append (get interp :frame-stack) (list (get interp :frame)))
|
|
:output ""
|
|
:result ""
|
|
:code 0
|
|
:current-ns proc-ns))
|
|
(caller-output (get interp :output)))
|
|
(let
|
|
((result-interp (tcl-eval-string proc-interp body)))
|
|
(let
|
|
((code (get result-interp :code))
|
|
(result-val (get result-interp :result))
|
|
(proc-output (get result-interp :output)))
|
|
(let
|
|
; result-stack = [updated-frame-0..updated-caller-frame]
|
|
; recover updated caller frame and below-caller frames
|
|
((result-stack (get result-interp :frame-stack)))
|
|
(let
|
|
((updated-below (take-n result-stack caller-stack-len))
|
|
(updated-caller
|
|
(if
|
|
(> (len result-stack) caller-stack-len)
|
|
(nth result-stack caller-stack-len)
|
|
(get interp :frame))))
|
|
(assoc interp
|
|
:frame updated-caller
|
|
:frame-stack updated-below
|
|
:result result-val
|
|
:output (str caller-output proc-output)
|
|
:code (if (= code 2) 0 code))))))))))))))
|
|
|
|
(define
|
|
tcl-eval-cmd
|
|
(fn
|
|
(interp cmd)
|
|
(let
|
|
((wr (tcl-eval-words (get cmd :words) interp)))
|
|
(let
|
|
((words (get wr :values)) (cur-interp (get wr :interp)))
|
|
(if
|
|
(= 0 (len words))
|
|
cur-interp
|
|
(let
|
|
((cmd-name (first words)) (cmd-args (rest words)))
|
|
(let
|
|
((cmd-fn (get (get cur-interp :commands) cmd-name)))
|
|
(if
|
|
(nil? cmd-fn)
|
|
(let
|
|
((proc-entry (tcl-proc-lookup cur-interp cmd-name)))
|
|
(if
|
|
(nil? proc-entry)
|
|
(error (str "unknown command: \"" cmd-name "\""))
|
|
(tcl-call-proc cur-interp (get proc-entry :name) (get proc-entry :def) cmd-args)))
|
|
(cmd-fn cur-interp cmd-args)))))))))
|
|
|
|
(define
|
|
tcl-eval-script
|
|
(fn
|
|
(interp cmds)
|
|
(if
|
|
(or (= 0 (len cmds)) (not (= 0 (get interp :code))))
|
|
interp
|
|
(tcl-eval-script (tcl-eval-cmd interp (first cmds)) (rest cmds)))))
|
|
|
|
(define
|
|
tcl-eval-string
|
|
(fn (interp src) (tcl-eval-script interp (tcl-parse src))))
|
|
|
|
(define
|
|
tcl-cmd-set
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= (len args) 1)
|
|
(assoc interp :result (tcl-var-get interp (first args)))
|
|
(let
|
|
((val (nth args 1)))
|
|
(assoc (tcl-var-set interp (first args) val) :result val)))))
|
|
|
|
(define
|
|
tcl-cmd-puts
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((text (last args))
|
|
(no-nl
|
|
(and
|
|
(> (len args) 1)
|
|
(equal? (first args) "-nonewline"))))
|
|
(let
|
|
((line (if no-nl text (str text "\n"))))
|
|
(assoc interp :output (str (get interp :output) line))))))
|
|
|
|
(define
|
|
tcl-cmd-incr
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((name (first args))
|
|
(delta
|
|
(if
|
|
(> (len args) 1)
|
|
(parse-int (nth args 1))
|
|
1)))
|
|
(let
|
|
((new-val (str (+ (parse-int (tcl-var-get interp name)) delta))))
|
|
(assoc (tcl-var-set interp name new-val) :result new-val)))))
|
|
|
|
(define
|
|
tcl-cmd-append
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((name (first args)) (suffix (join "" (rest args))))
|
|
(let
|
|
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" 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)))
|
|
|
|
; Parse -code name/number to integer
|
|
(define
|
|
tcl-return-code-num
|
|
(fn
|
|
(s)
|
|
(cond
|
|
((equal? s "ok") 0)
|
|
((equal? s "error") 1)
|
|
((equal? s "return") 2)
|
|
((equal? s "break") 3)
|
|
((equal? s "continue") 4)
|
|
(else (parse-int s)))))
|
|
|
|
; Parse return options from args list
|
|
; Returns {:code N :result val :errorinfo str :errorcode str}
|
|
(define
|
|
tcl-parse-return-opts
|
|
(fn
|
|
(args)
|
|
(let
|
|
((go
|
|
(fn
|
|
(remaining code ei ec)
|
|
(if
|
|
(or (= 0 (len remaining)) (not (equal? (substring (first remaining) 0 1) "-")))
|
|
{:code code :result (if (> (len remaining) 0) (first remaining) "") :errorinfo ei :errorcode ec}
|
|
(let
|
|
((flag (first remaining)) (rest1 (rest remaining)))
|
|
(cond
|
|
((equal? flag "-code")
|
|
(if
|
|
(= 0 (len rest1))
|
|
{:code code :result "" :errorinfo ei :errorcode ec}
|
|
(go (rest rest1) (tcl-return-code-num (first rest1)) ei ec)))
|
|
((equal? flag "-errorinfo")
|
|
(if
|
|
(= 0 (len rest1))
|
|
{:code code :result "" :errorinfo "" :errorcode ec}
|
|
(go (rest rest1) code (first rest1) ec)))
|
|
((equal? flag "-errorcode")
|
|
(if
|
|
(= 0 (len rest1))
|
|
{:code code :result "" :errorinfo ei :errorcode ""}
|
|
(go (rest rest1) code ei (first rest1))))
|
|
((equal? flag "-level")
|
|
; stub: consume the level arg and ignore
|
|
(if
|
|
(= 0 (len rest1))
|
|
{:code code :result "" :errorinfo ei :errorcode ec}
|
|
(go (rest rest1) code ei ec)))
|
|
(else
|
|
; unknown flag: treat as value
|
|
{:code code :result flag :errorinfo ei :errorcode ec})))))))
|
|
(go args 2 "" ""))))
|
|
|
|
(define
|
|
tcl-cmd-return
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((opts (tcl-parse-return-opts args)))
|
|
(assoc interp
|
|
:result (get opts :result)
|
|
:code (get opts :code)
|
|
:errorinfo (get opts :errorinfo)
|
|
:errorcode (get opts :errorcode)))))
|
|
|
|
(define
|
|
tcl-cmd-error
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((msg (if (> (len args) 0) (first args) "error"))
|
|
(ei (if (> (len args) 1) (nth args 1) ""))
|
|
(ec (if (> (len args) 2) (nth args 2) "")))
|
|
(assoc interp :result msg :code 1 :errorinfo ei :errorcode ec))))
|
|
|
|
; --- catch command ---
|
|
; catch script ?resultVar? ?optionsVar?
|
|
(define
|
|
tcl-cmd-catch
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((script (first args))
|
|
(result-var (if (> (len args) 1) (nth args 1) nil))
|
|
(opts-var (if (> (len args) 2) (nth args 2) nil)))
|
|
(let
|
|
; run script in a sub-interp with code/result/output reset
|
|
((sub-interp (assoc interp :code 0 :result "" :output ""))
|
|
(caller-output (get interp :output)))
|
|
(let
|
|
((result-interp (tcl-eval-string sub-interp script)))
|
|
(let
|
|
((rc (get result-interp :code))
|
|
(rv (get result-interp :result))
|
|
(rei (get result-interp :errorinfo))
|
|
(rec (get result-interp :errorcode))
|
|
(sub-output (get result-interp :output)))
|
|
(let
|
|
; merge sub-interp frame changes back but reset code to 0
|
|
((merged (assoc result-interp
|
|
:code 0
|
|
:result (str rc)
|
|
:output (str caller-output sub-output))))
|
|
(let
|
|
; set resultVar if given
|
|
((after-rv
|
|
(if (nil? result-var)
|
|
merged
|
|
(tcl-var-set merged result-var rv))))
|
|
(let
|
|
; set optsVar if given
|
|
((opts-str (str "-code " rc " -errorinfo " (if (equal? rei "") "{}" rei) " -errorcode " (if (equal? rec "") "{}" rec))))
|
|
(let
|
|
((after-opts
|
|
(if (nil? opts-var)
|
|
after-rv
|
|
(tcl-var-set after-rv opts-var opts-str))))
|
|
(assoc after-opts :result (str rc))))))))))))
|
|
|
|
; --- throw command ---
|
|
; throw type message
|
|
(define
|
|
tcl-cmd-throw
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((ec (if (> (len args) 0) (first args) ""))
|
|
(msg (if (> (len args) 1) (nth args 1) "")))
|
|
(assoc interp :result msg :code 1 :errorcode ec :errorinfo ""))))
|
|
|
|
; --- try command ---
|
|
; try script ?on code var body? ... ?finally body?
|
|
(define
|
|
tcl-try-code-matches?
|
|
(fn
|
|
(code-str rc)
|
|
(cond
|
|
((equal? code-str "ok") (= rc 0))
|
|
((equal? code-str "error") (= rc 1))
|
|
((equal? code-str "return") (= rc 2))
|
|
((equal? code-str "break") (= rc 3))
|
|
((equal? code-str "continue") (= rc 4))
|
|
(else (= rc (parse-int code-str))))))
|
|
|
|
(define
|
|
tcl-cmd-try
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((script (first args))
|
|
(rest-args (rest args)))
|
|
; Parse clauses: list of {:type "on"|"finally" :code str :var str :body str}
|
|
(let
|
|
((parse-clauses
|
|
(fn
|
|
(remaining acc)
|
|
(if
|
|
(= 0 (len remaining))
|
|
acc
|
|
(let
|
|
((kw (first remaining)))
|
|
(cond
|
|
((equal? kw "on")
|
|
(if (< (len remaining) 4)
|
|
acc
|
|
(parse-clauses
|
|
(slice remaining 4 (len remaining))
|
|
(append acc (list {:type "on" :code (nth remaining 1) :var (nth remaining 2) :body (nth remaining 3)})))))
|
|
((equal? kw "finally")
|
|
(if (< (len remaining) 2)
|
|
acc
|
|
(parse-clauses
|
|
(slice remaining 2 (len remaining))
|
|
(append acc (list {:type "finally" :body (nth remaining 1)})))))
|
|
(else acc))))))
|
|
(clauses (parse-clauses rest-args (list))))
|
|
; Run the main script
|
|
(let
|
|
((sub-interp (assoc interp :code 0 :result ""))
|
|
(caller-output (get interp :output)))
|
|
(let
|
|
((result-interp (tcl-eval-string sub-interp script)))
|
|
(let
|
|
((rc (get result-interp :code))
|
|
(rv (get result-interp :result))
|
|
(sub-output (get result-interp :output)))
|
|
; Find matching "on" clause
|
|
(let
|
|
((find-clause
|
|
(fn
|
|
(cs)
|
|
(if
|
|
(= 0 (len cs))
|
|
nil
|
|
(let
|
|
((c (first cs)))
|
|
(if
|
|
(and (equal? (get c :type) "on") (tcl-try-code-matches? (get c :code) rc))
|
|
c
|
|
(find-clause (rest cs)))))))
|
|
(matched (find-clause clauses))
|
|
; Find finally clause
|
|
(finally-clause
|
|
(reduce
|
|
(fn (acc c) (if (equal? (get c :type) "finally") c acc))
|
|
nil
|
|
clauses)))
|
|
; Evaluate matched handler if any
|
|
(let
|
|
((after-handler
|
|
(if
|
|
(nil? matched)
|
|
(assoc result-interp :output (str caller-output sub-output))
|
|
(let
|
|
((handler-interp
|
|
(assoc result-interp
|
|
:code 0
|
|
:output (str caller-output sub-output))))
|
|
(let
|
|
((bound-interp
|
|
(if (equal? (get matched :var) "")
|
|
handler-interp
|
|
(tcl-var-set handler-interp (get matched :var) rv))))
|
|
(tcl-eval-string bound-interp (get matched :body)))))))
|
|
; Run finally if present
|
|
(let
|
|
((final-result
|
|
(if
|
|
(nil? finally-clause)
|
|
after-handler
|
|
(let
|
|
((fi (tcl-eval-string (assoc after-handler :code 0) (get finally-clause :body))))
|
|
; Restore code from after-handler unless finally itself errored
|
|
(if (= (get fi :code) 0)
|
|
(assoc fi :code (get after-handler :code) :result (get after-handler :result))
|
|
fi)))))
|
|
final-result))))))))))
|
|
|
|
(define
|
|
tcl-cmd-unset
|
|
(fn
|
|
(interp args)
|
|
(reduce
|
|
(fn
|
|
(i name)
|
|
(let
|
|
((frame (get i :frame)))
|
|
(let
|
|
((new-locals (reduce (fn (acc k) (if (equal? k name) acc (assoc acc k (get (get frame :locals) k)))) {} (keys (get frame :locals)))))
|
|
(assoc i :frame (assoc frame :locals new-locals)))))
|
|
interp
|
|
args)))
|
|
|
|
(define
|
|
tcl-cmd-lappend
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((name (first args)) (items (rest args)))
|
|
(let
|
|
((cur (let ((v (frame-lookup (get interp :frame) name))) (if (nil? v) "" 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 "\""))))))))
|
|
|
|
; --- namespace helpers ---
|
|
|
|
; Normalize a namespace name to fully-qualified form: ::ns
|
|
; Accepts: "ns", "::ns", "ns::", "::ns::", "" → "::"
|
|
(define
|
|
tcl-ns-normalize
|
|
(fn
|
|
(ns)
|
|
(if
|
|
(or (equal? ns "") (equal? ns "::"))
|
|
"::"
|
|
(let
|
|
; strip trailing ::
|
|
((stripped
|
|
(if
|
|
(equal? (substring ns (- (string-length ns) 2) (string-length ns)) "::")
|
|
(substring ns 0 (- (string-length ns) 2))
|
|
ns)))
|
|
; ensure leading ::
|
|
(if
|
|
(equal? (substring stripped 0 2) "::")
|
|
stripped
|
|
(str "::" stripped))))))
|
|
|
|
; Test whether string s starts with prefix p
|
|
(define
|
|
tcl-starts-with?
|
|
(fn
|
|
(s p)
|
|
(let
|
|
((pl (string-length p)) (sl (string-length s)))
|
|
(if (> pl sl) false (equal? (substring s 0 pl) p)))))
|
|
|
|
; Qualify a proc name relative to current-ns.
|
|
; If name already starts with :: return as-is.
|
|
; Otherwise prepend current-ns:: (or :: if current-ns is ::).
|
|
(define
|
|
tcl-qualify-name
|
|
(fn
|
|
(name current-ns)
|
|
(if
|
|
(tcl-starts-with? name "::")
|
|
name
|
|
(if
|
|
(equal? current-ns "::")
|
|
(str "::" name)
|
|
(str current-ns "::" name)))))
|
|
|
|
; Look up a command by name with namespace resolution.
|
|
; Try: exact name → ::current-ns::name → ::name
|
|
(define
|
|
tcl-proc-lookup
|
|
(fn
|
|
(interp name)
|
|
(let
|
|
((procs (get interp :procs))
|
|
(current-ns (get interp :current-ns)))
|
|
(let
|
|
((exact (get procs name)))
|
|
(if (not (nil? exact))
|
|
{:name name :def exact}
|
|
(let
|
|
((qualified (tcl-qualify-name name current-ns)))
|
|
(let
|
|
((qual-def (get procs qualified)))
|
|
(if (not (nil? qual-def))
|
|
{:name qualified :def qual-def}
|
|
(let
|
|
((global-name (str "::" name)))
|
|
(let
|
|
((global-def (get procs global-name)))
|
|
(if (not (nil? global-def))
|
|
{:name global-name :def global-def}
|
|
nil)))))))))))
|
|
|
|
; Get all proc names in a namespace (returns list of fully-qualified names)
|
|
(define
|
|
tcl-ns-procs
|
|
(fn
|
|
(procs ns)
|
|
(let
|
|
((prefix (if (equal? ns "::") "::" (str ns "::"))))
|
|
(filter
|
|
(fn (k)
|
|
(if (equal? ns "::")
|
|
; global ns: keys that start with :: but have no further ::
|
|
(and
|
|
(tcl-starts-with? k "::")
|
|
(not (tcl-starts-with? (substring k 2 (string-length k)) "::")))
|
|
(tcl-starts-with? k prefix)))
|
|
(keys procs)))))
|
|
|
|
; Check if a namespace exists (has any procs)
|
|
(define
|
|
tcl-ns-exists?
|
|
(fn
|
|
(procs ns)
|
|
(> (len (tcl-ns-procs procs ns)) 0)))
|
|
|
|
; Extract last component from qualified name ::ns::foo → foo
|
|
(define
|
|
tcl-ns-tail
|
|
(fn
|
|
(name)
|
|
(let
|
|
((parts (filter (fn (p) (not (equal? p ""))) (split name ":"))))
|
|
(if (= 0 (len parts)) name (nth parts (- (len parts) 1))))))
|
|
|
|
; --- proc command ---
|
|
|
|
(define
|
|
tcl-cmd-proc
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((raw-name (first args))
|
|
(arg-spec (nth args 1))
|
|
(body (nth args 2)))
|
|
(let
|
|
; qualify name based on current namespace
|
|
((name (tcl-qualify-name raw-name (get interp :current-ns))))
|
|
(let
|
|
; extract the namespace of the proc for runtime context
|
|
((proc-ns
|
|
(let
|
|
((parts (filter (fn (p) (not (equal? p ""))) (split name ":"))))
|
|
; proc-ns is all but last component, re-joined as ::ns or ::
|
|
(if (<= (len parts) 1)
|
|
"::"
|
|
(str "::" (join "::" (take-n parts (- (len parts) 1))))))))
|
|
(assoc interp
|
|
:procs (assoc (get interp :procs) name {:args arg-spec :body body :ns proc-ns})
|
|
:result ""))))))
|
|
|
|
; --- parse uplevel/upvar level argument ---
|
|
; Returns absolute level number.
|
|
; current-level = len(frame-stack)
|
|
(define
|
|
tcl-parse-level
|
|
(fn
|
|
(level-str current-level)
|
|
(if
|
|
(equal? (substring level-str 0 1) "#")
|
|
; absolute: #N
|
|
(parse-int (substring level-str 1 (string-length level-str)))
|
|
; relative: N levels up from current
|
|
(- current-level (parse-int level-str)))))
|
|
|
|
; --- uplevel command ---
|
|
|
|
(define
|
|
tcl-cmd-uplevel
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((current-level (len (get interp :frame-stack))))
|
|
(let
|
|
; check if first arg is a level specifier
|
|
((has-level
|
|
(and
|
|
(> (len args) 1)
|
|
(or
|
|
(equal? (substring (first args) 0 1) "#")
|
|
(let
|
|
((fst (first args)))
|
|
(and
|
|
(> (string-length fst) 0)
|
|
(tcl-expr-digit? (substring fst 0 1)))))))
|
|
(level-str (if (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (and (> (string-length (first args)) 0) (tcl-expr-digit? (substring (first args) 0 1))))) (first args) "1"))
|
|
(script (if (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (and (> (string-length (first args)) 0) (tcl-expr-digit? (substring (first args) 0 1))))) (nth args 1) (first args))))
|
|
(let
|
|
((target-level (tcl-parse-level level-str current-level)))
|
|
(let
|
|
((full-stack (tcl-full-stack interp)))
|
|
(let
|
|
((target-frame (tcl-frame-nth full-stack target-level)))
|
|
(let
|
|
((temp-interp
|
|
(assoc interp
|
|
:frame target-frame
|
|
:frame-stack (take-n (get interp :frame-stack) target-level)
|
|
:output ""))
|
|
(saved-output (get interp :output)))
|
|
(let
|
|
((result-interp (tcl-eval-string temp-interp script)))
|
|
(let
|
|
((updated-target (get result-interp :frame))
|
|
(new-output (get result-interp :output)))
|
|
(let
|
|
((new-full-stack (replace-at full-stack target-level updated-target)))
|
|
(let
|
|
((new-frame-stack (take-n new-full-stack (- (len new-full-stack) 1)))
|
|
(new-current (nth new-full-stack (- (len new-full-stack) 1))))
|
|
(assoc interp
|
|
:frame new-current
|
|
:frame-stack new-frame-stack
|
|
:result (get result-interp :result)
|
|
:output (str saved-output new-output)
|
|
:code (get result-interp :code))))))))))))))
|
|
|
|
; --- upvar command ---
|
|
|
|
(define
|
|
tcl-cmd-upvar
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((current-level (len (get interp :frame-stack))))
|
|
(let
|
|
; check if first arg is a level specifier
|
|
((has-level
|
|
(and
|
|
(> (len args) 2)
|
|
(or
|
|
(equal? (substring (first args) 0 1) "#")
|
|
(tcl-expr-digit? (substring (first args) 0 1)))))
|
|
(level-str (if (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))) (first args) "1"))
|
|
(pair-args (if (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))) (rest args) args)))
|
|
(let
|
|
((target-level (tcl-parse-level level-str current-level)))
|
|
(let
|
|
((bind-pairs
|
|
(fn
|
|
(i-interp remaining)
|
|
(if
|
|
(< (len remaining) 2)
|
|
i-interp
|
|
(let
|
|
((remote-name (first remaining))
|
|
(local-name (nth remaining 1)))
|
|
(let
|
|
((alias {:upvar-level target-level :upvar-name remote-name}))
|
|
(bind-pairs
|
|
(assoc i-interp :frame (frame-set-top (get i-interp :frame) local-name alias))
|
|
(rest (rest remaining)))))))))
|
|
(assoc (bind-pairs interp pair-args) :result "")))))))
|
|
|
|
; --- global command ---
|
|
|
|
(define
|
|
tcl-cmd-global
|
|
(fn
|
|
(interp args)
|
|
(reduce
|
|
(fn
|
|
(i name)
|
|
(tcl-cmd-upvar i (list "#0" name name)))
|
|
interp
|
|
args)))
|
|
|
|
; --- variable command ---
|
|
|
|
(define
|
|
tcl-cmd-variable
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((go
|
|
(fn
|
|
(i remaining)
|
|
(if
|
|
(= 0 (len remaining))
|
|
i
|
|
(let
|
|
((name (first remaining))
|
|
(rest-rem (rest remaining)))
|
|
(let
|
|
((linked (tcl-cmd-upvar i (list "#0" name name))))
|
|
(if
|
|
(and (> (len rest-rem) 0) (not (equal? (substring (first rest-rem) 0 1) "-")))
|
|
(let
|
|
((val (first rest-rem)))
|
|
(go (assoc (tcl-var-set linked name val) :result "") (rest rest-rem)))
|
|
(go linked rest-rem))))))))
|
|
(go interp args))))
|
|
|
|
; --- namespace command ---
|
|
|
|
; namespace ensemble dispatch fn for a given ns and map
|
|
(define
|
|
tcl-make-ensemble
|
|
(fn
|
|
(procs ns map-dict)
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error (str "wrong # args: ensemble \"" ns "\" requires subcommand"))
|
|
(let
|
|
((subcmd (first args)) (rest-args (rest args)))
|
|
(let
|
|
((target-name (tcl-dict-get map-dict subcmd)))
|
|
(if (not (nil? target-name))
|
|
; dispatch via mapped name
|
|
(let
|
|
((proc-entry (tcl-proc-lookup interp target-name)))
|
|
(if (nil? proc-entry)
|
|
(error (str "ensemble: command \"" target-name "\" not found"))
|
|
(tcl-call-proc interp (get proc-entry :name) (get proc-entry :def) rest-args)))
|
|
(error (str "unknown or ambiguous subcommand \"" subcmd "\": must be one of " (join ", " (map first (tcl-dict-to-pairs map-dict))))))))))))
|
|
|
|
(define
|
|
tcl-cmd-namespace
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "namespace: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
; namespace eval ns body
|
|
((equal? sub "eval")
|
|
(let
|
|
((ns-raw (if (> (len rest-args) 0) (first rest-args) ""))
|
|
(body (if (> (len rest-args) 1) (nth rest-args 1) "")))
|
|
(let
|
|
; if ns-raw is relative (no leading ::), resolve relative to current-ns
|
|
((ns
|
|
(let
|
|
((normalized (tcl-ns-normalize ns-raw))
|
|
(current-ns (get interp :current-ns)))
|
|
; tcl-ns-normalize always adds :: prefix, so ::name is absolute
|
|
; check if the original had leading ::
|
|
(if
|
|
(tcl-starts-with? ns-raw "::")
|
|
normalized
|
|
; relative: if current is ::, just use ::name; else ::current::name
|
|
(if
|
|
(equal? current-ns "::")
|
|
normalized
|
|
(str current-ns "::" (tcl-ns-tail normalized))))))
|
|
(saved-ns (get interp :current-ns)))
|
|
(let
|
|
((ns-interp (assoc interp :current-ns ns)))
|
|
(let
|
|
((result-interp (tcl-eval-string ns-interp body)))
|
|
; restore current-ns after eval
|
|
(assoc result-interp :current-ns saved-ns))))))
|
|
; namespace current
|
|
((equal? sub "current")
|
|
(assoc interp :result (get interp :current-ns)))
|
|
; namespace which -command name
|
|
((equal? sub "which")
|
|
(let
|
|
((name (if (and (> (len rest-args) 0) (equal? (first rest-args) "-command"))
|
|
(if (> (len rest-args) 1) (nth rest-args 1) "")
|
|
(if (> (len rest-args) 0) (first rest-args) ""))))
|
|
(let
|
|
((entry (tcl-proc-lookup interp name)))
|
|
(if (nil? entry)
|
|
(assoc interp :result "")
|
|
(assoc interp :result (get entry :name))))))
|
|
; namespace exists ns
|
|
((equal? sub "exists")
|
|
(let
|
|
((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) ""))))
|
|
(assoc interp :result (if (tcl-ns-exists? (get interp :procs) ns) "1" "0"))))
|
|
; namespace delete ns
|
|
((equal? sub "delete")
|
|
(let
|
|
((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) ""))))
|
|
(let
|
|
((prefix (if (equal? ns "::") "::" (str ns "::"))))
|
|
(let
|
|
((remaining-procs
|
|
(reduce
|
|
(fn (acc k) (if (tcl-starts-with? k prefix) acc (assoc acc k (get (get interp :procs) k))))
|
|
{}
|
|
(keys (get interp :procs)))))
|
|
(assoc interp :procs remaining-procs :result "")))))
|
|
; namespace export pattern — stub
|
|
((equal? sub "export")
|
|
(assoc interp :result ""))
|
|
; namespace import ns::name
|
|
((equal? sub "import")
|
|
(let
|
|
((target-name (if (> (len rest-args) 0) (first rest-args) "")))
|
|
(let
|
|
((tail (tcl-ns-tail target-name))
|
|
(entry (tcl-proc-lookup interp target-name)))
|
|
(if (nil? entry)
|
|
(error (str "namespace import: \"" target-name "\" not found"))
|
|
(let
|
|
((local-name (tcl-qualify-name tail (get interp :current-ns))))
|
|
(assoc interp
|
|
:procs (assoc (get interp :procs) local-name (get entry :def))
|
|
:result ""))))))
|
|
; namespace forget name — remove import alias
|
|
((equal? sub "forget")
|
|
(let
|
|
((name (if (> (len rest-args) 0) (first rest-args) "")))
|
|
(let
|
|
((qualified (tcl-qualify-name name (get interp :current-ns))))
|
|
(let
|
|
((new-procs (reduce
|
|
(fn (acc k) (if (equal? k qualified) acc (assoc acc k (get (get interp :procs) k))))
|
|
{}
|
|
(keys (get interp :procs)))))
|
|
(assoc interp :procs new-procs :result "")))))
|
|
; namespace path ?nslist? — stub
|
|
((equal? sub "path")
|
|
(assoc interp :result ""))
|
|
; namespace ensemble create ?-map dict?
|
|
((equal? sub "ensemble")
|
|
(if (and (> (len rest-args) 0) (equal? (first rest-args) "create"))
|
|
(let
|
|
((ens-args (rest rest-args))
|
|
(current-ns (get interp :current-ns)))
|
|
(let
|
|
; parse optional -map {subcmd cmd ...}
|
|
((map-str
|
|
(let
|
|
((go
|
|
(fn
|
|
(remaining)
|
|
(if
|
|
(< (len remaining) 2)
|
|
nil
|
|
(if (equal? (first remaining) "-map")
|
|
(nth remaining 1)
|
|
(go (rest remaining)))))))
|
|
(go ens-args))))
|
|
(let
|
|
; build dispatch map
|
|
((dispatch-map
|
|
(if (nil? map-str)
|
|
; auto-map: all procs in this namespace → tail name
|
|
(let
|
|
((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns)))
|
|
(reduce
|
|
(fn (acc qname)
|
|
(let
|
|
((tail (tcl-ns-tail qname)))
|
|
(tcl-dict-set-pair acc tail qname)))
|
|
""
|
|
ns-proc-names))
|
|
map-str)))
|
|
; ensemble command name = tail of current-ns
|
|
(let
|
|
((ens-name (tcl-ns-tail current-ns))
|
|
(ens-fn (tcl-make-ensemble (get interp :procs) current-ns dispatch-map)))
|
|
(assoc interp
|
|
:commands (assoc (get interp :commands) ens-name ens-fn)
|
|
:result "")))))
|
|
(error "namespace ensemble: unknown subcommand")))
|
|
(else (error (str "namespace: unknown subcommand \"" sub "\""))))))))
|
|
|
|
; --- info command ---
|
|
|
|
(define
|
|
tcl-cmd-info
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "info: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
; info level
|
|
((equal? sub "level")
|
|
(assoc interp :result (str (len (get interp :frame-stack)))))
|
|
; info vars / info locals
|
|
((or (equal? sub "vars") (equal? sub "locals"))
|
|
(let
|
|
((frame-locals (get (get interp :frame) :locals)))
|
|
(assoc interp :result
|
|
(tcl-list-build
|
|
(filter
|
|
(fn (k) (not (upvar-alias? (get frame-locals k))))
|
|
(keys frame-locals))))))
|
|
; info globals
|
|
((equal? sub "globals")
|
|
(let
|
|
((global-frame
|
|
(if
|
|
(= 0 (len (get interp :frame-stack)))
|
|
(get interp :frame)
|
|
(first (get interp :frame-stack)))))
|
|
(let
|
|
((global-locals (get global-frame :locals)))
|
|
(assoc interp :result
|
|
(tcl-list-build
|
|
(filter
|
|
(fn (k) (not (upvar-alias? (get global-locals k))))
|
|
(keys global-locals)))))))
|
|
; info commands
|
|
((equal? sub "commands")
|
|
(assoc interp :result (tcl-list-build (keys (get interp :commands)))))
|
|
; info procs — return unqualified names of procs in current namespace
|
|
((equal? sub "procs")
|
|
(let
|
|
((current-ns (get interp :current-ns)))
|
|
(let
|
|
((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns)))
|
|
(assoc interp :result (tcl-list-build (map tcl-ns-tail ns-proc-names))))))
|
|
; info args procname
|
|
((equal? sub "args")
|
|
(let
|
|
((pname (first rest-args)))
|
|
(let
|
|
((entry (tcl-proc-lookup interp pname)))
|
|
(if
|
|
(nil? entry)
|
|
(error (str "info args: \"" pname "\" isn't a procedure"))
|
|
(assoc interp :result (get (get entry :def) :args))))))
|
|
; info body procname
|
|
((equal? sub "body")
|
|
(let
|
|
((pname (first rest-args)))
|
|
(let
|
|
((entry (tcl-proc-lookup interp pname)))
|
|
(if
|
|
(nil? entry)
|
|
(error (str "info body: \"" pname "\" isn't a procedure"))
|
|
(assoc interp :result (get (get entry :def) :body))))))
|
|
(else (error (str "info: unknown subcommand \"" sub "\""))))))))
|
|
|
|
(define
|
|
make-default-tcl-interp
|
|
(fn
|
|
()
|
|
(let
|
|
((i (make-tcl-interp)))
|
|
(let
|
|
((i (tcl-register i "set" tcl-cmd-set)))
|
|
(let
|
|
((i (tcl-register i "puts" tcl-cmd-puts)))
|
|
(let
|
|
((i (tcl-register i "incr" tcl-cmd-incr)))
|
|
(let
|
|
((i (tcl-register i "append" tcl-cmd-append)))
|
|
(let
|
|
((i (tcl-register i "unset" tcl-cmd-unset)))
|
|
(let
|
|
((i (tcl-register i "lappend" tcl-cmd-lappend)))
|
|
(let
|
|
((i (tcl-register i "eval" tcl-cmd-eval)))
|
|
(let
|
|
((i (tcl-register i "if" tcl-cmd-if)))
|
|
(let
|
|
((i (tcl-register i "while" tcl-cmd-while)))
|
|
(let
|
|
((i (tcl-register i "for" tcl-cmd-for)))
|
|
(let
|
|
((i (tcl-register i "foreach" tcl-cmd-foreach)))
|
|
(let
|
|
((i (tcl-register i "switch" tcl-cmd-switch)))
|
|
(let
|
|
((i (tcl-register i "break" tcl-cmd-break)))
|
|
(let
|
|
((i (tcl-register i "continue" tcl-cmd-continue)))
|
|
(let
|
|
((i (tcl-register i "return" tcl-cmd-return)))
|
|
(let
|
|
((i (tcl-register i "error" tcl-cmd-error)))
|
|
(let
|
|
((i (tcl-register i "expr" tcl-cmd-expr)))
|
|
(let
|
|
((i (tcl-register i "gets" tcl-cmd-gets)))
|
|
(let
|
|
((i (tcl-register i "subst" tcl-cmd-subst)))
|
|
(let
|
|
((i (tcl-register i "format" tcl-cmd-format)))
|
|
(let
|
|
((i (tcl-register i "scan" tcl-cmd-scan)))
|
|
(let
|
|
((i (tcl-register i "string" tcl-cmd-string)))
|
|
(let
|
|
((i (tcl-register i "list" tcl-cmd-list)))
|
|
(let
|
|
((i (tcl-register i "lindex" tcl-cmd-lindex)))
|
|
(let
|
|
((i (tcl-register i "lrange" tcl-cmd-lrange)))
|
|
(let
|
|
((i (tcl-register i "llength" tcl-cmd-llength)))
|
|
(let
|
|
((i (tcl-register i "lreverse" tcl-cmd-lreverse)))
|
|
(let
|
|
((i (tcl-register i "lsearch" tcl-cmd-lsearch)))
|
|
(let
|
|
((i (tcl-register i "lsort" tcl-cmd-lsort)))
|
|
(let
|
|
((i (tcl-register i "lreplace" tcl-cmd-lreplace)))
|
|
(let
|
|
((i (tcl-register i "linsert" tcl-cmd-linsert)))
|
|
(let
|
|
((i (tcl-register i "concat" tcl-cmd-concat)))
|
|
(let
|
|
((i (tcl-register i "split" tcl-cmd-split)))
|
|
(let
|
|
((i (tcl-register i "join" tcl-cmd-join)))
|
|
(let
|
|
((i (tcl-register i "dict" tcl-cmd-dict)))
|
|
(let
|
|
((i (tcl-register i "proc" tcl-cmd-proc)))
|
|
(let
|
|
((i (tcl-register i "uplevel" tcl-cmd-uplevel)))
|
|
(let
|
|
((i (tcl-register i "upvar" tcl-cmd-upvar)))
|
|
(let
|
|
((i (tcl-register i "global" tcl-cmd-global)))
|
|
(let
|
|
((i (tcl-register i "variable" tcl-cmd-variable)))
|
|
(let
|
|
((i (tcl-register i "info" tcl-cmd-info)))
|
|
(let
|
|
((i (tcl-register i "catch" tcl-cmd-catch)))
|
|
(let
|
|
((i (tcl-register i "throw" tcl-cmd-throw)))
|
|
(let
|
|
((i (tcl-register i "try" tcl-cmd-try)))
|
|
(tcl-register i "namespace" tcl-cmd-namespace))))))))))))))))))))))))))))))))))))))))))))))))
|