Tcl Source Code

Artifact 00954b22f04523e7d011acf9252e6861f9361419:

Attachment "errorstackloop.patch" to ticket [3386417fff] added by ferrieux 2011-08-09 06:13:20.

---

Index: generic/tclCompCmds.c
===================================================================
--- generic/tclCompCmds.c
+++ generic/tclCompCmds.c
@@ -3642,11 +3642,11 @@
     const char *bytes = TclGetStringFromObj(msg, &numBytes);
 
     TclErrorStackResetIf(interp, bytes, numBytes);
     TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
     CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
-	    Tcl_GetReturnOptions(interp, TCL_ERROR));
+			  TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
 }
 
 /*
  *----------------------------------------------------------------------
  *

Index: generic/tclInt.h
===================================================================
--- generic/tclInt.h
+++ generic/tclInt.h
@@ -3014,10 +3014,11 @@
 MODULE_SCOPE int	TclMaxListLength(const char *bytes, int numBytes,
 			    const char **endPtr);
 MODULE_SCOPE int	TclMergeReturnOptions(Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[], Tcl_Obj **optionsPtrPtr,
 			    int *codePtr, int *levelPtr);
+MODULE_SCOPE Tcl_Obj *  TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options);
 MODULE_SCOPE int	TclNokia770Doubles(void);
 MODULE_SCOPE void	TclNsDecrRefCount(Namespace *nsPtr);
 MODULE_SCOPE void	TclObjVarErrMsg(Tcl_Interp *interp, Tcl_Obj *part1Ptr,
 			    Tcl_Obj *part2Ptr, const char *operation,
 			    const char *reason, int index);

Index: generic/tclResult.c
===================================================================
--- generic/tclResult.c
+++ generic/tclResult.c
@@ -1591,10 +1591,33 @@
     if (iPtr->errorInfo) {
 	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORINFO], iPtr->errorInfo);
 	Tcl_DictObjPut(NULL, options, keys[KEY_ERRORLINE],
 		Tcl_NewIntObj(iPtr->errorLine));
     }
+    return options;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
+ * TclNoErrorStack --
+ *
+ *	Removes the -errorstack entry from an options dict to avoid reference cycles
+ *
+ * Results:
+ *	The (unshared) argument options dict, modified in -place.
+ *
+ *-------------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclNoErrorStack(Tcl_Interp *interp, Tcl_Obj *options)
+{
+    Tcl_Obj **keys = GetKeys();
+    
+    Tcl_DictObjRemove(interp, options, keys[KEY_ERRORSTACK]);
+
     return options;
 }
 
 /*
  *-------------------------------------------------------------------------