merged tcl 8.1 branch back into the main trunk

1 files changed, 442 insertions, 8 deletions

diff --git a/tests/execute.test b/tests/execute.test
index b4ae4a4..aebe67b 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -9,13 +9,16 @@
 # 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.2 1998/09/14 18:40:08 stanton Exp $
+# RCS: @(#) $Id: execute.test,v 1.3 1999/04/16 00:47:27 stanton Exp $
 
-if {[string compare test [info procs test]] == 1} then {source defs}
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    source [file join [pwd] [file dirname [info script]] defs.tcl]
+}
 
 catch {eval namespace delete [namespace children :: test_ns_*]}
 catch {rename foo ""}
@@ -23,7 +26,420 @@ catch {unset x}
 catch {unset y}
 catch {unset msg}
 
-test execute-1.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
+set ::tcltest::testConfig(testobj) \
+	[expr {[info commands testobj] != {} \
+	&& [info commands testdoubleobj] != {} \
+	&& [info commands teststringobj] != {} \
+	&& [info commands testobj] != {}}]
+
+# Tests for the omnibus TclExecuteByteCode function:
+
+# INST_DONE not tested
+# INST_PUSH1 not tested
+# 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_SCALAR_STK not tested
+# INST_LOAD_ARRAY4 not tested
+# INST_LOAD_ARRAY1 not tested
+# INST_LOAD_ARRAY_STK not tested
+# INST_LOAD_STK not tested
+# INST_STORE_SCALAR4 not tested
+# INST_STORE_SCALAR1 not tested
+# INST_STORE_SCALAR_STK not tested
+# INST_STORE_ARRAY4 not tested
+# INST_STORE_ARRAY1 not tested
+# INST_STORE_ARRAY_STK not tested
+# INST_STORE_STK not tested
+# INST_INCR_SCALAR1 not tested
+# INST_INCR_SCALAR_STK not tested
+# INST_INCR_STK not tested
+# INST_INCR_ARRAY1 not tested
+# INST_INCR_ARRAY_STK not tested
+# INST_INCR_SCALAR1_IMM not tested
+# INST_INCR_SCALAR_STK_IMM not tested
+# INST_INCR_STK_IMM not tested
+# INST_INCR_ARRAY1_IMM not tested
+# INST_INCR_ARRAY_STK_IMM not tested
+# INST_JUMP1 not tested
+# INST_JUMP4 not tested
+# INST_JUMP_TRUE4 not tested
+# INST_JUMP_TRUE1 not tested
+# INST_JUMP_FALSE4 not tested
+# INST_JUMP_FALSE1 not tested
+# INST_LOR not tested
+# INST_LAND not tested
+# INST_EQ not tested
+# INST_NEQ not tested
+# INST_LT not tested
+# INST_GT not tested
+# INST_LE not tested
+# INST_GE not tested
+# INST_MOD not tested
+# INST_LSHIFT not tested
+# INST_RSHIFT not tested
+# INST_BITOR not tested
+# INST_BITXOR not tested
+# INST_BITAND not tested
+
+# INST_ADD is partially tested:
+test execute-1.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} {
+    set x [testdoubleobj set 0 1]
+    expr {$x + 1}
+} 2.0
+test execute-1.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} {
+    set x [teststringobj set 0 1]
+    expr {$x + 1}
+} 2
+test execute-1.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} {
+    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} {
+    set x [testintobj set 0 1]
+    expr {1 + $x}
+} 2
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 0 1]
+    expr {1 + $x}
+} 2
+test execute-1.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} {
+    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} {
+    set x [testintobj set 0 1]
+    expr {$x - 1}
+} 0
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 0 1]
+    expr {$x - 1}
+} 0
+test execute-1.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} {
+    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} {
+    set x [testintobj set 0 1]
+    expr {1 - $x}
+} 0
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 0 1]
+    expr {1 - $x}
+} 0
+test execute-1.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} {
+    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} {
+    set x [testintobj set 1 1]
+    expr {$x * 1}
+} 1
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 1 1]
+    expr {$x * 1}
+} 1
+test execute-1.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} {
+    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} {
+    set x [testintobj set 1 1]
+    expr {1 * $x}
+} 1
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 1 1]
+    expr {1 * $x}
+} 1
+test execute-1.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} {
+    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} {
+    set x [testintobj set 1 1]
+    expr {$x / 1}
+} 1
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 1 1]
+    expr {$x / 1}
+} 1
+test execute-1.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} {
+    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} {
+    set x [testintobj set 1 1]
+    expr {2 / $x}
+} 2
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 1 1]
+    expr {2 / $x}
+} 2
+test execute-1.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} {
+    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} {
+    set x [testintobj set 1 1]
+    expr {+ $x}
+} 1
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 1 1]
+    expr {+ $x}
+} 1
+test execute-1.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} {
+    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} {
+    set x [testintobj set 1 1]
+    expr {- $x}
+} -1
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 1 1]
+    expr {- $x}
+} -1
+test execute-1.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} {
+    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} {
+    set x [testintobj set 1 2]
+    expr {! $x}
+} 0
+test execute-1.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} {
+    set x [testdoubleobj set 1 1.0]
+    expr {! $x}
+} 0
+test execute-1.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} {
+    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} {
+    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} {
+    set x [teststringobj set 1 1]
+    expr {! $x}
+} 0
+test execute-1.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} {
+    set x [teststringobj set 1 1.0]
+    expr {! $x}
+} 0
+test execute-1.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} {
+    set x [teststringobj set 1 foo]
+    list [catch {expr {! $x}} msg] $msg
+} {1 {can't use non-numeric string as operand of "!"}}
+
+# INST_BITNOT not tested
+# INST_CALL_BUILTIN_FUNC1 not tested
+# 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} {
+    set x [testintobj set 1 1]
+    expr {$x}
+} 1
+test execute-1.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} {
+    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} {
+    set x [teststringobj set 1 1]
+    expr {$x}
+} 1
+test execute-1.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} {
+    set x [teststringobj set 1 foo]
+    expr {$x}
+} foo
+
+# INST_BREAK not tested
+# INST_CONTINUE not tested
+# INST_FOREACH_START4 not tested
+# INST_FOREACH_STEP4 not tested
+# INST_BEGIN_CATCH4 not tested
+# INST_END_CATCH not tested
+# 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}
@@ -41,7 +457,7 @@ test execute-1.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
          [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-1.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} {
+test execute-2.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} {
     catch {eval namespace delete [namespace children :: test_ns_*]}
     catch {rename foo ""}
     catch {unset l}
@@ -63,7 +479,7 @@ test execute-1.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval
     lappend l [test_ns_1::whichFoo]
     set l
 } {::foo ::test_ns_1::foo}
-test execute-1.3 {Tcl_GetCommandFromObj, command never found} {
+test execute-2.3 {Tcl_GetCommandFromObj, command never found} {
     catch {eval namespace delete [namespace children :: test_ns_*]}
     catch {rename foo ""}
     namespace eval test_ns_1 {
@@ -81,7 +497,7 @@ test execute-1.3 {Tcl_GetCommandFromObj, command never found} {
          [catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg
 } {::test_ns_1::foo {} 0 {}}
 
-test execute-2.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} {
+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}
     proc {} {} {return {}}
@@ -91,7 +507,7 @@ test execute-2.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL}
     {}
 } {}
 
-test execute-3.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} {
+test execute-4.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} {
     proc {} {} {}
     proc { } {} {}
     proc p {} {
@@ -103,6 +519,7 @@ test execute-3.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName o
     p
 } {}
 
+# cleanup
 catch {eval namespace delete [namespace children :: test_ns_*]}
 catch {rename foo ""}
 catch {rename p ""}
@@ -111,4 +528,21 @@ catch {rename { } ""}
 catch {unset x}
 catch {unset y}
 catch {unset msg}
-concat {}
+::tcltest::cleanupTests
+return
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+
+