Merge remote-tracking branch 'origin/loops/tcl' into architecture
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m0s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m0s
This commit is contained in:
@@ -354,14 +354,28 @@
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((text (last args))
|
||||
(no-nl
|
||||
(and
|
||||
(> (len args) 1)
|
||||
(equal? (first args) "-nonewline"))))
|
||||
((no-nl (and (> (len args) 1) (equal? (first args) "-nonewline"))))
|
||||
(let
|
||||
((line (if no-nl text (str text "\n"))))
|
||||
(assoc interp :output (str (get interp :output) line))))))
|
||||
((args2 (if no-nl (rest args) args)))
|
||||
(let
|
||||
((maybe-chan (if (> (len args2) 1) (first args2) nil))
|
||||
(is-chan
|
||||
(and
|
||||
(not (nil? maybe-chan))
|
||||
(>= (len maybe-chan) 4)
|
||||
(equal? (slice maybe-chan 0 4) "file"))))
|
||||
(if
|
||||
is-chan
|
||||
(let
|
||||
((chan (first args2))
|
||||
(text (last args2))
|
||||
(line (if no-nl text (str text "\n"))))
|
||||
(let
|
||||
((_ (channel-write chan line)))
|
||||
(assoc interp :result "")))
|
||||
(let
|
||||
((text (last args2)) (line (if no-nl text (str text "\n"))))
|
||||
(assoc interp :output (str (get interp :output) line)))))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-incr
|
||||
@@ -2874,30 +2888,318 @@
|
||||
((equal? sub "scan") (assoc interp :result "0"))
|
||||
(else (error (str "clock: unknown subcommand \"" sub "\""))))))))
|
||||
|
||||
(define tcl-cmd-open (fn (interp args) (assoc interp :result "file0")))
|
||||
(define
|
||||
tcl-cmd-open
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((path (first args))
|
||||
(mode (if (> (len args) 1) (nth args 1) "r")))
|
||||
(assoc interp :result (channel-open path mode)))))
|
||||
|
||||
; gets channel ?varname?
|
||||
(define tcl-cmd-close (fn (interp args) (assoc interp :result "")))
|
||||
(define
|
||||
tcl-cmd-close
|
||||
(fn
|
||||
(interp args)
|
||||
(let ((_ (channel-close (first args)))) (assoc interp :result ""))))
|
||||
|
||||
(define tcl-cmd-read (fn (interp args) (assoc interp :result "")))
|
||||
(define
|
||||
tcl-cmd-read
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((chan (first args))
|
||||
(n (if (> (len args) 1) (parse-int (nth args 1)) -1)))
|
||||
(assoc
|
||||
interp
|
||||
:result (if (< n 0) (channel-read chan) (channel-read chan n))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-gets-chan
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(> (len args) 1)
|
||||
(assoc (tcl-var-set interp (nth args 1) "") :result "-1")
|
||||
(assoc interp :result ""))))
|
||||
(let
|
||||
((chan (first args)) (line (channel-read-line chan)))
|
||||
(if
|
||||
(nil? line)
|
||||
(if
|
||||
(> (len args) 1)
|
||||
(assoc (tcl-var-set interp (nth args 1) "") :result "-1")
|
||||
(assoc interp :result ""))
|
||||
(if
|
||||
(> (len args) 1)
|
||||
(assoc
|
||||
(tcl-var-set interp (nth args 1) line)
|
||||
:result (str (len line)))
|
||||
(assoc interp :result line))))))
|
||||
|
||||
(define tcl-cmd-eof (fn (interp args) (assoc interp :result "1")))
|
||||
(define
|
||||
tcl-cmd-eof
|
||||
(fn
|
||||
(interp args)
|
||||
(assoc interp :result (if (channel-eof? (first args)) "1" "0"))))
|
||||
|
||||
(define tcl-cmd-seek (fn (interp args) (assoc interp :result "")))
|
||||
(define
|
||||
tcl-cmd-seek
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((chan (first args))
|
||||
(off (parse-int (nth args 1)))
|
||||
(whence (if (> (len args) 2) (nth args 2) "start")))
|
||||
(let ((_ (channel-seek chan off whence))) (assoc interp :result "")))))
|
||||
|
||||
; file command dispatcher
|
||||
(define tcl-cmd-tell (fn (interp args) (assoc interp :result "0")))
|
||||
(define
|
||||
tcl-cmd-tell
|
||||
(fn
|
||||
(interp args)
|
||||
(assoc interp :result (str (channel-tell (first args))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-flush
|
||||
(fn
|
||||
(interp args)
|
||||
(let ((_ (channel-flush (first args)))) (assoc interp :result ""))))
|
||||
(define
|
||||
tcl-cmd-fconfigure
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((chan (first args)) (rest-args (rest args)))
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
(assoc
|
||||
interp
|
||||
:result (str "-blocking " (if (channel-blocking? chan) "1" "0")))
|
||||
(if
|
||||
(and
|
||||
(= 2 (len rest-args))
|
||||
(equal? (first rest-args) "-blocking"))
|
||||
(let
|
||||
((b (nth rest-args 1)))
|
||||
(let
|
||||
((_ (channel-set-blocking! chan (not (or (equal? b "0") (equal? b "false"))))))
|
||||
(assoc interp :result "")))
|
||||
(if
|
||||
(and
|
||||
(= 1 (len rest-args))
|
||||
(equal? (first rest-args) "-blocking"))
|
||||
(assoc interp :result (if (channel-blocking? chan) "1" "0"))
|
||||
(assoc interp :result "")))))))
|
||||
|
||||
|
||||
; ============================================================
|
||||
; Event loop: fileevent / after / vwait / update (Phase 5b)
|
||||
; ============================================================
|
||||
|
||||
; :fileevents is list of (chan event script) tuples
|
||||
; :timers is list of (expiry-ms script) tuples, sorted ascending by expiry
|
||||
|
||||
(define
|
||||
tcl-fileevent-set
|
||||
(fn
|
||||
(interp chan event script)
|
||||
(let
|
||||
((existing (or (get interp :fileevents) (list))))
|
||||
(let
|
||||
((filtered
|
||||
(filter
|
||||
(fn (e) (not (and (equal? (first e) chan) (equal? (nth e 1) event))))
|
||||
existing)))
|
||||
(let
|
||||
((new-list
|
||||
(if (equal? script "")
|
||||
filtered
|
||||
(append filtered (list (list chan event script))))))
|
||||
(assoc interp :fileevents new-list))))))
|
||||
|
||||
(define
|
||||
tcl-fileevent-get
|
||||
(fn
|
||||
(interp chan event)
|
||||
(let
|
||||
((events (or (get interp :fileevents) (list))))
|
||||
(let
|
||||
((matches
|
||||
(filter
|
||||
(fn (e) (and (equal? (first e) chan) (equal? (nth e 1) event)))
|
||||
events)))
|
||||
(if (= 0 (len matches)) "" (nth (first matches) 2))))))
|
||||
|
||||
(define
|
||||
tcl-timer-insert
|
||||
(fn
|
||||
(timers new-timer)
|
||||
(cond
|
||||
((= 0 (len timers)) (list new-timer))
|
||||
((<= (first new-timer) (first (first timers))) (cons new-timer timers))
|
||||
(else (cons (first timers) (tcl-timer-insert (rest timers) new-timer))))))
|
||||
|
||||
(define
|
||||
tcl-timer-add
|
||||
(fn
|
||||
(interp ms script)
|
||||
(let
|
||||
((expiry (+ (clock-milliseconds) ms)))
|
||||
(let
|
||||
((existing (or (get interp :timers) (list))))
|
||||
(assoc interp :timers (tcl-timer-insert existing (list expiry script)))))))
|
||||
|
||||
; Run one iteration of the event loop.
|
||||
; poll-timeout-ms: -1 = block indefinitely, 0 = poll, N>0 = wait up to N ms.
|
||||
; Returns updated interp.
|
||||
(define
|
||||
tcl-event-step
|
||||
(fn
|
||||
(interp poll-timeout-ms)
|
||||
(let
|
||||
((timers (or (get interp :timers) (list))) (now-ms (clock-milliseconds)))
|
||||
(let
|
||||
((expired (filter (fn (t) (<= (first t) now-ms)) timers))
|
||||
(remaining (filter (fn (t) (> (first t) now-ms)) timers)))
|
||||
(let
|
||||
((interp1
|
||||
(reduce
|
||||
(fn (acc t) (tcl-eval-string acc (nth t 1)))
|
||||
(assoc interp :timers remaining)
|
||||
expired)))
|
||||
(let
|
||||
((events (or (get interp1 :fileevents) (list))))
|
||||
(let
|
||||
((read-chans
|
||||
(map
|
||||
(fn (e) (first e))
|
||||
(filter (fn (e) (equal? (nth e 1) "readable")) events)))
|
||||
(write-chans
|
||||
(map
|
||||
(fn (e) (first e))
|
||||
(filter (fn (e) (equal? (nth e 1) "writable")) events)))
|
||||
(next-timer-delta
|
||||
(if
|
||||
(= 0 (len remaining))
|
||||
-1
|
||||
(- (first (first remaining)) (clock-milliseconds)))))
|
||||
(let
|
||||
((effective-timeout
|
||||
(cond
|
||||
((and (>= poll-timeout-ms 0) (>= next-timer-delta 0))
|
||||
(min poll-timeout-ms next-timer-delta))
|
||||
((>= poll-timeout-ms 0) poll-timeout-ms)
|
||||
((>= next-timer-delta 0) next-timer-delta)
|
||||
(else -1))))
|
||||
(if
|
||||
(and
|
||||
(= 0 (len read-chans))
|
||||
(= 0 (len write-chans)))
|
||||
; nothing to select on; if timeout > 0, do a no-op wait via select
|
||||
(if
|
||||
(> effective-timeout 0)
|
||||
(let
|
||||
((_ (io-select-channels (list) (list) effective-timeout)))
|
||||
interp1)
|
||||
interp1)
|
||||
(let
|
||||
((select-result
|
||||
(io-select-channels read-chans write-chans effective-timeout)))
|
||||
(let
|
||||
((ready-r (or (get select-result :readable) (list)))
|
||||
(ready-w (or (get select-result :writable) (list))))
|
||||
(let
|
||||
((interp2
|
||||
(reduce
|
||||
(fn (acc chan)
|
||||
(let
|
||||
((script (tcl-fileevent-get acc chan "readable")))
|
||||
(if (equal? script "") acc (tcl-eval-string acc script))))
|
||||
interp1
|
||||
ready-r)))
|
||||
(reduce
|
||||
(fn (acc chan)
|
||||
(let
|
||||
((script (tcl-fileevent-get acc chan "writable")))
|
||||
(if (equal? script "") acc (tcl-eval-string acc script))))
|
||||
interp2
|
||||
ready-w)))))))))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-fileevent
|
||||
(fn
|
||||
(interp args)
|
||||
(let
|
||||
((chan (first args)) (event (nth args 1)))
|
||||
(if
|
||||
(= 2 (len args))
|
||||
(assoc interp :result (tcl-fileevent-get interp chan event))
|
||||
(let
|
||||
((script (nth args 2)))
|
||||
(assoc (tcl-fileevent-set interp chan event script) :result ""))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-after
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(= 0 (len args))
|
||||
(error "after: wrong # args")
|
||||
(let
|
||||
((ms (parse-int (first args))))
|
||||
(if
|
||||
(= 1 (len args))
|
||||
; pure sleep — drive event loop until ms elapsed
|
||||
(let
|
||||
((target-ms (+ (clock-milliseconds) ms)))
|
||||
(assoc (tcl-after-sleep-loop interp target-ms) :result ""))
|
||||
; schedule timer
|
||||
(let
|
||||
((script (join " " (rest args))))
|
||||
(assoc (tcl-timer-add interp ms script) :result "")))))))
|
||||
|
||||
(define
|
||||
tcl-after-sleep-loop
|
||||
(fn
|
||||
(interp target-ms)
|
||||
(let
|
||||
((now (clock-milliseconds)))
|
||||
(if
|
||||
(>= now target-ms)
|
||||
interp
|
||||
(tcl-after-sleep-loop
|
||||
(tcl-event-step interp (- target-ms now))
|
||||
target-ms)))))
|
||||
|
||||
(define
|
||||
tcl-cmd-vwait
|
||||
(fn
|
||||
(interp args)
|
||||
(if
|
||||
(= 0 (len args))
|
||||
(error "vwait: wrong # args")
|
||||
(let
|
||||
((name (first args)))
|
||||
(let
|
||||
((initial (frame-lookup (get interp :frame) name)))
|
||||
(assoc (tcl-vwait-loop interp name initial) :result ""))))))
|
||||
|
||||
(define
|
||||
tcl-vwait-loop
|
||||
(fn
|
||||
(interp name initial)
|
||||
(let
|
||||
((cur (frame-lookup (get interp :frame) name)))
|
||||
(if
|
||||
(and (not (nil? cur)) (not (equal? cur initial)))
|
||||
interp
|
||||
(tcl-vwait-loop (tcl-event-step interp 1000) name initial)))))
|
||||
|
||||
(define
|
||||
tcl-cmd-update
|
||||
(fn
|
||||
(interp args)
|
||||
(assoc (tcl-event-step interp 0) :result "")))
|
||||
|
||||
|
||||
(define tcl-cmd-flush (fn (interp args) (assoc interp :result "")))
|
||||
(define
|
||||
tcl-cmd-array
|
||||
(fn
|
||||
@@ -2909,11 +3211,16 @@
|
||||
((sub (first args)) (rest-args (rest args)))
|
||||
(cond
|
||||
((equal? sub "get")
|
||||
(if (= 0 (len rest-args))
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
(error "array get: wrong # args")
|
||||
(let
|
||||
((arr-name (first rest-args))
|
||||
(pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
|
||||
(pattern
|
||||
(if
|
||||
(> (len rest-args) 1)
|
||||
(nth rest-args 1)
|
||||
nil)))
|
||||
(let
|
||||
((prefix (str arr-name "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
@@ -2922,21 +3229,20 @@
|
||||
(let
|
||||
((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
|
||||
(let
|
||||
((filtered
|
||||
(if
|
||||
(nil? pattern)
|
||||
arr-keys
|
||||
(filter
|
||||
(fn (k)
|
||||
(let ((kn (substring k pl (- (string-length k) 1))))
|
||||
(tcl-glob-match (split pattern "") (split kn ""))))
|
||||
arr-keys))))
|
||||
(assoc interp :result
|
||||
(join " "
|
||||
((filtered (if (nil? pattern) arr-keys (filter (fn (k) (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) arr-keys))))
|
||||
(assoc
|
||||
interp
|
||||
:result (join
|
||||
" "
|
||||
(reduce
|
||||
(fn (acc k)
|
||||
(let ((kn (substring k pl (- (string-length k) 1))))
|
||||
(append acc (list kn) (list (get locals k)))))
|
||||
(fn
|
||||
(acc k)
|
||||
(let
|
||||
((kn (substring k pl (- (string-length k) 1))))
|
||||
(append
|
||||
acc
|
||||
(list kn)
|
||||
(list (get locals k)))))
|
||||
(list)
|
||||
filtered))))))))))
|
||||
((equal? sub "set")
|
||||
@@ -2954,7 +3260,8 @@
|
||||
(assoc acc :result "")
|
||||
(loop
|
||||
(rest (rest pairs))
|
||||
(tcl-var-set acc
|
||||
(tcl-var-set
|
||||
acc
|
||||
(str arr-name "(" (first pairs) ")")
|
||||
(nth pairs 1))))))))
|
||||
((equal? sub "names")
|
||||
@@ -2963,7 +3270,11 @@
|
||||
(error "array names: wrong # args")
|
||||
(let
|
||||
((arr-name (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
|
||||
((prefix (str arr-name "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
@@ -2972,17 +3283,19 @@
|
||||
(let
|
||||
((arr-keys (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))
|
||||
(let
|
||||
((filtered
|
||||
(if
|
||||
(nil? pattern)
|
||||
arr-keys
|
||||
(filter
|
||||
(fn (k)
|
||||
(let ((kn (substring k pl (- (string-length k) 1))))
|
||||
(tcl-glob-match (split pattern "") (split kn ""))))
|
||||
arr-keys))))
|
||||
(assoc interp :result
|
||||
(join " " (map (fn (k) (substring k pl (- (string-length k) 1))) filtered))))))))))
|
||||
((filtered (if (nil? pattern) arr-keys (filter (fn (k) (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) arr-keys))))
|
||||
(assoc
|
||||
interp
|
||||
:result (join
|
||||
" "
|
||||
(map
|
||||
(fn
|
||||
(k)
|
||||
(substring
|
||||
k
|
||||
pl
|
||||
(- (string-length k) 1)))
|
||||
filtered))))))))))
|
||||
((equal? sub "size")
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
@@ -2990,8 +3303,13 @@
|
||||
(let
|
||||
((prefix (str (first rest-args) "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
(assoc interp :result
|
||||
(str (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))))))))
|
||||
(assoc
|
||||
interp
|
||||
:result (str
|
||||
(len
|
||||
(filter
|
||||
(fn (k) (tcl-starts-with? k prefix))
|
||||
(keys locals))))))))
|
||||
((equal? sub "exists")
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
@@ -2999,44 +3317,39 @@
|
||||
(let
|
||||
((prefix (str (first rest-args) "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
(assoc interp :result
|
||||
(if (> (len (filter (fn (k) (tcl-starts-with? k prefix)) (keys locals))) 0) "1" "0")))))
|
||||
(assoc
|
||||
interp
|
||||
:result (if
|
||||
(>
|
||||
(len
|
||||
(filter
|
||||
(fn (k) (tcl-starts-with? k prefix))
|
||||
(keys locals)))
|
||||
0)
|
||||
"1"
|
||||
"0")))))
|
||||
((equal? sub "unset")
|
||||
(if
|
||||
(= 0 (len rest-args))
|
||||
(error "array unset: wrong # args")
|
||||
(let
|
||||
((arr-name (first rest-args))
|
||||
(pattern (if (> (len rest-args) 1) (nth rest-args 1) nil)))
|
||||
(pattern
|
||||
(if
|
||||
(> (len rest-args) 1)
|
||||
(nth rest-args 1)
|
||||
nil)))
|
||||
(let
|
||||
((prefix (str arr-name "("))
|
||||
(locals (get (get interp :frame) :locals)))
|
||||
(let
|
||||
((pl (string-length prefix)))
|
||||
(let
|
||||
((to-delete
|
||||
(filter
|
||||
(fn (k)
|
||||
(if
|
||||
(tcl-starts-with? k prefix)
|
||||
(if
|
||||
(nil? pattern)
|
||||
true
|
||||
(let ((kn (substring k pl (- (string-length k) 1))))
|
||||
(tcl-glob-match (split pattern "") (split kn ""))))
|
||||
false))
|
||||
(keys locals))))
|
||||
((to-delete (filter (fn (k) (if (tcl-starts-with? k prefix) (if (nil? pattern) true (let ((kn (substring k pl (- (string-length k) 1)))) (tcl-glob-match (split pattern "") (split kn "")))) false)) (keys locals))))
|
||||
(let
|
||||
((new-locals
|
||||
(reduce
|
||||
(fn (acc k)
|
||||
(if
|
||||
(contains? to-delete k)
|
||||
acc
|
||||
(assoc acc k (get locals k))))
|
||||
{}
|
||||
(keys locals))))
|
||||
(assoc interp
|
||||
((new-locals (reduce (fn (acc k) (if (contains? to-delete k) acc (assoc acc k (get locals k)))) {} (keys locals))))
|
||||
(assoc
|
||||
interp
|
||||
:frame (assoc (get interp :frame) :locals new-locals)
|
||||
:result ""))))))))
|
||||
(else (error (str "array: unknown subcommand \"" sub "\""))))))))
|
||||
@@ -3048,7 +3361,7 @@
|
||||
(interp args)
|
||||
(if
|
||||
(< (len args) 1)
|
||||
(error "apply: wrong # args: should be "apply lambdaList ?arg ...?"")
|
||||
(error "apply: wrong # args: should be " apply lambdaList ?arg ...? "")
|
||||
(let
|
||||
((func-list (tcl-list-split (first args)))
|
||||
(call-args (rest args)))
|
||||
@@ -3058,90 +3371,122 @@
|
||||
(let
|
||||
((param-spec (first func-list))
|
||||
(body (nth func-list 1))
|
||||
(ns (if (> (len func-list) 2) (nth func-list 2) nil)))
|
||||
(ns
|
||||
(if
|
||||
(> (len func-list) 2)
|
||||
(nth func-list 2)
|
||||
nil)))
|
||||
(let
|
||||
((proc-def {:args param-spec :body body :ns ns}))
|
||||
(tcl-call-proc interp "#apply" proc-def call-args))))))))
|
||||
|
||||
|
||||
(define
|
||||
tcl-cmd-regexp
|
||||
(fn
|
||||
(interp args)
|
||||
(define parse-flags
|
||||
(fn (as nocase? all? inline?)
|
||||
(if (= 0 (len as))
|
||||
{:nocase nocase? :all all? :inline inline? :rest as}
|
||||
(define
|
||||
parse-flags
|
||||
(fn
|
||||
(as nocase? all? inline?)
|
||||
(if
|
||||
(= 0 (len as))
|
||||
{:rest as :nocase nocase? :inline inline? :all all?}
|
||||
(cond
|
||||
((equal? (first as) "-nocase") (parse-flags (rest as) true all? inline?))
|
||||
((equal? (first as) "-all") (parse-flags (rest as) nocase? true inline?))
|
||||
((equal? (first as) "-inline") (parse-flags (rest as) nocase? all? true))
|
||||
(else {:nocase nocase? :all all? :inline inline? :rest as})))))
|
||||
(let ((pf (parse-flags args false false false)))
|
||||
(let ((nocase (get pf :nocase))
|
||||
(all-mode (get pf :all))
|
||||
(inline-mode (get pf :inline))
|
||||
(ra (get pf :rest)))
|
||||
(if (< (len ra) 2)
|
||||
((equal? (first as) "-nocase")
|
||||
(parse-flags (rest as) true all? inline?))
|
||||
((equal? (first as) "-all")
|
||||
(parse-flags (rest as) nocase? true inline?))
|
||||
((equal? (first as) "-inline")
|
||||
(parse-flags (rest as) nocase? all? true))
|
||||
(else {:rest as :nocase nocase? :inline inline? :all all?})))))
|
||||
(let
|
||||
((pf (parse-flags args false false false)))
|
||||
(let
|
||||
((nocase (get pf :nocase))
|
||||
(all-mode (get pf :all))
|
||||
(inline-mode (get pf :inline))
|
||||
(ra (get pf :rest)))
|
||||
(if
|
||||
(< (len ra) 2)
|
||||
(error "regexp: wrong # args")
|
||||
(let ((pattern (first ra))
|
||||
(str-val (nth ra 1))
|
||||
(var-args (if (> (len ra) 2) (rest (rest ra)) (list))))
|
||||
(let ((re (make-regexp pattern (if nocase "i" ""))))
|
||||
(if all-mode
|
||||
(assoc interp :result (str (len (regexp-match-all re str-val))))
|
||||
(if inline-mode
|
||||
(assoc interp :result (join " " (map (fn (m) (get m :match)) (regexp-match-all re str-val))))
|
||||
(let ((m (regexp-match re str-val)))
|
||||
(if (nil? m)
|
||||
(let
|
||||
((pattern (first ra))
|
||||
(str-val (nth ra 1))
|
||||
(var-args
|
||||
(if (> (len ra) 2) (rest (rest ra)) (list))))
|
||||
(let
|
||||
((re (make-regexp pattern (if nocase "i" ""))))
|
||||
(if
|
||||
all-mode
|
||||
(assoc
|
||||
interp
|
||||
:result (str (len (regexp-match-all re str-val))))
|
||||
(if
|
||||
inline-mode
|
||||
(assoc
|
||||
interp
|
||||
:result (join
|
||||
" "
|
||||
(map
|
||||
(fn (m) (get m :match))
|
||||
(regexp-match-all re str-val))))
|
||||
(let
|
||||
((m (regexp-match re str-val)))
|
||||
(if
|
||||
(nil? m)
|
||||
(assoc interp :result "0")
|
||||
(let ((interp2
|
||||
(if (> (len var-args) 0)
|
||||
(tcl-var-set interp (first var-args) (get m :match))
|
||||
interp)))
|
||||
(let ((interp3
|
||||
(let loop ((vi 1) (gs (get m :groups)) (acc interp2))
|
||||
(if (or (= 0 (len gs)) (>= vi (len var-args))) acc
|
||||
(loop (+ vi 1) (rest gs)
|
||||
(tcl-var-set acc (nth var-args vi) (first gs)))))))
|
||||
(let
|
||||
((interp2 (if (> (len var-args) 0) (tcl-var-set interp (first var-args) (get m :match)) interp)))
|
||||
(let
|
||||
((interp3 (let loop ((vi 1) (gs (get m :groups)) (acc interp2)) (if (or (= 0 (len gs)) (>= vi (len var-args))) acc (loop (+ vi 1) (rest gs) (tcl-var-set acc (nth var-args vi) (first gs)))))))
|
||||
(assoc interp3 :result "1"))))))))))))))
|
||||
|
||||
|
||||
|
||||
(define
|
||||
tcl-cmd-regsub
|
||||
(fn
|
||||
(interp args)
|
||||
(define parse-flags
|
||||
(fn (as all? nocase?)
|
||||
(if (= 0 (len as))
|
||||
{:all all? :nocase nocase? :rest as}
|
||||
(define
|
||||
parse-flags
|
||||
(fn
|
||||
(as all? nocase?)
|
||||
(if
|
||||
(= 0 (len as))
|
||||
{:rest as :nocase nocase? :all all?}
|
||||
(cond
|
||||
((equal? (first as) "-all") (parse-flags (rest as) true nocase?))
|
||||
((equal? (first as) "-nocase") (parse-flags (rest as) all? true))
|
||||
(else {:all all? :nocase nocase? :rest as})))))
|
||||
(let ((pf (parse-flags args false false)))
|
||||
(let ((all-mode (get pf :all))
|
||||
(nocase (get pf :nocase))
|
||||
(ra (get pf :rest)))
|
||||
(if (< (len ra) 3)
|
||||
((equal? (first as) "-all")
|
||||
(parse-flags (rest as) true nocase?))
|
||||
((equal? (first as) "-nocase")
|
||||
(parse-flags (rest as) all? true))
|
||||
(else {:rest as :nocase nocase? :all all?})))))
|
||||
(let
|
||||
((pf (parse-flags args false false)))
|
||||
(let
|
||||
((all-mode (get pf :all))
|
||||
(nocase (get pf :nocase))
|
||||
(ra (get pf :rest)))
|
||||
(if
|
||||
(< (len ra) 3)
|
||||
(error "regsub: wrong # args")
|
||||
(let ((pattern (first ra))
|
||||
(str-val (nth ra 1))
|
||||
(replacement (nth ra 2))
|
||||
(var-name (if (> (len ra) 3) (nth ra 3) nil)))
|
||||
(let ((re (make-regexp pattern (if nocase "i" ""))))
|
||||
(let ((result
|
||||
(if all-mode
|
||||
(regexp-replace-all re str-val replacement)
|
||||
(regexp-replace re str-val replacement))))
|
||||
(if (nil? var-name)
|
||||
(let
|
||||
((pattern (first ra))
|
||||
(str-val (nth ra 1))
|
||||
(replacement (nth ra 2))
|
||||
(var-name
|
||||
(if (> (len ra) 3) (nth ra 3) nil)))
|
||||
(let
|
||||
((re (make-regexp pattern (if nocase "i" ""))))
|
||||
(let
|
||||
((result (if all-mode (regexp-replace-all re str-val replacement) (regexp-replace re str-val replacement))))
|
||||
(if
|
||||
(nil? var-name)
|
||||
(assoc interp :result result)
|
||||
(let ((count
|
||||
(if all-mode
|
||||
(len (regexp-match-all re str-val))
|
||||
(if (nil? (regexp-match re str-val)) 0 1))))
|
||||
(assoc (tcl-var-set interp var-name result) :result (str count))))))))))))
|
||||
|
||||
|
||||
(let
|
||||
((count (if all-mode (len (regexp-match-all re str-val)) (if (nil? (regexp-match re str-val)) 0 1))))
|
||||
(assoc
|
||||
(tcl-var-set interp var-name result)
|
||||
:result (str count))))))))))))
|
||||
|
||||
(define
|
||||
tcl-cmd-file
|
||||
@@ -3153,7 +3498,10 @@
|
||||
(let
|
||||
((sub (first args)) (rest-args (rest args)))
|
||||
(cond
|
||||
((equal? sub "exists") (assoc interp :result (if (file-exists? (first rest-args)) "1" "0")))
|
||||
((equal? sub "exists")
|
||||
(assoc
|
||||
interp
|
||||
:result (if (file-exists? (first rest-args)) "1" "0")))
|
||||
((equal? sub "join") (assoc interp :result (join "/" rest-args)))
|
||||
((equal? sub "split")
|
||||
(assoc
|
||||
@@ -3254,7 +3602,7 @@
|
||||
(let
|
||||
((i (tcl-register i "expr" tcl-cmd-expr)))
|
||||
(let
|
||||
((i (tcl-register i "gets" tcl-cmd-gets)))
|
||||
((i (tcl-register i "gets" tcl-cmd-gets-chan)))
|
||||
(let
|
||||
((i (tcl-register i "subst" tcl-cmd-subst)))
|
||||
(let
|
||||
@@ -3331,6 +3679,25 @@
|
||||
((i (tcl-register i "tell" tcl-cmd-tell)))
|
||||
(let
|
||||
((i (tcl-register i "flush" tcl-cmd-flush)))
|
||||
(let ((i (tcl-register i "file" tcl-cmd-file)))
|
||||
(let ((i (tcl-register i "regexp" tcl-cmd-regexp)))
|
||||
(let ((i (tcl-register i "regsub" tcl-cmd-regsub))) (let ((i (tcl-register i "apply" tcl-cmd-apply))) (tcl-register i "array" tcl-cmd-array))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
||||
(let
|
||||
((i (tcl-register i "fconfigure" tcl-cmd-fconfigure)))
|
||||
(let
|
||||
((i (tcl-register i "fileevent" tcl-cmd-fileevent)))
|
||||
(let
|
||||
((i (tcl-register i "after" tcl-cmd-after)))
|
||||
(let
|
||||
((i (tcl-register i "vwait" tcl-cmd-vwait)))
|
||||
(let
|
||||
((i (tcl-register i "update" tcl-cmd-update)))
|
||||
(let
|
||||
((i (tcl-register i "file" tcl-cmd-file)))
|
||||
(let
|
||||
((i (tcl-register i "regexp" tcl-cmd-regexp)))
|
||||
(let
|
||||
((i (tcl-register i "regsub" tcl-cmd-regsub)))
|
||||
(let
|
||||
((i (tcl-register i "apply" tcl-cmd-apply)))
|
||||
(tcl-register
|
||||
i
|
||||
"array"
|
||||
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
|
||||
|
||||
@@ -59,7 +59,7 @@ cat > "$TMPFILE" << EPOCHS
|
||||
(eval "tcl-test-summary")
|
||||
EPOCHS
|
||||
|
||||
OUTPUT=$(timeout 180 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
OUTPUT=$(timeout 1200 "$SX_SERVER" < "$TMPFILE" 2>&1)
|
||||
[ "$VERBOSE" = "-v" ] && echo "$OUTPUT"
|
||||
|
||||
# Extract summary line from epoch 11 output
|
||||
|
||||
@@ -124,7 +124,7 @@
|
||||
"file0")
|
||||
|
||||
(ok "eof-returns-1"
|
||||
(get (run "set ch [open /dev/null r]\neof $ch") :result)
|
||||
(get (run "set ch [open /dev/null r]\nread $ch\neof $ch") :result)
|
||||
"1")
|
||||
|
||||
(dict
|
||||
|
||||
@@ -187,6 +187,93 @@
|
||||
(env-extend (env-extend base "a" 3) "b" 7)
|
||||
(quote (* a b))))
|
||||
21)
|
||||
|
||||
; 26-32. Phase 5 channels: write/read/seek/tell/eof/append/non-blocking
|
||||
(ok "channel-write-read"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-1.txt\nset c [open $f w]\nputs $c \"line one\"\nputs $c \"line two\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"line one\nline two\n")
|
||||
|
||||
(ok "channel-gets-loop"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-2.txt\nset c [open $f w]\nputs $c apple\nputs $c banana\nputs $c cherry\nclose $c\nset c [open $f r]\nset out {}\nwhile {[gets $c line] >= 0} {lappend out $line}\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"apple banana cherry")
|
||||
|
||||
(ok "channel-seek-tell"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-3.txt\nset c [open $f w]\nputs -nonewline $c \"hello world\"\nclose $c\nset c [open $f r]\nseek $c 6\nset pos [tell $c]\nset rest [read $c]\nclose $c\nfile delete $f\nreturn \"$pos:$rest\"")
|
||||
:result)
|
||||
"6:world")
|
||||
|
||||
(ok "channel-eof-after-read"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-4.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nread $c\nset e [eof $c]\nclose $c\nfile delete $f\nreturn $e")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "channel-append-mode"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-5.txt\nset c [open $f w]\nputs -nonewline $c \"first\"\nclose $c\nset c [open $f a]\nputs -nonewline $c \"-second\"\nclose $c\nset c [open $f r]\nset out [read $c]\nclose $c\nfile delete $f\nreturn $out")
|
||||
:result)
|
||||
"first-second")
|
||||
|
||||
(ok "channel-seek-end"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-6.txt\nset c [open $f w]\nputs -nonewline $c \"abcdefghij\"\nclose $c\nset c [open $f r]\nseek $c 0 end\nset pos [tell $c]\nclose $c\nfile delete $f\nreturn $pos")
|
||||
:result)
|
||||
"10")
|
||||
|
||||
(ok "channel-fconfigure-blocking"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5-7.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfconfigure $c -blocking 0\nset b [fconfigure $c -blocking]\nclose $c\nfile delete $f\nreturn $b")
|
||||
:result)
|
||||
"0")
|
||||
|
||||
; 33-37. Phase 5b event loop: after / vwait / fileevent / update
|
||||
(ok "after-vwait-timer"
|
||||
(get
|
||||
(run
|
||||
"after 30 {set ::done fired}\nvwait ::done\nset ::done")
|
||||
:result)
|
||||
"fired")
|
||||
|
||||
(ok "after-multiple-timers-update"
|
||||
(get
|
||||
(run
|
||||
"set ::n 0\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nafter 0 {incr ::n}\nupdate\nset ::n")
|
||||
:result)
|
||||
"3")
|
||||
|
||||
(ok "fileevent-readable-fires"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5b-1.txt\nset c [open $f w]\nputs -nonewline $c hi\nclose $c\nset c [open $f r]\nfileevent $c readable {set ::ready 1; fileevent $::ch readable {}}\nset ::ch $c\nvwait ::ready\nclose $c\nfile delete $f\nset ::ready")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(ok "fileevent-query-script"
|
||||
(get
|
||||
(run
|
||||
"set f /tmp/tcl-phase5b-2.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset c [open $f r]\nfileevent $c readable {puts hello}\nset s [fileevent $c readable]\nclose $c\nfile delete $f\nreturn $s")
|
||||
:result)
|
||||
"puts hello")
|
||||
|
||||
(ok "after-cancel-via-vwait-timing"
|
||||
(get
|
||||
(run
|
||||
"set ::counter 0\nafter 10 {incr ::counter}\nafter 50 {set ::done 1}\nvwait ::done\nset ::counter")
|
||||
:result)
|
||||
"1")
|
||||
|
||||
(dict
|
||||
"passed"
|
||||
tcl-idiom-pass
|
||||
|
||||
Reference in New Issue
Block a user