diff --git a/hosts/ocaml/lib/sx_primitives.ml b/hosts/ocaml/lib/sx_primitives.ml index bd30b828..58f7d5c4 100644 --- a/hosts/ocaml/lib/sx_primitives.ml +++ b/hosts/ocaml/lib/sx_primitives.ml @@ -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 diff --git a/lib/tcl/runtime.sx b/lib/tcl/runtime.sx index 81bf37c4..4457dc55 100644 --- a/lib/tcl/runtime.sx +++ b/lib/tcl/runtime.sx @@ -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))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))))) diff --git a/lib/tcl/tests/idioms.sx b/lib/tcl/tests/idioms.sx index b84aaafd..17738dc9 100644 --- a/lib/tcl/tests/idioms.sx +++ b/lib/tcl/tests/idioms.sx @@ -238,6 +238,42 @@ :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