diff options
Diffstat (limited to 'tests')
| -rw-r--r-- | tests/assemble.test | 655 | ||||
| -rw-r--r-- | tests/assemble1.bench | 113 | ||||
| -rw-r--r-- | tests/execute.test | 23 | ||||
| -rw-r--r-- | tests/stringComp.test | 320 |
4 files changed, 686 insertions, 425 deletions
diff --git a/tests/assemble.test b/tests/assemble.test index d0cbdaa..a2ce531 100644 --- a/tests/assemble.test +++ b/tests/assemble.test @@ -33,69 +33,118 @@ test assemble-1.4 {empty body} { -result {} } +test assemble-1.4.1 {unknown assembly instruction} { + -body { + list [catch { + tcl::unsupported::assemble { + push 2 + push 2 + rubbish + } + } result] $result $errorCode $errorInfo + } + -match glob + -result {1 {bad instruction "rubbish":*} {bad instruction "rubbish":* + while executing +"rubbish" + ("tcl::unsupported::assemble" body, line 4)*}} +} + test assemble-1.5 {Testing push and add} { - -body { tcl::unsupported::assemble {{push 2} {push 2} {add}} } + -body { tcl::unsupported::assemble { + push 2 + push 2 + add + } + } -result {4} } test assemble-1.6 {Testing push, dup, add} { - -body { tcl::unsupported::assemble {{push 2} {dup} {add}} } + -body { + tcl::unsupported::assemble { + push 2 + dup + add + } + } -result {4} } test assemble-1.6a {wrong # args} { -body { catch { - tcl::unsupported::assemble {{push 2 2} {dup} {add}} + tcl::unsupported::assemble { + push 2 2 + dup + add + } } set ::errorInfo } -match glob -result {wrong # args: should be "push value" - processing source instruction at list index 0 ("push 2 2")*} + while executing +"push 2 2" + ("tcl::unsupported::assemble" body, line 2)* + } } -test assemble-1.7 { Testing push, dup, mul, push, dup, mult, push, expon sequence } { - -body { tcl::unsupported::assemble {{push 3} dup mult {push 4} dup mult expon}} +test assemble-1.7 {longer sequence} { + -body { + tcl::unsupported::assemble { + push 3 + dup + mult + push 4 + dup + mult + expon + } + } -result {1853020188851841} } -test assemble-1.8 { Testing push, dup, mul, push, dup, mult, push, expon, pop sequence with unbalanced stack } {*}{ +test assemble-1.8 {unbalanced stack} { -body { list \ [catch { tcl::unsupported::assemble { - {push 3} + push 3 dup mult - {push 4} + push 4 dup mult pop - expon} + expon + } } result] $result $::errorInfo } -result {1 {stack underflow} {stack underflow - between source instruction at list index 0 ("push 3") - and end of assembly code*}} + in assembly code between lines 1 and end of assembly code*}} -match glob -returnCodes ok } + test assemble-1.8a {unbalanced stack} {*}{ -body { list \ [catch { tcl::unsupported::assemble { - {label a} - {pop} - {label b} - {pop} + label a + push {} + label b + pop + label c + pop + label d + push {} } } result] $result $::errorInfo } -result {1 {stack underflow} {stack underflow - between source instruction at list index 0 ("label a") - and source instruction at list index 2 ("label b")*}} + in assembly code between lines 6 and 8*}} -match glob -returnCodes ok } @@ -103,35 +152,46 @@ test assemble-1.8a {unbalanced stack} {*}{ # Tests for load and store test assemble-1.9 { Testing load within a proc } { - -body { proc x y { tcl::unsupported::assemble {{load y} dup mult }} + -body { + proc x y { + tcl::unsupported::assemble { + load y + dup + mult + } + } x 10 } -result {100} } -test assemble-1.10 { Testing store and load, saving the string "aString" to a variable and then - loading it from variable } { - -body { - proc x arg { - tcl::unsupported::assemble { - {push aString} {store arg} {pop} {load arg}} +test assemble-1.10 {store and load again} { + -body { + proc x arg { + tcl::unsupported::assemble { + push aString + store arg + pop + load arg } - x "not_aString" - } - -result {aString} + } + x "not_aString" } + -result {aString} +} -test assemble-1.11 { Testing storeArray and loadArray } { - -body { set anArray(1,2) "not_aString" +test assemble-1.11 {Testing storeArray and loadArray} { + -body { + set anArray(1,2) "not_aString" proc x arg { upvar $arg anArray tcl::unsupported::assemble { - {push 1,2} - {push aString} - {storeArray anArray} + push 1,2 + push aString + storeArray anArray pop - {push 1,2} - {loadArray anArray} + push 1,2 + loadArray anArray } } x anArray @@ -140,30 +200,51 @@ test assemble-1.11 { Testing storeArray and loadArray } { -result {aString} } -test assemble-1.12 { Testing loadStk with a variable } { - -body { set vara 10 - tcl::unsupported::assemble {{push vara} loadStk dup mult {push 4} dup mult add}} +test assemble-1.12 {Testing loadStk with a variable} { + -body { + set vara 10 + tcl::unsupported::assemble { + push vara + loadStk + dup + mult + push 4 + dup + mult + add + } + } -cleanup {unset vara} -result {116} } -test assemble-1.13 { Testing loadStk with an array variable } { - -body { set vararr(1,2) 10 - tcl::unsupported::assemble {{push vararr(1,2)} loadStk dup mult {push 4} dup mult add}} +test assemble-1.13 {Testing loadStk with an array variable} { + -body { + set vararr(1,2) 10 + tcl::unsupported::assemble { + push vararr(1,2) + loadStk + dup + mult + push 4 + dup + mult + add + } + } -cleanup {unset vararr} -result {116} } - -test assemble-1.14 { Testing loadStk and storeStk } { - -body { +test assemble-1.14 {Testing loadStk and storeStk} { + -body { set aVar 5 tcl::unsupported::assemble { - {push aVar} - {push aString} - {storeStk} + push aVar + push aString + storeStk pop - {push aVar} + push aVar loadStk } } @@ -171,17 +252,17 @@ test assemble-1.14 { Testing loadStk and storeStk } { -result {aString} } -test assemble-1.15 { Testing loadArrayStk and storeArrayStk } { +test assemble-1.15 {Testing loadArrayStk and storeArrayStk} { -body { set aVar(1,2) 5 tcl::unsupported::assemble { - {push aVar} - {push 1,2} - {push aString} - {storeArrayStk} + push aVar + push 1,2 + push aString + storeArrayStk pop - {push aVar} - {push 1,2} + push aVar + push 1,2 loadArrayStk } } @@ -192,81 +273,130 @@ test assemble-1.15 { Testing loadArrayStk and storeArrayStk } { # Tests for incr instructions test assemble-1.16 { Testing incr } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{push 5} {incr i}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + push 5 + incr i + } + } x 1 } -result {10} } test assemble-1.17 { Testing incrImm } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{incrImm i 5}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + incrImm i 5 + } + } x 1 } -result {10} } test assemble-1.18 { Testing incrStk } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{push i} {push 5} {incrStk}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + push i + push 5 + incrStk + } + } x 1 } -result {10} } test assemble-1.19 { Testing incrStkImm } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{push i} {incrStkImm 5}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + push i + incrStkImm 5 + } + } x 1 } -result {10} } test assemble-1.20 { Testing incrStkImm } { - -body { proc x arg { set i 5 - tcl::unsupported::assemble {{push i} {incrStkImm 5}} - } + -body { + proc x arg { + set i 5 + tcl::unsupported::assemble { + push i + incrStkImm 5 + } + } x 1 } -result {10} } test assemble-1.21 { Testing incrArray } { - -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble {{push 1,2} {push 5} {incrArray i}} - } + -body { + proc x arg { + set i(1,2) 5 + tcl::unsupported::assemble { + push 1,2 + push 5 + incrArray i + } + } x 1 } -result {10} } test assemble-1.22 { Testing incrArrayImm } { - -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble {{push 1,2} {incrArrayImm i 5}} - } + -body { + proc x arg { + set i(1,2) 5 + tcl::unsupported::assemble { + push 1,2 + incrArrayImm i 5 + } + } x 1 } -result {10} } test assemble-1.23 { Testing incrArrayStk } { - -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble {{push i} {push 1,2} {push 5} {incrArrayStk}} - } + -body { + proc x arg { + set i(1,2) 5 + tcl::unsupported::assemble { + push i + push 1,2 + push 5 + incrArrayStk + } + } x 1 } -result {10} } test assemble-1.24 { Testing incrArrayStkImm } { - -body { proc x arg { set i(1,2) 5 - tcl::unsupported::assemble {{push i} {push 1,2} {incrArrayStkImm 5}} - } + -body { + proc x arg { + set i(1,2) 5 + tcl::unsupported::assemble { + push i + push 1,2 + incrArrayStkImm 5 + } + } x 1 } -result {10} @@ -279,9 +409,24 @@ test assemble-1.24 { Testing incrArrayStkImm } { test assemble-1.25 { Testing label and jumpTrue } { -body { - proc x {arg1 arg2} { tcl::unsupported::assemble {{label a} {load arg2} - {push 2} {mult} {store arg2} pop {load arg1} {push 1} {sub} {store arg1} - {push 0} {neq} {jumpTrue a} {load arg2}}} + proc x {arg1 arg2} { + tcl::unsupported::assemble { + label a + load arg2 + push 2 + mult + store arg2 + pop + load arg1 + push 1 + sub + store arg1 + push 0 + neq + jumpTrue a + load arg2 + } + } x 4 2 } -result {32} @@ -289,39 +434,99 @@ test assemble-1.25 { Testing label and jumpTrue } { test assemble-1.26 { Testing label and jumpFalse } { -body { - proc x {arg1 arg2} { tcl::unsupported::assemble {{label a} {load arg2} - {push 2} {mult} {store arg2} pop {load arg1} {push 1} {sub} {store arg1} - {push 0} {eq} {jumpFalse a} {load arg2}}} + proc x {arg1 arg2} { + tcl::unsupported::assemble { + label a + load arg2 + push 2 + mult + store arg2 + pop + load arg1 + push 1 + sub + store arg1 + push 0 + eq + jumpFalse a + load arg2 + } + } x 4 2 } -result {32} } -test assemble-1.27 { Testing trampoline undefined label and jump } { +test assemble-1.27 {forward jumps} { -body { - proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} - {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} - {push aString} {store arg3} {label c} {load arg1} }} + proc x {arg1 arg2 arg3} { + tcl::unsupported::assemble { + jump a + push aString + store arg1 + pop + label a + jump b + push aString + store arg2 + label b + jump c + push aString + store arg3 + label c + load arg1 + } + } x 1 2 3 } -result {1} } -test assemble-1.28 { Testing trampoline undefined label and jump } { +test assemble-1.28 {forward jumps} { -body { - proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} - {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} - {push aString} {store arg3} {label c} {load arg2} }} + proc x {arg1 arg2 arg3} { + tcl::unsupported::assemble { + jump a + push aString + store arg1 + pop + label a + jump b + push aString + store arg2 + label b + jump c + push aString + store arg3 + label c + load arg2 + } + } x 1 2 3 } -result {2} } -test assemble-1.29 { Testing trampoline undefined label and jump } { +test assemble-1.29 {forward jumps} { -body { - proc x {arg1 arg2 arg3} { tcl::unsupported::assemble {{jump a} {push aString} - {store arg1} pop {label a} {jump b} {push aString} {store arg2} {label b} {jump c} - {push aString} {store arg3} {label c} {load arg3} }} + proc x {arg1 arg2 arg3} { + tcl::unsupported::assemble { + jump a + push aString + store arg1 + pop + label a + jump b + push aString + store arg2 + label b + jump c + push aString + store arg3 + label c + load arg3 + } + } x 1 2 3 } -result {3} @@ -331,14 +536,14 @@ test assemble-1.30 {Inconsistent stack usage} {*}{ -body { proc x {y} { tcl::unsupported::assemble { - {load y} - {jumpFalse else} - {push 0} - {jump then} - {label else} - {push 1} - {push 2} - {label then} + load y + jumpFalse else + push 0 + jump then + label else + push 1 + push 2 + label then pop } } @@ -347,67 +552,67 @@ test assemble-1.30 {Inconsistent stack usage} {*}{ } -match glob -result {inconsistent stack depths on two execution paths - to source instruction at list index 7 ("label then")*} + ("tcl::unsupported::assemble" body, line 9)*} } test assemble-1.31 {unset, exists, lappend - smoke test} { -body { proc x {y} { tcl::unsupported::assemble { - {exist result} - {store result} - {pop} - - {exist result} - {lappend result} - {pop} - - {push result} - {push y} - {existStk} - {lappendStk} - {pop} - - {push y} - {unsetStk true} - {exist y} - {lappend result} - {pop} - - {push {}} - {store foo} - {pop} - {exist foo} - {lappend result} - {pop} - - {unset true foo} - {exist foo} - {lappend result} - {pop} - - {push a} - {existArray z} - {lappend result} - {pop} - - {push a} - {push b} - {lappendArray z} - {lappend result} - {pop} - - {push z} - {push a} - {existArrayStk} - {lappend result} - {pop} - - {push z} - {push a} - {push c} - {lappendArrayStk} - {lappend result} + exist result + store result + pop + + exist result + lappend result + pop + + push result + push y + existStk + lappendStk + pop + + push y + unsetStk true + exist y + lappend result + pop + + push {} + store foo + pop + exist foo + lappend result + pop + + unset true foo + exist foo + lappend result + pop + + push a + existArray z + lappend result + pop + + push a + push b + lappendArray z + lappend result + pop + + push z + push a + existArrayStk + lappend result + pop + + push z + push a + push c + lappendArrayStk + lappend result } } @@ -419,10 +624,10 @@ test assemble-1.31 {unset, exists, lappend - smoke test} { test assemble-2.1 {concat} { -body { ::tcl::unsupported::assemble { - {push a} - {push b} - {push c} - {concat 3} + push a + push b + push c + concat 3 } } -result abc @@ -431,8 +636,8 @@ test assemble-2.1 {concat} { test assemble-3.1 {expr} { -body { ::tcl::unsupported::assemble { - {push {1+2+3+4+5}} - {exprStk} + push {1+2+3+4+5} + exprStk } } -result 15 @@ -440,72 +645,89 @@ test assemble-3.1 {expr} { test assemble-4.1 {eval} { -body { ::tcl::unsupported::assemble { - {push {join [list [expr {1+2+3+4+5}] a] {}}} - {evalStk} + push {join [list [expr {1+2+3+4+5}] a] {}} + evalStk } } -result 15a } -set ::tcl_traceCompile 2 test assemble-4.2 {eval} { -body { proc x {} { ::tcl::unsupported::assemble { - {push 3} - {store n} + push 3 + store n pop - {eval {expr {3*$n + 1}}} + eval {expr {3*$n + 1}} + push 1 + add } } x } - -result 10 + -result 11 } -set ::tcl_traceCompile 0 +test assemble-4.3 {expr} { + -body { + proc x {} { + ::tcl::unsupported::assemble { + push 3 + store n + pop + expr {3*$n + 1} + push 1 + add + } + } + x + } + -result 11 +} + test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} { -body { - regsub -all {\#[^\n]*} { - {load n} # max - {dup} # max n - {jump start} # max n + proc ulam {n} { + tcl::unsupported::assemble { + load n; # max + dup; # max n + jump start; # max n - {label loop} # max n - {over 1} # max n max - {over 1} # max n max n - {ge} # man n max>=n - {jumpTrue skip} # max n - - {reverse 2} # n max - {pop} # n - {dup} # n n + label loop; # max n + over 1; # max n max + over 1; # max in max n + ge; # man n max>=n + jumpTrue skip; # max n + + reverse 2; # n max + pop; # n + dup; # n n - {label skip} # max n - {dup} # max n n - {push 2} # max n n 2 - {mod} # max n n%2 - {jumpTrue odd} # max n + label skip; # max n + dup; # max n n + push 2; # max n n 2 + mod; # max n n%2 + jumpTrue odd; # max n - {push 2} # max n 2 - {div} # max n/2 -> max n - {jump start} # max n + push 2; # max n 2 + div; # max n/2 -> max n + jump start; # max n - {label odd} # max n - {push 3} # max n 3 - {mult} # max 3*n - {push 1} # max 3*n 1 - {add} # max 3*n+1 + label odd; # max n + push 3; # max n 3 + mult; # max 3*n + push 1; # max 3*n 1 + add; # max 3*n+1 - {label start} # max n - {dup} # max n n - {push 1} # max n n 1 - {neq} # max n n>1 - {jumpTrue loop} # max n + label start; # max n + dup; # max n n + push 1; # max n n 1 + neq; # max n n>1 + jumpTrue loop; # max n - {pop} # max - - } {} code - proc ulam n [list tcl::unsupported::assemble $code] + pop; # max + } + } set result {} for {set i 1} {$i < 30} {incr i} { lappend result [ulam $i] @@ -513,4 +735,11 @@ test assemble-30.1 {Ulam's 3n+1 problem, TAL implementation} { set result } -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88} -}
\ No newline at end of file +} + +::tcltest::cleanupTests +return + +# Local Variables: +# mode: tcl +# End:
\ No newline at end of file diff --git a/tests/assemble1.bench b/tests/assemble1.bench index 4f4dbce..18fd3a9 100644 --- a/tests/assemble1.bench +++ b/tests/assemble1.bench @@ -12,49 +12,74 @@ proc ulam1 {n} { } return $max } -set i 0 -puts [time {ulam1 [incr i]} 10000] -regsub -all {\#[^\n]*} { - {load n} # max - {dup} # max n - {jump start} # max n - - {label loop} # max n - {over 1} # max n max - {over 1} # max n max n - {ge} # man n max>=n - {jumpTrue skip} # max n - - {reverse 2} # n max - {pop} # n - {dup} # n n - - {label skip} # max n - {dup} # max n n - {push 2} # max n n 2 - {mod} # max n n%2 - {jumpTrue odd} # max n - - {push 2} # max n 2 - {div} # max n/2 -> max n - {jump start} # max n - - {label odd} # max n - {push 3} # max n 3 - {mult} # max 3*n - {push 1} # max 3*n 1 - {add} # max 3*n+1 - - {label start} # max n - {dup} # max n n - {push 1} # max n n 1 - {neq} # max n n>1 - {jumpTrue loop} # max n - - {pop} # max +set tcl_traceCompile 2; ulam1 1; set tcl_traceCompile 0 + +proc ulam2 {n} { + tcl::unsupported::assemble { + load n; # max + dup; # max n + jump start; # max n + + label loop; # max n + over 1; # max n max + over 1; # max in max n + ge; # man n max>=n + jumpTrue skip; # max n + + reverse 2; # n max + pop; # n + dup; # n n + + label skip; # max n + dup; # max n n + push 2; # max n n 2 + mod; # max n n%2 + jumpTrue odd; # max n + + push 2; # max n 2 + div; # max n/2 -> max n + jump start; # max n + + label odd; # max n + push 3; # max n 3 + mult; # max 3*n + push 1; # max 3*n 1 + add; # max 3*n+1 + + label start; # max n + dup; # max n n + push 1; # max n n 1 + neq; # max n n>1 + jumpTrue loop; # max n + + pop; # max + } +} +set tcl_traceCompile 2; ulam2 1; set tcl_traceCompile 0 + +proc test1 {n} { + for {set i 1} {$i <= $n} {incr i} { + ulam1 $i + } +} +proc test2 {n} { + for {set i 1} {$i <= $n} {incr i} { + ulam2 $i + } +} + +for {set j 0} {$j < 10} {incr j} { + test1 1 + set before [clock microseconds] + test1 30000 + set after [clock microseconds] + puts "compiled: [expr {1e-6 * ($after - $before)}]" -} {} code -proc ulam2 n [list tcl::unsupported::assemble $code] -set i 0 -puts [time {ulam2 [incr i]} 10000] + test2 1 + set before [clock microseconds] + test2 30000 + set after [clock microseconds] + puts "assembled: [expr {1e-6 * ($after - $before)}]" +} +
\ No newline at end of file diff --git a/tests/execute.test b/tests/execute.test index ce21040..4519890 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -14,7 +14,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: execute.test,v 1.35 2010/04/05 19:44:45 ferrieux Exp $ +# RCS: @(#) $Id: execute.test,v 1.35.2.1 2010/09/25 14:51:13 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 @@ -993,6 +993,27 @@ test execute-10.2 {Bug 2802881} -setup { interp delete slave } -returnCodes error -match glob -result * +test execute-10.3 {Bug 3072640} -setup { + proc generate {n} { + for {set i 0} {$i < $n} {incr i} { + yield $i + } + } + proc t {args} { + incr ::foo + } + trace add execution ::generate enterstep ::t +} -body { + coroutine coro generate 5 + trace remove execution ::generate enterstep ::t + set ::foo +} -cleanup { + unset ::foo + rename generate {} + rename t {} + rename coro {} +} -result 4 + # cleanup if {[info commands testobj] != {}} { testobj freeallvars diff --git a/tests/stringComp.test b/tests/stringComp.test index 2f187be..35c11d1 100644 --- a/tests/stringComp.test +++ b/tests/stringComp.test @@ -15,7 +15,7 @@ # See the file "license.terms" for information on usage and redistribution # of this file, and for a DISCLAIMER OF ALL WARRANTIES. # -# RCS: @(#) $Id: stringComp.test,v 1.17 2009/06/24 15:17:41 dgp Exp $ +# RCS: @(#) $Id: stringComp.test,v 1.17.4.1 2010/09/25 14:51:13 kennykb Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest @@ -44,180 +44,166 @@ test stringComp-1.3 {error condition - undefined method during compile} { foo abc 0 } a -test stringComp-2.1 {string compare, too few args} { - proc foo {} {string compare a} - list [catch {foo} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.2 {string compare, bad args} { - proc foo {} {string compare a b c} - list [catch {foo} msg] $msg -} {1 {bad option "a": must be -nocase or -length}} -test stringComp-2.3 {string compare, bad args} { - list [catch {string compare -length -nocase str1 str2} msg] $msg -} {1 {expected integer but got "-nocase"}} -test stringComp-2.4 {string compare, too many args} { - list [catch {string compare -length 10 -nocase str1 str2 str3} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.5 {string compare with length unspecified} { - list [catch {string compare -length 10 10} msg] $msg -} {1 {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"}} -test stringComp-2.6 {string compare} { - proc foo {} {string compare abcde abdef} - foo -} -1 -test stringComp-2.7 {string compare, shortest method name} { - proc foo {} {string c abcde ABCDE} - foo -} 1 -test stringComp-2.8 {string compare} { - proc foo {} {string compare abcde abcde} - foo -} 0 -test stringComp-2.9 {string compare with length} { - proc foo {} {string compare -length 2 abcde abxyz} - foo -} 0 -test stringComp-2.10 {string compare with special index} { - proc foo {} {string compare -length end-3 abcde abxyz} - list [catch {foo} msg] $msg -} {1 {expected integer but got "end-3"}} -test stringComp-2.11 {string compare, unicode} { - proc foo {} {string compare ab\u7266 ab\u7267} - foo -} -1 -test stringComp-2.12 {string compare, high bit} { - # This test will fail if the underlying comparaison - # is using signed chars instead of unsigned chars. - # (like SunOS's default memcmp thus the compat/memcmp.c) - proc foo {} {string compare "\x80" "@"} - foo - # Nb this tests works also in utf8 space because \x80 is - # translated into a 2 or more bytelength but whose first byte has - # the high bit set. -} 1 -test stringComp-2.13 {string compare -nocase} { - proc foo {} {string compare -nocase abcde abdef} - foo -} -1 -test stringComp-2.14 {string compare -nocase} { - proc foo {} {string c -nocase abcde ABCDE} - foo -} 0 -test stringComp-2.15 {string compare -nocase} { - proc foo {} {string compare -nocase abcde abcde} - foo -} 0 -test stringComp-2.16 {string compare -nocase with length} { - proc foo {} {string compare -length 2 -nocase abcde Abxyz} - foo -} 0 -test stringComp-2.17 {string compare -nocase with length} { - proc foo {} {string compare -nocase -length 3 abcde Abxyz} - foo -} -1 -test stringComp-2.18 {string compare -nocase with length <= 0} { - proc foo {} {string compare -nocase -length -1 abcde AbCdEf} - foo -} -1 -test stringComp-2.19 {string compare -nocase with excessive length} { - proc foo {} {string compare -nocase -length 50 AbCdEf abcde} - foo -} 1 -test stringComp-2.20 {string compare -len unicode} { - # These are strings that are 6 BYTELENGTH long, but the length - # shouldn't make a different because there are actually 3 CHARS long - proc foo {} {string compare -len 5 \334\334\334 \334\334\374} - foo -} -1 -test stringComp-2.21 {string compare -nocase with special index} { - proc foo {} {string compare -nocase -length end-3 Abcde abxyz} - list [catch {foo} msg] $msg -} {1 {expected integer but got "end-3"}} -test stringComp-2.22 {string compare, null strings} { - proc foo {} {string compare "" ""} - foo -} 0 -test stringComp-2.23 {string compare, null strings} { - proc foo {} {string compare "" foo} - foo -} -1 -test stringComp-2.24 {string compare, null strings} { - proc foo {} {string compare foo ""} - foo -} 1 -test stringComp-2.25 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase "" ""} - foo -} 0 -test stringComp-2.26 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase "" foo} - foo -} -1 -test stringComp-2.27 {string compare -nocase, null strings} { - proc foo {} {string compare -nocase foo ""} - foo -} 1 -test stringComp-2.28 {string compare with length, unequal strings} { - proc foo {} {string compare -length 2 abc abde} - foo -} 0 -test stringComp-2.29 {string compare with length, unequal strings} { - proc foo {} {string compare -length 2 ab abde} - foo -} 0 -test stringComp-2.30 {string compare with NUL character vs. other ASCII} { - # Be careful here, since UTF-8 rep comparison with memcmp() of - # these puts chars in the wrong order - proc foo {} {string compare \x00 \x01} - foo -} -1 -test stringComp-2.31 {string compare, high bit} { - proc foo {} {string compare "a\x80" "a@"} - foo -} 1 -test stringComp-2.32 {string compare, high bit} { - proc foo {} {string compare "a\x00" "a\x01"} - foo -} -1 -test stringComp-2.33 {string compare, high bit} { - proc foo {} {string compare "\x00\x00" "\x00\x01"} - foo -} -1 +## Test string compare|equal over equal constraints +## Use result for string compare, and negate it for string equal +## The body will be tested both in and outside a proc +set i 0 +foreach {tname tbody tresult tcode} { + {too few args} { + string compare a + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {bad args} { + string compare a b c + } {bad option "a": must be -nocase or -length} {error} + {bad args} { + string compare -length -nocase str1 str2 + } {expected integer but got "-nocase"} {error} + {too many args} { + string compare -length 10 -nocase str1 str2 str3 + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {compare with length unspecified} { + string compare -length 10 10 + } {wrong # args: should be "string compare ?-nocase? ?-length int? string1 string2"} {error} + {basic operation fail} { + string compare abcde abdef + } {-1} {} + {basic operation success} { + string compare abcde abcde + } {0} {} + {with length} { + string compare -length 2 abcde abxyz + } {0} {} + {with special index} { + string compare -length end-3 abcde abxyz + } {expected integer but got "end-3"} {error} + {unicode} { + string compare ab\u7266 ab\u7267 + } {-1} {} + {unicode} {string compare \334 \u00dc} 0 {} + {unicode} {string compare \334 \u00fc} -1 {} + {unicode} {string compare \334\334\334\374\374 \334\334\334\334\334} 1 {} + {high bit} { + # This test will fail if the underlying comparaison + # is using signed chars instead of unsigned chars. + # (like SunOS's default memcmp thus the compat/memcmp.c) + string compare "\x80" "@" + # Nb this tests works also in utf8 space because \x80 is + # translated into a 2 or more bytelength but whose first byte has + # the high bit set. + } {1} {} + {-nocase 1} {string compare -nocase abcde abdef} {-1} {} + {-nocase 2} {string compare -nocase abcde Abdef} {-1} {} + {-nocase 3} {string compare -nocase abcde ABCDE} {0} {} + {-nocase 4} {string compare -nocase abcde abcde} {0} {} + {-nocase unicode} { + string compare -nocase \334 \u00dc + } 0 {} + {-nocase unicode} { + string compare -nocase \334\334\334\374\u00fc \334\334\334\334\334 + } 0 {} + {-nocase with length} { + string compare -length 2 -nocase abcde Abxyz + } {0} {} + {-nocase with length} { + string compare -nocase -length 3 abcde Abxyz + } {-1} {} + {-nocase with length <= 0} { + string compare -nocase -length -1 abcde AbCdEf + } {-1} {} + {-nocase with excessive length} { + string compare -nocase -length 50 AbCdEf abcde + } {1} {} + {-len unicode} { + # These are strings that are 6 BYTELENGTH long, but the length + # shouldn't make a different because there are actually 3 CHARS long + string compare -len 5 \334\334\334 \334\334\374 + } -1 {} + {-nocase with special index} { + string compare -nocase -length end-3 Abcde abxyz + } {expected integer but got "end-3"} error + {null strings} { + string compare "" "" + } 0 {} + {null strings} { + string compare "" foo + } -1 {} + {null strings} { + string compare foo "" + } 1 {} + {-nocase null strings} { + string compare -nocase "" "" + } 0 {} + {-nocase null strings} { + string compare -nocase "" foo + } -1 {} + {-nocase null strings} { + string compare -nocase foo "" + } 1 {} + {with length, unequal strings} { + string compare -length 2 abc abde + } 0 {} + {with length, unequal strings} { + string compare -length 2 ab abde + } 0 {} + {with NUL character vs. other ASCII} { + # Be careful here, since UTF-8 rep comparison with memcmp() of + # these puts chars in the wrong order + string compare \x00 \x01 + } -1 {} + {high bit} { + string compare "a\x80" "a@" + } 1 {} + {high bit} { + string compare "a\x00" "a\x01" + } -1 {} + {high bit} { + string compare "\x00\x00" "\x00\x01" + } -1 {} + {binary equal} { + string compare [binary format a100 0] [binary format a100 0] + } 0 {} + {binary neq} { + string compare [binary format a100a 0 1] [binary format a100a 0 0] + } 1 {} + {binary neq inequal length} { + string compare [binary format a20a 0 1] [binary format a100a 0 0] + } 1 {} +} { + if {$tname eq ""} { continue } + if {$tcode eq ""} { set tcode ok } + test stringComp-2.[incr i] "string compare, $tname" \ + -body [list eval $tbody] \ + -returnCodes $tcode -result $tresult + test stringComp-2.[incr i] "string compare bc, $tname" \ + -body "[list proc foo {} $tbody];foo" \ + -returnCodes $tcode -result $tresult + if {"error" ni $tcode} { + set tresult [expr {!$tresult}] + } else { + set tresult [string map {compare equal} $tresult] + } + set tbody [string map {compare equal} $tbody] + test stringComp-2.[incr i] "string equal, $tname" \ + -body [list eval $tbody] \ + -returnCodes $tcode -result $tresult + test stringComp-2.[incr i] "string equal bc, $tname" \ + -body "[list proc foo {} $tbody];foo" \ + -returnCodes $tcode -result $tresult +} -# only need a few tests on equal, since it uses the same code as -# string compare, but just modifies the return output -test stringComp-3.1 {string equal} { - proc foo {} {string equal abcde abdef} - foo -} 0 -test stringComp-3.2 {string equal} { - proc foo {} {string eq abcde ABCDE} - foo -} 0 -test stringComp-3.3 {string equal} { - proc foo {} {string equal abcde abcde} - foo -} 1 -test stringComp-3.4 {string equal -nocase} { - proc foo {} {string equal -nocase \334\334\334\334\374\374\374\374 \334\334\334\334\334\334\334\334} +# need a few extra tests short abbr cmd +test stringComp-3.1 {string compare, shortest method name} { + proc foo {} {string c abcde ABCDE} foo } 1 -test stringComp-3.5 {string equal -nocase} { - proc foo {} {string equal -nocase abcde abdef} +test stringComp-3.2 {string equal, shortest method name} { + proc foo {} {string e abcde ABCDE} foo } 0 -test stringComp-3.6 {string equal -nocase} { +test stringComp-3.3 {string equal -nocase} { proc foo {} {string eq -nocase abcde ABCDE} foo } 1 -test stringComp-3.7 {string equal -nocase} { - proc foo {} {string equal -nocase abcde abcde} - foo -} 1 -test stringComp-3.8 {string equal with length, unequal strings} { - proc foo {} {string equal -length 2 abc abde} - foo -} 1 test stringComp-4.1 {string first, too few args} { proc foo {} {string first a} |