diff options
Diffstat (limited to 'tests/execute.test')
| -rw-r--r-- | tests/execute.test | 448 |
1 files changed, 415 insertions, 33 deletions
diff --git a/tests/execute.test b/tests/execute.test index e82ac57..b460cfe 100644 --- a/tests/execute.test +++ b/tests/execute.test @@ -13,25 +13,26 @@ # # 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.9 2001/02/23 21:41:01 msofer Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { - package require tcltest + package require tcltest 2 namespace import -force ::tcltest::* } -catch {eval namespace delete [namespace children :: test_ns_*]} +catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} catch {unset x} catch {unset y} catch {unset msg} -set ::tcltest::testConstraints(testobj) \ - [expr {[info commands testobj] != {} \ - && [info commands testdoubleobj] != {} \ - && [info commands teststringobj] != {} \ - && [info commands testobj] != {}}] +testConstraint testobj [expr { + [llength [info commands testobj]] + && [llength [info commands testdoubleobj]] + && [llength [info commands teststringobj]] +}] + +testConstraint longIs32bit [expr {int(0x80000000) < 0}] +testConstraint testexprlongobj [llength [info commands testexprlongobj]] # Tests for the omnibus TclExecuteByteCode function: @@ -504,7 +505,7 @@ test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeri # INST_PUSH_RETURN_CODE not tested test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {unset x} catch {unset y} namespace eval test_ns_1 { @@ -522,7 +523,7 @@ test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { [catch {namespace which -command ${x}${y}:cmd2} msg] $msg } {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} catch {unset l} proc foo {} { @@ -544,7 +545,7 @@ test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval set l } {::foo ::test_ns_1::foo} test execute-4.3 {Tcl_GetCommandFromObj, command never found} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} namespace eval test_ns_1 { proc foo {} { @@ -562,7 +563,7 @@ test execute-4.3 {Tcl_GetCommandFromObj, command never found} { } {::test_ns_1::foo {} 0 {}} test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { - catch {eval namespace delete [namespace children :: test_ns_*]} + catch {namespace delete {*}[namespace children :: test_ns_*]} catch {unset l} proc {} {} {return {}} {} @@ -582,15 +583,411 @@ test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName o } p } {} - test execute-6.2 {Evaluate an expression in a variable; compile the first time, do not the second} { set w {3*5} proc a {obj} {expr $obj} set res "[a $w]:[a $w]" } {15:15} +test execute-6.3 {Tcl_ExprObj: don't use cached script bytecode [Bug 1899164]} -setup { + proc 0+0 {} {return SCRIPT} +} -body { + set e { 0+0 } + if 1 $e + if 1 {expr $e} +} -cleanup { + rename 0+0 {} +} -result 0 +test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]} -setup { + proc 0+0 {} {return SCRIPT} +} -body { + set e { 0+0 } + if 1 {expr $e} + if 1 $e +} -cleanup { + rename 0+0 {} +} -result SCRIPT +test execute-6.5 {TclCompEvalObj: bytecode epoch validation} { + set script { llength {} } + set result {} + lappend result [if 1 $script] + set origName [namespace which llength] + rename $origName llength.orig + proc $origName {args} {return AHA!} + lappend result [if 1 $script] + rename $origName {} + rename llength.orig $origName + set result +} {0 AHA!} +test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} { + proc foo {} {set a 1} + set a untouched + set result {} + lappend result [foo] $a + lappend result [if 1 [info body foo]] $a + rename foo {} + set result +} {1 untouched 1 1} +test execute-6.7 {TclCompEvalObj: bytecode context validation} { + set script { llength {} } + namespace eval foo { + proc llength {args} {return AHA!} + } + set result {} + lappend result [if 1 $script] + lappend result [namespace eval foo $script] + namespace delete foo + set result +} {0 AHA!} +test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} { + set script { llength {} } + set result {} + lappend result [namespace eval foo $script] + namespace eval foo { + proc llength {args} {return AHA!} + } + lappend result [namespace eval foo $script] + namespace delete foo + set result +} {0 AHA!} +test execute-6.9 {TclCompEvalObj: bytecode interp validation} { + set script { llength {} } + interp create slave + slave eval {proc llength args {return AHA!}} + set result {} + lappend result [if 1 $script] + lappend result [slave eval $script] + interp delete slave + set result +} {0 AHA!} +test execute-6.10 {TclCompEvalObj: bytecode interp validation} { + set script { llength {} } + interp create slave + set result {} + lappend result [slave eval $script] + interp delete slave + interp create slave + lappend result [slave eval $script] + interp delete slave + set result +} {0 0} +test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj { + set e { [llength {}]+1 } + set result {} + interp create slave + load {} Tcltest slave + interp alias {} e slave testexprlongobj + lappend result [e $e] + interp delete slave + interp create slave + load {} Tcltest slave + interp alias {} e slave testexprlongobj + lappend result [e $e] + interp delete slave + set result +} {{This is a result: 1} {This is a result: 1}} +test execute-6.12 {Tcl_ExprObj: exprcode interp validation} { + set e { [llength {}]+1 } + set result {} + interp create slave + interp alias {} e slave expr + lappend result [e $e] + interp delete slave + interp create slave + interp alias {} e slave expr + lappend result [e $e] + interp delete slave + set result +} {1 1} +test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} { + set e { [llength {}]+1 } + set result {} + lappend result [expr $e] + set origName [namespace which llength] + rename $origName llength.orig + proc $origName {args} {return 1} + lappend result [expr $e] + rename $origName {} + rename llength.orig $origName + set result +} {1 2} +test execute-6.14 {Tcl_ExprObj: exprcode context validation} { + set e { [llength {}]+1 } + namespace eval foo { + proc llength {args} {return 1} + } + set result {} + lappend result [expr $e] + lappend result [namespace eval foo {expr $e}] + namespace delete foo + set result +} {1 2} +test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} { + set e { [llength {}]+1 } + set result {} + lappend result [namespace eval foo {expr $e}] + namespace eval foo { + proc llength {args} {return 1} + } + lappend result [namespace eval foo {expr $e}] + namespace delete foo + set result +} {1 2} +test execute-6.16 {Tcl_ExprObj: exprcode interp validation} { + set e { [llength {}]+1 } + interp create slave + interp alias {} e slave expr + slave eval {proc llength args {return 1}} + set result {} + lappend result [expr $e] + lappend result [e $e] + interp delete slave + set result +} {1 2} +test execute-6.17 {Tcl_ExprObj: exprcode context validation} { + set e { $v } + proc foo e {set v 0; expr $e} + proc bar e {set v 1; expr $e} + set result {} + lappend result [foo $e] + lappend result [bar $e] + rename foo {} + rename bar {} + set result +} {0 1} +test execute-6.18 {Tcl_ExprObj: exprcode context validation} { + set e { [llength $v] } + proc foo e {set v {}; expr $e} + proc bar e {set v v; expr $e} + set result {} + lappend result [foo $e] + lappend result [bar $e] + rename foo {} + rename bar {} + set result +} {0 1} + +test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} { + set x 0x100000000 + expr {$x && 1} +} 1 +test execute-7.1 {Wide int handling in INST_JUMP_FALSE/LAND} { + expr {0x100000000 && 1} +} 1 +test execute-7.2 {Wide int handling in INST_JUMP_FALSE/LAND} { + expr {1 && 0x100000000} +} 1 +test execute-7.3 {Wide int handling in INST_JUMP_FALSE/LAND} { + expr {wide(0x100000000) && 1} +} 1 +test execute-7.4 {Wide int handling in INST_JUMP_FALSE/LAND} { + expr {1 && wide(0x100000000)} +} 1 +test execute-7.5 {Wide int handling in INST_EQ} { + expr {4 == (wide(1)+wide(3))} +} 1 +test execute-7.6 {Wide int handling in INST_EQ and [incr]} { + set x 399999999999 + expr {400000000000 == [incr x]} +} 1 +# wide ints have more bits of precision than doubles, but we convert anyway +test execute-7.7 {Wide int handling in INST_EQ and [incr]} { + set x [expr {wide(1)<<62}] + set y [expr {$x+1}] + expr {double($x) == double($y)} +} 1 +test execute-7.8 {Wide int conversions can change sign} longIs32bit { + set x 0x80000000 + expr {int($x) < wide($x)} +} 1 +test execute-7.9 {Wide int handling in INST_MOD} { + expr {(wide(1)<<60) % ((wide(47)<<45)-1)} +} 316659348800185 +test execute-7.10 {Wide int handling in INST_MOD} { + expr {((wide(1)<<60)-1) % 0x400000000} +} 17179869183 +test execute-7.11 {Wide int handling in INST_LSHIFT} { + expr wide(42)<<30 +} 45097156608 +test execute-7.12 {Wide int handling in INST_LSHIFT} { + expr 12345678901<<3 +} 98765431208 +test execute-7.13 {Wide int handling in INST_RSHIFT} { + expr 0x543210febcda9876>>7 +} 47397893236700464 +test execute-7.14 {Wide int handling in INST_RSHIFT} { + expr wide(0x9876543210febcda)>>7 +} -58286587177206407 +test execute-7.15 {Wide int handling in INST_BITOR} { + expr wide(0x9876543210febcda) | 0x543210febcda9876 +} -2560765885044310786 +test execute-7.16 {Wide int handling in INST_BITXOR} { + expr wide(0x9876543210febcda) ^ 0x543210febcda9876 +} -3727778945703861076 +test execute-7.17 {Wide int handling in INST_BITAND} { + expr wide(0x9876543210febcda) & 0x543210febcda9876 +} 1167013060659550290 +test execute-7.18 {Wide int handling in INST_ADD} { + expr wide(0x7fffffff)+wide(0x7fffffff) +} 4294967294 +test execute-7.19 {Wide int handling in INST_ADD} { + expr 0x7fffffff+wide(0x7fffffff) +} 4294967294 +test execute-7.20 {Wide int handling in INST_ADD} { + expr wide(0x7fffffff)+0x7fffffff +} 4294967294 +test execute-7.21 {Wide int handling in INST_ADD} { + expr double(0x7fffffff)+wide(0x7fffffff) +} 4294967294.0 +test execute-7.22 {Wide int handling in INST_ADD} { + expr wide(0x7fffffff)+double(0x7fffffff) +} 4294967294.0 +test execute-7.23 {Wide int handling in INST_SUB} { + expr 0x123456789a-0x20406080a +} 69530054800 +test execute-7.24 {Wide int handling in INST_MULT} { + expr 0x123456789a*193 +} 15090186251290 +test execute-7.25 {Wide int handling in INST_DIV} { + expr 0x123456789a/193 +} 405116546 +test execute-7.26 {Wide int handling in INST_UPLUS} { + set x 0x123456871234568 + expr {+ $x} +} 81985533099853160 +test execute-7.27 {Wide int handling in INST_UMINUS} { + set x 0x123456871234568 + expr {- $x} +} -81985533099853160 +test execute-7.28 {Wide int handling in INST_LNOT} { + set x 0x123456871234568 + expr {! $x} +} 0 +test execute-7.29 {Wide int handling in INST_BITNOT} { + set x 0x123456871234568 + expr {~ $x} +} -81985533099853161 +test execute-7.30 {Wide int handling in function call} { + set x 0x12345687123456 + incr x + expr {log($x) == log(double($x))} +} 1 +test execute-7.31 {Wide int handling in abs()} { + set x 0xa23456871234568 + incr x + set y 0x123456871234568 + concat [expr {abs($x)}] [expr {abs($y)}] +} {730503879441204585 81985533099853160} +test execute-7.32 {Wide int handling} longIs32bit { + expr {int(1024 * 1024 * 1024 * 1024)} +} 0 +test execute-7.33 {Wide int handling} longIs32bit { + expr {int(0x1 * 1024 * 1024 * 1024 * 1024)} +} 0 +test execute-7.34 {Wide int handling} { + expr {wide(0x1) * 1024 * 1024 * 1024 * 1024} +} 1099511627776 + +test execute-8.1 {Stack protection} -setup { + # If [Bug #804681] has not been properly + # taken care of, this should segfault + proc whatever args {llength $args} + trace add variable ::errorInfo {write unset} whatever +} -body { + expr {1+9/0} +} -cleanup { + trace remove variable ::errorInfo {write unset} whatever + rename whatever {} +} -returnCodes error -match glob -result * + +test execute-8.2 {Stack restoration} -body { + # Test for [Bug #816641], correct restoration + # of the stack top after the stack is grown + proc f {args} { f bee bop } + catch f msg + set msg + } -setup { + # Avoid crashes when system stack size is limited (thread-enabled!) + set limit [interp recursionlimit {}] + interp recursionlimit {} 100 + } -cleanup { + interp recursionlimit {} $limit + } -result {too many nested evaluations (infinite loop?)} + +test execute-8.3 {Stack restoration} -body { + # Test for [Bug #1055676], correct restoration + # of the stack top after the epoch is bumped and + # the stack is grown in a call from a nested evaluation + set arglst [string repeat "a " 1000] + proc f {args} "f $arglst" + proc run {} { + # bump the interp's epoch + rename ::set ::dummy + rename ::dummy ::set + catch f msg + set msg + } + run + } -setup { + # Avoid crashes when system stack size is limited (thread-enabled!) + set limit [interp recursionlimit {}] + interp recursionlimit {} 100 + } -cleanup { + interp recursionlimit {} $limit + } -result {too many nested evaluations (infinite loop?)} + +test execute-8.4 {Compile epoch bump effect on stack trace} -setup { + proc foo {} { + error bar + } + proc FOO {} { + catch {error bar} m o + rename ::set ::dummy + rename ::dummy ::set + return -options $o $m + } +} -body { + catch foo m o + set stack1 [dict get $o -errorinfo] + catch FOO m o + set stack2 [string map {FOO foo} [dict get $o -errorinfo]] + expr {$stack1 eq $stack2 ? {} : "These differ:\n$stack1\n$stack2"} +} -cleanup { + rename foo {} + rename FOO {} +} -result {} + +test execute-9.1 {Interp result resetting [Bug 1522803]} { + set c 0 + catch { + catch {set foo} + expr {1/$c} + } + if {[string match *foo* $::errorInfo]} { + set result "Bad errorInfo: $::errorInfo" + } else { + set result SUCCESS + } + set result +} SUCCESS + +test execute-10.2 {Bug 2802881} -setup { + interp create slave +} -body { + # If [Bug 2802881] is not fixed, this will segfault + slave eval { + trace add variable ::errorInfo write {expr {$foo} ;#} + proc demo {} {a {}{}} + demo + } +} -cleanup { + interp delete slave +} -returnCodes error -match glob -result * # cleanup -catch {eval namespace delete [namespace children :: test_ns_*]} +if {[info commands testobj] != {}} { + testobj freeallvars +} +catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} catch {rename p ""} catch {rename {} ""} @@ -601,21 +998,6 @@ catch {unset msg} ::tcltest::cleanupTests return - - - - - - - - - - - - - - - - - - +# Local Variables: +# mode: tcl +# End: |