sl@0: # This file contains tests for the tclExecute.c source file. Tests appear sl@0: # in the same order as the C code that they test. The set of tests is sl@0: # currently incomplete since it currently includes only new tests for sl@0: # code changed for the addition of Tcl namespaces. Other execution- sl@0: # related tests appear in several other test files including sl@0: # namespace.test, basic.test, eval.test, for.test, etc. sl@0: # sl@0: # Sourcing this file into Tcl runs the tests and generates output for sl@0: # errors. No output means no errors were found. sl@0: # sl@0: # Copyright (c) 1997 Sun Microsystems, Inc. sl@0: # Copyright (c) 1998-1999 by Scriptics Corporation. sl@0: # sl@0: # See the file "license.terms" for information on usage and redistribution sl@0: # of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: # sl@0: # RCS: @(#) $Id: execute.test,v 1.13.2.2 2004/10/28 00:01:07 dgp Exp $ sl@0: sl@0: if {[lsearch [namespace children] ::tcltest] == -1} { sl@0: package require tcltest 2 sl@0: namespace import -force ::tcltest::* sl@0: } sl@0: sl@0: catch {eval namespace delete [namespace children :: test_ns_*]} sl@0: catch {rename foo ""} sl@0: catch {unset x} sl@0: catch {unset y} sl@0: catch {unset msg} sl@0: sl@0: ::tcltest::testConstraint testobj \ sl@0: [expr {[info commands testobj] != {} \ sl@0: && [info commands testdoubleobj] != {} \ sl@0: && [info commands teststringobj] != {} \ sl@0: && [info commands testobj] != {}}] sl@0: sl@0: ::tcltest::testConstraint longIs32bit \ sl@0: [expr {int(0x80000000) < 0}] sl@0: sl@0: # Tests for the omnibus TclExecuteByteCode function: sl@0: sl@0: # INST_DONE not tested sl@0: # INST_PUSH1 not tested sl@0: # INST_PUSH4 not tested sl@0: # INST_POP not tested sl@0: # INST_DUP not tested sl@0: # INST_CONCAT1 not tested sl@0: # INST_INVOKE_STK4 not tested sl@0: # INST_INVOKE_STK1 not tested sl@0: # INST_EVAL_STK not tested sl@0: # INST_EXPR_STK not tested sl@0: sl@0: # INST_LOAD_SCALAR1 sl@0: sl@0: test execute-1.1 {TclExecuteByteCode, INST_LOAD_SCALAR1, small opnd} { sl@0: proc foo {} { sl@0: set x 1 sl@0: return $x sl@0: } sl@0: foo sl@0: } 1 sl@0: test execute-1.2 {TclExecuteByteCode, INST_LOAD_SCALAR1, large opnd} { sl@0: # Bug: 2243 sl@0: set body {} sl@0: for {set i 0} {$i < 129} {incr i} { sl@0: append body "set x$i x\n" sl@0: } sl@0: append body { sl@0: set y 1 sl@0: return $y sl@0: } sl@0: sl@0: proc foo {} $body sl@0: foo sl@0: } 1 sl@0: test execute-1.3 {TclExecuteByteCode, INST_LOAD_SCALAR1, error} { sl@0: proc foo {} { sl@0: set x 1 sl@0: unset x sl@0: return $x sl@0: } sl@0: list [catch {foo} msg] $msg sl@0: } {1 {can't read "x": no such variable}} sl@0: sl@0: sl@0: # INST_LOAD_SCALAR4 sl@0: sl@0: test execute-2.1 {TclExecuteByteCode, INST_LOAD_SCALAR4, simple case} { sl@0: set body {} sl@0: for {set i 0} {$i < 256} {incr i} { sl@0: append body "set x$i x\n" sl@0: } sl@0: append body { sl@0: set y 1 sl@0: return $y sl@0: } sl@0: sl@0: proc foo {} $body sl@0: foo sl@0: } 1 sl@0: test execute-2.2 {TclExecuteByteCode, INST_LOAD_SCALAR4, error} { sl@0: set body {} sl@0: for {set i 0} {$i < 256} {incr i} { sl@0: append body "set x$i x\n" sl@0: } sl@0: append body { sl@0: set y 1 sl@0: unset y sl@0: return $y sl@0: } sl@0: sl@0: proc foo {} $body sl@0: list [catch {foo} msg] $msg sl@0: } {1 {can't read "y": no such variable}} sl@0: sl@0: sl@0: # INST_LOAD_SCALAR_STK not tested sl@0: # INST_LOAD_ARRAY4 not tested sl@0: # INST_LOAD_ARRAY1 not tested sl@0: # INST_LOAD_ARRAY_STK not tested sl@0: # INST_LOAD_STK not tested sl@0: # INST_STORE_SCALAR4 not tested sl@0: # INST_STORE_SCALAR1 not tested sl@0: # INST_STORE_SCALAR_STK not tested sl@0: # INST_STORE_ARRAY4 not tested sl@0: # INST_STORE_ARRAY1 not tested sl@0: # INST_STORE_ARRAY_STK not tested sl@0: # INST_STORE_STK not tested sl@0: # INST_INCR_SCALAR1 not tested sl@0: # INST_INCR_SCALAR_STK not tested sl@0: # INST_INCR_STK not tested sl@0: # INST_INCR_ARRAY1 not tested sl@0: # INST_INCR_ARRAY_STK not tested sl@0: # INST_INCR_SCALAR1_IMM not tested sl@0: # INST_INCR_SCALAR_STK_IMM not tested sl@0: # INST_INCR_STK_IMM not tested sl@0: # INST_INCR_ARRAY1_IMM not tested sl@0: # INST_INCR_ARRAY_STK_IMM not tested sl@0: # INST_JUMP1 not tested sl@0: # INST_JUMP4 not tested sl@0: # INST_JUMP_TRUE4 not tested sl@0: # INST_JUMP_TRUE1 not tested sl@0: # INST_JUMP_FALSE4 not tested sl@0: # INST_JUMP_FALSE1 not tested sl@0: # INST_LOR not tested sl@0: # INST_LAND not tested sl@0: # INST_EQ not tested sl@0: # INST_NEQ not tested sl@0: # INST_LT not tested sl@0: # INST_GT not tested sl@0: # INST_LE not tested sl@0: # INST_GE not tested sl@0: # INST_MOD not tested sl@0: # INST_LSHIFT not tested sl@0: # INST_RSHIFT not tested sl@0: # INST_BITOR not tested sl@0: # INST_BITXOR not tested sl@0: # INST_BITAND not tested sl@0: sl@0: # INST_ADD is partially tested: sl@0: test execute-3.1 {TclExecuteByteCode, INST_ADD, op1 is int} {testobj} { sl@0: set x [testintobj set 0 1] sl@0: expr {$x + 1} sl@0: } 2 sl@0: test execute-3.2 {TclExecuteByteCode, INST_ADD, op1 is double} {testobj} { sl@0: set x [testdoubleobj set 0 1] sl@0: expr {$x + 1} sl@0: } 2.0 sl@0: test execute-3.3 {TclExecuteByteCode, INST_ADD, op1 is double with string} {testobj} { sl@0: set x [testintobj set 0 1] sl@0: testobj convert 0 double sl@0: expr {$x + 1} sl@0: } 2 sl@0: test execute-3.4 {TclExecuteByteCode, INST_ADD, op1 is string int} {testobj} { sl@0: set x [teststringobj set 0 1] sl@0: expr {$x + 1} sl@0: } 2 sl@0: test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} { sl@0: set x [teststringobj set 0 1.0] sl@0: expr {$x + 1} sl@0: } 2.0 sl@0: test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} { sl@0: set x [teststringobj set 0 foo] sl@0: list [catch {expr {$x + 1}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "+"}} sl@0: test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { sl@0: set x [testintobj set 0 1] sl@0: expr {1 + $x} sl@0: } 2 sl@0: test execute-3.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} { sl@0: set x [testdoubleobj set 0 1] sl@0: expr {1 + $x} sl@0: } 2.0 sl@0: test execute-3.9 {TclExecuteByteCode, INST_ADD, op2 is double with string} {testobj} { sl@0: set x [testintobj set 0 1] sl@0: testobj convert 0 double sl@0: expr {1 + $x} sl@0: } 2 sl@0: test execute-3.10 {TclExecuteByteCode, INST_ADD, op2 is string int} {testobj} { sl@0: set x [teststringobj set 0 1] sl@0: expr {1 + $x} sl@0: } 2 sl@0: test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} { sl@0: set x [teststringobj set 0 1.0] sl@0: expr {1 + $x} sl@0: } 2.0 sl@0: test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} { sl@0: set x [teststringobj set 0 foo] sl@0: list [catch {expr {1 + $x}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "+"}} sl@0: sl@0: # INST_SUB is partially tested: sl@0: test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { sl@0: set x [testintobj set 0 1] sl@0: expr {$x - 1} sl@0: } 0 sl@0: test execute-3.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} { sl@0: set x [testdoubleobj set 0 1] sl@0: expr {$x - 1} sl@0: } 0.0 sl@0: test execute-3.15 {TclExecuteByteCode, INST_SUB, op1 is double with string} {testobj} { sl@0: set x [testintobj set 0 1] sl@0: testobj convert 0 double sl@0: expr {$x - 1} sl@0: } 0 sl@0: test execute-3.16 {TclExecuteByteCode, INST_SUB, op1 is string int} {testobj} { sl@0: set x [teststringobj set 0 1] sl@0: expr {$x - 1} sl@0: } 0 sl@0: test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} { sl@0: set x [teststringobj set 0 1.0] sl@0: expr {$x - 1} sl@0: } 0.0 sl@0: test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} { sl@0: set x [teststringobj set 0 foo] sl@0: list [catch {expr {$x - 1}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "-"}} sl@0: test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { sl@0: set x [testintobj set 0 1] sl@0: expr {1 - $x} sl@0: } 0 sl@0: test execute-3.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} { sl@0: set x [testdoubleobj set 0 1] sl@0: expr {1 - $x} sl@0: } 0.0 sl@0: test execute-3.21 {TclExecuteByteCode, INST_SUB, op2 is double with string} {testobj} { sl@0: set x [testintobj set 0 1] sl@0: testobj convert 0 double sl@0: expr {1 - $x} sl@0: } 0 sl@0: test execute-3.22 {TclExecuteByteCode, INST_SUB, op2 is string int} {testobj} { sl@0: set x [teststringobj set 0 1] sl@0: expr {1 - $x} sl@0: } 0 sl@0: test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} { sl@0: set x [teststringobj set 0 1.0] sl@0: expr {1 - $x} sl@0: } 0.0 sl@0: test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} { sl@0: set x [teststringobj set 0 foo] sl@0: list [catch {expr {1 - $x}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "-"}} sl@0: sl@0: # INST_MULT is partially tested: sl@0: test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: expr {$x * 1} sl@0: } 1 sl@0: test execute-3.26 {TclExecuteByteCode, INST_MULT, op1 is double} {testobj} { sl@0: set x [testdoubleobj set 1 2.0] sl@0: expr {$x * 1} sl@0: } 2.0 sl@0: test execute-3.27 {TclExecuteByteCode, INST_MULT, op1 is double with string} {testobj} { sl@0: set x [testintobj set 1 2] sl@0: testobj convert 1 double sl@0: expr {$x * 1} sl@0: } 2 sl@0: test execute-3.28 {TclExecuteByteCode, INST_MULT, op1 is string int} {testobj} { sl@0: set x [teststringobj set 1 1] sl@0: expr {$x * 1} sl@0: } 1 sl@0: test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} { sl@0: set x [teststringobj set 1 1.0] sl@0: expr {$x * 1} sl@0: } 1.0 sl@0: test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} { sl@0: set x [teststringobj set 1 foo] sl@0: list [catch {expr {$x * 1}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "*"}} sl@0: test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: expr {1 * $x} sl@0: } 1 sl@0: test execute-3.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} { sl@0: set x [testdoubleobj set 1 2.0] sl@0: expr {1 * $x} sl@0: } 2.0 sl@0: test execute-3.33 {TclExecuteByteCode, INST_MULT, op2 is double with string} {testobj} { sl@0: set x [testintobj set 1 2] sl@0: testobj convert 1 double sl@0: expr {1 * $x} sl@0: } 2 sl@0: test execute-3.34 {TclExecuteByteCode, INST_MULT, op2 is string int} {testobj} { sl@0: set x [teststringobj set 1 1] sl@0: expr {1 * $x} sl@0: } 1 sl@0: test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} { sl@0: set x [teststringobj set 1 1.0] sl@0: expr {1 * $x} sl@0: } 1.0 sl@0: test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} { sl@0: set x [teststringobj set 1 foo] sl@0: list [catch {expr {1 * $x}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "*"}} sl@0: sl@0: # INST_DIV is partially tested: sl@0: test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: expr {$x / 1} sl@0: } 1 sl@0: test execute-3.38 {TclExecuteByteCode, INST_DIV, op1 is double} {testobj} { sl@0: set x [testdoubleobj set 1 2.0] sl@0: expr {$x / 1} sl@0: } 2.0 sl@0: test execute-3.39 {TclExecuteByteCode, INST_DIV, op1 is double with string} {testobj} { sl@0: set x [testintobj set 1 2] sl@0: testobj convert 1 double sl@0: expr {$x / 1} sl@0: } 2 sl@0: test execute-3.40 {TclExecuteByteCode, INST_DIV, op1 is string int} {testobj} { sl@0: set x [teststringobj set 1 1] sl@0: expr {$x / 1} sl@0: } 1 sl@0: test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} { sl@0: set x [teststringobj set 1 1.0] sl@0: expr {$x / 1} sl@0: } 1.0 sl@0: test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} { sl@0: set x [teststringobj set 1 foo] sl@0: list [catch {expr {$x / 1}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "/"}} sl@0: test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: expr {2 / $x} sl@0: } 2 sl@0: test execute-3.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} { sl@0: set x [testdoubleobj set 1 1.0] sl@0: expr {2 / $x} sl@0: } 2.0 sl@0: test execute-3.45 {TclExecuteByteCode, INST_DIV, op2 is double with string} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: testobj convert 1 double sl@0: expr {2 / $x} sl@0: } 2 sl@0: test execute-3.46 {TclExecuteByteCode, INST_DIV, op2 is string int} {testobj} { sl@0: set x [teststringobj set 1 1] sl@0: expr {2 / $x} sl@0: } 2 sl@0: test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} { sl@0: set x [teststringobj set 1 1.0] sl@0: expr {2 / $x} sl@0: } 2.0 sl@0: test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} { sl@0: set x [teststringobj set 1 foo] sl@0: list [catch {expr {1 / $x}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "/"}} sl@0: sl@0: # INST_UPLUS is partially tested: sl@0: test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: expr {+ $x} sl@0: } 1 sl@0: test execute-3.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} { sl@0: set x [testdoubleobj set 1 1.0] sl@0: expr {+ $x} sl@0: } 1.0 sl@0: test execute-3.51 {TclExecuteByteCode, INST_UPLUS, op is double with string} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: testobj convert 1 double sl@0: expr {+ $x} sl@0: } 1 sl@0: test execute-3.52 {TclExecuteByteCode, INST_UPLUS, op is string int} {testobj} { sl@0: set x [teststringobj set 1 1] sl@0: expr {+ $x} sl@0: } 1 sl@0: test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} { sl@0: set x [teststringobj set 1 1.0] sl@0: expr {+ $x} sl@0: } 1.0 sl@0: test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} { sl@0: set x [teststringobj set 1 foo] sl@0: list [catch {expr {+ $x}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "+"}} sl@0: sl@0: # INST_UMINUS is partially tested: sl@0: test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: expr {- $x} sl@0: } -1 sl@0: test execute-3.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} { sl@0: set x [testdoubleobj set 1 1.0] sl@0: expr {- $x} sl@0: } -1.0 sl@0: test execute-3.57 {TclExecuteByteCode, INST_UMINUS, op is double with string} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: testobj convert 1 double sl@0: expr {- $x} sl@0: } -1 sl@0: test execute-3.58 {TclExecuteByteCode, INST_UMINUS, op is string int} {testobj} { sl@0: set x [teststringobj set 1 1] sl@0: expr {- $x} sl@0: } -1 sl@0: test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} { sl@0: set x [teststringobj set 1 1.0] sl@0: expr {- $x} sl@0: } -1.0 sl@0: test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} { sl@0: set x [teststringobj set 1 foo] sl@0: list [catch {expr {- $x}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "-"}} sl@0: sl@0: # INST_LNOT is partially tested: sl@0: test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { sl@0: set x [testintobj set 1 2] sl@0: expr {! $x} sl@0: } 0 sl@0: test execute-3.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { sl@0: set x [testintobj set 1 0] sl@0: expr {! $x} sl@0: } 1 sl@0: test execute-3.63 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} { sl@0: set x [testdoubleobj set 1 1.0] sl@0: expr {! $x} sl@0: } 0 sl@0: test execute-3.64 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} { sl@0: set x [testdoubleobj set 1 0.0] sl@0: expr {! $x} sl@0: } 1 sl@0: test execute-3.65 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: testobj convert 1 double sl@0: expr {! $x} sl@0: } 0 sl@0: test execute-3.66 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} { sl@0: set x [testintobj set 1 0] sl@0: testobj convert 1 double sl@0: expr {! $x} sl@0: } 1 sl@0: test execute-3.67 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} { sl@0: set x [teststringobj set 1 1] sl@0: expr {! $x} sl@0: } 0 sl@0: test execute-3.68 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} { sl@0: set x [teststringobj set 1 0] sl@0: expr {! $x} sl@0: } 1 sl@0: test execute-3.69 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { sl@0: set x [teststringobj set 1 1.0] sl@0: expr {! $x} sl@0: } 0 sl@0: test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { sl@0: set x [teststringobj set 1 0.0] sl@0: expr {! $x} sl@0: } 1 sl@0: test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { sl@0: set x [teststringobj set 1 foo] sl@0: list [catch {expr {! $x}} msg] $msg sl@0: } {1 {can't use non-numeric string as operand of "!"}} sl@0: sl@0: # INST_BITNOT not tested sl@0: # INST_CALL_BUILTIN_FUNC1 not tested sl@0: # INST_CALL_FUNC1 not tested sl@0: sl@0: # INST_TRY_CVT_TO_NUMERIC is partially tested: sl@0: test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: expr {$x} sl@0: } 1 sl@0: test execute-3.73 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double} {testobj} { sl@0: set x [testdoubleobj set 1 1.0] sl@0: expr {$x} sl@0: } 1.0 sl@0: test execute-3.74 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double with string} {testobj} { sl@0: set x [testintobj set 1 1] sl@0: testobj convert 1 double sl@0: expr {$x} sl@0: } 1 sl@0: test execute-3.75 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string int} {testobj} { sl@0: set x [teststringobj set 1 1] sl@0: expr {$x} sl@0: } 1 sl@0: test execute-3.76 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string double} {testobj} { sl@0: set x [teststringobj set 1 1.0] sl@0: expr {$x} sl@0: } 1.0 sl@0: test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeric} {testobj} { sl@0: set x [teststringobj set 1 foo] sl@0: expr {$x} sl@0: } foo sl@0: sl@0: # INST_BREAK not tested sl@0: # INST_CONTINUE not tested sl@0: # INST_FOREACH_START4 not tested sl@0: # INST_FOREACH_STEP4 not tested sl@0: # INST_BEGIN_CATCH4 not tested sl@0: # INST_END_CATCH not tested sl@0: # INST_PUSH_RESULT not tested sl@0: # INST_PUSH_RETURN_CODE not tested sl@0: sl@0: test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { sl@0: catch {eval namespace delete [namespace children :: test_ns_*]} sl@0: catch {unset x} sl@0: catch {unset y} sl@0: namespace eval test_ns_1 { sl@0: namespace export cmd1 sl@0: proc cmd1 {args} {return "cmd1: $args"} sl@0: proc cmd2 {args} {return "cmd2: $args"} sl@0: } sl@0: namespace eval test_ns_1::test_ns_2 { sl@0: namespace import ::test_ns_1::* sl@0: } sl@0: set x "test_ns_1::" sl@0: set y "test_ns_2::" sl@0: list [namespace which -command ${x}${y}cmd1] \ sl@0: [catch {namespace which -command ${x}${y}cmd2} msg] $msg \ sl@0: [catch {namespace which -command ${x}${y}:cmd2} msg] $msg sl@0: } {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} sl@0: test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { sl@0: catch {eval namespace delete [namespace children :: test_ns_*]} sl@0: catch {rename foo ""} sl@0: catch {unset l} sl@0: proc foo {} { sl@0: return "global foo" sl@0: } sl@0: namespace eval test_ns_1 { sl@0: proc whichFoo {} { sl@0: return [namespace which -command foo] sl@0: } sl@0: } sl@0: set l "" sl@0: lappend l [test_ns_1::whichFoo] sl@0: namespace eval test_ns_1 { sl@0: proc foo {} { sl@0: return "namespace foo" sl@0: } sl@0: } sl@0: lappend l [test_ns_1::whichFoo] sl@0: set l sl@0: } {::foo ::test_ns_1::foo} sl@0: test execute-4.3 {Tcl_GetCommandFromObj, command never found} { sl@0: catch {eval namespace delete [namespace children :: test_ns_*]} sl@0: catch {rename foo ""} sl@0: namespace eval test_ns_1 { sl@0: proc foo {} { sl@0: return "namespace foo" sl@0: } sl@0: } sl@0: namespace eval test_ns_1 { sl@0: proc foo {} { sl@0: return "namespace foo" sl@0: } sl@0: } sl@0: list [namespace eval test_ns_1 {namespace which -command foo}] \ sl@0: [rename test_ns_1::foo ""] \ sl@0: [catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg sl@0: } {::test_ns_1::foo {} 0 {}} sl@0: sl@0: test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { sl@0: catch {eval namespace delete [namespace children :: test_ns_*]} sl@0: catch {unset l} sl@0: proc {} {} {return {}} sl@0: {} sl@0: set l {} sl@0: lindex {} 0 sl@0: {} sl@0: } {} sl@0: sl@0: test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { sl@0: proc {} {} {} sl@0: proc { } {} {} sl@0: proc p {} { sl@0: set x {} sl@0: $x sl@0: append x { } sl@0: $x sl@0: } sl@0: p sl@0: } {} sl@0: sl@0: test execute-6.2 {Evaluate an expression in a variable; compile the first time, do not the second} { sl@0: set w {3*5} sl@0: proc a {obj} {expr $obj} sl@0: set res "[a $w]:[a $w]" sl@0: } {15:15} sl@0: sl@0: test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { sl@0: set x 0x100000000 sl@0: expr {$x && 1} sl@0: } 1 sl@0: test execute-7.1 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { sl@0: expr {0x100000000 && 1} sl@0: } 1 sl@0: test execute-7.2 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { sl@0: expr {1 && 0x100000000} sl@0: } 1 sl@0: test execute-7.3 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { sl@0: expr {wide(0x100000000) && 1} sl@0: } 1 sl@0: test execute-7.4 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { sl@0: expr {1 && wide(0x100000000)} sl@0: } 1 sl@0: test execute-7.5 {Wide int handling in INST_EQ} {longIs32bit} { sl@0: expr {4 == (wide(1)+wide(3))} sl@0: } 1 sl@0: test execute-7.6 {Wide int handling in INST_EQ and [incr]} {longIs32bit} { sl@0: set x 399999999999 sl@0: expr {400000000000 == [incr x]} sl@0: } 1 sl@0: # wide ints have more bits of precision than doubles, but we convert anyway sl@0: test execute-7.7 {Wide int handling in INST_EQ and [incr]} {longIs32bit} { sl@0: set x [expr {wide(1)<<62}] sl@0: set y [expr {$x+1}] sl@0: expr {double($x) == double($y)} sl@0: } 1 sl@0: test execute-7.8 {Wide int conversions can change sign} {longIs32bit} { sl@0: set x 0x80000000 sl@0: expr {int($x) < wide($x)} sl@0: } 1 sl@0: test execute-7.9 {Wide int handling in INST_MOD} {longIs32bit} { sl@0: expr {(wide(1)<<60) % ((wide(47)<<45)-1)} sl@0: } 316659348800185 sl@0: test execute-7.10 {Wide int handling in INST_MOD} {longIs32bit} { sl@0: expr {((wide(1)<<60)-1) % 0x400000000} sl@0: } 17179869183 sl@0: test execute-7.11 {Wide int handling in INST_LSHIFT} {longIs32bit} { sl@0: expr wide(42)<<30 sl@0: } 45097156608 sl@0: test execute-7.12 {Wide int handling in INST_LSHIFT} {longIs32bit} { sl@0: expr 12345678901<<3 sl@0: } 98765431208 sl@0: test execute-7.13 {Wide int handling in INST_RSHIFT} {longIs32bit} { sl@0: expr 0x543210febcda9876>>7 sl@0: } 47397893236700464 sl@0: test execute-7.14 {Wide int handling in INST_RSHIFT} {longIs32bit} { sl@0: expr 0x9876543210febcda>>7 sl@0: } -58286587177206407 sl@0: test execute-7.15 {Wide int handling in INST_BITOR} {longIs32bit} { sl@0: expr 0x9876543210febcda | 0x543210febcda9876 sl@0: } -2560765885044310786 sl@0: test execute-7.16 {Wide int handling in INST_BITXOR} {longIs32bit} { sl@0: expr 0x9876543210febcda ^ 0x543210febcda9876 sl@0: } -3727778945703861076 sl@0: test execute-7.17 {Wide int handling in INST_BITAND} {longIs32bit} { sl@0: expr 0x9876543210febcda & 0x543210febcda9876 sl@0: } 1167013060659550290 sl@0: test execute-7.18 {Wide int handling in INST_ADD} {longIs32bit} { sl@0: expr wide(0x7fffffff)+wide(0x7fffffff) sl@0: } 4294967294 sl@0: test execute-7.19 {Wide int handling in INST_ADD} {longIs32bit} { sl@0: expr 0x7fffffff+wide(0x7fffffff) sl@0: } 4294967294 sl@0: test execute-7.20 {Wide int handling in INST_ADD} {longIs32bit} { sl@0: expr wide(0x7fffffff)+0x7fffffff sl@0: } 4294967294 sl@0: test execute-7.21 {Wide int handling in INST_ADD} {longIs32bit} { sl@0: expr double(0x7fffffff)+wide(0x7fffffff) sl@0: } 4294967294.0 sl@0: test execute-7.22 {Wide int handling in INST_ADD} {longIs32bit} { sl@0: expr wide(0x7fffffff)+double(0x7fffffff) sl@0: } 4294967294.0 sl@0: test execute-7.23 {Wide int handling in INST_SUB} {longIs32bit} { sl@0: expr 0x123456789a-0x20406080a sl@0: } 69530054800 sl@0: test execute-7.24 {Wide int handling in INST_MULT} {longIs32bit} { sl@0: expr 0x123456789a*193 sl@0: } 15090186251290 sl@0: test execute-7.25 {Wide int handling in INST_DIV} {longIs32bit} { sl@0: expr 0x123456789a/193 sl@0: } 405116546 sl@0: test execute-7.26 {Wide int handling in INST_UPLUS} {longIs32bit} { sl@0: set x 0x123456871234568 sl@0: expr {+ $x} sl@0: } 81985533099853160 sl@0: test execute-7.27 {Wide int handling in INST_UMINUS} {longIs32bit} { sl@0: set x 0x123456871234568 sl@0: expr {- $x} sl@0: } -81985533099853160 sl@0: test execute-7.28 {Wide int handling in INST_LNOT} {longIs32bit} { sl@0: set x 0x123456871234568 sl@0: expr {! $x} sl@0: } 0 sl@0: test execute-7.29 {Wide int handling in INST_BITNOT} {longIs32bit} { sl@0: set x 0x123456871234568 sl@0: expr {~ $x} sl@0: } -81985533099853161 sl@0: test execute-7.30 {Wide int handling in function call} {longIs32bit} { sl@0: set x 0x12345687123456 sl@0: incr x sl@0: expr {log($x) == log(double($x))} sl@0: } 1 sl@0: test execute-7.31 {Wide int handling in abs()} {longIs32bit} { sl@0: set x 0xa23456871234568 sl@0: incr x sl@0: set y 0x123456871234568 sl@0: concat [expr {abs($x)}] [expr {abs($y)}] sl@0: } {730503879441204585 81985533099853160} sl@0: test execute-7.32 {Wide int handling} {longIs32bit} { sl@0: expr {1024 * 1024 * 1024 * 1024} sl@0: } 0 sl@0: test execute-7.33 {Wide int handling} {longIs32bit} { sl@0: expr {0x1 * 1024 * 1024 * 1024 * 1024} sl@0: } 0 sl@0: test execute-7.34 {Wide int handling} {longIs32bit} { sl@0: expr {wide(0x1) * 1024 * 1024 * 1024 * 1024} sl@0: } 1099511627776 sl@0: sl@0: test execute-8.1 {Stack protection} -setup { sl@0: # If [Bug #804681] has not been properly sl@0: # taken care of, this should segfault sl@0: proc whatever args {llength $args} sl@0: trace add variable ::errorInfo {write unset} whatever sl@0: } -body { sl@0: expr {1+9/0} sl@0: } -cleanup { sl@0: trace remove variable ::errorInfo {write unset} whatever sl@0: rename whatever {} sl@0: } -returnCodes error -match glob -result * sl@0: sl@0: # cleanup sl@0: if {[info commands testobj] != {}} { sl@0: testobj freeallvars sl@0: } sl@0: catch {eval namespace delete [namespace children :: test_ns_*]} sl@0: catch {rename foo ""} sl@0: catch {rename p ""} sl@0: catch {rename {} ""} sl@0: catch {rename { } ""} sl@0: catch {unset x} sl@0: catch {unset y} sl@0: catch {unset msg} sl@0: ::tcltest::cleanupTests sl@0: return