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

tcl: Phase 5d/5e/5f — file ops, clock locale+scan, socket -async
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 54s
Details

Browse Source 
Phase 5d (file metadata + ops):
- 11 SX primitives: file-size/mtime/stat/isfile?/isdir?/readable?/writable?/
  delete/mkdir/copy/rename — wrap Unix.stat/access/unlink/mkdir/rename
- Tcl `file` subcommands real (were stubs): isfile, isdir, readable,
  writable, size, mtime, atime, type, mkdir, copy, rename, delete
- file delete/copy/rename strip leading-`-` flags
- +10 idiom tests

Phase 5e (clock options + scan):
- clock-format extended to (t fmt tz), tz ∈ utc|local
- Added specifiers: %y, %I, %p, %w, %%
- New clock-scan SX primitive — format-driven parser + manual timegm
- Tcl clock format/scan accept -format, -timezone, -gmt 0|1
- +5 idiom tests

Phase 5f (socket -async):
- socket-connect-async SX primitive: Unix.set_nonblock + connect, catches
  EINPROGRESS; returns channel immediately
- channel-async-error: Unix.getsockopt_error
- Tcl `socket -async host port`; `fconfigure $sock -error`
- Connection completes on writable; canonical fileevent pattern works
- +3 idiom tests

Bug fix: tcl-call-proc was discarding :fileevents/:timers/:procs updates
made inside Tcl procs (only :commands forwarded). Now forwards full
result-interp as base, restoring caller's frame/stack/result/output/code.
This was masked until socket-async made fileevent-from-inside-proc the
natural pattern.

test.sh inner timeout bumped 1200s→2400s (post-merge JIT remains slow).

376/376 green.

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
This commit is contained in:
giles
2026-05-07 18:28:49 +00:00
parent c8b232d40e
commit 63ad4563cb
4 changed files with 481 additions and 43 deletions
Download Patch File Download Diff File Expand all files Collapse all files

160
lib/tcl/runtime.sx
View File

