coop/rose-ash
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity
Files
2fa0bb4df1056f9bdb833c82ce70dcf3d0be0bb9
rose-ash/lib/tcl/tests/idioms.sx
giles 2fa0bb4df1
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 50s
Details
tcl: Phase 6 — namespace, list ops, dict additions, scan/format, exec [WIP] 
Phase 6a (namespace `::` prefix):
- tcl-global-ref?/strip-global helpers
- tcl-var-get/set route ::name to root frame
- tokenizer parse-var-sub accepts `::` start so $::var works
- tcl-call-proc forwards :fileevents/:timers/:procs/:commands
- char-at fast-path optimization on var-get/set hot path

Phase 6b (list ops): added lassign, lrepeat, lset, lmap.

Phase 6c (dict additions): added dict lappend, remove, filter -key.

Phase 6d (scan/format):
- printf-spec SX primitive wrapping OCaml Printf via Scanf.format_from_string
- scan-spec SX primitive (manual scanner for d/i/u/x/X/o/c/s/f/e/g)
- Tcl format dispatches via printf-spec; tcl-cmd-scan walks fmt and dispatches

Phase 6e (exec):
- exec-process SX primitive wraps Unix.create_process + waitpid
- Tcl `exec cmd arg...` returns trimmed stdout; raises on non-zero exit

test.sh inner timeout 3600s → 7200s (post-merge JIT recursion is slow).

+27 idiom tests covering ns, list ops, dict, format, scan, exec.

[WIP — full suite verification still pending]

Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
2026-05-08 08:28:05 +00:00

534 lines
18 KiB
Plaintext
Raw Blame History

