giles
35511db15b
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 45s
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
3342 lines
117 KiB
Plaintext
3342 lines
117 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 "::" :coroutines {} :in-coro false :coro-yields (list)}))
|
|
|
|
(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)
|
|
:coro-yields (get result-interp :coro-yields)
|
|
:coroutines (get result-interp :coroutines)
|
|
:commands (get result-interp :commands))))))))))))))
|
|
|
|
(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) "" (tcl-var-get interp name)))))
|
|
(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-num-float?
|
|
(fn
|
|
(s)
|
|
(let
|
|
loop
|
|
((i 0))
|
|
(cond
|
|
((>= i (len s)) false)
|
|
((or (equal? (nth s i) ".") (equal? (nth s i) "e") (equal? (nth s i) "E"))
|
|
true)
|
|
(else (loop (+ i 1)))))))
|
|
|
|
(define
|
|
tcl-parse-num
|
|
(fn (s) (if (tcl-num-float? s) (parse-float s) (parse-int s))))
|
|
|
|
(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-float (first args)) 0))
|
|
(a1 (if (> (len args) 1) (parse-float (nth args 1)) 0)))
|
|
(cond
|
|
((equal? name "abs") (str (if (< a0 0) (- 0 a0) a0)))
|
|
((equal? name "int") (str (truncate a0)))
|
|
((equal? name "double") (str a0))
|
|
((equal? name "round") (str (round a0)))
|
|
((equal? name "floor") (str (floor a0)))
|
|
((equal? name "ceil") (str (ceil a0)))
|
|
((equal? name "sqrt") (str (sqrt a0)))
|
|
((equal? name "pow") (str (pow a0 a1)))
|
|
((equal? name "max") (str (if (>= a0 a1) a0 a1)))
|
|
((equal? name "min") (str (if (<= a0 a1) a0 a1)))
|
|
((equal? name "sin") (str (sin a0)))
|
|
((equal? name "cos") (str (cos a0)))
|
|
((equal? name "tan") (str (tan a0)))
|
|
((equal? name "atan") (str (atan a0)))
|
|
((equal? name "atan2") (str (atan2 a0 a1)))
|
|
((equal? name "exp") (str (exp a0)))
|
|
((equal? name "log") (str (log a0)))
|
|
(else (error (str "expr: unknown function: " name)))))))
|
|
|
|
(define
|
|
tcl-apply-binop
|
|
(fn
|
|
(op l r)
|
|
(let
|
|
((fl (tcl-num-float? l))
|
|
(fr (tcl-num-float? r))
|
|
(nl (tcl-parse-num l))
|
|
(nr (tcl-parse-num r)))
|
|
(cond
|
|
((equal? op "+") (str (+ nl nr)))
|
|
((equal? op "-") (str (- nl nr)))
|
|
((equal? op "*") (str (* nl nr)))
|
|
((equal? op "/")
|
|
(if (or fl fr) (str (/ nl nr)) (str (truncate (/ nl nr)))))
|
|
((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 (< nl nr) "1" "0"))
|
|
((equal? op ">") (if (> nl nr) "1" "0"))
|
|
((equal? op "<=") (if (<= nl nr) "1" "0"))
|
|
((equal? op ">=") (if (>= nl nr) "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 (pow nl nr)))
|
|
(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) ")"))
|
|
{:tokens (rest after) :value (get inner :value)}
|
|
(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) ")"))
|
|
{:tokens (rest after-args) :value (tcl-apply-func tok (get args-r :args))}
|
|
(error (str "expr: missing ) after function call " tok))))))
|
|
(else {:tokens rest-toks :value tok}))))))
|
|
|
|
(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)))) {:tokens (get r :tokens) :value (if (tcl-false? (get r :value)) "1" "0")}))
|
|
((equal? tok "-")
|
|
(let ((r (tcl-expr-parse-unary (rest tokens)))) {:tokens (get r :tokens) :value (str (- 0 (tcl-parse-num (get r :value))))}))
|
|
((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))))
|
|
{:tokens (get exp-r :tokens) :value (str (pow (tcl-parse-num base-val) (tcl-parse-num (get exp-r :value))))})
|
|
{:tokens rest-toks :value base-val})))))
|
|
|
|
(define
|
|
tcl-expr-parse-multiplicative-rest
|
|
(fn
|
|
(tokens left)
|
|
(if
|
|
(or
|
|
(= 0 (len tokens))
|
|
(not (contains? (list "*" "/" "%") (first tokens))))
|
|
{:tokens tokens :value left}
|
|
(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))))
|
|
{:tokens tokens :value left}
|
|
(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))))
|
|
{:tokens tokens :value left}
|
|
(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))))
|
|
{:tokens tokens :value left}
|
|
(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) "&&")))
|
|
{:tokens tokens :value left}
|
|
(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) "||")))
|
|
{:tokens tokens :value left}
|
|
(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)})))))))
|
|
|
|
; Parse -code name/number to integer
|
|
(define tcl-cmd-break (fn (interp args) (assoc interp :code 3)))
|
|
|
|
; Parse return options from args list
|
|
; Returns {:code N :result val :errorinfo str :errorcode str}
|
|
(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4)))
|
|
|
|
(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)))))
|
|
|
|
(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) "-"))) {:result (if (> (len remaining) 0) (first remaining) "") :errorinfo ei :errorcode ec :code code} (let ((flag (first remaining)) (rest1 (rest remaining))) (cond ((equal? flag "-code") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode ec :code code} (go (rest rest1) (tcl-return-code-num (first rest1)) ei ec))) ((equal? flag "-errorinfo") (if (= 0 (len rest1)) {:result "" :errorinfo "" :errorcode ec :code code} (go (rest rest1) code (first rest1) ec))) ((equal? flag "-errorcode") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode "" :code code} (go (rest rest1) code ei (first rest1)))) ((equal? flag "-level") (if (= 0 (len rest1)) {:result "" :errorinfo ei :errorcode ec :code code} (go (rest rest1) code ei ec))) (else {:result flag :errorinfo ei :errorcode ec :code code})))))))
|
|
(go args 2 "" ""))))
|
|
|
|
; --- catch command ---
|
|
; catch script ?resultVar? ?optionsVar?
|
|
(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)))))
|
|
|
|
; --- throw command ---
|
|
; throw type message
|
|
(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))))
|
|
|
|
; --- try command ---
|
|
; try script ?on code var body? ... ?finally body?
|
|
(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
|
|
((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
|
|
((merged (assoc result-interp :code 0 :result (str rc) :output (str caller-output sub-output))))
|
|
(let
|
|
((after-rv (if (nil? result-var) merged (tcl-var-set merged result-var rv))))
|
|
(let
|
|
((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))))))))))))
|
|
|
|
(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 ""))))
|
|
|
|
(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)))
|
|
(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 {:body (nth remaining 3) :code (nth remaining 1) :type "on" :var (nth remaining 2)}))))) ((equal? kw "finally") (if (< (len remaining) 2) acc (parse-clauses (slice remaining 2 (len remaining)) (append acc (list {:body (nth remaining 1) :type "finally"}))))) (else acc))))))
|
|
(clauses (parse-clauses rest-args (list))))
|
|
(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)))
|
|
(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))
|
|
(finally-clause
|
|
(reduce
|
|
(fn
|
|
(acc c)
|
|
(if (equal? (get c :type) "finally") c acc))
|
|
nil
|
|
clauses)))
|
|
(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)))))))
|
|
(let
|
|
((final-result (if (nil? finally-clause) after-handler (let ((fi (tcl-eval-string (assoc after-handler :code 0) (get finally-clause :body)))) (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) "" (tcl-var-get interp name)))))
|
|
(let
|
|
((quoted-items (map tcl-list-quote-elem items)))
|
|
(let
|
|
((new-val (if (equal? cur "") (join " " quoted-items) (str cur " " (join " " quoted-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))))))
|
|
|
|
; Format helper: repeat char ch n times, building pad string
|
|
(define tcl-cmd-gets (fn (interp args) (assoc interp :result "")))
|
|
|
|
; Format helper: pad string s to width w
|
|
(define
|
|
tcl-cmd-subst
|
|
(fn (interp args) (assoc interp :result (last args))))
|
|
|
|
; Format helper: scan flag characters
|
|
(define
|
|
tcl-fmt-make-pad
|
|
(fn
|
|
(ch cnt acc)
|
|
(if
|
|
(<= cnt 0)
|
|
acc
|
|
(tcl-fmt-make-pad ch (- cnt 1) (str ch acc)))))
|
|
|
|
; Format helper: scan digits for width/precision
|
|
(define
|
|
tcl-fmt-pad
|
|
(fn
|
|
(s width zero-pad? left-align?)
|
|
(let
|
|
((w (if (equal? width "") 0 (parse-int width))))
|
|
(let
|
|
((pad-len (- w (string-length s))))
|
|
(if
|
|
(<= pad-len 0)
|
|
s
|
|
(let
|
|
((pad (tcl-fmt-make-pad (if zero-pad? "0" " ") pad-len "")))
|
|
(if left-align? (str s pad) (str pad s))))))))
|
|
|
|
; Main format apply: process chars, produce output string
|
|
(define
|
|
tcl-fmt-scan-flags
|
|
(fn
|
|
(chars j flags)
|
|
(if
|
|
(>= j (len chars))
|
|
{:j j :flags flags}
|
|
(let
|
|
((ch (nth chars j)))
|
|
(if
|
|
(contains? (list "-" "0" "+" " " "#") ch)
|
|
(tcl-fmt-scan-flags chars (+ j 1) (str flags ch))
|
|
{:j j :flags flags})))))
|
|
|
|
(define
|
|
tcl-fmt-scan-num
|
|
(fn
|
|
(chars j acc-n)
|
|
(if
|
|
(>= j (len chars))
|
|
{:num acc-n :j j}
|
|
(let
|
|
((ch (nth chars j)))
|
|
(if
|
|
(tcl-expr-digit? ch)
|
|
(tcl-fmt-scan-num chars (+ j 1) (str acc-n ch))
|
|
{:num acc-n :j j})))))
|
|
|
|
(define
|
|
tcl-fmt-apply
|
|
(fn
|
|
(chars n-len fmt-args i arg-idx acc)
|
|
(if
|
|
(>= i n-len)
|
|
acc
|
|
(let
|
|
((c (nth chars i)))
|
|
(if
|
|
(not (equal? c "%"))
|
|
(tcl-fmt-apply
|
|
chars
|
|
n-len
|
|
fmt-args
|
|
(+ i 1)
|
|
arg-idx
|
|
(str acc c))
|
|
(let
|
|
((i2 (+ i 1)))
|
|
(if
|
|
(>= i2 n-len)
|
|
(str acc "%")
|
|
(let
|
|
((c2 (nth chars i2)))
|
|
(if
|
|
(equal? c2 "%")
|
|
(tcl-fmt-apply
|
|
chars
|
|
n-len
|
|
fmt-args
|
|
(+ i2 1)
|
|
arg-idx
|
|
(str acc "%"))
|
|
(let
|
|
((fr (tcl-fmt-scan-flags chars i2 "")))
|
|
(let
|
|
((flags (get fr :flags)) (j (get fr :j)))
|
|
(let
|
|
((wr (tcl-fmt-scan-num chars j "")))
|
|
(let
|
|
((width (get wr :num)) (j2 (get wr :j)))
|
|
(let
|
|
((j3 (if (and (< j2 n-len) (equal? (nth chars j2) ".")) (let ((pr (tcl-fmt-scan-num chars (+ j2 1) ""))) (get pr :j)) j2)))
|
|
(if
|
|
(>= j3 n-len)
|
|
(str acc "?")
|
|
(let
|
|
((type-char (nth chars j3))
|
|
(cur-arg
|
|
(if
|
|
(< arg-idx (len fmt-args))
|
|
(nth fmt-args arg-idx)
|
|
"")))
|
|
(let
|
|
((zero-pad? (contains? (split flags "") "0"))
|
|
(left-align?
|
|
(contains? (split flags "") "-")))
|
|
(let
|
|
((formatted (cond ((or (equal? type-char "d") (equal? type-char "i")) (tcl-fmt-pad (str (parse-int cur-arg)) width zero-pad? left-align?)) ((equal? type-char "s") (tcl-fmt-pad cur-arg width false left-align?)) ((or (equal? type-char "f") (equal? type-char "g") (equal? type-char "e")) cur-arg) ((equal? type-char "x") (str (parse-int cur-arg))) ((equal? type-char "o") (str (parse-int cur-arg))) ((equal? type-char "c") cur-arg) (else (str "%" type-char)))))
|
|
(tcl-fmt-apply
|
|
chars
|
|
n-len
|
|
fmt-args
|
|
(+ j3 1)
|
|
(+ arg-idx 1)
|
|
(str acc formatted))))))))))))))))))))
|
|
|
|
; --- string command helpers ---
|
|
|
|
; glob match: pattern chars list, string chars list
|
|
(define
|
|
tcl-cmd-format
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "format: wrong # args")
|
|
(let
|
|
((fmt-str (first args)) (fmt-args (rest args)))
|
|
(let
|
|
((chars (split fmt-str "")) (n-len (string-length fmt-str)))
|
|
(assoc
|
|
interp
|
|
:result (tcl-fmt-apply chars n-len fmt-args 0 0 "")))))))
|
|
|
|
; toupper/tolower via char tables
|
|
(define tcl-cmd-scan (fn (interp args) (assoc interp :result "0")))
|
|
|
|
(define
|
|
tcl-glob-match
|
|
(fn
|
|
(pat-chars str-chars)
|
|
(cond
|
|
((and (= 0 (len pat-chars)) (= 0 (len str-chars)))
|
|
true)
|
|
((= 0 (len pat-chars)) false)
|
|
((equal? (first pat-chars) "*")
|
|
(let
|
|
((rest-pat (rest pat-chars)))
|
|
(if
|
|
(tcl-glob-match rest-pat str-chars)
|
|
true
|
|
(if
|
|
(= 0 (len str-chars))
|
|
false
|
|
(tcl-glob-match pat-chars (rest str-chars))))))
|
|
((= 0 (len str-chars)) false)
|
|
((equal? (first pat-chars) "?")
|
|
(tcl-glob-match (rest pat-chars) (rest str-chars)))
|
|
((equal? (first pat-chars) (first str-chars))
|
|
(tcl-glob-match (rest pat-chars) (rest str-chars)))
|
|
(else false))))
|
|
|
|
; strip chars from left
|
|
(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))))
|
|
|
|
; strip chars from right (reverse, trim left, reverse)
|
|
(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))))
|
|
|
|
(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))))
|
|
|
|
; default whitespace set
|
|
(define
|
|
tcl-reverse-list
|
|
(fn (lst) (reduce (fn (acc x) (append (list x) acc)) (list) lst)))
|
|
|
|
; string map: apply flat list of pairs old→new to string
|
|
(define
|
|
tcl-trim-right-chars
|
|
(fn
|
|
(chars strip-set)
|
|
(tcl-reverse-list
|
|
(tcl-trim-left-chars (tcl-reverse-list chars) strip-set))))
|
|
|
|
; string first: index of needle in haystack starting at start
|
|
(define tcl-ws-set (list " " "\t" "\n" "\r"))
|
|
|
|
; string last: last index of needle in haystack up to end
|
|
(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 is: check string class
|
|
(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))))))
|
|
|
|
(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))))))))
|
|
|
|
|
|
; --- list command helpers ---
|
|
|
|
; Quote a single list element: add braces if it contains a space or is empty
|
|
(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")))))
|
|
|
|
; Build a Tcl list string from an SX list of string elements
|
|
(define
|
|
tcl-cmd-string
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "string: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
((equal? sub "length")
|
|
(assoc interp :result (str (string-length (first rest-args)))))
|
|
((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)))))))
|
|
((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))))))))
|
|
((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")))))
|
|
((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"))))
|
|
((equal? sub "toupper")
|
|
(let
|
|
((s (first rest-args)))
|
|
(assoc
|
|
interp
|
|
:result (join "" (map tcl-upcase-char (split s ""))))))
|
|
((equal? sub "tolower")
|
|
(let
|
|
((s (first rest-args)))
|
|
(assoc
|
|
interp
|
|
:result (join "" (map tcl-downcase-char (split s ""))))))
|
|
((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))))))
|
|
((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)))))
|
|
((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)))))
|
|
((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)))))
|
|
((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 "")))))
|
|
((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))))
|
|
((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))))
|
|
((equal? sub "is")
|
|
(let
|
|
((class (first rest-args)) (s (nth rest-args 1)))
|
|
(assoc interp :result (tcl-string-is class s))))
|
|
((equal? sub "cat") (assoc interp :result (join "" rest-args)))
|
|
(else (error (str "string: unknown subcommand: " sub))))))))
|
|
|
|
; Resolve "end" index to numeric value given list length
|
|
(define
|
|
tcl-list-quote-elem
|
|
(fn
|
|
(elem)
|
|
(if
|
|
(or (equal? elem "") (contains? (split elem "") " "))
|
|
(str "{" elem "}")
|
|
elem)))
|
|
|
|
; Insertion sort for list commands (comparator: fn(a b) -> true if a before b)
|
|
(define
|
|
tcl-list-build
|
|
(fn (elems) (join " " (map tcl-list-quote-elem elems))))
|
|
|
|
(define
|
|
tcl-end-index
|
|
(fn (s n) (if (equal? s "end") (- n 1) (parse-int s))))
|
|
|
|
; --- list commands ---
|
|
|
|
(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)))
|
|
|
|
(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)))))
|
|
|
|
; --- dict command helpers ---
|
|
|
|
; Parse flat dict string into SX list of [key val] pairs
|
|
(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))))))
|
|
|
|
; Build flat dict string from SX list of [key val] pairs
|
|
(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)))))
|
|
|
|
; Get value for key from flat dict string; returns nil if missing
|
|
(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))))))
|
|
|
|
; Set key=val in flat dict string; returns new flat dict string
|
|
(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))))
|
|
|
|
; Remove key from flat dict string; returns new flat dict string
|
|
(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)))))
|
|
|
|
; --- dict command ---
|
|
|
|
(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)))))))))
|
|
|
|
; --- namespace helpers ---
|
|
|
|
; Normalize a namespace name to fully-qualified form: ::ns
|
|
; Accepts: "ns", "::ns", "ns::", "::ns::", "" → "::"
|
|
(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)))))
|
|
|
|
; Test whether string s starts with prefix p
|
|
(define
|
|
tcl-cmd-dict
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "dict: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
((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))))
|
|
((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)))))
|
|
((equal? sub "set")
|
|
(let
|
|
((varname (first rest-args))
|
|
(key (nth rest-args 1))
|
|
(val (nth rest-args 2)))
|
|
(let
|
|
((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp 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)))))
|
|
((equal? sub "unset")
|
|
(let
|
|
((varname (first rest-args))
|
|
(key (nth rest-args 1)))
|
|
(let
|
|
((cur (let ((v (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp 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)))))
|
|
((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"))))
|
|
((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))))))
|
|
((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))))))
|
|
((equal? sub "size")
|
|
(let
|
|
((dict-str (first rest-args)))
|
|
(assoc
|
|
interp
|
|
:result (str (len (tcl-dict-to-pairs dict-str))))))
|
|
((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))))))
|
|
((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 (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp 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)))))))))
|
|
((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)))
|
|
((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 (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp 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)))))))
|
|
((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 (if (nil? (frame-lookup (get interp :frame) varname)) nil (tcl-var-get interp 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 "\""))))))))
|
|
|
|
; 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-ns-normalize
|
|
(fn
|
|
(ns)
|
|
(if
|
|
(or (equal? ns "") (equal? ns "::"))
|
|
"::"
|
|
(let
|
|
((stripped (if (equal? (substring ns (- (string-length ns) 2) (string-length ns)) "::") (substring ns 0 (- (string-length ns) 2)) ns)))
|
|
(if
|
|
(equal? (substring stripped 0 2) "::")
|
|
stripped
|
|
(str "::" stripped))))))
|
|
|
|
; Look up a command by name with namespace resolution.
|
|
; Try: exact name → ::current-ns::name → ::name
|
|
(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)))))
|
|
|
|
; Get all proc names in a namespace (returns list of fully-qualified names)
|
|
(define
|
|
tcl-qualify-name
|
|
(fn
|
|
(name current-ns)
|
|
(if
|
|
(tcl-starts-with? name "::")
|
|
name
|
|
(if
|
|
(equal? current-ns "::")
|
|
(str "::" name)
|
|
(str current-ns "::" name)))))
|
|
|
|
; Check if a namespace exists (has any procs)
|
|
(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))
|
|
{:def exact :name name}
|
|
(let
|
|
((qualified (tcl-qualify-name name current-ns)))
|
|
(let
|
|
((qual-def (get procs qualified)))
|
|
(if
|
|
(not (nil? qual-def))
|
|
{:def qual-def :name qualified}
|
|
(let
|
|
((global-name (str "::" name)))
|
|
(let
|
|
((global-def (get procs global-name)))
|
|
(if (not (nil? global-def)) {:def global-def :name global-name} nil)))))))))))
|
|
|
|
; Extract last component from qualified name ::ns::foo → foo
|
|
(define
|
|
tcl-ns-procs
|
|
(fn
|
|
(procs ns)
|
|
(let
|
|
((prefix (if (equal? ns "::") "::" (str ns "::"))))
|
|
(filter
|
|
(fn
|
|
(k)
|
|
(if
|
|
(equal? ns "::")
|
|
(and
|
|
(tcl-starts-with? k "::")
|
|
(not
|
|
(tcl-starts-with?
|
|
(substring k 2 (string-length k))
|
|
"::")))
|
|
(tcl-starts-with? k prefix)))
|
|
(keys procs)))))
|
|
|
|
; --- proc command ---
|
|
|
|
(define
|
|
tcl-ns-exists?
|
|
(fn (procs ns) (> (len (tcl-ns-procs procs ns)) 0)))
|
|
|
|
; --- parse uplevel/upvar level argument ---
|
|
; Returns absolute level number.
|
|
; current-level = len(frame-stack)
|
|
(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))))))
|
|
|
|
; --- uplevel command ---
|
|
|
|
(define
|
|
tcl-cmd-proc
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((raw-name (first args))
|
|
(arg-spec (nth args 1))
|
|
(body (nth args 2)))
|
|
(let
|
|
((name (tcl-qualify-name raw-name (get interp :current-ns))))
|
|
(let
|
|
((proc-ns (let ((parts (filter (fn (p) (not (equal? p ""))) (split name ":")))) (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 ""))))))
|
|
|
|
; --- upvar command ---
|
|
|
|
(define
|
|
tcl-parse-level
|
|
(fn
|
|
(level-str current-level)
|
|
(if
|
|
(equal? (substring level-str 0 1) "#")
|
|
(parse-int (substring level-str 1 (string-length level-str)))
|
|
(- current-level (parse-int level-str)))))
|
|
|
|
; --- global command ---
|
|
|
|
(define
|
|
tcl-cmd-uplevel
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((current-level (len (get interp :frame-stack))))
|
|
(let
|
|
((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))))))))))))))
|
|
|
|
; --- variable command ---
|
|
|
|
(define
|
|
tcl-cmd-upvar
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((current-level (len (get interp :frame-stack))))
|
|
(let
|
|
((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-name remote-name :upvar-level target-level})) (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 "")))))))
|
|
|
|
; --- namespace command ---
|
|
|
|
; namespace ensemble dispatch fn for a given ns and map
|
|
(define
|
|
tcl-cmd-global
|
|
(fn
|
|
(interp args)
|
|
(reduce
|
|
(fn (i name) (tcl-cmd-upvar i (list "#0" name name)))
|
|
interp
|
|
args)))
|
|
|
|
(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))))
|
|
|
|
; --- info command ---
|
|
|
|
(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))
|
|
(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))))))))))))
|
|
|
|
; --- coroutine support ---
|
|
|
|
; yield: inside a coroutine body, record a yielded value
|
|
(define
|
|
tcl-cmd-namespace
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "namespace: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
((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
|
|
((ns (let ((normalized (tcl-ns-normalize ns-raw)) (current-ns (get interp :current-ns))) (if (tcl-starts-with? ns-raw "::") normalized (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)))
|
|
(assoc result-interp :current-ns saved-ns))))))
|
|
((equal? sub "current")
|
|
(assoc interp :result (get interp :current-ns)))
|
|
((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))))))
|
|
((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"))))
|
|
((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 "")))))
|
|
((equal? sub "export") (assoc interp :result ""))
|
|
((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 ""))))))
|
|
((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 "")))))
|
|
((equal? sub "path") (assoc interp :result ""))
|
|
((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
|
|
((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
|
|
((dispatch-map (if (nil? map-str) (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)))
|
|
(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 "\""))))))))
|
|
|
|
; yieldto: stub — yield empty string
|
|
(define
|
|
tcl-cmd-info
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "info: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
((equal? sub "level")
|
|
(assoc interp :result (str (len (get interp :frame-stack)))))
|
|
((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))))))
|
|
((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)))))))
|
|
((equal? sub "commands")
|
|
(assoc
|
|
interp
|
|
:result (tcl-list-build (keys (get interp :commands)))))
|
|
((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))))))
|
|
((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))))))
|
|
((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))))))
|
|
((equal? sub "exists")
|
|
(let
|
|
((varname (first rest-args)))
|
|
(let
|
|
((val (frame-lookup (get interp :frame) varname)))
|
|
(assoc interp :result (if (nil? val) "0" "1")))))
|
|
((equal? sub "hostname") (assoc interp :result "localhost"))
|
|
((equal? sub "script") (assoc interp :result ""))
|
|
((equal? sub "tclversion") (assoc interp :result "8.6"))
|
|
(else (error (str "info: unknown subcommand \"" sub "\""))))))))
|
|
|
|
; make-coro-cmd: returns a command function that pops values from the coroutine's yields list
|
|
(define
|
|
tcl-cmd-yield
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((val (if (> (len args) 0) (first args) "")))
|
|
(if
|
|
(get interp :in-coro)
|
|
(assoc
|
|
(assoc
|
|
interp
|
|
:coro-yields (append (get interp :coro-yields) (list val)))
|
|
:result "")
|
|
(error "yield called outside coroutine")))))
|
|
|
|
; coroutine: execute proc eagerly in a coroutine context, collecting all yields
|
|
(define
|
|
tcl-cmd-yieldto
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(get interp :in-coro)
|
|
(assoc
|
|
(assoc
|
|
interp
|
|
:coro-yields (append (get interp :coro-yields) (list "")))
|
|
:result "")
|
|
(error "yieldto called outside coroutine"))))
|
|
|
|
; --- clock command (stubs) ---
|
|
|
|
(define
|
|
make-coro-cmd
|
|
(fn
|
|
(coro-name)
|
|
(fn
|
|
(interp args)
|
|
(let
|
|
((coros (get interp :coroutines)))
|
|
(let
|
|
((coro (get coros coro-name)))
|
|
(if
|
|
(nil? coro)
|
|
(error (str "coroutine \"" coro-name "\" not found"))
|
|
(let
|
|
((yields (get coro :yields)) (pos (get coro :pos)))
|
|
(if
|
|
(>= pos (len yields))
|
|
(assoc interp :result "")
|
|
(let
|
|
((val (nth yields pos)))
|
|
(let
|
|
((new-coro (assoc coro :pos (+ pos 1))))
|
|
(assoc
|
|
(assoc
|
|
interp
|
|
:coroutines (assoc coros coro-name new-coro))
|
|
:result val)))))))))))
|
|
|
|
; --- file I/O stubs ---
|
|
|
|
(define
|
|
tcl-cmd-coroutine
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(< (len args) 2)
|
|
(error "coroutine: wrong # args")
|
|
(let
|
|
((coro-name (first args))
|
|
(cmd-name (nth args 1))
|
|
(call-args (rest (rest args))))
|
|
(let
|
|
((coro-interp (assoc interp :in-coro true :coro-yields (list) :result "" :code 0)))
|
|
(let
|
|
((cmd-fn (get (get coro-interp :commands) cmd-name)))
|
|
(let
|
|
((exec-result (if (nil? cmd-fn) (let ((proc-entry (tcl-proc-lookup coro-interp cmd-name))) (if (nil? proc-entry) (error (str "coroutine: unknown command \"" cmd-name "\"")) (tcl-call-proc coro-interp (get proc-entry :name) (get proc-entry :def) call-args))) (cmd-fn coro-interp call-args))))
|
|
(let
|
|
((yields (get exec-result :coro-yields)))
|
|
(let
|
|
((new-coros (assoc (get exec-result :coroutines) coro-name {:yields yields :pos 0})))
|
|
(let
|
|
((new-commands (assoc (get exec-result :commands) coro-name (make-coro-cmd coro-name))))
|
|
(assoc
|
|
exec-result
|
|
:coroutines new-coros
|
|
:commands new-commands
|
|
:in-coro false
|
|
:coro-yields (list)
|
|
:result "")))))))))))
|
|
|
|
(define
|
|
tcl-cmd-clock
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "clock: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
((equal? sub "seconds") (assoc interp :result "0"))
|
|
((equal? sub "milliseconds") (assoc interp :result "0"))
|
|
((equal? sub "format")
|
|
(assoc interp :result "Thu Jan 1 00:00:00 UTC 1970"))
|
|
((equal? sub "scan") (assoc interp :result "0"))
|
|
(else (error (str "clock: unknown subcommand \"" sub "\""))))))))
|
|
|
|
(define tcl-cmd-open (fn (interp args) (assoc interp :result "file0")))
|
|
|
|
; gets channel ?varname?
|
|
(define tcl-cmd-close (fn (interp args) (assoc interp :result "")))
|
|
|
|
(define tcl-cmd-read (fn (interp args) (assoc interp :result "")))
|
|
|
|
(define
|
|
tcl-cmd-gets-chan
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(> (len args) 1)
|
|
(assoc (tcl-var-set interp (nth args 1) "") :result "-1")
|
|
(assoc interp :result ""))))
|
|
|
|
(define tcl-cmd-eof (fn (interp args) (assoc interp :result "1")))
|
|
|
|
(define tcl-cmd-seek (fn (interp args) (assoc interp :result "")))
|
|
|
|
; file command dispatcher
|
|
(define tcl-cmd-tell (fn (interp args) (assoc interp :result "0")))
|
|
|
|
(define tcl-cmd-flush (fn (interp args) (assoc interp :result "")))
|
|
(define
|
|
tcl-cmd-array
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "array: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
((equal? sub "get")
|
|
(if (= 0 (len rest-args))
|
|
(error "array get: wrong # args")
|
|
(let
|
|
((arr-name (first rest-args))
|
|
(pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
|
|
(let
|
|
((prefix (str arr-name "("))
|
|
(locals (get (get interp :frame) :locals)))
|
|
(let
|
|
((pl (string-length prefix)))
|
|
(let
|
|
((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
|
|
(let
|
|
((filtered
|
|
(if
|
|
(nil? pattern)
|
|
arr-keys
|
|
(filter
|
|
(fn (k)
|
|
(let ((kn (substring k pl (- (string-length k) 1))))
|
|
(tcl-glob-match (split pattern "") (split kn ""))))
|
|
arr-keys))))
|
|
(assoc interp :result
|
|
(join " "
|
|
(reduce
|
|
(fn (acc k)
|
|
(let ((kn (substring k pl (- (string-length k) 1))))
|
|
(append acc (list kn) (list (get locals k)))))
|
|
(list)
|
|
filtered))))))))))
|
|
((equal? sub "set")
|
|
(if
|
|
(< (len rest-args) 2)
|
|
(error "array set: wrong # args")
|
|
(let
|
|
((arr-name (first rest-args))
|
|
(flat (tcl-list-split (nth rest-args 1))))
|
|
(let
|
|
loop
|
|
((pairs flat) (acc interp))
|
|
(if
|
|
(< (len pairs) 2)
|
|
(assoc acc :result "")
|
|
(loop
|
|
(rest (rest pairs))
|
|
(tcl-var-set acc
|
|
(str arr-name "(" (first pairs) ")")
|
|
(nth pairs 1))))))))
|
|
((equal? sub "names")
|
|
(if
|
|
(= 0 (len rest-args))
|
|
(error "array names: wrong # args")
|
|
(let
|
|
((arr-name (first rest-args))
|
|
(pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
|
|
(let
|
|
((prefix (str arr-name "("))
|
|
(locals (get (get interp :frame) :locals)))
|
|
(let
|
|
((pl (string-length prefix)))
|
|
(let
|
|
((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
|
|
(let
|
|
((filtered
|
|
(if
|
|
(nil? pattern)
|
|
arr-keys
|
|
(filter
|
|
(fn (k)
|
|
(let ((kn (substring k pl (- (string-length k) 1))))
|
|
(tcl-glob-match (split pattern "") (split kn ""))))
|
|
arr-keys))))
|
|
(assoc interp :result
|
|
(join " " (map (fn (k) (substring k pl (- (string-length k) 1))) filtered))))))))))
|
|
((equal? sub "size")
|
|
(if
|
|
(= 0 (len rest-args))
|
|
(error "array size: wrong # args")
|
|
(let
|
|
((prefix (str (first rest-args) "("))
|
|
(locals (get (get interp :frame) :locals)))
|
|
(assoc interp :result
|
|
(str (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))))))
|
|
((equal? sub "exists")
|
|
(if
|
|
(= 0 (len rest-args))
|
|
(error "array exists: wrong # args")
|
|
(let
|
|
((prefix (str (first rest-args) "("))
|
|
(locals (get (get interp :frame) :locals)))
|
|
(assoc interp :result
|
|
(if (> (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))) 0) "1" "0")))))
|
|
((equal? sub "unset")
|
|
(if
|
|
(= 0 (len rest-args))
|
|
(error "array unset: wrong # args")
|
|
(let
|
|
((arr-name (first rest-args))
|
|
(pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
|
|
(let
|
|
((prefix (str arr-name "("))
|
|
(locals (get (get interp :frame) :locals)))
|
|
(let
|
|
((pl (string-length prefix)))
|
|
(let
|
|
((to-delete
|
|
(filter
|
|
(fn (k)
|
|
(if
|
|
(tcl-starts-with? k prefix)
|
|
(if
|
|
(nil? pattern)
|
|
true
|
|
(let ((kn (substring k pl (- (string-length k) 1))))
|
|
(tcl-glob-match (split pattern "") (split kn ""))))
|
|
false))
|
|
(keys locals))))
|
|
(let
|
|
((new-locals
|
|
(reduce
|
|
(fn (acc k)
|
|
(if
|
|
(contains? to-delete k)
|
|
acc
|
|
(assoc acc k (get locals k))))
|
|
{}
|
|
(keys locals))))
|
|
(assoc interp
|
|
:frame (assoc (get interp :frame) :locals new-locals)
|
|
:result ""))))))))
|
|
(else (error (str "array: unknown subcommand \"" sub "\""))))))))
|
|
|
|
|
|
(define
|
|
tcl-cmd-apply
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(< (len args) 1)
|
|
(error "apply: wrong # args: should be "apply lambdaList ?arg ...?"")
|
|
(let
|
|
((func-list (tcl-list-split (first args)))
|
|
(call-args (rest args)))
|
|
(if
|
|
(< (len func-list) 2)
|
|
(error "apply: lambdaList must be a 2 or 3 element list")
|
|
(let
|
|
((param-spec (first func-list))
|
|
(body (nth func-list 1))
|
|
(ns (if (> (len func-list) 2) (nth func-list 2) nil)))
|
|
(let
|
|
((proc-def {:args param-spec :body body :ns ns}))
|
|
(tcl-call-proc interp "#apply" proc-def call-args))))))))
|
|
|
|
|
|
(define
|
|
tcl-cmd-regexp
|
|
(fn
|
|
(interp args)
|
|
(define parse-flags
|
|
(fn (as nocase? all? inline?)
|
|
(if (= 0 (len as))
|
|
{:nocase nocase? :all all? :inline inline? :rest as}
|
|
(cond
|
|
((equal? (first as) "-nocase") (parse-flags (rest as) true all? inline?))
|
|
((equal? (first as) "-all") (parse-flags (rest as) nocase? true inline?))
|
|
((equal? (first as) "-inline") (parse-flags (rest as) nocase? all? true))
|
|
(else {:nocase nocase? :all all? :inline inline? :rest as})))))
|
|
(let ((pf (parse-flags args false false false)))
|
|
(let ((nocase (get pf :nocase))
|
|
(all-mode (get pf :all))
|
|
(inline-mode (get pf :inline))
|
|
(ra (get pf :rest)))
|
|
(if (< (len ra) 2)
|
|
(error "regexp: wrong # args")
|
|
(let ((pattern (first ra))
|
|
(str-val (nth ra 1))
|
|
(var-args (if (> (len ra) 2) (rest (rest ra)) (list))))
|
|
(let ((re (make-regexp pattern (if nocase "i" ""))))
|
|
(if all-mode
|
|
(assoc interp :result (str (len (regexp-match-all re str-val))))
|
|
(if inline-mode
|
|
(assoc interp :result (join " " (map (fn (m) (get m :match)) (regexp-match-all re str-val))))
|
|
(let ((m (regexp-match re str-val)))
|
|
(if (nil? m)
|
|
(assoc interp :result "0")
|
|
(let ((interp2
|
|
(if (> (len var-args) 0)
|
|
(tcl-var-set interp (first var-args) (get m :match))
|
|
interp)))
|
|
(let ((interp3
|
|
(let loop ((vi 1) (gs (get m :groups)) (acc interp2))
|
|
(if (or (= 0 (len gs)) (>= vi (len var-args))) acc
|
|
(loop (+ vi 1) (rest gs)
|
|
(tcl-var-set acc (nth var-args vi) (first gs)))))))
|
|
(assoc interp3 :result "1"))))))))))))))
|
|
|
|
(define
|
|
tcl-cmd-regsub
|
|
(fn
|
|
(interp args)
|
|
(define parse-flags
|
|
(fn (as all? nocase?)
|
|
(if (= 0 (len as))
|
|
{:all all? :nocase nocase? :rest as}
|
|
(cond
|
|
((equal? (first as) "-all") (parse-flags (rest as) true nocase?))
|
|
((equal? (first as) "-nocase") (parse-flags (rest as) all? true))
|
|
(else {:all all? :nocase nocase? :rest as})))))
|
|
(let ((pf (parse-flags args false false)))
|
|
(let ((all-mode (get pf :all))
|
|
(nocase (get pf :nocase))
|
|
(ra (get pf :rest)))
|
|
(if (< (len ra) 3)
|
|
(error "regsub: wrong # args")
|
|
(let ((pattern (first ra))
|
|
(str-val (nth ra 1))
|
|
(replacement (nth ra 2))
|
|
(var-name (if (> (len ra) 3) (nth ra 3) nil)))
|
|
(let ((re (make-regexp pattern (if nocase "i" ""))))
|
|
(let ((result
|
|
(if all-mode
|
|
(regexp-replace-all re str-val replacement)
|
|
(regexp-replace re str-val replacement))))
|
|
(if (nil? var-name)
|
|
(assoc interp :result result)
|
|
(let ((count
|
|
(if all-mode
|
|
(len (regexp-match-all re str-val))
|
|
(if (nil? (regexp-match re str-val)) 0 1))))
|
|
(assoc (tcl-var-set interp var-name result) :result (str count))))))))))))
|
|
|
|
|
|
|
|
(define
|
|
tcl-cmd-file
|
|
(fn
|
|
(interp args)
|
|
(if
|
|
(= 0 (len args))
|
|
(error "file: wrong # args")
|
|
(let
|
|
((sub (first args)) (rest-args (rest args)))
|
|
(cond
|
|
((equal? sub "exists") (assoc interp :result "0"))
|
|
((equal? sub "join") (assoc interp :result (join "/" rest-args)))
|
|
((equal? sub "split")
|
|
(assoc
|
|
interp
|
|
:result (tcl-list-build
|
|
(filter
|
|
(fn (s) (not (equal? s "")))
|
|
(split (first rest-args) "/")))))
|
|
((equal? sub "tail")
|
|
(let
|
|
((parts (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/"))))
|
|
(assoc
|
|
interp
|
|
:result (if (= 0 (len parts)) "" (last parts)))))
|
|
((equal? sub "dirname")
|
|
(let
|
|
((parts (filter (fn (s) (not (equal? s ""))) (split (first rest-args) "/"))))
|
|
(assoc
|
|
interp
|
|
:result (if
|
|
(<= (len parts) 1)
|
|
"."
|
|
(str
|
|
"/"
|
|
(join "/" (take-n parts (- (len parts) 1))))))))
|
|
((equal? sub "extension")
|
|
(let
|
|
((nm (first rest-args)))
|
|
(let
|
|
((dot-idx (tcl-string-last "." nm (- (string-length nm) 1))))
|
|
(assoc
|
|
interp
|
|
:result (if
|
|
(equal? dot-idx "-1")
|
|
""
|
|
(substring nm (parse-int dot-idx) (string-length nm)))))))
|
|
((equal? sub "rootname")
|
|
(let
|
|
((nm (first rest-args)))
|
|
(let
|
|
((dot-idx (tcl-string-last "." nm (- (string-length nm) 1))))
|
|
(assoc
|
|
interp
|
|
:result (if
|
|
(equal? dot-idx "-1")
|
|
nm
|
|
(substring nm 0 (parse-int dot-idx)))))))
|
|
((equal? sub "isfile") (assoc interp :result "0"))
|
|
((equal? sub "isdir") (assoc interp :result "0"))
|
|
((equal? sub "isdirectory") (assoc interp :result "0"))
|
|
((equal? sub "readable") (assoc interp :result "0"))
|
|
((equal? sub "writable") (assoc interp :result "0"))
|
|
((equal? sub "size") (assoc interp :result "0"))
|
|
((equal? sub "mkdir") (assoc interp :result ""))
|
|
((equal? sub "copy") (assoc interp :result ""))
|
|
((equal? sub "rename") (assoc interp :result ""))
|
|
((equal? sub "delete") (assoc interp :result ""))
|
|
(else (error (str "file: 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)))
|
|
(let
|
|
((i (tcl-register i "namespace" tcl-cmd-namespace)))
|
|
(let
|
|
((i (tcl-register i "coroutine" tcl-cmd-coroutine)))
|
|
(let
|
|
((i (tcl-register i "yield" tcl-cmd-yield)))
|
|
(let
|
|
((i (tcl-register i "yieldto" tcl-cmd-yieldto)))
|
|
(let
|
|
((i (tcl-register i "clock" tcl-cmd-clock)))
|
|
(let
|
|
((i (tcl-register i "open" tcl-cmd-open)))
|
|
(let
|
|
((i (tcl-register i "close" tcl-cmd-close)))
|
|
(let
|
|
((i (tcl-register i "read" tcl-cmd-read)))
|
|
(let
|
|
((i (tcl-register i "eof" tcl-cmd-eof)))
|
|
(let
|
|
((i (tcl-register i "seek" tcl-cmd-seek)))
|
|
(let
|
|
((i (tcl-register i "tell" tcl-cmd-tell)))
|
|
(let
|
|
((i (tcl-register i "flush" tcl-cmd-flush)))
|
|
(let ((i (tcl-register i "file" tcl-cmd-file)))
|
|
(let ((i (tcl-register i "regexp" tcl-cmd-regexp)))
|
|
(let ((i (tcl-register i "regsub" tcl-cmd-regsub))) (let ((i (tcl-register i "apply" tcl-cmd-apply))) (tcl-register i "array" tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|