summaryrefslogtreecommitdiffstats
path: root/tests/execute.test
diff options
context:
space:
mode:
Diffstat (limited to 'tests/execute.test')
-rw-r--r--tests/execute.test785
1 files changed, 651 insertions, 134 deletions
diff --git a/tests/execute.test b/tests/execute.test
index aebe67b..94af158 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -1,37 +1,42 @@
-# 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 (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.
-#
-# RCS: @(#) $Id: execute.test,v 1.3 1999/04/16 00:47:27 stanton Exp $
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
-if {[lsearch [namespace children] ::tcltest] == -1} {
- source [file join [pwd] [file dirname [info script]] defs.tcl]
+if {"::tcltest" ni [namespace children]} {
+ package require tcltest 2
+ namespace import -force ::tcltest::*
}
-catch {eval namespace delete [namespace children :: test_ns_*]}
+::tcltest::loadTestedCommands
+catch [list package require -exact Tcltest [info patchlevel]]
+
+catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
catch {unset x}
catch {unset y}
catch {unset msg}
-set ::tcltest::testConfig(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:
# INST_DONE not tested
@@ -39,13 +44,68 @@ set ::tcltest::testConfig(testobj) \
# 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 not tested
-# INST_LOAD_SCALAR4 not tested
+
+# INST_LOAD_SCALAR1
+test execute-1.1 {TclExecuteByteCode, INST_LOAD_SCALAR1, small opnd} {
+ proc foo {} {
+ set x 1
+ return $x
+ }
+ foo
+} 1
+test execute-1.2 {TclExecuteByteCode, INST_LOAD_SCALAR1, large opnd} {
+ # Bug: 2243
+ set body {}
+ for {set i 0} {$i < 129} {incr i} {
+ append body "set x$i x\n"
+ }
+ append body {
+ set y 1
+ return $y
+ }
+ proc foo {} $body
+ foo
+} 1
+test execute-1.3 {TclExecuteByteCode, INST_LOAD_SCALAR1, error} {
+ proc foo {} {
+ set x 1
+ unset x
+ return $x
+ }
+ 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} {
+ append body "set x$i x\n"
+ }
+ append body {
+ set y 1
+ return $y
+ }
+ proc foo {} $body
+ foo
+} 1
+test execute-2.2 {TclExecuteByteCode, INST_LOAD_SCALAR4, error} {
+ set body {}
+ for {set i 0} {$i < 256} {incr i} {
+ append body "set x$i x\n"
+ }
+ append body {
+ set y 1
+ 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
@@ -90,311 +150,311 @@ set ::tcltest::testConfig(testobj) \
# INST_BITAND not tested
# INST_ADD is partially tested:
-test execute-1.1 {TclExecuteByteCode, INST_ADD, op1 is int} {testobj} {
+test execute-3.1 {TclExecuteByteCode, INST_ADD, op1 is int} {testobj} {
set x [testintobj set 0 1]
expr {$x + 1}
} 2
-test execute-1.2 {TclExecuteByteCode, INST_ADD, op1 is double} {testobj} {
+test execute-3.2 {TclExecuteByteCode, INST_ADD, op1 is double} {testobj} {
set x [testdoubleobj set 0 1]
expr {$x + 1}
} 2.0
-test execute-1.3 {TclExecuteByteCode, INST_ADD, op1 is double with string} {testobj} {
+test execute-3.3 {TclExecuteByteCode, INST_ADD, op1 is double with string} {testobj} {
set x [testintobj set 0 1]
testobj convert 0 double
expr {$x + 1}
} 2
-test execute-1.4 {TclExecuteByteCode, INST_ADD, op1 is string int} {testobj} {
+test execute-3.4 {TclExecuteByteCode, INST_ADD, op1 is string int} {testobj} {
set x [teststringobj set 0 1]
expr {$x + 1}
} 2
-test execute-1.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} {
+test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x + 1}
} 2.0
-test execute-1.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {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 as operand of "+"}}
-test execute-1.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} {
+test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 + $x}
} 2
-test execute-1.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} {
+test execute-3.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} {
set x [testdoubleobj set 0 1]
expr {1 + $x}
} 2.0
-test execute-1.9 {TclExecuteByteCode, INST_ADD, op2 is double with string} {testobj} {
+test execute-3.9 {TclExecuteByteCode, INST_ADD, op2 is double with string} {testobj} {
set x [testintobj set 0 1]
testobj convert 0 double
expr {1 + $x}
} 2
-test execute-1.10 {TclExecuteByteCode, INST_ADD, op2 is string int} {testobj} {
+test execute-3.10 {TclExecuteByteCode, INST_ADD, op2 is string int} {testobj} {
set x [teststringobj set 0 1]
expr {1 + $x}
} 2
-test execute-1.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} {
+test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 + $x}
} 2.0
-test execute-1.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {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 as operand of "+"}}
# INST_SUB is partially tested:
-test execute-1.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} {
+test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} {
set x [testintobj set 0 1]
expr {$x - 1}
} 0
-test execute-1.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} {
+test execute-3.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} {
set x [testdoubleobj set 0 1]
expr {$x - 1}
} 0.0
-test execute-1.15 {TclExecuteByteCode, INST_SUB, op1 is double with string} {testobj} {
+test execute-3.15 {TclExecuteByteCode, INST_SUB, op1 is double with string} {testobj} {
set x [testintobj set 0 1]
testobj convert 0 double
expr {$x - 1}
} 0
-test execute-1.16 {TclExecuteByteCode, INST_SUB, op1 is string int} {testobj} {
+test execute-3.16 {TclExecuteByteCode, INST_SUB, op1 is string int} {testobj} {
set x [teststringobj set 0 1]
expr {$x - 1}
} 0
-test execute-1.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} {
+test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {$x - 1}
} 0.0
-test execute-1.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {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 as operand of "-"}}
-test execute-1.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} {
+test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} {
set x [testintobj set 0 1]
expr {1 - $x}
} 0
-test execute-1.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} {
+test execute-3.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} {
set x [testdoubleobj set 0 1]
expr {1 - $x}
} 0.0
-test execute-1.21 {TclExecuteByteCode, INST_SUB, op2 is double with string} {testobj} {
+test execute-3.21 {TclExecuteByteCode, INST_SUB, op2 is double with string} {testobj} {
set x [testintobj set 0 1]
testobj convert 0 double
expr {1 - $x}
} 0
-test execute-1.22 {TclExecuteByteCode, INST_SUB, op2 is string int} {testobj} {
+test execute-3.22 {TclExecuteByteCode, INST_SUB, op2 is string int} {testobj} {
set x [teststringobj set 0 1]
expr {1 - $x}
} 0
-test execute-1.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} {
+test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} {
set x [teststringobj set 0 1.0]
expr {1 - $x}
} 0.0
-test execute-1.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {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 as operand of "-"}}
# INST_MULT is partially tested:
-test execute-1.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} {
+test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} {
set x [testintobj set 1 1]
expr {$x * 1}
} 1
-test execute-1.26 {TclExecuteByteCode, INST_MULT, op1 is double} {testobj} {
+test execute-3.26 {TclExecuteByteCode, INST_MULT, op1 is double} {testobj} {
set x [testdoubleobj set 1 2.0]
expr {$x * 1}
} 2.0
-test execute-1.27 {TclExecuteByteCode, INST_MULT, op1 is double with string} {testobj} {
+test execute-3.27 {TclExecuteByteCode, INST_MULT, op1 is double with string} {testobj} {
set x [testintobj set 1 2]
testobj convert 1 double
expr {$x * 1}
} 2
-test execute-1.28 {TclExecuteByteCode, INST_MULT, op1 is string int} {testobj} {
+test execute-3.28 {TclExecuteByteCode, INST_MULT, op1 is string int} {testobj} {
set x [teststringobj set 1 1]
expr {$x * 1}
} 1
-test execute-1.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} {
+test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x * 1}
} 1.0
-test execute-1.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {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 as operand of "*"}}
-test execute-1.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} {
+test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {1 * $x}
} 1
-test execute-1.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} {
+test execute-3.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} {
set x [testdoubleobj set 1 2.0]
expr {1 * $x}
} 2.0
-test execute-1.33 {TclExecuteByteCode, INST_MULT, op2 is double with string} {testobj} {
+test execute-3.33 {TclExecuteByteCode, INST_MULT, op2 is double with string} {testobj} {
set x [testintobj set 1 2]
testobj convert 1 double
expr {1 * $x}
} 2
-test execute-1.34 {TclExecuteByteCode, INST_MULT, op2 is string int} {testobj} {
+test execute-3.34 {TclExecuteByteCode, INST_MULT, op2 is string int} {testobj} {
set x [teststringobj set 1 1]
expr {1 * $x}
} 1
-test execute-1.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} {
+test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {1 * $x}
} 1.0
-test execute-1.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {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 as operand of "*"}}
# INST_DIV is partially tested:
-test execute-1.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} {
+test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} {
set x [testintobj set 1 1]
expr {$x / 1}
} 1
-test execute-1.38 {TclExecuteByteCode, INST_DIV, op1 is double} {testobj} {
+test execute-3.38 {TclExecuteByteCode, INST_DIV, op1 is double} {testobj} {
set x [testdoubleobj set 1 2.0]
expr {$x / 1}
} 2.0
-test execute-1.39 {TclExecuteByteCode, INST_DIV, op1 is double with string} {testobj} {
+test execute-3.39 {TclExecuteByteCode, INST_DIV, op1 is double with string} {testobj} {
set x [testintobj set 1 2]
testobj convert 1 double
expr {$x / 1}
} 2
-test execute-1.40 {TclExecuteByteCode, INST_DIV, op1 is string int} {testobj} {
+test execute-3.40 {TclExecuteByteCode, INST_DIV, op1 is string int} {testobj} {
set x [teststringobj set 1 1]
expr {$x / 1}
} 1
-test execute-1.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} {
+test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x / 1}
} 1.0
-test execute-1.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {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 as operand of "/"}}
-test execute-1.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} {
+test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} {
set x [testintobj set 1 1]
expr {2 / $x}
} 2
-test execute-1.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} {
+test execute-3.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} {
set x [testdoubleobj set 1 1.0]
expr {2 / $x}
} 2.0
-test execute-1.45 {TclExecuteByteCode, INST_DIV, op2 is double with string} {testobj} {
+test execute-3.45 {TclExecuteByteCode, INST_DIV, op2 is double with string} {testobj} {
set x [testintobj set 1 1]
testobj convert 1 double
expr {2 / $x}
} 2
-test execute-1.46 {TclExecuteByteCode, INST_DIV, op2 is string int} {testobj} {
+test execute-3.46 {TclExecuteByteCode, INST_DIV, op2 is string int} {testobj} {
set x [teststringobj set 1 1]
expr {2 / $x}
} 2
-test execute-1.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} {
+test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {2 / $x}
} 2.0
-test execute-1.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {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 as operand of "/"}}
# INST_UPLUS is partially tested:
-test execute-1.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} {
+test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} {
set x [testintobj set 1 1]
expr {+ $x}
} 1
-test execute-1.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} {
+test execute-3.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} {
set x [testdoubleobj set 1 1.0]
expr {+ $x}
} 1.0
-test execute-1.51 {TclExecuteByteCode, INST_UPLUS, op is double with string} {testobj} {
+test execute-3.51 {TclExecuteByteCode, INST_UPLUS, op is double with string} {testobj} {
set x [testintobj set 1 1]
testobj convert 1 double
expr {+ $x}
} 1
-test execute-1.52 {TclExecuteByteCode, INST_UPLUS, op is string int} {testobj} {
+test execute-3.52 {TclExecuteByteCode, INST_UPLUS, op is string int} {testobj} {
set x [teststringobj set 1 1]
expr {+ $x}
} 1
-test execute-1.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} {
+test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {+ $x}
} 1.0
-test execute-1.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {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 as operand of "+"}}
# INST_UMINUS is partially tested:
-test execute-1.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} {
+test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} {
set x [testintobj set 1 1]
expr {- $x}
} -1
-test execute-1.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} {
+test execute-3.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} {
set x [testdoubleobj set 1 1.0]
expr {- $x}
} -1.0
-test execute-1.57 {TclExecuteByteCode, INST_UMINUS, op is double with string} {testobj} {
+test execute-3.57 {TclExecuteByteCode, INST_UMINUS, op is double with string} {testobj} {
set x [testintobj set 1 1]
testobj convert 1 double
expr {- $x}
} -1
-test execute-1.58 {TclExecuteByteCode, INST_UMINUS, op is string int} {testobj} {
+test execute-3.58 {TclExecuteByteCode, INST_UMINUS, op is string int} {testobj} {
set x [teststringobj set 1 1]
expr {- $x}
} -1
-test execute-1.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} {
+test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {- $x}
} -1.0
-test execute-1.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} {
+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 as operand of "-"}}
# INST_LNOT is partially tested:
-test execute-1.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
+test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
set x [testintobj set 1 2]
expr {! $x}
} 0
-test execute-1.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
+test execute-3.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} {
set x [testintobj set 1 0]
expr {! $x}
} 1
-test execute-1.63 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} {
+test execute-3.63 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} {
set x [testdoubleobj set 1 1.0]
expr {! $x}
} 0
-test execute-1.64 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} {
+test execute-3.64 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} {
set x [testdoubleobj set 1 0.0]
expr {! $x}
} 1
-test execute-1.65 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} {
+test execute-3.65 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} {
set x [testintobj set 1 1]
testobj convert 1 double
expr {! $x}
} 0
-test execute-1.66 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} {
+test execute-3.66 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} {
set x [testintobj set 1 0]
testobj convert 1 double
expr {! $x}
} 1
-test execute-1.67 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} {
+test execute-3.67 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} {
set x [teststringobj set 1 1]
expr {! $x}
} 0
-test execute-1.68 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} {
+test execute-3.68 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} {
set x [teststringobj set 1 0]
expr {! $x}
} 1
-test execute-1.69 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} {
+test execute-3.69 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {! $x}
} 0
-test execute-1.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} {
+test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} {
set x [teststringobj set 1 0.0]
expr {! $x}
} 1
-test execute-1.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {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 as operand of "!"}}
@@ -404,28 +464,28 @@ test execute-1.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} {
# INST_CALL_FUNC1 not tested
# INST_TRY_CVT_TO_NUMERIC is partially tested:
-test execute-1.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} {
+test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} {
set x [testintobj set 1 1]
expr {$x}
} 1
-test execute-1.73 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double} {testobj} {
+test execute-3.73 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double} {testobj} {
set x [testdoubleobj set 1 1.0]
expr {$x}
} 1.0
-test execute-1.74 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double with string} {testobj} {
+test execute-3.74 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double with string} {testobj} {
set x [testintobj set 1 1]
testobj convert 1 double
expr {$x}
} 1
-test execute-1.75 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string int} {testobj} {
+test execute-3.75 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string int} {testobj} {
set x [teststringobj set 1 1]
expr {$x}
} 1
-test execute-1.76 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string double} {testobj} {
+test execute-3.76 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string double} {testobj} {
set x [teststringobj set 1 1.0]
expr {$x}
} 1.0
-test execute-1.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeric} {testobj} {
+test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeric} {testobj} {
set x [teststringobj set 1 foo]
expr {$x}
} foo
@@ -439,10 +499,11 @@ test execute-1.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeri
# INST_PUSH_RESULT not tested
# INST_PUSH_RETURN_CODE not tested
-test execute-2.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
- catch {unset x}
- catch {unset y}
+test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ unset -nocomplain x
+ unset -nocomplain y
+} -body {
namespace eval test_ns_1 {
namespace export cmd1
proc cmd1 {args} {return "cmd1: $args"}
@@ -456,11 +517,12 @@ test execute-2.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
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
-} {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}}
-test execute-2.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+} -result {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}}
+test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
- catch {unset l}
+ unset -nocomplain l
+} -body {
proc foo {} {
return "global foo"
}
@@ -477,11 +539,11 @@ test execute-2.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval
}
}
lappend l [test_ns_1::whichFoo]
- set l
-} {::foo ::test_ns_1::foo}
-test execute-2.3 {Tcl_GetCommandFromObj, command never found} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
+} -result {::foo ::test_ns_1::foo}
+test execute-4.3 {Tcl_GetCommandFromObj, command never found} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
catch {rename foo ""}
+} -body {
namespace eval test_ns_1 {
proc foo {} {
return "namespace foo"
@@ -495,19 +557,20 @@ test execute-2.3 {Tcl_GetCommandFromObj, command never found} {
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
-} {::test_ns_1::foo {} 0 {}}
+} -result {::test_ns_1::foo {} 0 {}}
-test execute-3.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} {
- catch {eval namespace delete [namespace children :: test_ns_*]}
- catch {unset l}
+test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} -setup {
+ catch {namespace delete {*}[namespace children :: test_ns_*]}
+ unset -nocomplain l
+} -body {
proc {} {} {return {}}
{}
set l {}
lindex {} 0
{}
-} {}
+} -result {}
-test execute-4.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} {
+test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} {
proc {} {} {}
proc { } {} {}
proc p {} {
@@ -518,9 +581,474 @@ test execute-4.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} -body {
+ 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]
+} -cleanup {
+ rename $origName {}
+ rename llength.orig $origName
+} -result {0 AHA!}
+test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} -body {
+ 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 script { llength {} }
+ namespace eval foo {
+ proc llength {args} {return AHA!}
+ }
+ 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 script { llength {} }
+ set result {}
+ lappend result [namespace eval foo $script]
+ namespace eval foo {
+ 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 slave
+} -body {
+ set script { llength {} }
+ slave eval {proc llength args {return AHA!}}
+ set result {}
+ lappend result [if 1 $script]
+ lappend result [slave eval $script]
+} -cleanup {
+ interp delete slave
+} -result {0 AHA!}
+test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body {
+ set script { llength {} }
+ interp create slave
+ set result {}
+ lappend result [slave eval $script]
+ interp delete slave
+ interp create slave
+ lappend result [slave eval $script]
+} -cleanup {
+ catch {interp delete slave}
+} -result {0 0}
+test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup {
+ interp create slave
+} -constraints testexprlongobj -body {
+ set e { [llength {}]+1 }
+ set result {}
+ 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]
+} -cleanup {
+ interp delete slave
+} -result {{This is a result: 1} {This is a result: 1}}
+test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup {
+ interp create slave
+} -body {
+ set e { [llength {}]+1 }
+ set result {}
+ interp alias {} e slave expr
+ lappend result [e $e]
+ interp delete slave
+ interp create slave
+ interp alias {} e slave expr
+ lappend result [e $e]
+} -cleanup {
+ interp delete slave
+} -result {1 1}
+test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body {
+ 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]
+} -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 e { [llength {}]+1 }
+ namespace eval foo {
+ proc llength {args} {return 1}
+ }
+ set result {}
+ lappend result [expr $e]
+ lappend result [namespace eval foo {expr $e}]
+} -cleanup {
+ namespace delete foo
+} -result {1 2}
+test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setup {
+ namespace eval foo {}
+} -body {
+ 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}]
+} -cleanup {
+ namespace delete foo
+} -result {1 2}
+test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup {
+ interp create slave
+} -body {
+ set e { [llength {}]+1 }
+ 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 slave
+} -result {1 2}
+test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body {
+ 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 {
+ 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}
+
+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} -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 {
+ # 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
+ rename ::set ::dummy
+ rename ::dummy ::set
+ catch f msg
+ set msg
+ }
+ run
+} -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 {}
+ 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-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.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} {
+ apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130
+} {48 {304 304}}
+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 *
+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
+test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
+ interp create slave
+} -body {
+ slave 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 slave
+} -result ok
+
# 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 {} ""}
@@ -531,18 +1059,7 @@ catch {unset msg}
::tcltest::cleanupTests
return
-
-
-
-
-
-
-
-
-
-
-
-
-
-
-
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
generated by cgit v0.12 at 2025-10-25 03:26:59 (GMT)