@@ -292,13 +292,15 @@
(> (len result-stack) caller-stack-len)
(nth result-stack caller-stack-len)
(get interp :frame))))
(assoc interp
; 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
:frame updated-caller
:frame-stack updated-below
:result result-val
:output (str caller-output proc-output)
:code (if (= code 2) 0 code)
:commands (get result-interp :commands))))))))))))))
:code (if (= code 2) 0 code))))))))))))))
(define
tcl-eval-cmd
@@ -2887,12 +2889,54 @@
((equal? sub "seconds") (assoc interp :result (str (clock-seconds))))
((equal? sub "milliseconds") (assoc interp :result (str (clock-milliseconds))))
((equal? sub "format")
(assoc interp :result (clock-format
(floor (parse-int (first rest-args)))
(if (> (len rest-args) 1) (nth rest-args (- (len rest-args) 1)) "%a %b %e %H:%M:%S %Z %Y"))))
((equal? sub "scan") (assoc interp :result "0"))
; clock format $secs ?-format $fmt? ?-timezone $tz? ?-gmt 0|1?
(let
((t (floor (parse-int (first rest-args))))
(opts (rest rest-args)))
(let
((fmt (tcl-clock-opt opts "-format" "%a %b %e %H:%M:%S %Z %Y"))
(tz (tcl-clock-tz opts)))
(assoc interp :result (clock-format t fmt tz)))))
((equal? sub "scan")
; clock scan $str ?-format $fmt? ?-timezone $tz? ?-gmt 0|1?
(let
((s (first rest-args)) (opts (rest rest-args)))
(let
((fmt (tcl-clock-opt opts "-format" "%Y-%m-%d %H:%M:%S"))
(tz (tcl-clock-tz opts)))
(assoc interp :result (str (clock-scan s fmt tz))))))
(else (error (str "clock: unknown subcommand \"" sub "\""))))))))
; Helper: extract a -flag $val pair from clock args.
(define
tcl-clock-opt
(fn
(opts flag default)
(cond
((< (len opts) 2) default)
((equal? (first opts) flag) (nth opts 1))
(else (tcl-clock-opt (rest (rest opts)) flag default)))))
; Helper: derive tz string from clock opts (-timezone or -gmt).
(define
tcl-clock-tz
(fn
(opts)
(let
((tz-explicit (tcl-clock-opt opts "-timezone" nil))
(gmt-flag (tcl-clock-opt opts "-gmt" nil)))
(cond
((not (nil? tz-explicit))
(cond
((equal? tz-explicit ":UTC") "utc")
((equal? tz-explicit "UTC") "utc")
((equal? tz-explicit "GMT") "utc")
(else "local")))
((equal? gmt-flag "1") "utc")
((equal? gmt-flag "true") "utc")
((not (nil? gmt-flag)) "local")
(else "utc")))))
(define
tcl-cmd-open
(fn
@@ -2973,26 +3017,31 @@
(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"))
(cond
((= 0 (len rest-args))
(assoc
interp
:result (str "-blocking " (if (channel-blocking? chan) "1" "0"))))
((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 "")))))))
((_
(channel-set-blocking!
chan
(not (or (equal? b "0") (equal? b "false"))))))
(assoc interp :result ""))))
((and
(= 1 (len rest-args))
(equal? (first rest-args) "-blocking"))
(assoc interp :result (if (channel-blocking? chan) "1" "0")))
((and
(= 1 (len rest-args))
(equal? (first rest-args) "-error"))
(assoc interp :result (channel-async-error chan)))
(else (assoc interp :result ""))))))
; ============================================================
@@ -3253,6 +3302,13 @@
(assoc
(tcl-fileevent-set interp server-chan "readable" handler)
:result server-chan))))))
((equal? (first args) "-async")
(if
(< (len args) 3)
(error "socket: usage: socket -async host port")
(let
((host (nth args 1)) (port (parse-int (nth args 2))))
(assoc interp :result (socket-connect-async host port)))))
((= 2 (len args))
(let
((host (first args)) (port (parse-int (nth args 1))))
@@ -3609,16 +3665,52 @@
(equal? dot-idx "-1")
nm
(substring nm 0 (parse-int dot-idx)))))))
((equal? sub "isfile") (assoc interp :result "0"))
((equal? sub "isdir") (assoc interp :result "0"))
((equal? sub "isdirectory") (assoc interp :result "0"))
((equal? sub "readable") (assoc interp :result "0"))
((equal? sub "writable") (assoc interp :result "0"))
((equal? sub "size") (assoc interp :result "0"))
((equal? sub "mkdir") (assoc interp :result ""))
((equal? sub "copy") (assoc interp :result ""))
((equal? sub "rename") (assoc interp :result ""))
((equal? sub "delete") (assoc interp :result ""))
((equal? sub "isfile")
(assoc interp :result (if (file-isfile? (first rest-args)) "1" "0")))
((equal? sub "isdir")
(assoc interp :result (if (file-isdir? (first rest-args)) "1" "0")))
((equal? sub "isdirectory")
(assoc interp :result (if (file-isdir? (first rest-args)) "1" "0")))
((equal? sub "readable")
(assoc interp :result (if (file-readable? (first rest-args)) "1" "0")))
((equal? sub "writable")
(assoc interp :result (if (file-writable? (first rest-args)) "1" "0")))
((equal? sub "size")
(assoc interp :result (str (file-size (first rest-args)))))
((equal? sub "mtime")
(assoc interp :result (str (file-mtime (first rest-args)))))
((equal? sub "atime")
(let ((s (file-stat (first rest-args))))
(assoc interp :result (if (nil? s) "0" (str (get s :atime))))))
((equal? sub "type")
(let ((s (file-stat (first rest-args))))
(assoc interp :result (if (nil? s) "" (get s :type)))))
((equal? sub "mkdir")
(let ((_ (file-mkdir (first rest-args))))
(assoc interp :result "")))
((equal? sub "copy")
(let
((paths
(filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args)))
(let ((_ (file-copy (first paths) (nth paths 1))))
(assoc interp :result ""))))
((equal? sub "rename")
(let
((paths
(filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args)))
(let ((_ (file-rename (first paths) (nth paths 1))))
(assoc interp :result ""))))
((equal? sub "delete")
(let
((paths
(filter (fn (a) (not (equal? (slice a 0 1) "-"))) rest-args)))
(let
((_
(reduce
(fn (acc p) (let ((_ (file-delete p))) acc))
nil
paths)))
(assoc interp :result ""))))
(else (error (str "file: unknown subcommand \"" sub "\""))))))))
(define