coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

tcl: Phase 5b event loop — fileevent/after/vwait/update
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m3s
Details

Browse Source 
New SX primitive io-select-channels(read-list write-list timeout-ms) wrapping
Unix.select on the registered channel table. Returns {:readable :writable}.

Tcl event loop implemented purely in Tcl (no sx_server.ml changes):
- fileevent $chan readable|writable script (or "" to unregister)
- fileevent $chan event (1 arg) returns the registered script
- after ms script — schedule one-shot timer
- after ms (no script) — sleep, driving event loop in the meantime
- vwait varname — block until var is set/changed, handlers run between polls
- update — non-blocking event drain (poll-timeout=0)

State on interp: :fileevents (list of (chan event script)) and :timers
(sorted list of (expiry-ms script)).

tcl-event-step is the inner loop: expire timers, build fd lists from
:fileevents, call io-select-channels with computed timeout, run ready
handlers. vwait polls every 1000ms or until var changes.

Scoped to script mode by design — vwait from inside a server-handled
command does not interact with sx_server's stdin scheduler.

+5 idiom tests: after-vwait-timer, after-multiple-timers-update,
fileevent-readable-fires, fileevent-query-script,
after-cancel-via-vwait-timing. 354/354 green.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-07 12:47:31 +00:00
parent be820d0337
commit 64d36fa66e
3 changed files with 299 additions and 1 deletions
Download Patch File Download Diff File Expand all files Collapse all files

220
lib/tcl/runtime.sx
View File

@@ -2990,6 +2990,216 @@
(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-array
(fn
@@ -3471,6 +3681,14 @@
((i (tcl-register i "flush" tcl-cmd-flush)))
(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
@@ -3482,4 +3700,4 @@
(tcl-register
i
"array"
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))
tcl-cmd-array)))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))