giles
be820d0337
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 2m0s
11 new SX primitives in sx_primitives.ml wrapping Unix.openfile/read/write/ lseek/set_nonblock: channel-open/close/read/read-line/write/flush/seek/tell/ eof?/blocking?/set-blocking!. Tcl runtime now uses real channel ops: - open ?-mode? returns "fileN" handle (modes r/w/a/r+/w+/a+) - close/read/gets/puts/seek/tell/eof/flush wired through - new fconfigure command supports -blocking 0|1 - puts dispatches to channel-write when first arg starts with "file" - gets command registration fixed (was pointing to old stub) eof-returns-1 coro test updated to match real Tcl semantics (eof flips only after a read hits EOF). Test runner timeout bumped 180s→1200s (post-merge JIT is slow). +7 idiom tests covering write+read, gets-loop, seek/tell, eof-after-read, append mode, seek-to-end, fconfigure-blocking. 349/349 green. Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
248 lines
8.3 KiB
Plaintext
248 lines
8.3 KiB
Plaintext
; 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")
|
|
|
|
(dict
|
|
"passed"
|
|
tcl-idiom-pass
|
|
"failed"
|
|
tcl-idiom-fail
|
|
"failures"
|
|
tcl-idiom-failures)))
|