Fix [Bug 1671138]

3 files changed, 56 insertions, 30 deletions

diff --git a/ChangeLog b/ChangeLog
index accf50b..65469d4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,34 +1,39 @@
+2007-03-01  Donal K. Fellows  <donal.k.fellows@manchester.ac.uk>
+
+	* generic/tclCompCmds.c (TclCompileForeachCmd): Prevent an unexpected
+	* tests/foreach.test (foreach-9.1):		infinite loop when the
+	variable list is empty and the foreach is compiled. [Bug 1671138]
+
 2007-02-26  Andreas Kupries  <andreask@activestate.com>
 
 	* generic/tclIORChan.c (FreeReflectedChannel): Added the missing
-	  refcount release between NewRC and FreeRC for the channel handle
-	  object, spotted by Don Porter. This fixes the bug 1667990.
+	refcount release between NewRC and FreeRC for the channel handle
+	object, spotted by Don Porter. [Bug 1667990]
 
 2007-02-26  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCmdAH.c (Tcl_ForeachObjCmd):	Removed surplus copying
-	of the objv array that used to be a workaround for Bug 404865.  That bug
-	is long fixed.
+	* generic/tclCmdAH.c (Tcl_ForeachObjCmd):	Removed surplus
+	copying of the objv array that used to be a workaround for [Bug
+	404865]. That bug is long fixed.
 
 2007-02-24  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclBasic.c:	Use new interface in Tcl_EvalObjEx so that
-	the refcounting logic of the List internal rep need not be repeated
-	there.  Better encapsulation of internal details.
+	* generic/tclBasic.c:	Use new interface in Tcl_EvalObjEx so that the
+	recounting logic of the List internal rep need not be repeated there.
+	Better encapsulation of internal details.
 
 	* generic/tclInt.h:	New internal routine TclListObjCopy() used
-	* generic/tclListObj.c:	to efficiently do the equivalent of
-	[lrange $list 0 end].  After some experience with this, might be
-	a good candidate for exposure as a public interface.  It's useful
-	for callers of Tcl_ListObjGetElements() who want to control the
-	ongoing validity of the returned objv pointer.
+	* generic/tclListObj.c:	to efficiently do the equivalent of [lrange
+	$list 0 end]. After some experience with this, might be a good
+	candidate for exposure as a public interface. It's useful for callers
+	of Tcl_ListObjGetElements() who want to control the ongoing validity
+	of the returned objv pointer.
 
 2007-02-22  Andreas Kupries  <andreask@activestate.com>
 
 	* tests/pkg.test: Added tests for the case of an alpha package
-	  satisfying a require for the regular package, demonstrating a
-	  corner case specified in TIP#280. More notes in the comments to
-	  the test.
+	satisfying a require for the regular package, demonstrating a corner
+	case specified in TIP#280. More notes in the comments to the test.
 
 2007-02-20  Jan Nijtmans  <nijtmans@users.sf.net>
 
@@ -46,7 +51,7 @@
 
 2007-02-20  Pat Thoyts  <patthoyts@users.sourceforge.net>
 
-	* generic/tclFileName.c:  Bug #1479814. Handle extended paths
+	* generic/tclFileName.c:  [Bug 1479814]. Handle extended paths
 	* generic/tclPathObj.c:   on Windows NT and above. These have a
 	* win/tclWinFile.c:       \\?\ prefix.
 	* tests/winFCmd.test:     Tests for extended path handling.
@@ -165,15 +170,16 @@
 
 	* generic/tcl.h: update location of version numbers in macosx files.
 
-	* macosx/Tcl.xcode/project.pbxproj: restore 'tcltest' target to
-	* macosx/Tcl.xcode/default.pbxuser: working order by replicating
-	applicable changes to Tcl.xcodeproj since 2006-07-20.
+	* macosx/Tcl.xcode/project.pbxproj: restore 'tcltest' target to working
+	* macosx/Tcl.xcode/default.pbxuser: order by replicating applicable
+	changes to Tcl.xcodeproj since 2006-07-20.
 
 2007-01-25  Daniel Steffen  <das@users.sourceforge.net>
 
 	* unix/tcl.m4: integrate CPPFLAGS into CFLAGS as late as possible and
