diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index 7c7fe08c..6daf03d9 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -440,6 +440,23 @@ 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 @@ -456,129 +473,63 @@ (fn (name args) (let - ((a0 (if (> (len args) 0) (parse-int (first args)) 0)) - (a1 (if (> (len args) 1) (parse-int (nth args 1)) 0))) + ((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 a0)) + ((equal? name "int") (str (truncate a0))) ((equal? name "double") (str a0)) - ((equal? name "round") (str a0)) - ((equal? name "floor") (str a0)) - ((equal? name "ceil") (str a0)) - ((equal? name "sqrt") (str (tcl-isqrt a0))) - ((equal? name "pow") (str (tcl-pow a0 a1))) + ((equal? name "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") "0") - ((equal? name "cos") "1") - ((equal? name "tan") "0") + ((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) - (cond - ((equal? op "+") (str (+ (parse-int l) (parse-int r)))) - ((equal? op "-") (str (- (parse-int l) (parse-int r)))) - ((equal? op "*") (str (* (parse-int l) (parse-int r)))) - ((equal? op "/") (str (/ (parse-int l) (parse-int r)))) - ((equal? op "%") (str (mod (parse-int l) (parse-int r)))) - ((equal? op "==") (if (equal? l r) "1" "0")) - ((equal? op "!=") (if (equal? l r) "0" "1")) - ((equal? op "<") (if (< (parse-int l) (parse-int r)) "1" "0")) - ((equal? op ">") (if (> (parse-int l) (parse-int r)) "1" "0")) - ((equal? op "<=") (if (<= (parse-int l) (parse-int r)) "1" "0")) - ((equal? op ">=") (if (>= (parse-int l) (parse-int r)) "1" "0")) - ((equal? op "&&") (if (and (tcl-true? l) (tcl-true? r)) "1" "0")) - ((equal? op "||") (if (or (tcl-true? l) (tcl-true? r)) "1" "0")) - ((equal? op "**") (str (tcl-pow (parse-int l) (parse-int r)))) - (else (error (str "expr: unknown op: " op)))))) + (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 "")))) + ((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 (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 @@ -606,9 +557,7 @@ {:args (list) :tokens tokens} (let ((r (tcl-expr-parse-or tokens))) - (tcl-expr-parse-args-rest - (get r :tokens) - (list (get r :value))))))) + (tcl-expr-parse-args-rest (get r :tokens) (list (get r :value))))))) (define tcl-expr-parse-primary @@ -626,21 +575,23 @@ (let ((after (get inner :tokens))) (if - (and (> (len after) 0) (equal? (first after) ")")) - {:value (get inner :value) :tokens (rest after)} + (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) "(")) + ((and (> (len rest-toks) 0) (equal? (first rest-toks) "(")) (let ((args-r (tcl-expr-parse-args (rest rest-toks)))) (let ((after-args (get args-r :tokens))) (if - (and (> (len after-args) 0) (equal? (first after-args) ")")) - {:value (tcl-apply-func tok (get args-r :args)) :tokens (rest after-args)} + (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 {:value tok :tokens rest-toks})))))) + (else {:tokens rest-toks :value tok})))))) (define tcl-expr-parse-unary @@ -653,15 +604,10 @@ ((tok (first tokens))) (cond ((equal? tok "!") - (let - ((r (tcl-expr-parse-unary (rest tokens)))) - {:value (if (tcl-false? (get r :value)) "1" "0") :tokens (get r :tokens)})) + (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)))) - {:value (str (- 0 (parse-int (get r :value)))) :tokens (get r :tokens)})) - ((equal? tok "+") - (tcl-expr-parse-unary (rest tokens))) + (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 @@ -673,19 +619,23 @@ (let ((base-val (get base-r :value)) (rest-toks (get base-r :tokens))) (if - (and (> (len rest-toks) 0) (equal? (first rest-toks) "**")) + (and + (> (len rest-toks) 0) + (equal? (first rest-toks) "**")) (let ((exp-r (tcl-expr-parse-power (rest rest-toks)))) - {:value (str (tcl-pow (parse-int base-val) (parse-int (get exp-r :value)))) :tokens (get exp-r :tokens)}) - {:value base-val :tokens rest-toks}))))) + {: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)))) - {:value left :tokens tokens} + (or + (= 0 (len tokens)) + (not (contains? (list "*" "/" "%") (first tokens)))) + {:tokens tokens :value left} (let ((op (first tokens))) (let @@ -707,8 +657,10 @@ (fn (tokens left) (if - (or (= 0 (len tokens)) (not (contains? (list "+" "-") (first tokens)))) - {:value left :tokens tokens} + (or + (= 0 (len tokens)) + (not (contains? (list "+" "-") (first tokens)))) + {:tokens tokens :value left} (let ((op (first tokens))) (let @@ -730,8 +682,10 @@ (fn (tokens left) (if - (or (= 0 (len tokens)) (not (contains? (list "<" ">" "<=" ">=") (first tokens)))) - {:value left :tokens tokens} + (or + (= 0 (len tokens)) + (not (contains? (list "<" ">" "<=" ">=") (first tokens)))) + {:tokens tokens :value left} (let ((op (first tokens))) (let @@ -753,8 +707,10 @@ (fn (tokens left) (if - (or (= 0 (len tokens)) (not (contains? (list "==" "!=") (first tokens)))) - {:value left :tokens tokens} + (or + (= 0 (len tokens)) + (not (contains? (list "==" "!=") (first tokens)))) + {:tokens tokens :value left} (let ((op (first tokens))) (let @@ -777,7 +733,7 @@ (tokens left) (if (or (= 0 (len tokens)) (not (equal? (first tokens) "&&"))) - {:value left :tokens tokens} + {:tokens tokens :value left} (let ((r (tcl-expr-parse-equality (rest tokens)))) (tcl-expr-parse-and-rest @@ -798,7 +754,7 @@ (tokens left) (if (or (= 0 (len tokens)) (not (equal? (first tokens) "||"))) - {:value left :tokens tokens} + {:tokens tokens :value left} (let ((r (tcl-expr-parse-and (rest tokens)))) (tcl-expr-parse-or-rest @@ -835,15 +791,15 @@ ((wr (tcl-eval-words (get (first cmds) :words) interp))) (let ((flat (join " " (get wr :values)))) - (let - ((tokens (tcl-expr-tokenize flat))) - {:result (tcl-expr-parse tokens) :interp (get wr :interp)}))))))) - -(define tcl-cmd-break (fn (interp args) (assoc interp :code 3))) - -(define tcl-cmd-continue (fn (interp args) (assoc interp :code 4))) + (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 @@ -856,60 +812,31 @@ ((equal? s "continue") 4) (else (parse-int s))))) -; Parse return options from args list -; Returns {:code N :result val :errorinfo str :errorcode str} (define tcl-parse-return-opts (fn (args) (let - ((go - (fn - (remaining code ei ec) - (if - (or (= 0 (len remaining)) (not (equal? (substring (first remaining) 0 1) "-"))) - {:code code :result (if (> (len remaining) 0) (first remaining) "") :errorinfo ei :errorcode ec} - (let - ((flag (first remaining)) (rest1 (rest remaining))) - (cond - ((equal? flag "-code") - (if - (= 0 (len rest1)) - {:code code :result "" :errorinfo ei :errorcode ec} - (go (rest rest1) (tcl-return-code-num (first rest1)) ei ec))) - ((equal? flag "-errorinfo") - (if - (= 0 (len rest1)) - {:code code :result "" :errorinfo "" :errorcode ec} - (go (rest rest1) code (first rest1) ec))) - ((equal? flag "-errorcode") - (if - (= 0 (len rest1)) - {:code code :result "" :errorinfo ei :errorcode ""} - (go (rest rest1) code ei (first rest1)))) - ((equal? flag "-level") - ; stub: consume the level arg and ignore - (if - (= 0 (len rest1)) - {:code code :result "" :errorinfo ei :errorcode ec} - (go (rest rest1) code ei ec))) - (else - ; unknown flag: treat as value - {:code code :result flag :errorinfo ei :errorcode ec}))))))) + ((go (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 + (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 @@ -920,18 +847,18 @@ (ec (if (> (len args) 2) (nth args 2) ""))) (assoc interp :result msg :code 1 :errorinfo ei :errorcode ec)))) -; --- catch command --- -; catch script ?resultVar? ?optionsVar? +; --- 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)) + (result-var + (if (> (len args) 1) (nth args 1) nil)) (opts-var (if (> (len args) 2) (nth args 2) nil))) (let - ; run script in a sub-interp with code/result/output reset ((sub-interp (assoc interp :code 0 :result "" :output "")) (caller-output (get interp :output))) (let @@ -943,29 +870,15 @@ (rec (get result-interp :errorcode)) (sub-output (get result-interp :output))) (let - ; merge sub-interp frame changes back but reset code to 0 - ((merged (assoc result-interp - :code 0 - :result (str rc) - :output (str caller-output sub-output)))) + ((merged (assoc result-interp :code 0 :result (str rc) :output (str caller-output sub-output)))) (let - ; set resultVar if given - ((after-rv - (if (nil? result-var) - merged - (tcl-var-set merged result-var rv)))) + ((after-rv (if (nil? result-var) merged (tcl-var-set merged result-var rv)))) (let - ; set optsVar if given ((opts-str (str "-code " rc " -errorinfo " (if (equal? rei "") "{}" rei) " -errorcode " (if (equal? rec "") "{}" rec)))) (let - ((after-opts - (if (nil? opts-var) - after-rv - (tcl-var-set after-rv opts-var opts-str)))) + ((after-opts (if (nil? opts-var) after-rv (tcl-var-set after-rv opts-var opts-str)))) (assoc after-opts :result (str rc)))))))))))) -; --- throw command --- -; throw type message (define tcl-cmd-throw (fn @@ -975,8 +888,6 @@ (msg (if (> (len args) 1) (nth args 1) ""))) (assoc interp :result msg :code 1 :errorcode ec :errorinfo "")))) -; --- try command --- -; try script ?on code var body? ... ?finally body? (define tcl-try-code-matches? (fn @@ -994,34 +905,10 @@ (fn (interp args) (let - ((script (first args)) - (rest-args (rest args))) - ; Parse clauses: list of {:type "on"|"finally" :code str :var str :body str} + ((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 {:type "on" :code (nth remaining 1) :var (nth remaining 2) :body (nth remaining 3)}))))) - ((equal? kw "finally") - (if (< (len remaining) 2) - acc - (parse-clauses - (slice remaining 2 (len remaining)) - (append acc (list {:type "finally" :body (nth remaining 1)}))))) - (else acc)))))) + ((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)))) - ; Run the main script (let ((sub-interp (assoc interp :code 0 :result "")) (caller-output (get interp :output))) @@ -1031,56 +918,20 @@ ((rc (get result-interp :code)) (rv (get result-interp :result)) (sub-output (get result-interp :output))) - ; Find matching "on" clause (let - ((find-clause - (fn - (cs) - (if - (= 0 (len cs)) - nil - (let - ((c (first cs))) - (if - (and (equal? (get c :type) "on") (tcl-try-code-matches? (get c :code) rc)) - c - (find-clause (rest cs))))))) + ((find-clause (fn (cs) (if (= 0 (len cs)) nil (let ((c (first cs))) (if (and (equal? (get c :type) "on") (tcl-try-code-matches? (get c :code) rc)) c (find-clause (rest cs))))))) (matched (find-clause clauses)) - ; Find finally clause (finally-clause (reduce - (fn (acc c) (if (equal? (get c :type) "finally") c acc)) + (fn + (acc c) + (if (equal? (get c :type) "finally") c acc)) nil clauses))) - ; Evaluate matched handler if any (let - ((after-handler - (if - (nil? matched) - (assoc result-interp :output (str caller-output sub-output)) - (let - ((handler-interp - (assoc result-interp - :code 0 - :output (str caller-output sub-output)))) - (let - ((bound-interp - (if (equal? (get matched :var) "") - handler-interp - (tcl-var-set handler-interp (get matched :var) rv)))) - (tcl-eval-string bound-interp (get matched :body))))))) - ; Run finally if present + ((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)))) - ; Restore code from after-handler unless finally itself errored - (if (= (get fi :code) 0) - (assoc fi :code (get after-handler :code) :result (get after-handler :result)) - fi))))) + ((final-result (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 @@ -1280,20 +1131,25 @@ ((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: repeat char ch n times, building pad string +; 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))))) + (if + (<= cnt 0) + acc + (tcl-fmt-make-pad ch (- cnt 1) (str ch acc))))) -; Format helper: pad string s to width w +; Format helper: scan digits for width/precision (define tcl-fmt-pad (fn @@ -1309,7 +1165,7 @@ ((pad (tcl-fmt-make-pad (if zero-pad? "0" " ") pad-len ""))) (if left-align? (str s pad) (str pad s)))))))) -; Format helper: scan flag characters +; Main format apply: process chars, produce output string (define tcl-fmt-scan-flags (fn @@ -1324,22 +1180,20 @@ (tcl-fmt-scan-flags chars (+ j 1) (str flags ch)) {:j j :flags flags}))))) -; Format helper: scan digits for width/precision (define tcl-fmt-scan-num (fn (chars j acc-n) (if (>= j (len chars)) - {:j j :num acc-n} + {: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)) - {:j j :num acc-n}))))) + {:num acc-n :j j}))))) -; Main format apply: process chars, produce output string (define tcl-fmt-apply (fn @@ -1351,8 +1205,13 @@ ((c (nth chars i))) (if (not (equal? c "%")) - (tcl-fmt-apply chars n-len fmt-args (+ i 1) arg-idx (str acc c)) - ; parse specifier + (tcl-fmt-apply + chars + n-len + fmt-args + (+ i 1) + arg-idx + (str acc c)) (let ((i2 (+ i 1))) (if @@ -1362,8 +1221,13 @@ ((c2 (nth chars i2))) (if (equal? c2 "%") - (tcl-fmt-apply chars n-len fmt-args (+ i2 1) arg-idx (str acc "%")) - ; scan flags + (tcl-fmt-apply + chars + n-len + fmt-args + (+ i2 1) + arg-idx + (str acc "%")) (let ((fr (tcl-fmt-scan-flags chars i2 ""))) (let @@ -1372,40 +1236,35 @@ ((wr (tcl-fmt-scan-num chars j ""))) (let ((width (get wr :num)) (j2 (get wr :j))) - ; skip precision .N (let - ((j3 - (if - (and (< j2 n-len) (equal? (nth chars j2) ".")) - (let ((pr (tcl-fmt-scan-num chars (+ j2 1) ""))) (get pr :j)) - j2))) + ((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) ""))) + (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 "") "-"))) + (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)))))))))))))))))))) + ((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 @@ -1416,29 +1275,25 @@ (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 ""))))))) + ((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"))) -; --- string command helpers --- - -; glob match: pattern chars list, string chars list (define tcl-glob-match (fn (pat-chars str-chars) (cond - ; both exhausted → success - ((and (= 0 (len pat-chars)) (= 0 (len str-chars))) true) - ; pattern exhausted but string remains → fail + ((and (= 0 (len pat-chars)) (= 0 (len str-chars))) + true) ((= 0 (len pat-chars)) false) - ; leading * in pattern ((equal? (first pat-chars) "*") (let ((rest-pat (rest pat-chars))) - ; * can match zero chars (skip *) or consume one str char and retry (if (tcl-glob-match rest-pat str-chars) true @@ -1446,77 +1301,109 @@ (= 0 (len str-chars)) false (tcl-glob-match pat-chars (rest str-chars)))))) - ; string exhausted but pattern non-empty (and not *) → fail ((= 0 (len str-chars)) false) - ; ? matches any single char ((equal? (first pat-chars) "?") (tcl-glob-match (rest pat-chars) (rest str-chars))) - ; literal match ((equal? (first pat-chars) (first str-chars)) (tcl-glob-match (rest pat-chars) (rest str-chars))) - ; literal mismatch (else false)))) -; toupper/tolower via char tables +; 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") + ((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") + ((equal? c "A") "a") + ((equal? c "B") "b") + ((equal? c "C") "c") + ((equal? c "D") "d") + ((equal? c "E") "e") + ((equal? c "F") "f") + ((equal? c "G") "g") + ((equal? c "H") "h") + ((equal? c "I") "i") + ((equal? c "J") "j") + ((equal? c "K") "k") + ((equal? c "L") "l") + ((equal? c "M") "m") + ((equal? c "N") "n") + ((equal? c "O") "o") + ((equal? c "P") "p") + ((equal? c "Q") "q") + ((equal? c "R") "r") + ((equal? c "S") "s") + ((equal? c "T") "t") + ((equal? c "U") "u") + ((equal? c "V") "v") + ((equal? c "W") "w") + ((equal? c "X") "x") + ((equal? c "Y") "y") + ((equal? c "Z") "z") (else c)))) -; strip chars from left (define tcl-trim-left-chars (fn (chars strip-set) (if - (or (= 0 (len chars)) (not (contains? strip-set (first chars)))) + (or + (= 0 (len chars)) + (not (contains? strip-set (first chars)))) chars (tcl-trim-left-chars (rest chars) strip-set)))) -; strip chars from right (reverse, trim left, reverse) +; 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)))) + (tcl-reverse-list + (tcl-trim-left-chars (tcl-reverse-list chars) strip-set)))) -; default whitespace set -(define - tcl-ws-set - (list " " "\t" "\n" "\r")) +; string first: index of needle in haystack starting at start +(define tcl-ws-set (list " " "\t" "\n" "\r")) -; string map: apply flat list of pairs old→new to string +; string last: last index of needle in haystack up to end (define tcl-string-map-apply (fn @@ -1525,26 +1412,16 @@ (< (len pairs) 2) s (let - ((old (first pairs)) (new-s (nth pairs 1)) (rest-pairs (rest (rest pairs)))) + ((old (first pairs)) + (new-s (nth pairs 1)) + (rest-pairs (rest (rest pairs)))) (let - ((old-chars (split old "")) - (old-len (string-length old))) + ((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))))))) + ((go (fn (i acc) (if (>= i (string-length s)) acc (let ((chunk (if (> (+ i old-len) (string-length s)) "" (substring s i (+ i old-len))))) (if (equal? chunk old) (go (+ i old-len) (str acc new-s)) (go (+ i 1) (str acc (substring s i (+ i 1)))))))))) + (tcl-string-map-apply (go 0 "") rest-pairs))))))) -; string first: index of needle in haystack starting at start +; string is: check string class (define tcl-string-first (fn @@ -1555,19 +1432,9 @@ (= 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 (fn (i) (if (> (+ i nl) hl) "-1" (if (equal? (substring haystack i (+ i nl)) needle) (str i) (go (+ i 1))))))) (go start)))))) -; string last: last index of needle in haystack up to end (define tcl-string-last (fn @@ -1580,28 +1447,19 @@ (= 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 (fn (i) (if (< i 0) "-1" (if (and (<= (+ i nl) hl) (equal? (substring haystack i (+ i nl)) needle)) (str i) (go (- i 1))))))) (go (- (+ bound 1) nl)))))))) -; string is: check string class + +; --- 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))) + ((chars (split s "")) (n (string-length s))) (cond ((equal? class "integer") (if @@ -1625,7 +1483,17 @@ "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")))) + (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" @@ -1643,7 +1511,12 @@ (= n 0) "0" (if - (reduce (fn (ok c) (and ok (or (tcl-expr-alpha? c) (tcl-expr-digit? c)))) true chars) + (reduce + (fn + (ok c) + (and ok (or (tcl-expr-alpha? c) (tcl-expr-digit? c)))) + true + chars) "1" "0"))) ((equal? class "digit") @@ -1673,8 +1546,33 @@ (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") + (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) @@ -1691,8 +1589,33 @@ (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") + (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) @@ -1700,14 +1623,20 @@ "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")) + (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 @@ -1718,20 +1647,18 @@ (let ((sub (first args)) (rest-args (rest args))) (cond - ; string length s ((equal? sub "length") (assoc interp :result (str (string-length (first rest-args))))) - ; string index s i ((equal? sub "index") (let - ((s (first rest-args)) (idx (parse-int (nth rest-args 1)))) + ((s (first rest-args)) + (idx (parse-int (nth rest-args 1)))) (let ((n (string-length s))) (if (or (< idx 0) (>= idx n)) (assoc interp :result "") (assoc interp :result (substring s idx (+ idx 1))))))) - ; string range s first last ((equal? sub "range") (let ((s (first rest-args)) @@ -1746,116 +1673,112 @@ (> f l) (assoc interp :result "") (assoc interp :result (substring s f (+ l 1)))))))) - ; string compare s1 s2 ((equal? sub "compare") (let ((s1 (first rest-args)) (s2 (nth rest-args 1))) (assoc interp - :result - (cond - ((equal? s1 s2) "0") - ((< s1 s2) "-1") - (else "1"))))) - ; string match pattern s + :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")))) - ; string toupper s + :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 "")))))) - ; string tolower s + :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 "")))))) - ; string trim s ?chars? + :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))) + (strip-set + (if + (> (len rest-args) 1) + (split (nth rest-args 1) "") + tcl-ws-set))) (let ((chars (split s ""))) (assoc interp - :result - (join "" (tcl-trim-right-chars (tcl-trim-left-chars chars strip-set) strip-set)))))) - ; string trimleft s ?chars? + :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))) + (strip-set + (if + (> (len rest-args) 1) + (split (nth rest-args 1) "") + tcl-ws-set))) (assoc interp - :result - (join "" (tcl-trim-left-chars (split s "") strip-set))))) - ; string trimright s ?chars? + :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))) + (strip-set + (if + (> (len rest-args) 1) + (split (nth rest-args 1) "") + tcl-ws-set))) (assoc interp - :result - (join "" (tcl-trim-right-chars (split s "") strip-set))))) - ; string map mapping s + :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))))) - ; string repeat s n + :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)))) + ((s (first rest-args)) + (n (parse-int (nth rest-args 1)))) (assoc interp - :result - (let + :result (let ((go (fn (i acc) (if (>= i n) acc (go (+ i 1) (str acc s)))))) (go 0 ""))))) - ; string first needle haystack ?start? ((equal? sub "first") (let ((needle (first rest-args)) (haystack (nth rest-args 1)) - (start (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) 0))) + (start + (if + (> (len rest-args) 2) + (parse-int (nth rest-args 2)) + 0))) (assoc interp :result (tcl-string-first needle haystack start)))) - ; string last needle haystack ?end? ((equal? sub "last") (let ((needle (first rest-args)) (haystack (nth rest-args 1)) - (end-idx (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) -1))) + (end-idx + (if + (> (len rest-args) 2) + (parse-int (nth rest-args 2)) + -1))) (assoc interp :result (tcl-string-last needle haystack end-idx)))) - ; string is class s ((equal? sub "is") (let ((class (first rest-args)) (s (nth rest-args 1))) (assoc interp :result (tcl-string-is class s)))) - ; string cat ?args...? - ((equal? sub "cat") - (assoc interp :result (join "" rest-args))) + ((equal? sub "cat") (assoc interp :result (join "" rest-args))) (else (error (str "string: unknown subcommand: " sub)))))))) - -; --- list command helpers --- - -; Quote a single list element: add braces if it contains a space or is empty +; Resolve "end" index to numeric value given list length (define tcl-list-quote-elem (fn @@ -1865,19 +1788,17 @@ (str "{" elem "}") elem))) -; Build a Tcl list string from an SX list of string elements +; 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)))) -; Resolve "end" index to numeric value given list length (define tcl-end-index - (fn - (s n) - (if (equal? s "end") (- n 1) (parse-int s)))) + (fn (s n) (if (equal? s "end") (- n 1) (parse-int s)))) + +; --- list commands --- -; Insertion sort for list commands (comparator: fn(a b) -> true if a before b) (define tcl-insert-sorted (fn @@ -1888,7 +1809,9 @@ (if (before? x (first lst)) (append (list x) lst) - (append (list (first lst)) (tcl-insert-sorted (rest lst) before? x)))))) + (append + (list (first lst)) + (tcl-insert-sorted (rest lst) before? x)))))) (define tcl-insertion-sort @@ -1899,13 +1822,9 @@ (list) lst))) -; --- list commands --- - (define tcl-cmd-list - (fn - (interp args) - (assoc interp :result (tcl-list-build args)))) + (fn (interp args) (assoc interp :result (tcl-list-build args)))) (define tcl-cmd-lindex @@ -1913,11 +1832,13 @@ (interp args) (let ((elems (tcl-list-split (first args))) - (idx (tcl-end-index (nth args 1) (len (tcl-list-split (first args)))))) + (idx + (tcl-end-index + (nth args 1) + (len (tcl-list-split (first args)))))) (assoc interp - :result - (if + :result (if (or (< idx 0) (>= idx (len elems))) "" (nth elems idx)))))) @@ -1937,8 +1858,7 @@ (l (if (>= li n) (- n 1) li))) (assoc interp - :result - (if + :result (if (> f l) "" (tcl-list-build (slice elems f (+ l 1)))))))))) @@ -1955,8 +1875,7 @@ (interp args) (assoc interp - :result - (tcl-list-build (tcl-reverse-list (tcl-list-split (first args))))))) + :result (tcl-list-build (tcl-reverse-list (tcl-list-split (first args))))))) (define tcl-cmd-lsearch @@ -1964,8 +1883,16 @@ (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)))) + (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 @@ -1990,20 +1917,33 @@ (fn (remaining) (if - (or (= 0 (len remaining)) (not (equal? (substring (first remaining) 0 1) "-"))) + (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")) + (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")) + (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")) + (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)) + (let + ((r (parse-opts (rest remaining)))) + (assoc r :decreasing true)) {:mode "ascii" :decreasing false :list-str (first remaining)}))))))) (let ((opts (parse-opts args))) @@ -2012,17 +1952,12 @@ (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))))) + ((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 + :result (tcl-list-build (if decreasing? (tcl-reverse-list sorted) sorted))))))))) (define @@ -2044,11 +1979,13 @@ (after (slice elems (+ l 1) n))) (assoc interp - :result - (tcl-list-build + :result (tcl-list-build (reduce (fn (acc x) (append acc (list x))) - (reduce (fn (acc x) (append acc (list x))) before new-elems) + (reduce + (fn (acc x) (append acc (list x))) + before + new-elems) after))))))))) (define @@ -2062,23 +1999,19 @@ (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)))))) + ((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 + :result (tcl-list-build (reduce (fn (acc x) (append acc (list x))) - (reduce (fn (acc x) (append acc (list x))) before new-elems) + (reduce + (fn (acc x) (append acc (list x))) + before + new-elems) after))))))))) (define @@ -2086,13 +2019,12 @@ (fn (interp args) (let - ((all-elems - (reduce - (fn (acc s) (append acc (tcl-list-split s))) - (list) - args))) + ((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 @@ -2101,13 +2033,10 @@ ((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)))) + ((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 @@ -2117,9 +2046,7 @@ (sep (if (> (len args) 1) (nth args 1) " "))) (assoc interp :result (join sep elems))))) -; --- dict command helpers --- - -; Parse flat dict string into SX list of [key val] pairs +; Get value for key from flat dict string; returns nil if missing (define tcl-dict-to-pairs (fn @@ -2127,30 +2054,25 @@ (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 (fn (lst acc) (if (= 0 (len lst)) acc (if (= 1 (len lst)) (error "dict: malformed dict (odd number of elements)") (go (rest (rest lst)) (append acc (list (list (first lst) (nth lst 1)))))))))) (go flat (list)))))) -; Build flat dict string from SX list of [key val] pairs +; 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)))) + (fn + (acc pair) + (append + (append acc (list (first pair))) + (list (nth pair 1)))) (list) pairs)))) -; Get value for key from flat dict string; returns nil if missing +; Remove key from flat dict string; returns new flat dict string (define tcl-dict-get (fn @@ -2158,19 +2080,11 @@ (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 (fn (lst) (if (< (len lst) 2) nil (if (equal? (first lst) key) (nth lst 1) (go (rest (rest lst)))))))) (go flat))))) -; Set key=val in flat dict string; returns new flat dict string +; --- dict command --- + (define tcl-dict-set-pair (fn @@ -2181,19 +2095,28 @@ ((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 + (map + (fn + (pair) + (if (equal? (first pair) key) (list key val) pair)) + pairs)) (tcl-dict-from-pairs (append pairs (list (list key val))))))))) -; Remove key from flat dict string; returns new flat dict string +; --- 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))))) - -; --- dict command --- + (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 @@ -2204,23 +2127,22 @@ (let ((sub (first args)) (rest-args (rest args))) (cond - ; dict create ?key val …? ((equal? sub "create") (if (= 1 (mod (len rest-args) 2)) (error "dict create: wrong # args (must be even)") (assoc interp :result (tcl-list-build rest-args)))) - ; dict get dict key ((equal? sub "get") (let - ((dict-str (first rest-args)) (key (nth rest-args 1))) + ((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")) + (error + (str "dict get: key \"" key "\" not known in dictionary")) (assoc interp :result val))))) - ; dict set varname key val ((equal? sub "set") (let ((varname (first rest-args)) @@ -2230,46 +2152,55 @@ ((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))))) - ; dict unset varname key + (assoc + (tcl-var-set interp varname new-dict) + :result new-dict))))) ((equal? sub "unset") (let - ((varname (first rest-args)) (key (nth rest-args 1))) + ((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))))) - ; dict exists dict 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")))) - ; dict keys dict ?pattern? + ((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))) + (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)))) + ((filtered (if (nil? pattern) all-keys (filter (fn (k) (tcl-glob-match (split pattern "") (split k ""))) all-keys)))) (assoc interp :result (tcl-list-build filtered)))))) - ; dict values dict ((equal? sub "values") (let ((dict-str (first rest-args))) - (assoc interp :result (tcl-list-build (map (fn (pair) (nth pair 1)) (tcl-dict-to-pairs dict-str)))))) - ; dict size dict + (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)))))) - ; dict for {kvar vvar} dict body + (assoc + interp + :result (str (len (tcl-dict-to-pairs dict-str)))))) ((equal? sub "for") (let ((var-pair-str (first rest-args)) @@ -2278,7 +2209,8 @@ (let ((var-list (tcl-list-split var-pair-str))) (let - ((kvar (first var-list)) (vvar (nth var-list 1))) + ((kvar (first var-list)) + (vvar (nth var-list 1))) (let ((pairs (tcl-dict-to-pairs dict-str))) (define @@ -2297,12 +2229,15 @@ (let ((code (get body-result :code))) (cond - ((= code 3) (assoc body-result :code 0)) + ((= 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))))))))))) + (else + (dict-for-loop + (assoc body-result :code 0) + (rest ps))))))))))) (dict-for-loop interp pairs)))))) - ; dict update varname key var … body ((equal? sub "update") (let ((varname (first rest-args))) @@ -2314,60 +2249,25 @@ (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)))) + ((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 (fn (i-interp remaining new-dict) (if (< (len remaining) 2) (assoc (tcl-var-set i-interp varname new-dict) :result new-dict) (let ((k (first remaining)) (var (nth remaining 1))) (let ((new-val (frame-lookup (get body-result :frame) var))) (write-back i-interp (rest (rest remaining)) (if (nil? new-val) (tcl-dict-unset-key new-dict k) (tcl-dict-set-pair new-dict k new-val))))))))) (write-back body-result kv-args cur))))))))) - ; dict merge ?dict…? ((equal? sub "merge") (let - ((merged - (reduce - (fn - (acc dict-str) - (reduce - (fn (a pair) (tcl-dict-set-pair a (first pair) (nth pair 1))) - acc - (tcl-dict-to-pairs dict-str))) - "" - rest-args))) + ((merged (reduce (fn (acc dict-str) (reduce (fn (a pair) (tcl-dict-set-pair a (first pair) (nth pair 1))) acc (tcl-dict-to-pairs dict-str))) "" rest-args))) (assoc interp :result merged))) - ; dict incr varname key ?increment? ((equal? sub "incr") (let ((varname (first rest-args)) (key (nth rest-args 1)) - (delta (if (> (len rest-args) 2) (parse-int (nth rest-args 2)) 1))) + (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 @@ -2376,13 +2276,15 @@ ((new-val (str (+ (parse-int old-val) delta)))) (let ((new-dict (tcl-dict-set-pair cur key new-val))) - (assoc (tcl-var-set interp varname new-dict) :result new-dict))))))) - ; dict append varname key ?string…? + (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))))) + (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 @@ -2391,13 +2293,14 @@ ((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))))))) + (assoc + (tcl-var-set interp varname new-dict) + :result new-dict))))))) (else (error (str "dict: unknown subcommand \"" sub "\"")))))))) -; --- namespace helpers --- - -; Normalize a namespace name to fully-qualified form: ::ns -; Accepts: "ns", "::ns", "ns::", "::ns::", "" → "::" +; 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 @@ -2406,19 +2309,14 @@ (or (equal? ns "") (equal? ns "::")) "::" (let - ; strip trailing :: - ((stripped - (if - (equal? (substring ns (- (string-length ns) 2) (string-length ns)) "::") - (substring ns 0 (- (string-length ns) 2)) - ns))) - ; ensure leading :: + ((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)))))) -; Test whether string s starts with prefix p +; Look up a command by name with namespace resolution. +; Try: exact name → ::current-ns::name → ::name (define tcl-starts-with? (fn @@ -2427,9 +2325,7 @@ ((pl (string-length p)) (sl (string-length s))) (if (> pl sl) false (equal? (substring s 0 pl) p))))) -; Qualify a proc name relative to current-ns. -; If name already starts with :: return as-is. -; Otherwise prepend current-ns:: (or :: if current-ns is ::). +; Get all proc names in a namespace (returns list of fully-qualified names) (define tcl-qualify-name (fn @@ -2442,34 +2338,32 @@ (str "::" name) (str current-ns "::" name))))) -; Look up a command by name with namespace resolution. -; Try: exact name → ::current-ns::name → ::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))) + ((procs (get interp :procs)) (current-ns (get interp :current-ns))) (let ((exact (get procs name))) - (if (not (nil? exact)) - {:name name :def exact} + (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)) - {:name qualified :def qual-def} + (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)) - {:name global-name :def global-def} - nil))))))))))) + (if (not (nil? global-def)) {:def global-def :name global-name} nil))))))))))) -; Get all proc names in a namespace (returns list of fully-qualified names) +; Extract last component from qualified name ::ns::foo → foo (define tcl-ns-procs (fn @@ -2477,32 +2371,40 @@ (let ((prefix (if (equal? ns "::") "::" (str ns "::")))) (filter - (fn (k) - (if (equal? ns "::") - ; global ns: keys that start with :: but have no further :: + (fn + (k) + (if + (equal? ns "::") (and (tcl-starts-with? k "::") - (not (tcl-starts-with? (substring k 2 (string-length k)) "::"))) + (not + (tcl-starts-with? + (substring k 2 (string-length k)) + "::"))) (tcl-starts-with? k prefix))) (keys procs))))) -; Check if a namespace exists (has any procs) +; --- proc command --- + (define tcl-ns-exists? - (fn - (procs ns) - (> (len (tcl-ns-procs procs ns)) 0))) + (fn (procs ns) (> (len (tcl-ns-procs procs ns)) 0))) -; Extract last component from qualified name ::ns::foo → foo +; --- 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)))))) + (if + (= 0 (len parts)) + name + (nth parts (- (len parts) 1)))))) -; --- proc command --- +; --- uplevel command --- (define tcl-cmd-proc @@ -2513,36 +2415,26 @@ (arg-spec (nth args 1)) (body (nth args 2))) (let - ; qualify name based on current namespace ((name (tcl-qualify-name raw-name (get interp :current-ns)))) (let - ; extract the namespace of the proc for runtime context - ((proc-ns - (let - ((parts (filter (fn (p) (not (equal? p ""))) (split name ":")))) - ; proc-ns is all but last component, re-joined as ::ns or :: - (if (<= (len parts) 1) - "::" - (str "::" (join "::" (take-n parts (- (len parts) 1)))))))) - (assoc interp + ((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 "")))))) -; --- parse uplevel/upvar level argument --- -; Returns absolute level number. -; current-level = len(frame-stack) +; --- upvar command --- + (define tcl-parse-level (fn (level-str current-level) (if (equal? (substring level-str 0 1) "#") - ; absolute: #N (parse-int (substring level-str 1 (string-length level-str))) - ; relative: N levels up from current (- current-level (parse-int level-str))))) -; --- uplevel command --- +; --- global command --- (define tcl-cmd-uplevel @@ -2551,19 +2443,31 @@ (let ((current-level (len (get interp :frame-stack)))) (let - ; check if first arg is a level specifier - ((has-level - (and - (> (len args) 1) - (or - (equal? (substring (first args) 0 1) "#") - (let - ((fst (first args))) - (and - (> (string-length fst) 0) - (tcl-expr-digit? (substring fst 0 1))))))) - (level-str (if (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (and (> (string-length (first args)) 0) (tcl-expr-digit? (substring (first args) 0 1))))) (first args) "1")) - (script (if (and (> (len args) 1) (or (equal? (substring (first args) 0 1) "#") (and (> (string-length (first args)) 0) (tcl-expr-digit? (substring (first args) 0 1))))) (nth args 1) (first args)))) + ((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 @@ -2571,11 +2475,7 @@ (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 "")) + ((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))) @@ -2586,15 +2486,19 @@ ((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 + (new-current + (nth + new-full-stack + (- (len new-full-stack) 1)))) + (assoc + interp :frame new-current :frame-stack new-frame-stack :result (get result-interp :result) :output (str saved-output new-output) :code (get result-interp :code)))))))))))))) -; --- upvar command --- +; --- variable command --- (define tcl-cmd-upvar @@ -2603,76 +2507,55 @@ (let ((current-level (len (get interp :frame-stack)))) (let - ; check if first arg is a level specifier - ((has-level - (and - (> (len args) 2) - (or - (equal? (substring (first args) 0 1) "#") - (tcl-expr-digit? (substring (first args) 0 1))))) - (level-str (if (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))) (first args) "1")) - (pair-args (if (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1)))) (rest args) args))) + ((has-level (and (> (len args) 2) (or (equal? (substring (first args) 0 1) "#") (tcl-expr-digit? (substring (first args) 0 1))))) + (level-str + (if + (and + (> (len args) 2) + (or + (equal? (substring (first args) 0 1) "#") + (tcl-expr-digit? + (substring (first args) 0 1)))) + (first args) + "1")) + (pair-args + (if + (and + (> (len args) 2) + (or + (equal? (substring (first args) 0 1) "#") + (tcl-expr-digit? + (substring (first args) 0 1)))) + (rest args) + args))) (let ((target-level (tcl-parse-level level-str current-level))) (let - ((bind-pairs - (fn - (i-interp remaining) - (if - (< (len remaining) 2) - i-interp - (let - ((remote-name (first remaining)) - (local-name (nth remaining 1))) - (let - ((alias {:upvar-level target-level :upvar-name remote-name})) - (bind-pairs - (assoc i-interp :frame (frame-set-top (get i-interp :frame) local-name alias)) - (rest (rest remaining))))))))) + ((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 ""))))))) -; --- global command --- +; --- 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))) + (fn (i name) (tcl-cmd-upvar i (list "#0" name name))) interp args))) -; --- variable command --- - (define tcl-cmd-variable (fn (interp args) (let - ((go - (fn - (i remaining) - (if - (= 0 (len remaining)) - i - (let - ((name (first remaining)) - (rest-rem (rest remaining))) - (let - ((linked (tcl-cmd-upvar i (list "#0" name name)))) - (if - (and (> (len rest-rem) 0) (not (equal? (substring (first rest-rem) 0 1) "-"))) - (let - ((val (first rest-rem))) - (go (assoc (tcl-var-set linked name val) :result "") (rest rest-rem))) - (go linked rest-rem)))))))) + ((go (fn (i remaining) (if (= 0 (len remaining)) i (let ((name (first remaining)) (rest-rem (rest remaining))) (let ((linked (tcl-cmd-upvar i (list "#0" name name)))) (if (and (> (len rest-rem) 0) (not (equal? (substring (first rest-rem) 0 1) "-"))) (let ((val (first rest-rem))) (go (assoc (tcl-var-set linked name val) :result "") (rest rest-rem))) (go linked rest-rem)))))))) (go interp args)))) -; --- namespace command --- +; --- info command --- -; namespace ensemble dispatch fn for a given ns and map (define tcl-make-ensemble (fn @@ -2686,15 +2569,29 @@ ((subcmd (first args)) (rest-args (rest args))) (let ((target-name (tcl-dict-get map-dict subcmd))) - (if (not (nil? target-name)) - ; dispatch via mapped name + (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)))))))))))) + (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 @@ -2705,145 +2602,100 @@ (let ((sub (first args)) (rest-args (rest args))) (cond - ; namespace eval ns body ((equal? sub "eval") (let ((ns-raw (if (> (len rest-args) 0) (first rest-args) "")) - (body (if (> (len rest-args) 1) (nth rest-args 1) ""))) + (body + (if + (> (len rest-args) 1) + (nth rest-args 1) + ""))) (let - ; if ns-raw is relative (no leading ::), resolve relative to current-ns - ((ns - (let - ((normalized (tcl-ns-normalize ns-raw)) - (current-ns (get interp :current-ns))) - ; tcl-ns-normalize always adds :: prefix, so ::name is absolute - ; check if the original had leading :: - (if - (tcl-starts-with? ns-raw "::") - normalized - ; relative: if current is ::, just use ::name; else ::current::name - (if - (equal? current-ns "::") - normalized - (str current-ns "::" (tcl-ns-tail normalized)))))) + ((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))) - ; restore current-ns after eval (assoc result-interp :current-ns saved-ns)))))) - ; namespace current ((equal? sub "current") (assoc interp :result (get interp :current-ns))) - ; namespace which -command name ((equal? sub "which") (let - ((name (if (and (> (len rest-args) 0) (equal? (first rest-args) "-command")) - (if (> (len rest-args) 1) (nth rest-args 1) "") - (if (> (len rest-args) 0) (first rest-args) "")))) + ((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) + (if + (nil? entry) (assoc interp :result "") (assoc interp :result (get entry :name)))))) - ; namespace exists ns ((equal? sub "exists") (let ((ns (tcl-ns-normalize (if (> (len rest-args) 0) (first rest-args) "")))) - (assoc interp :result (if (tcl-ns-exists? (get interp :procs) ns) "1" "0")))) - ; namespace delete ns + (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))))) + ((remaining-procs (reduce (fn (acc k) (if (tcl-starts-with? k prefix) acc (assoc acc k (get (get interp :procs) k)))) {} (keys (get interp :procs))))) (assoc interp :procs remaining-procs :result ""))))) - ; namespace export pattern — stub - ((equal? sub "export") - (assoc interp :result "")) - ; namespace import ns::name + ((equal? sub "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")) + (if + (nil? entry) + (error + (str "namespace import: \"" target-name "\" not found")) (let ((local-name (tcl-qualify-name tail (get interp :current-ns)))) - (assoc interp + (assoc + interp :procs (assoc (get interp :procs) local-name (get entry :def)) :result "")))))) - ; namespace forget name — remove import alias ((equal? sub "forget") (let ((name (if (> (len rest-args) 0) (first rest-args) ""))) (let ((qualified (tcl-qualify-name name (get interp :current-ns)))) (let - ((new-procs (reduce - (fn (acc k) (if (equal? k qualified) acc (assoc acc k (get (get interp :procs) k)))) - {} - (keys (get interp :procs))))) + ((new-procs (reduce (fn (acc k) (if (equal? k qualified) acc (assoc acc k (get (get interp :procs) k)))) {} (keys (get interp :procs))))) (assoc interp :procs new-procs :result ""))))) - ; namespace path ?nslist? — stub - ((equal? sub "path") - (assoc interp :result "")) - ; namespace ensemble create ?-map dict? + ((equal? sub "path") (assoc interp :result "")) ((equal? sub "ensemble") - (if (and (> (len rest-args) 0) (equal? (first rest-args) "create")) + (if + (and + (> (len rest-args) 0) + (equal? (first rest-args) "create")) (let ((ens-args (rest rest-args)) (current-ns (get interp :current-ns))) (let - ; parse optional -map {subcmd cmd ...} - ((map-str - (let - ((go - (fn - (remaining) - (if - (< (len remaining) 2) - nil - (if (equal? (first remaining) "-map") - (nth remaining 1) - (go (rest remaining))))))) - (go ens-args)))) + ((map-str (let ((go (fn (remaining) (if (< (len remaining) 2) nil (if (equal? (first remaining) "-map") (nth remaining 1) (go (rest remaining))))))) (go ens-args)))) (let - ; build dispatch map - ((dispatch-map - (if (nil? map-str) - ; auto-map: all procs in this namespace → tail name - (let - ((ns-proc-names (tcl-ns-procs (get interp :procs) current-ns))) - (reduce - (fn (acc qname) - (let - ((tail (tcl-ns-tail qname))) - (tcl-dict-set-pair acc tail qname))) - "" - ns-proc-names)) - map-str))) - ; ensemble command name = tail of current-ns + ((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 + (ens-fn + (tcl-make-ensemble + (get interp :procs) + current-ns + dispatch-map))) + (assoc + interp :commands (assoc (get interp :commands) ens-name ens-fn) :result ""))))) (error "namespace ensemble: unknown subcommand"))) (else (error (str "namespace: unknown subcommand \"" sub "\"")))))))) -; --- info command --- - +; yieldto: stub — yield empty string (define tcl-cmd-info (fn @@ -2854,44 +2706,40 @@ (let ((sub (first args)) (rest-args (rest args))) (cond - ; info level ((equal? sub "level") (assoc interp :result (str (len (get interp :frame-stack))))) - ; info vars / info locals ((or (equal? sub "vars") (equal? sub "locals")) (let ((frame-locals (get (get interp :frame) :locals))) - (assoc interp :result - (tcl-list-build + (assoc + interp + :result (tcl-list-build (filter (fn (k) (not (upvar-alias? (get frame-locals k)))) (keys frame-locals)))))) - ; info globals ((equal? sub "globals") (let - ((global-frame - (if - (= 0 (len (get interp :frame-stack))) - (get interp :frame) - (first (get interp :frame-stack))))) + ((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 + (assoc + interp + :result (tcl-list-build (filter (fn (k) (not (upvar-alias? (get global-locals k)))) (keys global-locals))))))) - ; info commands ((equal? sub "commands") - (assoc interp :result (tcl-list-build (keys (get interp :commands))))) - ; info procs — return unqualified names of procs in current namespace + (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)))))) - ; info args procname + (assoc + interp + :result (tcl-list-build (map tcl-ns-tail ns-proc-names)))))) ((equal? sub "args") (let ((pname (first rest-args))) @@ -2901,7 +2749,6 @@ (nil? entry) (error (str "info args: \"" pname "\" isn't a procedure")) (assoc interp :result (get (get entry :def) :args)))))) - ; info body procname ((equal? sub "body") (let ((pname (first rest-args))) @@ -2911,27 +2758,18 @@ (nil? entry) (error (str "info body: \"" pname "\" isn't a procedure")) (assoc interp :result (get (get entry :def) :body)))))) - ; info exists varname — 1 if variable exists in current frame, 0 otherwise ((equal? sub "exists") (let ((varname (first rest-args))) (let ((val (frame-lookup (get interp :frame) varname))) (assoc interp :result (if (nil? val) "0" "1"))))) - ; info hostname — stub - ((equal? sub "hostname") - (assoc interp :result "localhost")) - ; info script — stub - ((equal? sub "script") - (assoc interp :result "")) - ; info tclversion — stub - ((equal? sub "tclversion") - (assoc interp :result "8.6")) + ((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 "\"")))))))) -; --- coroutine support --- - -; yield: inside a coroutine body, record a yielded value +; make-coro-cmd: returns a command function that pops values from the coroutine's yields list (define tcl-cmd-yield (fn @@ -2941,11 +2779,13 @@ (if (get interp :in-coro) (assoc - (assoc interp :coro-yields (append (get interp :coro-yields) (list val))) + (assoc + interp + :coro-yields (append (get interp :coro-yields) (list val))) :result "") (error "yield called outside coroutine"))))) -; yieldto: stub — yield empty string +; coroutine: execute proc eagerly in a coroutine context, collecting all yields (define tcl-cmd-yieldto (fn @@ -2953,11 +2793,14 @@ (if (get interp :in-coro) (assoc - (assoc interp :coro-yields (append (get interp :coro-yields) (list ""))) + (assoc + interp + :coro-yields (append (get interp :coro-yields) (list ""))) :result "") (error "yieldto called outside coroutine")))) -; make-coro-cmd: returns a command function that pops values from the coroutine's yields list +; --- clock command (stubs) --- + (define make-coro-cmd (fn @@ -2972,8 +2815,7 @@ (nil? coro) (error (str "coroutine \"" coro-name "\" not found")) (let - ((yields (get coro :yields)) - (pos (get coro :pos))) + ((yields (get coro :yields)) (pos (get coro :pos))) (if (>= pos (len yields)) (assoc interp :result "") @@ -2982,10 +2824,13 @@ (let ((new-coro (assoc coro :pos (+ pos 1)))) (assoc - (assoc interp :coroutines (assoc coros coro-name new-coro)) + (assoc + interp + :coroutines (assoc coros coro-name new-coro)) :result val))))))))))) -; coroutine: execute proc eagerly in a coroutine context, collecting all yields +; --- file I/O stubs --- + (define tcl-cmd-coroutine (fn @@ -2997,45 +2842,26 @@ ((coro-name (first args)) (cmd-name (nth args 1)) (call-args (rest (rest args)))) - ; set up coroutine context (let - ((coro-interp - (assoc interp - :in-coro true - :coro-yields (list) - :result "" - :code 0))) - ; find the command or proc and execute it + ((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)))) + ((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))) - ; build the coroutine state (let ((new-coros (assoc (get exec-result :coroutines) coro-name {:yields yields :pos 0}))) - ; register the coroutine command in the commands dict (let ((new-commands (assoc (get exec-result :commands) coro-name (make-coro-cmd coro-name)))) - (assoc exec-result + (assoc + exec-result :coroutines new-coros :commands new-commands :in-coro false :coro-yields (list) :result ""))))))))))) -; --- clock command (stubs) --- - (define tcl-cmd-clock (fn @@ -3046,69 +2872,38 @@ (let ((sub (first args)) (rest-args (rest args))) (cond - ((equal? sub "seconds") (assoc interp :result "0")) + ((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")) + ((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 "\"")))))))) -; --- file I/O stubs --- - -(define - tcl-cmd-open - (fn - (interp args) - (assoc interp :result "file0"))) - -(define - tcl-cmd-close - (fn - (interp args) - (assoc interp :result ""))) - -(define - tcl-cmd-read - (fn - (interp args) - (assoc interp :result ""))) +(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) - ; gets channel varname: store "" and return -1 (EOF) (assoc (tcl-var-set interp (nth args 1) "") :result "-1") - ; gets channel: return "" (EOF) (assoc interp :result "")))) -(define - tcl-cmd-eof - (fn - (interp args) - (assoc interp :result "1"))) +(define tcl-cmd-eof (fn (interp args) (assoc interp :result "1"))) -(define - tcl-cmd-seek - (fn - (interp args) - (assoc interp :result ""))) - -(define - tcl-cmd-tell - (fn - (interp args) - (assoc interp :result "0"))) - -(define - tcl-cmd-flush - (fn - (interp args) - (assoc interp :result ""))) +(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-file (fn @@ -3119,31 +2914,40 @@ (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 "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) "/"))))) + (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))))) + (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 + (assoc + interp + :result (if (<= (len parts) 1) "." - (str "/" (join "/" (take-n parts (- (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 + (assoc + interp + :result (if (equal? dot-idx "-1") "" (substring nm (parse-int dot-idx) (string-length nm))))))) @@ -3152,21 +2956,22 @@ ((nm (first rest-args))) (let ((dot-idx (tcl-string-last "." nm (- (string-length nm) 1)))) - (assoc interp :result - (if + (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 "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 "")) + ((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 @@ -3264,27 +3069,30 @@ (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))) + ((i (tcl-register i "namespace" tcl-cmd-namespace))) (let - ((i (tcl-register i "seek" tcl-cmd-seek))) + ((i (tcl-register i "coroutine" tcl-cmd-coroutine))) (let - ((i (tcl-register i "tell" tcl-cmd-tell))) + ((i (tcl-register i "yield" tcl-cmd-yield))) (let - ((i (tcl-register i "flush" tcl-cmd-flush))) - (tcl-register i "file" tcl-cmd-file)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) + ((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))) + (tcl-register + i + "file" + tcl-cmd-file))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))