; Tcl-on-SX idiom corpus (Phase 6)
; Classic Tcl idioms covering lists, dicts, procs, patterns
(define tcl-idiom-pass 0)
(define tcl-idiom-fail 0)
(define tcl-idiom-failures (list))
(define
tcl-idiom-assert
(fn
(label expected actual)
(if
(equal? expected actual)
(set! tcl-idiom-pass (+ tcl-idiom-pass 1))
(begin
(set! tcl-idiom-fail (+ tcl-idiom-fail 1))
(append!
tcl-idiom-failures
(str label ": expected=" (str expected) " got=" (str actual)))))))
(define
tcl-run-idiom-tests
(fn
()
(set! tcl-idiom-pass 0)
(set! tcl-idiom-fail 0)
(set! tcl-idiom-failures (list))
(define interp (fn () (make-default-tcl-interp)))
(define run (fn (src) (tcl-eval-string (interp) src)))
(define
ok
(fn (label actual expected) (tcl-idiom-assert label expected actual)))
(ok
"idiom-lmap"
(get
(run
"set result {}\nforeach x {1 2 3} { lappend result [expr {$x * $x}] }\nset result")
:result)
"1 4 9")
(ok
"idiom-flatten"
(get
(run
"proc flatten {lst} { set out {}\n foreach item $lst {\n if {[llength $item] > 1} {\n foreach sub [flatten $item] { lappend out $sub }\n } else {\n lappend out $item\n }\n }\n return $out\n}\nflatten {1 {2 3} {4 {5 6}}}")
:result)
"1 2 3 4 5 6")
(ok
"idiom-string-builder"
(get
(run
"set buf \"\"\nforeach w {Hello World Tcl} { append buf $w \" \" }\nstring trimright $buf")
:result)
"Hello World Tcl")
(ok
"idiom-default-param"
(get (run "if {![info exists x]} { set x 42 }\nset x") :result)
"42")
(ok
"idiom-alist-lookup"
(get
(run
"set keys {a b c}\nset vals {10 20 30}\nset idx [lsearch $keys b]\nlindex $vals $idx")
:result)
"20")
(ok
"idiom-optional-args"
(get
(run
"proc greet {name args} {\n set greeting \"Hello\"\n if {[llength $args] > 0} { set greeting [lindex $args 0] }\n return \"$greeting $name\"\n}\ngreet World Hi")
:result)
"Hi World")
(ok
"idiom-dict-builder"
(get
(run
"proc build-dict {args} { dict create {*}$args }\ndict get [build-dict name Alice age 30] name")
:result)
"Alice")
(ok
"idiom-loop-with-index"
(get
(run "set i 0\nforeach x {a b c} { set arr($i) $x; incr i }\nset arr(1)")
:result)
"b")
(ok
"idiom-string-reverse"
(get
(run
"set s hello\nset chars [split $s \"\"]\nset rev [lreverse $chars]\njoin $rev \"\"")
:result)
"olleh")
(ok "idiom-number-format" (get (run "format \"%05d\" 42") :result) "00042")
(ok
"idiom-dict-comprehension"
(get
(run
"set squares {}\nforeach n {1 2 3 4} { dict set squares $n [expr {$n * $n}] }\ndict get $squares 3")
:result)
"9")
(ok
"idiom-stack"
(get
(run
"proc stack-push {stackvar val} { upvar $stackvar s; lappend s $val }\nproc stack-pop {stackvar} { upvar $stackvar s; set val [lindex $s end]; set s [lrange $s 0 end-1]; return $val }\nset stk {}\nstack-push stk 10\nstack-push stk 20\nstack-push stk 30\nstack-pop stk")
:result)
"30")
(ok
"idiom-queue"
(get
(run
"proc q-enq {qvar val} { upvar $qvar q; lappend q $val }\nproc q-deq {qvar} { upvar $qvar q; set val [lindex $q 0]; set q [lrange $q 1 end]; return $val }\nset q {}\nq-enq q alpha\nq-enq q beta\nq-enq q gamma\nq-deq q")
:result)
"alpha")
(ok
"idiom-pipeline"
(get
(run
"proc double {x} { expr {$x * 2} }\nproc add1 {x} { expr {$x + 1} }\nproc pipeline {val procs} { foreach p $procs { set val [$p $val] }; return $val }\npipeline 5 {double add1 double}")
:result)
"22")
(ok
"idiom-memoize"
(get
(run
"set cache {}\nproc cached-square {n} { global cache\n if {[dict exists $cache $n]} { return [dict get $cache $n] }\n set r [expr {$n * $n}]\n dict set cache $n $r\n return $r\n}\nset a [cached-square 7]\nset b [cached-square 7]\nset c [cached-square 8]\nexpr {$a == $b && $c == 64}")
:result)
"1")
(ok
"idiom-recursive-eval"
(get
(run
"proc calc {expr} { return [::tcl::mathop::+ 0 [expr $expr]] }\nexpr {3 + 4 * 2}")
:result)
"11")
(ok
"idiom-dict-for"
(get
(run
"set d [dict create a 1 b 2 c 3]\nset total 0\ndict for {k v} $d { incr total $v }\nset total")
:result)
"6")
(ok
"idiom-find-max"
(get
(run
"proc list-max {lst} {\n set m [lindex $lst 0]\n foreach x $lst { if {$x > $m} { set m $x } }\n return $m\n}\nlist-max {3 1 4 1 5 9 2 6}")
:result)
"9")
(ok
"idiom-filter-list"
(get
(run
"proc list-filter {lst pred} {\n set out {}\n foreach x $lst { if {[$pred $x]} { lappend out $x } }\n return $out\n}\nproc is-even {n} { expr {$n % 2 == 0} }\nlist-filter {1 2 3 4 5 6} is-even")
:result)
"2 4 6")
(ok
"idiom-zip"
(get
(run
"proc zip {a b} {\n set out {}\n set n [llength $a]\n for {set i 0} {$i < $n} {incr i} {\n lappend out [lindex $a $i]\n lappend out [lindex $b $i]\n }\n return $out\n}\nzip {1 2 3} {a b c}")
:result)
"1 a 2 b 3 c")
(ok
"env-lookup-basic"
(env-lookup (let ((x 42)) (current-env)) "x")
42)
(ok
"env-lookup-missing"
(env-lookup (let ((x 42)) (current-env)) "z")
nil)
(ok
"env-extend-lookup"
(let
((e (let ((x 5)) (current-env))))
(env-lookup (env-extend e "y" 10) "y"))
10)
(ok
"eval-in-env-parent"
(let
((x 5))
(eval-in-env (env-extend (current-env) "y" 10) (quote (+ x y))))
15)
(ok
"eval-in-env-multi"
(let
((base (current-env)))
(eval-in-env
(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")
; 38-41. Phase 5c sockets: TCP client + server
(ok "socket-server-fires-callback"
(get
(run
"proc h {sock host port} { global got; set got hit; close $sock }\nset srv [socket -server h 18901]\nset cli [socket localhost 18901]\nvwait got\nclose $srv\nclose $cli\nset got")
:result)
"hit")
(ok "socket-client-server-roundtrip"
(get
(run
"proc h {sock host port} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server h 18902]\nset cli [socket localhost 18902]\nputs $cli ping\nflush $cli\nvwait received\nclose $srv\nclose $cli\nset received")
:result)
"ping")
(ok "socket-server-peer-host"
(get
(run
"proc h {sock host port} { global peer; set peer $host; close $sock }\nset srv [socket -server h 18903]\nset cli [socket 127.0.0.1 18903]\nvwait peer\nclose $srv\nclose $cli\nset peer")
:result)
"127.0.0.1")
(ok "socket-multiple-connections"
(get
(run
"proc h {sock host port} { global count; incr count; close $sock }\nset count 0\nset srv [socket -server h 18904]\nset c1 [socket localhost 18904]\nset c2 [socket localhost 18904]\nset c3 [socket localhost 18904]\nwhile {$count < 3} { update; after 5 }\nclose $srv\nclose $c1\nclose $c2\nclose $c3\nset count")
:result)
"3")
; 42-49. Phase 5d file metadata + ops
(ok "file-isfile-true"
(get
(run
"set f /tmp/tcl-phase5d-1.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset r [file isfile $f]\nfile delete $f\nreturn $r")
:result)
"1")
(ok "file-isfile-false-on-dir"
(get (run "file isfile /tmp") :result)
"0")
(ok "file-isdir-true"
(get (run "file isdir /tmp") :result)
"1")
(ok "file-size"
(get
(run
"set f /tmp/tcl-phase5d-2.txt\nset c [open $f w]\nputs -nonewline $c hello\nclose $c\nset s [file size $f]\nfile delete $f\nreturn $s")
:result)
"5")
(ok "file-readable-true"
(get (run "file readable /tmp") :result)
"1")
(ok "file-readable-missing"
(get (run "file readable /no/such/path/here") :result)
"0")
(ok "file-mkdir-then-isdir"
(get
(run
"set d /tmp/tcl-phase5d-mkdir/sub\nfile mkdir $d\nset r [file isdir $d]\nfile delete $d\nfile delete /tmp/tcl-phase5d-mkdir\nreturn $r")
:result)
"1")
(ok "file-copy-roundtrip"
(get
(run
"set s /tmp/tcl-phase5d-src.txt\nset d /tmp/tcl-phase5d-dst.txt\nset c [open $s w]\nputs -nonewline $c copydata\nclose $c\nfile copy $s $d\nset c [open $d r]\nset out [read $c]\nclose $c\nfile delete $s\nfile delete $d\nreturn $out")
:result)
"copydata")
(ok "file-rename-then-exists"
(get
(run
"set s /tmp/tcl-phase5d-r1.txt\nset d /tmp/tcl-phase5d-r2.txt\nset c [open $s w]\nputs -nonewline $c x\nclose $c\nfile rename $s $d\nset r [list [file exists $s] [file exists $d]]\nfile delete $d\nreturn $r")
:result)
"0 1")
(ok "file-mtime-positive"
(get
(run
"set f /tmp/tcl-phase5d-mt.txt\nset c [open $f w]\nputs -nonewline $c x\nclose $c\nset m [file mtime $f]\nfile delete $f\nexpr {$m > 0}")
:result)
"1")
; 52-56. Phase 5e clock format options + clock scan
(ok "clock-format-utc"
(get
(run "clock format 0 -format {%Y-%m-%d %H:%M:%S} -gmt 1")
:result)
"1970-01-01 00:00:00")
(ok "clock-format-fmt-default"
(get
(run "clock format 1710513000 -format {%Y-%m-%d} -gmt 1")
:result)
"2024-03-15")
(ok "clock-scan-roundtrip"
(get
(run "set t [clock scan {2024-06-15 12:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1]\nclock format $t -format {%Y-%m-%d %H:%M:%S} -gmt 1")
:result)
"2024-06-15 12:00:00")
(ok "clock-scan-returns-int"
(get
(run "expr {[clock scan {1970-01-01 00:00:00} -format {%Y-%m-%d %H:%M:%S} -gmt 1] == 0}")
:result)
"1")
(ok "clock-format-percent-pct"
(get
(run "clock format 0 -format {%Y%%%m} -gmt 1")
:result)
"1970%01")
; 57-59. Phase 5f socket -async (non-blocking connect)
(ok "socket-async-completes-writable"
(get
(run
"proc h {sock host port} { close $sock }\nset srv [socket -server h 18930]\nset c [socket -async localhost 18930]\nset ready 0\nfileevent $c writable {global ready; set ready 1}\nvwait ready\nclose $c\nclose $srv\nset ready")
:result)
"1")
(ok "socket-async-then-write"
(get
(run
"proc accept {sock host port} { global accepted_sock; set accepted_sock $sock; fileevent $sock readable [list reader $sock] }\nproc reader {sock} { global received; gets $sock line; set received $line; close $sock }\nset srv [socket -server accept 18931]\nset c [socket -async localhost 18931]\nfileevent $c writable {global wready; set wready 1; fileevent $::ch writable {}}\nset ::ch $c\nvwait wready\nputs $c async-data\nflush $c\nvwait received\nclose $c\nclose $srv\nset received")
:result)
"async-data")
(ok "socket-async-no-error"
(get
(run
"proc h {sock host port} { close $sock }\nset srv [socket -server h 18932]\nset c [socket -async localhost 18932]\nset r 0\nfileevent $c writable {global r; set r 1}\nvwait r\nset err [fconfigure $c -error]\nclose $c\nclose $srv\nreturn $err")
:result)
"")
; 60-63. Phase 6a namespace :: prefix
(ok "ns-set-from-proc-reaches-global"
(get
(run
"proc f {x} { set ::g $x }\nf hello\nset ::g")
:result)
"hello")
(ok "ns-read-from-proc"
(get
(run
"set ::v 42\nproc f {} { return $::v }\nf")
:result)
"42")
(ok "ns-incr-via-prefix"
(get
(run
"set ::n 5\nproc bump {} { incr ::n }\nbump\nbump\nset ::n")
:result)
"7")
(ok "ns-different-from-local"
(get
(run
"set x outer\nproc f {} { set x inner; set ::x global; return $x }\nf")
:result)
"inner")
; 64-69. Phase 6b list ops (lassign, lrepeat, lset, lmap)
(ok "lassign-three"
(get (run "lassign {a b c d e} x y z\nlist $x $y $z") :result)
"a b c")
(ok "lassign-leftover"
(get (run "lassign {1 2 3 4 5} a b") :result)
"3 4 5")
(ok "lrepeat-basic"
(get (run "lrepeat 3 a") :result)
"a a a")
(ok "lrepeat-multi"
(get (run "lrepeat 2 x y") :result)
"x y x y")
(ok "lset-replaces"
(get (run "set L {a b c d}\nlset L 2 ZZ\nset L") :result)
"a b ZZ d")
(ok "lmap-square"
(get (run "lmap n {1 2 3 4} {expr {$n * $n}}") :result)
"1 4 9 16")
; 70-72. Phase 6c dict additions (lappend, remove, filter)
(ok "dict-lappend-extends"
(get (run "set d {tags {a b}}\ndict lappend d tags c d\nset d") :result)
"tags {a b c d}")
(ok "dict-remove"
(get (run "dict remove {a 1 b 2 c 3} b") :result)
"a 1 c 3")
(ok "dict-filter-key"
(get (run "dict filter {alpha 1 beta 2 gamma 3} key a*") :result)
"alpha 1")
; 73-79. Phase 6d format and scan
(ok "format-int-padded"
(get (run "format {%05d} 42") :result)
"00042")
(ok "format-float-precision"
(get (run "format {%.2f} 3.14159") :result)
"3.14")
(ok "format-hex"
(get (run "format {%x} 255") :result)
"ff")
(ok "format-char"
(get (run "format {%c} 65") :result)
"A")
(ok "format-string-left"
(get (run "format {%-5s|} hi") :result)
"hi |")
(ok "scan-two-ints"
(get (run "scan {12 34} {%d %d} a b\nlist $a $b") :result)
"12 34")
(ok "scan-count"
(get (run "scan {hello 42} {%s %d}") :result)
"hello 42")
; 80-82. Phase 6e exec
(ok "exec-echo"
(get (run "exec echo hello world") :result)
"hello world")
(ok "exec-printf-no-newline"
(get (run "exec /bin/printf x") :result)
"x")
(ok "exec-with-args"
(get (run "exec /bin/echo -n test") :result)
"test")
(dict
"passed"
tcl-idiom-pass
"failed"
tcl-idiom-fail
"failures"
tcl-idiom-failures)))
Reference in New Issue View Git Blame Copy Permalink