summaryrefslogtreecommitdiffstats
path: root/tests/execute.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/execute.test')
-rw-r--r--tests/execute.test572
1 files changed, 187 insertions, 385 deletions
diff --git a/tests/execute.test b/tests/execute.test
index 8702de6..b460cfe 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -1,27 +1,24 @@
-# This file contains tests for the tclExecute.c source file. Tests appear in
-# the same order as the C code that they test. The set of tests is currently
-# incomplete since it currently includes only new tests for code changed for
-# the addition of Tcl namespaces. Other execution-related tests appear in
-# several other test files including namespace.test, basic.test, eval.test,
-# for.test, etc.
+# This file contains tests for the tclExecute.c source file. Tests appear
+# in the same order as the C code that they test. The set of tests is
+# currently incomplete since it currently includes only new tests for
+# code changed for the addition of Tcl namespaces. Other execution-
+# related tests appear in several other test files including
+# namespace.test, basic.test, eval.test, for.test, etc.
#
-# Sourcing this file into Tcl runs the tests and generates output for errors.
-# No output means no errors were found.
+# Sourcing this file into Tcl runs the tests and generates output for
+# errors. No output means no errors were found.
#
-# Copyright © 1997 Sun Microsystems, Inc.
-# Copyright © 1998-1999 Scriptics Corporation.
+# Copyright (c) 1997 Sun Microsystems, Inc.
+# Copyright (c) 1998-1999 by Scriptics Corporation.
#
-# See the file "license.terms" for information on usage and redistribution of
-# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+# See the file "license.terms" for information on usage and redistribution
+# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {"::tcltest" ni [namespace children]} {
- package require tcltest 2.5
+if {[lsearch [namespace children] ::tcltest] == -1} {
+ package require tcltest 2
namespace import -force ::tcltest::*
}
-::tcltest::loadTestedCommands
-catch [list package require -exact tcl::test [info patchlevel]]
-
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
@@ -34,13 +31,8 @@ testConstraint testobj [expr {
&& [llength [info commands teststringobj]]
}]
-testConstraint longIs32bit [expr {$tcl_platform(wordSize) == 4}]
+testConstraint longIs32bit [expr {int(0x80000000) < 0}]
testConstraint testexprlongobj [llength [info commands testexprlongobj]]
-
-
-if {[namespace which -command testbumpinterpepoch] eq ""} {
- proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
-}
# Tests for the omnibus TclExecuteByteCode function:
@@ -49,12 +41,14 @@ if {[namespace which -command testbumpinterpepoch] eq ""} {
# INST_PUSH4 not tested
# INST_POP not tested
# INST_DUP not tested
+# INST_CONCAT1 not tested
# INST_INVOKE_STK4 not tested
# INST_INVOKE_STK1 not tested
# INST_EVAL_STK not tested
# INST_EXPR_STK not tested
# INST_LOAD_SCALAR1
+
test execute-1.1 {TclExecuteByteCode, INST_LOAD_SCALAR1, small opnd} {
proc foo {} {
set x 1
@@ -72,6 +66,7 @@ test execute-1.2 {TclExecuteByteCode, INST_LOAD_SCALAR1, large opnd} {
set y 1
return $y
}
+
proc foo {} $body
foo
} 1
@@ -84,7 +79,9 @@ test execute-1.3 {TclExecuteByteCode, INST_LOAD_SCALAR1, error} {
list [catch {foo} msg] $msg
} {1 {can't read "x": no such variable}}
+
# INST_LOAD_SCALAR4
+
test execute-2.1 {TclExecuteByteCode, INST_LOAD_SCALAR4, simple case} {
set body {}
for {set i 0} {$i < 256} {incr i} {
@@ -94,6 +91,7 @@ test execute-2.1 {TclExecuteByteCode, INST_LOAD_SCALAR4, simple case} {
set y 1
return $y
}
+
proc foo {} $body
foo
} 1
@@ -107,10 +105,12 @@ test execute-2.2 {TclExecuteByteCode, INST_LOAD_SCALAR4, error} {
unset y
return $y
}
+
proc foo {} $body
list [catch {foo} msg] $msg
} {1 {can't read "y": no such variable}}
+
# INST_LOAD_SCALAR_STK not tested
# INST_LOAD_ARRAY4 not tested
# INST_LOAD_ARRAY1 not tested
@@ -179,7 +179,7 @@ test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj}
test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x + 1}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "+"}}
+} {1 {can't use non-numeric string as operand of "+"}}
test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 + $x}
@@ -204,7 +204,7 @@ test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj}
test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 + $x}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "+"}}
+} {1 {can't use non-numeric string as operand of "+"}}
# INST_SUB is partially tested:
test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} {
@@ -231,7 +231,7 @@ test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj}
test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {$x - 1}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "-"}}
+} {1 {can't use non-numeric string as operand of "-"}}
test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 - $x}
@@ -256,7 +256,7 @@ test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj}
test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} {
set x [teststringobj set 0 foo]
list [catch {expr {1 - $x}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "-"}}
+} {1 {can't use non-numeric string as operand of "-"}}
# INST_MULT is partially tested:
test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} {
@@ -283,7 +283,7 @@ test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj
test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x * 1}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "*"}}
+} {1 {can't use non-numeric string as operand of "*"}}
test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {1 * $x}
@@ -308,7 +308,7 @@ test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj
test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 * $x}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "*"}}
+} {1 {can't use non-numeric string as operand of "*"}}
# INST_DIV is partially tested:
test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} {
@@ -335,7 +335,7 @@ test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj}
test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {$x / 1}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "/"}}
+} {1 {can't use non-numeric string as operand of "/"}}
test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {2 / $x}
@@ -360,7 +360,7 @@ test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj}
test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {1 / $x}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "/"}}
+} {1 {can't use non-numeric string as operand of "/"}}
# INST_UPLUS is partially tested:
test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} {
@@ -387,7 +387,7 @@ test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj
test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {+ $x}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "+"}}
+} {1 {can't use non-numeric string as operand of "+"}}
# INST_UMINUS is partially tested:
test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} {
@@ -414,7 +414,7 @@ test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testob
test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {- $x}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "-"}}
+} {1 {can't use non-numeric string as operand of "-"}}
# INST_LNOT is partially tested:
test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
@@ -462,7 +462,7 @@ test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj}
test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
list [catch {expr {! $x}} msg] $msg
-} {1 {can't use non-numeric string "foo" as operand of "!"}}
+} {1 {can't use non-numeric string as operand of "!"}}
# INST_BITNOT not tested
# INST_CALL_BUILTIN_FUNC1 not tested
@@ -504,11 +504,10 @@ test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeri
# INST_PUSH_RESULT not tested
# INST_PUSH_RETURN_CODE not tested
-test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} -setup {
+test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
- unset -nocomplain x
- unset -nocomplain y
-} -body {
+ catch {unset x}
+ catch {unset y}
namespace eval test_ns_1 {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
@@ -522,12 +521,11 @@ test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} -setup {
list [namespace which -command ${x}${y}cmd1] \
[catch {namespace which -command ${x}${y}cmd2} msg] $msg \
[catch {namespace which -command ${x}${y}:cmd2} msg] $msg
-} -result {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}}
-test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} -setup {
+} {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}}
+test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
- unset -nocomplain l
-} -body {
+ catch {unset l}
proc foo {} {
return "global foo"
}
@@ -544,11 +542,11 @@ test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval
}
}
lappend l [test_ns_1::whichFoo]
-} -result {::foo ::test_ns_1::foo}
-test execute-4.3 {Tcl_GetCommandFromObj, command never found} -setup {
+ set l
+} {::foo ::test_ns_1::foo}
+test execute-4.3 {Tcl_GetCommandFromObj, command never found} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
-} -body {
namespace eval test_ns_1 {
proc foo {} {
return "namespace foo"
@@ -562,18 +560,17 @@ test execute-4.3 {Tcl_GetCommandFromObj, command never found} -setup {
list [namespace eval test_ns_1 {namespace which -command foo}] \
[rename test_ns_1::foo ""] \
[catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg
-} -result {::test_ns_1::foo {} 0 {}}
+} {::test_ns_1::foo {} 0 {}}
-test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} -setup {
+test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} {
catch {namespace delete {*}[namespace children :: test_ns_*]}
- unset -nocomplain l
-} -body {
+ catch {unset l}
proc {} {} {return {}}
{}
set l {}
lindex {} 0
{}
-} -result {}
+} {}
test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} {
proc {} {} {}
@@ -609,7 +606,7 @@ test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]}
} -cleanup {
rename 0+0 {}
} -result SCRIPT
-test execute-6.5 {TclCompEvalObj: bytecode epoch validation} -body {
+test execute-6.5 {TclCompEvalObj: bytecode epoch validation} {
set script { llength {} }
set result {}
lappend result [if 1 $script]
@@ -617,22 +614,20 @@ test execute-6.5 {TclCompEvalObj: bytecode epoch validation} -body {
rename $origName llength.orig
proc $origName {args} {return AHA!}
lappend result [if 1 $script]
-} -cleanup {
rename $origName {}
rename llength.orig $origName
-} -result {0 AHA!}
-test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} -body {
+ 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
-} -cleanup {
rename foo {}
-} -result {1 untouched 1 1}
-test execute-6.7 {TclCompEvalObj: bytecode context validation} -setup {
- namespace eval foo {}
-} -body {
+ 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!}
@@ -640,12 +635,10 @@ test execute-6.7 {TclCompEvalObj: bytecode context validation} -setup {
set result {}
lappend result [if 1 $script]
lappend result [namespace eval foo $script]
-} -cleanup {
namespace delete foo
-} -result {0 AHA!}
-test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -setup {
- namespace eval foo {}
-} -body {
+ 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]
@@ -653,62 +646,59 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -se
proc llength {args} {return AHA!}
}
lappend result [namespace eval foo $script]
-} -cleanup {
namespace delete foo
-} -result {0 AHA!}
-test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup {
- interp create child
-} -body {
+ set result
+} {0 AHA!}
+test execute-6.9 {TclCompEvalObj: bytecode interp validation} {
set script { llength {} }
- child eval {proc llength args {return AHA!}}
+ interp create slave
+ slave eval {proc llength args {return AHA!}}
set result {}
lappend result [if 1 $script]
- lappend result [child eval $script]
-} -cleanup {
- interp delete child
-} -result {0 AHA!}
-test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body {
+ 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 child
+ interp create slave
set result {}
- lappend result [child eval $script]
- interp delete child
- interp create child
- lappend result [child eval $script]
-} -cleanup {
- catch {interp delete child}
-} -result {0 0}
-test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup {
- interp create child
-} -constraints testexprlongobj -body {
+ 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 {}
- load {} Tcltest child
- interp alias {} e child testexprlongobj
+ interp create slave
+ load {} Tcltest slave
+ interp alias {} e slave testexprlongobj
lappend result [e $e]
- interp delete child
- interp create child
- load {} Tcltest child
- interp alias {} e child testexprlongobj
+ interp delete slave
+ interp create slave
+ load {} Tcltest slave
+ interp alias {} e slave testexprlongobj
lappend result [e $e]
-} -cleanup {
- interp delete child
-} -result {{This is a result: 1} {This is a result: 1}}
-test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup {
- interp create child
-} -body {
+ 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 alias {} e child expr
+ interp create slave
+ interp alias {} e slave expr
lappend result [e $e]
- interp delete child
- interp create child
- interp alias {} e child expr
+ interp delete slave
+ interp create slave
+ interp alias {} e slave expr
lappend result [e $e]
-} -cleanup {
- interp delete child
-} -result {1 1}
-test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body {
+ 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]
@@ -716,70 +706,65 @@ test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body {
rename $origName llength.orig
proc $origName {args} {return 1}
lappend result [expr $e]
-} -cleanup {
rename $origName {}
rename llength.orig $origName
-} -result {1 2}
-test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup {
- namespace eval foo {}
-} -body {
+ 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 [list expr $e]]
-} -cleanup {
+ lappend result [namespace eval foo {expr $e}]
namespace delete foo
-} -result {1 2}
-test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setup {
- namespace eval foo {}
-} -body {
+ 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 [list expr $e]]
+ lappend result [namespace eval foo {expr $e}]
namespace eval foo {
proc llength {args} {return 1}
}
- lappend result [namespace eval foo [list expr $e]]
-} -cleanup {
+ lappend result [namespace eval foo {expr $e}]
namespace delete foo
-} -result {1 2}
-test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup {
- interp create child
-} -body {
+ set result
+} {1 2}
+test execute-6.16 {Tcl_ExprObj: exprcode interp validation} {
set e { [llength {}]+1 }
- interp alias {} e child expr
- child eval {proc llength args {return 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]
-} -cleanup {
- interp delete child
-} -result {1 2}
-test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body {
+ 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 e { $v }
set result {}
lappend result [foo $e]
lappend result [bar $e]
-} -cleanup {
rename foo {}
rename bar {}
-} -result {0 1}
-test execute-6.18 {Tcl_ExprObj: exprcode context validation} -body {
+ 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 e { [llength $v] }
set result {}
lappend result [foo $e]
lappend result [bar $e]
-} -cleanup {
rename foo {}
rename bar {}
-} -result {0 1}
+ set result
+} {0 1}
test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {
set x 0x100000000
@@ -810,9 +795,9 @@ test execute-7.7 {Wide int handling in INST_EQ and [incr]} {
set y [expr {$x+1}]
expr {double($x) == double($y)}
} 1
-test execute-7.8 {Wide int conversions can change sign} {
- set x 0x8000000000000000
- expr {wide($x) < 0}
+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)}
@@ -821,49 +806,49 @@ 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}
+ expr wide(42)<<30
} 45097156608
test execute-7.12 {Wide int handling in INST_LSHIFT} {
- expr {12345678901 << 3}
+ expr 12345678901<<3
} 98765431208
test execute-7.13 {Wide int handling in INST_RSHIFT} {
- expr {0x543210febcda9876 >> 7}
+ expr 0x543210febcda9876>>7
} 47397893236700464
test execute-7.14 {Wide int handling in INST_RSHIFT} {
- expr {wide(0x9876543210febcda) >> 7}
+ expr wide(0x9876543210febcda)>>7
} -58286587177206407
test execute-7.15 {Wide int handling in INST_BITOR} {
- expr {wide(0x9876543210febcda) | 0x543210febcda9876}
+ expr wide(0x9876543210febcda) | 0x543210febcda9876
} -2560765885044310786
test execute-7.16 {Wide int handling in INST_BITXOR} {
- expr {wide(0x9876543210febcda) ^ 0x543210febcda9876}
+ expr wide(0x9876543210febcda) ^ 0x543210febcda9876
} -3727778945703861076
test execute-7.17 {Wide int handling in INST_BITAND} {
- expr {wide(0x9876543210febcda) & 0x543210febcda9876}
+ expr wide(0x9876543210febcda) & 0x543210febcda9876
} 1167013060659550290
test execute-7.18 {Wide int handling in INST_ADD} {
- expr {wide(0x7fffffff) + wide(0x7fffffff)}
+ expr wide(0x7fffffff)+wide(0x7fffffff)
} 4294967294
test execute-7.19 {Wide int handling in INST_ADD} {
- expr {0x7fffffff + wide(0x7fffffff)}
+ expr 0x7fffffff+wide(0x7fffffff)
} 4294967294
test execute-7.20 {Wide int handling in INST_ADD} {
- expr {wide(0x7fffffff) + 0x7fffffff}
+ expr wide(0x7fffffff)+0x7fffffff
} 4294967294
test execute-7.21 {Wide int handling in INST_ADD} {
- expr {double(0x7fffffff) + wide(0x7fffffff)}
+ expr double(0x7fffffff)+wide(0x7fffffff)
} 4294967294.0
test execute-7.22 {Wide int handling in INST_ADD} {
- expr {wide(0x7fffffff) + double(0x7fffffff)}
+ expr wide(0x7fffffff)+double(0x7fffffff)
} 4294967294.0
test execute-7.23 {Wide int handling in INST_SUB} {
- expr {0x123456789a - 0x20406080a}
+ expr 0x123456789a-0x20406080a
} 69530054800
test execute-7.24 {Wide int handling in INST_MULT} {
- expr {0x123456789a * 193}
+ expr 0x123456789a*193
} 15090186251290
test execute-7.25 {Wide int handling in INST_DIV} {
- expr {0x123456789a / 193}
+ expr 0x123456789a/193
} 405116546
test execute-7.26 {Wide int handling in INST_UPLUS} {
set x 0x123456871234568
@@ -892,19 +877,19 @@ test execute-7.31 {Wide int handling in abs()} {
set y 0x123456871234568
concat [expr {abs($x)}] [expr {abs($y)}]
} {730503879441204585 81985533099853160}
-test execute-7.32 {Wide int handling} {
+test execute-7.32 {Wide int handling} longIs32bit {
expr {int(1024 * 1024 * 1024 * 1024)}
-} 1099511627776
-test execute-7.33 {Wide int handling} {
+} 0
+test execute-7.33 {Wide int handling} longIs32bit {
expr {int(0x1 * 1024 * 1024 * 1024 * 1024)}
-} 1099511627776
+} 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
+ # 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 {
@@ -913,46 +898,51 @@ test execute-8.1 {Stack protection} -setup {
trace remove variable ::errorInfo {write unset} whatever
rename whatever {}
} -returnCodes error -match glob -result *
-test execute-8.2 {Stack restoration} -setup {
+
+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
-} -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
-} -cleanup {
- interp recursionlimit {} $limit
-} -result {too many nested evaluations (infinite loop?)}
-test execute-8.3 {Stack restoration} -setup {
+ 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
-} -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
- testbumpinterpepoch
- catch f msg
- set msg
- }
- run
-} -cleanup {
- interp recursionlimit {} $limit
-} -result {too many nested evaluations (infinite loop?)}
+ 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
- testbumpinterpepoch
+ rename ::set ::dummy
+ rename ::dummy ::set
return -options $o $m
}
} -body {
@@ -964,97 +954,12 @@ test execute-8.4 {Compile epoch bump effect on stack trace} -setup {
} -cleanup {
rename foo {}
rename FOO {}
- unset -nocomplain m o stack1 stack2
} -result {}
-test execute-8.5 {Bug 2038069} -setup {
- proc demo {} {
- catch [list error FOO] m o
- return $o
- }
-} -body {
- demo
-} -cleanup {
- rename demo {}
-} -match glob -result {-code 1 -level 0 -errorstack * -errorcode NONE -errorinfo {FOO
- while executing
-"error FOO"
- invoked from within
-"catch \[list error FOO\] m o"} -errorline 2}
-
-test execute-8.6 {Compile epoch bump in global level (bug [fa6bf38d07])} -setup {
- interp create child
- child eval {
- package require tcltest 2.5
- catch [list package require -exact tcl::test [info patchlevel]]
- ::tcltest::loadTestedCommands
- if {[namespace which -command testbumpinterpepoch] eq ""} {
- proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
- }
- }
-} -body {
- child eval {
- lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
- }
- child eval {
- set i 0; while {[incr i] < 3} {
- lappend res A; testbumpinterpepoch; lappend res B; return; lappend res C;
- }
- }
- child eval {
- set i 0; while {[incr i] < 3} {
- lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
- }
- }
- child eval {
- catch {
- lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
- }
- }
- child eval {set res}
-} -cleanup {
- interp delete child
-} -result [lrepeat 4 A B]
-test execute-8.7 {Compile epoch bump in global level (bug [fa6bf38d07]), exception case} -setup {
- interp create child
- child eval {
- package require tcltest 2.5
- catch [list package require -exact tcl::test [info patchlevel]]
- ::tcltest::loadTestedCommands
- if {[namespace which -command testbumpinterpepoch] eq ""} {
- proc testbumpinterpepoch {} { rename ::set ::dummy; rename ::dummy ::set }
- }
- }
-} -body {
- set res {}
- lappend res [catch {
- child eval {
- lappend res A; testbumpinterpepoch; lappend res B; return -code error test; lappend res C;
- }
- } e] $e
- lappend res [catch {
- child eval {
- lappend res A; testbumpinterpepoch; lappend res B; error test; lappend res C;
- }
- } e] $e
- lappend res [catch {
- child eval {
- lappend res A; testbumpinterpepoch; lappend res B; return -code return test; lappend res C;
- }
- } e] $e
- lappend res [catch {
- child eval {
- lappend res A; testbumpinterpepoch; lappend res B; break; lappend res C;
- }
- } e] $e
- list $res [child eval {set res}]
-} -cleanup {
- interp delete child
-} -result [list {1 test 1 test 2 test 3 {}} [lrepeat 4 A B]]
test execute-9.1 {Interp result resetting [Bug 1522803]} {
set c 0
catch {
- catch {error foo}
+ catch {set foo}
expr {1/$c}
}
if {[string match *foo* $::errorInfo]} {
@@ -1065,121 +970,19 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} {
set result
} SUCCESS
-test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} {
- apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} İ
-} {48 {304 304}}
test execute-10.2 {Bug 2802881} -setup {
- interp create child
+ interp create slave
} -body {
# If [Bug 2802881] is not fixed, this will segfault
- child eval {
+ slave eval {
trace add variable ::errorInfo write {expr {$foo} ;#}
proc demo {} {a {}{}}
demo
}
} -cleanup {
- interp delete child
+ 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
- }
- set ::foo 0
- 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
-
-test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
- interp create child
-} -body {
- child eval {
- set x [lrepeat 1320 199]
- for {set i 0} {$i < 20} {incr i} {
- lappend x $i
- lsort -integer $x
- }
- # Crashes on failure
- return ok
- }
-} -cleanup {
- interp delete child
-} -result ok
-test execute-11.2 {Bug 268b23df11} -setup {
- proc zero {} {return 0}
- proc crash {} {expr {abs([zero])}}
- proc noop args {}
- trace add execution crash enterstep noop
-} -body {
- crash
-} -cleanup {
- trace remove execution crash enterstep noop
- rename noop {}
- rename crash {}
- rename zero {}
-} -result 0
-test execute-11.3 {Bug a0ece9d6d4} -setup {
- proc crash {} {expr {rand()}}
- trace add execution crash enterstep {apply {args {info frame -2}}}
-} -body {
- string is double [crash]
-} -cleanup {
- trace remove execution crash enterstep {apply {args {info frame -2}}}
- rename crash {}
-} -result 1
-
-test execute-12.1 {failing multi-lappend to unshared} -setup {
- unset -nocomplain x y
-} -body {
- set x 1
- lappend x 2 3
- trace add variable x write {apply {args {error boo}}}
- lappend x 4 5
-} -cleanup {
- unset -nocomplain x y
-} -returnCodes error -result {can't set "x": boo}
-test execute-12.2 {failing multi-lappend to shared} -setup {
- unset -nocomplain x y
-} -body {
- set x 1
- lappend x 2 3
- set y $x
- trace add variable x write {apply {args {error boo}}}
- lappend x 4 5
-} -cleanup {
- unset -nocomplain x y
-} -returnCodes error -result {can't set "x": boo}
-test execute-12.3 {failing multi-lappend to unshared: LVT} -body {
- apply {{} {
- set x 1
- lappend x 2 3
- trace add variable x write {apply {args {error boo}}}
- lappend x 4 5
- }}
-} -returnCodes error -result {can't set "x": boo}
-test execute-12.4 {failing multi-lappend to shared: LVT} -body {
- apply {{} {
- set x 1
- lappend x 2 3
- set y $x
- trace add variable x write {apply {args {error boo}}}
- lappend x 4 5
- }}
-} -returnCodes error -result {can't set "x": boo}
-
# cleanup
if {[info commands testobj] != {}} {
testobj freeallvars
@@ -1197,5 +1000,4 @@ return
# Local Variables:
# mode: tcl
-# fill-column: 78
# End:
generated by cgit v0.12 at 2025-12-20 08:04:39 (GMT)