Fix [Bug 1382528]; thanks to Anton Kovalenko for finding this.

3 files changed, 36 insertions, 18 deletions

diff --git a/ChangeLog b/ChangeLog
index 64e460a..d1052e9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,13 @@
+2005-12-18  Donal K. Fellows  <donal.k.fellows@manchester.ac.uk>
+
+	* generic/tclCompCmds.c (TclCompileDictCmd): Ensure that we only do an
+	'endCatch' when there's a preceding 'beginCatch'. [Bug 1382528] Many
+	thanks to Anton Kovalenko for finding this and pointing out that it
+	was a catch stack handling problem!
+
 2005-12-14  Daniel Steffen  <das@users.sourceforge.net>
 
-	* generic/tclIOUtil.c: workaround gcc warning "comparison is always 
+	* generic/tclIOUtil.c: workaround gcc warning "comparison is always
 	* generic/tclTest.c:   false due to limited range of data type".
 
 	* macosx/Tcl.xcode/project.pbxproj:
@@ -46,7 +53,7 @@
 	* win/tclWinFile.c:
 	* win/tclWinReg.c:
 	* win/tclWinSock.c:
-	
+
 2005-12-13  Donal K. Fellows  <donal.k.fellows@manchester.ac.uk>
 
 	* generic/tclExecute.c (TEBC:DICT_FIRST,DICT_DONE): Only decrease the
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 2c63d5b..e62ab03 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.82 2005/11/30 14:59:40 dkf Exp $
+ * RCS: @(#) $Id: tclCompCmds.c,v 1.83 2005/12/18 22:42:18 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -669,7 +669,7 @@ TclCompileDictCmd(
     } else if (size==3 && strncmp(cmd, "for", 3)==0) {
 	Tcl_Token *varsTokenPtr, *dictTokenPtr, *bodyTokenPtr;
 	int keyVarIndex, valueVarIndex, nameChars, loopRange, catchRange;
-	int infoIndex, jumpDisplacement, bodyTargetOffset, doneTargetOffset;
+	int infoIndex, jumpDisplacement, bodyTargetOffset, emptyTargetOffset;
 	int endTargetOffset;
 	const char **argv;
 	Tcl_DString buffer;
@@ -740,7 +740,7 @@ TclCompileDictCmd(
 
 	CompileWord(envPtr, dictTokenPtr, interp);
 	TclEmitInstInt4( INST_DICT_FIRST, infoIndex,		envPtr);
-	doneTargetOffset = CurrentOffset(envPtr);
+	emptyTargetOffset = CurrentOffset(envPtr);
 	TclEmitInstInt4( INST_JUMP_TRUE4, 0,			envPtr);
 
 	/*
@@ -795,16 +795,6 @@ TclCompileDictCmd(
 	TclEmitInstInt4( INST_DICT_NEXT, infoIndex,		envPtr);
 	jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
 	TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement,	envPtr);
-
-	/*
-	 * Otherwise we're done (the jump after the DICT_FIRST points here)
-	 * and we need to pop the bogus key/value pair (pushed to keep stack
-	 * calculations easy!)
-	 */
-
-	jumpDisplacement = CurrentOffset(envPtr) - doneTargetOffset;
-	TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
-		envPtr->codeStart + doneTargetOffset);
 	TclEmitOpcode(   INST_POP,				envPtr);
 	TclEmitOpcode(   INST_POP,				envPtr);
 
@@ -836,6 +826,19 @@ TclCompileDictCmd(
 	TclEmitOpcode(   INST_RETURN_STK,			envPtr);
 
 	/*
+	 * Otherwise we're done (the jump after the DICT_FIRST points here)
+	 * and we need to pop the bogus key/value pair (pushed to keep stack
+	 * calculations easy!) Note that we skip the END_CATCH. [Bug 1382528]
+	 */
+
+	jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
+	TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
+		envPtr->codeStart + emptyTargetOffset);
+	TclEmitOpcode(   INST_POP,				envPtr);
+	TclEmitOpcode(   INST_POP,				envPtr);
+	TclEmitInstInt4( INST_DICT_DONE, infoIndex,		envPtr);
+
+	/*
 	 * Final stage of the command (normal case) is that we push an empty
 	 * object. This is done last to promote peephole optimization when
 	 * it's dropped immediately.
diff --git a/tests/dict.test b/tests/dict.test
index 722ba23..1f8e310 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -9,7 +9,7 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 #
-# RCS: @(#) $Id: dict.test,v 1.16 2005/12/13 13:46:15 dkf Exp $
+# RCS: @(#) $Id: dict.test,v 1.17 2005/12/18 22:42:18 dkf Exp $
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
@@ -551,8 +551,16 @@ test dict-14.17 {dict for command in compilation context} {
     }
     dicttest
 } {a 0}
-# There's probably a lot more tests to add here.  Really ought to use
-# a coverage tool for this job...
+test dict-14.17 {dict for command in compilation context} {
+    # Bug 1382528
+    proc dicttest {} {
+	dict for {k v} {} {}		;# Note empty dict
+	catch { error foo }		;# Note compiled [catch]
+    }
+    dicttest
+} 1
+# There's probably a lot more tests to add here. Really ought to use a
+# coverage tool for this job...
 
 test dict-15.1 {dict set command} {
     set dictVar {}