1# This file contains tests for the tclExecute.c source file. Tests appear 2# in the same order as the C code that they test. The set of tests is 3# currently incomplete since it currently includes only new tests for 4# code changed for the addition of Tcl namespaces. Other execution- 5# related tests appear in several other test files including 6# namespace.test, basic.test, eval.test, for.test, etc. 7# 8# Sourcing this file into Tcl runs the tests and generates output for 9# errors. No output means no errors were found. 10# 11# Copyright (c) 1997 Sun Microsystems, Inc. 12# Copyright (c) 1998-1999 by Scriptics Corporation. 13# 14# See the file "license.terms" for information on usage and redistribution 15# of this file, and for a DISCLAIMER OF ALL WARRANTIES. 16# 17# RCS: @(#) $Id: execute.test,v 1.13.2.4 2008/03/07 20:26:22 dgp Exp $ 18 19if {[lsearch [namespace children] ::tcltest] == -1} { 20 package require tcltest 2 21 namespace import -force ::tcltest::* 22} 23 24catch {eval namespace delete [namespace children :: test_ns_*]} 25catch {rename foo ""} 26catch {unset x} 27catch {unset y} 28catch {unset msg} 29 30::tcltest::testConstraint testobj \ 31 [expr {[info commands testobj] != {} \ 32 && [info commands testdoubleobj] != {} \ 33 && [info commands teststringobj] != {} \ 34 && [info commands testobj] != {}}] 35 36::tcltest::testConstraint longIs32bit \ 37 [expr {int(0x80000000) < 0}] 38::tcltest::testConstraint testexprlongobj \ 39 [llength [info commands testexprlongobj]] 40 41# Tests for the omnibus TclExecuteByteCode function: 42 43# INST_DONE not tested 44# INST_PUSH1 not tested 45# INST_PUSH4 not tested 46# INST_POP not tested 47# INST_DUP not tested 48# INST_CONCAT1 not tested 49# INST_INVOKE_STK4 not tested 50# INST_INVOKE_STK1 not tested 51# INST_EVAL_STK not tested 52# INST_EXPR_STK not tested 53 54# INST_LOAD_SCALAR1 55 56test execute-1.1 {TclExecuteByteCode, INST_LOAD_SCALAR1, small opnd} { 57 proc foo {} { 58 set x 1 59 return $x 60 } 61 foo 62} 1 63test execute-1.2 {TclExecuteByteCode, INST_LOAD_SCALAR1, large opnd} { 64 # Bug: 2243 65 set body {} 66 for {set i 0} {$i < 129} {incr i} { 67 append body "set x$i x\n" 68 } 69 append body { 70 set y 1 71 return $y 72 } 73 74 proc foo {} $body 75 foo 76} 1 77test execute-1.3 {TclExecuteByteCode, INST_LOAD_SCALAR1, error} { 78 proc foo {} { 79 set x 1 80 unset x 81 return $x 82 } 83 list [catch {foo} msg] $msg 84} {1 {can't read "x": no such variable}} 85 86 87# INST_LOAD_SCALAR4 88 89test execute-2.1 {TclExecuteByteCode, INST_LOAD_SCALAR4, simple case} { 90 set body {} 91 for {set i 0} {$i < 256} {incr i} { 92 append body "set x$i x\n" 93 } 94 append body { 95 set y 1 96 return $y 97 } 98 99 proc foo {} $body 100 foo 101} 1 102test execute-2.2 {TclExecuteByteCode, INST_LOAD_SCALAR4, error} { 103 set body {} 104 for {set i 0} {$i < 256} {incr i} { 105 append body "set x$i x\n" 106 } 107 append body { 108 set y 1 109 unset y 110 return $y 111 } 112 113 proc foo {} $body 114 list [catch {foo} msg] $msg 115} {1 {can't read "y": no such variable}} 116 117 118# INST_LOAD_SCALAR_STK not tested 119# INST_LOAD_ARRAY4 not tested 120# INST_LOAD_ARRAY1 not tested 121# INST_LOAD_ARRAY_STK not tested 122# INST_LOAD_STK not tested 123# INST_STORE_SCALAR4 not tested 124# INST_STORE_SCALAR1 not tested 125# INST_STORE_SCALAR_STK not tested 126# INST_STORE_ARRAY4 not tested 127# INST_STORE_ARRAY1 not tested 128# INST_STORE_ARRAY_STK not tested 129# INST_STORE_STK not tested 130# INST_INCR_SCALAR1 not tested 131# INST_INCR_SCALAR_STK not tested 132# INST_INCR_STK not tested 133# INST_INCR_ARRAY1 not tested 134# INST_INCR_ARRAY_STK not tested 135# INST_INCR_SCALAR1_IMM not tested 136# INST_INCR_SCALAR_STK_IMM not tested 137# INST_INCR_STK_IMM not tested 138# INST_INCR_ARRAY1_IMM not tested 139# INST_INCR_ARRAY_STK_IMM not tested 140# INST_JUMP1 not tested 141# INST_JUMP4 not tested 142# INST_JUMP_TRUE4 not tested 143# INST_JUMP_TRUE1 not tested 144# INST_JUMP_FALSE4 not tested 145# INST_JUMP_FALSE1 not tested 146# INST_LOR not tested 147# INST_LAND not tested 148# INST_EQ not tested 149# INST_NEQ not tested 150# INST_LT not tested 151# INST_GT not tested 152# INST_LE not tested 153# INST_GE not tested 154# INST_MOD not tested 155# INST_LSHIFT not tested 156# INST_RSHIFT not tested 157# INST_BITOR not tested 158# INST_BITXOR not tested 159# INST_BITAND not tested 160 161# INST_ADD is partially tested: 162test execute-3.1 {TclExecuteByteCode, INST_ADD, op1 is int} {testobj} { 163 set x [testintobj set 0 1] 164 expr {$x + 1} 165} 2 166test execute-3.2 {TclExecuteByteCode, INST_ADD, op1 is double} {testobj} { 167 set x [testdoubleobj set 0 1] 168 expr {$x + 1} 169} 2.0 170test execute-3.3 {TclExecuteByteCode, INST_ADD, op1 is double with string} {testobj} { 171 set x [testintobj set 0 1] 172 testobj convert 0 double 173 expr {$x + 1} 174} 2 175test execute-3.4 {TclExecuteByteCode, INST_ADD, op1 is string int} {testobj} { 176 set x [teststringobj set 0 1] 177 expr {$x + 1} 178} 2 179test execute-3.5 {TclExecuteByteCode, INST_ADD, op1 is string double} {testobj} { 180 set x [teststringobj set 0 1.0] 181 expr {$x + 1} 182} 2.0 183test execute-3.6 {TclExecuteByteCode, INST_ADD, op1 is non-numeric} {testobj} { 184 set x [teststringobj set 0 foo] 185 list [catch {expr {$x + 1}} msg] $msg 186} {1 {can't use non-numeric string as operand of "+"}} 187test execute-3.7 {TclExecuteByteCode, INST_ADD, op2 is int} {testobj} { 188 set x [testintobj set 0 1] 189 expr {1 + $x} 190} 2 191test execute-3.8 {TclExecuteByteCode, INST_ADD, op2 is double} {testobj} { 192 set x [testdoubleobj set 0 1] 193 expr {1 + $x} 194} 2.0 195test execute-3.9 {TclExecuteByteCode, INST_ADD, op2 is double with string} {testobj} { 196 set x [testintobj set 0 1] 197 testobj convert 0 double 198 expr {1 + $x} 199} 2 200test execute-3.10 {TclExecuteByteCode, INST_ADD, op2 is string int} {testobj} { 201 set x [teststringobj set 0 1] 202 expr {1 + $x} 203} 2 204test execute-3.11 {TclExecuteByteCode, INST_ADD, op2 is string double} {testobj} { 205 set x [teststringobj set 0 1.0] 206 expr {1 + $x} 207} 2.0 208test execute-3.12 {TclExecuteByteCode, INST_ADD, op2 is non-numeric} {testobj} { 209 set x [teststringobj set 0 foo] 210 list [catch {expr {1 + $x}} msg] $msg 211} {1 {can't use non-numeric string as operand of "+"}} 212 213# INST_SUB is partially tested: 214test execute-3.13 {TclExecuteByteCode, INST_SUB, op1 is int} {testobj} { 215 set x [testintobj set 0 1] 216 expr {$x - 1} 217} 0 218test execute-3.14 {TclExecuteByteCode, INST_SUB, op1 is double} {testobj} { 219 set x [testdoubleobj set 0 1] 220 expr {$x - 1} 221} 0.0 222test execute-3.15 {TclExecuteByteCode, INST_SUB, op1 is double with string} {testobj} { 223 set x [testintobj set 0 1] 224 testobj convert 0 double 225 expr {$x - 1} 226} 0 227test execute-3.16 {TclExecuteByteCode, INST_SUB, op1 is string int} {testobj} { 228 set x [teststringobj set 0 1] 229 expr {$x - 1} 230} 0 231test execute-3.17 {TclExecuteByteCode, INST_SUB, op1 is string double} {testobj} { 232 set x [teststringobj set 0 1.0] 233 expr {$x - 1} 234} 0.0 235test execute-3.18 {TclExecuteByteCode, INST_SUB, op1 is non-numeric} {testobj} { 236 set x [teststringobj set 0 foo] 237 list [catch {expr {$x - 1}} msg] $msg 238} {1 {can't use non-numeric string as operand of "-"}} 239test execute-3.19 {TclExecuteByteCode, INST_SUB, op2 is int} {testobj} { 240 set x [testintobj set 0 1] 241 expr {1 - $x} 242} 0 243test execute-3.20 {TclExecuteByteCode, INST_SUB, op2 is double} {testobj} { 244 set x [testdoubleobj set 0 1] 245 expr {1 - $x} 246} 0.0 247test execute-3.21 {TclExecuteByteCode, INST_SUB, op2 is double with string} {testobj} { 248 set x [testintobj set 0 1] 249 testobj convert 0 double 250 expr {1 - $x} 251} 0 252test execute-3.22 {TclExecuteByteCode, INST_SUB, op2 is string int} {testobj} { 253 set x [teststringobj set 0 1] 254 expr {1 - $x} 255} 0 256test execute-3.23 {TclExecuteByteCode, INST_SUB, op2 is string double} {testobj} { 257 set x [teststringobj set 0 1.0] 258 expr {1 - $x} 259} 0.0 260test execute-3.24 {TclExecuteByteCode, INST_SUB, op2 is non-numeric} {testobj} { 261 set x [teststringobj set 0 foo] 262 list [catch {expr {1 - $x}} msg] $msg 263} {1 {can't use non-numeric string as operand of "-"}} 264 265# INST_MULT is partially tested: 266test execute-3.25 {TclExecuteByteCode, INST_MULT, op1 is int} {testobj} { 267 set x [testintobj set 1 1] 268 expr {$x * 1} 269} 1 270test execute-3.26 {TclExecuteByteCode, INST_MULT, op1 is double} {testobj} { 271 set x [testdoubleobj set 1 2.0] 272 expr {$x * 1} 273} 2.0 274test execute-3.27 {TclExecuteByteCode, INST_MULT, op1 is double with string} {testobj} { 275 set x [testintobj set 1 2] 276 testobj convert 1 double 277 expr {$x * 1} 278} 2 279test execute-3.28 {TclExecuteByteCode, INST_MULT, op1 is string int} {testobj} { 280 set x [teststringobj set 1 1] 281 expr {$x * 1} 282} 1 283test execute-3.29 {TclExecuteByteCode, INST_MULT, op1 is string double} {testobj} { 284 set x [teststringobj set 1 1.0] 285 expr {$x * 1} 286} 1.0 287test execute-3.30 {TclExecuteByteCode, INST_MULT, op1 is non-numeric} {testobj} { 288 set x [teststringobj set 1 foo] 289 list [catch {expr {$x * 1}} msg] $msg 290} {1 {can't use non-numeric string as operand of "*"}} 291test execute-3.31 {TclExecuteByteCode, INST_MULT, op2 is int} {testobj} { 292 set x [testintobj set 1 1] 293 expr {1 * $x} 294} 1 295test execute-3.32 {TclExecuteByteCode, INST_MULT, op2 is double} {testobj} { 296 set x [testdoubleobj set 1 2.0] 297 expr {1 * $x} 298} 2.0 299test execute-3.33 {TclExecuteByteCode, INST_MULT, op2 is double with string} {testobj} { 300 set x [testintobj set 1 2] 301 testobj convert 1 double 302 expr {1 * $x} 303} 2 304test execute-3.34 {TclExecuteByteCode, INST_MULT, op2 is string int} {testobj} { 305 set x [teststringobj set 1 1] 306 expr {1 * $x} 307} 1 308test execute-3.35 {TclExecuteByteCode, INST_MULT, op2 is string double} {testobj} { 309 set x [teststringobj set 1 1.0] 310 expr {1 * $x} 311} 1.0 312test execute-3.36 {TclExecuteByteCode, INST_MULT, op2 is non-numeric} {testobj} { 313 set x [teststringobj set 1 foo] 314 list [catch {expr {1 * $x}} msg] $msg 315} {1 {can't use non-numeric string as operand of "*"}} 316 317# INST_DIV is partially tested: 318test execute-3.37 {TclExecuteByteCode, INST_DIV, op1 is int} {testobj} { 319 set x [testintobj set 1 1] 320 expr {$x / 1} 321} 1 322test execute-3.38 {TclExecuteByteCode, INST_DIV, op1 is double} {testobj} { 323 set x [testdoubleobj set 1 2.0] 324 expr {$x / 1} 325} 2.0 326test execute-3.39 {TclExecuteByteCode, INST_DIV, op1 is double with string} {testobj} { 327 set x [testintobj set 1 2] 328 testobj convert 1 double 329 expr {$x / 1} 330} 2 331test execute-3.40 {TclExecuteByteCode, INST_DIV, op1 is string int} {testobj} { 332 set x [teststringobj set 1 1] 333 expr {$x / 1} 334} 1 335test execute-3.41 {TclExecuteByteCode, INST_DIV, op1 is string double} {testobj} { 336 set x [teststringobj set 1 1.0] 337 expr {$x / 1} 338} 1.0 339test execute-3.42 {TclExecuteByteCode, INST_DIV, op1 is non-numeric} {testobj} { 340 set x [teststringobj set 1 foo] 341 list [catch {expr {$x / 1}} msg] $msg 342} {1 {can't use non-numeric string as operand of "/"}} 343test execute-3.43 {TclExecuteByteCode, INST_DIV, op2 is int} {testobj} { 344 set x [testintobj set 1 1] 345 expr {2 / $x} 346} 2 347test execute-3.44 {TclExecuteByteCode, INST_DIV, op2 is double} {testobj} { 348 set x [testdoubleobj set 1 1.0] 349 expr {2 / $x} 350} 2.0 351test execute-3.45 {TclExecuteByteCode, INST_DIV, op2 is double with string} {testobj} { 352 set x [testintobj set 1 1] 353 testobj convert 1 double 354 expr {2 / $x} 355} 2 356test execute-3.46 {TclExecuteByteCode, INST_DIV, op2 is string int} {testobj} { 357 set x [teststringobj set 1 1] 358 expr {2 / $x} 359} 2 360test execute-3.47 {TclExecuteByteCode, INST_DIV, op2 is string double} {testobj} { 361 set x [teststringobj set 1 1.0] 362 expr {2 / $x} 363} 2.0 364test execute-3.48 {TclExecuteByteCode, INST_DIV, op2 is non-numeric} {testobj} { 365 set x [teststringobj set 1 foo] 366 list [catch {expr {1 / $x}} msg] $msg 367} {1 {can't use non-numeric string as operand of "/"}} 368 369# INST_UPLUS is partially tested: 370test execute-3.49 {TclExecuteByteCode, INST_UPLUS, op is int} {testobj} { 371 set x [testintobj set 1 1] 372 expr {+ $x} 373} 1 374test execute-3.50 {TclExecuteByteCode, INST_UPLUS, op is double} {testobj} { 375 set x [testdoubleobj set 1 1.0] 376 expr {+ $x} 377} 1.0 378test execute-3.51 {TclExecuteByteCode, INST_UPLUS, op is double with string} {testobj} { 379 set x [testintobj set 1 1] 380 testobj convert 1 double 381 expr {+ $x} 382} 1 383test execute-3.52 {TclExecuteByteCode, INST_UPLUS, op is string int} {testobj} { 384 set x [teststringobj set 1 1] 385 expr {+ $x} 386} 1 387test execute-3.53 {TclExecuteByteCode, INST_UPLUS, op is string double} {testobj} { 388 set x [teststringobj set 1 1.0] 389 expr {+ $x} 390} 1.0 391test execute-3.54 {TclExecuteByteCode, INST_UPLUS, op is non-numeric} {testobj} { 392 set x [teststringobj set 1 foo] 393 list [catch {expr {+ $x}} msg] $msg 394} {1 {can't use non-numeric string as operand of "+"}} 395 396# INST_UMINUS is partially tested: 397test execute-3.55 {TclExecuteByteCode, INST_UMINUS, op is int} {testobj} { 398 set x [testintobj set 1 1] 399 expr {- $x} 400} -1 401test execute-3.56 {TclExecuteByteCode, INST_UMINUS, op is double} {testobj} { 402 set x [testdoubleobj set 1 1.0] 403 expr {- $x} 404} -1.0 405test execute-3.57 {TclExecuteByteCode, INST_UMINUS, op is double with string} {testobj} { 406 set x [testintobj set 1 1] 407 testobj convert 1 double 408 expr {- $x} 409} -1 410test execute-3.58 {TclExecuteByteCode, INST_UMINUS, op is string int} {testobj} { 411 set x [teststringobj set 1 1] 412 expr {- $x} 413} -1 414test execute-3.59 {TclExecuteByteCode, INST_UMINUS, op is string double} {testobj} { 415 set x [teststringobj set 1 1.0] 416 expr {- $x} 417} -1.0 418test execute-3.60 {TclExecuteByteCode, INST_UMINUS, op is non-numeric} {testobj} { 419 set x [teststringobj set 1 foo] 420 list [catch {expr {- $x}} msg] $msg 421} {1 {can't use non-numeric string as operand of "-"}} 422 423# INST_LNOT is partially tested: 424test execute-3.61 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { 425 set x [testintobj set 1 2] 426 expr {! $x} 427} 0 428test execute-3.62 {TclExecuteByteCode, INST_LNOT, op is int} {testobj} { 429 set x [testintobj set 1 0] 430 expr {! $x} 431} 1 432test execute-3.63 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} { 433 set x [testdoubleobj set 1 1.0] 434 expr {! $x} 435} 0 436test execute-3.64 {TclExecuteByteCode, INST_LNOT, op is double} {testobj} { 437 set x [testdoubleobj set 1 0.0] 438 expr {! $x} 439} 1 440test execute-3.65 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} { 441 set x [testintobj set 1 1] 442 testobj convert 1 double 443 expr {! $x} 444} 0 445test execute-3.66 {TclExecuteByteCode, INST_LNOT, op is double with string} {testobj} { 446 set x [testintobj set 1 0] 447 testobj convert 1 double 448 expr {! $x} 449} 1 450test execute-3.67 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} { 451 set x [teststringobj set 1 1] 452 expr {! $x} 453} 0 454test execute-3.68 {TclExecuteByteCode, INST_LNOT, op is string int} {testobj} { 455 set x [teststringobj set 1 0] 456 expr {! $x} 457} 1 458test execute-3.69 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { 459 set x [teststringobj set 1 1.0] 460 expr {! $x} 461} 0 462test execute-3.70 {TclExecuteByteCode, INST_LNOT, op is string double} {testobj} { 463 set x [teststringobj set 1 0.0] 464 expr {! $x} 465} 1 466test execute-3.71 {TclExecuteByteCode, INST_LNOT, op is non-numeric} {testobj} { 467 set x [teststringobj set 1 foo] 468 list [catch {expr {! $x}} msg] $msg 469} {1 {can't use non-numeric string as operand of "!"}} 470 471# INST_BITNOT not tested 472# INST_CALL_BUILTIN_FUNC1 not tested 473# INST_CALL_FUNC1 not tested 474 475# INST_TRY_CVT_TO_NUMERIC is partially tested: 476test execute-3.72 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is int} {testobj} { 477 set x [testintobj set 1 1] 478 expr {$x} 479} 1 480test execute-3.73 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double} {testobj} { 481 set x [testdoubleobj set 1 1.0] 482 expr {$x} 483} 1.0 484test execute-3.74 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is double with string} {testobj} { 485 set x [testintobj set 1 1] 486 testobj convert 1 double 487 expr {$x} 488} 1 489test execute-3.75 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string int} {testobj} { 490 set x [teststringobj set 1 1] 491 expr {$x} 492} 1 493test execute-3.76 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is string double} {testobj} { 494 set x [teststringobj set 1 1.0] 495 expr {$x} 496} 1.0 497test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeric} {testobj} { 498 set x [teststringobj set 1 foo] 499 expr {$x} 500} foo 501 502# INST_BREAK not tested 503# INST_CONTINUE not tested 504# INST_FOREACH_START4 not tested 505# INST_FOREACH_STEP4 not tested 506# INST_BEGIN_CATCH4 not tested 507# INST_END_CATCH not tested 508# INST_PUSH_RESULT not tested 509# INST_PUSH_RETURN_CODE not tested 510 511test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} { 512 catch {eval namespace delete [namespace children :: test_ns_*]} 513 catch {unset x} 514 catch {unset y} 515 namespace eval test_ns_1 { 516 namespace export cmd1 517 proc cmd1 {args} {return "cmd1: $args"} 518 proc cmd2 {args} {return "cmd2: $args"} 519 } 520 namespace eval test_ns_1::test_ns_2 { 521 namespace import ::test_ns_1::* 522 } 523 set x "test_ns_1::" 524 set y "test_ns_2::" 525 list [namespace which -command ${x}${y}cmd1] \ 526 [catch {namespace which -command ${x}${y}cmd2} msg] $msg \ 527 [catch {namespace which -command ${x}${y}:cmd2} msg] $msg 528} {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}} 529test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} { 530 catch {eval namespace delete [namespace children :: test_ns_*]} 531 catch {rename foo ""} 532 catch {unset l} 533 proc foo {} { 534 return "global foo" 535 } 536 namespace eval test_ns_1 { 537 proc whichFoo {} { 538 return [namespace which -command foo] 539 } 540 } 541 set l "" 542 lappend l [test_ns_1::whichFoo] 543 namespace eval test_ns_1 { 544 proc foo {} { 545 return "namespace foo" 546 } 547 } 548 lappend l [test_ns_1::whichFoo] 549 set l 550} {::foo ::test_ns_1::foo} 551test execute-4.3 {Tcl_GetCommandFromObj, command never found} { 552 catch {eval namespace delete [namespace children :: test_ns_*]} 553 catch {rename foo ""} 554 namespace eval test_ns_1 { 555 proc foo {} { 556 return "namespace foo" 557 } 558 } 559 namespace eval test_ns_1 { 560 proc foo {} { 561 return "namespace foo" 562 } 563 } 564 list [namespace eval test_ns_1 {namespace which -command foo}] \ 565 [rename test_ns_1::foo ""] \ 566 [catch {namespace eval test_ns_1 {namespace which -command foo}} msg] $msg 567} {::test_ns_1::foo {} 0 {}} 568 569test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} { 570 catch {eval namespace delete [namespace children :: test_ns_*]} 571 catch {unset l} 572 proc {} {} {return {}} 573 {} 574 set l {} 575 lindex {} 0 576 {} 577} {} 578 579test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} { 580 proc {} {} {} 581 proc { } {} {} 582 proc p {} { 583 set x {} 584 $x 585 append x { } 586 $x 587 } 588 p 589} {} 590test execute-6.2 {Evaluate an expression in a variable; compile the first time, do not the second} { 591 set w {3*5} 592 proc a {obj} {expr $obj} 593 set res "[a $w]:[a $w]" 594} {15:15} 595test execute-6.3 {Tcl_ExprObj: don't use cached script bytecode [Bug 1899164]} -setup { 596 proc 0+0 {} {return SCRIPT} 597} -body { 598 set e { 0+0 } 599 if 1 $e 600 if 1 {expr $e} 601} -cleanup { 602 rename 0+0 {} 603} -result 0 604test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]} -setup { 605 proc 0+0 {} {return SCRIPT} 606} -body { 607 set e { 0+0 } 608 if 1 {expr $e} 609 if 1 $e 610} -cleanup { 611 rename 0+0 {} 612} -result SCRIPT 613test execute-6.5 {TclCompEvalObj: bytecode epoch validation} { 614 set script { llength {} } 615 set result {} 616 lappend result [if 1 $script] 617 set origName [namespace which llength] 618 rename $origName llength.orig 619 proc $origName {args} {return AHA!} 620 lappend result [if 1 $script] 621 rename $origName {} 622 rename llength.orig $origName 623 set result 624} {0 AHA!} 625test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} { 626 proc foo {} {set a 1} 627 set a untouched 628 set result {} 629 lappend result [foo] $a 630 lappend result [if 1 [info body foo]] $a 631 rename foo {} 632 set result 633} {1 untouched 1 1} 634test execute-6.7 {TclCompEvalObj: bytecode context validation} { 635 set script { llength {} } 636 namespace eval foo { 637 proc llength {args} {return AHA!} 638 } 639 set result {} 640 lappend result [if 1 $script] 641 lappend result [namespace eval foo $script] 642 namespace delete foo 643 set result 644} {0 AHA!} 645test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} { 646 set script { llength {} } 647 set result {} 648 lappend result [namespace eval foo $script] 649 namespace eval foo { 650 proc llength {args} {return AHA!} 651 } 652 lappend result [namespace eval foo $script] 653 namespace delete foo 654 set result 655} {0 AHA!} 656test execute-6.9 {TclCompEvalObj: bytecode interp validation} { 657 set script { llength {} } 658 interp create slave 659 slave eval {proc llength args {return AHA!}} 660 set result {} 661 lappend result [if 1 $script] 662 lappend result [slave eval $script] 663 interp delete slave 664 set result 665} {0 AHA!} 666test execute-6.10 {TclCompEvalObj: bytecode interp validation} { 667 set script { llength {} } 668 interp create slave 669 set result {} 670 lappend result [slave eval $script] 671 interp delete slave 672 interp create slave 673 lappend result [slave eval $script] 674 interp delete slave 675 set result 676} {0 0} 677test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj { 678 set e { [llength {}]+1 } 679 set result {} 680 interp create slave 681 load {} Tcltest slave 682 interp alias {} e slave testexprlongobj 683 lappend result [e $e] 684 interp delete slave 685 interp create slave 686 load {} Tcltest slave 687 interp alias {} e slave testexprlongobj 688 lappend result [e $e] 689 interp delete slave 690 set result 691} {{This is a result: 1} {This is a result: 1}} 692test execute-6.12 {Tcl_ExprObj: exprcode interp validation} { 693 set e { [llength {}]+1 } 694 set result {} 695 interp create slave 696 interp alias {} e slave expr 697 lappend result [e $e] 698 interp delete slave 699 interp create slave 700 interp alias {} e slave expr 701 lappend result [e $e] 702 interp delete slave 703 set result 704} {1 1} 705test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} { 706 set e { [llength {}]+1 } 707 set result {} 708 lappend result [expr $e] 709 set origName [namespace which llength] 710 rename $origName llength.orig 711 proc $origName {args} {return 1} 712 lappend result [expr $e] 713 rename $origName {} 714 rename llength.orig $origName 715 set result 716} {1 2} 717test execute-6.14 {Tcl_ExprObj: exprcode context validation} { 718 set e { [llength {}]+1 } 719 namespace eval foo { 720 proc llength {args} {return 1} 721 } 722 set result {} 723 lappend result [expr $e] 724 lappend result [namespace eval foo {expr $e}] 725 namespace delete foo 726 set result 727} {1 2} 728test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} { 729 set e { [llength {}]+1 } 730 set result {} 731 lappend result [namespace eval foo {expr $e}] 732 namespace eval foo { 733 proc llength {args} {return 1} 734 } 735 lappend result [namespace eval foo {expr $e}] 736 namespace delete foo 737 set result 738} {1 2} 739test execute-6.16 {Tcl_ExprObj: exprcode interp validation} { 740 set e { [llength {}]+1 } 741 interp create slave 742 interp alias {} e slave expr 743 slave eval {proc llength args {return 1}} 744 set result {} 745 lappend result [expr $e] 746 lappend result [e $e] 747 interp delete slave 748 set result 749} {1 2} 750test execute-6.17 {Tcl_ExprObj: exprcode context validation} { 751 set e { $v } 752 proc foo e {set v 0; expr $e} 753 proc bar e {set v 1; expr $e} 754 set result {} 755 lappend result [foo $e] 756 lappend result [bar $e] 757 rename foo {} 758 rename bar {} 759 set result 760} {0 1} 761test execute-6.18 {Tcl_ExprObj: exprcode context validation} { 762 set e { [llength $v] } 763 proc foo e {set v {}; expr $e} 764 proc bar e {set v v; expr $e} 765 set result {} 766 lappend result [foo $e] 767 lappend result [bar $e] 768 rename foo {} 769 rename bar {} 770 set result 771} {0 1} 772 773 774test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { 775 set x 0x100000000 776 expr {$x && 1} 777} 1 778test execute-7.1 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { 779 expr {0x100000000 && 1} 780} 1 781test execute-7.2 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { 782 expr {1 && 0x100000000} 783} 1 784test execute-7.3 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { 785 expr {wide(0x100000000) && 1} 786} 1 787test execute-7.4 {Wide int handling in INST_JUMP_FALSE/LAND} {longIs32bit} { 788 expr {1 && wide(0x100000000)} 789} 1 790test execute-7.5 {Wide int handling in INST_EQ} {longIs32bit} { 791 expr {4 == (wide(1)+wide(3))} 792} 1 793test execute-7.6 {Wide int handling in INST_EQ and [incr]} {longIs32bit} { 794 set x 399999999999 795 expr {400000000000 == [incr x]} 796} 1 797# wide ints have more bits of precision than doubles, but we convert anyway 798test execute-7.7 {Wide int handling in INST_EQ and [incr]} {longIs32bit} { 799 set x [expr {wide(1)<<62}] 800 set y [expr {$x+1}] 801 expr {double($x) == double($y)} 802} 1 803test execute-7.8 {Wide int conversions can change sign} {longIs32bit} { 804 set x 0x80000000 805 expr {int($x) < wide($x)} 806} 1 807test execute-7.9 {Wide int handling in INST_MOD} {longIs32bit} { 808 expr {(wide(1)<<60) % ((wide(47)<<45)-1)} 809} 316659348800185 810test execute-7.10 {Wide int handling in INST_MOD} {longIs32bit} { 811 expr {((wide(1)<<60)-1) % 0x400000000} 812} 17179869183 813test execute-7.11 {Wide int handling in INST_LSHIFT} {longIs32bit} { 814 expr wide(42)<<30 815} 45097156608 816test execute-7.12 {Wide int handling in INST_LSHIFT} {longIs32bit} { 817 expr 12345678901<<3 818} 98765431208 819test execute-7.13 {Wide int handling in INST_RSHIFT} {longIs32bit} { 820 expr 0x543210febcda9876>>7 821} 47397893236700464 822test execute-7.14 {Wide int handling in INST_RSHIFT} {longIs32bit} { 823 expr 0x9876543210febcda>>7 824} -58286587177206407 825test execute-7.15 {Wide int handling in INST_BITOR} {longIs32bit} { 826 expr 0x9876543210febcda | 0x543210febcda9876 827} -2560765885044310786 828test execute-7.16 {Wide int handling in INST_BITXOR} {longIs32bit} { 829 expr 0x9876543210febcda ^ 0x543210febcda9876 830} -3727778945703861076 831test execute-7.17 {Wide int handling in INST_BITAND} {longIs32bit} { 832 expr 0x9876543210febcda & 0x543210febcda9876 833} 1167013060659550290 834test execute-7.18 {Wide int handling in INST_ADD} {longIs32bit} { 835 expr wide(0x7fffffff)+wide(0x7fffffff) 836} 4294967294 837test execute-7.19 {Wide int handling in INST_ADD} {longIs32bit} { 838 expr 0x7fffffff+wide(0x7fffffff) 839} 4294967294 840test execute-7.20 {Wide int handling in INST_ADD} {longIs32bit} { 841 expr wide(0x7fffffff)+0x7fffffff 842} 4294967294 843test execute-7.21 {Wide int handling in INST_ADD} {longIs32bit} { 844 expr double(0x7fffffff)+wide(0x7fffffff) 845} 4294967294.0 846test execute-7.22 {Wide int handling in INST_ADD} {longIs32bit} { 847 expr wide(0x7fffffff)+double(0x7fffffff) 848} 4294967294.0 849test execute-7.23 {Wide int handling in INST_SUB} {longIs32bit} { 850 expr 0x123456789a-0x20406080a 851} 69530054800 852test execute-7.24 {Wide int handling in INST_MULT} {longIs32bit} { 853 expr 0x123456789a*193 854} 15090186251290 855test execute-7.25 {Wide int handling in INST_DIV} {longIs32bit} { 856 expr 0x123456789a/193 857} 405116546 858test execute-7.26 {Wide int handling in INST_UPLUS} {longIs32bit} { 859 set x 0x123456871234568 860 expr {+ $x} 861} 81985533099853160 862test execute-7.27 {Wide int handling in INST_UMINUS} {longIs32bit} { 863 set x 0x123456871234568 864 expr {- $x} 865} -81985533099853160 866test execute-7.28 {Wide int handling in INST_LNOT} {longIs32bit} { 867 set x 0x123456871234568 868 expr {! $x} 869} 0 870test execute-7.29 {Wide int handling in INST_BITNOT} {longIs32bit} { 871 set x 0x123456871234568 872 expr {~ $x} 873} -81985533099853161 874test execute-7.30 {Wide int handling in function call} {longIs32bit} { 875 set x 0x12345687123456 876 incr x 877 expr {log($x) == log(double($x))} 878} 1 879test execute-7.31 {Wide int handling in abs()} {longIs32bit} { 880 set x 0xa23456871234568 881 incr x 882 set y 0x123456871234568 883 concat [expr {abs($x)}] [expr {abs($y)}] 884} {730503879441204585 81985533099853160} 885test execute-7.32 {Wide int handling} {longIs32bit} { 886 expr {1024 * 1024 * 1024 * 1024} 887} 0 888test execute-7.33 {Wide int handling} {longIs32bit} { 889 expr {0x1 * 1024 * 1024 * 1024 * 1024} 890} 0 891test execute-7.34 {Wide int handling} {longIs32bit} { 892 expr {wide(0x1) * 1024 * 1024 * 1024 * 1024} 893} 1099511627776 894 895test execute-8.1 {Stack protection} -setup { 896 # If [Bug #804681] has not been properly 897 # taken care of, this should segfault 898 proc whatever args {llength $args} 899 trace add variable ::errorInfo {write unset} whatever 900} -body { 901 expr {1+9/0} 902} -cleanup { 903 trace remove variable ::errorInfo {write unset} whatever 904 rename whatever {} 905} -returnCodes error -match glob -result * 906 907test execute-10.2 {Bug 2802881} -setup { 908 interp create slave 909} -body { 910 # If [Bug 2802881] is not fixed, this will segfault 911 slave eval { 912 trace add variable ::errorInfo write {expr {$foo} ;#} 913 proc demo {} {a {}{}} 914 demo 915 } 916} -cleanup { 917 interp delete slave 918} -returnCodes error -match glob -result * 919 920# cleanup 921if {[info commands testobj] != {}} { 922 testobj freeallvars 923} 924catch {eval namespace delete [namespace children :: test_ns_*]} 925catch {rename foo ""} 926catch {rename p ""} 927catch {rename {} ""} 928catch {rename { } ""} 929catch {unset x} 930catch {unset y} 931catch {unset msg} 932::tcltest::cleanupTests 933return 934