tcl: Phase 5b event loop — fileevent/after/vwait/update
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m3s
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 1m3s
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:
@@ -3264,6 +3264,50 @@ let () =
|
||||
Nil
|
||||
| _ -> raise (Eval_error "channel-set-blocking!: (channel bool)"));
|
||||
|
||||
(* io-select-channels: (read-list write-list timeout-ms) → {:readable [...] :writable [...]}
|
||||
timeout-ms < 0 → block indefinitely; 0 → poll. Returns ready channel names. *)
|
||||
register "io-select-channels" (fun args ->
|
||||
let to_ms v = match v with
|
||||
| Integer n -> n
|
||||
| Number n -> int_of_float n
|
||||
| _ -> raise (Eval_error "io-select-channels: timeout must be a number")
|
||||
in
|
||||
let to_list v = match v with
|
||||
| List xs | ListRef { contents = xs } -> xs
|
||||
| Nil -> []
|
||||
| _ -> raise (Eval_error "io-select-channels: expected list")
|
||||
in
|
||||
let chan_name_of v = match v with
|
||||
| String s -> s
|
||||
| _ -> raise (Eval_error "io-select-channels: channel must be a string")
|
||||
in
|
||||
let (read_list, write_list, timeout_ms) = match args with
|
||||
| [r; w; t] -> (to_list r, to_list w, to_ms t)
|
||||
| _ -> raise (Eval_error "io-select-channels: (read-list write-list timeout-ms)")
|
||||
in
|
||||
let read_pairs = List.map (fun v ->
|
||||
let name = chan_name_of v in
|
||||
let (fd, _, _, _) = chan_get name in (name, fd)) read_list in
|
||||
let write_pairs = List.map (fun v ->
|
||||
let name = chan_name_of v in
|
||||
let (fd, _, _, _) = chan_get name in (name, fd)) write_list in
|
||||
let read_fds = List.map snd read_pairs in
|
||||
let write_fds = List.map snd write_pairs in
|
||||
let timeout = if timeout_ms < 0 then -1.0 else float_of_int timeout_ms /. 1000.0 in
|
||||
let (ready_r, ready_w, _) =
|
||||
try Unix.select read_fds write_fds [] timeout
|
||||
with Unix.Unix_error (Unix.EINTR, _, _) -> ([], [], [])
|
||||
in
|
||||
let names_of pairs ready =
|
||||
List.filter_map (fun (n, fd) ->
|
||||
if List.exists (fun rfd -> rfd = fd) ready then Some (String n) else None
|
||||
) pairs
|
||||
in
|
||||
let d = Hashtbl.create 2 in
|
||||
Hashtbl.replace d "readable" (List (names_of read_pairs ready_r));
|
||||
Hashtbl.replace d "writable" (List (names_of write_pairs ready_w));
|
||||
Dict d);
|
||||
|
||||
(* === Clock === *)
|
||||
register "clock-seconds" (fun args ->
|
||||
match args with
|
||||
|
||||
Reference in New Issue
Block a user