giles
35511db15b
Some checks failed
Test, Build, and Deploy / test-build-deploy (push) Failing after 45s
Co-Authored-By: Claude Sonnet 4.6 <noreply@anthropic.com>
387 lines
17 KiB
Plaintext
387 lines
17 KiB
Plaintext
; Tcl-on-SX eval tests
|
|
(define tcl-eval-pass 0)
|
|
(define tcl-eval-fail 0)
|
|
(define tcl-eval-failures (list))
|
|
|
|
(define
|
|
tcl-eval-assert
|
|
(fn
|
|
(label expected actual)
|
|
(if
|
|
(equal? expected actual)
|
|
(set! tcl-eval-pass (+ tcl-eval-pass 1))
|
|
(begin
|
|
(set! tcl-eval-fail (+ tcl-eval-fail 1))
|
|
(append!
|
|
tcl-eval-failures
|
|
(str label ": expected=" (str expected) " got=" (str actual)))))))
|
|
|
|
(define
|
|
tcl-run-eval-tests
|
|
(fn
|
|
()
|
|
(set! tcl-eval-pass 0)
|
|
(set! tcl-eval-fail 0)
|
|
(set! tcl-eval-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-eval-assert label expected actual)))
|
|
(define
|
|
ok?
|
|
(fn (label condition) (tcl-eval-assert label true condition)))
|
|
(tcl-eval-assert "set-result" "hello" (get (run "set x hello") :result))
|
|
(tcl-eval-assert
|
|
"set-stored"
|
|
"hello"
|
|
(tcl-var-get (run "set x hello") "x"))
|
|
(tcl-eval-assert
|
|
"var-sub"
|
|
"hello"
|
|
(tcl-var-get (run "set x hello\nset y $x") "y"))
|
|
(tcl-eval-assert
|
|
"puts"
|
|
"world\n"
|
|
(get (run "set x world\nputs $x") :output))
|
|
(tcl-eval-assert
|
|
"puts-nonewline"
|
|
"hi"
|
|
(get (run "puts -nonewline hi") :output))
|
|
(tcl-eval-assert "incr" "6" (tcl-var-get (run "set x 5\nincr x") "x"))
|
|
(tcl-eval-assert
|
|
"incr-delta"
|
|
"8"
|
|
(tcl-var-get (run "set x 5\nincr x 3") "x"))
|
|
(tcl-eval-assert
|
|
"incr-neg"
|
|
"7"
|
|
(tcl-var-get (run "set x 10\nincr x -3") "x"))
|
|
(tcl-eval-assert
|
|
"append"
|
|
"foobar"
|
|
(tcl-var-get (run "set x foo\nappend x bar") "x"))
|
|
(tcl-eval-assert
|
|
"append-new"
|
|
"hello"
|
|
(tcl-var-get (run "append x hello") "x"))
|
|
(tcl-eval-assert
|
|
"cmdsub-result"
|
|
"6"
|
|
(get (run "set x 5\nset y [incr x]") :result))
|
|
(tcl-eval-assert
|
|
"cmdsub-y"
|
|
"6"
|
|
(tcl-var-get (run "set x 5\nset y [incr x]") "y"))
|
|
(tcl-eval-assert
|
|
"cmdsub-x"
|
|
"6"
|
|
(tcl-var-get (run "set x 5\nset y [incr x]") "x"))
|
|
(tcl-eval-assert
|
|
"multi-cmd"
|
|
"second"
|
|
(get (run "set x first\nset x second") :result))
|
|
(tcl-eval-assert "semi-x" "1" (tcl-var-get (run "set x 1; set y 2") "x"))
|
|
(tcl-eval-assert "semi-y" "2" (tcl-var-get (run "set x 1; set y 2") "y"))
|
|
(tcl-eval-assert
|
|
"braced-nosub"
|
|
"$x"
|
|
(tcl-var-get (run "set x 42\nset y {$x}") "y"))
|
|
(tcl-eval-assert
|
|
"concat-word"
|
|
"foobar"
|
|
(tcl-var-get (run "set x foo\nset y ${x}bar") "y"))
|
|
(tcl-eval-assert
|
|
"set-get"
|
|
"world"
|
|
(get (run "set x world\nset x") :result))
|
|
(tcl-eval-assert
|
|
"puts-channel"
|
|
"hello\n"
|
|
(get (run "puts stdout hello") :output))
|
|
(ok "if-true" (get (run "set x 0\nif {1} {set x 1}") :result) "1")
|
|
(ok "if-false" (get (run "set x 0\nif {0} {set x 1}") :result) "0")
|
|
(ok
|
|
"if-else-t"
|
|
(tcl-var-get (run "if {1} {set x yes} else {set x no}") "x")
|
|
"yes")
|
|
(ok
|
|
"if-else-f"
|
|
(tcl-var-get (run "if {0} {set x yes} else {set x no}") "x")
|
|
"no")
|
|
(ok
|
|
"if-cmp"
|
|
(tcl-var-get
|
|
(run "set x 5\nif {$x > 3} {set r big} else {set r small}")
|
|
"r")
|
|
"big")
|
|
(ok
|
|
"while"
|
|
(tcl-var-get
|
|
(run "set i 0\nset s 0\nwhile {$i < 5} {incr i\nincr s $i}")
|
|
"s")
|
|
"15")
|
|
(ok
|
|
"while-break"
|
|
(tcl-var-get
|
|
(run "set i 0\nwhile {1} {incr i\nif {$i == 3} {break}}")
|
|
"i")
|
|
"3")
|
|
(ok
|
|
"for"
|
|
(tcl-var-get
|
|
(run "set s 0\nfor {set i 1} {$i <= 5} {incr i} {incr s $i}")
|
|
"s")
|
|
"15")
|
|
(ok
|
|
"foreach"
|
|
(tcl-var-get (run "set s 0\nforeach x {1 2 3 4 5} {incr s $x}") "s")
|
|
"15")
|
|
(ok
|
|
"foreach-list"
|
|
(get (run "set acc \"\"\nforeach w {hello world} {append acc $w}") :result)
|
|
"helloworld")
|
|
(ok
|
|
"lappend"
|
|
(tcl-var-get (run "lappend lst a\nlappend lst b\nlappend lst c") "lst")
|
|
"a b c")
|
|
(ok?
|
|
"unset-gone"
|
|
(let
|
|
((i (run "set x 42\nunset x")))
|
|
(let
|
|
((frame (get i :frame)))
|
|
(nil? (get (get frame :locals) "x")))))
|
|
(ok "eval" (tcl-var-get (run "eval {set x hello}") "x") "hello")
|
|
(ok "expr-precedence" (get (run "expr {3 + 4 * 2}") :result) "11")
|
|
(ok "expr-parens" (get (run "expr {(3 + 4) * 2}") :result) "14")
|
|
(ok "expr-unary-minus" (get (run "expr {-5}") :result) "-5")
|
|
(ok "expr-unary-not-0" (get (run "expr {!0}") :result) "1")
|
|
(ok "expr-unary-not-1" (get (run "expr {!1}") :result) "0")
|
|
(ok "expr-power" (get (run "expr {2 ** 10}") :result) "1024")
|
|
(ok "expr-le" (get (run "expr {3 <= 3}") :result) "1")
|
|
(ok "expr-ge" (get (run "expr {4 >= 5}") :result) "0")
|
|
(ok "expr-and" (get (run "expr {1 && 1}") :result) "1")
|
|
(ok "expr-or" (get (run "expr {0 || 1}") :result) "1")
|
|
(ok "expr-var-sub" (get (run "set x 7\nexpr {$x * 3}") :result) "21")
|
|
(ok "expr-abs-neg" (get (run "expr {abs(-3)}") :result) "3")
|
|
(ok "expr-abs-pos" (get (run "expr {abs(5)}") :result) "5")
|
|
(ok "expr-pow-fn" (get (run "expr {pow(2, 8)}") :result) "256")
|
|
(ok "expr-max" (get (run "expr {max(3, 7)}") :result) "7")
|
|
(ok "expr-min" (get (run "expr {min(3, 7)}") :result) "3")
|
|
(ok "expr-sqrt-9" (get (run "expr {sqrt(9)}") :result) "3")
|
|
(ok "expr-sqrt-16" (get (run "expr {sqrt(16)}") :result) "4")
|
|
(ok "expr-mod" (get (run "expr {17 % 5}") :result) "2")
|
|
(ok "expr-nospace" (get (run "expr {3+4*2}") :result) "11")
|
|
(ok "expr-add" (get (run "expr {3 + 4}") :result) "7")
|
|
(ok "expr-cmp" (get (run "expr {5 > 3}") :result) "1")
|
|
(ok
|
|
"break-stops"
|
|
(tcl-var-get (run "set x 0\nwhile {1} {set x 1\nbreak\nset x 99}") "x")
|
|
"1")
|
|
(ok
|
|
"continue"
|
|
(tcl-var-get
|
|
(run
|
|
"set s 0\nfor {set i 1} {$i <= 5} {incr i} {if {$i == 3} {continue}\nincr s $i}")
|
|
"s")
|
|
"12")
|
|
(ok
|
|
"switch"
|
|
(tcl-var-get
|
|
(run "set x foo\nswitch $x {{foo} {set r yes} {bar} {set r no}}")
|
|
"r")
|
|
"yes")
|
|
(ok
|
|
"switch-default"
|
|
(tcl-var-get
|
|
(run "set x baz\nswitch $x {{foo} {set r yes} default {set r other}}")
|
|
"r")
|
|
"other")
|
|
(ok
|
|
"nested-if"
|
|
(tcl-var-get
|
|
(run
|
|
"set x 5\nif {$x > 10} {set r big} elseif {$x > 3} {set r mid} else {set r small}")
|
|
"r")
|
|
"mid")
|
|
(ok "str-length" (get (run "string length hello") :result) "5")
|
|
(ok "str-length-empty" (get (run "string length {}") :result) "0")
|
|
(ok "str-index" (get (run "string index hello 1") :result) "e")
|
|
(ok "str-index-oob" (get (run "string index hello 99") :result) "")
|
|
(ok "str-range" (get (run "string range hello 1 3") :result) "ell")
|
|
(ok "str-range-clamp" (get (run "string range hello 3 99") :result) "lo")
|
|
(ok "str-compare-eq" (get (run "string compare abc abc") :result) "0")
|
|
(ok "str-compare-lt" (get (run "string compare abc abd") :result) "-1")
|
|
(ok "str-compare-gt" (get (run "string compare b a") :result) "1")
|
|
(ok "str-match-star" (get (run "string match h*o hello") :result) "1")
|
|
(ok "str-match-q" (get (run "string match h?llo hello") :result) "1")
|
|
(ok "str-match-no" (get (run "string match h*x hello") :result) "0")
|
|
(ok "str-toupper" (get (run "string toupper hello") :result) "HELLO")
|
|
(ok "str-tolower" (get (run "string tolower WORLD") :result) "world")
|
|
(ok "str-trim" (get (run "string trim { hi }") :result) "hi")
|
|
(ok "str-trimleft" (get (run "string trimleft { hi }") :result) "hi ")
|
|
(ok "str-trimright" (get (run "string trimright { hi }") :result) " hi")
|
|
(ok "str-trim-chars" (get (run "string trim {xxhelloxx} x") :result) "hello")
|
|
(ok "str-map" (get (run "string map {a X b Y} {abc}") :result) "XYc")
|
|
(ok "str-repeat" (get (run "string repeat ab 3") :result) "ababab")
|
|
(ok "str-first" (get (run "string first ll hello") :result) "2")
|
|
(ok "str-first-miss" (get (run "string first z hello") :result) "-1")
|
|
(ok "str-last" (get (run "string last l hello") :result) "3")
|
|
(ok "str-is-int" (get (run "string is integer 42") :result) "1")
|
|
(ok "str-is-not-int" (get (run "string is integer foo") :result) "0")
|
|
(ok "str-is-alpha" (get (run "string is alpha hello") :result) "1")
|
|
(ok "str-is-alpha-no" (get (run "string is alpha hello1") :result) "0")
|
|
(ok "str-is-boolean" (get (run "string is boolean true") :result) "1")
|
|
(ok "str-cat" (get (run "string cat foo bar baz") :result) "foobarbaz")
|
|
; --- list command tests ---
|
|
(ok "list-simple" (get (run "list a b c") :result) "a b c")
|
|
(ok "list-brace-elem" (get (run "list {a b} c") :result) "{a b} c")
|
|
(ok "list-empty" (get (run "list") :result) "")
|
|
(ok "lindex-1" (get (run "lindex {a b c} 1") :result) "b")
|
|
(ok "lindex-0" (get (run "lindex {a b c} 0") :result) "a")
|
|
(ok "lindex-oob" (get (run "lindex {a b c} 5") :result) "")
|
|
(ok "lrange" (get (run "lrange {a b c d} 1 2") :result) "b c")
|
|
(ok "lrange-full" (get (run "lrange {a b c} 0 end") :result) "a b c")
|
|
(ok "llength" (get (run "llength {a b c}") :result) "3")
|
|
(ok "llength-empty" (get (run "llength {}") :result) "0")
|
|
(ok "lreverse" (get (run "lreverse {1 2 3}") :result) "3 2 1")
|
|
(ok "lsearch-found" (get (run "lsearch {a b c} b") :result) "1")
|
|
(ok "lsearch-missing" (get (run "lsearch {a b c} z") :result) "-1")
|
|
(ok "lsearch-exact" (get (run "lsearch -exact {foo bar} foo") :result) "0")
|
|
(ok "lsort-asc" (get (run "lsort {banana apple cherry}") :result) "apple banana cherry")
|
|
(ok "lsort-int" (get (run "lsort -integer {10 2 30 5}") :result) "2 5 10 30")
|
|
(ok "lsort-dec" (get (run "lsort -decreasing {c a b}") :result) "c b a")
|
|
(ok "lreplace" (get (run "lreplace {a b c d} 1 2 X Y") :result) "a X Y d")
|
|
(ok "linsert" (get (run "linsert {a b c} 1 X Y") :result) "a X Y b c")
|
|
(ok "linsert-end" (get (run "linsert {a b} end Z") :result) "a b Z")
|
|
(ok "concat" (get (run "concat {a b} {c d}") :result) "a b c d")
|
|
(ok "split-sep" (get (run "split {a:b:c} :") :result) "a b c")
|
|
(ok "split-ws" (get (run "split {a b c}") :result) "a b c")
|
|
(ok "join-sep" (get (run "join {a b c} -") :result) "a-b-c")
|
|
(ok "join-default" (get (run "join {a b c}") :result) "a b c")
|
|
(ok "list-var" (get (run "set L {x y z}\nllength $L") :result) "3")
|
|
; --- dict command tests ---
|
|
(ok "dict-create" (get (run "dict create a 1 b 2") :result) "a 1 b 2")
|
|
(ok "dict-create-empty" (get (run "dict create") :result) "")
|
|
(ok "dict-get" (get (run "dict get {a 1 b 2} a") :result) "1")
|
|
(ok "dict-get-b" (get (run "dict get {a 1 b 2} b") :result) "2")
|
|
(ok "dict-exists-yes" (get (run "dict exists {a 1 b 2} a") :result) "1")
|
|
(ok "dict-exists-no" (get (run "dict exists {a 1 b 2} z") :result) "0")
|
|
(ok "dict-set-new" (get (run "set d {}\ndict set d x 42") :result) "x 42")
|
|
(ok "dict-set-update" (get (run "set d {a 1 b 2}\ndict set d a 99") :result) "a 99 b 2")
|
|
(ok "dict-set-stored" (tcl-var-get (run "set d {a 1}\ndict set d b 2") "d") "a 1 b 2")
|
|
(ok "dict-unset" (get (run "set d {a 1 b 2}\ndict unset d a") :result) "b 2")
|
|
(ok "dict-unset-stored" (tcl-var-get (run "set d {a 1 b 2}\ndict unset d a") "d") "b 2")
|
|
(ok "dict-keys" (get (run "dict keys {a 1 b 2}") :result) "a b")
|
|
(ok "dict-keys-pattern" (get (run "dict keys {abc 1 abd 2 xyz 3} ab*") :result) "abc abd")
|
|
(ok "dict-values" (get (run "dict values {a 1 b 2}") :result) "1 2")
|
|
(ok "dict-size" (get (run "dict size {a 1 b 2 c 3}") :result) "3")
|
|
(ok "dict-size-empty" (get (run "dict size {}") :result) "0")
|
|
(ok "dict-for" (tcl-var-get (run "set acc {}\ndict for {k v} {a 1 b 2} {append acc $k$v}") "acc") "a1b2")
|
|
(ok "dict-merge-disjoint" (get (run "dict merge {a 1} {b 2}") :result) "a 1 b 2")
|
|
(ok "dict-merge-overlap" (get (run "dict merge {a 1 b 2} {b 99}") :result) "a 1 b 99")
|
|
(ok "dict-incr-existing" (get (run "set d {x 5}\ndict incr d x") :result) "x 6")
|
|
(ok "dict-incr-delta" (get (run "set d {x 5}\ndict incr d x 3") :result) "x 8")
|
|
(ok "dict-incr-missing" (get (run "set d {}\ndict incr d n") :result) "n 1")
|
|
(ok "dict-append" (get (run "set d {x hello}\ndict append d x _hi") :result) "x hello_hi")
|
|
(ok "dict-append-new" (get (run "set d {}\ndict append d k val") :result) "k val")
|
|
; --- proc tests ---
|
|
(ok "proc-basic" (get (run "proc add {a b} {expr {$a + $b}}\nadd 3 4") :result) "7")
|
|
(ok "proc-return" (get (run "proc greet {name} {set msg \"hi $name\"\nreturn $msg}\ngreet World") :result) "hi World")
|
|
(ok "proc-factorial" (get (run "proc factorial {n} {if {$n <= 1} {return 1}\nexpr {$n * [factorial [expr {$n - 1}]]}}\nfactorial 5") :result) "120")
|
|
(ok "proc-args" (get (run "proc sum args {set t 0\nforeach x $args {incr t $x}\nreturn $t}\nsum 1 2 3 4") :result) "10")
|
|
(ok "proc-isolated" (get (run "set x outer\nproc p {} {set x inner\nreturn $x}\np") :result) "inner")
|
|
(ok "proc-caller-unchanged" (tcl-var-get (run "set x outer\nproc p {} {set x inner\nreturn $x}\np\nset dummy 1") "x") "outer")
|
|
(ok "proc-output" (get (run "proc hello {} {puts -nonewline hi}\nhello") :output) "hi")
|
|
; --- upvar tests ---
|
|
(ok "upvar-incr" (tcl-var-get (run "proc incr2 {varname} {upvar 1 $varname v\nincr v}\nset counter 10\nincr2 counter\nset counter") "counter") "11")
|
|
(ok "upvar-double" (tcl-var-get (run "proc double-it {varname} {upvar 1 $varname x\nset x [expr {$x * 2}]}\nset val 5\ndouble-it val\nset val") "val") "10")
|
|
(ok "upvar-result" (get (run "proc double-it {varname} {upvar 1 $varname x\nset x [expr {$x * 2}]}\nset val 5\ndouble-it val\nset val") :result) "10")
|
|
; --- uplevel tests ---
|
|
(ok "uplevel-set" (tcl-var-get (run "proc setvar {name val} {uplevel 1 \"set $name $val\"}\nsetvar x 99\nset x") "x") "99")
|
|
(ok "uplevel-get" (get (run "proc getvar {name} {uplevel 1 \"set $name\"}\nset y 77\ngetvar y") :result) "77")
|
|
; --- global tests ---
|
|
(ok "global-read" (get (run "set g 100\nproc getg {} {global g\nreturn $g}\ngetg") :result) "100")
|
|
(ok "global-write" (tcl-var-get (run "set g 0\nproc bumping {} {global g\nincr g}\nbumping\nbumping\nset g") "g") "2")
|
|
; --- info tests ---
|
|
(ok "info-level-0" (get (run "info level") :result) "0")
|
|
(ok "info-level-proc" (get (run "proc p {} {info level}\np") :result) "1")
|
|
(ok "info-procs" (let ((r (get (run "proc myfn {} {}\ninfo procs") :result))) (contains? (tcl-list-split r) "myfn")) true)
|
|
(ok "info-args" (get (run "proc add {a b} {expr {$a+$b}}\ninfo args add") :result) "a b")
|
|
(ok "info-commands-has-set" (let ((r (get (run "info commands") :result))) (contains? (tcl-list-split r) "set")) true)
|
|
; --- classic programs ---
|
|
(ok
|
|
"classic-for-each-line"
|
|
(get
|
|
(run "proc for-each-line {var lines body} {\n foreach item $lines {\n uplevel 1 [list set $var $item]\n uplevel 1 $body\n }\n}\nset total 0\nfor-each-line line {hello world foo} {\n incr total [string length $line]\n}\nset total")
|
|
:result)
|
|
"13")
|
|
(ok
|
|
"classic-assert"
|
|
(get
|
|
(run "proc assert {expr_str} {\n set result [uplevel 1 [list expr $expr_str]]\n if {!$result} {\n error \"Assertion failed: $expr_str\"\n }\n}\nset x 42\nassert {$x == 42}\nassert {$x > 0}\nset x 10\nassert {$x < 100}\nset x")
|
|
:result)
|
|
"10")
|
|
(ok
|
|
"classic-with-temp-var"
|
|
(get
|
|
(run "proc with-temp-var {varname tempval body} {\n upvar 1 $varname v\n set saved $v\n set v $tempval\n uplevel 1 $body\n set v $saved\n}\nset x 100\nwith-temp-var x 999 {\n set captured $x\n}\nlist $x $captured")
|
|
:result)
|
|
"100 999")
|
|
(ok
|
|
"array-set-get"
|
|
(get
|
|
(run "array set a {x 1 y 2 z 3}; array get a x")
|
|
:result)
|
|
"x 1")
|
|
(ok
|
|
"array-names"
|
|
(get
|
|
(run "array set a {p 10 q 20}; lsort [array names a]")
|
|
:result)
|
|
"p q")
|
|
(ok
|
|
"array-size"
|
|
(get
|
|
(run "array set a {x 1 y 2 z 3}; array size a")
|
|
:result)
|
|
"3")
|
|
(ok
|
|
"array-exists-true"
|
|
(get
|
|
(run "array set a {x 1}; array exists a")
|
|
:result)
|
|
"1")
|
|
(ok
|
|
"array-exists-false"
|
|
(get
|
|
(run "array exists nosucharray")
|
|
:result)
|
|
"0")
|
|
(ok
|
|
"array-unset-key"
|
|
(get
|
|
(run "array set a {x 1 y 2 z 3}; array unset a y; lsort [array names a]")
|
|
:result)
|
|
"x z")
|
|
(ok
|
|
"array-scalar-access"
|
|
(get
|
|
(run "set a(foo) hello; set a(bar) world; set a(foo)")
|
|
:result)
|
|
"hello")
|
|
(ok
|
|
"array-get-all"
|
|
(get
|
|
(run "set a(k) v; set pairs [array get a]; llength $pairs")
|
|
:result)
|
|
"2")
|
|
(dict
|
|
"passed"
|
|
tcl-eval-pass
|
|
"failed"
|
|
tcl-eval-fail
|
|
"failures"
|
|
tcl-eval-failures)))
|