summaryrefslogtreecommitdiffstats
path: root/tests/execute.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/execute.test')
-rw-r--r--tests/execute.test196
1 files changed, 134 insertions, 62 deletions
diff --git a/tests/execute.test b/tests/execute.test
index 1a95c44..b460cfe 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -19,22 +19,20 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
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}
-::tcltest::testConstraint 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]]
+}]
-::tcltest::testConstraint longIs32bit \
- [expr {int(0x80000000) < 0}]
-::tcltest::testConstraint testexprlongobj \
- [llength [info commands testexprlongobj]]
+testConstraint longIs32bit [expr {int(0x80000000) < 0}]
+testConstraint testexprlongobj [llength [info commands testexprlongobj]]
# Tests for the omnibus TclExecuteByteCode function:
@@ -507,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 {
@@ -525,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 {} {
@@ -547,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 {} {
@@ -565,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 {}}
{}
@@ -632,7 +630,7 @@ test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} {
test execute-6.7 {TclCompEvalObj: bytecode context validation} {
set script { llength {} }
namespace eval foo {
- proc llength {args} {return AHA!}
+ proc llength {args} {return AHA!}
}
set result {}
lappend result [if 1 $script]
@@ -645,7 +643,7 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} {
set result {}
lappend result [namespace eval foo $script]
namespace eval foo {
- proc llength {args} {return AHA!}
+ proc llength {args} {return AHA!}
}
lappend result [namespace eval foo $script]
namespace delete foo
@@ -695,7 +693,7 @@ test execute-6.12 {Tcl_ExprObj: exprcode interp validation} {
lappend result [e $e]
interp delete slave
interp create slave
- interp alias {} e slave expr
+ interp alias {} e slave expr
lappend result [e $e]
interp delete slave
set result
@@ -715,7 +713,7 @@ test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} {
test execute-6.14 {Tcl_ExprObj: exprcode context validation} {
set e { [llength {}]+1 }
namespace eval foo {
- proc llength {args} {return 1}
+ proc llength {args} {return 1}
}
set result {}
lappend result [expr $e]
@@ -728,7 +726,7 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} {
set result {}
lappend result [namespace eval foo {expr $e}]
namespace eval foo {
- proc llength {args} {return 1}
+ proc llength {args} {return 1}
}
lappend result [namespace eval foo {expr $e}]
namespace delete foo
@@ -768,125 +766,124 @@ test execute-6.18 {Tcl_ExprObj: exprcode context validation} {
set result
} {0 1}
-
-test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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]} {longIs32bit} {
+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]} {longIs32bit} {
+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} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+test execute-7.12 {Wide int handling in INST_LSHIFT} {
expr 12345678901<<3
} 98765431208
-test execute-7.13 {Wide int handling in INST_RSHIFT} {longIs32bit} {
+test execute-7.13 {Wide int handling in INST_RSHIFT} {
expr 0x543210febcda9876>>7
} 47397893236700464
-test execute-7.14 {Wide int handling in INST_RSHIFT} {longIs32bit} {
- expr 0x9876543210febcda>>7
+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} {longIs32bit} {
- expr 0x9876543210febcda | 0x543210febcda9876
+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} {longIs32bit} {
- expr 0x9876543210febcda ^ 0x543210febcda9876
+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} {longIs32bit} {
- expr 0x9876543210febcda & 0x543210febcda9876
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+test execute-7.23 {Wide int handling in INST_SUB} {
expr 0x123456789a-0x20406080a
} 69530054800
-test execute-7.24 {Wide int handling in INST_MULT} {longIs32bit} {
+test execute-7.24 {Wide int handling in INST_MULT} {
expr 0x123456789a*193
} 15090186251290
-test execute-7.25 {Wide int handling in INST_DIV} {longIs32bit} {
+test execute-7.25 {Wide int handling in INST_DIV} {
expr 0x123456789a/193
} 405116546
-test execute-7.26 {Wide int handling in INST_UPLUS} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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} {longIs32bit} {
+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()} {longIs32bit} {
+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 {1024 * 1024 * 1024 * 1024}
+test execute-7.32 {Wide int handling} longIs32bit {
+ expr {int(1024 * 1024 * 1024 * 1024)}
} 0
-test execute-7.33 {Wide int handling} {longIs32bit} {
- expr {0x1 * 1024 * 1024 * 1024 * 1024}
+test execute-7.33 {Wide int handling} longIs32bit {
+ expr {int(0x1 * 1024 * 1024 * 1024 * 1024)}
} 0
-test execute-7.34 {Wide int handling} {longIs32bit} {
+test execute-7.34 {Wide int handling} {
expr {wide(0x1) * 1024 * 1024 * 1024 * 1024}
} 1099511627776
@@ -902,6 +899,77 @@ test execute-8.1 {Stack protection} -setup {
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 {
@@ -919,7 +987,7 @@ test execute-10.2 {Bug 2802881} -setup {
if {[info commands testobj] != {}} {
testobj freeallvars
}
-catch {eval namespace delete [namespace children :: test_ns_*]}
+catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {rename p ""}
catch {rename {} ""}
@@ -929,3 +997,7 @@ catch {unset y}
catch {unset msg}
::tcltest::cleanupTests
return
+
+# Local Variables:
+# mode: tcl
+# End:
generated by cgit v0.12 at 2024-07-15 12:57:19 (GMT)