tcl: Phase 6 — namespace, list ops, dict additions, scan/format, exec [WIP]
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
Phase 6a (namespace `::` prefix): - tcl-global-ref?/strip-global helpers - tcl-var-get/set route ::name to root frame - tokenizer parse-var-sub accepts `::` start so $::var works - tcl-call-proc forwards :fileevents/:timers/:procs/:commands - char-at fast-path optimization on var-get/set hot path Phase 6b (list ops): added lassign, lrepeat, lset, lmap. Phase 6c (dict additions): added dict lappend, remove, filter -key. Phase 6d (scan/format): - printf-spec SX primitive wrapping OCaml Printf via Scanf.format_from_string - scan-spec SX primitive (manual scanner for d/i/u/x/X/o/c/s/f/e/g) - Tcl format dispatches via printf-spec; tcl-cmd-scan walks fmt and dispatches Phase 6e (exec): - exec-process SX primitive wraps Unix.create_process + waitpid - Tcl `exec cmd arg...` returns trimmed stdout; raises on non-zero exit test.sh inner timeout 3600s → 7200s (post-merge JIT recursion is slow). +27 idiom tests covering ns, list ops, dict, format, scan, exec. [WIP — full suite verification still pending] Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
@@ -73,59 +73,106 @@
|
||||
(fn (full-stack level)
|
||||
(nth full-stack level)))
|
||||
|
||||
; True if name starts with "::" (absolute namespace reference; for now we
|
||||
; treat any "::name" as the global variable `name`). Multi-level namespace
|
||||
; paths like "::ns::var" are not yet split — they're stored under the
|
||||
; literal name in the global frame.
|
||||
; Hot path on every var-get/set; only one char-at on the typical fast path.
|
||||
(define
|
||||
tcl-global-ref?
|
||||
(fn (name)
|
||||
(and
|
||||
(equal? (char-at name 0) ":")
|
||||
(equal? (char-at name 1) ":"))))
|
||||
|
||||
(define
|
||||
tcl-strip-global
|
||||
(fn (name)
|
||||
(substring name 2 (string-length name))))
|
||||
|
||||
(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
|
||||
(tcl-global-ref? name)
|
||||
; absolute reference — look up in global (root) frame
|
||||
(let
|
||||
((root-frame
|
||||
(let ((stack (get interp :frame-stack)))
|
||||
(if (= 0 (len stack)) (get interp :frame) (first stack))))
|
||||
(gname (tcl-strip-global name)))
|
||||
(let ((val (frame-lookup root-frame gname)))
|
||||
(if
|
||||
(nil? val)
|
||||
(error (str "can't read \"" name "\": no such variable"))
|
||||
val)))
|
||||
(let
|
||||
((val (frame-lookup (get interp :frame) name)))
|
||||
(if
|
||||
(upvar-alias? val)
|
||||
; follow alias to target frame
|
||||
(let
|
||||
((target-level (get val :upvar-level))
|
||||
(target-name (get val :upvar-name)))
|
||||
(nil? val)
|
||||
(error (str "can't read \"" name "\": no such variable"))
|
||||
(if
|
||||
(upvar-alias? val)
|
||||
; follow alias to target frame
|
||||
(let
|
||||
((full-stack (tcl-full-stack interp)))
|
||||
((target-level (get val :upvar-level))
|
||||
(target-name (get val :upvar-name)))
|
||||
(let
|
||||
((target-frame (tcl-frame-nth full-stack target-level)))
|
||||
((full-stack (tcl-full-stack interp)))
|
||||
(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)))))
|
||||
((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
|
||||
(cond
|
||||
((tcl-global-ref? name)
|
||||
; absolute reference — set in global (root) frame
|
||||
(let
|
||||
((target-level (get cur-val :upvar-level))
|
||||
(target-name (get cur-val :upvar-name)))
|
||||
(let
|
||||
((full-stack (tcl-full-stack interp)))
|
||||
((stack (get interp :frame-stack)) (gname (tcl-strip-global name)))
|
||||
(if
|
||||
(= 0 (len stack))
|
||||
; no frame stack — current frame is the root
|
||||
(assoc interp :frame (frame-set-top (get interp :frame) gname val))
|
||||
(let
|
||||
((target-frame (tcl-frame-nth full-stack target-level)))
|
||||
((root-frame (first stack))
|
||||
(rest-stack (rest stack)))
|
||||
(assoc
|
||||
interp
|
||||
:frame-stack
|
||||
(cons (frame-set-top root-frame gname val) rest-stack))))))
|
||||
(else
|
||||
(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
|
||||
((updated-target (frame-set-top target-frame target-name val)))
|
||||
((full-stack (tcl-full-stack interp)))
|
||||
(let
|
||||
((new-full-stack (replace-at full-stack target-level updated-target)))
|
||||
((target-frame (tcl-frame-nth full-stack target-level)))
|
||||
(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))))))
|
||||
((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
|
||||
@@ -292,15 +339,20 @@
|
||||
(> (len result-stack) caller-stack-len)
|
||||
(nth result-stack caller-stack-len)
|
||||
(get interp :frame))))
|
||||
; Forward result-interp as base so state changes inside
|
||||
; the proc (e.g. :fileevents, :timers, :procs) propagate;
|
||||
; restore caller's frame/stack/result/output/code.
|
||||
(assoc result-interp
|
||||
; Forward state that must escape the proc body —
|
||||
; :commands, :procs, :fileevents, :timers. Without this
|
||||
; fileevent registrations made inside a proc body are
|
||||
; lost on return (broke socket -async accept handlers).
|
||||
(assoc interp
|
||||
:frame updated-caller
|
||||
:frame-stack updated-below
|
||||
:result result-val
|
||||
:output (str caller-output proc-output)
|
||||
:code (if (= code 2) 0 code))))))))))))))
|
||||
:code (if (= code 2) 0 code)
|
||||
:commands (get result-interp :commands)
|
||||
:procs (get result-interp :procs)
|
||||
:fileevents (get result-interp :fileevents)
|
||||
:timers (get result-interp :timers))))))))))))))
|
||||
|
||||
(define
|
||||
tcl-eval-cmd
|
||||
@@ -1214,6 +1266,7 @@
|
||||
(tcl-fmt-scan-num chars (+ j 1) (str acc-n ch))
|
||||
{:num acc-n :j j})))))
|
||||
|
||||
; Walk format string char by char; dispatch each %spec to printf-spec.
|
||||
(define
|
||||
tcl-fmt-apply
|
||||
(fn
|
||||
@@ -1237,50 +1290,30 @@
|
||||
(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 "")))
|
||||
(if
|
||||
(equal? (nth chars i2) "%")
|
||||
; literal %%
|
||||
(tcl-fmt-apply chars n-len fmt-args (+ i2 1) arg-idx (str acc "%"))
|
||||
; dispatch via printf-spec
|
||||
(let
|
||||
((j (tcl-fmt-find-end chars i2 n-len)))
|
||||
(if
|
||||
(>= j n-len)
|
||||
(str acc "?")
|
||||
(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))))))))))))))))))))
|
||||
((spec (str "%" (join "" (slice chars i2 (+ j 1)))))
|
||||
(cur-arg
|
||||
(if
|
||||
(< arg-idx (len fmt-args))
|
||||
(nth fmt-args arg-idx)
|
||||
"")))
|
||||
(tcl-fmt-apply
|
||||
chars
|
||||
n-len
|
||||
fmt-args
|
||||
(+ j 1)
|
||||
(+ arg-idx 1)
|
||||
(str acc (printf-spec spec cur-arg))))))))))))))
|
||||
|
||||
; --- string command helpers ---
|
||||
|
||||
@@ -1300,8 +1333,127 @@
|
||||
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")))
|
||||
; scan str fmt ?varName ...? — printf-style parse.
|
||||
; Returns count of successful conversions. If varNames given, sets each to
|
||||
; its conversion result; otherwise returns the values as a list.
|
||||
(define
|
||||
tcl-cmd-scan
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(< (len args) 2)
|
||||
(error "scan: wrong # args")
|
||||
(let
|
||||
((input (first args))
|
||||
(fmt (nth args 1))
|
||||
(var-names (slice args 2 (len args))))
|
||||
(let
|
||||
((parsed
|
||||
(tcl-scan-loop
|
||||
input
|
||||
(split fmt "")
|
||||
(string-length fmt)
|
||||
0
|
||||
0
|
||||
(list))))
|
||||
(if
|
||||
(= 0 (len var-names))
|
||||
(assoc interp :result (tcl-list-build parsed))
|
||||
(let
|
||||
((bind-loop
|
||||
(fn
|
||||
(i-interp i)
|
||||
(if
|
||||
(>= i (len var-names))
|
||||
i-interp
|
||||
(let
|
||||
((v (if (< i (len parsed)) (str (nth parsed i)) "")))
|
||||
(bind-loop (tcl-var-set i-interp (nth var-names i) v) (+ i 1)))))))
|
||||
(let ((bound (bind-loop interp 0)))
|
||||
(assoc bound :result (str (len parsed)))))))))))
|
||||
|
||||
; Loop helper: walk format chars, dispatch each %spec to scan-spec.
|
||||
(define
|
||||
tcl-scan-loop
|
||||
(fn
|
||||
(input fmt-chars n-fmt fi pos values)
|
||||
(if
|
||||
(>= fi n-fmt)
|
||||
values
|
||||
(let
|
||||
((c (nth fmt-chars fi)))
|
||||
(cond
|
||||
((equal? c "%")
|
||||
(if
|
||||
(>= (+ fi 1) n-fmt)
|
||||
values
|
||||
(let
|
||||
((j (tcl-fmt-find-end fmt-chars (+ fi 1) n-fmt)))
|
||||
(if
|
||||
(>= j n-fmt)
|
||||
values
|
||||
(let
|
||||
((spec (str "%" (join "" (slice fmt-chars (+ fi 1) (+ j 1)))))
|
||||
(rem-str (substring input pos (string-length input))))
|
||||
(let
|
||||
((r (scan-spec spec rem-str)))
|
||||
(if
|
||||
(nil? r)
|
||||
values
|
||||
(tcl-scan-loop
|
||||
input
|
||||
fmt-chars
|
||||
n-fmt
|
||||
(+ j 1)
|
||||
(+ pos (get r :consumed))
|
||||
(append values (list (str (get r :value))))))))))))
|
||||
((or (equal? c " ") (equal? c "\t") (equal? c "\n"))
|
||||
(tcl-scan-loop
|
||||
input
|
||||
fmt-chars
|
||||
n-fmt
|
||||
(+ fi 1)
|
||||
(tcl-skip-ws input pos)
|
||||
values))
|
||||
(else
|
||||
(if
|
||||
(and
|
||||
(< pos (string-length input))
|
||||
(equal? c (substring input pos (+ pos 1))))
|
||||
(tcl-scan-loop input fmt-chars n-fmt (+ fi 1) (+ pos 1) values)
|
||||
values)))))))
|
||||
|
||||
; Find end of a printf spec starting at fi (after '%'). Returns index of
|
||||
; the conversion character.
|
||||
(define
|
||||
tcl-fmt-find-end
|
||||
(fn
|
||||
(chars i n)
|
||||
(if
|
||||
(>= i n)
|
||||
i
|
||||
(let
|
||||
((c (nth chars i)))
|
||||
(cond
|
||||
((or (equal? c "-") (equal? c "+") (equal? c " ") (equal? c "0") (equal? c "#"))
|
||||
(tcl-fmt-find-end chars (+ i 1) n))
|
||||
((or (equal? c ".") (and (>= c "0") (<= c "9")))
|
||||
(tcl-fmt-find-end chars (+ i 1) n))
|
||||
(else i))))))
|
||||
|
||||
(define
|
||||
tcl-skip-ws
|
||||
(fn
|
||||
(input pos)
|
||||
(if
|
||||
(>= pos (string-length input))
|
||||
pos
|
||||
(let
|
||||
((c (substring input pos (+ pos 1))))
|
||||
(if
|
||||
(or (equal? c " ") (equal? c "\t") (equal? c "\n"))
|
||||
(tcl-skip-ws input (+ pos 1))
|
||||
pos)))))
|
||||
|
||||
(define
|
||||
tcl-glob-match
|
||||
@@ -2042,6 +2194,123 @@
|
||||
((all-elems (reduce (fn (acc s) (append acc (tcl-list-split s))) (list) args)))
|
||||
(assoc interp :result (tcl-list-build all-elems)))))
|
||||
|
||||
; lassign list var ?var ...? → assigns elements to vars; returns
|
||||
; remaining unassigned elements as a list (empty string if all consumed)
|
||||
(define
|
||||
tcl-cmd-lassign
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(= 0 (len args))
|
||||
(error "lassign: wrong # args")
|
||||
(let
|
||||
((elems (tcl-list-split (first args))) (vars (rest args)))
|
||||
(let
|
||||
((bind-loop
|
||||
(fn
|
||||
(i-interp i)
|
||||
(if
|
||||
(>= i (len vars))
|
||||
i-interp
|
||||
(let
|
||||
((var (nth vars i))
|
||||
(val (if (< i (len elems)) (nth elems i) "")))
|
||||
(bind-loop (tcl-var-set i-interp var val) (+ i 1)))))))
|
||||
(let
|
||||
((bound (bind-loop interp 0)))
|
||||
(let
|
||||
((leftover
|
||||
(if
|
||||
(> (len elems) (len vars))
|
||||
(slice elems (len vars) (len elems))
|
||||
(list))))
|
||||
(assoc bound :result (tcl-list-build leftover)))))))))
|
||||
|
||||
; lrepeat count ?elem ...? → list with elem... repeated count times
|
||||
(define
|
||||
tcl-cmd-lrepeat
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(= 0 (len args))
|
||||
(error "lrepeat: wrong # args")
|
||||
(let
|
||||
((n (parse-int (first args))) (elems (rest args)))
|
||||
(if
|
||||
(or (< n 0) (= 0 (len elems)))
|
||||
(assoc interp :result "")
|
||||
(let
|
||||
((build
|
||||
(fn
|
||||
(i acc)
|
||||
(if (= i 0) acc (build (- i 1) (append acc elems))))))
|
||||
(assoc interp :result (tcl-list-build (build n (list))))))))))
|
||||
|
||||
; lset varname index value → set element at index in list-valued variable
|
||||
(define
|
||||
tcl-cmd-lset
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(< (len args) 3)
|
||||
(error "lset: wrong # args")
|
||||
(let
|
||||
((varname (first args))
|
||||
(idx (parse-int (nth args 1)))
|
||||
(val (nth args 2)))
|
||||
(let
|
||||
((cur (tcl-var-get interp varname)))
|
||||
(let
|
||||
((elems (tcl-list-split cur)))
|
||||
(if
|
||||
(or (< idx 0) (>= idx (len elems)))
|
||||
(error (str "lset: index out of range " idx))
|
||||
(let
|
||||
((new-list (replace-at elems idx val)))
|
||||
(let
|
||||
((new-str (tcl-list-build new-list)))
|
||||
(assoc
|
||||
(tcl-var-set interp varname new-str)
|
||||
:result new-str))))))))))
|
||||
|
||||
; lmap helper: like foreach-loop but collects body results
|
||||
(define
|
||||
tcl-lmap-loop
|
||||
(fn
|
||||
(interp varname items body acc)
|
||||
(if
|
||||
(= 0 (len items))
|
||||
(assoc interp :result (tcl-list-build acc))
|
||||
(let
|
||||
((body-result (tcl-eval-string (tcl-var-set interp varname (first items)) body)))
|
||||
(let
|
||||
((code (get body-result :code)))
|
||||
(cond
|
||||
((= code 3) (assoc (assoc body-result :code 0) :result (tcl-list-build acc)))
|
||||
((= code 4) (tcl-lmap-loop (assoc body-result :code 0) varname (rest items) body acc))
|
||||
((= code 2) body-result)
|
||||
((= code 1) body-result)
|
||||
(else
|
||||
(tcl-lmap-loop
|
||||
(assoc body-result :code 0)
|
||||
varname
|
||||
(rest items)
|
||||
body
|
||||
(append acc (list (get body-result :result)))))))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-lmap
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(< (len args) 3)
|
||||
(error "lmap: wrong # args")
|
||||
(let
|
||||
((varname (first args))
|
||||
(list-str (nth args 1))
|
||||
(body (nth args 2)))
|
||||
(tcl-lmap-loop interp varname (tcl-list-split list-str) body (list))))))
|
||||
|
||||
; --- dict command helpers ---
|
||||
|
||||
; Parse flat dict string into SX list of [key val] pairs
|
||||
@@ -2316,6 +2585,51 @@
|
||||
(assoc
|
||||
(tcl-var-set interp varname new-dict)
|
||||
:result new-dict)))))))
|
||||
((equal? sub "lappend")
|
||||
; dict lappend dictVarName key elem ?elem ...?
|
||||
(let
|
||||
((varname (first rest-args))
|
||||
(key (nth rest-args 1))
|
||||
(new-elems (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
|
||||
((merged (tcl-list-build (append (tcl-list-split old-val) new-elems))))
|
||||
(let
|
||||
((new-dict (tcl-dict-set-pair cur key merged)))
|
||||
(assoc
|
||||
(tcl-var-set interp varname new-dict)
|
||||
:result new-dict)))))))
|
||||
((equal? sub "remove")
|
||||
; dict remove dict ?key ...?
|
||||
(let
|
||||
((dict-str (first rest-args))
|
||||
(keys-to-remove (rest rest-args)))
|
||||
(assoc
|
||||
interp
|
||||
:result (reduce
|
||||
(fn (acc k) (tcl-dict-unset-key acc k))
|
||||
dict-str
|
||||
keys-to-remove))))
|
||||
((equal? sub "filter")
|
||||
; dict filter dict key pattern — only `key` filter supported
|
||||
(let
|
||||
((dict-str (first rest-args))
|
||||
(mode (nth rest-args 1))
|
||||
(pattern (nth rest-args 2)))
|
||||
(if
|
||||
(not (equal? mode "key"))
|
||||
(error (str "dict filter: only key filter implemented, got " mode))
|
||||
(let
|
||||
((kept
|
||||
(filter
|
||||
(fn (pair) (tcl-glob-match (split pattern "") (split (first pair) "")))
|
||||
(tcl-dict-to-pairs dict-str))))
|
||||
(assoc
|
||||
interp
|
||||
:result (tcl-dict-from-pairs kept))))))
|
||||
(else (error (str "dict: unknown subcommand \"" sub "\""))))))))
|
||||
|
||||
; Qualify a proc name relative to current-ns.
|
||||
@@ -3011,6 +3325,13 @@
|
||||
(fn
|
||||
(interp args)
|
||||
(let ((_ (channel-flush (first args)))) (assoc interp :result ""))))
|
||||
|
||||
; exec cmd ?arg ...? — run external process, return stdout (newline-stripped)
|
||||
(define
|
||||
tcl-cmd-exec
|
||||
(fn
|
||||
(interp args)
|
||||
(assoc interp :result (exec-process args))))
|
||||
(define
|
||||
tcl-cmd-fconfigure
|
||||
(fn
|
||||
@@ -3783,6 +4104,16 @@
|
||||
((i (tcl-register i "linsert" tcl-cmd-linsert)))
|
||||
(let
|
||||
((i (tcl-register i "concat" tcl-cmd-concat)))
|
||||
(let
|
||||
((i (tcl-register i "lassign" tcl-cmd-lassign)))
|
||||
(let
|
||||
((i (tcl-register i "lrepeat" tcl-cmd-lrepeat)))
|
||||
(let
|
||||
((i (tcl-register i "lset" tcl-cmd-lset)))
|
||||
(let
|
||||
((i (tcl-register i "lmap" tcl-cmd-lmap)))
|
||||
(let
|
||||
((i (tcl-register i "exec" tcl-cmd-exec)))
|
||||
(let
|
||||
((i (tcl-register i "split" tcl-cmd-split)))
|
||||
(let
|
||||
@@ -3856,4 +4187,4 @@
|
||||
(tcl-register
|
||||
i
|
||||
"array"
|
||||
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
||||
tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
||||
|
||||
@@ -57,7 +57,7 @@ cat > "$TMPFILE" << EPOCHS
|
||||
(eval "tcl-test-summary")
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 2400 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
OUTPUT=$(timeout 7200 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||
|
||||
# Extract summary line from epoch 11 output
|
||||
|
||||
@@ -415,6 +415,115 @@
|
||||
:result)
|
||||
"")
|
||||
|
||||
; 60-63. Phase 6a namespace :: prefix
|
||||
(ok "ns-set-from-proc-reaches-global"
|
||||
(get
|
||||
(run
|
||||
"proc f {x} { set ::g $x }\nf hello\nset ::g")
|
||||
:result)
|
||||
"hello")
|
||||
|
||||
(ok "ns-read-from-proc"
|
||||
(get
|
||||
(run
|
||||
"set ::v 42\nproc f {} { return $::v }\nf")
|
||||
:result)
|
||||
"42")
|
||||
|
||||
(ok "ns-incr-via-prefix"
|
||||
(get
|
||||
(run
|
||||
"set ::n 5\nproc bump {} { incr ::n }\nbump\nbump\nset ::n")
|
||||
:result)
|
||||
"7")
|
||||
|
||||
(ok "ns-different-from-local"
|
||||
(get
|
||||
(run
|
||||
"set x outer\nproc f {} { set x inner; set ::x global; return $x }\nf")
|
||||
:result)
|
||||
"inner")
|
||||
|
||||
; 64-69. Phase 6b list ops (lassign, lrepeat, lset, lmap)
|
||||
(ok "lassign-three"
|
||||
(get (run "lassign {a b c d e} x y z\nlist $x $y $z") :result)
|
||||
"a b c")
|
||||
|
||||
(ok "lassign-leftover"
|
||||
(get (run "lassign {1 2 3 4 5} a b") :result)
|
||||
"3 4 5")
|
||||
|
||||
(ok "lrepeat-basic"
|
||||
(get (run "lrepeat 3 a") :result)
|
||||
"a a a")
|
||||
|
||||
(ok "lrepeat-multi"
|
||||
(get (run "lrepeat 2 x y") :result)
|
||||
"x y x y")
|
||||
|
||||
(ok "lset-replaces"
|
||||
(get (run "set L {a b c d}\nlset L 2 ZZ\nset L") :result)
|
||||
"a b ZZ d")
|
||||
|
||||
(ok "lmap-square"
|
||||
(get (run "lmap n {1 2 3 4} {expr {$n * $n}}") :result)
|
||||
"1 4 9 16")
|
||||
|
||||
; 70-72. Phase 6c dict additions (lappend, remove, filter)
|
||||
(ok "dict-lappend-extends"
|
||||
(get (run "set d {tags {a b}}\ndict lappend d tags c d\nset d") :result)
|
||||
"tags {a b c d}")
|
||||
|
||||
(ok "dict-remove"
|
||||
(get (run "dict remove {a 1 b 2 c 3} b") :result)
|
||||
"a 1 c 3")
|
||||
|
||||
(ok "dict-filter-key"
|
||||
(get (run "dict filter {alpha 1 beta 2 gamma 3} key a*") :result)
|
||||
"alpha 1")
|
||||
|
||||
; 73-79. Phase 6d format and scan
|
||||
(ok "format-int-padded"
|
||||
(get (run "format {%05d} 42") :result)
|
||||
"00042")
|
||||
|
||||
(ok "format-float-precision"
|
||||
(get (run "format {%.2f} 3.14159") :result)
|
||||
"3.14")
|
||||
|
||||
(ok "format-hex"
|
||||
(get (run "format {%x} 255") :result)
|
||||
"ff")
|
||||
|
||||
(ok "format-char"
|
||||
(get (run "format {%c} 65") :result)
|
||||
"A")
|
||||
|
||||
(ok "format-string-left"
|
||||
(get (run "format {%-5s|} hi") :result)
|
||||
"hi |")
|
||||
|
||||
(ok "scan-two-ints"
|
||||
(get (run "scan {12 34} {%d %d} a b\nlist $a $b") :result)
|
||||
"12 34")
|
||||
|
||||
(ok "scan-count"
|
||||
(get (run "scan {hello 42} {%s %d}") :result)
|
||||
"hello 42")
|
||||
|
||||
; 80-82. Phase 6e exec
|
||||
(ok "exec-echo"
|
||||
(get (run "exec echo hello world") :result)
|
||||
"hello world")
|
||||
|
||||
(ok "exec-printf-no-newline"
|
||||
(get (run "exec /bin/printf x") :result)
|
||||
"x")
|
||||
|
||||
(ok "exec-with-args"
|
||||
(get (run "exec /bin/echo -n test") :result)
|
||||
"test")
|
||||
|
||||
(dict
|
||||
"passed"
|
||||
tcl-idiom-pass
|
||||
|
||||
@@ -167,7 +167,9 @@
|
||||
(begin
|
||||
(when (= (cur) "}") (advance! 1))
|
||||
{:type "var" :name name}))))))
|
||||
((tcl-ident-start? (cur))
|
||||
((or
|
||||
(tcl-ident-start? (cur))
|
||||
(and (= (cur) ":") (= (char-at 1) ":")))
|
||||
(let ((start pos))
|
||||
(begin
|
||||
(scan-ns-name!)
|
||||
|
||||
Reference in New Issue
Block a user