* tests/execute.test (execute-11.1): [Bug 3142026]: Added test that

	fails (with a crash) in an unfixed memdebug build on 64-bit systems.

1 files changed, 124 insertions, 94 deletions

diff --git a/tests/execute.test b/tests/execute.test
index 9e5b1f6..c5de6e8 100644
--- a/tests/execute.test
+++ b/tests/execute.test
@@ -1,22 +1,22 @@
-# 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.
+# 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.
+# 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.
+# 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.36 2010/09/22 17:21:03 msofer Exp $
+# RCS: @(#) $Id: execute.test,v 1.37 2011/01/01 14:44:32 dkf Exp $
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
+if {"::tcltest" ni [namespace children]} {
     package require tcltest 2
     namespace import -force ::tcltest::*
 }
@@ -35,7 +35,7 @@ testConstraint testobj [expr {
 
 testConstraint longIs32bit [expr {int(0x80000000) < 0}]
 testConstraint testexprlongobj [llength [info commands testexprlongobj]]
-
+
 # Tests for the omnibus TclExecuteByteCode function:
 
 # INST_DONE not tested
@@ -498,10 +498,11 @@ test execute-3.77 {TclExecuteByteCode, INST_TRY_CVT_TO_NUMERIC, op is non-numeri
 # INST_PUSH_RESULT not tested
 # INST_PUSH_RETURN_CODE not tested
 
-test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
+test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
-    catch {unset x}
-    catch {unset y}
+    unset -nocomplain x
+    unset -nocomplain y
+} -body {
     namespace eval test_ns_1 {
         namespace export cmd1
         proc cmd1 {args} {return "cmd1: $args"}
@@ -515,11 +516,12 @@ test execute-4.1 {Tcl_GetCommandFromObj, convert to tclCmdNameType} {
     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} {
+} -result {::test_ns_1::test_ns_2::cmd1 0 {} 0 {}}
+test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is invalid} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
     catch {rename foo ""}
-    catch {unset l}
+    unset -nocomplain l
+} -body {
     proc foo {} {
         return "global foo"
     }
@@ -536,11 +538,11 @@ test execute-4.2 {Tcl_GetCommandFromObj, check if cached tclCmdNameType is inval
         }
     }
     lappend l [test_ns_1::whichFoo]
-    set l
-} {::foo ::test_ns_1::foo}
-test execute-4.3 {Tcl_GetCommandFromObj, command never found} {
+} -result {::foo ::test_ns_1::foo}
+test execute-4.3 {Tcl_GetCommandFromObj, command never found} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
     catch {rename foo ""}
+} -body {
     namespace eval test_ns_1 {
         proc foo {} {
             return "namespace foo"
@@ -554,17 +556,18 @@ test execute-4.3 {Tcl_GetCommandFromObj, command never found} {
     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 {}}
+} -result {::test_ns_1::foo {} 0 {}}
 
-test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} {
+test execute-5.1 {SetCmdNameFromAny, set cmd name to empty heap string if NULL} -setup {
     catch {namespace delete {*}[namespace children :: test_ns_*]}
-    catch {unset l}
+    unset -nocomplain l
+} -body {
     proc {} {} {return {}}
     {}
     set l {}
     lindex {} 0
     {}
-} {}
+} -result {}
 
 test execute-6.1 {UpdateStringOfCmdName: called for duplicate of empty cmdName object} {
     proc {} {} {}
@@ -600,7 +603,7 @@ test execute-6.4 {TclCompEvalObj: don't use cached expr bytecode [Bug 1899164]}
 } -cleanup {
     rename 0+0 {}
 } -result SCRIPT
-test execute-6.5 {TclCompEvalObj: bytecode epoch validation} {
+test execute-6.5 {TclCompEvalObj: bytecode epoch validation} -body {
     set script { llength {} }
     set result {}
     lappend result [if 1 $script]
@@ -608,20 +611,22 @@ test execute-6.5 {TclCompEvalObj: bytecode epoch validation} {
     rename $origName llength.orig
     proc $origName {args} {return AHA!}
     lappend result [if 1 $script]
+} -cleanup {
     rename $origName {}
     rename llength.orig $origName
-    set result
-} {0 AHA!}
-test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} {
+} -result {0 AHA!}
+test execute-6.6 {TclCompEvalObj: proc-body bytecode invalid for script} -body {
     proc foo {} {set a 1}
     set a untouched
     set result {}
     lappend result [foo] $a
     lappend result [if 1 [info body foo]] $a
+} -cleanup {
     rename foo {}
-    set result
-} {1 untouched 1 1}
-test execute-6.7 {TclCompEvalObj: bytecode context validation} {
+} -result {1 untouched 1 1}
+test execute-6.7 {TclCompEvalObj: bytecode context validation} -setup {
+    namespace eval foo {}
+} -body {
     set script { llength {} }
     namespace eval foo {
 	proc llength {args} {return AHA!}
@@ -629,10 +634,12 @@ test execute-6.7 {TclCompEvalObj: bytecode context validation} {
     set result {}
     lappend result [if 1 $script]
     lappend result [namespace eval foo $script]
+} -cleanup {
     namespace delete foo
-    set result
-} {0 AHA!}
-test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} {
+} -result {0 AHA!}
+test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} -setup {
+    namespace eval foo {}
+} -body {
     set script { llength {} }
     set result {}
     lappend result [namespace eval foo $script]
@@ -640,20 +647,21 @@ test execute-6.8 {TclCompEvalObj: bytecode name resolution epoch validation} {
 	proc llength {args} {return AHA!}
     }
     lappend result [namespace eval foo $script]
+} -cleanup {
     namespace delete foo
-    set result
-} {0 AHA!}
-test execute-6.9 {TclCompEvalObj: bytecode interp validation} {
-    set script { llength {} }
+} -result {0 AHA!}
+test execute-6.9 {TclCompEvalObj: bytecode interp validation} -setup {
     interp create slave
+} -body {
+    set script { llength {} }
     slave eval {proc llength args {return AHA!}}
     set result {}
     lappend result [if 1 $script]
     lappend result [slave eval $script]
+} -cleanup {
     interp delete slave
-    set result
-} {0 AHA!}
-test execute-6.10 {TclCompEvalObj: bytecode interp validation} {
+} -result {0 AHA!}
+test execute-6.10 {TclCompEvalObj: bytecode interp validation} -body {
     set script { llength {} }
     interp create slave
     set result {}
@@ -661,13 +669,14 @@ test execute-6.10 {TclCompEvalObj: bytecode interp validation} {
     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 {
+} -cleanup {
+    catch {interp delete slave}
+} -result {0 0}
+test execute-6.11 {Tcl_ExprObj: exprcode interp validation} -setup {
+    interp create slave
+} -constraints testexprlongobj -body {
     set e { [llength {}]+1 }
     set result {}
-    interp create slave
     load {} Tcltest slave
     interp alias {} e slave testexprlongobj
     lappend result [e $e]
@@ -676,23 +685,24 @@ test execute-6.11 {Tcl_ExprObj: exprcode interp validation} testexprlongobj {
     load {} Tcltest slave
     interp alias {} e slave testexprlongobj
     lappend result [e $e]
+} -cleanup {
     interp delete slave
-    set result
-} {{This is a result: 1} {This is a result: 1}}
-test execute-6.12 {Tcl_ExprObj: exprcode interp validation} {
+} -result {{This is a result: 1} {This is a result: 1}}
+test execute-6.12 {Tcl_ExprObj: exprcode interp validation} -setup {
+    interp create slave
+} -body {
     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]
+} -cleanup {
     interp delete slave
-    set result
-} {1 1}
-test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} {
+} -result {1 1}
+test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} -body {
     set e { [llength {}]+1 }
     set result {}
     lappend result [expr $e]
@@ -700,11 +710,13 @@ test execute-6.13 {Tcl_ExprObj: exprcode epoch validation} {
     rename $origName llength.orig
     proc $origName {args} {return 1}
     lappend result [expr $e]
+} -cleanup {
     rename $origName {}
     rename llength.orig $origName
-    set result
-} {1 2}
-test execute-6.14 {Tcl_ExprObj: exprcode context validation} {
+} -result {1 2}
+test execute-6.14 {Tcl_ExprObj: exprcode context validation} -setup {
+    namespace eval foo {}
+} -body {
     set e { [llength {}]+1 }
     namespace eval foo {
 	proc llength {args} {return 1}
@@ -712,10 +724,12 @@ test execute-6.14 {Tcl_ExprObj: exprcode context validation} {
     set result {}
     lappend result [expr $e]
     lappend result [namespace eval foo {expr $e}]
+} -cleanup {
     namespace delete foo
-    set result
-} {1 2}
-test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} {
+} -result {1 2}
+test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} -setup {
+    namespace eval foo {}
+} -body {
     set e { [llength {}]+1 }
     set result {}
     lappend result [namespace eval foo {expr $e}]
@@ -723,42 +737,43 @@ test execute-6.15 {Tcl_ExprObj: exprcode name resolution epoch validation} {
 	proc llength {args} {return 1}
     }
     lappend result [namespace eval foo {expr $e}]
+} -cleanup {
     namespace delete foo
-    set result
-} {1 2}
-test execute-6.16 {Tcl_ExprObj: exprcode interp validation} {
-    set e { [llength {}]+1 }
+} -result {1 2}
+test execute-6.16 {Tcl_ExprObj: exprcode interp validation} -setup {
     interp create slave
+} -body {
+    set e { [llength {}]+1 }
     interp alias {} e slave expr
     slave eval {proc llength args {return 1}}
     set result {}
     lappend result [expr $e]
     lappend result [e $e]
+} -cleanup {
     interp delete slave
-    set result
-} {1 2}
-test execute-6.17 {Tcl_ExprObj: exprcode context validation} {
-    set e { $v }
+} -result {1 2}
+test execute-6.17 {Tcl_ExprObj: exprcode context validation} -body {
     proc foo e {set v 0; expr $e}
     proc bar e {set v 1; expr $e}
+    set e { $v }
     set result {}
     lappend result [foo $e]
     lappend result [bar $e]
+} -cleanup {
     rename foo {}
     rename bar {}
-    set result
-} {0 1}
-test execute-6.18 {Tcl_ExprObj: exprcode context validation} {
-    set e { [llength $v] }
+} -result {0 1}
+test execute-6.18 {Tcl_ExprObj: exprcode context validation} -body {
     proc foo e {set v {}; expr $e}
     proc bar e {set v v; expr $e}
+    set e { [llength $v] }
     set result {}
     lappend result [foo $e]
     lappend result [bar $e]
+} -cleanup {
     rename foo {}
     rename bar {}
-    set result
-} {0 1}
+} -result {0 1}
 
 test execute-7.0 {Wide int handling in INST_JUMP_FALSE/LAND} {
     set x 0x100000000
@@ -882,8 +897,8 @@ test execute-7.34 {Wide int handling} {
 } 1099511627776
 
 test execute-8.1 {Stack protection} -setup {
-    # If [Bug #804681] has not been properly
-    # taken care of, this should segfault
+    # 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 {
@@ -892,23 +907,27 @@ test execute-8.1 {Stack protection} -setup {
     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 {
+test execute-8.2 {Stack restoration} -setup {
     # Avoid crashes when system stack size is limited (thread-enabled!)
     set limit [interp recursionlimit {}]
     interp recursionlimit {} 100
+} -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
 } -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
+test execute-8.3 {Stack restoration} -setup {
+    # Avoid crashes when system stack size is limited (thread-enabled!)
+    set limit [interp recursionlimit {}]
+    interp recursionlimit {} 100
+} -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 {} {
@@ -919,10 +938,6 @@ test execute-8.3 {Stack restoration} -body {
 	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?)}
@@ -979,7 +994,6 @@ test execute-9.1 {Interp result resetting [Bug 1522803]} {
 test execute-10.1 {TclExecuteByteCode, INST_CONCAT1, bytearrays} {
     apply {s {binary scan $s c x; list $x [scan $s$s %c%c]}} \u0130
 } {48 {304 304}}
-
 test execute-10.2 {Bug 2802881} -setup {
     interp create slave
 } -body {
@@ -992,7 +1006,6 @@ test execute-10.2 {Bug 2802881} -setup {
 } -cleanup {
     interp delete slave
 } -returnCodes error -match glob -result *
-
 test execute-10.3 {Bug 3072640} -setup {
     proc generate {n} {
 	for {set i 0} {$i < $n} {incr i} {
@@ -1014,6 +1027,22 @@ test execute-10.3 {Bug 3072640} -setup {
     rename coro {}
 } -result 4
 
+test execute-11.1 {Bug 3142026: GrowEvaluationStack off-by-one} -setup {
+    interp create slave
+} -body {
+    slave eval {
+	set x [lrepeat 1320 199]
+	for {set i 0} {$i < 20} {incr i} {
+	    lappend x $i
+	    lsort -integer $x
+	}
+	# Crashes on failure
+	return ok
+    }
+} -cleanup {
+    interp delete slave
+} -result ok
+
 # cleanup
 if {[info commands testobj] != {}} {
    testobj freeallvars
@@ -1031,4 +1060,5 @@ return
 
 # Local Variables:
 # mode: tcl
+# fill-column: 78
 # End: