# 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. # # 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.27.2.3 2009/06/13 14:27:43 dgp Exp $ if {[lsearch [namespace children] ::tcltest] == -1} { package require tcltest 2 namespace import -force ::tcltest::* } catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} catch {unset x} catch {unset y} catch {unset msg} 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 # 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 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 # 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-3.1 {TclExecuteByteCode, INST_ADD, op1 is int} {testobj} { set x [testintobj set 0 1] expr {$x + 1} } 2 test execute-3.2 {TclExecuteByteCode, INST_ADD, op1 is double} {testobj} { set x [testdoubleobj set 0 1] expr {$x + 1} } 2.0 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-3.4 {TclExecuteByteCode, INST_ADD, op1 is string int} {testobj} { set x [teststringobj set 0 1] expr {$x + 1} } 2 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-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-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 + $x} } 2 test execute-3.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} { set x [testdoubleobj set 0 1] expr {1 + $x} } 2.0 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-3.10 {TclExecuteByteCode, INST_ADD, op2 is string int} {testobj} { set x [teststringobj set 0 1] expr {1 + $x} } 2 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-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-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { set x [testintobj set 0 1] expr {$x - 1} } 0 test execute-3.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} { set x [testdoubleobj set 0 1] expr {$x - 1} } 0.0 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-3.16 {TclExecuteByteCode, INST_SUB, op1 is string int} {testobj} { set x [teststringobj set 0 1] expr {$x - 1} } 0 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-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-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { set x [testintobj set 0 1] expr {1 - $x} } 0 test execute-3.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} { set x [testdoubleobj set 0 1] expr {1 - $x} } 0.0 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-3.22 {TclExecuteByteCode, INST_SUB, op2 is string int} {testobj} { set x [teststringobj set 0 1] expr {1 - $x} } 0 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-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-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { set x [testintobj set 1 1] expr {$x * 1} } 1 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-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-3.28 {TclExecuteByteCode, INST_MULT, op1 is string int} {testobj} { set x [teststringobj set 1 1] expr {$x * 1} } 1 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-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-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { set x [testintobj set 1 1] expr {1 * $x} } 1 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-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-3.34 {TclExecuteByteCode, INST_MULT, op2 is string int} {testobj} { set x [teststringobj set 1 1] expr {1 * $x} } 1 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-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-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { set x [testintobj set 1 1] expr {$x / 1} } 1 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-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-3.40 {TclExecuteByteCode, INST_DIV, op1 is string int} {testobj} { set x [teststringobj set 1 1] expr {$x / 1} } 1 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-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-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { set x [testintobj set 1 1] expr {2 / $x} } 2 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-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-3.46 {TclExecuteByteCode, INST_DIV, op2 is string int} {testobj} { set x [teststringobj set 1 1] expr {2 / $x} } 2 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-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-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { set x [testintobj set 1 1] expr {+ $x} } 1 test execute-3.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} { set x [testdoubleobj set 1 1.0] expr {+ $x} } 1.0 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-3.52 {TclExecuteByteCode, INST_UPLUS, op is string int} {testobj} { set x [teststringobj set 1 1] expr {+ $x} } 1 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-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-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { set x [testintobj set 1 1] expr {- $x} } -1 test execute-3.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} { set x [testdoubleobj set 1 1.0] expr {- $x} } -1.0 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-3.58 {TclExecuteByteCode, INST_UMINUS, op is string int} {testobj} { set x [teststringobj set 1 1] expr {- $x} } -1 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-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-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { set x [testintobj set 1 2] expr {! $x} } 0 test execute-3.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { set x [testintobj set 1 0] expr {! $x} } 1 test execute-3.63 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} { set x [testdoubleobj set 1 1.0] expr {! $x} } 0 test execute-3.64 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} { set x [testdoubleobj set 1 0.0] expr {! $x} } 1 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-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-3.67 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} { set x [teststringobj set 1 1] expr {! $x} } 0 test execute-3.68 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} { set x [teststringobj set 1 0] expr {! $x} } 1 test execute-3.69 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { set x [teststringobj set 1 1.0] expr {! $x} } 0 test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { set x [teststringobj set 1 0.0] expr {! $x} } 1 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 "!"}} # 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-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { set x [testintobj set 1 1] expr {$x} } 1 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-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-3.75 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string int} {testobj} { set x [teststringobj set 1 1] expr {$x} } 1 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-3.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-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {unset x} catch {unset y} namespace eval test_ns_1 { namespace export cmd1 proc cmd1 {args} {return "cmd1: $args"} proc cmd2 {args} {return "cmd2: $args"} } namespace eval test_ns_1::test_ns_2 { namespace import ::test_ns_1::* } set x "test_ns_1::" set y "test_ns_2::" 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-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} catch {unset l} proc foo {} { return "global foo" } namespace eval test_ns_1 { proc whichFoo {} { return [namespace which -command foo] } } set l "" lappend l [test_ns_1::whichFoo] namespace eval test_ns_1 { proc foo {} { return "namespace foo" } } lappend l [test_ns_1::whichFoo] set l } {::foo ::test_ns_1::foo} test execute-4.3 {Tcl_GetCommandFromObj, command never found} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} namespace eval test_ns_1 { proc foo {} { return "namespace foo" } } namespace eval test_ns_1 { proc foo {} { return "namespace foo" } } 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 {}} test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { catch {namespace delete {*}[namespace children :: test_ns_*]} catch {unset l} proc {} {} {return {}} {} set l {} lindex {} 0 {} } {} test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { proc {} {} {} proc { } {} {} proc p {} { set x {} $x append x { } $x } 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} { 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] rename $origName {} rename llength.orig $origName set result } {0 AHA!} test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} { proc foo {} {set a 1} set a untouched set result {} lappend result [foo] $a lappend result [if 1 [info body foo]] $a rename foo {} set result } {1 untouched 1 1} test execute-6.7 {TclCompEvalObj: bytecode context validation} { set script { llength {} } namespace eval foo { proc llength {args} {return AHA!} } set result {} lappend result [if 1 $script] lappend result [namespace eval foo $script] namespace delete foo set result } {0 AHA!} test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} { set script { llength {} } set result {} lappend result [namespace eval foo $script] namespace eval foo { proc llength {args} {return AHA!} } lappend result [namespace eval foo $script] namespace delete foo set result } {0 AHA!} test execute-6.9 {TclCompEvalObj: bytecode interp validation} { set script { llength {} } interp create slave slave eval {proc llength args {return AHA!}} set result {} lappend result [if 1 $script] lappend result [slave eval $script] interp delete slave set result } {0 AHA!} test execute-6.10 {TclCompEvalObj: bytecode interp validation} { set script { llength {} } interp create slave set result {} lappend result [slave eval $script] interp delete slave interp create slave lappend result [slave eval $script] interp delete slave set result } {0 0} test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj { set e { [llength {}]+1 } set result {} interp create slave 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] interp delete slave set result } {{This is a result: 1} {This is a result: 1}} test execute-6.12 {Tcl_ExprObj: exprcode interp validation} { set e { [llength {}]+1 } set result {} interp create slave interp alias {} e slave expr lappend result [e $e] interp delete slave interp create slave interp alias {} e slave expr lappend result [e $e] interp delete slave set result } {1 1} test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} { set e { [llength {}]+1 } set result {} lappend result [expr $e] set origName [namespace which llength] rename $origName llength.orig proc $origName {args} {return 1} lappend result [expr $e] rename $origName {} rename llength.orig $origName set result } {1 2} test execute-6.14 {Tcl_ExprObj: exprcode context validation} { set e { [llength {}]+1 } namespace eval foo { proc llength {args} {return 1} } set result {} lappend result [expr $e] lappend result [namespace eval foo {expr $e}] namespace delete foo set result } {1 2} test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} { set e { [llength {}]+1 } set result {} lappend result [namespace eval foo {expr $e}] namespace eval foo { proc llength {args} {return 1} } lappend result [namespace eval foo {expr $e}] namespace delete foo set result } {1 2} test execute-6.16 {Tcl_ExprObj: exprcode interp validation} { set e { [llength {}]+1 } interp create slave interp alias {} e slave expr slave eval {proc llength args {return 1}} set result {} lappend result [expr $e] lappend result [e $e] interp delete slave set result } {1 2} test execute-6.17 {Tcl_ExprObj: exprcode context validation} { set e { $v } proc foo e {set v 0; expr $e} proc bar e {set v 1; expr $e} set result {} lappend result [foo $e] lappend result [bar $e] rename foo {} rename bar {} set result } {0 1} test execute-6.18 {Tcl_ExprObj: exprcode context validation} { set e { [llength $v] } proc foo e {set v {}; expr $e} proc bar e {set v v; expr $e} set result {} lappend result [foo $e] lappend result [bar $e] rename foo {} rename bar {} set 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} -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 { # 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 * # cleanup if {[info commands testobj] != {}} { testobj freeallvars } catch {namespace delete {*}[namespace children :: test_ns_*]} catch {rename foo ""} catch {rename p ""} catch {rename {} ""} catch {rename { } ""} catch {unset x} catch {unset y} catch {unset msg} ::tcltest::cleanupTests return # Local Variables: # mode: tcl # End: