summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog5
-rw-r--r--tests/execute.test181
2 files changed, 184 insertions, 2 deletions
diff --git a/ChangeLog b/ChangeLog
index dfc3ba5..f4dbb91 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2008-03-07 Don Porter <dgp@users.sourceforge.net>
+
+ * tests/execute.test (execute-6.8): Added tests checking that
+ bytecode is invalidates in the right situations.
+
2008-03-03 Reinhard Max <max@suse.de>
* unix/tclUnixChan.c: Fix mark and space parity on Linux, which
diff --git a/tests/execute.test b/tests/execute.test
index 7883ffe..c7bd2fd 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -14,7 +14,7 @@
# 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.13.2.2 2004/10/28 00:01:07 dgp Exp $
+# RCS: @(#) $Id: execute.test,v 1.13.2.3 2008/03/07 19:10:03 dgp Exp $
if {[lsearch [namespace children] ::tcltest] == -1} {
package require tcltest 2
@@ -585,12 +585,189 @@ test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName o
}
p
} {}
-
test execute-6.2 {Evaluate an expression in a variable; compile the first time, do not the second} {
set w {3*5}
proc a {obj} {expr $obj}
set res "[a $w]:[a $w]"
} {15:15}
+test execute-6.3 {Tcl_ExprObj: don't use cached script bytecode [Bug 1899164]} -setup {
+ proc 0+0 {} {return SCRIPT}
+} -body {
+ set e { 0+0 }
+ if 1 $e
+ if 1 {expr $e}
+} -cleanup {
+ rename 0+0 {}
+} -result 0
+test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]} -setup {
+ proc 0+0 {} {return SCRIPT}
+} -body {
+ set e { 0+0 }
+ if 1 {expr $e}
+ if 1 $e
+} -cleanup {
+ rename 0+0 {}
+} -result SCRIPT
+test execute-6.5 {TclCompEvalObj: bytecode epoch validation} {
+ 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} {longIs32bit} {
set x 0x100000000