-	move (rather than duplicate) -isysroot flags from CFLAGS to CPPFLAGS to
-	avoid errors about multiple -isysroot flags from some older gcc builds.
+	move (rather than duplicate) -isysroot flags from CFLAGS to CPPFLAGS
+	to avoid errors about multiple -isysroot flags from some older gcc
+	builds.
 
 	* unix/configure: autoconf-2.59
 
@@ -689,7 +695,7 @@
 	* generic/tclThreadStorage.c (Tcl_InitThreadStorage):
 	(Tcl_FinalizeThreadStorage): Silence a compiler warning about
 	presenting a volatile pointer to 'memset'.
-	
+
 2006-11-13  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclIO.c:	When [gets] on a binary channel needs to use
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 6453012..c0721fa 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -12,7 +12,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclCompCmds.c,v 1.100 2007/02/27 21:44:29 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.101 2007/03/01 10:07:12 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -1397,8 +1397,21 @@ TclCompileForeachCmd(
 	    goto done;
 	}
 	numVars = varcList[loopIndex];
+
+	/*
+	 * If the variable list is empty, we can enter an infinite loop when
+	 * the interpreted version would not. Take care to ensure this does
+	 * not happen. [Bug 1671138]
+	 */
+
+	if (numVars == 0) {
+	    code = TCL_ERROR;
+	    goto done;
+	}
+
 	for (j = 0;  j < numVars;  j++) {
 	    const char *varName = varvList[loopIndex][j];
+
 	    if (!TclIsLocalScalar(varName, (int) strlen(varName))) {
 		code = TCL_ERROR;
 		goto done;
diff --git a/tests/foreach.test b/tests/foreach.test
index abb88f4..8f452ed 100644
--- a/tests/foreach.test
+++ b/tests/foreach.test
@@ -10,7 +10,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: foreach.test,v 1.10 2005/10/22 03:37:27 msofer Exp $
+# RCS: @(#) $Id: foreach.test,v 1.11 2007/03/01 10:07:12 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest
@@ -163,7 +163,7 @@ test foreach-3.1 {compiled foreach backward jump works correctly} {
 test foreach-4.1 {noncompiled foreach and shared variable or value list objects that are converted to another type} {
     catch {unset x}
     foreach {12.0} {a b c} {
-        set x 12.0  
+        set x 12.0
         set x [expr $x + 1]
     }
     set x
@@ -210,7 +210,7 @@ test foreach-6.4 {break tests} {
     catch {break foo} msg
     set msg
 } {wrong # args: should be "break"}
-# Check for bug #406709 
+# Check for bug #406709
 test foreach-6.5 {break tests} {
     proc a {} {
 	set a 1
@@ -221,7 +221,6 @@ test foreach-6.5 {break tests} {
 } {2}
 
 # Test for incorrect "double evaluation" semantics
-
 test foreach-7.1 {delayed substitution of body} {
     proc foo {} {
        set a 0
@@ -233,9 +232,7 @@ test foreach-7.1 {delayed substitution of body} {
     foo
 } {0}
 
-
 # Test for [Bug 1189274]; crash on failure
-
 test foreach-8.1 {empty list handling} {
     proc crash {} {
 	rename crash {}
@@ -246,6 +243,16 @@ test foreach-8.1 {empty list handling} {
     crash
 } {}
 
+# [Bug 1671138]; infinite loop with empty var list in bytecompiled version
+test foreach-9.1 {compiled empty var list} {
+    proc foo {} {
+	foreach {} x {
+	    error "reached body"
+	}
+    }
+    list [catch { foo } msg] $msg
+} {1 {foreach varlist is empty}}
+
 # cleanup
 catch {unset a}
 catch {unset x}