From 1111254200cc2b8bc8aa2d899f43d56884f1f1cb Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 9 Mar 2011 14:06:53 +0000
Subject: Turn namespace into an ensemble. Not yet on trunk because of some
 mysterious failures that need resolving...

---
 generic/tclBasic.c    |  17 ++-
 generic/tclCompCmds.c |  23 +---
 generic/tclEnsemble.c |  36 ++---
 generic/tclInt.h      |   7 +-
 generic/tclNamesp.c   | 363 ++++++++++++++++++++++----------------------------
 tests/namespace.test  |   4 +-
 6 files changed, 198 insertions(+), 252 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 20cb1ad..9d5b006 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -237,7 +237,6 @@ static const CmdInfo builtInCmds[] = {
     {"lsearch",		Tcl_LsearchObjCmd,	NULL,			NULL,	1},
     {"lset",		Tcl_LsetObjCmd,		TclCompileLsetCmd,	NULL,	1},
     {"lsort",		Tcl_LsortObjCmd,	NULL,			NULL,	1},
-    {"namespace",	Tcl_NamespaceObjCmd,	TclCompileNamespaceCmd,	TclNRNamespaceObjCmd,	1},
     {"package",		Tcl_PackageObjCmd,	NULL,			NULL,	1},
     {"proc",		Tcl_ProcObjCmd,		NULL,			NULL,	1},
     {"regexp",		Tcl_RegexpObjCmd,	TclCompileRegexpCmd,	NULL,	1},
@@ -780,10 +779,10 @@ Tcl_CreateInterp(void)
     }
 
     /*
-     * Create the "array", "binary", "chan", "dict", "file", "info" and
-     * "string" ensembles. Note that all these commands (and their subcommands
-     * that are not present in the global namespace) are wholly safe *except*
-     * for "file".
+     * Create the "array", "binary", "chan", "dict", "file", "info",
+     * "namespace" and "string" ensembles. Note that all these commands (and
+     * their subcommands that are not present in the global namespace) are
+     * wholly safe *except* for "file".
      */
 
     TclInitArrayCmd(interp);
@@ -792,6 +791,7 @@ Tcl_CreateInterp(void)
     TclInitDictCmd(interp);
     TclInitFileCmd(interp);
     TclInitInfoCmd(interp);
+    TclInitNamespaceCmd(interp);
     TclInitStringCmd(interp);
     TclInitPrefixCmd(interp);
 
@@ -825,10 +825,9 @@ Tcl_CreateInterp(void)
 	    Tcl_RepresentationCmd, NULL, NULL);
 
     /* Adding the bytecode assembler command */
-    cmdPtr = (Command*)
-        Tcl_NRCreateCommand(interp, "::tcl::unsupported::assemble",
-                            Tcl_AssembleObjCmd, TclNRAssembleObjCmd,
-                            NULL, NULL);
+    cmdPtr = (Command *) Tcl_NRCreateCommand(interp,
+            "::tcl::unsupported::assemble", Tcl_AssembleObjCmd,
+            TclNRAssembleObjCmd, NULL, NULL);
     cmdPtr->compileProc = &TclCompileAssembleCmd;
 
     Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index c4d88a0..83e99aa 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3211,7 +3211,8 @@ TclCompileLsetCmd(
  * TclCompileNamespaceCmd --
  *
  *	Procedure called to compile the "namespace" command; currently, only
- *	the subcommand "namespace upvar" is compiled to bytecodes.
+ *	the subcommand "namespace upvar" is compiled to bytecodes, and then
+ *	only inside a procedure(-like) context.
  *
  * Results:
  *	Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer
@@ -3225,7 +3226,7 @@ TclCompileLsetCmd(
  */
 
 int
-TclCompileNamespaceCmd(
+TclCompileNamespaceUpvarCmd(
     Tcl_Interp *interp,		/* Used for error reporting. */
     Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
 				 * created by Tcl_ParseCommand. */
@@ -3242,21 +3243,11 @@ TclCompileNamespaceCmd(
     }
 
     /*
-     * Only compile [namespace upvar ...]: needs an odd number of args, >=5
+     * Only compile [namespace upvar ...]: needs an even number of args, >=4
      */
 
     numWords = parsePtr->numWords;
-    if (!(numWords%2) || (numWords < 5)) {
-	return TCL_ERROR;
-    }
-
-    /*
-     * Check if the second argument is "upvar"
-     */
-
-    tokenPtr = TokenAfter(parsePtr->tokenPtr);
-    if ((tokenPtr->size != 5)  /* 5 == strlen("upvar") */
-	    || strncmp(tokenPtr->start, "upvar", 5)) {
+    if ((numWords % 2) || (numWords < 4)) {
 	return TCL_ERROR;
     }
 
@@ -3264,7 +3255,7 @@ TclCompileNamespaceCmd(
      * Push the namespace
      */
 
-    tokenPtr = TokenAfter(tokenPtr);
+    tokenPtr = TokenAfter(parsePtr->tokenPtr);
     CompileWord(envPtr, tokenPtr, interp, 1);
 
     /*
@@ -3274,7 +3265,7 @@ TclCompileNamespaceCmd(
      */
 
     localTokenPtr = tokenPtr;
-    for (i=4; i<=numWords; i+=2) {
+    for (i=3; i<=numWords; i+=2) {
 	otherTokenPtr = TokenAfter(localTokenPtr);
 	localTokenPtr = TokenAfter(otherTokenPtr);
 
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index bc9ff16..bbc1e55 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -123,11 +123,11 @@ TclNamespaceEnsembleCmd(
 	return TCL_ERROR;
     }
 
-    if (objc < 3) {
-	Tcl_WrongNumArgs(interp, 2, objv, "subcommand ?arg ...?");
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
 	return TCL_ERROR;
     }
-    if (Tcl_GetIndexFromObj(interp, objv[2], ensembleSubcommands,
+    if (Tcl_GetIndexFromObj(interp, objv[1], ensembleSubcommands,
 	    "subcommand", 0, &index) != TCL_OK) {
 	return TCL_ERROR;
     }
@@ -149,12 +149,12 @@ TclNamespaceEnsembleCmd(
 	 * Check that we've got option-value pairs... [Bug 1558654]
 	 */
 
-	if ((objc & 1) == 0) {
-	    Tcl_WrongNumArgs(interp, 3, objv, "?option value ...?");
+	if (objc & 1) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "?option value ...?");
 	    return TCL_ERROR;
 	}
-	objv += 3;
-	objc -= 3;
+	objv += 2;
+	objc -= 2;
 
 	/*
 	 * Work out what name to use for the command to create. If supplied,
@@ -322,29 +322,29 @@ TclNamespaceEnsembleCmd(
     }
 
     case ENS_EXISTS:
-	if (objc != 4) {
-	    Tcl_WrongNumArgs(interp, 3, objv, "cmdname");
+	if (objc != 3) {
+	    Tcl_WrongNumArgs(interp, 2, objv, "cmdname");
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
-		Tcl_FindEnsemble(interp, objv[3], 0) != NULL));
+		Tcl_FindEnsemble(interp, objv[2], 0) != NULL));
 	return TCL_OK;
 
     case ENS_CONFIG:
-	if (objc < 4 || (objc != 5 && objc & 1)) {
-	    Tcl_WrongNumArgs(interp, 3, objv,
+	if (objc < 3 || (objc != 4 && !(objc & 1))) {
+	    Tcl_WrongNumArgs(interp, 2, objv,
 		    "cmdname ?-option value ...? ?arg ...?");
 	    return TCL_ERROR;
 	}
-	token = Tcl_FindEnsemble(interp, objv[3], TCL_LEAVE_ERR_MSG);
+	token = Tcl_FindEnsemble(interp, objv[2], TCL_LEAVE_ERR_MSG);
 	if (token == NULL) {
 	    return TCL_ERROR;
 	}
 
-	if (objc == 5) {
+	if (objc == 4) {
 	    Tcl_Obj *resultObj = NULL;		/* silence gcc 4 warning */
 
-	    if (Tcl_GetIndexFromObj(interp, objv[4], ensembleConfigOptions,
+	    if (Tcl_GetIndexFromObj(interp, objv[3], ensembleConfigOptions,
 		    "option", 0, &index) != TCL_OK) {
 		return TCL_ERROR;
 	    }
@@ -388,7 +388,7 @@ TclNamespaceEnsembleCmd(
 		}
 		break;
 	    }
-	} else if (objc == 4) {
+	} else if (objc == 3) {
 	    /*
 	     * Produce list of all information.
 	     */
@@ -457,8 +457,8 @@ TclNamespaceEnsembleCmd(
 	    Tcl_GetEnsembleFlags(NULL, token, &flags);
 	    permitPrefix = (flags & TCL_ENSEMBLE_PREFIX) != 0;
 
-	    objv += 4;
-	    objc -= 4;
+	    objv += 3;
+	    objc -= 3;
 
 	    /*
 	     * Parse the option list, applying type checks as we go. Note that
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 180e0e8..42e2212 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2750,7 +2750,6 @@ MODULE_SCOPE char	tclEmptyString;
  *----------------------------------------------------------------
  */
 
-MODULE_SCOPE Tcl_ObjCmdProc TclNRNamespaceObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
@@ -3327,9 +3326,7 @@ MODULE_SCOPE int	Tcl_LsetObjCmd(ClientData clientData,
 MODULE_SCOPE int	Tcl_LsortObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
-MODULE_SCOPE int	Tcl_NamespaceObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const objv[]);
+MODULE_SCOPE Tcl_Command TclInitNamespaceCmd(Tcl_Interp *interp);
 MODULE_SCOPE int	TclNamespaceEnsembleCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -3515,7 +3512,7 @@ MODULE_SCOPE int	TclCompileLlengthCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileLsetCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-MODULE_SCOPE int	TclCompileNamespaceCmd(Tcl_Interp *interp,
+MODULE_SCOPE int	TclCompileNamespaceUpvarCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileNoOp(Tcl_Interp *interp,
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index a777d27..69411c2 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -103,6 +103,8 @@ static int		NamespaceDeleteCmd(ClientData dummy,Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		NamespaceEvalCmd(ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
+static int		NRNamespaceEvalCmd(ClientData dummy,
+                            Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 static int		NamespaceExistsCmd(ClientData dummy,Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		NamespaceExportCmd(ClientData dummy,Tcl_Interp *interp,
@@ -114,6 +116,8 @@ static int		NamespaceImportCmd(ClientData dummy,Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		NamespaceInscopeCmd(ClientData dummy,
 			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
+static int		NRNamespaceInscopeCmd(ClientData dummy,
+			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 static int		NamespaceOriginCmd(ClientData dummy,Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		NamespaceParentCmd(ClientData dummy,Tcl_Interp *interp,
@@ -127,8 +131,7 @@ static int		NamespaceTailCmd(ClientData dummy, Tcl_Interp *interp,
 static int		NamespaceUpvarCmd(ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		NamespaceUnknownCmd(ClientData dummy,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const objv[]);
+			    Tcl_Interp *interp,int objc,Tcl_Obj *const objv[]);
 static int		NamespaceWhichCmd(ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		SetNsNameFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr);
@@ -150,6 +153,34 @@ static const Tcl_ObjType nsNameType = {
     NULL,			/* updateStringProc */
     SetNsNameFromAny		/* setFromAnyProc */
 };
+
+/*
+ * Array of values describing how to implement each standard subcommand of the
+ * "namespace" command.
+ */
+
+static const EnsembleImplMap defaultNamespaceMap[] = {
+    {"children",        NamespaceChildrenCmd},
+    {"code",            NamespaceCodeCmd},
+    {"current",         NamespaceCurrentCmd},
+    {"delete",          NamespaceDeleteCmd},
+    {"ensemble",        TclNamespaceEnsembleCmd},
+    {"eval",            NamespaceEvalCmd,       NULL, NRNamespaceEvalCmd},
+    {"exists",          NamespaceExistsCmd},
+    {"export",          NamespaceExportCmd},
+    {"forget",          NamespaceForgetCmd},
+    {"import",          NamespaceImportCmd},
+    {"inscope",         NamespaceInscopeCmd,    NULL, NRNamespaceInscopeCmd},
+    {"origin",          NamespaceOriginCmd},
+    {"parent",          NamespaceParentCmd},
+    {"path",            NamespacePathCmd},
+    {"qualifiers",      NamespaceQualifiersCmd},
+    {"tail",            NamespaceTailCmd},
+    {"unknown",         NamespaceUnknownCmd},
+    {"upvar",           NamespaceUpvarCmd,      TclCompileNamespaceUpvarCmd},
+    {"which",           NamespaceWhichCmd},
+    {NULL, NULL, NULL, NULL, NULL, 0}
+};
 
 /*
  *----------------------------------------------------------------------
@@ -2742,7 +2773,7 @@ TclGetNamespaceFromObj(
 	     * Get the current namespace name.
 	     */
 
-	    NamespaceCurrentCmd(NULL, interp, 2, NULL);
+	    NamespaceCurrentCmd(NULL, interp, 1, NULL);
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		    "namespace \"%s\" not found in \"%s\"", name,
 		    Tcl_GetStringResult(interp)));
@@ -2790,132 +2821,25 @@ GetNamespaceFromObj(
 /*
  *----------------------------------------------------------------------
  *
- * Tcl_NamespaceObjCmd --
+ * TclInitNamespaceCmd --
  *
- *	Invoked to implement the "namespace" command that creates, deletes, or
- *	manipulates Tcl namespaces. Handles the following syntax:
- *
- *	    namespace children ?name? ?pattern?
- *	    namespace code arg
- *	    namespace current
- *	    namespace delete ?name name...?
- *	    namespace ensemble subcommand ?arg...?
- *	    namespace eval name arg ?arg...?
- *	    namespace exists name
- *	    namespace export ?-clear? ?pattern pattern...?
- *	    namespace forget ?pattern pattern...?
- *	    namespace import ?-force? ?pattern pattern...?
- *	    namespace inscope name arg ?arg...?
- *	    namespace origin name
- *	    namespace parent ?name?
- *	    namespace qualifiers string
- *	    namespace tail string
- *	    namespace which ?-command? ?-variable? name
+ *	This function is called to create the "namespace" Tcl command. See the
+ *	user documentation for details on what it does.
  *
  * Results:
- *	Returns TCL_OK if the command is successful. Returns TCL_ERROR if
- *	anything goes wrong.
+ *	Handle for the namespace command, or NULL on failure.
  *
  * Side effects:
- *	Based on the subcommand name (e.g., "import"), this function
- *	dispatches to a corresponding function NamespaceXXXCmd defined
- *	statically in this file. This function's side effects depend on
- *	whatever that subcommand function does. If there is an error, this
- *	function returns an error message in the interpreter's result object.
- *	Otherwise it may return a result in the interpreter's result object.
+ *	none
  *
  *----------------------------------------------------------------------
  */
 
-int
-Tcl_NamespaceObjCmd(
-    ClientData clientData,	/* Arbitrary value passed to cmd. */
-    Tcl_Interp *interp,		/* Current interpreter. */
-    int objc,			/* Number of arguments. */
-    Tcl_Obj *const objv[])	/* Argument objects. */
-{
-    return Tcl_NRCallObjProc(interp, TclNRNamespaceObjCmd, clientData, objc,
-	    objv);
-}
-
-int
-TclNRNamespaceObjCmd(
-    ClientData clientData,	/* Arbitrary value passed to cmd. */
-    Tcl_Interp *interp,		/* Current interpreter. */
-    int objc,			/* Number of arguments. */
-    Tcl_Obj *const objv[])	/* Argument objects. */
+Tcl_Command
+TclInitNamespaceCmd(
+    Tcl_Interp *interp)		/* Current interpreter. */
 {
-    static const char *const subCmds[] = {
-	"children", "code", "current", "delete", "ensemble",
-	"eval", "exists", "export", "forget", "import",
-	"inscope", "origin", "parent", "path", "qualifiers",
-	"tail", "unknown", "upvar", "which", NULL
-    };
-    enum NSSubCmdIdx {
-	NSChildrenIdx, NSCodeIdx, NSCurrentIdx, NSDeleteIdx, NSEnsembleIdx,
-	NSEvalIdx, NSExistsIdx, NSExportIdx, NSForgetIdx, NSImportIdx,
-	NSInscopeIdx, NSOriginIdx, NSParentIdx, NSPathIdx, NSQualifiersIdx,
-	NSTailIdx, NSUnknownIdx, NSUpvarIdx, NSWhichIdx
-    };
-    int index;
-
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "subcommand ?arg ...?");
-	return TCL_ERROR;
-    }
-
-    /*
-     * Return an index reflecting the particular subcommand.
-     */
-
-    if (Tcl_GetIndexFromObj(interp, objv[1], subCmds, "option", /*flags*/ 0,
-	    (int *) &index) != TCL_OK) {
-	return TCL_ERROR;
-    }
-
-    switch (index) {
-    case NSChildrenIdx:
-	return NamespaceChildrenCmd(clientData, interp, objc, objv);
-    case NSCodeIdx:
-	return NamespaceCodeCmd(clientData, interp, objc, objv);
-    case NSCurrentIdx:
-	return NamespaceCurrentCmd(clientData, interp, objc, objv);
-    case NSDeleteIdx:
-	return NamespaceDeleteCmd(clientData, interp, objc, objv);
-    case NSEnsembleIdx:
-	return TclNamespaceEnsembleCmd(clientData, interp, objc, objv);
-    case NSEvalIdx:
-	return NamespaceEvalCmd(clientData, interp, objc, objv);
-    case NSExistsIdx:
-	return NamespaceExistsCmd(clientData, interp, objc, objv);
-    case NSExportIdx:
-	return NamespaceExportCmd(clientData, interp, objc, objv);
-    case NSForgetIdx:
-	return NamespaceForgetCmd(clientData, interp, objc, objv);
-    case NSImportIdx:
-	return NamespaceImportCmd(clientData, interp, objc, objv);
-    case NSInscopeIdx:
-	return NamespaceInscopeCmd(clientData, interp, objc, objv);
-    case NSOriginIdx:
-	return NamespaceOriginCmd(clientData, interp, objc, objv);
-    case NSParentIdx:
-	return NamespaceParentCmd(clientData, interp, objc, objv);
-    case NSPathIdx:
-	return NamespacePathCmd(clientData, interp, objc, objv);
-    case NSQualifiersIdx:
-	return NamespaceQualifiersCmd(clientData, interp, objc, objv);
-    case NSTailIdx:
-	return NamespaceTailCmd(clientData, interp, objc, objv);
-    case NSUpvarIdx:
-	return NamespaceUpvarCmd(clientData, interp, objc, objv);
-    case NSUnknownIdx:
-	return NamespaceUnknownCmd(clientData, interp, objc, objv);
-    case NSWhichIdx:
-	return NamespaceWhichCmd(clientData, interp, objc, objv);
-    default:
-	Tcl_Panic("unhandled namespace subcommand");
-    }
-    return TCL_ERROR;
+    return TclMakeEnsemble(interp, "namespace", defaultNamespaceMap);
 }
 
 /*
@@ -2959,15 +2883,15 @@ NamespaceChildrenCmd(
      * Get a pointer to the specified namespace, or the current namespace.
      */
 
-    if (objc == 2) {
+    if (objc == 1) {
 	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
-    } else if ((objc == 3) || (objc == 4)) {
-	if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK){
+    } else if ((objc == 2) || (objc == 3)) {
+	if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK){
 	    return TCL_ERROR;
 	}
 	nsPtr = (Namespace *) namespacePtr;
     } else {
-	Tcl_WrongNumArgs(interp, 2, objv, "?name? ?pattern?");
+	Tcl_WrongNumArgs(interp, 1, objv, "?name? ?pattern?");
 	return TCL_ERROR;
     }
 
@@ -2976,8 +2900,8 @@ NamespaceChildrenCmd(
      */
 
     Tcl_DStringInit(&buffer);
-    if (objc == 4) {
-	const char *name = TclGetString(objv[3]);
+    if (objc == 3) {
+	const char *name = TclGetString(objv[2]);
 
 	if ((*name == ':') && (*(name+1) == ':')) {
 	    pattern = name;
@@ -3080,8 +3004,8 @@ NamespaceCodeCmd(
     register const char *arg, *p;
     int length;
 
-    if (objc != 3) {
-	Tcl_WrongNumArgs(interp, 2, objv, "arg");
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "arg");
 	return TCL_ERROR;
     }
 
@@ -3089,7 +3013,7 @@ NamespaceCodeCmd(
      * If "arg" is already a scoped value, then return it directly.
      */
 
-    arg = TclGetStringFromObj(objv[2], &length);
+    arg = TclGetStringFromObj(objv[1], &length);
     while (*arg == ':') {
 	arg++;
 	length--;
@@ -3099,7 +3023,7 @@ NamespaceCodeCmd(
 	    /* empty body: skip over whitespace */
 	}
 	if (*p=='i' && (p+7 <= arg+length) && strncmp(p, "inscope", 7)==0) {
-	    Tcl_SetObjResult(interp, objv[2]);
+	    Tcl_SetObjResult(interp, objv[1]);
 	    return TCL_OK;
 	}
     }
@@ -3126,7 +3050,7 @@ NamespaceCodeCmd(
     }
     Tcl_ListObjAppendElement(interp, listPtr, objPtr);
 
-    Tcl_ListObjAppendElement(interp, listPtr, objv[2]);
+    Tcl_ListObjAppendElement(interp, listPtr, objv[1]);
 
     Tcl_SetObjResult(interp, listPtr);
     return TCL_OK;
@@ -3162,8 +3086,8 @@ NamespaceCurrentCmd(
 {
     register Namespace *currNsPtr;
 
-    if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 2, objv, NULL);
+    if (objc != 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, NULL);
 	return TCL_ERROR;
     }
 
@@ -3227,8 +3151,8 @@ NamespaceDeleteCmd(
     const char *name;
     register int i;
 
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 2, objv, "?name name...?");
+    if (objc < 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?name name...?");
 	return TCL_ERROR;
     }
 
@@ -3238,7 +3162,7 @@ NamespaceDeleteCmd(
      * command line are valid, and report any errors.
      */
 
-    for (i = 2;  i < objc;  i++) {
+    for (i = 1;  i < objc;  i++) {
 	name = TclGetString(objv[i]);
 	namespacePtr = Tcl_FindNamespace(interp, name, NULL, /*flags*/ 0);
 	if ((namespacePtr == NULL)
@@ -3256,7 +3180,7 @@ NamespaceDeleteCmd(
      * Okay, now delete each namespace.
      */
 
-    for (i = 2;  i < objc;  i++) {
+    for (i = 1;  i < objc;  i++) {
 	name = TclGetString(objv[i]);
 	namespacePtr = Tcl_FindNamespace(interp, name, NULL, /* flags */ 0);
 	if (namespacePtr) {
@@ -3295,6 +3219,17 @@ NamespaceDeleteCmd(
 
 static int
 NamespaceEvalCmd(
+    ClientData clientData,	/* Arbitrary value passed to cmd. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, NRNamespaceEvalCmd, clientData, objc,
+	    objv);
+}
+
+static int
+NRNamespaceEvalCmd(
     ClientData dummy,		/* Not used. */
     Tcl_Interp *interp,		/* Current interpreter. */
     int objc,			/* Number of arguments. */
@@ -3308,8 +3243,8 @@ NamespaceEvalCmd(
     Tcl_Obj *objPtr;
     int result;
 
-    if (objc < 4) {
-	Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?");
 	return TCL_ERROR;
     }
 
@@ -3318,14 +3253,14 @@ NamespaceEvalCmd(
      * namespace object along the way.
      */
 
-    result = GetNamespaceFromObj(interp, objv[2], &namespacePtr);
+    result = GetNamespaceFromObj(interp, objv[1], &namespacePtr);
 
     /*
      * If the namespace wasn't found, try to create it.
      */
 
     if (result == TCL_ERROR) {
-	const char *name = TclGetString(objv[2]);
+	const char *name = TclGetString(objv[1]);
 
 	namespacePtr = Tcl_CreateNamespace(interp, name, NULL, NULL);
 	if (namespacePtr == NULL) {
@@ -3346,15 +3281,21 @@ NamespaceEvalCmd(
 	return TCL_ERROR;
     }
 
-    framePtr->objc = objc;
-    framePtr->objv = objv;
+    if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+        framePtr->objc = objc;
+        framePtr->objv = objv;
+    } else {
+        framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+                - iPtr->ensembleRewrite.numInsertedObjs;
+        framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+    }
 
-    if (objc == 4) {
+    if (objc == 3) {
 	/*
 	 * TIP #280: Make actual argument location available to eval'd script.
 	 */
 
-	objPtr = objv[3];
+	objPtr = objv[2];
 	invoker = iPtr->cmdFramePtr;
 	word = 3;
 	TclArgumentGet(interp, objPtr, &invoker, &word);
@@ -3365,7 +3306,7 @@ NamespaceEvalCmd(
 	 * object when it decrements its refcount after eval'ing it.
 	 */
 
-	objPtr = Tcl_ConcatObj(objc-3, objv+3);
+	objPtr = Tcl_ConcatObj(objc-2, objv+2);
 	invoker = NULL;
 	word = 0;
     }
@@ -3438,13 +3379,13 @@ NamespaceExistsCmd(
 {
     Tcl_Namespace *namespacePtr;
 
-    if (objc != 3) {
-	Tcl_WrongNumArgs(interp, 2, objv, "name");
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name");
 	return TCL_ERROR;
     }
 
     Tcl_SetObjResult(interp, Tcl_NewBooleanObj(
-	    GetNamespaceFromObj(interp, objv[2], &namespacePtr) == TCL_OK));
+	    GetNamespaceFromObj(interp, objv[1], &namespacePtr) == TCL_OK));
     return TCL_OK;
 }
 
@@ -3496,8 +3437,8 @@ NamespaceExportCmd(
     int resetListFirst = 0;
     int firstArg, patternCt, i, result;
 
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 2, objv, "?-clear? ?pattern pattern...?");
+    if (objc < 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?-clear? ?pattern pattern...?");
 	return TCL_ERROR;
     }
 
@@ -3505,7 +3446,7 @@ NamespaceExportCmd(
      * Process the optional "-clear" argument.
      */
 
-    firstArg = 2;
+    firstArg = 1;
     if (firstArg < objc) {
 	string = TclGetString(objv[firstArg]);
 	if (strcmp(string, "-clear") == 0) {
@@ -3519,9 +3460,9 @@ NamespaceExportCmd(
      * the namespace's current export pattern list.
      */
 
-    patternCt = (objc - firstArg);
+    patternCt = objc - firstArg;
     if (patternCt == 0) {
-	if (firstArg > 2) {
+	if (firstArg > 1) {
 	    return TCL_OK;
 	} else {
 	    /*
@@ -3595,12 +3536,12 @@ NamespaceForgetCmd(
     const char *pattern;
     register int i, result;
 
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 2, objv, "?pattern pattern...?");
+    if (objc < 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?pattern pattern...?");
 	return TCL_ERROR;
     }
 
-    for (i = 2;  i < objc;  i++) {
+    for (i = 1;  i < objc;  i++) {
 	pattern = TclGetString(objv[i]);
 	result = Tcl_ForgetImport(interp, NULL, pattern);
 	if (result != TCL_OK) {
@@ -3662,8 +3603,8 @@ NamespaceImportCmd(
     register int i, result;
     int firstArg;
 
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 2, objv, "?-force? ?pattern pattern...?");
+    if (objc < 1) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?-force? ?pattern pattern...?");
 	return TCL_ERROR;
     }
 
@@ -3671,7 +3612,7 @@ NamespaceImportCmd(
      * Skip over the optional "-force" as the first argument.
      */
 
-    firstArg = 2;
+    firstArg = 1;
     if (firstArg < objc) {
 	string = TclGetString(objv[firstArg]);
 	if ((*string == '-') && (strcmp(string, "-force") == 0)) {
@@ -3680,7 +3621,7 @@ NamespaceImportCmd(
 	}
     } else {
 	/*
-	 * When objc == 2, command is just [namespace import]. Introspection
+	 * When objc == 1, command is just [namespace import]. Introspection
 	 * form to return list of imported commands.
 	 */
 
@@ -3756,6 +3697,17 @@ NamespaceImportCmd(
 
 static int
 NamespaceInscopeCmd(
+    ClientData clientData,	/* Arbitrary value passed to cmd. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
+    return Tcl_NRCallObjProc(interp, NRNamespaceInscopeCmd, clientData, objc,
+	    objv);
+}
+
+static int
+NRNamespaceInscopeCmd(
     ClientData dummy,		/* Not used. */
     Tcl_Interp *interp,		/* Current interpreter. */
     int objc,			/* Number of arguments. */
@@ -3763,11 +3715,12 @@ NamespaceInscopeCmd(
 {
     Tcl_Namespace *namespacePtr;
     CallFrame *framePtr, **framePtrPtr;
+    register Interp *iPtr = (Interp *) interp;
     int i, result;
     Tcl_Obj *cmdObjPtr;
 
-    if (objc < 4) {
-	Tcl_WrongNumArgs(interp, 2, objv, "name arg ?arg...?");
+    if (objc < 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name arg ?arg...?");
 	return TCL_ERROR;
     }
 
@@ -3775,7 +3728,7 @@ NamespaceInscopeCmd(
      * Resolve the namespace reference.
      */
 
-    if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
+    if (TclGetNamespaceFromObj(interp, objv[1], &namespacePtr) != TCL_OK) {
 	return TCL_ERROR;
     }
 
@@ -3791,8 +3744,14 @@ NamespaceInscopeCmd(
 	return result;
     }
 
-    framePtr->objc = objc;
-    framePtr->objv = objv;
+    if (iPtr->ensembleRewrite.sourceObjs == NULL) {
+        framePtr->objc = objc;
+        framePtr->objv = objv;
+    } else {
+        framePtr->objc = objc + iPtr->ensembleRewrite.numRemovedObjs
+                - iPtr->ensembleRewrite.numInsertedObjs;
+        framePtr->objv = iPtr->ensembleRewrite.sourceObjs;
+    }
 
     /*
      * Execute the command. If there is just one argument, just treat it as a
@@ -3801,21 +3760,21 @@ NamespaceInscopeCmd(
      * of extra arguments to form the command to evaluate.
      */
 
-    if (objc == 4) {
-	cmdObjPtr = objv[3];
+    if (objc == 3) {
+	cmdObjPtr = objv[2];
     } else {
 	Tcl_Obj *concatObjv[2];
 	register Tcl_Obj *listPtr;
 
 	listPtr = Tcl_NewListObj(0, NULL);
-	for (i = 4;  i < objc;  i++) {
+	for (i = 3;  i < objc;  i++) {
 	    if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){
 		Tcl_DecrRefCount(listPtr);	/* Free unneeded obj. */
 		return TCL_ERROR;
 	    }
 	}
 
-	concatObjv[0] = objv[3];
+	concatObjv[0] = objv[2];
 	concatObjv[1] = listPtr;
 	cmdObjPtr = Tcl_ConcatObj(2, concatObjv);
 	Tcl_DecrRefCount(listPtr);    /* We're done with the list object. */
@@ -3865,17 +3824,17 @@ NamespaceOriginCmd(
     Tcl_Command command, origCommand;
     Tcl_Obj *resultPtr;
 
-    if (objc != 3) {
-	Tcl_WrongNumArgs(interp, 2, objv, "name");
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "name");
 	return TCL_ERROR;
     }
 
-    command = Tcl_GetCommandFromObj(interp, objv[2]);
+    command = Tcl_GetCommandFromObj(interp, objv[1]);
     if (command == NULL) {
 	Tcl_AppendResult(interp, "invalid command name \"",
-		TclGetString(objv[2]), "\"", NULL);
+		TclGetString(objv[1]), "\"", NULL);
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
-		TclGetString(objv[2]), NULL);
+		TclGetString(objv[1]), NULL);
 	return TCL_ERROR;
     }
     origCommand = TclGetOriginalCommand(command);
@@ -3925,14 +3884,14 @@ NamespaceParentCmd(
 {
     Tcl_Namespace *nsPtr;
 
-    if (objc == 2) {
+    if (objc == 1) {
 	nsPtr = TclGetCurrentNamespace(interp);
-    } else if (objc == 3) {
-	if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) {
+    } else if (objc == 2) {
+	if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) {
 	    return TCL_ERROR;
 	}
     } else {
-	Tcl_WrongNumArgs(interp, 2, objv, "?name?");
+	Tcl_WrongNumArgs(interp, 1, objv, "?name?");
 	return TCL_ERROR;
     }
 
@@ -3986,8 +3945,8 @@ NamespacePathCmd(
     Tcl_Obj **nsObjv;
     Tcl_Namespace **namespaceList = NULL;
 
-    if (objc > 3) {
-	Tcl_WrongNumArgs(interp, 2, objv, "?pathList?");
+    if (objc > 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?pathList?");
 	return TCL_ERROR;
     }
 
@@ -3995,7 +3954,7 @@ NamespacePathCmd(
      * If no path is given, return the current path.
      */
 
-    if (objc == 2) {
+    if (objc == 1) {
 	/*
 	 * Not a very fast way to compute this, but easy to get right.
 	 */
@@ -4013,7 +3972,7 @@ NamespacePathCmd(
      * There is a path given, so parse it into an array of namespace pointers.
      */
 
-    if (TclListObjGetElements(interp, objv[2], &nsObjc, &nsObjv) != TCL_OK) {
+    if (TclListObjGetElements(interp, objv[1], &nsObjc, &nsObjv) != TCL_OK) {
 	goto badNamespace;
     }
     if (nsObjc != 0) {
@@ -4210,8 +4169,8 @@ NamespaceQualifiersCmd(
     register const char *name, *p;
     int length;
 
-    if (objc != 3) {
-	Tcl_WrongNumArgs(interp, 2, objv, "string");
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "string");
 	return TCL_ERROR;
     }
 
@@ -4220,7 +4179,7 @@ NamespaceQualifiersCmd(
      * the last "::" qualifier.
      */
 
-    name = TclGetString(objv[2]);
+    name = TclGetString(objv[1]);
     for (p = name;  *p != '\0';  p++) {
 	/* empty body */
     }
@@ -4279,14 +4238,14 @@ NamespaceUnknownCmd(
     Tcl_Obj *resultPtr;
     int rc;
 
-    if (objc > 3) {
-	Tcl_WrongNumArgs(interp, 2, objv, "?script?");
+    if (objc > 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?script?");
 	return TCL_ERROR;
     }
 
     currNsPtr = TclGetCurrentNamespace(interp);
 
-    if (objc == 2) {
+    if (objc == 1) {
 	/*
 	 * Introspection - return the current namespace handler.
 	 */
@@ -4297,9 +4256,9 @@ NamespaceUnknownCmd(
 	}
 	Tcl_SetObjResult(interp, resultPtr);
     } else {
-	rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[2]);
+	rc = Tcl_SetNamespaceUnknownHandler(interp, currNsPtr, objv[1]);
 	if (rc == TCL_OK) {
-	    Tcl_SetObjResult(interp, objv[2]);
+	    Tcl_SetObjResult(interp, objv[1]);
 	}
 	return rc;
     }
@@ -4464,8 +4423,8 @@ NamespaceTailCmd(
 {
     register const char *name, *p;
 
-    if (objc != 3) {
-	Tcl_WrongNumArgs(interp, 2, objv, "string");
+    if (objc != 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "string");
 	return TCL_ERROR;
     }
 
@@ -4474,7 +4433,7 @@ NamespaceTailCmd(
      * qualifier.
      */
 
-    name = TclGetString(objv[2]);
+    name = TclGetString(objv[1]);
     for (p = name;  *p != '\0';  p++) {
 	/* empty body */
     }
@@ -4525,17 +4484,17 @@ NamespaceUpvarCmd(
     Var *otherPtr, *arrayPtr;
     const char *myName;
 
-    if (objc < 3 || !(objc & 1)) {
-	Tcl_WrongNumArgs(interp, 2, objv, "ns ?otherVar myVar ...?");
+    if (objc < 2 || (objc & 1)) {
+	Tcl_WrongNumArgs(interp, 1, objv, "ns ?otherVar myVar ...?");
 	return TCL_ERROR;
     }
 
-    if (TclGetNamespaceFromObj(interp, objv[2], &nsPtr) != TCL_OK) {
+    if (TclGetNamespaceFromObj(interp, objv[1], &nsPtr) != TCL_OK) {
 	return TCL_ERROR;
     }
 
-    objc -= 3;
-    objv += 3;
+    objc -= 2;
+    objv += 2;
 
     for (; objc>0 ; objc-=2, objv+=2) {
 	/*
@@ -4600,16 +4559,16 @@ NamespaceWhichCmd(
     int lookupType = 0;
     Tcl_Obj *resultPtr;
 
-    if (objc < 3 || objc > 4) {
+    if (objc < 2 || objc > 3) {
     badArgs:
-	Tcl_WrongNumArgs(interp, 2, objv, "?-command? ?-variable? name");
+	Tcl_WrongNumArgs(interp, 1, objv, "?-command? ?-variable? name");
 	return TCL_ERROR;
-    } else if (objc == 4) {
+    } else if (objc == 3) {
 	/*
 	 * Look for a flag controlling the lookup.
 	 */
 
-	if (Tcl_GetIndexFromObj(interp, objv[2], opts, "option", 0,
+	if (Tcl_GetIndexFromObj(interp, objv[1], opts, "option", 0,
 		&lookupType) != TCL_OK) {
 	    /*
 	     * Preserve old style of error message!
diff --git a/tests/namespace.test b/tests/namespace.test
index cda26f8..643514a 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -890,7 +890,7 @@ test namespace-20.1 {Tcl_NamespaceObjCmd, bad subcommand} {
 } {1 {wrong # args: should be "namespace subcommand ?arg ...?"}}
 test namespace-20.2 {Tcl_NamespaceObjCmd, bad subcommand} -body {
     namespace wombat {}
-} -returnCodes error -match glob -result {bad option "wombat": must be *}
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "wombat": must be *}
 test namespace-20.3 {Tcl_NamespaceObjCmd, abbreviations are okay} {
     namespace ch :: test_ns_*
 } {}
@@ -1002,7 +1002,7 @@ test namespace-25.1 {NamespaceEvalCmd, bad args} {
 } {1 {wrong # args: should be "namespace eval name arg ?arg...?"}}
 test namespace-25.2 {NamespaceEvalCmd, bad args} -body {
     namespace test_ns_1
-} -returnCodes error -match glob -result {bad option "test_ns_1": must be *}
+} -returnCodes error -match glob -result {unknown or ambiguous subcommand "test_ns_1": must be *}
 catch {unset v}
 test namespace-25.3 {NamespaceEvalCmd, new namespace} {
     set v 123
-- 
cgit v0.12


From feb40ba8d2f3784d9284d9f86d2e7ef45342107b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 10 Mar 2011 13:40:43 +0000
Subject: Make tests in child interpreters report their summary info in the
 master. Bumped tcltest version to 2.3.3

---
 ChangeLog                    |  8 ++++++++
 library/tcltest/pkgIndex.tcl |  2 +-
 library/tcltest/tcltest.tcl  | 33 ++++++++++++++++++++++++++++++++-
 tests/init.test              | 28 ++++++++++++----------------
 tests/package.test           |  6 ++----
 unix/Makefile.in             |  4 ++--
 win/Makefile.in              |  4 ++--
 7 files changed, 59 insertions(+), 26 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 9619fd4..a03c070 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,13 @@
 2011-03-10  Donal K. Fellows  <dkf@users.sf.net>
 
+	* library/tcltest/tcltest.tcl (loadIntoSlaveInterpreter): Added this
+	command to handle connecting tcltest to a slave interpreter. This adds
+	in the hook (inside the tcltest namespace) that allows the tests run
+	in the child interpreter to be reported as part of the main sequence
+	of test results. Bumped version of tcltest to 2.3.3.
+	* tests/init.test, tests/package.test: Adapted these test files to use
+	the new feature.
+
 	* generic/tclAlloc.c, generic/tclCmdMZ.c, generic/tclCompExpr.c:
 	* generic/tclCompile.c, generic/tclEnv.c, generic/tclEvent.c:
 	* generic/tclIO.c, generic/tclIOCmd.c, generic/tclIORChan.c:
diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl
index fe80272..2eb43a6 100644
--- a/library/tcltest/pkgIndex.tcl
+++ b/library/tcltest/pkgIndex.tcl
@@ -9,4 +9,4 @@
 # full path name of this file's directory.
 
 if {![package vsatisfies [package provide Tcl] 8.5]} {return}
-package ifneeded tcltest 2.3.2 [list source [file join $dir tcltest.tcl]]
+package ifneeded tcltest 2.3.3 [list source [file join $dir tcltest.tcl]]
diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl
index 15b7293..ad61f9c 100644
--- a/library/tcltest/tcltest.tcl
+++ b/library/tcltest/tcltest.tcl
@@ -22,7 +22,7 @@ namespace eval tcltest {
     # When the version number changes, be sure to update the pkgIndex.tcl file,
     # and the install directory in the Makefiles.  When the minor version
     # changes (new feature) be sure to update the man page as well.
-    variable Version 2.3.2
+    variable Version 2.3.3
 
     # Compatibility support for dumb variables defined in tcltest 1
     # Do not use these.  Call [package provide Tcl] and [info patchlevel]
@@ -795,6 +795,29 @@ namespace eval tcltest {
     trace variable Option(-errfile) w \
 	    [namespace code {errorChannel $Option(-errfile) ;#}]
 
+    proc loadIntoSlaveInterpreter {slave args} {
+	variable Version
+	interp eval $slave [list set ::argv $args]
+	interp eval $slave [list package require tcltest $Version]
+	interp alias $slave ::tcltest::ReportToMaster \
+	    {} ::tcltest::ReportedFromSlave
+    }
+    proc ReportedFromSlave {total passed skipped failed because newfiles} {
+	variable numTests
+	variable skippedBecause
+	variable createdNewFiles
+	incr numTests(Total)   $total
+	incr numTests(Passed)  $passed
+	incr numTests(Skipped) $skipped
+	incr numTests(Failed)  $failed
+	foreach {constraint count} $because {
+	    incr skippedBecause($constraint) $count
+	}
+	foreach {testfile created} $newfiles {
+	    lappend createdNewFiles($testfile) {*}$created
+	}
+	return
+    }
 }
 
 #####################################################################
@@ -2354,6 +2377,14 @@ proc tcltest::cleanupTests {{calledFromAllFile 0}} {
     FillFilesExisted
     set testFileName [file tail [info script]]
 
+    # Hook to handle reporting to a parent interpreter
+    if {[llength [info commands [namespace current]::ReportToMaster]]} {
+	ReportToMaster $numTests(Total) $numTests(Passed) $numTests(Skipped) \
+	    $numTests(Failed) [array get skippedBecause] \
+	    [array get createdNewFiles]
+	set testSingleFile false
+    }
+
     # Call the cleanup hook
     cleanupTestsHook
 
diff --git a/tests/init.test b/tests/init.test
index 40fa507..62b3af2 100644
--- a/tests/init.test
+++ b/tests/init.test
@@ -45,26 +45,22 @@ test init-1.7 {auto_qualify - multiples colons 1} {
 test init-1.8 {auto_qualify - multiple colons 2} {
     auto_qualify :::foo ::bar
 } foo
-
+
 # We use a sub-interp and auto_reset and double the tests because there is 2
 # places where auto_loading occur (before loading the indexes files and after)
 
 set testInterp [interp create]
-interp eval $testInterp [list set argv $argv]
+tcltest::loadIntoSlaveInterpreter $testInterp {*}$argv
 interp eval $testInterp {
-    package require tcltest 2
     namespace import -force ::tcltest::*
     customMatch pairwise {apply {{mode pair} {
 	if {[llength $pair] != 2} {error "need a pair of values to check"}
 	string $mode [lindex $pair 0] [lindex $pair 1]
     }}}
-}
-# TODO: Connect result reporting to master interp
-interp eval $testInterp {
-
-auto_reset
-catch {rename parray {}}
 
+    auto_reset
+    catch {rename parray {}}
+
 test init-2.0 {load parray - stage 1} -body {
     parray
 } -returnCodes error -cleanup {
@@ -127,12 +123,12 @@ test init-3.0 {random stuff in the auto_index, should still work} {
 
 set count 0
 foreach arg [subst -nocommands -novariables {
-		c
-                {argument
+    c
+    {argument
                 which spans
                 multiple lines}
-                {argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack}
-                {argument which spans multiple lines
+    {argument which is all on one line but which is of such great length that the Tcl C library will truncate it when appending it onto the global error stack}
+    {argument which spans multiple lines
                 and is long enough to be truncated and
 "               <- includes a false lead in the prune point search
                 and must be longer still to force truncation}
@@ -141,13 +137,13 @@ foreach arg [subst -nocommands -novariables {
 		error stack cannot be uniquely determined.
 		foo bar foo
 "}
-                {contrived example: rare circumstance 
+    {contrived example: rare circumstance 
 		where the point at which to prune the
 		error stack cannot be uniquely determined.
 		foo bar
 "}
-		{argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library}
-	}] {
+    {argument that contains non-ASCII character, \u20ac, and which is of such great length that it will be longer than 150 bytes so it will be truncated by the Tcl C library}
+	}] {    ;# emacs needs -> "
 
     test init-4.$count.0 {::errorInfo produced by [unknown]} -setup {
 	auto_reset
diff --git a/tests/package.test b/tests/package.test
index dbeedb7..55aaf2b 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -19,11 +19,9 @@ if {"::tcltest" ni [namespace children]} {
 
 # Do all this in a slave interp to avoid garbaging the package list
 set i [interp create]
-interp eval $i [list set argv $argv]
-interp eval $i [list package require tcltest 2]
-interp eval $i [list namespace import -force ::tcltest::*]
+tcltest::loadIntoSlaveInterpreter $i {*}$argv
 interp eval $i {
-
+namespace import -force ::tcltest::*
 package forget {*}[package names]
 set oldPkgUnknown [package unknown]
 package unknown {}
diff --git a/unix/Makefile.in b/unix/Makefile.in
index bba6f91..20ba896 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -836,8 +836,8 @@ install-libraries: libraries
 	    done;
 	@echo "Installing package msgcat 1.4.3 as a Tcl Module";
 	@$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.4.3.tm;
-	@echo "Installing package tcltest 2.3.2 as a Tcl Module";
-	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.2.tm;
+	@echo "Installing package tcltest 2.3.3 as a Tcl Module";
+	@$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.3.tm;
 
 	@echo "Installing package platform 1.0.9 as a Tcl Module";
 	@$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.9.tm;
diff --git a/win/Makefile.in b/win/Makefile.in
index eaf40d1..a2d855d 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -672,8 +672,8 @@ install-libraries: libraries install-tzdata install-msgs
 	    done;
 	@echo "Installing package msgcat 1.4.3 as a Tcl Module";
 	@$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.4.3.tm;
-	@echo "Installing package tcltest 2.3.2 as a Tcl Module";
-	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.2.tm;
+	@echo "Installing package tcltest 2.3.3 as a Tcl Module";
+	@$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.3.tm;
 	@echo "Installing package platform 1.0.9 as a Tcl Module";
 	@$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.9.tm;
 	@echo "Installing package platform::shell 1.1.4 as a Tcl Module";
-- 
cgit v0.12


From a4400dbc29df9167ce93222e822d8f2868215f8a Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 10 Mar 2011 14:12:40 +0000
Subject: fix broken build

---
 unix/tclUnixNotfy.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c
index 7dcfc7d..34e1fbb 100644
--- a/unix/tclUnixNotfy.c
+++ b/unix/tclUnixNotfy.c
@@ -1043,7 +1043,7 @@ NotifierThreadProc(
 		    found = 1;
 		}
 		if (FD_ISSET(i, &tsdPtr->checkMasks.exception)
-			&& FD_ISSET(i, &exceptionalMask)) {
+			&& FD_ISSET(i, &exceptionMask)) {
 		    FD_SET(i, &tsdPtr->readyMasks.exception);
 		    found = 1;
 		}
-- 
cgit v0.12


From 226803c44fa0615537f00d627caf13edc292ae67 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 10 Mar 2011 15:31:47 +0000
Subject: Fix most of the failing tests (some of which were due to breakage
 done to the parser used in auto_mkIndex; never a good idea to delete the
 ::tcl NS!)

---
 library/auto.tcl  |  9 ++++++++-
 tests/interp.test | 10 +++++-----
 tests/nre.test    | 30 ++++++++++++++++++------------
 3 files changed, 31 insertions(+), 18 deletions(-)

diff --git a/library/auto.tcl b/library/auto.tcl
index c84ab58..4bd860d 100644
--- a/library/auto.tcl
+++ b/library/auto.tcl
@@ -304,7 +304,14 @@ namespace eval auto_mkindex_parser {
 	    $parser hide namespace
 	    $parser hide eval
 	    $parser hide puts
-	    $parser invokehidden namespace delete ::
+	    foreach ns [$parser invokehidden namespace children ::] {
+		# MUST NOT DELETE "::tcl" OR BAD THINGS HAPPEN!
+		if {$ns eq "::tcl"} continue
+		$parser invokehidden namespace delete $ns
+	    }
+	    foreach cmd [$parser invokehidden info commands ::*] {
+		$parser invokehidden rename $cmd {}
+	    }
 	    $parser invokehidden proc unknown {args} {}
 
 	    # We'll need access to the "namespace" command within the
diff --git a/tests/interp.test b/tests/interp.test
index fd6090e..35f6824 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -2328,17 +2328,17 @@ test interp-28.1 {getting fooled by slave's namespace ?} -setup {
 } -result {}
 test interp-28.2 {master's nsName cache should not cross} -setup {
     set i [interp create]
+    $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}}
 } -body {
     $i eval {
 	set x {namespace children ::}
 	set y [list namespace children ::]
-	namespace delete {*}[{*}$y]
+	namespace delete {*}[filter [{*}$y]]
 	set j [interp create]
-	$j eval {namespace delete {*}[namespace children ::]}
+	$j alias filter filter
+	$j eval {namespace delete {*}[filter [namespace children ::]]}
 	namespace eval foo {}
-	set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]]
-	interp delete $j
-	set res
+	list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]]
     }
 } -cleanup {
     interp delete $i
diff --git a/tests/nre.test b/tests/nre.test
index c0d0aaa..2c97edc 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -60,7 +60,7 @@ if {[testConstraint testnrelevels]} {
     }
     namespace import testnre::*
 }
-
+
 test nre-1.1 {self-recursive procs} -setup {
     proc a i [makebody {a $i}]
 } -body {
@@ -411,23 +411,24 @@ test nre-oo.5 {really deep calls in oo - forwards} -setup {
 # NASTY BUG found by tcllib's interp package
 #
 
-test nre-X.1 {eval in wrong interp} {
+test nre-X.1 {eval in wrong interp} -setup {
     set i [interp create]
-    set res [$i eval {
+    $i eval {proc filter lst {lsearch -all -inline -not $lst "::tcl"}}
+} -body {
+    $i eval {
 	set x {namespace children ::}
 	set y [list namespace children ::]
-	namespace delete {*}[{*}$y]
+	namespace delete {*}[filter [{*}$y]]
 	set j [interp create]
-	$j eval {namespace delete {*}[namespace children ::]}
+	$j alias filter filter
+	$j eval {namespace delete {*}[filter [namespace children ::]]}
 	namespace eval foo {}
-	set res [list [eval $x] [eval $y] [$j eval $x] [$j eval $y]]
-	interp delete $j
-	set res
-    }]
+	list [filter [eval $x]] [filter [eval $y]] [filter [$j eval $x]] [filter [$j eval $y]]
+    }
+} -cleanup {
     interp delete $i
-    set res
-} {::foo ::foo {} {}}
-
+} -result {::foo ::foo {} {}}
+
 # cleanup
 ::tcltest::cleanupTests
 
@@ -437,3 +438,8 @@ if {[testConstraint testnrelevels]} {
 }
 
 return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
-- 
cgit v0.12


From 595b0578b02537167e39fb7f4d2c25a18b196391 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 10 Mar 2011 16:25:31 +0000
Subject: Fix remaining broken tests (test failures appear non-serious)

---
 generic/tclTest.c | 8 ++++----
 tests/nre.test    | 4 ++--
 2 files changed, 6 insertions(+), 6 deletions(-)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index fc29702..47d271e 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -6724,7 +6724,7 @@ TestNRELevels(
     ptrdiff_t depth;
     Tcl_Obj *levels[6];
     int i = 0;
-    NRE_callback *cbPtr = ((Interp *) interp)->execEnvPtr->callbackPtr;
+    NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
 
     if (refDepth == NULL) {
 	refDepth = &depth;
@@ -6733,11 +6733,11 @@ TestNRELevels(
     depth = (refDepth - &depth);
 
     levels[0] = Tcl_NewIntObj(depth);
-    levels[1] = Tcl_NewIntObj(((Interp *)interp)->numLevels);
+    levels[1] = Tcl_NewIntObj(iPtr->numLevels);
     levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level);
     levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
-    levels[4] = Tcl_NewIntObj((iPtr->execEnvPtr->execStackPtr->tosPtr
-		    - iPtr->execEnvPtr->execStackPtr->stackWords));
+    levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
+	    - iPtr->execEnvPtr->execStackPtr->stackWords);
 
     while (cbPtr) {
 	i++;
diff --git a/tests/nre.test b/tests/nre.test
index 2c97edc..295f02e 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -161,7 +161,7 @@ test nre-5.1 {[namespace eval] is not recursive} -setup {
     namespace delete ::foo
 } -constraints {
     testnrelevels
-} -result {{0 2 2 2} 0}
+} -result {{0 3 2 2} 0}
 
 test nre-5.2 {[namespace eval] is not recursive} -setup {
     namespace eval ::foo {
@@ -174,7 +174,7 @@ test nre-5.2 {[namespace eval] is not recursive} -setup {
     namespace delete ::foo
 } -constraints {
     testnrelevels
-} -result {{0 2 2 2} 0}
+} -result {{0 3 2 2} 0}
 
 test nre-6.1 {[uplevel] is not recursive} -setup {
     proc a i [makebody {uplevel 1 [list a $i]}]
-- 
cgit v0.12


From 1d5c8f395413d93b65f5d82deda05776957456b2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 10 Mar 2011 21:32:14 +0000
Subject: Add ChangeLog entry.

---
 ChangeLog | 8 ++++++++
 1 file changed, 8 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index a03c070..7724d9d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,13 @@
 2011-03-10  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclBasic.c, generic/tclCompCmds.c, generic/tclEnsemble.c:
+	* generic/tclInt.h, generic/tclNamesp.c, library/auto.tcl:
+	* tests/interp.test, tests/namespace.test, tests/nre.test:
+	Converted the [namespace] command into an ensemble. This has the
+	consequence of making it vital for Tcl code that wishes to work with
+	namespaces to _not_ delete the ::tcl namespace.
+	***POTENTIAL INCOMPATIBILITY***
+
 	* library/tcltest/tcltest.tcl (loadIntoSlaveInterpreter): Added this
 	command to handle connecting tcltest to a slave interpreter. This adds
 	in the hook (inside the tcltest namespace) that allows the tests run
-- 
cgit v0.12


From c1b078e39707aa499f02daa1c07b4bd087f3e6e1 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 11 Mar 2011 22:20:16 +0000
Subject: More test suite updating.

---
 ChangeLog           |  4 ++++
 tests/unixInit.test | 55 +++++++++++++++++++++--------------------------------
 2 files changed, 26 insertions(+), 33 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 7724d9d..088a51f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-03-11  Donal K. Fellows  <dkf@users.sf.net>
+
+	* tests/unixInit.test: Make better use of tcltest2.
+
 2011-03-10  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclBasic.c, generic/tclCompCmds.c, generic/tclEnsemble.c:
diff --git a/tests/unixInit.test b/tests/unixInit.test
index 580a231..9ba9c11 100644
--- a/tests/unixInit.test
+++ b/tests/unixInit.test
@@ -73,8 +73,7 @@ test unixInit-1.2 {initialisation: standard channel type deduction} {unix stdio}
     # Can't use normal comparison, as hostname varies due to some
     # installations having a messed up /etc/hosts file.
     if {
-	[string equal 127.0.0.1 [lindex $result 0]] &&
-	[string equal $port     [lindex $result 2]]
+	"127.0.0.1" eq [lindex $result 0] && $port == [lindex $result 2]
     } then {
 	subst "OK"
     } else {
@@ -106,16 +105,14 @@ test unixInit-2.1 {TclpInitLibraryPath: value of installLib, developLib} -setup
     set installLib lib/tcl[info tclversion]
     set developLib tcl[info patchlevel]/library
     set prefix [file dirname [file dirname [interpreter]]]
-    set x {}
-    lappend x [string compare [lindex $path 0] $prefix/$installLib]
-    lappend x [string compare [lindex $path 4] [file dirname $prefix]/$developLib]
-    set x
+    list [string equal [lindex $path 0] $prefix/$installLib] \
+	[string equal [lindex $path 4] [file dirname $prefix]/$developLib]
 } -cleanup {
     if {[info exists oldlibrary]} {
 	set env(TCL_LIBRARY) $oldlibrary
 	unset oldlibrary
     }
-} -result {0 0}
+} -result {1 1}
 test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup {
     unset -nocomplain oldlibrary
     if {[info exists env(TCL_LIBRARY)]} {
@@ -124,10 +121,9 @@ test unixInit-2.2 {TclpInitLibraryPath: TCL_LIBRARY} -setup {
 } -body {
     # ((str != NULL) && (str[0] != '\0'))
     set env(TCL_LIBRARY) sparkly
-    set path [getlibpath]
-    unset env(TCL_LIBRARY)
-    lindex $path 0
+    lindex [getlibpath] 0
 } -cleanup {
+    unset -nocomplain env(TCL_LIBRARY)
     if {[info exists oldlibrary]} {
 	set env(TCL_LIBRARY) $oldlibrary
 	unset oldlibrary
@@ -141,10 +137,9 @@ test unixInit-2.3 {TclpInitLibraryPath: TCL_LIBRARY wrong version} -setup {
 } -body {
     # ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc - 1]) != 0))
     set env(TCL_LIBRARY) /a/b/tcl1.7
-    set path [getlibpath]
-    unset env(TCL_LIBRARY)
-    lrange $path 0 1
+    lrange [getlibpath] 0 1
 } -cleanup {
+    unset -nocomplain env(TCL_LIBRARY)
     if {[info exists oldlibrary]} {
 	set env(TCL_LIBRARY) $oldlibrary
 	unset oldlibrary
@@ -157,11 +152,9 @@ test unixInit-2.4 {TclpInitLibraryPath: TCL_LIBRARY: INTL} -setup {
 } -body {
     # Child process translates env variable from native encoding.
     set env(TCL_LIBRARY) "\xa7"
-    set x [lindex [getlibpath] 0]
-    unset env(TCL_LIBRARY)
-    unset env(LANG)
-    set x
+    lindex [getlibpath] 0
 } -cleanup {
+    unset -nocomplain env(TCL_LIBRARY) env(LANG)
     if {[info exists oldlibrary]} {
 	set env(TCL_LIBRARY) $oldlibrary
 	unset oldlibrary
@@ -315,21 +308,15 @@ test unixInit-2.10 {TclpInitLibraryPath: executable relative} -setup {
     set y
 } -cleanup {
     cd $saveDir
-    unset saveDir
     removeFile init.tcl $scriptDir
-    unset scriptDir
     removeDirectory tcl[info tclversion] $libDir
-    unset libDir
     file delete $execPath
-    unset execPath
     removeDirectory bin $sparklyDir
     removeDirectory lib $sparklyDir
-    unset sparklyDir
     removeDirectory sparkly $tmpDir
-    unset tmpDir
     removeDirectory tmp
-    unset x p y
-    unset env(TCL_LIBRARY)
+    unset -nocomplain saveDir scriptDir libDir execPath sparklyDir tmpDir
+    unset -nocomplain x p y env(TCL_LIBRARY)
     if {[info exists oldlibrary]} {
 	set env(TCL_LIBRARY) $oldlibrary
 	unset oldlibrary
@@ -346,22 +333,21 @@ test unixInit-3.1 {TclpSetInitialEncodings} -constraints {
     puts $f {puts [encoding system]; exit}
     set enc [gets $f]
     close $f
-    unset env(LANG)
-    set enc
+    return $enc
+} -cleanup {
+    unset -nocomplain env(LANG)
 } -match regexp -result [expr {
 	($tcl_platform(os) eq "Darwin") ? "^utf-8$" : "^iso8859-15?$"}]
-test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} {
-    set env(LANG) japanese
+test unixInit-3.2 {TclpSetInitialEncodings} -setup {
     catch {set oldlc_all $env(LC_ALL)}
+} -constraints {unix stdio} -body {
+    set env(LANG) japanese
     set env(LC_ALL) japanese
     set f [open "|[list [interpreter]]" w+]
     fconfigure $f -buffering none
     puts $f {puts [encoding system]; exit}
     set enc [gets $f]
     close $f
-    unset env(LANG)
-    unset env(LC_ALL)
-    catch {set env(LC_ALL) $oldlc_all}
     set validEncodings [list euc-jp]
     if {[string match HP-UX $tcl_platform(os)]} {
 	# Some older HP-UX systems need us to accept this as valid Bug 453883
@@ -369,7 +355,10 @@ test unixInit-3.2 {TclpSetInitialEncodings} {unix stdio} {
 	lappend validEncodings shiftjis
     }
     expr {$enc ni $validEncodings}
-} 0
+} -cleanup {
+    unset -nocomplain env(LANG) env(LC_ALL)
+    catch {set env(LC_ALL) $oldlc_all}
+} -result 0
 
 test unixInit-4.1 {TclpSetVariables} {unix} {
     # just make sure they exist
-- 
cgit v0.12


From 0d3106376c20bbe48cba344885fcad371b72b50f Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Sat, 12 Mar 2011 00:52:22 +0000
Subject: [Bug 3185609] File normalization corner case of ... broken with
 -DUNICODE

---
 ChangeLog        | 5 +++++
 win/tclWinFile.c | 6 +++---
 2 files changed, 8 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 088a51f..99c6758 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-03-12  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* win/tclWinFile.c: [Bug 3185609] File normalization
+	corner case of ... broken with -DUNICODE
+
 2011-03-11  Donal K. Fellows  <dkf@users.sf.net>
 
 	* tests/unixInit.test: Make better use of tcltest2.
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 34be41f..620c454 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -2776,9 +2776,9 @@ TclpObjNormalizePath(
 			 * path segment and continue.
 			 */
 
-			Tcl_DStringAppend(&dsNorm, (const char *)
-				((WCHAR *)(nativePath + Tcl_DStringLength(&ds))
-				- dotLen), (int)(dotLen * sizeof(WCHAR)));
+			Tcl_DStringAppend(&dsNorm,
+				((const char *) nativePath) + Tcl_DStringLength(&ds)
+				- (dotLen * sizeof(TCHAR)), (int)(dotLen * sizeof(TCHAR)));
 		    } else {
 			/*
 			 * Normal path.
-- 
cgit v0.12


From 2ff0db90f57b60e46b714f2b5cdb1d2c5eacce98 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 12 Mar 2011 15:06:47 +0000
Subject: Adjust ckalloc/ckfree macros to greatly reduce number of explicit
 casts in rest of Tcl source code. No ABI change. API change *should* be
 harmless.

---
 ChangeLog                  |  13 +-
 generic/tcl.h              |  30 +++--
 generic/tclAssembly.c      |  18 +--
 generic/tclAsync.c         |   4 +-
 generic/tclBasic.c         | 151 +++++++++++------------
 generic/tclBinary.c        |  20 ++-
 generic/tclClock.c         |   8 +-
 generic/tclCmdAH.c         |   2 +-
 generic/tclCmdMZ.c         |   6 +-
 generic/tclCompCmds.c      |  37 +++---
 generic/tclCompCmdsSZ.c    |  35 +++---
 generic/tclCompExpr.c      |  16 +--
 generic/tclCompile.c       | 147 +++++++++++-----------
 generic/tclConfig.c        |   7 +-
 generic/tclDictObj.c       |  28 ++---
 generic/tclEncoding.c      |  34 +++---
 generic/tclEnsemble.c      |  22 ++--
 generic/tclEnv.c           |  17 ++-
 generic/tclEvent.c         |  41 +++----
 generic/tclExecute.c       |  20 +--
 generic/tclFileName.c      |   5 +-
 generic/tclHash.c          |  20 +--
 generic/tclHistory.c       |   4 +-
 generic/tclIO.c            |  82 ++++++-------
 generic/tclIOCmd.c         |  14 +--
 generic/tclIOGT.c          |  12 +-
 generic/tclIORChan.c       |  28 ++---
 generic/tclIORTrans.c      |  24 ++--
 generic/tclIOUtil.c        |  36 +++---
 generic/tclIndexObj.c      |  26 ++--
 generic/tclInterp.c        |  33 +++--
 generic/tclLink.c          |  10 +-
 generic/tclListObj.c       |  22 ++--
 generic/tclLiteral.c       |  26 ++--
 generic/tclLoad.c          |  20 +--
 generic/tclMain.c          |   5 +-
 generic/tclNamesp.c        |  40 +++---
 generic/tclNotify.c        |  12 +-
 generic/tclOO.c            |  84 ++++++-------
 generic/tclOOBasic.c       |   2 +-
 generic/tclOOCall.c        |  27 ++---
 generic/tclOODefineCmds.c  |  61 ++++------
 generic/tclOOInfo.c        |   4 +-
 generic/tclOOMethod.c      |  45 ++++---
 generic/tclObj.c           |  49 ++++----
 generic/tclParse.c         |   8 +-
 generic/tclPathObj.c       |  16 +--
 generic/tclPipe.c          |  10 +-
 generic/tclPkg.c           |  12 +-
 generic/tclPreserve.c      |  20 ++-
 generic/tclProc.c          |  68 +++++------
 generic/tclRegexp.c        |  12 +-
 generic/tclResolve.c       |   6 +-
 generic/tclResult.c        |  12 +-
 generic/tclScan.c          |  13 +-
 generic/tclStrToD.c        |   5 +-
 generic/tclStringObj.c     |  16 +--
 generic/tclTest.c          |  74 ++++++------
 generic/tclTestObj.c       |   4 +-
 generic/tclThread.c        |  15 +--
 generic/tclThreadJoin.c    |   4 +-
 generic/tclThreadStorage.c |   2 +-
 generic/tclThreadTest.c    |  18 +--
 generic/tclTimer.c         |  30 ++---
 generic/tclTrace.c         |  54 ++++-----
 generic/tclUtil.c          |  53 ++++----
 generic/tclVar.c           |  30 +++--
 generic/tclZlib.c          |  11 +-
 macosx/tclMacOSXNotify.c   |   8 +-
 unix/tclLoadDl.c           |   6 +-
 unix/tclLoadDyld.c         |  22 ++--
 unix/tclLoadNext.c         |   4 +-
 unix/tclLoadOSF.c          |   4 +-
 unix/tclLoadShl.c          |   4 +-
 unix/tclUnixChan.c         |  26 ++--
 unix/tclUnixFile.c         |   4 +-
 unix/tclUnixInit.c         |   4 +-
 unix/tclUnixNotfy.c        |   6 +-
 unix/tclUnixPipe.c         |   8 +-
 unix/tclUnixSock.c         |  28 ++---
 unix/tclUnixThrd.c         |  11 +-
 unix/tclXtNotify.c         |   6 +-
 win/tclAppInit.c           |   4 +-
 win/tclWin32Dll.c          |  12 +-
 win/tclWinChan.c           |   6 +-
 win/tclWinConsole.c        |   8 +-
 win/tclWinDde.c            |   8 +-
 win/tclWinFCmd.c           |   4 +-
 win/tclWinFile.c           | 296 ++++++++++++++++++++++-----------------------
 win/tclWinInit.c           |   8 +-
 win/tclWinLoad.c           |  11 +-
 win/tclWinPipe.c           |  24 ++--
 win/tclWinReg.c            |   8 +-
 win/tclWinSerial.c         |  18 +--
 win/tclWinSock.c           |  14 +--
 win/tclWinTest.c           |  14 +--
 win/tclWinThrd.c           |   8 +-
 97 files changed, 1178 insertions(+), 1246 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 99c6758..37bd48b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,16 @@
+2011-03-12  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tcl.h (ckalloc,ckfree,ckrealloc): Moved casts into these
+	macro so that they work with VOID* (which is a void* on all platforms
+	which Tcl actually builds on) and unsigned int for the length
+	parameters, removing the need for MANY casts across the rest of Tcl.
+	Note that this is a strict source-level-only change, so size_t cannot
+	be used (would break binary compatibility on 64-bit platforms).
+
 2011-03-12  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinFile.c: [Bug 3185609] File normalization
-	corner case of ... broken with -DUNICODE
+	* win/tclWinFile.c: [Bug 3185609]: File normalization corner case
+	of ... broken with -DUNICODE
 
 2011-03-11  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tcl.h b/generic/tcl.h
index 41875bf..2abbb1a 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2402,11 +2402,16 @@ EXTERN void		Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
 
 #ifdef TCL_MEM_DEBUG
 
-#   define ckalloc(x) Tcl_DbCkalloc(x, __FILE__, __LINE__)
-#   define ckfree(x)  Tcl_DbCkfree(x, __FILE__, __LINE__)
-#   define ckrealloc(x,y) Tcl_DbCkrealloc((x), (y),__FILE__, __LINE__)
-#   define attemptckalloc(x) Tcl_AttemptDbCkalloc(x, __FILE__, __LINE__)
-#   define attemptckrealloc(x,y) Tcl_AttemptDbCkrealloc((x), (y), __FILE__, __LINE__)
+#   define ckalloc(x) \
+    ((VOID *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__))
+#   define ckfree(x) \
+    Tcl_DbCkfree((VOID *)(x), __FILE__, __LINE__)
+#   define ckrealloc(x,y) \
+    ((VOID *) Tcl_DbCkrealloc((VOID *)(x), (unsigned)(y), __FILE__, __LINE__))
+#   define attemptckalloc(x) \
+    ((VOID *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__))
+#   define attemptckrealloc(x,y) \
+    ((VOID *) Tcl_AttemptDbCkrealloc((VOID *)(x), (unsigned)(y), __FILE__, __LINE__))
 
 #else /* !TCL_MEM_DEBUG */
 
@@ -2416,11 +2421,16 @@ EXTERN void		Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
  * memory allocator both inside and outside of the Tcl library.
  */
 
-#   define ckalloc(x) Tcl_Alloc(x)
-#   define ckfree(x) Tcl_Free(x)
-#   define ckrealloc(x,y) Tcl_Realloc(x,y)
-#   define attemptckalloc(x) Tcl_AttemptAlloc(x)
-#   define attemptckrealloc(x,y) Tcl_AttemptRealloc(x,y)
+#   define ckalloc(x) \
+    ((VOID *) Tcl_Alloc((unsigned)(x)))
+#   define ckfree(x) \
+    Tcl_Free((VOID *)(x))
+#   define ckrealloc(x,y) \
+    ((VOID *) Tcl_Realloc((VOID *)(x), (unsigned)(y)))
+#   define attemptckalloc(x) \
+    ((VOID *) Tcl_AttemptAlloc((unsigned)(x)))
+#   define attemptckrealloc(x,y) \
+    ((VOID *) Tcl_AttemptRealloc((VOID *)(x), (unsigned)(y)))
 #   undef  Tcl_InitMemory
 #   define Tcl_InitMemory(x)
 #   undef  Tcl_DumpActiveMemory
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index e11d68a..45756eb 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -1162,14 +1162,14 @@ FreeAssemblyEnv(
 	    Tcl_DecrRefCount(thisBB->jumpTarget);
 	}
 	if (thisBB->foreignExceptions != NULL) {
-	    ckfree((char*) thisBB->foreignExceptions);
+	    ckfree(thisBB->foreignExceptions);
 	}
 	nextBB = thisBB->successor1;
 	if (thisBB->jtPtr != NULL) {
 	    DeleteMirrorJumpTable(thisBB->jtPtr);
 	    thisBB->jtPtr = NULL;
 	}
-	ckfree((char*) thisBB);
+	ckfree(thisBB);
     }
 
     /*
@@ -1478,7 +1478,7 @@ AssembleOneLine(
 	    goto cleanup;
 	}
 
-	jtPtr = (JumptableInfo*) ckalloc(sizeof(JumptableInfo));
+	jtPtr = ckalloc(sizeof(JumptableInfo));
 
 	Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
 	assemEnvPtr->curr_bb->jumpLine = assemEnvPtr->cmdLine;
@@ -1873,7 +1873,7 @@ MoveExceptionRangesToBasicBlock(
 	    curr_bb, exceptionCount, savedExceptArrayNext);
     curr_bb->foreignExceptionBase = savedExceptArrayNext;
     curr_bb->foreignExceptionCount = exceptionCount;
-    curr_bb->foreignExceptions = (ExceptionRange*)
+    curr_bb->foreignExceptions = 
 	    ckalloc(exceptionCount * sizeof(ExceptionRange));
     memcpy(curr_bb->foreignExceptions,
 	    envPtr->exceptArrayPtr + savedExceptArrayNext,
@@ -1940,7 +1940,7 @@ CreateMirrorJumpTable(
      * Allocate the jumptable.
      */
 
-    jtPtr = (JumptableInfo*) ckalloc(sizeof(JumptableInfo));
+    jtPtr = ckalloc(sizeof(JumptableInfo));
     jtHashPtr = &jtPtr->hashTable;
     Tcl_InitHashTable(jtHashPtr, TCL_STRING_KEYS);
 
@@ -2007,7 +2007,7 @@ DeleteMirrorJumpTable(
 	Tcl_SetHashValue(entry, NULL);
     }
     Tcl_DeleteHashTable(jtHashPtr);
-    ckfree((char*) jtPtr);
+    ckfree(jtPtr);
 }
 
 /*
@@ -2606,7 +2606,7 @@ AllocBB(
     AssemblyEnv* assemEnvPtr)	/* Assembly environment */
 {
     CompileEnv* envPtr = assemEnvPtr->envPtr;
-    BasicBlock * bb = (BasicBlock *) ckalloc(sizeof(BasicBlock));
+    BasicBlock *bb = ckalloc(sizeof(BasicBlock));
 
     bb->originalStartOffset =
 	    bb->startOffset = envPtr->codeNext - envPtr->codeStart;
@@ -3889,8 +3889,8 @@ BuildExceptionRanges(
      * Allocate memory for a stack of active catches.
      */
 
-    catches = (BasicBlock**) ckalloc(maxCatchDepth * sizeof(BasicBlock*));
-    catchIndices = (int*) ckalloc(maxCatchDepth * sizeof(int));
+    catches = ckalloc(maxCatchDepth * sizeof(BasicBlock*));
+    catchIndices = ckalloc(maxCatchDepth * sizeof(int));
     for (i = 0; i < maxCatchDepth; ++i) {
 	catches[i] = NULL;
 	catchIndices[i] = -1;
diff --git a/generic/tclAsync.c b/generic/tclAsync.c
index f210004..14804e4 100644
--- a/generic/tclAsync.c
+++ b/generic/tclAsync.c
@@ -118,7 +118,7 @@ Tcl_AsyncCreate(
     AsyncHandler *asyncPtr;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
-    asyncPtr = (AsyncHandler *) ckalloc(sizeof(AsyncHandler));
+    asyncPtr = ckalloc(sizeof(AsyncHandler));
     asyncPtr->ready = 0;
     asyncPtr->nextPtr = NULL;
     asyncPtr->proc = proc;
@@ -310,7 +310,7 @@ Tcl_AsyncDelete(
 	}
     }
     Tcl_MutexUnlock(&tsdPtr->asyncMutex);
-    ckfree((char *) asyncPtr);
+    ckfree(asyncPtr);
 }
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9d5b006..adf8e2d 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -499,7 +499,7 @@ Tcl_CreateInterp(void)
      * object type table and other object management code.
      */
 
-    iPtr = (Interp *) ckalloc(sizeof(Interp));
+    iPtr = ckalloc(sizeof(Interp));
     interp = (Tcl_Interp *) iPtr;
 
     iPtr->result = iPtr->resultSpace;
@@ -523,10 +523,10 @@ Tcl_CreateInterp(void)
      */
 
     iPtr->cmdFramePtr = NULL;
-    iPtr->linePBodyPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
-    iPtr->lineBCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
-    iPtr->lineLAPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
-    iPtr->lineLABCPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+    iPtr->linePBodyPtr = ckalloc(sizeof(Tcl_HashTable));
+    iPtr->lineBCPtr = ckalloc(sizeof(Tcl_HashTable));
+    iPtr->lineLAPtr = ckalloc(sizeof(Tcl_HashTable));
+    iPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable));
     Tcl_InitHashTable(iPtr->linePBodyPtr, TCL_ONE_WORD_KEYS);
     Tcl_InitHashTable(iPtr->lineBCPtr, TCL_ONE_WORD_KEYS);
     Tcl_InitHashTable(iPtr->lineLAPtr, TCL_ONE_WORD_KEYS);
@@ -624,7 +624,7 @@ Tcl_CreateInterp(void)
      */
 
     /* This is needed to satisfy GCC 3.3's strict aliasing rules */
-    framePtr = (CallFrame *) ckalloc(sizeof(CallFrame));
+    framePtr = ckalloc(sizeof(CallFrame));
     result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
 	    (Tcl_Namespace *) iPtr->globalNsPtr, /*isProcCallFrame*/ 0);
     if (result != TCL_OK) {
@@ -657,7 +657,7 @@ Tcl_CreateInterp(void)
 
     iPtr->asyncCancelMsg = Tcl_NewObj();
 
-    cancelInfo = (CancelInfo *) ckalloc(sizeof(CancelInfo));
+    cancelInfo = ckalloc(sizeof(CancelInfo));
     cancelInfo->interp = interp;
 
     iPtr->asyncCancel = Tcl_AsyncCreate(CancelEvalProc, cancelInfo);
@@ -758,7 +758,7 @@ Tcl_CreateInterp(void)
 	hPtr = Tcl_CreateHashEntry(&iPtr->globalNsPtr->cmdTable,
 		cmdInfoPtr->name, &isNew);
 	if (isNew) {
-	    cmdPtr = (Command *) ckalloc(sizeof(Command));
+	    cmdPtr = ckalloc(sizeof(Command));
 	    cmdPtr->hPtr = hPtr;
 	    cmdPtr->nsPtr = iPtr->globalNsPtr;
 	    cmdPtr->refCount = 1;
@@ -875,8 +875,7 @@ Tcl_CreateInterp(void)
 #define MATH_OP_PREFIX_LEN 15 /* == strlen("::tcl::mathop::") */
     memcpy(mathFuncName, "::tcl::mathop::", MATH_OP_PREFIX_LEN);
     for (opcmdInfoPtr=mathOpCmds ; opcmdInfoPtr->name!=NULL ; opcmdInfoPtr++){
-	TclOpCmdClientData *occdPtr = (TclOpCmdClientData *)
-		ckalloc(sizeof(TclOpCmdClientData));
+	TclOpCmdClientData *occdPtr = ckalloc(sizeof(TclOpCmdClientData));
 
 	occdPtr->op = opcmdInfoPtr->name;
 	occdPtr->i.numArgs = opcmdInfoPtr->i.numArgs;
@@ -979,7 +978,7 @@ DeleteOpCmdClientData(
 {
     TclOpCmdClientData *occdPtr = clientData;
 
-    ckfree((char *) occdPtr);
+    ckfree(occdPtr);
 }
 
 /*
@@ -1050,14 +1049,14 @@ Tcl_CallWhenDeleted(
 	    Tcl_GetThreadData(&assocDataCounterKey, (int)sizeof(int));
     int isNew;
     char buffer[32 + TCL_INTEGER_SPACE];
-    AssocData *dPtr = (AssocData *) ckalloc(sizeof(AssocData));
+    AssocData *dPtr = ckalloc(sizeof(AssocData));
     Tcl_HashEntry *hPtr;
 
     sprintf(buffer, "Assoc Data Key #%d", *assocDataCounterPtr);
     (*assocDataCounterPtr)++;
 
     if (iPtr->assocData == NULL) {
-	iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+	iPtr->assocData = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
     }
     hPtr = Tcl_CreateHashEntry(iPtr->assocData, buffer, &isNew);
@@ -1106,7 +1105,7 @@ Tcl_DontCallWhenDeleted(
 	    hPtr = Tcl_NextHashEntry(&hSearch)) {
 	dPtr = Tcl_GetHashValue(hPtr);
 	if ((dPtr->proc == proc) && (dPtr->clientData == clientData)) {
-	    ckfree((char *) dPtr);
+	    ckfree(dPtr);
 	    Tcl_DeleteHashEntry(hPtr);
 	    return;
 	}
@@ -1146,14 +1145,14 @@ Tcl_SetAssocData(
     int isNew;
 
     if (iPtr->assocData == NULL) {
-	iPtr->assocData = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+	iPtr->assocData = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(iPtr->assocData, TCL_STRING_KEYS);
     }
     hPtr = Tcl_CreateHashEntry(iPtr->assocData, name, &isNew);
     if (isNew == 0) {
 	dPtr = Tcl_GetHashValue(hPtr);
     } else {
-	dPtr = (AssocData *) ckalloc(sizeof(AssocData));
+	dPtr = ckalloc(sizeof(AssocData));
     }
     dPtr->proc = proc;
     dPtr->clientData = clientData;
@@ -1198,7 +1197,7 @@ Tcl_DeleteAssocData(
     if (dPtr->proc != NULL) {
 	dPtr->proc(dPtr->clientData, interp);
     }
-    ckfree((char *) dPtr);
+    ckfree(dPtr);
     Tcl_DeleteHashEntry(hPtr);
 }
 
@@ -1393,9 +1392,9 @@ DeleteInterpProc(
 
 	if (cancelInfo != NULL) {
 	    if (cancelInfo->result != NULL) {
-		ckfree((char *) cancelInfo->result);
+		ckfree(cancelInfo->result);
 	    }
-	    ckfree((char *) cancelInfo);
+	    ckfree(cancelInfo);
 	}
 
 	Tcl_DeleteHashEntry(hPtr);
@@ -1451,7 +1450,7 @@ DeleteInterpProc(
 	    Tcl_DeleteCommandFromToken(interp, Tcl_GetHashValue(hPtr));
 	}
 	Tcl_DeleteHashTable(hTablePtr);
-	ckfree((char *) hTablePtr);
+	ckfree(hTablePtr);
     }
 
     /*
@@ -1472,10 +1471,10 @@ DeleteInterpProc(
 	    if (dPtr->proc != NULL) {
 		dPtr->proc(dPtr->clientData, interp);
 	    }
-	    ckfree((char *) dPtr);
+	    ckfree(dPtr);
 	}
 	Tcl_DeleteHashTable(hTablePtr);
-	ckfree((char *) hTablePtr);
+	ckfree(hTablePtr);
     }
 
     /*
@@ -1487,7 +1486,7 @@ DeleteInterpProc(
 	Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
     }
     Tcl_PopCallFrame(interp);
-    ckfree((char *) iPtr->rootFramePtr);
+    ckfree(iPtr->rootFramePtr);
     iPtr->rootFramePtr = NULL;
     Tcl_DeleteNamespace((Tcl_Namespace *) iPtr->globalNsPtr);
 
@@ -1537,7 +1536,7 @@ DeleteInterpProc(
     while (resPtr) {
 	nextResPtr = resPtr->nextPtr;
 	ckfree(resPtr->name);
-	ckfree((char *) resPtr);
+	ckfree(resPtr);
 	resPtr = nextResPtr;
     }
 
@@ -1561,12 +1560,12 @@ DeleteInterpProc(
 	if (cfPtr->type == TCL_LOCATION_SOURCE) {
 	    Tcl_DecrRefCount(cfPtr->data.eval.path);
 	}
-	ckfree((char *) cfPtr->line);
-	ckfree((char *) cfPtr);
+	ckfree(cfPtr->line);
+	ckfree(cfPtr);
 	Tcl_DeleteHashEntry(hPtr);
     }
     Tcl_DeleteHashTable(iPtr->linePBodyPtr);
-    ckfree((char *) iPtr->linePBodyPtr);
+    ckfree(iPtr->linePBodyPtr);
     iPtr->linePBodyPtr = NULL;
 
     /*
@@ -1582,20 +1581,20 @@ DeleteInterpProc(
 	    Tcl_DecrRefCount(eclPtr->path);
 	}
 	for (i=0; i< eclPtr->nuloc; i++) {
-	    ckfree((char *) eclPtr->loc[i].line);
+	    ckfree(eclPtr->loc[i].line);
 	}
 
 	if (eclPtr->loc != NULL) {
-	    ckfree((char *) eclPtr->loc);
+	    ckfree(eclPtr->loc);
 	}
 
 	Tcl_DeleteHashTable(&eclPtr->litInfo);
 
-	ckfree((char *) eclPtr);
+	ckfree(eclPtr);
 	Tcl_DeleteHashEntry(hPtr);
     }
     Tcl_DeleteHashTable(iPtr->lineBCPtr);
-    ckfree((char *) iPtr->lineBCPtr);
+    ckfree(iPtr->lineBCPtr);
     iPtr->lineBCPtr = NULL;
 
     /*
@@ -1614,7 +1613,7 @@ DeleteInterpProc(
     }
 
     Tcl_DeleteHashTable(iPtr->lineLAPtr);
-    ckfree((char *) iPtr->lineLAPtr);
+    ckfree(iPtr->lineLAPtr);
     iPtr->lineLAPtr = NULL;
 
     if (iPtr->lineLABCPtr->numEntries) {
@@ -1627,7 +1626,7 @@ DeleteInterpProc(
     }
 
     Tcl_DeleteHashTable(iPtr->lineLABCPtr);
-    ckfree((char *) iPtr->lineLABCPtr);
+    ckfree(iPtr->lineLABCPtr);
     iPtr->lineLABCPtr = NULL;
 
     /*
@@ -1638,7 +1637,7 @@ DeleteInterpProc(
     Tcl_DeleteHashTable(&iPtr->varTraces);
     Tcl_DeleteHashTable(&iPtr->varSearches);
 
-    ckfree((char *) iPtr);
+    ckfree(iPtr);
 }
 
 /*
@@ -1741,8 +1740,7 @@ Tcl_HideCommand(
 
     hiddenCmdTablePtr = iPtr->hiddenCmdTablePtr;
     if (hiddenCmdTablePtr == NULL) {
-	hiddenCmdTablePtr = (Tcl_HashTable *)
-		ckalloc((unsigned) sizeof(Tcl_HashTable));
+	hiddenCmdTablePtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(hiddenCmdTablePtr, TCL_STRING_KEYS);
 	iPtr->hiddenCmdTablePtr = hiddenCmdTablePtr;
     }
@@ -2075,7 +2073,7 @@ Tcl_CreateCommand(
 	TclInvalidateNsCmdLookup(nsPtr);
 	TclInvalidateNsPath(nsPtr);
     }
-    cmdPtr = (Command *) ckalloc(sizeof(Command));
+    cmdPtr = ckalloc(sizeof(Command));
     Tcl_SetHashValue(hPtr, cmdPtr);
     cmdPtr->hPtr = hPtr;
     cmdPtr->nsPtr = nsPtr;
@@ -2247,7 +2245,7 @@ Tcl_CreateObjCommand(
 
 	TclInvalidateNsCmdLookup(nsPtr);
     }
-    cmdPtr = (Command *) ckalloc(sizeof(Command));
+    cmdPtr = ckalloc(sizeof(Command));
     Tcl_SetHashValue(hPtr, cmdPtr);
     cmdPtr->hPtr = hPtr;
     cmdPtr->nsPtr = nsPtr;
@@ -2990,8 +2988,9 @@ Tcl_DeleteCommandFromToken(
 	tracePtr = cmdPtr->tracePtr;
 	while (tracePtr != NULL) {
 	    CommandTrace *nextPtr = tracePtr->nextPtr;
+
 	    if ((--tracePtr->refCount) <= 0) {
-		ckfree((char *) tracePtr);
+		ckfree(tracePtr);
 	    }
 	    tracePtr = nextPtr;
 	}
@@ -3176,7 +3175,7 @@ CallCommandTraces(
 		oldName, newName, flags);
 	cmdPtr->flags &= ~tracePtr->flags;
 	if ((--tracePtr->refCount) <= 0) {
-	    ckfree((char *) tracePtr);
+	    ckfree(tracePtr);
 	}
     }
 
@@ -3369,7 +3368,7 @@ TclCleanupCommand(
 {
     cmdPtr->refCount--;
     if (cmdPtr->refCount <= 0) {
-	ckfree((char *) cmdPtr);
+	ckfree(cmdPtr);
     }
 }
 
@@ -3410,13 +3409,11 @@ Tcl_CreateMathFunc(
 				 * function. */
 {
     Tcl_DString bigName;
-    OldMathFuncData *data = (OldMathFuncData *)
-	    ckalloc(sizeof(OldMathFuncData));
+    OldMathFuncData *data = ckalloc(sizeof(OldMathFuncData));
 
     data->proc = proc;
     data->numArgs = numArgs;
-    data->argTypes = (Tcl_ValueType *)
-	    ckalloc(numArgs * sizeof(Tcl_ValueType));
+    data->argTypes = ckalloc(numArgs * sizeof(Tcl_ValueType));
     memcpy(data->argTypes, argTypes, numArgs * sizeof(Tcl_ValueType));
     data->clientData = clientData;
 
@@ -3473,7 +3470,7 @@ OldMathFuncProc(
      * Convert arguments from Tcl_Obj's to Tcl_Value's.
      */
 
-    args = (Tcl_Value *) ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
+    args = ckalloc(dataPtr->numArgs * sizeof(Tcl_Value));
     for (j = 1, k = 0; j < objc; ++j, ++k) {
 	/* TODO: Convert to TclGetNumberFromObj? */
 	valuePtr = objv[j];
@@ -3493,7 +3490,7 @@ OldMathFuncProc(
 		    "argument to math function didn't have numeric value",
 		    TCL_STATIC);
 	    TclCheckBadOctal(interp, Tcl_GetString(valuePtr));
-	    ckfree((char *) args);
+	    ckfree(args);
 	    return TCL_ERROR;
 	}
 
@@ -3525,7 +3522,7 @@ OldMathFuncProc(
 	    break;
 	case TCL_INT:
 	    if (ExprIntFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
-		ckfree((char *) args);
+		ckfree(args);
 		return TCL_ERROR;
 	    }
 	    valuePtr = Tcl_GetObjResult(interp);
@@ -3534,7 +3531,7 @@ OldMathFuncProc(
 	    break;
 	case TCL_WIDE_INT:
 	    if (ExprWideFunc(NULL, interp, 2, &objv[j-1]) != TCL_OK) {
-		ckfree((char *) args);
+		ckfree(args);
 		return TCL_ERROR;
 	    }
 	    valuePtr = Tcl_GetObjResult(interp);
@@ -3550,7 +3547,7 @@ OldMathFuncProc(
 
     errno = 0;
     result = dataPtr->proc(dataPtr->clientData, interp, args, &funcResult);
-    ckfree((char *) args);
+    ckfree(args);
     if (result != TCL_OK) {
 	return result;
     }
@@ -3593,8 +3590,8 @@ OldMathFuncDeleteProc(
 {
     OldMathFuncData *dataPtr = clientData;
 
-    ckfree((char *) dataPtr->argTypes);
-    ckfree((char *) dataPtr);
+    ckfree(dataPtr->argTypes);
+    ckfree(dataPtr);
 }
 
 /*
@@ -5088,10 +5085,9 @@ TclEvalEx(
 	     */
 
 	    if (numWords > minObjs) {
-		expand = (int *) ckalloc(numWords * sizeof(int));
-		objvSpace = (Tcl_Obj **)
-			ckalloc(numWords * sizeof(Tcl_Obj *));
-		lineSpace = (int *) ckalloc(numWords * sizeof(int));
+		expand =    ckalloc(numWords * sizeof(int));
+		objvSpace = ckalloc(numWords * sizeof(Tcl_Obj *));
+		lineSpace = ckalloc(numWords * sizeof(int));
 	    }
 	    expandRequested = 0;
 	    objv = objvSpace;
@@ -5176,10 +5172,9 @@ TclEvalEx(
 		int objIdx = objectsNeeded - 1;
 
 		if ((numWords > minObjs) || (objectsNeeded > minObjs)) {
-		    objv = objvSpace = (Tcl_Obj **)
+		    objv = objvSpace =
 			    ckalloc(objectsNeeded * sizeof(Tcl_Obj *));
-		    lines = lineSpace = (int *)
-			    ckalloc(objectsNeeded * sizeof(int));
+		    lines = lineSpace = ckalloc(objectsNeeded * sizeof(int));
 		}
 
 		objectsUsed = 0;
@@ -5206,10 +5201,10 @@ TclEvalEx(
 		objv += objIdx+1;
 
 		if (copy != stackObjArray) {
-		    ckfree((char *) copy);
+		    ckfree(copy);
 		}
 		if (lcopy != linesStack) {
-		    ckfree((char *) lcopy);
+		    ckfree(lcopy);
 		}
 	    }
 
@@ -5249,9 +5244,9 @@ TclEvalEx(
 	    }
 	    objectsUsed = 0;
 	    if (objvSpace != stackObjArray) {
-		ckfree((char *) objvSpace);
+		ckfree(objvSpace);
 		objvSpace = stackObjArray;
-		ckfree((char *) lineSpace);
+		ckfree(lineSpace);
 		lineSpace = linesStack;
 	    }
 
@@ -5261,7 +5256,7 @@ TclEvalEx(
 	     */
 
 	    if (expand != expandStack) {
-		ckfree((char *) expand);
+		ckfree(expand);
 		expand = expandStack;
 	    }
 	}
@@ -5326,11 +5321,11 @@ TclEvalEx(
 	Tcl_FreeParse(parsePtr);
     }
     if (objvSpace != stackObjArray) {
-	ckfree((char *) objvSpace);
-	ckfree((char *) lineSpace);
+	ckfree(objvSpace);
+	ckfree(lineSpace);
     }
     if (expand != expandStack) {
-	ckfree((char *) expand);
+	ckfree(expand);
     }
     iPtr->varFramePtr = savedVarFramePtr;
 
@@ -5494,7 +5489,7 @@ TclArgumentEnter(
 	     * and initialize references.
 	     */
 
-	    cfwPtr = (CFWord *) ckalloc(sizeof(CFWord));
+	    cfwPtr = ckalloc(sizeof(CFWord));
 	    cfwPtr->framePtr = cfPtr;
 	    cfwPtr->word = i;
 	    cfwPtr->refCount = 1;
@@ -5555,7 +5550,7 @@ TclArgumentRelease(
 	    continue;
 	}
 
-	ckfree((char *) cfwPtr);
+	ckfree(cfwPtr);
 	Tcl_DeleteHashEntry(hPtr);
     }
 }
@@ -5618,10 +5613,9 @@ TclArgumentBCEnter(
 	for (word = 1; word < objc; word++) {
 	    if (ePtr->line[word] >= 0) {
 		int isnew;
-		Tcl_HashEntry *hPtr =
-			Tcl_CreateHashEntry(iPtr->lineLABCPtr,
-				objv[word], &isnew);
-		CFWordBC *cfwPtr = (CFWordBC *) ckalloc(sizeof(CFWordBC));
+		Tcl_HashEntry *hPtr = Tcl_CreateHashEntry(iPtr->lineLABCPtr,
+			objv[word], &isnew);
+		CFWordBC *cfwPtr = ckalloc(sizeof(CFWordBC));
 
 		cfwPtr->framePtr = cfPtr;
 		cfwPtr->obj = objv[word];
@@ -5700,7 +5694,7 @@ TclArgumentBCRelease(
 	    Tcl_DeleteHashEntry(hPtr);
 	}
 
-	ckfree((char *) cfwPtr);
+	ckfree(cfwPtr);
 	cfwPtr = nextPtr;
     }
 
@@ -8615,7 +8609,7 @@ NRCoroutineCallerCallback(
 	NRE_ASSERT(iPtr->varFramePtr == corPtr->caller.varFramePtr);
 	NRE_ASSERT(iPtr->framePtr == corPtr->caller.framePtr);
 	NRE_ASSERT(iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr);
-	ckfree((char *) corPtr);
+	ckfree(corPtr);
 	return result;
     }
 
@@ -8674,7 +8668,7 @@ NRCoroutineExitCallback(
      */
 
     Tcl_DeleteHashTable(corPtr->lineLABCPtr);
-    ckfree((char *) corPtr->lineLABCPtr);
+    ckfree(corPtr->lineLABCPtr);
     corPtr->lineLABCPtr = NULL;
 
     RESTORE_CONTEXT(corPtr->caller);
@@ -8917,7 +8911,7 @@ TclNRCoroutineObjCmd(
      * struct and create the corresponding command.
      */
 
-    corPtr = (CoroutineData *) ckalloc(sizeof(CoroutineData));
+    corPtr = ckalloc(sizeof(CoroutineData));
 
     Tcl_DStringInit(&ds);
     if (nsPtr != iPtr->globalNsPtr) {
@@ -8946,8 +8940,7 @@ TclNRCoroutineObjCmd(
 	Tcl_HashSearch hSearch;
 	Tcl_HashEntry *hePtr;
 
-	corPtr->lineLABCPtr = (Tcl_HashTable *)
-		ckalloc(sizeof(Tcl_HashTable));
+	corPtr->lineLABCPtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(corPtr->lineLABCPtr, TCL_ONE_WORD_KEYS);
 
 	for (hePtr = Tcl_FirstHashEntry(iPtr->lineLABCPtr,&hSearch);
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index c6e4a8c..0a340f2 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -304,7 +304,7 @@ Tcl_SetByteArrayObj(
     Tcl_InvalidateStringRep(objPtr);
 
     length = (length < 0) ? 0 : length;
-    byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
+    byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
     memset(byteArrayPtr, 0, BYTEARRAY_SIZE(length));
     byteArrayPtr->used = length;
     byteArrayPtr->allocated = length;
@@ -391,8 +391,7 @@ Tcl_SetByteArrayLength(
 
     byteArrayPtr = GET_BYTEARRAY(objPtr);
     if (length > byteArrayPtr->allocated) {
-	byteArrayPtr = (ByteArray *)
-		ckrealloc((char *) byteArrayPtr, BYTEARRAY_SIZE(length));
+	byteArrayPtr = ckrealloc(byteArrayPtr, BYTEARRAY_SIZE(length));
 	byteArrayPtr->allocated = length;
 	SET_BYTEARRAY(objPtr, byteArrayPtr);
     }
@@ -432,7 +431,7 @@ SetByteArrayFromAny(
 	src = TclGetStringFromObj(objPtr, &length);
 	srcEnd = src + length;
 
-	byteArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
+	byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
 	for (dst = byteArrayPtr->bytes; src < srcEnd; ) {
 	    src += Tcl_UtfToUniChar(src, &ch);
 	    *dst++ = UCHAR(ch);
@@ -469,7 +468,7 @@ static void
 FreeByteArrayInternalRep(
     Tcl_Obj *objPtr)		/* Object with internal rep to free. */
 {
-    ckfree((char *) GET_BYTEARRAY(objPtr));
+    ckfree(GET_BYTEARRAY(objPtr));
     objPtr->typePtr = NULL;
 }
 
@@ -501,7 +500,7 @@ DupByteArrayInternalRep(
     srcArrayPtr = GET_BYTEARRAY(srcPtr);
     length = srcArrayPtr->used;
 
-    copyArrayPtr = (ByteArray *) ckalloc(BYTEARRAY_SIZE(length));
+    copyArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
     copyArrayPtr->used = length;
     copyArrayPtr->allocated = length;
     memcpy(copyArrayPtr->bytes, srcArrayPtr->bytes, (size_t) length);
@@ -560,7 +559,7 @@ UpdateStringOfByteArray(
 	Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
     }
 
-    dst = (char *) ckalloc((unsigned) (size + 1));
+    dst = ckalloc(size + 1);
     objPtr->bytes = dst;
     objPtr->length = size;
 
@@ -641,9 +640,8 @@ TclAppendBytesToByteArray(
 	}
 
 	if (BYTEARRAY_SIZE(attempt) > BYTEARRAY_SIZE(used)) {
-	    tmpByteArrayPtr = (ByteArray *)
-		    attemptckrealloc((char *) byteArrayPtr,
-			    BYTEARRAY_SIZE(attempt));
+	    tmpByteArrayPtr = attemptckrealloc(byteArrayPtr,
+		    BYTEARRAY_SIZE(attempt));
 	}
 
 	if (tmpByteArrayPtr == NULL) {
@@ -651,7 +649,7 @@ TclAppendBytesToByteArray(
 	    if (BYTEARRAY_SIZE(attempt) < BYTEARRAY_SIZE(used)) {
 		Tcl_Panic("attempt to allocate a bigger buffer than we can handle");
 	    }
-	    tmpByteArrayPtr = (ByteArray *) ckrealloc((char *) byteArrayPtr,
+	    tmpByteArrayPtr = ckrealloc(byteArrayPtr,
 		    BYTEARRAY_SIZE(attempt));
 	}
 
diff --git a/generic/tclClock.c b/generic/tclClock.c
index f7c4f9d..7fa4017 100644
--- a/generic/tclClock.c
+++ b/generic/tclClock.c
@@ -266,9 +266,9 @@ TclClockInit(
      * Create the client data, which is a refcounted literal pool.
      */
 
-    data = (ClockClientData *) ckalloc(sizeof(ClockClientData));
+    data = ckalloc(sizeof(ClockClientData));
     data->refCount = 0;
-    data->literals = (Tcl_Obj **) ckalloc(LIT__END * sizeof(Tcl_Obj*));
+    data->literals = ckalloc(LIT__END * sizeof(Tcl_Obj*));
     for (i = 0; i < LIT__END; ++i) {
 	data->literals[i] = Tcl_NewStringObj(literals[i], -1);
 	Tcl_IncrRefCount(data->literals[i]);
@@ -2024,8 +2024,8 @@ ClockDeleteCmdProc(
 	for (i = 0; i < LIT__END; ++i) {
 	    Tcl_DecrRefCount(data->literals[i]);
 	}
-	ckfree((char *) data->literals);
-	ckfree((char *) data);
+	ckfree(data->literals);
+	ckfree(data);
     }
 }
 
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index a63a658..3edfa54 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -234,7 +234,7 @@ Tcl_CaseObjCmd(
 		break;
 	    }
 	}
-	ckfree((char *) patObjv);
+	ckfree(patObjv);
 	if (j < patObjc) {
 	    break;
 	}
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 26831c3..05f2e5d 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -3879,7 +3879,7 @@ TclNRSwitchObjCmd(
 	if (ctxPtr->type == TCL_LOCATION_SOURCE && ctxPtr->line[bidx] >= 0) {
 	    int bline = ctxPtr->line[bidx];
 
-	    ctxPtr->line = (int *) ckalloc(objc * sizeof(int));
+	    ctxPtr->line = ckalloc(objc * sizeof(int));
 	    ctxPtr->nline = objc;
 	    TclListLines(blist, bline, objc, ctxPtr->line, objv);
 	} else {
@@ -3893,7 +3893,7 @@ TclNRSwitchObjCmd(
 
 	    int k;
 
-	    ctxPtr->line = (int *) ckalloc(objc * sizeof(int));
+	    ctxPtr->line = ckalloc(objc * sizeof(int));
 	    ctxPtr->nline = objc;
 	    for (k=0; k < objc; k++) {
 		ctxPtr->line[k] = -1;
@@ -3943,7 +3943,7 @@ SwitchPostProc(
      */
 
     if (splitObjs) {
-	ckfree((char *) ctxPtr->line);
+	ckfree(ctxPtr->line);
 	if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
 	    /*
 	     * Death of SrcInfo reference.
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 83e99aa..083f530 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -800,24 +800,24 @@ TclCompileDictForCmd(
     }
     Tcl_DStringFree(&buffer);
     if (numVars != 2) {
-	ckfree((char *) argv);
+	ckfree(argv);
 	return TCL_ERROR;
     }
 
     nameChars = strlen(argv[0]);
     if (!TclIsLocalScalar(argv[0], nameChars)) {
-	ckfree((char *) argv);
+	ckfree(argv);
 	return TCL_ERROR;
     }
     keyVarIndex = TclFindCompiledLocal(argv[0], nameChars, 1, envPtr);
 
     nameChars = strlen(argv[1]);
     if (!TclIsLocalScalar(argv[1], nameChars)) {
-	ckfree((char *) argv);
+	ckfree(argv);
 	return TCL_ERROR;
     }
     valueVarIndex = TclFindCompiledLocal(argv[1], nameChars, 1, envPtr);
-    ckfree((char *) argv);
+    ckfree(argv);
 
     if ((keyVarIndex < 0) || (valueVarIndex < 0)) {
 	return TCL_ERROR;
@@ -1019,8 +1019,7 @@ TclCompileDictUpdateCmd(
      * that are to be used.
      */
 
-    duiPtr = (DictUpdateInfo *)
-	    ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
+    duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
     duiPtr->length = numVars;
     keyTokenPtrs = TclStackAlloc(interp,
 	    sizeof(Tcl_Token *) * numVars);
@@ -1060,7 +1059,7 @@ TclCompileDictUpdateCmd(
     }
     if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
     failedUpdateInfoAssembly:
-	ckfree((char *) duiPtr);
+	ckfree(duiPtr);
 	TclStackFree(interp, keyTokenPtrs);
 	return TCL_ERROR;
     }
@@ -1266,7 +1265,7 @@ DupDictUpdateInfo(
 
     dui1Ptr = clientData;
     len = sizeof(DictUpdateInfo) + sizeof(int) * (dui1Ptr->length - 1);
-    dui2Ptr = (DictUpdateInfo *) ckalloc(len);
+    dui2Ptr = ckalloc(len);
     memcpy(dui2Ptr, dui1Ptr, len);
     return dui2Ptr;
 }
@@ -1730,8 +1729,8 @@ TclCompileForeachCmd(
      * pointing to the ForeachInfo structure.
      */
 
-    infoPtr = (ForeachInfo *) ckalloc((unsigned)
-	    sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
+    infoPtr = ckalloc(sizeof(ForeachInfo)
+	    + numLists * sizeof(ForeachVarList *));
     infoPtr->numLists = numLists;
     infoPtr->firstValueTemp = firstValueTemp;
     infoPtr->loopCtTemp = loopCtTemp;
@@ -1739,8 +1738,8 @@ TclCompileForeachCmd(
 	ForeachVarList *varListPtr;
 
 	numVars = varcList[loopIndex];
-	varListPtr = (ForeachVarList *) ckalloc((unsigned)
-		sizeof(ForeachVarList) + numVars*sizeof(int));
+	varListPtr = ckalloc(sizeof(ForeachVarList)
+		+ numVars * sizeof(int));
 	varListPtr->numVars = numVars;
 	for (j = 0;  j < numVars;  j++) {
 	    const char *varName = varvList[loopIndex][j];
@@ -1865,7 +1864,7 @@ TclCompileForeachCmd(
   done:
     for (loopIndex = 0;  loopIndex < numLists;  loopIndex++) {
 	if (varvList[loopIndex] != NULL) {
-	    ckfree((char *) varvList[loopIndex]);
+	    ckfree(varvList[loopIndex]);
 	}
     }
     TclStackFree(interp, (void *)varvList);
@@ -1904,8 +1903,8 @@ DupForeachInfo(
     register ForeachVarList *srcListPtr, *dupListPtr;
     int numVars, i, j, numLists = srcPtr->numLists;
 
-    dupPtr = (ForeachInfo *) ckalloc((unsigned)
-	    sizeof(ForeachInfo) + numLists*sizeof(ForeachVarList *));
+    dupPtr = ckalloc(sizeof(ForeachInfo)
+	    + numLists * sizeof(ForeachVarList *));
     dupPtr->numLists = numLists;
     dupPtr->firstValueTemp = srcPtr->firstValueTemp;
     dupPtr->loopCtTemp = srcPtr->loopCtTemp;
@@ -1913,8 +1912,8 @@ DupForeachInfo(
     for (i = 0;  i < numLists;  i++) {
 	srcListPtr = srcPtr->varLists[i];
 	numVars = srcListPtr->numVars;
-	dupListPtr = (ForeachVarList *) ckalloc((unsigned)
-		sizeof(ForeachVarList) + numVars*sizeof(int));
+	dupListPtr = ckalloc(sizeof(ForeachVarList)
+		+ numVars * sizeof(int));
 	dupListPtr->numVars = numVars;
 	for (j = 0;  j < numVars;  j++) {
 	    dupListPtr->varIndexes[j] =	srcListPtr->varIndexes[j];
@@ -1955,9 +1954,9 @@ FreeForeachInfo(
 
     for (i = 0;  i < numLists;  i++) {
 	listPtr = infoPtr->varLists[i];
-	ckfree((char *) listPtr);
+	ckfree(listPtr);
     }
-    ckfree((char *) infoPtr);
+    ckfree(infoPtr);
 }
 
 /*
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index 7398579..d956819 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -1082,15 +1082,15 @@ TclCompileSwitchCmd(
 	 */
 
 	if (numWords == 0 || numWords % 2) {
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    return TCL_ERROR;
 	}
 
 	isListedArms = 1;
-	bodyTokenArray = (Tcl_Token *) ckalloc(sizeof(Tcl_Token) * numWords);
-	bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
-	bodyLines = (int *) ckalloc(sizeof(int) * numWords);
-	bodyContLines = (int **) ckalloc(sizeof(int*) * numWords);
+	bodyTokenArray = ckalloc(sizeof(Tcl_Token) * numWords);
+	bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords);
+	bodyLines = ckalloc(sizeof(int) * numWords);
+	bodyContLines = ckalloc(sizeof(int*) * numWords);
 
 	/*
 	 * Locate the start of the arms within the overall word.
@@ -1130,7 +1130,7 @@ TclCompileSwitchCmd(
 	    if ((isTokenBraced && *(tokenStartPtr++) != '}') ||
 		    (tokenStartPtr < tokenPtr[1].start+tokenPtr[1].size
 		    && !isspace(UCHAR(*tokenStartPtr)))) {
-		ckfree((char *) argv);
+		ckfree(argv);
 		goto freeTemporaries;
 	    }
 
@@ -1160,7 +1160,7 @@ TclCompileSwitchCmd(
 		isTokenBraced = 0;
 	    }
 	}
-	ckfree((char *) argv);
+	ckfree(argv);
 
 	/*
 	 * Check that we've parsed everything we thought we were going to
@@ -1187,9 +1187,9 @@ TclCompileSwitchCmd(
 	 * Multi-word definition of patterns & actions.
 	 */
 
-	bodyToken = (Tcl_Token **) ckalloc(sizeof(Tcl_Token *) * numWords);
-	bodyLines = (int *) ckalloc(sizeof(int) * numWords);
-	bodyContLines = (int **) ckalloc(sizeof(int*) * numWords);
+	bodyToken = ckalloc(sizeof(Tcl_Token *) * numWords);
+	bodyLines = ckalloc(sizeof(int) * numWords);
+	bodyContLines = ckalloc(sizeof(int*) * numWords);
 	bodyTokenArray = NULL;
 	for (i=0 ; i<numWords ; i++) {
 	    /*
@@ -1247,11 +1247,11 @@ TclCompileSwitchCmd(
      */
 
   freeTemporaries:
-    ckfree((char *) bodyToken);
-    ckfree((char *) bodyLines);
-    ckfree((char *) bodyContLines);
+    ckfree(bodyToken);
+    ckfree(bodyLines);
+    ckfree(bodyContLines);
     if (bodyTokenArray != NULL) {
-	ckfree((char *) bodyTokenArray);
+	ckfree(bodyTokenArray);
     }
     return result;
 }
@@ -1579,7 +1579,7 @@ IssueSwitchJumpTable(
      * Start by allocating the jump table itself, plus some workspace.
      */
 
-    jtPtr = (JumptableInfo *) ckalloc(sizeof(JumptableInfo));
+    jtPtr = ckalloc(sizeof(JumptableInfo));
     Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
     infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
     finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
@@ -1749,8 +1749,7 @@ DupJumptableInfo(
     ClientData clientData)
 {
     JumptableInfo *jtPtr = clientData;
-    JumptableInfo *newJtPtr = (JumptableInfo *)
-	    ckalloc(sizeof(JumptableInfo));
+    JumptableInfo *newJtPtr = ckalloc(sizeof(JumptableInfo));
     Tcl_HashEntry *hPtr, *newHPtr;
     Tcl_HashSearch search;
     int isNew;
@@ -1772,7 +1771,7 @@ FreeJumptableInfo(
     JumptableInfo *jtPtr = clientData;
 
     Tcl_DeleteHashTable(&jtPtr->hashTable);
-    ckfree((char *) jtPtr);
+    ckfree(jtPtr);
 }
 
 static void
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 34deff7..d25aa07 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -621,7 +621,7 @@ ParseExpr(
 
     TclParseInit(interp, start, numBytes, parsePtr);
 
-    nodes = (OpNode *) attemptckalloc(nodesAvailable * sizeof(OpNode));
+    nodes = attemptckalloc(nodesAvailable * sizeof(OpNode));
     if (nodes == NULL) {
 	TclNewLiteralStringObj(msg, "not enough memory to parse expression");
 	goto error;
@@ -668,8 +668,7 @@ ParseExpr(
 	    OpNode *newPtr;
 
 	    do {
-		newPtr = (OpNode *) attemptckrealloc((char *) nodes,
-			(unsigned int) size * sizeof(OpNode));
+		newPtr = attemptckrealloc(nodes, size * sizeof(OpNode));
 	    } while ((newPtr == NULL)
 		    && ((size -= (size - nodesUsed) / 2) > nodesUsed));
 	    if (newPtr == NULL) {
@@ -682,7 +681,10 @@ ParseExpr(
 	}
 	nodePtr = nodes + nodesUsed;
 
-	/* Skip white space between lexemes. */
+	/*
+	 * Skip white space between lexemes.
+	 */
+
 	scanned = TclParseAllWhiteSpace(start, numBytes);
 	start += scanned;
 	numBytes -= scanned;
@@ -1348,7 +1350,7 @@ ParseExpr(
      */
 
     if (nodes != NULL) {
-	ckfree((char *) nodes);
+	ckfree(nodes);
     }
 
     if (interp == NULL) {
@@ -1806,7 +1808,7 @@ Tcl_ParseExpr(
 
     Tcl_FreeParse(exprParsePtr);
     TclStackFree(interp, exprParsePtr);
-    ckfree((char *) opTree);
+    ckfree(opTree);
     return code;
 }
 
@@ -2065,7 +2067,7 @@ TclCompileExpr(
     TclStackFree(interp, parsePtr);
     Tcl_DecrRefCount(funcList);
     Tcl_DecrRefCount(litList);
-    ckfree((char *) opTree);
+    ckfree(opTree);
 }
 
 /*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 4f04403..aed9e3b 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -881,16 +881,16 @@ TclCleanupByteCode(
 		Tcl_DecrRefCount(eclPtr->path);
 	    }
 	    for (i=0 ; i<eclPtr->nuloc ; i++) {
-		ckfree((char *) eclPtr->loc[i].line);
+		ckfree(eclPtr->loc[i].line);
 	    }
 
 	    if (eclPtr->loc != NULL) {
-		ckfree((char *) eclPtr->loc);
+		ckfree(eclPtr->loc);
 	    }
 
 	    Tcl_DeleteHashTable(&eclPtr->litInfo);
 
-	    ckfree((char *) eclPtr);
+	    ckfree(eclPtr);
 	    Tcl_DeleteHashEntry(hePtr);
 	}
     }
@@ -900,7 +900,7 @@ TclCleanupByteCode(
     }
 
     TclHandleRelease(codePtr->interpHandle);
-    ckfree((char *) codePtr);
+    ckfree(codePtr);
 }
 
 /*
@@ -1145,7 +1145,7 @@ TclInitCompileEnv(
      * non-compiling evaluator
      */
 
-    envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc));
+    envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc));
     envPtr->extCmdMapPtr->loc = NULL;
     envPtr->extCmdMapPtr->nloc = 0;
     envPtr->extCmdMapPtr->nuloc = 0;
@@ -1302,26 +1302,26 @@ TclFreeCompileEnv(
     register CompileEnv *envPtr)/* Points to the CompileEnv structure. */
 {
     if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){
-	ckfree((char *) envPtr->localLitTable.buckets);
+	ckfree(envPtr->localLitTable.buckets);
 	envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets;
     }
     if (envPtr->mallocedCodeArray) {
-	ckfree((char *) envPtr->codeStart);
+	ckfree(envPtr->codeStart);
     }
     if (envPtr->mallocedLiteralArray) {
-	ckfree((char *) envPtr->literalArrayPtr);
+	ckfree(envPtr->literalArrayPtr);
     }
     if (envPtr->mallocedExceptArray) {
-	ckfree((char *) envPtr->exceptArrayPtr);
+	ckfree(envPtr->exceptArrayPtr);
     }
     if (envPtr->mallocedCmdMap) {
-	ckfree((char *) envPtr->cmdMapPtr);
+	ckfree(envPtr->cmdMapPtr);
     }
     if (envPtr->mallocedAuxDataArray) {
-	ckfree((char *) envPtr->auxDataArrayPtr);
+	ckfree(envPtr->auxDataArrayPtr);
     }
     if (envPtr->extCmdMapPtr) {
-	ckfree((char *) envPtr->extCmdMapPtr);
+	ckfree(envPtr->extCmdMapPtr);
     }
 
     /*
@@ -1836,8 +1836,8 @@ TclCompileScript(
 	     * reduced form now
 	     */
 
-	    ckfree((char *) eclPtr->loc[wlineat].line);
-	    ckfree((char *) eclPtr->loc[wlineat].next);
+	    ckfree(eclPtr->loc[wlineat].line);
+	    ckfree(eclPtr->loc[wlineat].next);
 	    eclPtr->loc[wlineat].line = wlines;
 	    eclPtr->loc[wlineat].next = NULL;
 	} /* end if parsePtr->numWords > 0 */
@@ -2018,7 +2018,7 @@ TclCompileTokens(
 
     if (isLiteral) {
 	maxNumCL = NUM_STATIC_POS;
-	clPosition = (int *) ckalloc(maxNumCL * sizeof(int));
+	clPosition = ckalloc(maxNumCL * sizeof(int));
     }
 
     Tcl_DStringInit(&textBuffer);
@@ -2058,8 +2058,8 @@ TclCompileTokens(
 
 		    if (numCL >= maxNumCL) {
 			maxNumCL *= 2;
-			clPosition = (int *) ckrealloc((char *) clPosition,
-				maxNumCL * sizeof(int));
+			clPosition = ckrealloc(clPosition,
+                                maxNumCL * sizeof(int));
 		    }
 		    clPosition[numCL] = clPos;
 		    numCL ++;
@@ -2168,7 +2168,7 @@ TclCompileTokens(
      */
 
     if (maxNumCL) {
-	ckfree((char *) clPosition);
+	ckfree(clPosition);
     }
 }
 
@@ -2407,7 +2407,7 @@ TclInitByteCodeObj(
 	namespacePtr = envPtr->iPtr->globalNsPtr;
     }
 
-    p = (unsigned char *) ckalloc((size_t) structureSize);
+    p = ckalloc(structureSize);
     codePtr = (ByteCode *) p;
     codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
     codePtr->compileEpoch = iPtr->compileEpoch;
@@ -2599,8 +2599,7 @@ TclFindCompiledLocal(
 
     if (create || (name == NULL)) {
 	localVar = procPtr->numCompiledLocals;
-	localPtr = (CompiledLocal *) ckalloc((unsigned)
-		(TclOffset(CompiledLocal, name) + nameBytes + 1));
+	localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1);
 	if (procPtr->firstLocalPtr == NULL) {
 	    procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
 	} else {
@@ -2664,16 +2663,14 @@ TclExpandCodeArray(
     size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart);
 
     if (envPtr->mallocedCodeArray) {
-	envPtr->codeStart = (unsigned char *)
-		ckrealloc((char *) envPtr->codeStart, newBytes);
+	envPtr->codeStart = ckrealloc(envPtr->codeStart, newBytes);
     } else {
 	/*
 	 * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a
 	 * ckrealloc equivalent for ourselves.
 	 */
 
-	unsigned char *newPtr = (unsigned char *)
-		ckalloc((unsigned) newBytes);
+	unsigned char *newPtr = ckalloc(newBytes);
 
 	memcpy(newPtr, envPtr->codeStart, currBytes);
 	envPtr->codeStart = newPtr;
@@ -2733,16 +2730,14 @@ EnterCmdStartData(
 	size_t newBytes = newElems * sizeof(CmdLocation);
 
 	if (envPtr->mallocedCmdMap) {
-	    envPtr->cmdMapPtr = (CmdLocation *)
-		    ckrealloc((char *) envPtr->cmdMapPtr, newBytes);
+	    envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes);
 	} else {
 	    /*
 	     * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a
 	     * ckrealloc equivalent for ourselves.
 	     */
 
-	    CmdLocation *newPtr = (CmdLocation *)
-		    ckalloc((unsigned) newBytes);
+	    CmdLocation *newPtr = ckalloc(newBytes);
 
 	    memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
 	    envPtr->cmdMapPtr = newPtr;
@@ -2861,16 +2856,16 @@ EnterCmdWordData(
 	size_t newElems = (currElems ? 2*currElems : 1);
 	size_t newBytes = newElems * sizeof(ECL);
 
-	eclPtr->loc = (ECL *) ckrealloc((char *) eclPtr->loc, newBytes);
+	eclPtr->loc = ckrealloc(eclPtr->loc, newBytes);
 	eclPtr->nloc = newElems;
     }
 
     ePtr = &eclPtr->loc[eclPtr->nuloc];
     ePtr->srcOffset = srcOffset;
-    ePtr->line = (int *) ckalloc(numWords * sizeof(int));
-    ePtr->next = (int **) ckalloc(numWords * sizeof(int *));
+    ePtr->line = ckalloc(numWords * sizeof(int));
+    ePtr->next = ckalloc(numWords * sizeof(int *));
     ePtr->nline = numWords;
-    wwlines = (int *) ckalloc(numWords * sizeof(int));
+    wwlines = ckalloc(numWords * sizeof(int));
 
     last = cmd;
     wordLine = line;
@@ -2933,16 +2928,15 @@ TclCreateExceptRange(
 	size_t newBytes = newElems * sizeof(ExceptionRange);
 
 	if (envPtr->mallocedExceptArray) {
-	    envPtr->exceptArrayPtr = (ExceptionRange *)
-		    ckrealloc((char *) envPtr->exceptArrayPtr, newBytes);
+	    envPtr->exceptArrayPtr =
+		    ckrealloc(envPtr->exceptArrayPtr, newBytes);
 	} else {
 	    /*
 	     * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
 	     * code a ckrealloc equivalent for ourselves.
 	     */
 
-	    ExceptionRange *newPtr = (ExceptionRange *)
-		    ckalloc((unsigned) newBytes);
+	    ExceptionRange *newPtr = ckalloc(newBytes);
 
 	    memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
 	    envPtr->exceptArrayPtr = newPtr;
@@ -3012,15 +3006,15 @@ TclCreateAuxData(
 	size_t newBytes = newElems * sizeof(AuxData);
 
 	if (envPtr->mallocedAuxDataArray) {
-	    envPtr->auxDataArrayPtr = (AuxData *)
-		    ckrealloc((char *) envPtr->auxDataArrayPtr, newBytes);
+	    envPtr->auxDataArrayPtr =
+		    ckrealloc(envPtr->auxDataArrayPtr, newBytes);
 	} else {
 	    /*
 	     * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
 	     * code a ckrealloc equivalent for ourselves.
 	     */
 
-	    AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
+	    AuxData *newPtr = ckalloc(newBytes);
 
 	    memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
 	    envPtr->auxDataArrayPtr = newPtr;
@@ -3088,8 +3082,8 @@ TclInitJumpFixupArray(
 void
 TclExpandJumpFixupArray(
     register JumpFixupArray *fixupArrayPtr)
-				/* Points to the JumpFixupArray structure
-				 * to enlarge. */
+				/* Points to the JumpFixupArray structure to
+				 * enlarge. */
 {
     /*
      * The currently allocated jump fixup entries are stored from fixup[0] up
@@ -3102,15 +3096,14 @@ TclExpandJumpFixupArray(
     size_t newBytes = newElems * sizeof(JumpFixup);
 
     if (fixupArrayPtr->mallocedArray) {
-	fixupArrayPtr->fixup = (JumpFixup *)
-		ckrealloc((char *) fixupArrayPtr->fixup, newBytes);
+	fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes);
     } else {
 	/*
 	 * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a
 	 * ckrealloc equivalent for ourselves.
 	 */
 
-	JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
+	JumpFixup *newPtr = ckalloc(newBytes);
 
 	memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
 	fixupArrayPtr->fixup = newPtr;
@@ -3142,7 +3135,7 @@ TclFreeJumpFixupArray(
 				 * free. */
 {
     if (fixupArrayPtr->mallocedArray) {
-	ckfree((char *) fixupArrayPtr->fixup);
+	ckfree(fixupArrayPtr->fixup);
     }
 }
 
@@ -4259,16 +4252,18 @@ FormatInstruction(
  *
  *----------------------------------------------------------------------
  */
-Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
-			    const unsigned char *pc,
-			    Tcl_Obj **tosPtr)
+
+Tcl_Obj *
+TclGetInnerContext(
+    Tcl_Interp *interp,
+    const unsigned char *pc,
+    Tcl_Obj **tosPtr)
 {
     int objc = 0, off = 0;
     Tcl_Obj *result;
     Interp *iPtr = (Interp *) interp;
 
-    switch(*pc) {
-
+    switch (*pc) {
     case INST_STR_LEN:
     case INST_LNOT:
     case INST_BITNOT:
@@ -4277,7 +4272,6 @@ Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
     case INST_TRY_CVT_TO_NUMERIC:
     case INST_EXPAND_STKTOP:
     case INST_EXPR_STK:
-
         objc = 1;
         break;
 
@@ -4336,22 +4330,27 @@ Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
     } else {
         int len;
 
+        /*
+         * Reset while keeping the list intrep as much as possible.
+         */
+
 	Tcl_ListObjLength(interp, result, &len);
-        /* reset while keeping the list intrep as much as possible */
         Tcl_ListObjReplace(interp, result, 0, len, 0, NULL);
-    }    
+    }
     Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc));
-    for(;objc>0;objc--) {
-        Tcl_Obj *ob;
 
-        ob = tosPtr[1 - objc + off];
-        if (!ob) {
+    for (; objc>0 ; objc--) {
+        Tcl_Obj *objPtr;
+
+        objPtr = tosPtr[1 - objc + off];
+        if (!objPtr) {
             Tcl_Panic("InnerContext: bad tos -- appending null object");
         }
-        if (ob->refCount<=0 || ob->refCount==0x61616161) {
-            Tcl_Panic("InnerContext: bad tos -- appending freed object %p",ob);
+        if (objPtr->refCount<=0 || objPtr->refCount==0x61616161) {
+            Tcl_Panic("InnerContext: bad tos -- appending freed object %p",
+                    objPtr);
         }
-        Tcl_ListObjAppendElement(NULL, result, ob);
+        Tcl_ListObjAppendElement(NULL, result, objPtr);
     }
 
     return result;
@@ -4366,18 +4365,19 @@ Tcl_Obj *TclGetInnerContext(Tcl_Interp *interp,
  *
  *----------------------------------------------------------------------
  */
-MODULE_SCOPE Tcl_Obj	*TclNewInstNameObj(unsigned char inst)
+
+MODULE_SCOPE Tcl_Obj *
+TclNewInstNameObj(
+    unsigned char inst)
 {
-    Tcl_Obj *objPtr;
-    
-    objPtr=Tcl_NewObj();
+    Tcl_Obj *objPtr = Tcl_NewObj();
+
     objPtr->typePtr = &tclInstNameType;
-    objPtr->internalRep.longValue = (long)inst;
+    objPtr->internalRep.longValue = (long) inst;
     objPtr->bytes = NULL;
 
     return objPtr;
 }
-
 
 /*
  *----------------------------------------------------------------------
@@ -4388,25 +4388,26 @@ MODULE_SCOPE Tcl_Obj	*TclNewInstNameObj(unsigned char inst)
  *
  *----------------------------------------------------------------------
  */
-static void UpdateStringOfInstName(Tcl_Obj *objPtr)
+
+static void
+UpdateStringOfInstName(
+    Tcl_Obj *objPtr)
 {
     int inst = objPtr->internalRep.longValue;
-    char *s,buf[20];
+    char *s, buf[20];
     int len;
 
     if ((inst < 0) || (inst > LAST_INST_OPCODE)) {
-
         sprintf(buf, "inst_%d", inst);
         s = buf;
     } else {
-        s = (char *)tclInstructionTable[objPtr->internalRep.longValue].name;
+        s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name;
     }
     len = strlen(s);
-    objPtr->bytes = ckalloc((unsigned) len + 1);
+    objPtr->bytes = ckalloc(len + 1);
     memcpy(objPtr->bytes, s, len + 1);
     objPtr->length = len;
 }
-
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 432c354..8d42e21 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -78,7 +78,7 @@ Tcl_RegisterConfig(
     Tcl_DString cmdName;
     const Tcl_Config *cfg;
     Tcl_Encoding venc = Tcl_GetEncoding(NULL, valEncoding);
-    QCCD *cdPtr = (QCCD *) ckalloc(sizeof(QCCD));
+    QCCD *cdPtr = ckalloc(sizeof(QCCD));
 
     cdPtr->interp = interp;
     cdPtr->pkg = Tcl_NewStringObj(pkgName, -1);
@@ -319,12 +319,13 @@ static void
 QueryConfigDelete(
     ClientData clientData)
 {
-    QCCD *cdPtr = (QCCD *) clientData;
+    QCCD *cdPtr = clientData;
     Tcl_Obj *pkgName = cdPtr->pkg;
     Tcl_Obj *pDB = GetConfigDict(cdPtr->interp);
+
     Tcl_DictObjRemove(NULL, pDB, pkgName);
     Tcl_DecrRefCount(pkgName);
-    ckfree((char *)cdPtr);
+    ckfree(cdPtr);
 }
 
 /*
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index ba4dd69..3da91a3 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -210,8 +210,8 @@ AllocChainEntry(
     Tcl_Obj *objPtr = keyPtr;
     ChainEntry *cPtr;
 
-    cPtr = (ChainEntry *) ckalloc(sizeof(ChainEntry));
-    cPtr->entry.key.oneWordValue = (char *) objPtr;
+    cPtr = ckalloc(sizeof(ChainEntry));
+    cPtr->entry.key.objPtr = objPtr;
     Tcl_IncrRefCount(objPtr);
     cPtr->entry.clientData = NULL;
     cPtr->prevPtr = cPtr->nextPtr = NULL;
@@ -341,7 +341,7 @@ DupDictInternalRep(
     Tcl_Obj *copyPtr)
 {
     Dict *oldDict = srcPtr->internalRep.otherValuePtr;
-    Dict *newDict = (Dict *) ckalloc(sizeof(Dict));
+    Dict *newDict = ckalloc(sizeof(Dict));
     ChainEntry *cPtr;
 
     /*
@@ -437,7 +437,7 @@ DeleteDict(
     Dict *dict)
 {
     DeleteChainTable(dict);
-    ckfree((char *) dict);
+    ckfree(dict);
 }
 
 /*
@@ -489,7 +489,7 @@ UpdateStringOfDict(
     if (numElems <= LOCAL_SIZE) {
 	flagPtr = localFlags;
     } else {
-	flagPtr = (int *) ckalloc((unsigned) numElems*sizeof(int));
+	flagPtr = ckalloc(numElems * sizeof(int));
     }
     dictPtr->length = 1;
     for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
@@ -513,7 +513,7 @@ UpdateStringOfDict(
      * Pass 2: copy into string rep buffer.
      */
 
-    dictPtr->bytes = ckalloc((unsigned) dictPtr->length);
+    dictPtr->bytes = ckalloc(dictPtr->length);
     dst = dictPtr->bytes;
     for (i=0,cPtr=dict->entryChainHead; i<numElems; i+=2,cPtr=cPtr->nextPtr) {
 	keyPtr = Tcl_GetHashKey(&dict->table, &cPtr->entry);
@@ -529,7 +529,7 @@ UpdateStringOfDict(
 	*(dst++) = ' ';
     }
     if (flagPtr != localFlags) {
-	ckfree((char *) flagPtr);
+	ckfree(flagPtr);
     }
     if (dst == dictPtr->bytes) {
 	*dst = 0;
@@ -600,7 +600,7 @@ SetDictFromAny(
 	 * Build the hash of key/value pairs.
 	 */
 
-	dict = (Dict *) ckalloc(sizeof(Dict));
+	dict = ckalloc(sizeof(Dict));
 	InitChainTable(dict);
 	for (i=0 ; i<objc ; i+=2) {
 	    /*
@@ -644,7 +644,7 @@ SetDictFromAny(
      * values.
      */
 
-    dict = (Dict *) ckalloc(sizeof(Dict));
+    dict = ckalloc(sizeof(Dict));
     InitChainTable(dict);
     for (p = string, lenRemain = length;
 	    lenRemain > 0;
@@ -666,7 +666,7 @@ SetDictFromAny(
 	 * "elemSize" bytes starting at "elemStart".
 	 */
 
-	s = ckalloc((unsigned) elemSize + 1);
+	s = ckalloc(elemSize + 1);
 	if (hasBrace) {
 	    memcpy(s, elemStart, (size_t) elemSize);
 	    s[elemSize] = 0;
@@ -702,7 +702,7 @@ SetDictFromAny(
 	 * "elemSize" bytes starting at "elemStart".
 	 */
 
-	s = ckalloc((unsigned) elemSize + 1);
+	s = ckalloc(elemSize + 1);
 	if (hasBrace) {
 	    memcpy(s, elemStart, (size_t) elemSize);
 	    s[elemSize] = 0;
@@ -754,7 +754,7 @@ SetDictFromAny(
 
   errorExit:
     DeleteChainTable(dict);
-    ckfree((char *) dict);
+    ckfree(dict);
     return result;
 }
 
@@ -1419,7 +1419,7 @@ Tcl_NewDictObj(void)
 
     TclNewObj(dictPtr);
     Tcl_InvalidateStringRep(dictPtr);
-    dict = (Dict *) ckalloc(sizeof(Dict));
+    dict = ckalloc(sizeof(Dict));
     InitChainTable(dict);
     dict->epoch = 0;
     dict->chain = NULL;
@@ -1468,7 +1468,7 @@ Tcl_DbNewDictObj(
 
     TclDbNewObj(dictPtr, file, line);
     Tcl_InvalidateStringRep(dictPtr);
-    dict = (Dict *) ckalloc(sizeof(Dict));
+    dict = ckalloc(sizeof(Dict));
     InitChainTable(dict);
     dict->epoch = 0;
     dict->chain = NULL;
diff --git a/generic/tclEncoding.c b/generic/tclEncoding.c
index 8ca5807..15411d8 100644
--- a/generic/tclEncoding.c
+++ b/generic/tclEncoding.c
@@ -592,14 +592,14 @@ TclInitEncodingSubsystem(void)
      * code to duplicate the structure of a table encoding here.
      */
 
-    dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData));
+    dataPtr = ckalloc(sizeof(TableEncodingData));
     memset(dataPtr, 0, sizeof(TableEncodingData));
     dataPtr->fallback = '?';
 
     size = 256*(sizeof(unsigned short *) + sizeof(unsigned short));
-    dataPtr->toUnicode = (unsigned short **) ckalloc(size);
+    dataPtr->toUnicode = ckalloc(size);
     memset(dataPtr->toUnicode, 0, size);
-    dataPtr->fromUnicode = (unsigned short **) ckalloc(size);
+    dataPtr->fromUnicode = ckalloc(size);
     memset(dataPtr->fromUnicode, 0, size);
 
     dataPtr->toUnicode[0] = (unsigned short *) (dataPtr->toUnicode + 256);
@@ -849,8 +849,8 @@ FreeEncoding(
 	if (encodingPtr->hPtr != NULL) {
 	    Tcl_DeleteHashEntry(encodingPtr->hPtr);
 	}
-	ckfree((char *) encodingPtr->name);
-	ckfree((char *) encodingPtr);
+	ckfree(encodingPtr->name);
+	ckfree(encodingPtr);
     }
 }
 
@@ -1054,9 +1054,9 @@ Tcl_CreateEncoding(
 	encodingPtr->hPtr = NULL;
     }
 
-    name = ckalloc((unsigned) strlen(typePtr->encodingName) + 1);
+    name = ckalloc(strlen(typePtr->encodingName) + 1);
 
-    encodingPtr = (Encoding *) ckalloc(sizeof(Encoding));
+    encodingPtr = ckalloc(sizeof(Encoding));
     encodingPtr->name		= strcpy(name, typePtr->encodingName);
     encodingPtr->toUtfProc	= typePtr->toUtfProc;
     encodingPtr->fromUtfProc	= typePtr->fromUtfProc;
@@ -1707,7 +1707,7 @@ LoadTableEncoding(
 #undef PAGESIZE
 #define PAGESIZE    (256 * sizeof(unsigned short))
 
-    dataPtr = (TableEncodingData *) ckalloc(sizeof(TableEncodingData));
+    dataPtr = ckalloc(sizeof(TableEncodingData));
     memset(dataPtr, 0, sizeof(TableEncodingData));
 
     dataPtr->fallback = fallback;
@@ -1719,7 +1719,7 @@ LoadTableEncoding(
      */
 
     size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
-    dataPtr->toUnicode = (unsigned short **) ckalloc(size);
+    dataPtr->toUnicode = ckalloc(size);
     memset(dataPtr->toUnicode, 0, size);
     pageMemPtr = (unsigned short *) (dataPtr->toUnicode + 256);
 
@@ -1777,7 +1777,7 @@ LoadTableEncoding(
 	}
     }
     size = 256 * sizeof(unsigned short *) + numPages * PAGESIZE;
-    dataPtr->fromUnicode = (unsigned short **) ckalloc(size);
+    dataPtr->fromUnicode = ckalloc(size);
     memset(dataPtr->fromUnicode, 0, size);
     pageMemPtr = (unsigned short *) (dataPtr->fromUnicode + 256);
 
@@ -2009,13 +2009,13 @@ LoadEscapeEncoding(
 		Tcl_DStringAppend(&escapeData, (char *) &est, sizeof(est));
 	    }
 	}
-	ckfree((char *) argv);
+	ckfree(argv);
 	Tcl_DStringFree(&lineString);
     }
 
     size = sizeof(EscapeEncodingData) - sizeof(EscapeSubTable)
 	    + Tcl_DStringLength(&escapeData);
-    dataPtr = (EscapeEncodingData *) ckalloc(size);
+    dataPtr = ckalloc(size);
     dataPtr->initLen = strlen(init);
     memcpy(dataPtr->init, init, (unsigned) dataPtr->initLen + 1);
     dataPtr->finalLen = strlen(final);
@@ -2955,9 +2955,9 @@ TableFreeProc(
      * Make sure we aren't freeing twice on shutdown. [Bug 219314]
      */
 
-    ckfree((char *) dataPtr->toUnicode);
-    ckfree((char *) dataPtr->fromUnicode);
-    ckfree((char *) dataPtr);
+    ckfree(dataPtr->toUnicode);
+    ckfree(dataPtr->fromUnicode);
+    ckfree(dataPtr);
 }
 
 /*
@@ -3432,7 +3432,7 @@ EscapeFreeProc(
 	    subTablePtr++;
 	}
     }
-    ckfree((char *) dataPtr);
+    ckfree(dataPtr);
 }
 
 /*
@@ -3570,7 +3570,7 @@ InitializeEncodingSearchPath(
     bytes = Tcl_GetStringFromObj(searchPathObj, &numBytes);
 
     *lengthPtr = numBytes;
-    *valuePtr = ckalloc((unsigned) numBytes + 1);
+    *valuePtr = ckalloc(numBytes + 1);
     memcpy(*valuePtr, bytes, (size_t) numBytes + 1);
     Tcl_DecrRefCount(searchPathObj);
 }
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index bbc1e55..1c7b41d 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -616,8 +616,7 @@ Tcl_CreateEnsemble(
     int flags)
 {
     Namespace *nsPtr = (Namespace *) namespacePtr;
-    EnsembleConfig *ensemblePtr = (EnsembleConfig *)
-	    ckalloc(sizeof(EnsembleConfig));
+    EnsembleConfig *ensemblePtr = ckalloc(sizeof(EnsembleConfig));
     Tcl_Obj *nameObj = NULL;
 
     if (nsPtr == NULL) {
@@ -2189,7 +2188,7 @@ MakeCachedEnsembleCommand(
 	 */
 
 	TclFreeIntRep(objPtr);
-	ensembleCmd = (EnsembleCmdRep *) ckalloc(sizeof(EnsembleCmdRep));
+	ensembleCmd = ckalloc(sizeof(EnsembleCmdRep));
 	objPtr->internalRep.otherValuePtr = ensembleCmd;
 	objPtr->typePtr = &tclEnsembleCmdType;
     }
@@ -2204,7 +2203,7 @@ MakeCachedEnsembleCommand(
     ensemblePtr->nsPtr->refCount++;
     ensembleCmd->realPrefixObj = prefixObjPtr;
     length = strlen(subcommandName)+1;
-    ensembleCmd->fullSubcmdName = ckalloc((unsigned) length);
+    ensembleCmd->fullSubcmdName = ckalloc(length);
     memcpy(ensembleCmd->fullSubcmdName, subcommandName, (unsigned) length);
     Tcl_IncrRefCount(ensembleCmd->realPrefixObj);
 }
@@ -2271,7 +2270,7 @@ DeleteEnsembleConfig(
      */
 
     if (ensemblePtr->subcommandTable.numEntries != 0) {
-	ckfree((char *) ensemblePtr->subcommandArrayPtr);
+	ckfree(ensemblePtr->subcommandArrayPtr);
     }
     hEnt = Tcl_FirstHashEntry(&ensemblePtr->subcommandTable, &search);
     while (hEnt != NULL) {
@@ -2342,7 +2341,7 @@ BuildEnsembleConfig(
 	 * Remove pre-existing table.
 	 */
 
-	ckfree((char *) ensemblePtr->subcommandArrayPtr);
+	ckfree(ensemblePtr->subcommandArrayPtr);
 	hPtr = Tcl_FirstHashEntry(hash, &search);
 	while (hPtr != NULL) {
 	    Tcl_Obj *prefixObj = Tcl_GetHashValue(hPtr);
@@ -2497,7 +2496,7 @@ BuildEnsembleConfig(
      * the hash too, and vice versa) and running quicksort over the array.
      */
 
-    ensemblePtr->subcommandArrayPtr = (char **)
+    ensemblePtr->subcommandArrayPtr =
 	    ckalloc(sizeof(char *) * hash->numEntries);
 
     /*
@@ -2590,7 +2589,7 @@ FreeEnsembleCmdRep(
     Tcl_DecrRefCount(ensembleCmd->realPrefixObj);
     ckfree(ensembleCmd->fullSubcmdName);
     TclNsDecrRefCount(ensembleCmd->nsPtr);
-    ckfree((char *) ensembleCmd);
+    ckfree(ensembleCmd);
     objPtr->typePtr = NULL;
 }
 
@@ -2618,8 +2617,7 @@ DupEnsembleCmdRep(
     Tcl_Obj *copyPtr)
 {
     EnsembleCmdRep *ensembleCmd = objPtr->internalRep.otherValuePtr;
-    EnsembleCmdRep *ensembleCopy = (EnsembleCmdRep *)
-	    ckalloc(sizeof(EnsembleCmdRep));
+    EnsembleCmdRep *ensembleCopy = ckalloc(sizeof(EnsembleCmdRep));
     int length = strlen(ensembleCmd->fullSubcmdName);
 
     copyPtr->typePtr = &tclEnsembleCmdType;
@@ -2630,7 +2628,7 @@ DupEnsembleCmdRep(
     ensembleCopy->nsPtr->refCount++;
     ensembleCopy->realPrefixObj = ensembleCmd->realPrefixObj;
     Tcl_IncrRefCount(ensembleCopy->realPrefixObj);
-    ensembleCopy->fullSubcmdName = ckalloc((unsigned) length+1);
+    ensembleCopy->fullSubcmdName = ckalloc(length + 1);
     memcpy(ensembleCopy->fullSubcmdName, ensembleCmd->fullSubcmdName,
 	    (unsigned) length+1);
 }
@@ -2660,7 +2658,7 @@ StringOfEnsembleCmdRep(
     int length = strlen(ensembleCmd->fullSubcmdName);
 
     objPtr->length = length;
-    objPtr->bytes = ckalloc((unsigned) length+1);
+    objPtr->bytes = ckalloc(length + 1);
     memcpy(objPtr->bytes, ensembleCmd->fullSubcmdName, (unsigned) length+1);
 }
 
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 4a52bea..980a785 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -184,12 +184,11 @@ TclSetEnv(
 	 */
 
 	if ((env.ourEnviron != environ) || (length+2 > env.ourEnvironSize)) {
-	    char **newEnviron = (char **)
-		    ckalloc(((unsigned) length + 5) * sizeof(char *));
+	    char **newEnviron = ckalloc((length + 5) * sizeof(char *));
 
 	    memcpy(newEnviron, environ, length * sizeof(char *));
 	    if ((env.ourEnvironSize != 0) && (env.ourEnviron != NULL)) {
-		ckfree((char *) env.ourEnviron);
+		ckfree(env.ourEnviron);
 	    }
 	    environ = env.ourEnviron = newEnviron;
 	    env.ourEnvironSize = length + 5;
@@ -239,7 +238,7 @@ TclSetEnv(
      * Copy the native string to heap memory.
      */
 
-    p = ckrealloc(p, (unsigned) Tcl_DStringLength(&envString) + 1);
+    p = ckrealloc(p, Tcl_DStringLength(&envString) + 1);
     memcpy(p, p2, (unsigned) Tcl_DStringLength(&envString) + 1);
     Tcl_DStringFree(&envString);
 
@@ -400,18 +399,18 @@ TclUnsetEnv(
      */
 
 #if defined(__WIN32__) || defined(__CYGWIN__)
-    string = ckalloc((unsigned) length+2);
+    string = ckalloc(length + 2);
     memcpy(string, name, (size_t) length);
     string[length] = '=';
     string[length+1] = '\0';
 #else
-    string = ckalloc((unsigned) length+1);
+    string = ckalloc(length + 1);
     memcpy(string, name, (size_t) length);
     string[length] = '\0';
 #endif /* WIN32 */
 
     Tcl_UtfToExternalDString(NULL, string, -1, &envString);
-    string = ckrealloc(string, (unsigned) Tcl_DStringLength(&envString)+1);
+    string = ckrealloc(string, Tcl_DStringLength(&envString) + 1);
     memcpy(string, Tcl_DStringValue(&envString),
 	    (unsigned) Tcl_DStringLength(&envString)+1);
     Tcl_DStringFree(&envString);
@@ -646,7 +645,7 @@ ReplaceString(
 
 	const int growth = 5;
 
-	env.cache = (char **) ckrealloc((char *) env.cache,
+	env.cache = ckrealloc(env.cache,
 		(env.cacheSize + growth) * sizeof(char *));
 	env.cache[env.cacheSize] = newStr;
 	(void) memset(env.cache+env.cacheSize+1, 0,
@@ -685,7 +684,7 @@ TclFinalizeEnvironment(void)
      */
 
     if (env.cache) {
-	ckfree((char *) env.cache);
+	ckfree(env.cache);
 	env.cache = NULL;
 	env.cacheSize = 0;
 #ifndef USE_PUTENV
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index ad20626..78bd7b8 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -159,7 +159,7 @@ Tcl_BackgroundException(
 	return;
     }
 
-    errPtr = (BgError *) ckalloc(sizeof(BgError));
+    errPtr = ckalloc(sizeof(BgError));
     errPtr->errorMsg = Tcl_GetObjResult(interp);
     Tcl_IncrRefCount(errPtr->errorMsg);
     errPtr->returnOpts = Tcl_GetReturnOptions(interp, code);
@@ -226,7 +226,7 @@ HandleBgErrors(
 	errPtr = assocPtr->firstBgPtr;
 
 	Tcl_ListObjGetElements(NULL, copyObj, &prefixObjc, &prefixObjv);
-	tempObjv = (Tcl_Obj **) ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
+	tempObjv = ckalloc((prefixObjc+2) * sizeof(Tcl_Obj *));
 	memcpy(tempObjv, prefixObjv, prefixObjc*sizeof(Tcl_Obj *));
 	tempObjv[prefixObjc] = errPtr->errorMsg;
 	tempObjv[prefixObjc+1] = errPtr->returnOpts;
@@ -241,8 +241,8 @@ HandleBgErrors(
 	Tcl_DecrRefCount(errPtr->errorMsg);
 	Tcl_DecrRefCount(errPtr->returnOpts);
 	assocPtr->firstBgPtr = errPtr->nextPtr;
-	ckfree((char *) errPtr);
-	ckfree((char *) tempObjv);
+	ckfree(errPtr);
+	ckfree(tempObjv);
 
 	if (code == TCL_BREAK) {
 	    /*
@@ -255,7 +255,7 @@ HandleBgErrors(
 		assocPtr->firstBgPtr = errPtr->nextPtr;
 		Tcl_DecrRefCount(errPtr->errorMsg);
 		Tcl_DecrRefCount(errPtr->returnOpts);
-		ckfree((char *) errPtr);
+		ckfree(errPtr);
 	    }
 	} else if ((code == TCL_ERROR) && !Tcl_IsSafe(interp)) {
 	    Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
@@ -522,7 +522,7 @@ TclSetBgErrorHandler(
 	 * First access: initialize.
 	 */
 
-	assocPtr = (ErrAssocData *) ckalloc(sizeof(ErrAssocData));
+	assocPtr = ckalloc(sizeof(ErrAssocData));
 	assocPtr->interp = interp;
 	assocPtr->cmdPrefix = NULL;
 	assocPtr->firstBgPtr = NULL;
@@ -601,7 +601,7 @@ BgErrorDeleteProc(
 	assocPtr->firstBgPtr = errPtr->nextPtr;
 	Tcl_DecrRefCount(errPtr->errorMsg);
 	Tcl_DecrRefCount(errPtr->returnOpts);
-	ckfree((char *) errPtr);
+	ckfree(errPtr);
     }
     Tcl_CancelIdleCall(HandleBgErrors, assocPtr);
     Tcl_DecrRefCount(assocPtr->cmdPrefix);
@@ -631,7 +631,7 @@ Tcl_CreateExitHandler(
     Tcl_ExitProc *proc,		/* Function to invoke. */
     ClientData clientData)	/* Arbitrary value to pass to proc. */
 {
-    ExitHandler *exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
+    ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
 
     exitPtr->proc = proc;
     exitPtr->clientData = clientData;
@@ -664,7 +664,7 @@ TclCreateLateExitHandler(
     Tcl_ExitProc *proc,		/* Function to invoke. */
     ClientData clientData)	/* Arbitrary value to pass to proc. */
 {
-    ExitHandler *exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
+    ExitHandler *exitPtr = ckalloc(sizeof(ExitHandler));
 
     exitPtr->proc = proc;
     exitPtr->clientData = clientData;
@@ -709,7 +709,7 @@ Tcl_DeleteExitHandler(
 	    } else {
 		prevPtr->nextPtr = exitPtr->nextPtr;
 	    }
-	    ckfree((char *) exitPtr);
+	    ckfree(exitPtr);
 	    break;
 	}
     }
@@ -752,7 +752,7 @@ TclDeleteLateExitHandler(
 	    } else {
 		prevPtr->nextPtr = exitPtr->nextPtr;
 	    }
-	    ckfree((char *) exitPtr);
+	    ckfree(exitPtr);
 	    break;
 	}
     }
@@ -786,7 +786,7 @@ Tcl_CreateThreadExitHandler(
     ExitHandler *exitPtr;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
-    exitPtr = (ExitHandler *) ckalloc(sizeof(ExitHandler));
+    exitPtr = ckalloc(sizeof(ExitHandler));
     exitPtr->proc = proc;
     exitPtr->clientData = clientData;
     exitPtr->nextPtr = tsdPtr->firstExitPtr;
@@ -828,7 +828,7 @@ Tcl_DeleteThreadExitHandler(
 	    } else {
 		prevPtr->nextPtr = exitPtr->nextPtr;
 	    }
-	    ckfree((char *) exitPtr);
+	    ckfree(exitPtr);
 	    return;
 	}
     }
@@ -905,8 +905,8 @@ InvokeExitHandlers(void)
 
 	firstExitPtr = exitPtr->nextPtr;
 	Tcl_MutexUnlock(&exitMutex);
-	(*exitPtr->proc)(exitPtr->clientData);
-	ckfree((char *) exitPtr);
+	exitPtr->proc(exitPtr->clientData);
+	ckfree(exitPtr);
 	Tcl_MutexLock(&exitMutex);
     }
     firstExitPtr = NULL;
@@ -1121,7 +1121,7 @@ Tcl_Finalize(void)
 	firstLateExitPtr = exitPtr->nextPtr;
 	Tcl_MutexUnlock(&exitMutex);
 	exitPtr->proc(exitPtr->clientData);
-	ckfree((char *) exitPtr);
+	ckfree(exitPtr);
 	Tcl_MutexLock(&exitMutex);
     }
     firstLateExitPtr = NULL;
@@ -1286,7 +1286,7 @@ Tcl_FinalizeThread(void)
 
 	    tsdPtr->firstExitPtr = exitPtr->nextPtr;
 	    exitPtr->proc(exitPtr->clientData);
-	    ckfree((char *) exitPtr);
+	    ckfree(exitPtr);
 	}
 	TclFinalizeIOSubsystem();
 	TclFinalizeNotifier();
@@ -1547,7 +1547,7 @@ NewThreadProc(
 
     threadProc = cdPtr->proc;
     threadClientData = cdPtr->clientData;
-    ckfree((char *) clientData);	/* Allocated in Tcl_CreateThread() */
+    ckfree(clientData);		/* Allocated in Tcl_CreateThread() */
 
     threadProc(threadClientData);
 
@@ -1584,15 +1584,14 @@ Tcl_CreateThread(
 				 * thread. */
 {
 #ifdef TCL_THREADS
-    ThreadClientData *cdPtr = (ThreadClientData *)
-	    ckalloc(sizeof(ThreadClientData));
+    ThreadClientData *cdPtr = ckalloc(sizeof(ThreadClientData));
     int result;
 
     cdPtr->proc = proc;
     cdPtr->clientData = clientData;
     result = TclpThreadCreate(idPtr, NewThreadProc, cdPtr, stackSize, flags);
     if (result != TCL_OK) {
-	ckfree((char *) cdPtr);
+	ckfree(cdPtr);
     }
     return result;
 #else
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ece8a8c..a1f4479 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -772,7 +772,7 @@ ReleaseDictIterator(
 
     searchPtr = objPtr->internalRep.twoPtrValue.ptr1;
     Tcl_DictObjDone(searchPtr);
-    ckfree((char *) searchPtr);
+    ckfree(searchPtr);
 
     dictPtr = objPtr->internalRep.twoPtrValue.ptr2;
     TclDecrRefCount(dictPtr);
@@ -847,8 +847,8 @@ TclCreateExecEnv(
     int size)			/* The initial stack size, in number of words
 				 * [sizeof(Tcl_Obj*)] */
 {
-    ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
-    ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack)
+    ExecEnv *eePtr = ckalloc(sizeof(ExecEnv));
+    ExecStack *esPtr = ckalloc(sizeof(ExecStack)
 	    + (size_t) (size-1) * sizeof(Tcl_Obj *));
 
     eePtr->execStackPtr = esPtr;
@@ -909,7 +909,7 @@ DeleteExecStack(
     if (esPtr->nextPtr) {
 	esPtr->nextPtr->prevPtr = esPtr->prevPtr;
     }
-    ckfree((char *) esPtr);
+    ckfree(esPtr);
 }
 
 void
@@ -939,7 +939,7 @@ TclDeleteExecEnv(
     if (eePtr->corPtr) {
 	Tcl_Panic("Deleting execEnv with existing coroutine");
     }
-    ckfree((char *) eePtr);
+    ckfree(eePtr);
 }
 
 /*
@@ -1109,7 +1109,7 @@ GrowEvaluationStack(
     newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
 
     oldPtr = esPtr;
-    esPtr = (ExecStack *) ckalloc(newBytes);
+    esPtr = ckalloc(newBytes);
 
     oldPtr->nextPtr = esPtr;
     esPtr->prevPtr = oldPtr;
@@ -2592,7 +2592,7 @@ TEBCresume(
 	    } else
 #endif
 	    {
-		p = (char *) ckalloc((unsigned) (length + appendLen + 1));
+		p = ckalloc(length + appendLen + 1);
 		TclNewObj(objResultPtr);
 		objResultPtr->bytes = p;
 		objResultPtr->length = length + appendLen;
@@ -5946,10 +5946,10 @@ TEBCresume(
 	opnd = TclGetUInt4AtPtr(pc+1);
 	TRACE(("%u => ", opnd));
 	dictPtr = POP_OBJECT();
-	searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch));
+	searchPtr = ckalloc(sizeof(Tcl_DictSearch));
 	if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
 		&valuePtr, &done) != TCL_OK) {
-	    ckfree((char *) searchPtr);
+	    ckfree(searchPtr);
 	    goto gotError;
 	}
 	TclNewObj(statePtr);
@@ -8691,7 +8691,7 @@ EvalStatsCmd(
     litTableStats = TclLiteralStats(globalTablePtr);
     Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
 	    litTableStats);
-    ckfree((char *) litTableStats);
+    ckfree(litTableStats);
 
     /*
      * Source and ByteCode size distributions.
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index df67176..d53c271 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -577,8 +577,7 @@ Tcl_SplitPath(
      * plus the argv pointers and the terminating NULL pointer.
      */
 
-    *argvPtr = (const char **) ckalloc((unsigned)
-	    ((((*argcPtr) + 1) * sizeof(char *)) + size));
+    *argvPtr = ckalloc((((*argcPtr) + 1) * sizeof(char *)) + size);
 
     /*
      * Position p after the last argv pointer and copy the contents of the
@@ -2568,7 +2567,7 @@ DoGlob(
 Tcl_StatBuf *
 Tcl_AllocStatBuf(void)
 {
-    return (Tcl_StatBuf *) ckalloc(sizeof(Tcl_StatBuf));
+    return ckalloc(sizeof(Tcl_StatBuf));
 }
 
 /*
diff --git a/generic/tclHash.c b/generic/tclHash.c
index 040cc6b..c8dc939 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -360,7 +360,7 @@ CreateHashEntry(
     if (typePtr->allocEntryProc) {
 	hPtr = typePtr->allocEntryProc(tablePtr, (void *) key);
     } else {
-	hPtr = (Tcl_HashEntry *) ckalloc((unsigned) sizeof(Tcl_HashEntry));
+	hPtr = ckalloc(sizeof(Tcl_HashEntry));
 	hPtr->key.oneWordValue = (char *) key;
 	hPtr->clientData = 0;
     }
@@ -462,7 +462,7 @@ Tcl_DeleteHashEntry(
     if (typePtr->freeEntryProc) {
 	typePtr->freeEntryProc(entryPtr);
     } else {
-	ckfree((char *) entryPtr);
+	ckfree(entryPtr);
     }
 }
 
@@ -513,7 +513,7 @@ Tcl_DeleteHashTable(
 	    if (typePtr->freeEntryProc) {
 		typePtr->freeEntryProc(hPtr);
 	    } else {
-		ckfree((char *) hPtr);
+		ckfree(hPtr);
 	    }
 	    hPtr = nextPtr;
 	}
@@ -527,7 +527,7 @@ Tcl_DeleteHashTable(
 	if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
 	    TclpSysFree((char *) tablePtr->buckets);
 	} else {
-	    ckfree((char *) tablePtr->buckets);
+	    ckfree(tablePtr->buckets);
 	}
     }
 
@@ -672,7 +672,7 @@ Tcl_HashStats(
      * Print out the histogram and a few other pieces of information.
      */
 
-    result = (char *) ckalloc((unsigned) (NUM_COUNTERS*60) + 300);
+    result = ckalloc((NUM_COUNTERS * 60) + 300);
     sprintf(result, "%d entries in table, %d buckets\n",
 	    tablePtr->numEntries, tablePtr->numBuckets);
     p = result + strlen(result);
@@ -721,7 +721,7 @@ AllocArrayEntry(
     if (size < sizeof(Tcl_HashEntry)) {
 	size = sizeof(Tcl_HashEntry);
     }
-    hPtr = (Tcl_HashEntry *) ckalloc(size);
+    hPtr = ckalloc(size);
 
     for (iPtr1 = array, iPtr2 = hPtr->key.words;
 	    count > 0; count--, iPtr1++, iPtr2++) {
@@ -833,7 +833,7 @@ AllocStringEntry(
     if (size < sizeof(hPtr->key)) {
 	allocsize = sizeof(hPtr->key);
     }
-    hPtr = (Tcl_HashEntry *) ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize);
+    hPtr = ckalloc(TclOffset(Tcl_HashEntry, key) + allocsize);
     memcpy(hPtr->key.string, string, size);
     hPtr->clientData = 0;
     return hPtr;
@@ -1042,8 +1042,8 @@ RebuildTable(
 	tablePtr->buckets = (Tcl_HashEntry **) TclpSysAlloc((unsigned)
 		(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)), 0);
     } else {
-	tablePtr->buckets = (Tcl_HashEntry **) ckalloc((unsigned)
-		(tablePtr->numBuckets * sizeof(Tcl_HashEntry *)));
+	tablePtr->buckets =
+		ckalloc(tablePtr->numBuckets * sizeof(Tcl_HashEntry *));
     }
     for (count = tablePtr->numBuckets, newChainPtr = tablePtr->buckets;
 	    count > 0; count--, newChainPtr++) {
@@ -1100,7 +1100,7 @@ RebuildTable(
 	if (typePtr->flags & TCL_HASH_KEY_SYSTEM_HASH) {
 	    TclpSysFree((char *) oldBuckets);
 	} else {
-	    ckfree((char *) oldBuckets);
+	    ckfree(oldBuckets);
 	}
     }
 }
diff --git a/generic/tclHistory.c b/generic/tclHistory.c
index 6bf9b74..b10d423 100644
--- a/generic/tclHistory.c
+++ b/generic/tclHistory.c
@@ -138,7 +138,7 @@ Tcl_RecordAndEvalObj(
      */
 
     if (histObjsPtr == NULL) {
-	histObjsPtr = (HistoryObjs *) ckalloc(sizeof(HistoryObjs));
+	histObjsPtr = ckalloc(sizeof(HistoryObjs));
 	TclNewLiteralStringObj(histObjsPtr->historyObj, "::history");
 	TclNewLiteralStringObj(histObjsPtr->addObj, "add");
 	Tcl_IncrRefCount(histObjsPtr->historyObj);
@@ -218,7 +218,7 @@ DeleteHistoryObjs(
 
     TclDecrRefCount(histObjsPtr->historyObj);
     TclDecrRefCount(histObjsPtr->addObj);
-    ckfree((char *) histObjsPtr);
+    ckfree(histObjsPtr);
 }
 
 /*
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 7abbba4..8f76b26 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -627,7 +627,7 @@ Tcl_CreateCloseHandler(
     ChannelState *statePtr = ((Channel *) chan)->state;
     CloseCallback *cbPtr;
 
-    cbPtr = (CloseCallback *) ckalloc(sizeof(CloseCallback));
+    cbPtr = ckalloc(sizeof(CloseCallback));
     cbPtr->proc = proc;
     cbPtr->clientData = clientData;
 
@@ -671,7 +671,7 @@ Tcl_DeleteCloseHandler(
 	    if (cbPrevPtr == NULL) {
 		statePtr->closeCbPtr = cbPtr->nextPtr;
 	    }
-	    ckfree((char *) cbPtr);
+	    ckfree(cbPtr);
 	    break;
 	}
 	cbPrevPtr = cbPtr;
@@ -706,7 +706,7 @@ GetChannelTable(
 
     hTblPtr = Tcl_GetAssocData(interp, "tclIO", NULL);
     if (hTblPtr == NULL) {
-	hTblPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+	hTblPtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(hTblPtr, TCL_STRING_KEYS);
 	Tcl_SetAssocData(interp, "tclIO",
 		(Tcl_InterpDeleteProc *) DeleteChannelTable, hTblPtr);
@@ -798,7 +798,7 @@ DeleteChannelTable(
 			TclChannelEventScriptInvoker, sPtr);
 
 		TclDecrRefCount(sPtr->scriptPtr);
-		ckfree((char *) sPtr);
+		ckfree(sPtr);
 	    } else {
 		prevPtr = sPtr;
 	    }
@@ -822,7 +822,7 @@ DeleteChannelTable(
 
     }
     Tcl_DeleteHashTable(hTblPtr);
-    ckfree((char *) hTblPtr);
+    ckfree(hTblPtr);
 }
 
 /*
@@ -1355,8 +1355,8 @@ Tcl_CreateChannel(
      * assignments to 0/NULL below.
      */
 
-    chanPtr = (Channel *) ckalloc(sizeof(Channel));
-    statePtr = (ChannelState *) ckalloc(sizeof(ChannelState));
+    chanPtr = ckalloc(sizeof(Channel));
+    statePtr = ckalloc(sizeof(ChannelState));
     chanPtr->state = statePtr;
 
     chanPtr->instanceData = instanceData;
@@ -1436,7 +1436,7 @@ Tcl_CreateChannel(
 
     statePtr->outputStage	= NULL;
     if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
-	statePtr->outputStage = ckalloc((unsigned) statePtr->bufSize + 2);
+	statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
     }
 
     /*
@@ -1647,7 +1647,7 @@ Tcl_StackChannel(
 	statePtr->inQueueTail = NULL;
     }
 
-    chanPtr = (Channel *) ckalloc(sizeof(Channel));
+    chanPtr = ckalloc(sizeof(Channel));
 
     /*
      * Save some of the current state into the new structure, reinitialize the
@@ -2143,7 +2143,7 @@ AllocChannelBuffer(
     int n;
 
     n = length + CHANNELBUFFER_HEADER_SIZE + BUFFER_PADDING + BUFFER_PADDING;
-    bufPtr = (ChannelBuffer *) ckalloc((unsigned) n);
+    bufPtr = ckalloc(n);
     bufPtr->nextAdded	= BUFFER_PADDING;
     bufPtr->nextRemoved	= BUFFER_PADDING;
     bufPtr->bufLength	= length + BUFFER_PADDING;
@@ -2182,7 +2182,7 @@ RecycleBuffer(
      */
 
     if (mustDiscard) {
-	ckfree((char *) bufPtr);
+	ckfree(bufPtr);
 	return;
     }
 
@@ -2193,7 +2193,7 @@ RecycleBuffer(
      */
 
     if ((bufPtr->bufLength - BUFFER_PADDING) < statePtr->bufSize) {
-	ckfree((char *) bufPtr);
+	ckfree(bufPtr);
 	return;
     }
 
@@ -2228,7 +2228,7 @@ RecycleBuffer(
      * If we reached this code we return the buffer to the OS.
      */
 
-    ckfree((char *) bufPtr);
+    ckfree(bufPtr);
     return;
 
   keepBuffer:
@@ -2619,7 +2619,7 @@ CloseChannel(
      */
 
     if (statePtr->curOutPtr != NULL) {
-	ckfree((char *) statePtr->curOutPtr);
+	ckfree(statePtr->curOutPtr);
 	statePtr->curOutPtr = NULL;
     }
 
@@ -2677,13 +2677,13 @@ CloseChannel(
 
     if (chanPtr == statePtr->bottomChanPtr) {
 	if (statePtr->channelName != NULL) {
-	    ckfree((char *) statePtr->channelName);
+	    ckfree(statePtr->channelName);
 	    statePtr->channelName = NULL;
 	}
 
 	Tcl_FreeEncoding(statePtr->encoding);
 	if (statePtr->outputStage != NULL) {
-	    ckfree((char *) statePtr->outputStage);
+	    ckfree(statePtr->outputStage);
 	    statePtr->outputStage = NULL;
 	}
     }
@@ -3066,7 +3066,7 @@ Tcl_Close(
 	cbPtr = statePtr->closeCbPtr;
 	statePtr->closeCbPtr = cbPtr->nextPtr;
 	cbPtr->proc(cbPtr->clientData);
-	ckfree((char *) cbPtr);
+	ckfree(cbPtr);
     }
 
     ResetFlag(statePtr, CHANNEL_INCLOSE);
@@ -3540,7 +3540,7 @@ Tcl_ClearChannelHandlers(
 
     for (chPtr = statePtr->chPtr; chPtr != NULL; chPtr = chNext) {
 	chNext = chPtr->nextPtr;
-	ckfree((char *) chPtr);
+	ckfree(chPtr);
     }
     statePtr->chPtr = NULL;
 
@@ -3567,7 +3567,7 @@ Tcl_ClearChannelHandlers(
     for (ePtr = statePtr->scriptRecordPtr; ePtr != NULL; ePtr = eNextPtr) {
 	eNextPtr = ePtr->nextPtr;
 	TclDecrRefCount(ePtr->scriptPtr);
-	ckfree((char *) ePtr);
+	ckfree(ePtr);
     }
     statePtr->scriptRecordPtr = NULL;
 }
@@ -6559,7 +6559,7 @@ DiscardInputQueued(
      */
 
     if (discardSavedBuffers && statePtr->saveInBufPtr != NULL) {
-	ckfree((char *) statePtr->saveInBufPtr);
+	ckfree(statePtr->saveInBufPtr);
 	statePtr->saveInBufPtr = NULL;
     }
 }
@@ -6652,7 +6652,7 @@ GetInput(
 
 	if ((bufPtr != NULL)
 		&& (bufPtr->bufLength - BUFFER_PADDING < statePtr->bufSize)) {
-	    ckfree((char *) bufPtr);
+	    ckfree(bufPtr);
 	    bufPtr = NULL;
 	}
 
@@ -7440,11 +7440,11 @@ Tcl_SetChannelBufferSize(
     statePtr->bufSize = sz;
 
     if (statePtr->outputStage != NULL) {
-	ckfree((char *) statePtr->outputStage);
+	ckfree(statePtr->outputStage);
 	statePtr->outputStage = NULL;
     }
     if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
-	statePtr->outputStage = ckalloc((unsigned) statePtr->bufSize + 2);
+	statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
     }
 }
 
@@ -7538,7 +7538,7 @@ Tcl_BadChannelOption(
 	}
 	Tcl_AppendResult(interp, "or -", argv[i], NULL);
 	Tcl_DStringFree(&ds);
-	ckfree((char *) argv);
+	ckfree(argv);
     }
     Tcl_SetErrno(EINVAL);
     return TCL_ERROR;
@@ -7923,7 +7923,7 @@ Tcl_SetChannelOption(
 		    Tcl_AppendResult(interp, "bad value for -eofchar: ",
 			    "must be non-NUL ASCII character", NULL);
 		}
-		ckfree((char *) argv);
+		ckfree(argv);
 		return TCL_ERROR;
 	    }
 	    if (GotFlag(statePtr, TCL_READABLE)) {
@@ -7938,11 +7938,11 @@ Tcl_SetChannelOption(
 			"bad value for -eofchar: should be a list of zero,"
 			" one, or two elements", NULL);
 	    }
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    return TCL_ERROR;
 	}
 	if (argv != NULL) {
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	}
 
 	/*
@@ -7972,7 +7972,7 @@ Tcl_SetChannelOption(
 			"bad value for -translation: must be a one or two"
 			" element list", NULL);
 	    }
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    return TCL_ERROR;
 	}
 
@@ -8003,7 +8003,7 @@ Tcl_SetChannelOption(
 			    "must be one of auto, binary, cr, lf, crlf,"
 			    " or platform", NULL);
 		}
-		ckfree((char *) argv);
+		ckfree(argv);
 		return TCL_ERROR;
 	    }
 
@@ -8054,11 +8054,11 @@ Tcl_SetChannelOption(
 			    "must be one of auto, binary, cr, lf, crlf,"
 			    " or platform", NULL);
 		}
-		ckfree((char *) argv);
+		ckfree(argv);
 		return TCL_ERROR;
 	    }
 	}
-	ckfree((char *) argv);
+	ckfree(argv);
 	return TCL_OK;
     } else if (chanPtr->typePtr->setOptionProc != NULL) {
 	return chanPtr->typePtr->setOptionProc(chanPtr->instanceData, interp,
@@ -8092,7 +8092,7 @@ Tcl_SetChannelOption(
 	statePtr->outputStage = NULL;
     }
     if ((statePtr->encoding != NULL) && GotFlag(statePtr, TCL_WRITABLE)) {
-	statePtr->outputStage = ckalloc((unsigned) (statePtr->bufSize + 2));
+	statePtr->outputStage = ckalloc(statePtr->bufSize + 2);
     }
     return TCL_OK;
 }
@@ -8144,7 +8144,7 @@ CleanupChannelHandlers(
 		    TclChannelEventScriptInvoker, sPtr);
 
 	    TclDecrRefCount(sPtr->scriptPtr);
-	    ckfree((char *) sPtr);
+	    ckfree(sPtr);
 	} else {
 	    prevPtr = sPtr;
 	}
@@ -8515,7 +8515,7 @@ Tcl_CreateChannelHandler(
 	}
     }
     if (chPtr == NULL) {
-	chPtr = (ChannelHandler *) ckalloc(sizeof(ChannelHandler));
+	chPtr = ckalloc(sizeof(ChannelHandler));
 	chPtr->mask = 0;
 	chPtr->proc = proc;
 	chPtr->clientData = clientData;
@@ -8619,7 +8619,7 @@ Tcl_DeleteChannelHandler(
     } else {
 	prevChPtr->nextPtr = chPtr->nextPtr;
     }
-    ckfree((char *) chPtr);
+    ckfree(chPtr);
 
     /*
      * Recompute the interest list for the channel, so that infinite loops
@@ -8678,7 +8678,7 @@ DeleteScriptRecord(
 		    TclChannelEventScriptInvoker, esPtr);
 
 	    TclDecrRefCount(esPtr->scriptPtr);
-	    ckfree((char *) esPtr);
+	    ckfree(esPtr);
 
 	    break;
 	}
@@ -8727,7 +8727,7 @@ CreateScriptRecord(
     makeCH = (esPtr == NULL);
 
     if (makeCH) {
-	esPtr = (EventScriptRecord *) ckalloc(sizeof(EventScriptRecord));
+	esPtr = ckalloc(sizeof(EventScriptRecord));
     }
 
     /*
@@ -9041,7 +9041,7 @@ TclCopyChannel(
      * completed.
      */
 
-    csPtr = (CopyState *) ckalloc(sizeof(CopyState) + inStatePtr->bufSize);
+    csPtr = ckalloc(sizeof(CopyState) + inStatePtr->bufSize);
     csPtr->bufSize = inStatePtr->bufSize;
     csPtr->readPtr = inPtr;
     csPtr->writePtr = outPtr;
@@ -10027,7 +10027,7 @@ StopCopy(
     }
     inStatePtr->csPtrR = NULL;
     outStatePtr->csPtrW = NULL;
-    ckfree((char *) csPtr);
+    ckfree(csPtr);
 }
 
 /*
@@ -10996,7 +10996,7 @@ FixLevelCode(
 	lcn += 2;
     }
 
-    lvn = (Tcl_Obj **) ckalloc(lcn * sizeof(Tcl_Obj *));
+    lvn = ckalloc(lcn * sizeof(Tcl_Obj *));
 
     /*
      * New level/code information is spliced into the first occurence of
@@ -11049,7 +11049,7 @@ FixLevelCode(
 
     msg = Tcl_NewListObj(j, lvn);
 
-    ckfree((char *) lvn);
+    ckfree(lvn);
     return msg;
 }
 
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index abbe002..1f0e4a9 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -1168,7 +1168,7 @@ Tcl_OpenObjCmd(
 		Tcl_SetChannelOption(interp, chan, "-translation", "binary");
 	    }
 	}
-	ckfree((char *) cmdArgv);
+	ckfree(cmdArgv);
     }
     if (chan == NULL) {
 	return TCL_ERROR;
@@ -1217,7 +1217,7 @@ TcpAcceptCallbacksDeleteProc(
 	acceptCallbackPtr->interp = NULL;
     }
     Tcl_DeleteHashTable(hTblPtr);
-    ckfree((char *) hTblPtr);
+    ckfree(hTblPtr);
 }
 
 /*
@@ -1257,7 +1257,7 @@ RegisterTcpServerInterpCleanup(
     hTblPtr = Tcl_GetAssocData(interp, "tclTCPAcceptCallbacks", NULL);
 
     if (hTblPtr == NULL) {
-	hTblPtr = (Tcl_HashTable *) ckalloc((unsigned) sizeof(Tcl_HashTable));
+	hTblPtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(hTblPtr, TCL_ONE_WORD_KEYS);
 	Tcl_SetAssocData(interp, "tclTCPAcceptCallbacks",
 		TcpAcceptCallbacksDeleteProc, hTblPtr);
@@ -1425,7 +1425,7 @@ TcpServerCloseProc(
 		acceptCallbackPtr);
     }
     Tcl_EventuallyFree(acceptCallbackPtr->script, TCL_DYNAMIC);
-    ckfree((char *) acceptCallbackPtr);
+    ckfree(acceptCallbackPtr);
 }
 
 /*
@@ -1561,8 +1561,8 @@ Tcl_SocketObjCmd(
     }
 
     if (server) {
-	AcceptCallback *acceptCallbackPtr = (AcceptCallback *)
-		ckalloc((unsigned) sizeof(AcceptCallback));
+	AcceptCallback *acceptCallbackPtr =
+		ckalloc(sizeof(AcceptCallback));
 	unsigned len = strlen(script) + 1;
 	char *copyScript = ckalloc(len);
 
@@ -1573,7 +1573,7 @@ Tcl_SocketObjCmd(
 		acceptCallbackPtr);
 	if (chan == NULL) {
 	    ckfree(copyScript);
-	    ckfree((char *) acceptCallbackPtr);
+	    ckfree(acceptCallbackPtr);
 	    return TCL_ERROR;
 	}
 
diff --git a/generic/tclIOGT.c b/generic/tclIOGT.c
index ae13296..6f80c25 100644
--- a/generic/tclIOGT.c
+++ b/generic/tclIOGT.c
@@ -259,7 +259,7 @@ TclChannelTransform(
      * regime of the underlying channel and to use the same for us too.
      */
 
-    dataPtr = (TransformChannelData *) ckalloc(sizeof(TransformChannelData));
+    dataPtr = ckalloc(sizeof(TransformChannelData));
 
     Tcl_DStringInit(&ds);
     Tcl_GetChannelOption(interp, chan, "-blocking", &ds);
@@ -288,7 +288,7 @@ TclChannelTransform(
 		Tcl_GetChannelName(chan), "\"", NULL);
 	Tcl_DecrRefCount(dataPtr->command);
 	ResultClear(&dataPtr->result);
-	ckfree((char *) dataPtr);
+	ckfree(dataPtr);
 	return TCL_ERROR;
     }
 
@@ -561,7 +561,7 @@ TransformCloseProc(
 
     ResultClear(&dataPtr->result);
     Tcl_DecrRefCount(dataPtr->command);
-    ckfree((char *) dataPtr);
+    ckfree(dataPtr);
     return TCL_OK;
 }
 
@@ -1227,7 +1227,7 @@ ResultClear(
     r->used = 0;
 
     if (r->allocated) {
-	ckfree((char *) r->buf);
+	ckfree(r->buf);
 	r->buf = NULL;
 	r->allocated = 0;
     }
@@ -1371,10 +1371,10 @@ ResultAdd(
 
 	if (r->allocated == 0) {
 	    r->allocated = toWrite + INCREMENT;
-	    r->buf = UCHARP(ckalloc(r->allocated));
+	    r->buf = ckalloc(r->allocated);
 	} else {
 	    r->allocated += toWrite + INCREMENT;
-	    r->buf = UCHARP(ckrealloc((char *) r->buf, r->allocated));
+	    r->buf = ckrealloc(r->buf, r->allocated);
 	}
     }
 
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index b3e3fde..683e2e4 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -687,8 +687,7 @@ TclChanCreateObjCmd(
 	 * as the actual channel type.
 	 */
 
-	Tcl_ChannelType *clonePtr = (Tcl_ChannelType *)
-		ckalloc(sizeof(Tcl_ChannelType));
+	Tcl_ChannelType *clonePtr = ckalloc(sizeof(Tcl_ChannelType));
 
 	memcpy(clonePtr, &tclRChannelType, sizeof(Tcl_ChannelType));
 
@@ -2030,7 +2029,7 @@ NewReflectedChannel(
     int i, listc;
     Tcl_Obj **listv;
 
-    rcPtr = (ReflectedChannel *) ckalloc(sizeof(ReflectedChannel));
+    rcPtr = ckalloc(sizeof(ReflectedChannel));
 
     /* rcPtr->chan: Assigned by caller. Dummy data here. */
     /* rcPtr->methods: Assigned by caller. Dummy data here. */
@@ -2063,7 +2062,7 @@ NewReflectedChannel(
      */
 
     rcPtr->argc = listc + 2;
-    rcPtr->argv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (listc+4));
+    rcPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4));
 
     /*
      * Duplicate object references.
@@ -2149,7 +2148,7 @@ FreeReflectedChannel(
 	 * Delete a cloned ChannelType structure.
 	 */
 
-	ckfree((char *) chanPtr->typePtr);
+	ckfree(chanPtr->typePtr);
     }
 
     n = rcPtr->argc - 2;
@@ -2163,8 +2162,8 @@ FreeReflectedChannel(
 
     Tcl_DecrRefCount(rcPtr->argv[n+1]);
 
-    ckfree((char *) rcPtr->argv);
-    ckfree((char *) rcPtr);
+    ckfree(rcPtr->argv);
+    ckfree(rcPtr);
 }
 
 /*
@@ -2415,7 +2414,7 @@ GetReflectedChannelMap(
     ReflectedChannelMap *rcmPtr = Tcl_GetAssocData(interp, RCMKEY, NULL);
 
     if (rcmPtr == NULL) {
-	rcmPtr = (ReflectedChannelMap *) ckalloc(sizeof(ReflectedChannelMap));
+	rcmPtr = ckalloc(sizeof(ReflectedChannelMap));
 	Tcl_InitHashTable(&rcmPtr->map, TCL_STRING_KEYS);
 	Tcl_SetAssocData(interp, RCMKEY,
 		(Tcl_InterpDeleteProc *) DeleteReflectedChannelMap, rcmPtr);
@@ -2482,7 +2481,7 @@ DeleteReflectedChannelMap(
 	Tcl_DeleteHashEntry(hPtr);
     }
     Tcl_DeleteHashTable(&rcmPtr->map);
-    ckfree((char *) &rcmPtr->map);
+    ckfree(&rcmPtr->map);
 
 #ifdef TCL_THREADS
     /*
@@ -2578,8 +2577,7 @@ GetThreadReflectedChannelMap(void)
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
     if (!tsdPtr->rcmPtr) {
-	tsdPtr->rcmPtr = (ReflectedChannelMap *)
-		ckalloc(sizeof(ReflectedChannelMap));
+	tsdPtr->rcmPtr = ckalloc(sizeof(ReflectedChannelMap));
 	Tcl_InitHashTable(&tsdPtr->rcmPtr->map, TCL_STRING_KEYS);
 	Tcl_CreateThreadExitHandler(DeleteThreadReflectedChannelMap, NULL);
     }
@@ -2712,8 +2710,8 @@ ForwardOpToOwnerThread(
      * Create and initialize the event and data structures.
      */
 
-    evPtr = (ForwardingEvent *) ckalloc(sizeof(ForwardingEvent));
-    resultPtr = (ForwardingResult *) ckalloc(sizeof(ForwardingResult));
+    evPtr = ckalloc(sizeof(ForwardingEvent));
+    resultPtr = ckalloc(sizeof(ForwardingResult));
 
     evPtr->event.proc = ForwardProc;
     evPtr->resultPtr = resultPtr;
@@ -2792,7 +2790,7 @@ ForwardOpToOwnerThread(
 
     Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
 
-    ckfree((char *) resultPtr);
+    ckfree(resultPtr);
 }
 
 static int
@@ -3187,7 +3185,7 @@ ForwardSetObjError(
     const char *msgStr = Tcl_GetStringFromObj(obj, &len);
 
     len++;
-    ForwardSetDynamicError(paramPtr, ckalloc((unsigned) len));
+    ForwardSetDynamicError(paramPtr, ckalloc(len));
     memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
 }
 #endif
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index ec3a266..5bd77b7 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -1751,7 +1751,7 @@ NewReflectedTransform(
     Tcl_Obj **listv;
     int i;
 
-    rtPtr = (ReflectedTransform *) ckalloc(sizeof(ReflectedTransform));
+    rtPtr = ckalloc(sizeof(ReflectedTransform));
 
     /* rtPtr->chan: Assigned by caller. Dummy data here. */
     /* rtPtr->methods: Assigned by caller. Dummy data here. */
@@ -1796,7 +1796,7 @@ NewReflectedTransform(
      */
 
     rtPtr->argc = listc + 2;
-    rtPtr->argv = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * (listc+4));
+    rtPtr->argv = ckalloc(sizeof(Tcl_Obj *) * (listc+4));
 
     /*
      * Duplicate object references.
@@ -1892,8 +1892,8 @@ FreeReflectedTransform(
      */
     Tcl_DecrRefCount(rtPtr->argv[n+1]);
 
-    ckfree((char*) rtPtr->argv);
-    ckfree((char*) rtPtr);
+    ckfree(rtPtr->argv);
+    ckfree(rtPtr);
 }
 
 /*
@@ -2090,8 +2090,7 @@ GetReflectedTransformMap(
     ReflectedTransformMap *rtmPtr = Tcl_GetAssocData(interp, RTMKEY, NULL);
 
     if (rtmPtr == NULL) {
-	rtmPtr = (ReflectedTransformMap *)
-		ckalloc(sizeof(ReflectedTransformMap));
+	rtmPtr = ckalloc(sizeof(ReflectedTransformMap));
 	Tcl_InitHashTable(&rtmPtr->map, TCL_STRING_KEYS);
 	Tcl_SetAssocData(interp, RTMKEY,
 		(Tcl_InterpDeleteProc *) DeleteReflectedTransformMap, rtmPtr);
@@ -2155,7 +2154,7 @@ DeleteReflectedTransformMap(
 	Tcl_DeleteHashEntry(hPtr);
     }
     Tcl_DeleteHashTable(&rtmPtr->map);
-    ckfree((char *) &rtmPtr->map);
+    ckfree(&rtmPtr->map);
 
 #ifdef TCL_THREADS
     /*
@@ -2249,8 +2248,7 @@ GetThreadReflectedTransformMap(void)
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
     if (!tsdPtr->rtmPtr) {
-	tsdPtr->rtmPtr = (ReflectedTransformMap *)
-		ckalloc(sizeof(ReflectedTransformMap));
+	tsdPtr->rtmPtr = ckalloc(sizeof(ReflectedTransformMap));
 	Tcl_InitHashTable(&tsdPtr->rtmPtr->map, TCL_STRING_KEYS);
 	Tcl_CreateThreadExitHandler(DeleteThreadReflectedTransformMap, NULL);
     }
@@ -2381,8 +2379,8 @@ ForwardOpToOwnerThread(
      * Create and initialize the event and data structures.
      */
 
-    evPtr = (ForwardingEvent *) ckalloc(sizeof(ForwardingEvent));
-    resultPtr = (ForwardingResult *) ckalloc(sizeof(ForwardingResult));
+    evPtr = ckalloc(sizeof(ForwardingEvent));
+    resultPtr = ckalloc(sizeof(ForwardingResult));
 
     evPtr->event.proc = ForwardProc;
     evPtr->resultPtr = resultPtr;
@@ -2461,7 +2459,7 @@ ForwardOpToOwnerThread(
 
     Tcl_DeleteThreadExitHandler(SrcExitProc, evPtr);
 
-    ckfree((char*) resultPtr);
+    ckfree(resultPtr);
 }
 
 static int
@@ -2780,7 +2778,7 @@ ForwardSetObjError(
     const char *msgStr = Tcl_GetStringFromObj(obj, &len);
 
     len++;
-    ForwardSetDynamicError(paramPtr, ckalloc((unsigned) len));
+    ForwardSetDynamicError(paramPtr, ckalloc(len));
     memcpy(paramPtr->base.msgStr, msgStr, (unsigned) len);
 }
 #endif
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 0cd8888..17e50fa 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -417,7 +417,7 @@ FsThrExitProc(
     while (fsRecPtr != NULL) {
 	tmpFsRecPtr = fsRecPtr->nextPtr;
 	if (--fsRecPtr->fileRefCount <= 0) {
-	    ckfree((char *) fsRecPtr);
+	    ckfree(fsRecPtr);
 	}
 	fsRecPtr = tmpFsRecPtr;
     }
@@ -535,7 +535,7 @@ FsRecacheFilesystemList(void)
     while (fsRecPtr != NULL) {
 	tmpFsRecPtr = fsRecPtr->nextPtr;
 	if (--fsRecPtr->fileRefCount <= 0) {
-	    ckfree((char *) fsRecPtr);
+	    ckfree(fsRecPtr);
 	}
 	fsRecPtr = tmpFsRecPtr;
     }
@@ -560,7 +560,7 @@ FsRecacheFilesystemList(void)
 
     fsRecPtr = tmpFsRecPtr;
     while (fsRecPtr != NULL) {
-	tmpFsRecPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
+	tmpFsRecPtr = ckalloc(sizeof(FilesystemRecord));
 	*tmpFsRecPtr = *fsRecPtr;
 	tmpFsRecPtr->nextPtr = tsdPtr->filesystemList;
 	tmpFsRecPtr->prevPtr = NULL;
@@ -733,7 +733,7 @@ TclFinalizeFilesystem(void)
 	     */
 
 	    if (fsRecPtr->fsPtr != &tclNativeFilesystem) {
-		ckfree((char *) fsRecPtr);
+		ckfree(fsRecPtr);
 	    }
 	}
 	fsRecPtr = tmpFsRecPtr;
@@ -827,7 +827,7 @@ Tcl_FSRegister(
 	return TCL_ERROR;
     }
 
-    newFilesystemPtr = (FilesystemRecord *) ckalloc(sizeof(FilesystemRecord));
+    newFilesystemPtr = ckalloc(sizeof(FilesystemRecord));
 
     newFilesystemPtr->clientData = clientData;
     newFilesystemPtr->fsPtr = fsPtr;
@@ -935,7 +935,7 @@ Tcl_FSUnregister(
 
 	    fsRecPtr->fileRefCount--;
 	    if (fsRecPtr->fileRefCount <= 0) {
-		ckfree((char *) fsRecPtr);
+		ckfree(fsRecPtr);
 	    }
 
 	    retVal = TCL_OK;
@@ -1596,7 +1596,7 @@ TclGetOpenModeEx(
 		Tcl_AppendResult(interp, "access mode \"", flag,
 			"\" not supported by this system", NULL);
 	    }
-	    ckfree((char *) modeArgv);
+	    ckfree(modeArgv);
 	    return -1;
 #endif
 
@@ -1608,7 +1608,7 @@ TclGetOpenModeEx(
 		Tcl_AppendResult(interp, "access mode \"", flag,
 			"\" not supported by this system", NULL);
 	    }
-	    ckfree((char *) modeArgv);
+	    ckfree(modeArgv);
 	    return -1;
 #endif
 
@@ -1623,12 +1623,12 @@ TclGetOpenModeEx(
 			"\": must be RDONLY, WRONLY, RDWR, APPEND, BINARY, "
 			"CREAT, EXCL, NOCTTY, NONBLOCK, or TRUNC", NULL);
 	    }
-	    ckfree((char *) modeArgv);
+	    ckfree(modeArgv);
 	    return -1;
 	}
     }
 
-    ckfree((char *) modeArgv);
+    ckfree(modeArgv);
 
     if (!gotRW) {
 	if (interp != NULL) {
@@ -3229,7 +3229,7 @@ Tcl_LoadFile(
      * unload and cleanup the temporary file correctly.
      */
 
-    tvdlPtr = (FsDivertLoad *) ckalloc(sizeof(FsDivertLoad));
+    tvdlPtr = ckalloc(sizeof(FsDivertLoad));
 
     /*
      * Remember three pieces of information. This allows us to cleanup the
@@ -3275,10 +3275,8 @@ Tcl_LoadFile(
 
     copyToPtr = NULL;
 
-    
-    divertedLoadHandle = (Tcl_LoadHandle)
-	    ckalloc(sizeof (struct Tcl_LoadHandle_));
-    divertedLoadHandle->clientData = (ClientData) tvdlPtr;
+    divertedLoadHandle = ckalloc(sizeof(struct Tcl_LoadHandle_));
+    divertedLoadHandle->clientData = tvdlPtr;
     divertedLoadHandle->findSymbolProcPtr = DivertFindSymbol;
     divertedLoadHandle->unloadFileProcPtr = DivertUnloadFile;
     *handlePtr = divertedLoadHandle;
@@ -3421,8 +3419,8 @@ DivertUnloadFile(
 	Tcl_DecrRefCount(tvdlPtr->divertedFile);
     }
 
-    ckfree((void *) tvdlPtr);
-    ckfree((void *) loadHandle);
+    ckfree(tvdlPtr);
+    ckfree(loadHandle);
 }
 
 /*
@@ -3635,7 +3633,7 @@ TclFSUnloadTempFile(
 	Tcl_DecrRefCount(tvdlPtr->divertedFile);
     }
 
-    ckfree((char *) tvdlPtr);
+    ckfree(tvdlPtr);
 }
 
 /*
@@ -4589,7 +4587,7 @@ static void
 NativeFreeInternalRep(
     ClientData clientData)
 {
-    ckfree((char *) clientData);
+    ckfree(clientData);
 }
 
 /*
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 2d0c22f..d98842e 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -193,14 +193,14 @@ GetIndexFromObjList(
      * Build a string table from the list.
      */
 
-    tablePtr = (const char **) ckalloc((objc + 1) * sizeof(char *));
+    tablePtr = ckalloc((objc + 1) * sizeof(char *));
     for (t = 0; t < objc; t++) {
 	if (objv[t] == objPtr) {
 	    /*
 	     * An exact match is always chosen, so we can stop here.
 	     */
 
-	    ckfree((char *) tablePtr);
+	    ckfree(tablePtr);
 	    *indexPtr = t;
 	    return TCL_OK;
 	}
@@ -218,7 +218,7 @@ GetIndexFromObjList(
 
     TclFreeIntRep(objPtr);
     objPtr->typePtr = NULL;
-    ckfree((char *) tablePtr);
+    ckfree(tablePtr);
 
     return result;
 }
@@ -340,7 +340,7 @@ Tcl_GetIndexFromObjStruct(
 	indexRep = objPtr->internalRep.otherValuePtr;
     } else {
 	TclFreeIntRep(objPtr);
-	indexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
+	indexRep = ckalloc(sizeof(IndexRep));
 	objPtr->internalRep.otherValuePtr = indexRep;
 	objPtr->typePtr = &indexType;
     }
@@ -443,7 +443,7 @@ UpdateStringOfIndex(
     register const char *indexStr = EXPAND_OF(indexRep);
 
     len = strlen(indexStr);
-    buf = (char *) ckalloc(len + 1);
+    buf = ckalloc(len + 1);
     memcpy(buf, indexStr, len+1);
     objPtr->bytes = buf;
     objPtr->length = len;
@@ -473,7 +473,7 @@ DupIndex(
     Tcl_Obj *dupPtr)
 {
     IndexRep *srcIndexRep = srcPtr->internalRep.otherValuePtr;
-    IndexRep *dupIndexRep = (IndexRep *) ckalloc(sizeof(IndexRep));
+    IndexRep *dupIndexRep = ckalloc(sizeof(IndexRep));
 
     memcpy(dupIndexRep, srcIndexRep, sizeof(IndexRep));
     dupPtr->internalRep.otherValuePtr = dupIndexRep;
@@ -501,7 +501,7 @@ static void
 FreeIndex(
     Tcl_Obj *objPtr)
 {
-    ckfree((char *) objPtr->internalRep.otherValuePtr);
+    ckfree(objPtr->internalRep.otherValuePtr);
     objPtr->typePtr = NULL;
 }
 
@@ -1109,7 +1109,7 @@ Tcl_ParseArgsObjv(
 	 */
 
 	nrem = 1;
-	leftovers = (Tcl_Obj **) ckalloc((nrem+1) * sizeof(Tcl_Obj *));
+	leftovers = ckalloc((nrem + 1) * sizeof(Tcl_Obj *));
 	leftovers[nrem-1] = objv[0];
 	leftovers[nrem] = NULL;
     } else {
@@ -1181,8 +1181,7 @@ Tcl_ParseArgsObjv(
 	     * Allocate nrem (+1 extra for NULL terminator) pointers.
 	     */
 
-	    leftovers = (Tcl_Obj **) ckrealloc((void *) leftovers,
-		    (nrem+1) * sizeof(Tcl_Obj *));
+	    leftovers = ckrealloc(leftovers, (nrem+1) * sizeof(Tcl_Obj *));
 	    leftovers[nrem-1] = curArg;
 	    continue;
 	}
@@ -1293,8 +1292,7 @@ Tcl_ParseArgsObjv(
     }
 
     if (objc > 0) {
-	leftovers = (Tcl_Obj **) ckrealloc((void *) leftovers,
-		(nrem+objc+1) * sizeof(Tcl_Obj *));
+	leftovers = ckrealloc(leftovers, (nrem+objc+1) * sizeof(Tcl_Obj *));
 	while (objc) {
 	    leftovers[nrem] = objv[srcIndex];
 	    nrem++;
@@ -1302,7 +1300,7 @@ Tcl_ParseArgsObjv(
 	    objc--;
 	}
     } else if (leftovers != NULL) {
-	ckfree((char *) leftovers);
+	ckfree(leftovers);
     }
     leftovers[nrem] = NULL;
     *objcPtr = nrem;
@@ -1319,7 +1317,7 @@ Tcl_ParseArgsObjv(
 	    "\" option requires an additional argument", NULL);
   error:
     if (leftovers != NULL) {
-	ckfree((char *) leftovers);
+	ckfree(leftovers);
     }
     return TCL_ERROR;
 }
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 49d324f..67761ed 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -436,7 +436,7 @@ TclInterpInit(
     Master *masterPtr;
     Slave *slavePtr;
 
-    interpInfoPtr = (InterpInfo *) ckalloc(sizeof(InterpInfo));
+    interpInfoPtr = ckalloc(sizeof(InterpInfo));
     ((Interp *) interp)->interpInfo = interpInfoPtr;
 
     masterPtr = &interpInfoPtr->master;
@@ -532,7 +532,7 @@ InterpInfoDeleteProc(
     }
     Tcl_DeleteHashTable(&slavePtr->aliasTable);
 
-    ckfree((char *) interpInfoPtr);
+    ckfree(interpInfoPtr);
 }
 
 /*
@@ -1289,7 +1289,7 @@ Tcl_GetAlias(
     }
     if (argvPtr != NULL) {
 	*argvPtr = (const char **)
-		ckalloc((unsigned) sizeof(const char *) * (objc - 1));
+		ckalloc(sizeof(const char *) * (objc - 1));
 	for (i = 1; i < objc; i++) {
 	    (*argvPtr)[i - 1] = TclGetString(objv[i]);
 	}
@@ -1492,8 +1492,7 @@ AliasCreate(
     Tcl_Obj **prefv;
     int isNew, i;
 
-    aliasPtr = (Alias *) ckalloc((unsigned) (sizeof(Alias)
-	    + objc * sizeof(Tcl_Obj *)));
+    aliasPtr = ckalloc(sizeof(Alias) + objc * sizeof(Tcl_Obj *));
     aliasPtr->token = namePtr;
     Tcl_IncrRefCount(aliasPtr->token);
     aliasPtr->targetInterp = masterInterp;
@@ -1544,7 +1543,7 @@ AliasCreate(
 	cmdPtr->deleteData = NULL;
 	Tcl_DeleteCommandFromToken(slaveInterp, aliasPtr->slaveCmd);
 
-	ckfree((char *) aliasPtr);
+	ckfree(aliasPtr);
 
 	/*
 	 * The result was already set by TclPreventAliasLoop.
@@ -1601,11 +1600,11 @@ AliasCreate(
      * interp alias {} foo {} zop		# Now recreate "foo"...
      */
 
-    targetPtr = (Target *) ckalloc((unsigned) sizeof(Target));
+    targetPtr = ckalloc(sizeof(Target));
     targetPtr->slaveCmd = aliasPtr->slaveCmd;
     targetPtr->slaveInterp = slaveInterp;
 
-    masterPtr = &((InterpInfo *) ((Interp*) masterInterp)->interpInfo)->master;
+    masterPtr = &((InterpInfo*) ((Interp*) masterInterp)->interpInfo)->master;
     targetPtr->nextPtr = masterPtr->targetsPtr;
     targetPtr->prevPtr = NULL;
     if (masterPtr->targetsPtr != NULL) {
@@ -1988,8 +1987,8 @@ AliasObjCmdDeleteProc(
 	targetPtr->nextPtr->prevPtr = targetPtr->prevPtr;
     }
 
-    ckfree((char *) targetPtr);
-    ckfree((char *) aliasPtr);
+    ckfree(targetPtr);
+    ckfree(aliasPtr);
 }
 
 /*
@@ -3440,7 +3439,7 @@ RunLimitHandlers(
 	    if (handlerPtr->deleteProc != NULL) {
 		handlerPtr->deleteProc(handlerPtr->clientData);
 	    }
-	    ckfree((char *) handlerPtr);
+	    ckfree(handlerPtr);
 	}
     }
 }
@@ -3487,7 +3486,7 @@ Tcl_LimitAddHandler(
      * Allocate a handler record.
      */
 
-    handlerPtr = (LimitHandler *) ckalloc(sizeof(LimitHandler));
+    handlerPtr = ckalloc(sizeof(LimitHandler));
     handlerPtr->flags = 0;
     handlerPtr->handlerProc = handlerProc;
     handlerPtr->clientData = clientData;
@@ -3606,7 +3605,7 @@ Tcl_LimitRemoveHandler(
 	    if (handlerPtr->deleteProc != NULL) {
 		handlerPtr->deleteProc(handlerPtr->clientData);
 	    }
-	    ckfree((char *) handlerPtr);
+	    ckfree(handlerPtr);
 	}
 	return;
     }
@@ -3666,7 +3665,7 @@ TclLimitRemoveAllHandlers(
 	    if (handlerPtr->deleteProc != NULL) {
 		handlerPtr->deleteProc(handlerPtr->clientData);
 	    }
-	    ckfree((char *) handlerPtr);
+	    ckfree(handlerPtr);
 	}
     }
 
@@ -3699,7 +3698,7 @@ TclLimitRemoveAllHandlers(
 	    if (handlerPtr->deleteProc != NULL) {
 		handlerPtr->deleteProc(handlerPtr->clientData);
 	    }
-	    ckfree((char *) handlerPtr);
+	    ckfree(handlerPtr);
 	}
     }
 
@@ -4094,7 +4093,7 @@ DeleteScriptLimitCallback(
     if (limitCBPtr->entryPtr != NULL) {
 	Tcl_DeleteHashEntry(limitCBPtr->entryPtr);
     }
-    ckfree((char *) limitCBPtr);
+    ckfree(limitCBPtr);
 }
 
 /*
@@ -4194,7 +4193,7 @@ SetScriptLimitCallback(
 		limitCBPtr);
     }
 
-    limitCBPtr = (ScriptLimitCallback *) ckalloc(sizeof(ScriptLimitCallback));
+    limitCBPtr = ckalloc(sizeof(ScriptLimitCallback));
     limitCBPtr->interp = interp;
     limitCBPtr->scriptObj = scriptObj;
     limitCBPtr->entryPtr = hashPtr;
diff --git a/generic/tclLink.c b/generic/tclLink.c
index a72fee6..00010f3 100644
--- a/generic/tclLink.c
+++ b/generic/tclLink.c
@@ -112,7 +112,7 @@ Tcl_LinkVar(
     Link *linkPtr;
     int code;
 
-    linkPtr = (Link *) ckalloc(sizeof(Link));
+    linkPtr = ckalloc(sizeof(Link));
     linkPtr->interp = interp;
     linkPtr->varName = Tcl_NewStringObj(varName, -1);
     Tcl_IncrRefCount(linkPtr->varName);
@@ -127,14 +127,14 @@ Tcl_LinkVar(
     if (Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, objPtr,
 	    TCL_GLOBAL_ONLY|TCL_LEAVE_ERR_MSG) == NULL) {
 	Tcl_DecrRefCount(linkPtr->varName);
-	ckfree((char *) linkPtr);
+	ckfree(linkPtr);
 	return TCL_ERROR;
     }
     code = Tcl_TraceVar(interp, varName, TCL_GLOBAL_ONLY|TCL_TRACE_READS
 	    |TCL_TRACE_WRITES|TCL_TRACE_UNSETS, LinkTraceProc, linkPtr);
     if (code != TCL_OK) {
 	Tcl_DecrRefCount(linkPtr->varName);
-	ckfree((char *) linkPtr);
+	ckfree(linkPtr);
     }
     return code;
 }
@@ -172,7 +172,7 @@ Tcl_UnlinkVar(
 	    TCL_GLOBAL_ONLY|TCL_TRACE_READS|TCL_TRACE_WRITES|TCL_TRACE_UNSETS,
 	    LinkTraceProc, linkPtr);
     Tcl_DecrRefCount(linkPtr->varName);
-    ckfree((char *) linkPtr);
+    ckfree(linkPtr);
 }
 
 /*
@@ -266,7 +266,7 @@ LinkTraceProc(
     if (flags & TCL_TRACE_UNSETS) {
 	if (Tcl_InterpDeleted(interp)) {
 	    Tcl_DecrRefCount(linkPtr->varName);
-	    ckfree((char *) linkPtr);
+	    ckfree(linkPtr);
 	} else if (flags & TCL_TRACE_DESTROYED) {
 	    Tcl_ObjSetVar2(interp, linkPtr->varName, NULL, ObjValue(linkPtr),
 		    TCL_GLOBAL_ONLY);
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 0cfe27d..46710d6 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -89,8 +89,7 @@ NewListIntRep(
 	return NULL;
     }
 
-    listRepPtr = (List *)
-	    attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)));
+    listRepPtr = attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj*)));
     if (listRepPtr == NULL) {
 	return NULL;
     }
@@ -600,12 +599,11 @@ Tcl_ListObjAppendElement(
 	listRepPtr->elemCount = numElems;
 	listRepPtr->refCount++;
 	oldListRepPtr->refCount--;
-	listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
     } else if (newSize) {
-	listRepPtr = (List *) ckrealloc((char *)listRepPtr, (size_t)newSize);
+	listRepPtr = ckrealloc(listRepPtr, newSize);
 	listRepPtr->maxElemCount = newMax;
-	listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
     }
+    listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
 
     /*
      * Add objPtr to the end of listPtr's array of element pointers. Increment
@@ -943,7 +941,7 @@ Tcl_ListObjReplace(
 			(size_t) numAfterLast * sizeof(Tcl_Obj *));
 	    }
 
-	    ckfree((char *) oldListRepPtr);
+	    ckfree(oldListRepPtr);
 	}
     }
 
@@ -1611,7 +1609,7 @@ FreeListInternalRep(
 	    objPtr = elemPtrs[i];
 	    Tcl_DecrRefCount(objPtr);
 	}
-	ckfree((char *) listRepPtr);
+	ckfree(listRepPtr);
     }
 
     listPtr->internalRep.twoPtrValue.ptr1 = NULL;
@@ -1786,7 +1784,7 @@ SetListFromAny(
 		elemPtr = elemPtrs[j];
 		Tcl_DecrRefCount(elemPtr);
 	    }
-	    ckfree((char *) listRepPtr);
+	    ckfree(listRepPtr);
 	    if (interp != NULL) {
 		Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL);
 	    }
@@ -1804,7 +1802,7 @@ SetListFromAny(
 	 * "elemSize" bytes starting at "elemStart".
 	 */
 
-	s = ckalloc((unsigned) elemSize + 1);
+	s = ckalloc(elemSize + 1);
 	if (hasBrace) {
 	    memcpy(s, elemStart, (size_t) elemSize);
 	    s[elemSize] = 0;
@@ -1883,7 +1881,7 @@ UpdateStringOfList(
     if (numElems <= LOCAL_SIZE) {
 	flagPtr = localFlags;
     } else {
-	flagPtr = (int *) ckalloc((unsigned) numElems * sizeof(int));
+	flagPtr = ckalloc(numElems * sizeof(int));
     }
     listPtr->length = 1;
     elemPtrs = &listRepPtr->elements;
@@ -1904,7 +1902,7 @@ UpdateStringOfList(
      * Pass 2: copy into string rep buffer.
      */
 
-    listPtr->bytes = ckalloc((unsigned) listPtr->length);
+    listPtr->bytes = ckalloc(listPtr->length);
     dst = listPtr->bytes;
     for (i = 0; i < numElems; i++) {
 	elem = TclGetStringFromObj(elemPtrs[i], &length);
@@ -1914,7 +1912,7 @@ UpdateStringOfList(
 	dst++;
     }
     if (flagPtr != localFlags) {
-	ckfree((char *) flagPtr);
+	ckfree(flagPtr);
     }
     if (dst == listPtr->bytes) {
 	*dst = 0;
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 0bf3be1..72c4577 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -198,7 +198,7 @@ TclDeleteLiteralTable(
 	    objPtr = entryPtr->objPtr;
 	    TclDecrRefCount(objPtr);
 	    nextPtr = entryPtr->nextPtr;
-	    ckfree((char *) entryPtr);
+	    ckfree(entryPtr);
 	    entryPtr = nextPtr;
 	}
     }
@@ -208,7 +208,7 @@ TclDeleteLiteralTable(
      */
 
     if (tablePtr->buckets != tablePtr->staticBuckets) {
-	ckfree((char *) tablePtr->buckets);
+	ckfree(tablePtr->buckets);
     }
 }
 
@@ -282,7 +282,7 @@ TclCreateLiteral(
 		*globalPtrPtr = globalPtr;
 	    }
 	    if (flags & LITERAL_ON_HEAP) {
-		ckfree((char *) bytes);
+		ckfree(bytes);
 	    }
 	    globalPtr->refCount++;
 	    return objPtr;
@@ -290,7 +290,7 @@ TclCreateLiteral(
     }
     if (!newPtr) {
 	if (flags & LITERAL_ON_HEAP) {
-	    ckfree((char *) bytes);
+	    ckfree(bytes);
 	}
 	return NULL;
     }
@@ -316,7 +316,7 @@ TclCreateLiteral(
     }
 #endif
 
-    globalPtr = (LiteralEntry *) ckalloc((unsigned) sizeof(LiteralEntry));
+    globalPtr = ckalloc(sizeof(LiteralEntry));
     globalPtr->objPtr = objPtr;
     globalPtr->refCount = 1;
     globalPtr->nsPtr = nsPtr;
@@ -438,7 +438,7 @@ TclRegisterLiteral(
 		|| ((objPtr->bytes[0] == bytes[0])
 		&& (memcmp(objPtr->bytes, bytes, (unsigned) length) == 0)))) {
 	    if (flags & LITERAL_ON_HEAP) {
-		ckfree((char *) bytes);
+		ckfree(bytes);
 	    }
 	    objIndex = (localPtr - envPtr->literalArrayPtr);
 #ifdef TCL_COMPILE_DEBUG
@@ -756,15 +756,14 @@ ExpandLocalLiteralArray(
     int i;
 
     if (envPtr->mallocedLiteralArray) {
-	newArrayPtr = (LiteralEntry *)
-		ckrealloc((char *)currArrayPtr, 2 * currBytes);
+	newArrayPtr = ckrealloc(currArrayPtr, 2 * currBytes);
     } else {
 	/*
 	 * envPtr->literalArrayPtr isn't a ckalloc'd pointer, so we must
 	 * code a ckrealloc equivalent for ourselves.
 	 */
 
-	newArrayPtr = (LiteralEntry *) ckalloc(2 * currBytes);
+	newArrayPtr = ckalloc(2 * currBytes);
 	memcpy(newArrayPtr, currArrayPtr, currBytes);
 	envPtr->mallocedLiteralArray = 1;
     }
@@ -853,7 +852,7 @@ TclReleaseLiteral(
 		} else {
 		    prevPtr->nextPtr = entryPtr->nextPtr;
 		}
-		ckfree((char *) entryPtr);
+		ckfree(entryPtr);
 		globalTablePtr->numEntries--;
 
 		TclDecrRefCount(objPtr);
@@ -975,8 +974,7 @@ RebuildLiteralTable(
      */
 
     tablePtr->numBuckets *= 4;
-    tablePtr->buckets = (LiteralEntry **) ckalloc((unsigned)
-	    (tablePtr->numBuckets * sizeof(LiteralEntry *)));
+    tablePtr->buckets = ckalloc(tablePtr->numBuckets * sizeof(LiteralEntry*));
     for (count=tablePtr->numBuckets, newChainPtr=tablePtr->buckets;
 	    count>0 ; count--, newChainPtr++) {
 	*newChainPtr = NULL;
@@ -1005,7 +1003,7 @@ RebuildLiteralTable(
      */
 
     if (oldBuckets != tablePtr->staticBuckets) {
-	ckfree((char *) oldBuckets);
+	ckfree(oldBuckets);
     }
 }
 
@@ -1067,7 +1065,7 @@ TclLiteralStats(
      * Print out the histogram and a few other pieces of information.
      */
 
-    result = (char *) ckalloc((unsigned) ((NUM_COUNTERS*60) + 300));
+    result = ckalloc(NUM_COUNTERS*60 + 300);
     sprintf(result, "%d entries in table, %d buckets\n",
 	    tablePtr->numEntries, tablePtr->numBuckets);
     p = result + strlen(result);
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index d54220f..371a437 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -363,7 +363,7 @@ Tcl_LoadObjCmd(
 	 * Create a new record to describe this package.
 	 */
 
-	pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
+	pkgPtr = ckalloc(sizeof(LoadedPackage));
 	len = strlen(fullFileName) + 1;
 	pkgPtr->fileName	   = ckalloc(len);
 	memcpy(pkgPtr->fileName, fullFileName, len);
@@ -439,7 +439,7 @@ Tcl_LoadObjCmd(
 	 */
 
 	ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
-	ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
+	ipPtr = ckalloc(sizeof(InterpPackage));
 	ipPtr->pkgPtr = pkgPtr;
 	ipPtr->nextPtr = ipFirstPtr;
 	Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
@@ -814,8 +814,8 @@ Tcl_UnloadObjCmd(
 			ipFirstPtr);
 		ckfree(defaultPtr->fileName);
 		ckfree(defaultPtr->packageName);
-		ckfree((char *) defaultPtr);
-		ckfree((char *) ipPtr);
+		ckfree(defaultPtr);
+		ckfree(ipPtr);
 		Tcl_MutexUnlock(&packageMutex);
 	    } else {
 		code = TCL_ERROR;
@@ -929,10 +929,10 @@ Tcl_StaticPackage(
      */
 
     if (pkgPtr == NULL) {
-	pkgPtr = (LoadedPackage *) ckalloc(sizeof(LoadedPackage));
-	pkgPtr->fileName	= ckalloc((unsigned) 1);
+	pkgPtr = ckalloc(sizeof(LoadedPackage));
+	pkgPtr->fileName	= ckalloc(1);
 	pkgPtr->fileName[0]	= 0;
-	pkgPtr->packageName	= ckalloc((unsigned) (strlen(pkgName) + 1));
+	pkgPtr->packageName	= ckalloc(strlen(pkgName) + 1);
 	strcpy(pkgPtr->packageName, pkgName);
 	pkgPtr->loadHandle	= NULL;
 	pkgPtr->initProc	= initProc;
@@ -962,7 +962,7 @@ Tcl_StaticPackage(
 	 * loaded.
 	 */
 
-	ipPtr = (InterpPackage *) ckalloc(sizeof(InterpPackage));
+	ipPtr = ckalloc(sizeof(InterpPackage));
 	ipPtr->pkgPtr = pkgPtr;
 	ipPtr->nextPtr = ipFirstPtr;
 	Tcl_SetAssocData(interp, "tclLoad", LoadCleanupProc, ipPtr);
@@ -1075,7 +1075,7 @@ LoadCleanupProc(
     ipPtr = clientData;
     while (ipPtr != NULL) {
 	nextPtr = ipPtr->nextPtr;
-	ckfree((char *) ipPtr);
+	ckfree(ipPtr);
 	ipPtr = nextPtr;
     }
 }
@@ -1128,7 +1128,7 @@ TclFinalizeLoad(void)
 
 	ckfree(pkgPtr->fileName);
 	ckfree(pkgPtr->packageName);
-	ckfree((char *) pkgPtr);
+	ckfree(pkgPtr);
     }
 }
 
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 7caadd1..1b3b091 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -548,8 +548,7 @@ Tcl_MainEx(
 		if (tty) {
 		    Prompt(interp, &prompt);
 		}
-		isPtr = (InteractiveState *)
-			ckalloc(sizeof(InteractiveState));
+		isPtr = ckalloc(sizeof(InteractiveState));
 		isPtr->input = inChannel;
 		isPtr->tty = tty;
 		isPtr->commandPtr = commandPtr;
@@ -577,7 +576,7 @@ Tcl_MainEx(
 		if (isPtr->input != NULL) {
 		    Tcl_DeleteChannelHandler(isPtr->input, StdinProc, isPtr);
 		}
-		ckfree((char *) isPtr);
+		ckfree(isPtr);
 	    }
 	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
 	    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 7f86c38..ad233b9 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -397,7 +397,7 @@ Tcl_PopCallFrame(
 
     if (framePtr->varTablePtr != NULL) {
 	TclDeleteVars(iPtr, framePtr->varTablePtr);
-	ckfree((char *) framePtr->varTablePtr);
+	ckfree(framePtr->varTablePtr);
 	framePtr->varTablePtr = NULL;
     }
     if (framePtr->numCompiledLocals > 0) {
@@ -734,9 +734,9 @@ Tcl_CreateNamespace(
      * of namespaces created.
      */
 
-    nsPtr = (Namespace *) ckalloc(sizeof(Namespace));
+    nsPtr = ckalloc(sizeof(Namespace));
     nameLen = strlen(simpleName) + 1;
-    nsPtr->name = ckalloc((unsigned) nameLen);
+    nsPtr->name = ckalloc(nameLen);
     memcpy(nsPtr->name, simpleName, nameLen);
     nsPtr->fullName = NULL;		/* Set below. */
     nsPtr->clientData = clientData;
@@ -825,7 +825,7 @@ Tcl_CreateNamespace(
 
     name = Tcl_DStringValue(namePtr);
     nameLen = Tcl_DStringLength(namePtr);
-    nsPtr->fullName = ckalloc((unsigned) (nameLen+1));
+    nsPtr->fullName = ckalloc(nameLen + 1);
     memcpy(nsPtr->fullName, name, (unsigned) nameLen + 1);
 
     Tcl_DStringFree(&buffer1);
@@ -1006,7 +1006,7 @@ Tcl_DeleteNamespace(
 #else
 	    if (nsPtr->childTablePtr != NULL) {
 		Tcl_DeleteHashTable(nsPtr->childTablePtr);
-		ckfree((char *) nsPtr->childTablePtr);
+		ckfree(nsPtr->childTablePtr);
 	    }
 #endif
 	    Tcl_DeleteHashTable(&nsPtr->cmdTable);
@@ -1170,7 +1170,7 @@ TclTeardownNamespace(
 	for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
 	    ckfree(nsPtr->exportArrayPtr[i]);
 	}
-	ckfree((char *) nsPtr->exportArrayPtr);
+	ckfree(nsPtr->exportArrayPtr);
 	nsPtr->exportArrayPtr = NULL;
 	nsPtr->numExportPatterns = 0;
 	nsPtr->maxExportPatterns = 0;
@@ -1224,8 +1224,7 @@ NamespaceFree(
 
     ckfree(nsPtr->name);
     ckfree(nsPtr->fullName);
-
-    ckfree((char *) nsPtr);
+    ckfree(nsPtr);
 }
 
 /*
@@ -1317,7 +1316,7 @@ Tcl_Export(
 	    for (i = 0;  i < nsPtr->numExportPatterns;  i++) {
 		ckfree(nsPtr->exportArrayPtr[i]);
 	    }
-	    ckfree((char *) nsPtr->exportArrayPtr);
+	    ckfree(nsPtr->exportArrayPtr);
 	    nsPtr->exportArrayPtr = NULL;
 	    TclInvalidateNsCmdLookup(nsPtr);
 	    nsPtr->numExportPatterns = 0;
@@ -1364,8 +1363,7 @@ Tcl_Export(
     if (neededElems > nsPtr->maxExportPatterns) {
 	nsPtr->maxExportPatterns = nsPtr->maxExportPatterns ?
 		2 * nsPtr->maxExportPatterns : INIT_EXPORT_PATTERNS;
-	nsPtr->exportArrayPtr = (char **)
-		ckrealloc((char *) nsPtr->exportArrayPtr,
+	nsPtr->exportArrayPtr = ckrealloc(nsPtr->exportArrayPtr,
 		sizeof(char *) * nsPtr->maxExportPatterns);
     }
 
@@ -1374,7 +1372,7 @@ Tcl_Export(
      */
 
     len = strlen(pattern);
-    patternCpy = ckalloc((unsigned) (len + 1));
+    patternCpy = ckalloc(len + 1);
     memcpy(patternCpy, pattern, (unsigned) len + 1);
 
     nsPtr->exportArrayPtr[nsPtr->numExportPatterns] = patternCpy;
@@ -1688,7 +1686,7 @@ DoImport(
 	    }
 	}
 
-	dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData));
+	dataPtr = ckalloc(sizeof(ImportedCmdData));
 	importedCmd = Tcl_NRCreateCommand(interp, Tcl_DStringValue(&ds),
 		InvokeImportedCmd, InvokeImportedNRCmd, dataPtr,
 		DeleteImportedCmd);
@@ -1702,7 +1700,7 @@ DoImport(
 	 * and add it to the import ref list in the "real" command.
 	 */
 
-	refPtr = (ImportRef *) ckalloc(sizeof(ImportRef));
+	refPtr = ckalloc(sizeof(ImportRef));
 	refPtr->importedCmdPtr = (Command *) importedCmd;
 	refPtr->nextPtr = cmdPtr->importRefPtr;
 	cmdPtr->importRefPtr = refPtr;
@@ -1999,8 +1997,8 @@ DeleteImportedCmd(
 	    } else {
 		prevPtr->nextPtr = refPtr->nextPtr;
 	    }
-	    ckfree((char *) refPtr);
-	    ckfree((char *) dataPtr);
+	    ckfree(refPtr);
+	    ckfree(dataPtr);
 	    return;
 	}
 	prevPtr = refPtr;
@@ -4024,7 +4022,7 @@ TclSetNsPath(
     Tcl_Namespace *pathAry[])	/* Array of namespaces that are the path. */
 {
     if (pathLength != 0) {
-	NamespacePathEntry *tmpPathArray = (NamespacePathEntry *)
+	NamespacePathEntry *tmpPathArray =
 		ckalloc(sizeof(NamespacePathEntry) * pathLength);
 	int i;
 
@@ -4093,7 +4091,7 @@ UnlinkNsPath(
 	    }
 	}
     }
-    ckfree((char *) nsPtr->commandPathArray);
+    ckfree(nsPtr->commandPathArray);
 }
 
 /*
@@ -4639,7 +4637,7 @@ FreeNsNameInternalRep(
 	 */
 
 	TclNsDecrRefCount(resNamePtr->nsPtr);
-	ckfree((char *) resNamePtr);
+	ckfree(resNamePtr);
     }
     objPtr->typePtr = NULL;
 }
@@ -4732,7 +4730,7 @@ SetNsNameFromAny(
     }
 
     nsPtr->refCount++;
-    resNamePtr = (ResolvedNsName *) ckalloc(sizeof(ResolvedNsName));
+    resNamePtr = ckalloc(sizeof(ResolvedNsName));
     resNamePtr->nsPtr = nsPtr;
     if ((name[0] == ':') && (name[1] == ':')) {
 	resNamePtr->refNsPtr = NULL;
@@ -4794,7 +4792,7 @@ TclGetNamespaceChildTable(
     return &nPtr->childTable;
 #else
     if (nPtr->childTablePtr == NULL) {
-	nPtr->childTablePtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable));
+	nPtr->childTablePtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
     }
     return nPtr->childTablePtr;
diff --git a/generic/tclNotify.c b/generic/tclNotify.c
index 7edb192..a6523fc 100644
--- a/generic/tclNotify.c
+++ b/generic/tclNotify.c
@@ -181,7 +181,7 @@ TclFinalizeNotifier(void)
     for (evPtr = tsdPtr->firstEventPtr; evPtr != NULL; ) {
 	hold = evPtr;
 	evPtr = evPtr->nextPtr;
-	ckfree((char *) hold);
+	ckfree(hold);
     }
     tsdPtr->firstEventPtr = NULL;
     tsdPtr->lastEventPtr = NULL;
@@ -276,7 +276,7 @@ Tcl_CreateEventSource(
 				 * checkProc. */
 {
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-    EventSource *sourcePtr = (EventSource *) ckalloc(sizeof(EventSource));
+    EventSource *sourcePtr = ckalloc(sizeof(EventSource));
 
     sourcePtr->setupProc = setupProc;
     sourcePtr->checkProc = checkProc;
@@ -330,7 +330,7 @@ Tcl_DeleteEventSource(
 	} else {
 	    prevPtr->nextPtr = sourcePtr->nextPtr;
 	}
-	ckfree((char *) sourcePtr);
+	ckfree(sourcePtr);
 	return;
     }
 }
@@ -412,7 +412,7 @@ Tcl_ThreadQueueEvent(
     if (tsdPtr) {
 	QueueEvent(tsdPtr, evPtr, position);
     } else {
-	ckfree((char *) evPtr);
+	ckfree(evPtr);
     }
     Tcl_MutexUnlock(&listLock);
 }
@@ -563,7 +563,7 @@ Tcl_DeleteEvents(
 
 	    hold = evPtr;
 	    evPtr = evPtr->nextPtr;
-	    ckfree((char *) hold);
+	    ckfree(hold);
 	} else {
 	    /*
 	     * Event is to be retained.
@@ -702,7 +702,7 @@ Tcl_ServiceEvent(
 		}
 	    }
 	    if (evPtr) {
-		ckfree((char *) evPtr);
+		ckfree(evPtr);
 	    }
 	    Tcl_MutexUnlock(&(tsdPtr->queueMutex));
 	    return 1;
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 4397d8a..047b4c5 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -220,7 +220,7 @@ InitFoundation(
     static Tcl_ThreadDataKey tsdKey;
     ThreadLocalData *tsdPtr =
 	    Tcl_GetThreadData(&tsdKey, sizeof(ThreadLocalData));
-    Foundation *fPtr = (Foundation *) ckalloc(sizeof(Foundation));
+    Foundation *fPtr = ckalloc(sizeof(Foundation));
     Tcl_Obj *namePtr, *argsPtr, *bodyPtr;
     Tcl_DString buffer;
     int i;
@@ -292,7 +292,7 @@ InitFoundation(
     fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
     fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
     fPtr->objectCls->superclasses.num = 0;
-    ckfree((char *) fPtr->objectCls->superclasses.list);
+    ckfree(fPtr->objectCls->superclasses.list);
     fPtr->objectCls->superclasses.list = NULL;
     fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
     fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
@@ -419,7 +419,7 @@ KillFoundation(
     Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
     Tcl_DecrRefCount(fPtr->constructorName);
     Tcl_DecrRefCount(fPtr->destructorName);
-    ckfree((char *) fPtr);
+    ckfree(fPtr);
 }
 
 /*
@@ -453,7 +453,7 @@ AllocObject(
     CommandTrace *tracePtr;
     int creationEpoch, ignored;
 
-    oPtr = (Object *) ckalloc(sizeof(Object));
+    oPtr = ckalloc(sizeof(Object));
     memset(oPtr, 0, sizeof(Object));
 
     /*
@@ -567,8 +567,7 @@ AllocObject(
 
     cmdPtr = (Command *) oPtr->command;
     cmdPtr->nreProc = PublicNRObjectCmd;
-    cmdPtr->tracePtr = tracePtr = (CommandTrace *)
-	    ckalloc(sizeof(CommandTrace));
+    cmdPtr->tracePtr = tracePtr = ckalloc(sizeof(CommandTrace));
     tracePtr->traceProc = ObjectRenamedTrace;
     tracePtr->clientData = oPtr;
     tracePtr->flags = TCL_TRACE_RENAME|TCL_TRACE_DELETE;
@@ -580,7 +579,7 @@ AllocObject(
      * a bottleneck in string manipulation. Another abstraction-buster.
      */
 
-    cmdPtr = (Command *) ckalloc(sizeof(Command));
+    cmdPtr = ckalloc(sizeof(Command));
     memset(cmdPtr, 0, sizeof(Command));
     cmdPtr->nsPtr = (Namespace *) oPtr->namespacePtr;
     cmdPtr->hPtr = Tcl_CreateHashEntry(&cmdPtr->nsPtr->cmdTable, "my",
@@ -809,7 +808,7 @@ ReleaseClassContents(
 	DelRef(list[i]);
     }
     if (list != NULL) {
-	ckfree((char *) list);
+	ckfree(list);
     }
 
     list = clsPtr->subclasses.list;
@@ -830,7 +829,7 @@ ReleaseClassContents(
 	DelRef(list[i]);
     }
     if (list != NULL) {
-	ckfree((char *) list);
+	ckfree(list);
     }
 
     insts = clsPtr->instances.list;
@@ -849,7 +848,7 @@ ReleaseClassContents(
 	DelRef(insts[i]);
     }
     if (insts != NULL) {
-	ckfree((char *) insts);
+	ckfree(insts);
     }
 
     if (clsPtr->constructorChainPtr) {
@@ -868,7 +867,7 @@ ReleaseClassContents(
 	    TclOODeleteChain(callPtr);
 	}
 	Tcl_DeleteHashTable(clsPtr->classChainCache);
-	ckfree((char *) clsPtr->classChainCache);
+	ckfree(clsPtr->classChainCache);
 	clsPtr->classChainCache = NULL;
     }
 
@@ -878,7 +877,7 @@ ReleaseClassContents(
 	FOREACH(filterObj, clsPtr->filters) {
 	    Tcl_DecrRefCount(filterObj);
 	}
-	ckfree((char *) clsPtr->filters.list);
+	ckfree(clsPtr->filters.list);
 	clsPtr->filters.num = 0;
     }
 
@@ -892,7 +891,7 @@ ReleaseClassContents(
 	    metadataTypePtr->deleteProc(value);
 	}
 	Tcl_DeleteHashTable(clsPtr->metadataPtr);
-	ckfree((char *) clsPtr->metadataPtr);
+	ckfree(clsPtr->metadataPtr);
 	clsPtr->metadataPtr = NULL;
     }
 }
@@ -957,14 +956,14 @@ ObjectNamespaceDeleted(
 	TclOORemoveFromInstances(oPtr, mixinPtr);
     }
     if (i) {
-	ckfree((char *) oPtr->mixins.list);
+	ckfree(oPtr->mixins.list);
     }
 
     FOREACH(filterObj, oPtr->filters) {
 	Tcl_DecrRefCount(filterObj);
     }
     if (i) {
-	ckfree((char *) oPtr->filters.list);
+	ckfree(oPtr->filters.list);
     }
 
     if (oPtr->methodsPtr) {
@@ -972,14 +971,14 @@ ObjectNamespaceDeleted(
 	    TclOODelMethodRef(mPtr);
 	}
 	Tcl_DeleteHashTable(oPtr->methodsPtr);
-	ckfree((char *) oPtr->methodsPtr);
+	ckfree(oPtr->methodsPtr);
     }
 
     FOREACH(variableObj, oPtr->variables) {
 	Tcl_DecrRefCount(variableObj);
     }
     if (i) {
-	ckfree((char *) oPtr->variables.list);
+	ckfree(oPtr->variables.list);
     }
 
     if (oPtr->chainCache) {
@@ -999,7 +998,7 @@ ObjectNamespaceDeleted(
 	    metadataTypePtr->deleteProc(value);
 	}
 	Tcl_DeleteHashTable(oPtr->metadataPtr);
-	ckfree((char *) oPtr->metadataPtr);
+	ckfree(oPtr->metadataPtr);
 	oPtr->metadataPtr = NULL;
     }
 
@@ -1014,7 +1013,7 @@ ObjectNamespaceDeleted(
 		metadataTypePtr->deleteProc(value);
 	    }
 	    Tcl_DeleteHashTable(clsPtr->metadataPtr);
-	    ckfree((char *) clsPtr->metadataPtr);
+	    ckfree(clsPtr->metadataPtr);
 	    clsPtr->metadataPtr = NULL;
 	}
 
@@ -1022,7 +1021,7 @@ ObjectNamespaceDeleted(
 	    Tcl_DecrRefCount(filterObj);
 	}
 	if (i) {
-	    ckfree((char *) clsPtr->filters.list);
+	    ckfree(clsPtr->filters.list);
 	    clsPtr->filters.num = 0;
 	}
 	FOREACH(mixinPtr, clsPtr->mixins) {
@@ -1031,7 +1030,7 @@ ObjectNamespaceDeleted(
 	    }
 	}
 	if (i) {
-	    ckfree((char *) clsPtr->mixins.list);
+	    ckfree(clsPtr->mixins.list);
 	    clsPtr->mixins.num = 0;
 	}
 	FOREACH(superPtr, clsPtr->superclasses) {
@@ -1040,19 +1039,19 @@ ObjectNamespaceDeleted(
 	    }
 	}
 	if (i) {
-	    ckfree((char *) clsPtr->superclasses.list);
+	    ckfree(clsPtr->superclasses.list);
 	    clsPtr->superclasses.num = 0;
 	}
 	if (clsPtr->subclasses.list) {
-	    ckfree((char *) clsPtr->subclasses.list);
+	    ckfree(clsPtr->subclasses.list);
 	    clsPtr->subclasses.num = 0;
 	}
 	if (clsPtr->instances.list) {
-	    ckfree((char *) clsPtr->instances.list);
+	    ckfree(clsPtr->instances.list);
 	    clsPtr->instances.num = 0;
 	}
 	if (clsPtr->mixinSubs.list) {
-	    ckfree((char *) clsPtr->mixinSubs.list);
+	    ckfree(clsPtr->mixinSubs.list);
 	    clsPtr->mixinSubs.num = 0;
 	}
 
@@ -1067,7 +1066,7 @@ ObjectNamespaceDeleted(
 	    Tcl_DecrRefCount(variableObj);
 	}
 	if (i) {
-	    ckfree((char *) clsPtr->variables.list);
+	    ckfree(clsPtr->variables.list);
 	}
 
 	DelRef(clsPtr);
@@ -1143,11 +1142,9 @@ TclOOAddToInstances(
     if (clsPtr->instances.num >= clsPtr->instances.size) {
 	clsPtr->instances.size += ALLOC_CHUNK;
 	if (clsPtr->instances.size == ALLOC_CHUNK) {
-	    clsPtr->instances.list = (Object **)
-		    ckalloc(sizeof(Object *) * ALLOC_CHUNK);
+	    clsPtr->instances.list = ckalloc(sizeof(Object *) * ALLOC_CHUNK);
 	} else {
-	    clsPtr->instances.list = (Object **)
-		    ckrealloc((char *) clsPtr->instances.list,
+	    clsPtr->instances.list = ckrealloc(clsPtr->instances.list,
 		    sizeof(Object *) * clsPtr->instances.size);
 	}
     }
@@ -1211,11 +1208,9 @@ TclOOAddToSubclasses(
     if (superPtr->subclasses.num >= superPtr->subclasses.size) {
 	superPtr->subclasses.size += ALLOC_CHUNK;
 	if (superPtr->subclasses.size == ALLOC_CHUNK) {
-	    superPtr->subclasses.list = (Class **)
-		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+	    superPtr->subclasses.list = ckalloc(sizeof(Class*) * ALLOC_CHUNK);
 	} else {
-	    superPtr->subclasses.list = (Class **)
-		    ckrealloc((char *) superPtr->subclasses.list,
+	    superPtr->subclasses.list = ckrealloc(superPtr->subclasses.list,
 		    sizeof(Class *) * superPtr->subclasses.size);
 	}
     }
@@ -1279,11 +1274,9 @@ TclOOAddToMixinSubs(
     if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
 	superPtr->mixinSubs.size += ALLOC_CHUNK;
 	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
-	    superPtr->mixinSubs.list = (Class **)
-		    ckalloc(sizeof(Class *) * ALLOC_CHUNK);
+	    superPtr->mixinSubs.list = ckalloc(sizeof(Class *) * ALLOC_CHUNK);
 	} else {
-	    superPtr->mixinSubs.list = (Class **)
-		    ckrealloc((char *) superPtr->mixinSubs.list,
+	    superPtr->mixinSubs.list = ckrealloc(superPtr->mixinSubs.list,
 		    sizeof(Class *) * superPtr->mixinSubs.size);
 	}
     }
@@ -1310,7 +1303,7 @@ AllocClass(
 				 * (with automatic name) is to be used. */
 {
     Foundation *fPtr = GetFoundation(interp);
-    Class *clsPtr = (Class *) ckalloc(sizeof(Class));
+    Class *clsPtr = ckalloc(sizeof(Class));
 
     /*
      * Make an object if we haven't been given one.
@@ -1351,7 +1344,7 @@ AllocClass(
      */
 
     clsPtr->superclasses.num = 1;
-    clsPtr->superclasses.list = (Class **) ckalloc(sizeof(Class *));
+    clsPtr->superclasses.list = ckalloc(sizeof(Class *));
     clsPtr->superclasses.list[0] = fPtr->objectCls;
 
     /*
@@ -1769,11 +1762,10 @@ Tcl_CopyObjectInstance(
 	    TclOORemoveFromSubclasses(cls2Ptr, superPtr);
 	}
 	if (cls2Ptr->superclasses.num) {
-	    cls2Ptr->superclasses.list = (Class **)
-		    ckrealloc((char *) cls2Ptr->superclasses.list,
+	    cls2Ptr->superclasses.list = ckrealloc(cls2Ptr->superclasses.list,
 		    sizeof(Class *) * clsPtr->superclasses.num);
 	} else {
-	    cls2Ptr->superclasses.list = (Class **)
+	    cls2Ptr->superclasses.list =
 		    ckalloc(sizeof(Class *) * clsPtr->superclasses.num);
 	}
 	memcpy(cls2Ptr->superclasses.list, clsPtr->superclasses.list,
@@ -1801,7 +1793,7 @@ Tcl_CopyObjectInstance(
 	    TclOORemoveFromMixinSubs(cls2Ptr, mixinPtr);
 	}
 	if (cls2Ptr->mixins.num != 0) {
-	    ckfree((char *) clsPtr->mixins.list);
+	    ckfree(clsPtr->mixins.list);
 	}
 	DUPLICATE(cls2Ptr->mixins, clsPtr->mixins, Class *);
 	FOREACH(mixinPtr, cls2Ptr->mixins) {
@@ -2012,7 +2004,7 @@ Tcl_ClassSetMetadata(
 	if (metadata == NULL) {
 	    return;
 	}
-	clsPtr->metadataPtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable));
+	clsPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(clsPtr->metadataPtr, TCL_ONE_WORD_KEYS);
     }
 
@@ -2092,7 +2084,7 @@ Tcl_ObjectSetMetadata(
 	if (metadata == NULL) {
 	    return;
 	}
-	oPtr->metadataPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+	oPtr->metadataPtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(oPtr->metadataPtr, TCL_ONE_WORD_KEYS);
     }
 
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 7e9dc29..3fee439 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -473,7 +473,7 @@ TclOO_Object_Unknown(
 	Tcl_AppendResult(interp, " or ", NULL);
     }
     Tcl_AppendResult(interp, methodNames[i], NULL);
-    ckfree((char *) methodNames);
+    ckfree(methodNames);
     Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
 	    TclGetString(objv[skip]), NULL);
     return TCL_ERROR;
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index dd64eaa..1e8d1a3 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -131,7 +131,7 @@ TclOODeleteChainCache(
 	}
     }
     Tcl_DeleteHashTable(tablePtr);
-    ckfree((char *) tablePtr);
+    ckfree(tablePtr);
 }
 
 /*
@@ -152,9 +152,9 @@ TclOODeleteChain(
 	return;
     }
     if (callPtr->chain != callPtr->staticChain) {
-	ckfree((char *) callPtr->chain);
+	ckfree(callPtr->chain);
     }
-    ckfree((char *) callPtr);
+    ckfree(callPtr);
 }
 
 /*
@@ -451,7 +451,7 @@ TclOOGetSortedMethodList(
 	 * heavily sorted when it is long enough to matter.
 	 */
 
-	strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
+	strings = ckalloc(sizeof(char *) * names.numEntries);
 	FOREACH_HASH(namePtr, isWanted, &names) {
 	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
 		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
@@ -472,7 +472,7 @@ TclOOGetSortedMethodList(
 	    }
 	    *stringsPtr = strings;
 	} else {
-	    ckfree((char *) strings);
+	    ckfree(strings);
 	}
     }
 
@@ -518,7 +518,7 @@ TclOOGetSortedClassMethodList(
 	 * heavily sorted when it is long enough to matter.
 	 */
 
-	strings = (const char **) ckalloc(sizeof(char *) * names.numEntries);
+	strings = ckalloc(sizeof(char *) * names.numEntries);
 	FOREACH_HASH(namePtr, isWanted, &names) {
 	    if (!(flags & PUBLIC_METHOD) || (PTR2INT(isWanted) & IN_LIST)) {
 		if (PTR2INT(isWanted) & NO_IMPLEMENTATION) {
@@ -539,7 +539,7 @@ TclOOGetSortedClassMethodList(
 	    }
 	    *stringsPtr = strings;
 	} else {
-	    ckfree((char *) strings);
+	    ckfree(strings);
 	}
     }
 
@@ -801,12 +801,12 @@ AddMethodToCallChain(
      */
 
     if (callPtr->numChain == CALL_CHAIN_STATIC_SIZE) {
-	callPtr->chain = (struct MInvoke *)
-		ckalloc(sizeof(struct MInvoke)*(callPtr->numChain+1));
+	callPtr->chain =
+		ckalloc(sizeof(struct MInvoke) * (callPtr->numChain+1));
 	memcpy(callPtr->chain, callPtr->staticChain,
 		sizeof(struct MInvoke) * callPtr->numChain);
     } else if (callPtr->numChain > CALL_CHAIN_STATIC_SIZE) {
-	callPtr->chain = (struct MInvoke *) ckrealloc((char *) callPtr->chain,
+	callPtr->chain = ckrealloc(callPtr->chain,
 		sizeof(struct MInvoke) * (callPtr->numChain + 1));
     }
     callPtr->chain[i].mPtr = mPtr;
@@ -987,7 +987,7 @@ TclOOGetCallContext(
 	doFilters = 1;
     }
 
-    callPtr = (CallChain *) ckalloc(sizeof(CallChain));
+    callPtr = ckalloc(sizeof(CallChain));
     InitCallChain(callPtr, oPtr, flags);
 
     cb.callChainPtr = callPtr;
@@ -1052,7 +1052,7 @@ TclOOGetCallContext(
 	if (hPtr == NULL) {
 	    if (oPtr->flags & USE_CLASS_CACHE) {
 		if (oPtr->selfCls->classChainCache == NULL) {
-		    oPtr->selfCls->classChainCache = (Tcl_HashTable *)
+		    oPtr->selfCls->classChainCache =
 			    ckalloc(sizeof(Tcl_HashTable));
 
 		    Tcl_InitObjHashTable(oPtr->selfCls->classChainCache);
@@ -1061,8 +1061,7 @@ TclOOGetCallContext(
 			(char *) methodNameObj, &i);
 	    } else {
 		if (oPtr->chainCache == NULL) {
-		    oPtr->chainCache = (Tcl_HashTable *)
-			    ckalloc(sizeof(Tcl_HashTable));
+		    oPtr->chainCache = ckalloc(sizeof(Tcl_HashTable));
 
 		    Tcl_InitObjHashTable(oPtr->chainCache);
 		}
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index c420239..8d8eb85 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -129,7 +129,7 @@ TclOOObjectSetFilters(
 	 * No list of filters was supplied, so we're deleting filters.
 	 */
 
-	ckfree((char *) oPtr->filters.list);
+	ckfree(oPtr->filters.list);
 	oPtr->filters.list = NULL;
 	oPtr->filters.num = 0;
 	RecomputeClassCacheFlag(oPtr);
@@ -142,10 +142,9 @@ TclOOObjectSetFilters(
 	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */
 
 	if (oPtr->filters.num == 0) {
-	    filtersList = (Tcl_Obj **) ckalloc(size);
+	    filtersList = ckalloc(size);
 	} else {
-	    filtersList = (Tcl_Obj **)
-		    ckrealloc((char *) oPtr->filters.list, size);
+	    filtersList = ckrealloc(oPtr->filters.list, size);
 	}
 	for (i=0 ; i<numFilters ; i++) {
 	    filtersList[i] = filters[i];
@@ -189,7 +188,7 @@ TclOOClassSetFilters(
 	 * No list of filters was supplied, so we're deleting filters.
 	 */
 
-	ckfree((char *) classPtr->filters.list);
+	ckfree(classPtr->filters.list);
 	classPtr->filters.list = NULL;
 	classPtr->filters.num = 0;
     } else {
@@ -201,10 +200,9 @@ TclOOClassSetFilters(
 	int size = sizeof(Tcl_Obj *) * numFilters;	/* should be size_t */
 
 	if (classPtr->filters.num == 0) {
-	    filtersList = (Tcl_Obj **) ckalloc(size);
+	    filtersList = ckalloc(size);
 	} else {
-	    filtersList = (Tcl_Obj **)
-		    ckrealloc((char *) classPtr->filters.list, size);
+	    filtersList = ckrealloc(classPtr->filters.list, size);
 	}
 	for (i=0 ; i<numFilters ; i++) {
 	    filtersList[i] = filters[i];
@@ -244,7 +242,7 @@ TclOOObjectSetMixins(
 	    FOREACH(mixinPtr, oPtr->mixins) {
 		TclOORemoveFromInstances(oPtr, mixinPtr);
 	    }
-	    ckfree((char *) oPtr->mixins.list);
+	    ckfree(oPtr->mixins.list);
 	    oPtr->mixins.num = 0;
 	}
 	RecomputeClassCacheFlag(oPtr);
@@ -255,12 +253,10 @@ TclOOObjectSetMixins(
 		    TclOORemoveFromInstances(oPtr, mixinPtr);
 		}
 	    }
-	    oPtr->mixins.list = (Class **)
-		    ckrealloc((char *) oPtr->mixins.list,
+	    oPtr->mixins.list = ckrealloc(oPtr->mixins.list,
 		    sizeof(Class *) * numMixins);
 	} else {
-	    oPtr->mixins.list = (Class **)
-		    ckalloc(sizeof(Class *) * numMixins);
+	    oPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
 	    oPtr->flags &= ~USE_CLASS_CACHE;
 	}
 	oPtr->mixins.num = numMixins;
@@ -298,7 +294,7 @@ TclOOClassSetMixins(
 	    FOREACH(mixinPtr, classPtr->mixins) {
 		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
 	    }
-	    ckfree((char *) classPtr->mixins.list);
+	    ckfree(classPtr->mixins.list);
 	    classPtr->mixins.num = 0;
 	}
     } else {
@@ -306,12 +302,10 @@ TclOOClassSetMixins(
 	    FOREACH(mixinPtr, classPtr->mixins) {
 		TclOORemoveFromMixinSubs(classPtr, mixinPtr);
 	    }
-	    classPtr->mixins.list = (Class **)
-		    ckrealloc((char *) classPtr->mixins.list,
+	    classPtr->mixins.list = ckrealloc(classPtr->mixins.list,
 		    sizeof(Class *) * numMixins);
 	} else {
-	    classPtr->mixins.list = (Class **)
-		    ckalloc(sizeof(Class *) * numMixins);
+	    classPtr->mixins.list = ckalloc(sizeof(Class *) * numMixins);
 	}
 	classPtr->mixins.num = numMixins;
 	memcpy(classPtr->mixins.list, mixins, sizeof(Class *) * numMixins);
@@ -1333,8 +1327,7 @@ TclOODefineExportObjCmd(
 
 	if (isInstanceExport) {
 	    if (!oPtr->methodsPtr) {
-		oPtr->methodsPtr = (Tcl_HashTable *)
-			ckalloc(sizeof(Tcl_HashTable));
+		oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
 		Tcl_InitObjHashTable(oPtr->methodsPtr);
 		oPtr->flags &= ~USE_CLASS_CACHE;
 	    }
@@ -1346,7 +1339,7 @@ TclOODefineExportObjCmd(
 	}
 
 	if (isNew) {
-	    mPtr = (Method *) ckalloc(sizeof(Method));
+	    mPtr = ckalloc(sizeof(Method));
 	    memset(mPtr, 0, sizeof(Method));
 	    mPtr->refCount = 1;
 	    mPtr->namePtr = objv[i];
@@ -1686,7 +1679,7 @@ TclOODefineSuperclassObjCmd(
      * Allocate some working space.
      */
 
-    superclasses = (Class **) ckalloc(sizeof(Class *) * (objc-1));
+    superclasses = ckalloc(sizeof(Class *) * (objc-1));
 
     /*
      * Parse the arguments to get the class to use as superclasses.
@@ -1710,7 +1703,7 @@ TclOODefineSuperclassObjCmd(
 	    Tcl_AppendResult(interp,
 		    "attempt to form circular dependency graph", NULL);
 	failedAfterAlloc:
-	    ckfree((char *) superclasses);
+	    ckfree(superclasses);
 	    return TCL_ERROR;
 	}
 	superclasses[i] = clsPtr;
@@ -1727,7 +1720,7 @@ TclOODefineSuperclassObjCmd(
 	FOREACH(superPtr, oPtr->classPtr->superclasses) {
 	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
 	}
-	ckfree((char *) oPtr->classPtr->superclasses.list);
+	ckfree(oPtr->classPtr->superclasses.list);
     }
     oPtr->classPtr->superclasses.list = superclasses;
     oPtr->classPtr->superclasses.num = objc-1;
@@ -1790,8 +1783,7 @@ TclOODefineUnexportObjCmd(
 
 	if (isInstanceUnexport) {
 	    if (!oPtr->methodsPtr) {
-		oPtr->methodsPtr = (Tcl_HashTable *)
-			ckalloc(sizeof(Tcl_HashTable));
+		oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
 		Tcl_InitObjHashTable(oPtr->methodsPtr);
 		oPtr->flags &= ~USE_CLASS_CACHE;
 	    }
@@ -1803,7 +1795,7 @@ TclOODefineUnexportObjCmd(
 	}
 
 	if (isNew) {
-	    mPtr = (Method *) ckalloc(sizeof(Method));
+	    mPtr = ckalloc(sizeof(Method));
 	    memset(mPtr, 0, sizeof(Method));
 	    mPtr->refCount = 1;
 	    mPtr->namePtr = objv[i];
@@ -1887,13 +1879,13 @@ TclOODefineVariablesObjCmd(
 	}
 	if (i != objc-1) {
 	    if (objc == 1) {
-		ckfree((char *) oPtr->classPtr->variables.list);
+		ckfree(oPtr->classPtr->variables.list);
 	    } else if (i) {
-		oPtr->classPtr->variables.list = (Tcl_Obj **)
-			ckrealloc((char *) oPtr->classPtr->variables.list,
+		oPtr->classPtr->variables.list =
+			ckrealloc(oPtr->classPtr->variables.list,
 			sizeof(Tcl_Obj *) * (objc-1));
 	    } else {
-		oPtr->classPtr->variables.list = (Tcl_Obj **)
+		oPtr->classPtr->variables.list =
 			ckalloc(sizeof(Tcl_Obj *) * (objc-1));
 	    }
 	}
@@ -1908,13 +1900,12 @@ TclOODefineVariablesObjCmd(
 	}
 	if (i != objc-1) {
 	    if (objc == 1) {
-		ckfree((char *) oPtr->variables.list);
+		ckfree(oPtr->variables.list);
 	    } else if (i) {
-		oPtr->variables.list = (Tcl_Obj **)
-			ckrealloc((char *) oPtr->variables.list,
+		oPtr->variables.list = ckrealloc(oPtr->variables.list,
 			sizeof(Tcl_Obj *) * (objc-1));
 	    } else {
-		oPtr->variables.list = (Tcl_Obj **)
+		oPtr->variables.list =
 			ckalloc(sizeof(Tcl_Obj *) * (objc-1));
 	    }
 	}
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 15b8dca..2cd7cc3 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -603,7 +603,7 @@ InfoObjectMethodsCmd(
 		    Tcl_NewStringObj(names[i], -1));
 	}
 	if (numNames > 0) {
-	    ckfree((char *) names);
+	    ckfree(names);
 	}
     } else if (oPtr->methodsPtr) {
 	FOREACH_HASH(namePtr, mPtr, oPtr->methodsPtr) {
@@ -1221,7 +1221,7 @@ InfoClassMethodsCmd(
 		    Tcl_NewStringObj(names[i], -1));
 	}
 	if (numNames > 0) {
-	    ckfree((char *) names);
+	    ckfree(names);
 	}
     } else {
 	FOREACH_HASH_DECLS;
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 4f29337..112d663 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -157,19 +157,19 @@ Tcl_NewInstanceMethod(
     int isNew;
 
     if (nameObj == NULL) {
-	mPtr = (Method *) ckalloc(sizeof(Method));
+	mPtr = ckalloc(sizeof(Method));
 	mPtr->namePtr = NULL;
 	mPtr->refCount = 1;
 	goto populate;
     }
     if (!oPtr->methodsPtr) {
-	oPtr->methodsPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+	oPtr->methodsPtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitObjHashTable(oPtr->methodsPtr);
 	oPtr->flags &= ~USE_CLASS_CACHE;
     }
     hPtr = Tcl_CreateHashEntry(oPtr->methodsPtr, (char *) nameObj, &isNew);
     if (isNew) {
-	mPtr = (Method *) ckalloc(sizeof(Method));
+	mPtr = ckalloc(sizeof(Method));
 	mPtr->namePtr = nameObj;
 	mPtr->refCount = 1;
 	Tcl_IncrRefCount(nameObj);
@@ -225,14 +225,14 @@ Tcl_NewMethod(
     int isNew;
 
     if (nameObj == NULL) {
-	mPtr = (Method *) ckalloc(sizeof(Method));
+	mPtr = ckalloc(sizeof(Method));
 	mPtr->namePtr = NULL;
 	mPtr->refCount = 1;
 	goto populate;
     }
     hPtr = Tcl_CreateHashEntry(&clsPtr->classMethods, (char *)nameObj,&isNew);
     if (isNew) {
-	mPtr = (Method *) ckalloc(sizeof(Method));
+	mPtr = ckalloc(sizeof(Method));
 	mPtr->refCount = 1;
 	mPtr->namePtr = nameObj;
 	Tcl_IncrRefCount(nameObj);
@@ -280,7 +280,7 @@ TclOODelMethodRef(
 	    Tcl_DecrRefCount(mPtr->namePtr);
 	}
 
-	ckfree((char *) mPtr);
+	ckfree(mPtr);
     }
 }
 
@@ -344,7 +344,7 @@ TclOONewProcInstanceMethod(
     if (Tcl_ListObjLength(interp, argsObj, &argsLen) != TCL_OK) {
 	return NULL;
     }
-    pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
+    pmPtr = ckalloc(sizeof(ProcedureMethod));
     memset(pmPtr, 0, sizeof(ProcedureMethod));
     pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
     pmPtr->flags = flags & USE_DECLARER_NS;
@@ -353,7 +353,7 @@ TclOONewProcInstanceMethod(
     method = TclOOMakeProcInstanceMethod(interp, oPtr, flags, nameObj,
 	    argsObj, bodyObj, &procMethodType, pmPtr, &pmPtr->procPtr);
     if (method == NULL) {
-	ckfree((char *) pmPtr);
+	ckfree(pmPtr);
     } else if (pmPtrPtr != NULL) {
 	*pmPtrPtr = pmPtr;
     }
@@ -405,7 +405,7 @@ TclOONewProcMethod(
 	procName = (nameObj==NULL ? "<constructor>" : TclGetString(nameObj));
     }
 
-    pmPtr = (ProcedureMethod *) ckalloc(sizeof(ProcedureMethod));
+    pmPtr = ckalloc(sizeof(ProcedureMethod));
     memset(pmPtr, 0, sizeof(ProcedureMethod));
     pmPtr->version = TCLOO_PROCEDURE_METHOD_VERSION;
     pmPtr->flags = flags & USE_DECLARER_NS;
@@ -418,7 +418,7 @@ TclOONewProcMethod(
 	Tcl_DecrRefCount(argsObj);
     }
     if (method == NULL) {
-	ckfree((char *) pmPtr);
+	ckfree(pmPtr);
     } else if (pmPtrPtr != NULL) {
 	*pmPtrPtr = pmPtr;
     }
@@ -499,12 +499,12 @@ TclOOMakeProcInstanceMethod(
 	    if (context.line
 		    && (context.nline >= 4) && (context.line[3] >= 0)) {
 		int isNew;
-		CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+		CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
 		Tcl_HashEntry *hPtr;
 
 		cfPtr->level = -1;
 		cfPtr->type = context.type;
-		cfPtr->line = (int *) ckalloc(sizeof(int));
+		cfPtr->line = ckalloc(sizeof(int));
 		cfPtr->line[0] = context.line[3];
 		cfPtr->nline = 1;
 		cfPtr->framePtr = NULL;
@@ -612,12 +612,12 @@ TclOOMakeProcMethod(
 	    if (context.line
 		    && (context.nline >= 4) && (context.line[3] >= 0)) {
 		int isNew;
-		CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+		CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
 		Tcl_HashEntry *hPtr;
 
 		cfPtr->level = -1;
 		cfPtr->type = context.type;
-		cfPtr->line = (int *) ckalloc(sizeof(int));
+		cfPtr->line = ckalloc(sizeof(int));
 		cfPtr->line[0] = context.line[3];
 		cfPtr->nline = 1;
 		cfPtr->framePtr = NULL;
@@ -1082,7 +1082,7 @@ ProcedureMethodCompiledVarDelete(
 	TclCleanupVar((Var *) infoPtr->cachedObjectVar, NULL);
     }
     Tcl_DecrRefCount(infoPtr->variableObj);
-    ckfree((char *) infoPtr);
+    ckfree(infoPtr);
 }
 
 static int
@@ -1107,7 +1107,7 @@ ProcedureMethodCompiledVarResolver(
 	return TCL_CONTINUE;
     }
 
-    infoPtr = (OOResVarInfo *) ckalloc(sizeof(OOResVarInfo));
+    infoPtr = ckalloc(sizeof(OOResVarInfo));
     infoPtr->info.fetchProc = ProcedureMethodCompiledVarConnect;
     infoPtr->info.deleteProc = ProcedureMethodCompiledVarDelete;
     infoPtr->cachedObjectVar = NULL;
@@ -1278,7 +1278,7 @@ DeleteProcedureMethodRecord(
     if (pmPtr->deleteClientdataProc) {
 	pmPtr->deleteClientdataProc(pmPtr->clientData);
     }
-    ckfree((char *) pmPtr);
+    ckfree(pmPtr);
 }
 
 static void
@@ -1299,8 +1299,7 @@ CloneProcedureMethod(
     ClientData *newClientData)
 {
     ProcedureMethod *pmPtr = clientData;
-    ProcedureMethod *pm2Ptr = (ProcedureMethod *)
-	    ckalloc(sizeof(ProcedureMethod));
+    ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod));
 
     memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod));
     pm2Ptr->refCount = 1;
@@ -1344,7 +1343,7 @@ TclOONewForwardInstanceMethod(
 	return NULL;
     }
 
-    fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+    fmPtr = ckalloc(sizeof(ForwardMethod));
     fmPtr->prefixObj = prefixObj;
     Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
     fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0);
@@ -1385,7 +1384,7 @@ TclOONewForwardMethod(
 	return NULL;
     }
 
-    fmPtr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+    fmPtr = ckalloc(sizeof(ForwardMethod));
     fmPtr->prefixObj = prefixObj;
     Tcl_ListObjIndex(interp, prefixObj, 0, &cmdObj);
     fmPtr->fullyQualified = (strncmp(TclGetString(cmdObj), "::", 2) == 0);
@@ -1469,7 +1468,7 @@ DeleteForwardMethod(
     ForwardMethod *fmPtr = clientData;
 
     Tcl_DecrRefCount(fmPtr->prefixObj);
-    ckfree((char *) fmPtr);
+    ckfree(fmPtr);
 }
 
 static int
@@ -1479,7 +1478,7 @@ CloneForwardMethod(
     ClientData *newClientData)
 {
     ForwardMethod *fmPtr = clientData;
-    ForwardMethod *fm2Ptr = (ForwardMethod *) ckalloc(sizeof(ForwardMethod));
+    ForwardMethod *fm2Ptr = ckalloc(sizeof(ForwardMethod));
 
     fm2Ptr->prefixObj = fmPtr->prefixObj;
     fm2Ptr->fullyQualified = fmPtr->fullyQualified;
diff --git a/generic/tclObj.c b/generic/tclObj.c
index ad48ad1..3bc6f12 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -458,12 +458,12 @@ TclFinalizeThreadObjects(void)
 	    ObjData *objData = Tcl_GetHashValue(hPtr);
 
 	    if (objData != NULL) {
-		ckfree((char *) objData);
+		ckfree(objData);
 	    }
 	}
 
 	Tcl_DeleteHashTable(tablePtr);
-	ckfree((char *) tablePtr);
+	ckfree(tablePtr);
 	tsdPtr->objThreadMap = NULL;
     }
 #endif
@@ -539,7 +539,7 @@ TclGetContLineTable(void)
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
     if (!tsdPtr->lineCLPtr) {
-	tsdPtr->lineCLPtr = (Tcl_HashTable *) ckalloc(sizeof(Tcl_HashTable));
+	tsdPtr->lineCLPtr = ckalloc(sizeof(Tcl_HashTable));
 	Tcl_InitHashTable(tsdPtr->lineCLPtr, TCL_ONE_WORD_KEYS);
 	Tcl_CreateThreadExitHandler(TclThreadFinalizeContLines,NULL);
     }
@@ -574,8 +574,7 @@ TclContinuationsEnter(
     ThreadSpecificData *tsdPtr = TclGetContLineTable();
     Tcl_HashEntry *hPtr =
 	    Tcl_CreateHashEntry(tsdPtr->lineCLPtr, objPtr, &newEntry);
-    ContLineLoc *clLocPtr = (ContLineLoc *)
-            ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
+    ContLineLoc *clLocPtr = ckalloc(sizeof(ContLineLoc) + num*sizeof(int));
 
     if (!newEntry) {
 	/*
@@ -814,7 +813,7 @@ TclThreadFinalizeContLines(
 	Tcl_DeleteHashEntry(hPtr);
     }
     Tcl_DeleteHashTable(tsdPtr->lineCLPtr);
-    ckfree((char *) tsdPtr->lineCLPtr);
+    ckfree(tsdPtr->lineCLPtr);
     tsdPtr->lineCLPtr = NULL;
 }
 
@@ -1104,8 +1103,7 @@ TclDbInitNewObj(
 	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
 	if (tsdPtr->objThreadMap == NULL) {
-	    tsdPtr->objThreadMap = (Tcl_HashTable *)
-		    ckalloc(sizeof(Tcl_HashTable));
+	    tsdPtr->objThreadMap = ckalloc(sizeof(Tcl_HashTable));
 	    Tcl_InitHashTable(tsdPtr->objThreadMap, TCL_ONE_WORD_KEYS);
 	}
 	tablePtr = tsdPtr->objThreadMap;
@@ -1118,7 +1116,7 @@ TclDbInitNewObj(
 	 * Record the debugging information.
 	 */
 
-	objData = (ObjData *) ckalloc(sizeof(ObjData));
+	objData = ckalloc(sizeof(ObjData));
 	objData->objPtr = objPtr;
 	objData->file = file;
 	objData->line = line;
@@ -1277,7 +1275,7 @@ TclAllocateFreeObjects(void)
      * Purify apparently can't figure that out, and fires a false alarm.
      */
 
-    basePtr = (char *) ckalloc(bytesToAlloc);
+    basePtr = ckalloc(bytesToAlloc);
 
     prevPtr = NULL;
     objPtr = (Tcl_Obj *) basePtr;
@@ -1351,7 +1349,7 @@ TclFreeObj(
 	}
 
 	Tcl_MutexLock(&tclObjMutex);
-	ckfree((char *) objPtr);
+	ckfree(objPtr);
 	Tcl_MutexUnlock(&tclObjMutex);
 	TclIncrObjsFreed();
 	ObjDeletionLock(context);
@@ -1363,7 +1361,7 @@ TclFreeObj(
 	    TclFreeIntRep(objToFree);
 
 	    Tcl_MutexLock(&tclObjMutex);
-	    ckfree((char *) objToFree);
+	    ckfree(objToFree);
 	    Tcl_MutexUnlock(&tclObjMutex);
 	    TclIncrObjsFreed();
 	}
@@ -2350,7 +2348,7 @@ UpdateStringOfDouble(
     Tcl_PrintDouble(NULL, objPtr->internalRep.doubleValue, buffer);
     len = strlen(buffer);
 
-    objPtr->bytes = (char *) ckalloc((unsigned) len + 1);
+    objPtr->bytes = ckalloc(len + 1);
     memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
     objPtr->length = len;
 }
@@ -2546,7 +2544,7 @@ UpdateStringOfInt(
 
     len = TclFormatInt(buffer, objPtr->internalRep.longValue);
 
-    objPtr->bytes = ckalloc((unsigned) len + 1);
+    objPtr->bytes = ckalloc(len + 1);
     memcpy(objPtr->bytes, buffer, (unsigned) len + 1);
     objPtr->length = len;
 }
@@ -2852,7 +2850,7 @@ UpdateStringOfWideInt(
 
     sprintf(buffer, "%" TCL_LL_MODIFIER "d", wideVal);
     len = strlen(buffer);
-    objPtr->bytes = ckalloc((unsigned) len + 1);
+    objPtr->bytes = ckalloc(len + 1);
     memcpy(objPtr->bytes, buffer, len + 1);
     objPtr->length = len;
 }
@@ -3164,7 +3162,7 @@ FreeBignum(
     UNPACK_BIGNUM(objPtr, toFree);
     mp_clear(&toFree);
     if ((long) objPtr->internalRep.ptrAndLongRep.value < 0) {
-	ckfree((char *) objPtr->internalRep.ptrAndLongRep.ptr);
+	ckfree(objPtr->internalRep.ptrAndLongRep.ptr);
     }
     objPtr->typePtr = NULL;
 }
@@ -3249,7 +3247,7 @@ UpdateStringOfBignum(
 
 	Tcl_Panic("UpdateStringOfBignum: string length limit exceeded");
     }
-    stringVal = ckalloc((size_t) size);
+    stringVal = ckalloc(size);
     status = mp_toradix_n(&bignumVal, stringVal, 10, size);
     if (status != MP_OKAY) {
 	Tcl_Panic("conversion failure in UpdateStringOfBignum");
@@ -3797,7 +3795,7 @@ Tcl_DbDecrRefCount(
 	    ObjData *objData = Tcl_GetHashValue(hPtr);
 
 	    if (objData != NULL) {
-		ckfree((char *) objData);
+		ckfree(objData);
 	    }
 
 	    Tcl_DeleteHashEntry(hPtr);
@@ -3935,11 +3933,10 @@ AllocObjEntry(
     Tcl_HashTable *tablePtr,	/* Hash table. */
     void *keyPtr)		/* Key to store in the hash table entry. */
 {
-    Tcl_Obj *objPtr = (Tcl_Obj *) keyPtr;
-    Tcl_HashEntry *hPtr;
+    Tcl_Obj *objPtr = keyPtr;
+    Tcl_HashEntry *hPtr = ckalloc(sizeof(Tcl_HashEntry));
 
-    hPtr = (Tcl_HashEntry *) ckalloc((unsigned) (sizeof(Tcl_HashEntry)));
-    hPtr->key.oneWordValue = (char *) objPtr;
+    hPtr->key.objPtr = objPtr;
     Tcl_IncrRefCount(objPtr);
     hPtr->clientData = NULL;
 
@@ -4032,7 +4029,7 @@ TclFreeObjEntry(
     Tcl_Obj *objPtr = (Tcl_Obj *) hPtr->key.oneWordValue;
 
     Tcl_DecrRefCount(objPtr);
-    ckfree((char *) hPtr);
+    ckfree(hPtr);
 }
 
 /*
@@ -4227,7 +4224,7 @@ TclSetCmdNameObj(
     }
 
     cmdPtr->refCount++;
-    resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+    resPtr = ckalloc(sizeof(ResolvedCmdName));
     resPtr->cmdPtr = cmdPtr;
     resPtr->cmdEpoch = cmdPtr->cmdEpoch;
     resPtr->refCount = 1;
@@ -4303,7 +4300,7 @@ FreeCmdNameInternalRep(
 	    Command *cmdPtr = resPtr->cmdPtr;
 
 	    TclCleanupCommandMacro(cmdPtr);
-	    ckfree((char *) resPtr);
+	    ckfree(resPtr);
 	}
     }
     objPtr->typePtr = NULL;
@@ -4410,7 +4407,7 @@ SetCmdNameFromAny(
 	    }
 	} else {
 	    TclFreeIntRep(objPtr);
-	    resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
+	    resPtr = ckalloc(sizeof(ResolvedCmdName));
 	    resPtr->refCount = 1;
 	    objPtr->internalRep.twoPtrValue.ptr1 = resPtr;
 	    objPtr->internalRep.twoPtrValue.ptr2 = NULL;
diff --git a/generic/tclParse.c b/generic/tclParse.c
index ff7cdd6..3650677 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -1280,7 +1280,7 @@ Tcl_FreeParse(
 				 * call to Tcl_ParseCommand. */
 {
     if (parsePtr->tokenPtr != parsePtr->staticTokens) {
-	ckfree((char *) parsePtr->tokenPtr);
+	ckfree(parsePtr->tokenPtr);
 	parsePtr->tokenPtr = parsePtr->staticTokens;
     }
 }
@@ -2154,7 +2154,7 @@ TclSubstTokens(
 
     if (isLiteral) {
 	maxNumCL = NUM_STATIC_POS;
-	clPosition = (int *) ckalloc(maxNumCL * sizeof(int));
+	clPosition = ckalloc(maxNumCL * sizeof(int));
     }
 
     adjust = 0;
@@ -2204,7 +2204,7 @@ TclSubstTokens(
 
 		    if (numCL >= maxNumCL) {
 			maxNumCL *= 2;
-			clPosition = (int *) ckrealloc((char *) clPosition,
+			clPosition = ckrealloc(clPosition,
 				maxNumCL * sizeof(int));
 		    }
 		    clPosition[numCL] = clPos;
@@ -2362,7 +2362,7 @@ TclSubstTokens(
 	     */
 
 	    if (maxNumCL) {
-		ckfree((char *) clPosition);
+		ckfree(clPosition);
 	    }
 	} else {
 	    Tcl_ResetResult(interp);
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index bd1515a..81007a2 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -1299,7 +1299,7 @@ TclNewFSPathObj(
     tsdPtr = TCL_TSD_INIT(&tclFsDataKey);
 
     pathPtr = Tcl_NewObj();
-    fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+    fsPathPtr = ckalloc(sizeof(FsPath));
 
     /*
      * Set up the path.
@@ -1531,7 +1531,7 @@ TclFSMakePathFromNormalized(
 	TclFreeIntRep(pathPtr);
     }
 
-    fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+    fsPathPtr = ckalloc(sizeof(FsPath));
 
     /*
      * It's a pure normalized absolute path.
@@ -1613,7 +1613,7 @@ Tcl_FSNewNativePath(
 	TclFreeIntRep(pathPtr);
     }
 
-    fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+    fsPathPtr = ckalloc(sizeof(FsPath));
 
     fsPathPtr->translatedPathPtr = NULL;
 
@@ -1738,7 +1738,7 @@ Tcl_FSGetTranslatedStringPath(
     if (transPtr != NULL) {
 	int len;
 	const char *orig = Tcl_GetStringFromObj(transPtr, &len);
-	char *result = ckalloc((unsigned) len+1);
+	char *result = ckalloc(len+1);
 
 	memcpy(result, orig, (size_t) len+1);
 	TclDecrRefCount(transPtr);
@@ -2532,7 +2532,7 @@ SetFsPathFromAny(
      * slashes on Windows, and will not contain any ~user sequences.
      */
 
-    fsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+    fsPathPtr = ckalloc(sizeof(FsPath));
 
     fsPathPtr->translatedPathPtr = transPtr;
     if (transPtr != pathPtr) {
@@ -2597,11 +2597,11 @@ FreeFsPathInternalRep(
 	     * It has been unregistered already.
 	     */
 
-	    ckfree((char *) fsPathPtr->fsRecPtr);
+	    ckfree(fsPathPtr->fsRecPtr);
 	}
     }
 
-    ckfree((char *) fsPathPtr);
+    ckfree(fsPathPtr);
     pathPtr->typePtr = NULL;
 }
 
@@ -2611,7 +2611,7 @@ DupFsPathInternalRep(
     Tcl_Obj *copyPtr)		/* Path obj with internal rep to set. */
 {
     FsPath *srcFsPathPtr = PATHOBJ(srcPtr);
-    FsPath *copyFsPathPtr = (FsPath *) ckalloc(sizeof(FsPath));
+    FsPath *copyFsPathPtr = ckalloc(sizeof(FsPath));
 
     SETPATHOBJ(copyPtr, copyFsPathPtr);
 
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index ad48f03..c24d136 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -183,7 +183,7 @@ Tcl_DetachPids(
 
     Tcl_MutexLock(&pipeMutex);
     for (i = 0; i < numPids; i++) {
-	detPtr = (Detached *) ckalloc(sizeof(Detached));
+	detPtr = ckalloc(sizeof(Detached));
 	detPtr->pid = pidPtr[i];
 	detPtr->nextPtr = detList;
 	detList = detPtr;
@@ -233,7 +233,7 @@ Tcl_ReapDetachedProcs(void)
 	} else {
 	    prevPtr->nextPtr = detPtr->nextPtr;
 	}
-	ckfree((char *) detPtr);
+	ckfree(detPtr);
 	detPtr = nextPtr;
     }
     Tcl_MutexUnlock(&pipeMutex);
@@ -835,7 +835,7 @@ TclCreatePipeline(
      */
 
     Tcl_ReapDetachedProcs();
-    pidPtr = (Tcl_Pid *) ckalloc((unsigned) (cmdCount * sizeof(Tcl_Pid)));
+    pidPtr = ckalloc(cmdCount * sizeof(Tcl_Pid));
 
     curInFile = inputFile;
 
@@ -988,7 +988,7 @@ TclCreatePipeline(
 		Tcl_DetachPids(1, &pidPtr[i]);
 	    }
 	}
-	ckfree((char *) pidPtr);
+	ckfree(pidPtr);
     }
     numPids = -1;
     goto cleanup;
@@ -1085,7 +1085,7 @@ Tcl_OpenCommandChannel(
   error:
     if (numPids > 0) {
 	Tcl_DetachPids(numPids, pidPtr);
-	ckfree((char *) pidPtr);
+	ckfree(pidPtr);
     }
     if (inPipe != NULL) {
 	TclpCloseFile(inPipe);
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 1f1410f..53be4af 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -791,9 +791,9 @@ Tcl_PackageObjCmd(
 		pkgPtr->availPtr = availPtr->nextPtr;
 		Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
 		Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
-		ckfree((char *) availPtr);
+		ckfree(availPtr);
 	    }
-	    ckfree((char *) pkgPtr);
+	    ckfree(pkgPtr);
 	}
 	break;
     }
@@ -849,7 +849,7 @@ Tcl_PackageObjCmd(
 	    return TCL_OK;
 	}
 	if (availPtr == NULL) {
-	    availPtr = (PkgAvail *) ckalloc(sizeof(PkgAvail));
+	    availPtr = ckalloc(sizeof(PkgAvail));
 	    DupBlock(availPtr->version, argv3, (unsigned) length + 1);
 
 	    if (prevPtr == NULL) {
@@ -1154,7 +1154,7 @@ FindPackage(
 
     hPtr = Tcl_CreateHashEntry(&iPtr->packageTable, name, &isNew);
     if (isNew) {
-	pkgPtr = (Package *) ckalloc(sizeof(Package));
+	pkgPtr = ckalloc(sizeof(Package));
 	pkgPtr->version = NULL;
 	pkgPtr->availPtr = NULL;
 	pkgPtr->clientData = NULL;
@@ -1202,9 +1202,9 @@ TclFreePackageInfo(
 	    pkgPtr->availPtr = availPtr->nextPtr;
 	    Tcl_EventuallyFree(availPtr->version, TCL_DYNAMIC);
 	    Tcl_EventuallyFree(availPtr->script, TCL_DYNAMIC);
-	    ckfree((char *) availPtr);
+	    ckfree(availPtr);
 	}
-	ckfree((char *) pkgPtr);
+	ckfree(pkgPtr);
     }
     Tcl_DeleteHashTable(&iPtr->packageTable);
     if (iPtr->packageUnknown != NULL) {
diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c
index a6c24f7..cbd7b63 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -89,7 +89,7 @@ TclFinalizePreserve(void)
 {
     Tcl_MutexLock(&preserveMutex);
     if (spaceAvl != 0) {
-	ckfree((char *) refArray);
+	ckfree(refArray);
 	refArray = NULL;
 	inUse = 0;
 	spaceAvl = 0;
@@ -144,8 +144,7 @@ Tcl_Preserve(
 
     if (inUse == spaceAvl) {
 	spaceAvl = spaceAvl ? 2*spaceAvl : INITIAL_SIZE;
-	refArray = (Reference *) ckrealloc((char *) refArray,
-		spaceAvl * sizeof(Reference));
+	refArray = ckrealloc(refArray, spaceAvl * sizeof(Reference));
     }
 
     /*
@@ -225,9 +224,9 @@ Tcl_Release(
 	Tcl_MutexUnlock(&preserveMutex);
 	if (mustFree) {
 	    if (freeProc == TCL_DYNAMIC) {
-		ckfree((char *) clientData);
+		ckfree(clientData);
 	    } else {
-		freeProc((char *) clientData);
+		freeProc(clientData);
 	    }
 	}
 	return;
@@ -292,9 +291,9 @@ Tcl_EventuallyFree(
      */
 
     if (freeProc == TCL_DYNAMIC) {
-	ckfree((char *) clientData);
+	ckfree(clientData);
     } else {
-	freeProc((char *)clientData);
+	freeProc(clientData);
     }
 }
 
@@ -328,9 +327,8 @@ TclHandleCreate(
 				 * be tracked for deletion. Must not be
 				 * NULL. */
 {
-    HandleStruct *handlePtr;
+    HandleStruct *handlePtr = ckalloc(sizeof(HandleStruct));
 
-    handlePtr = (HandleStruct *) ckalloc(sizeof(HandleStruct));
     handlePtr->ptr = ptr;
 #ifdef TCL_MEM_DEBUG
     handlePtr->ptr2 = ptr;
@@ -379,7 +377,7 @@ TclHandleFree(
 #endif
     handlePtr->ptr = NULL;
     if (handlePtr->refCount == 0) {
-	ckfree((char *) handlePtr);
+	ckfree(handlePtr);
     }
 }
 
@@ -463,7 +461,7 @@ TclHandleRelease(
 #endif
     handlePtr->refCount--;
     if ((handlePtr->refCount == 0) && (handlePtr->ptr == NULL)) {
-	ckfree((char *) handlePtr);
+	ckfree(handlePtr);
     }
 }
 
diff --git a/generic/tclProc.c b/generic/tclProc.c
index bf46a5d..a4309b6 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -253,11 +253,11 @@ Tcl_ProcObjCmd(
 		    && (contextPtr->nline >= 4) && (contextPtr->line[3] >= 0)) {
 		int isNew;
 		Tcl_HashEntry *hePtr;
-		CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+		CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
 
 		cfPtr->level = -1;
 		cfPtr->type = contextPtr->type;
-		cfPtr->line = (int *) ckalloc(sizeof(int));
+		cfPtr->line = ckalloc(sizeof(int));
 		cfPtr->line[0] = contextPtr->line[3];
 		cfPtr->nline = 1;
 		cfPtr->framePtr = NULL;
@@ -285,9 +285,9 @@ Tcl_ProcObjCmd(
 			Tcl_DecrRefCount(cfOldPtr->data.eval.path);
 			cfOldPtr->data.eval.path = NULL;
 		    }
-		    ckfree((char *) cfOldPtr->line);
+		    ckfree(cfOldPtr->line);
 		    cfOldPtr->line = NULL;
-		    ckfree((char *) cfOldPtr);
+		    ckfree(cfOldPtr);
 		}
 		Tcl_SetHashValue(hePtr, cfPtr);
 	    }
@@ -460,7 +460,7 @@ TclCreateProc(
 
 	Tcl_IncrRefCount(bodyPtr);
 
-	procPtr = (Proc *) ckalloc(sizeof(Proc));
+	procPtr = ckalloc(sizeof(Proc));
 	procPtr->iPtr = iPtr;
 	procPtr->refCount = 1;
 	procPtr->bodyPtr = bodyPtr;
@@ -513,14 +513,14 @@ TclCreateProc(
 	    goto procError;
 	}
 	if (fieldCount > 2) {
-	    ckfree((char *) fieldValues);
+	    ckfree(fieldValues);
 	    Tcl_AppendResult(interp,
 		    "too many fields in argument specifier \"",
 		    argArray[i], "\"", NULL);
 	    goto procError;
 	}
 	if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
-	    ckfree((char *) fieldValues);
+	    ckfree(fieldValues);
 	    Tcl_AppendResult(interp, "argument with no name", NULL);
 	    goto procError;
 	}
@@ -546,16 +546,14 @@ TclCreateProc(
 		q--;
 		if (*q == ')') {	/* We have an array element. */
 		    Tcl_AppendResult(interp, "formal parameter \"",
-			    fieldValues[0],
-			    "\" is an array element", NULL);
-		    ckfree((char *) fieldValues);
+			    fieldValues[0], "\" is an array element", NULL);
+		    ckfree(fieldValues);
 		    goto procError;
 		}
 	    } else if ((*p == ':') && (*(p+1) == ':')) {
 		Tcl_AppendResult(interp, "formal parameter \"",
-			fieldValues[0],
-			"\" is not a simple name", NULL);
-		ckfree((char *) fieldValues);
+			fieldValues[0], "\" is not a simple name", NULL);
+		ckfree(fieldValues);
 		goto procError;
 	    }
 	    p++;
@@ -582,7 +580,7 @@ TclCreateProc(
 		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 			"procedure \"%s\": formal parameter %d is "
 			"inconsistent with precompiled body", procName, i));
-		ckfree((char *) fieldValues);
+		ckfree(fieldValues);
 		goto procError;
 	    }
 
@@ -601,7 +599,7 @@ TclCreateProc(
 			    "procedure \"%s\": formal parameter \"%s\" has "
 			    "default value inconsistent with precompiled body",
 			    procName, fieldValues[0]));
-		    ckfree((char *) fieldValues);
+		    ckfree(fieldValues);
 		    goto procError;
 		}
 	    }
@@ -619,8 +617,7 @@ TclCreateProc(
 	     * local variables for the argument.
 	     */
 
-	    localPtr = (CompiledLocal *) ckalloc((unsigned)
-		    (TclOffset(CompiledLocal, name) + nameLength + 1));
+	    localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameLength+1);
 	    if (procPtr->firstLocalPtr == NULL) {
 		procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
 	    } else {
@@ -649,11 +646,11 @@ TclCreateProc(
 	    }
 	}
 
-	ckfree((char *) fieldValues);
+	ckfree(fieldValues);
     }
 
     *procPtrPtr = procPtr;
-    ckfree((char *) argArray);
+    ckfree(argArray);
     return TCL_OK;
 
   procError:
@@ -670,12 +667,12 @@ TclCreateProc(
 		Tcl_DecrRefCount(defPtr);
 	    }
 
-	    ckfree((char *) localPtr);
+	    ckfree(localPtr);
 	}
-	ckfree((char *) procPtr);
+	ckfree(procPtr);
     }
     if (argArray != NULL) {
-	ckfree((char *) argArray);
+	ckfree(argArray);
     }
     return TCL_ERROR;
 }
@@ -1247,7 +1244,7 @@ InitResolvedLocals(
 	    if (localPtr->resolveInfo->deleteProc) {
 		localPtr->resolveInfo->deleteProc(localPtr->resolveInfo);
 	    } else {
-		ckfree((char *) localPtr->resolveInfo);
+		ckfree(localPtr->resolveInfo);
 	    }
 	    localPtr->resolveInfo = NULL;
 	}
@@ -1341,7 +1338,7 @@ TclFreeLocalCache(
 	    }
 	}
     }
-    ckfree((char *) localCachePtr);
+    ckfree(localCachePtr);
 }
 
 static void
@@ -1365,9 +1362,9 @@ InitLocalCache(
      * for future calls.
      */
 
-    localCachePtr = (LocalCache *) ckalloc(sizeof(LocalCache)
-	    + (localCt-1)*sizeof(Tcl_Obj *)
-	    + numArgs*sizeof(Var));
+    localCachePtr = ckalloc(sizeof(LocalCache)
+	    + (localCt - 1) * sizeof(Tcl_Obj *)
+	    + numArgs * sizeof(Var));
 
     namePtr = &localCachePtr->varName0;
     varPtr = (Var *) (namePtr + localCt);
@@ -2045,8 +2042,9 @@ TclProcCompileProc(
 	    procPtr->lastLocalPtr = lastPtr;
 	    while (clPtr) {
 		CompiledLocal *toFree = clPtr;
+
 		clPtr = clPtr->nextPtr;
-		ckfree((char *) toFree);
+		ckfree(toFree);
 	    }
 	    procPtr->numCompiledLocals = procPtr->numArgs;
 	}
@@ -2189,7 +2187,7 @@ TclProcCleanupProc(
 	    if (resVarInfo->deleteProc) {
 		resVarInfo->deleteProc(resVarInfo);
 	    } else {
-		ckfree((char *) resVarInfo);
+		ckfree(resVarInfo);
 	    }
 	}
 
@@ -2197,10 +2195,10 @@ TclProcCleanupProc(
 	    defPtr = localPtr->defValuePtr;
 	    Tcl_DecrRefCount(defPtr);
 	}
-	ckfree((char *) localPtr);
+	ckfree(localPtr);
 	localPtr = nextPtr;
     }
-    ckfree((char *) procPtr);
+    ckfree(procPtr);
 
     /*
      * TIP #280: Release the location data associated with this Proc
@@ -2223,9 +2221,9 @@ TclProcCleanupProc(
 	Tcl_DecrRefCount(cfPtr->data.eval.path);
 	cfPtr->data.eval.path = NULL;
     }
-    ckfree((char *) cfPtr->line);
+    ckfree(cfPtr->line);
     cfPtr->line = NULL;
-    ckfree((char *) cfPtr);
+    ckfree(cfPtr);
     Tcl_DeleteHashEntry(hePtr);
 }
 
@@ -2549,7 +2547,7 @@ SetLambdaFromAny(
 	    if (contextPtr->line
 		    && (contextPtr->nline >= 2) && (contextPtr->line[1] >= 0)) {
 		int isNew, buf[2];
-		CmdFrame *cfPtr = (CmdFrame *) ckalloc(sizeof(CmdFrame));
+		CmdFrame *cfPtr = ckalloc(sizeof(CmdFrame));
 
 		/*
 		 * Move from approximation (line of list cmd word) to actual
@@ -2560,7 +2558,7 @@ SetLambdaFromAny(
 
 		cfPtr->level = -1;
 		cfPtr->type = contextPtr->type;
-		cfPtr->line = (int *) ckalloc(sizeof(int));
+		cfPtr->line = ckalloc(sizeof(int));
 		cfPtr->line[0] = buf[1];
 		cfPtr->nline = 1;
 		cfPtr->framePtr = NULL;
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index c3ff608..5c5af7b 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -905,7 +905,7 @@ CompileRegexp(
      * This is a new expression, so compile it and add it to the cache.
      */
 
-    regexpPtr = (TclRegexp *) ckalloc(sizeof(TclRegexp));
+    regexpPtr = ckalloc(sizeof(TclRegexp));
     regexpPtr->objPtr = NULL;
     regexpPtr->string = NULL;
     regexpPtr->details.rm_extend.rm_so = -1;
@@ -932,7 +932,7 @@ CompileRegexp(
 	 * Clean up and report errors in the interpreter, if possible.
 	 */
 
-	ckfree((char *)regexpPtr);
+	ckfree(regexpPtr);
 	if (interp) {
 	    TclRegError(interp,
 		    "couldn't compile regular expression pattern: ", status);
@@ -960,7 +960,7 @@ CompileRegexp(
      * the entire pattern.
      */
 
-    regexpPtr->matches = (regmatch_t *)
+    regexpPtr->matches =
 	    ckalloc(sizeof(regmatch_t) * (regexpPtr->re.re_nsub + 1));
 
     /*
@@ -987,7 +987,7 @@ CompileRegexp(
 	tsdPtr->patLengths[i+1] = tsdPtr->patLengths[i];
 	tsdPtr->regexps[i+1] = tsdPtr->regexps[i];
     }
-    tsdPtr->patterns[0] = ckalloc((unsigned) length+1);
+    tsdPtr->patterns[0] = ckalloc(length + 1);
     memcpy(tsdPtr->patterns[0], string, (unsigned) length + 1);
     tsdPtr->patLengths[0] = length;
     tsdPtr->regexps[0] = regexpPtr;
@@ -1020,9 +1020,9 @@ FreeRegexp(
 	TclDecrRefCount(regexpPtr->globObjPtr);
     }
     if (regexpPtr->matches) {
-	ckfree((char *) regexpPtr->matches);
+	ckfree(regexpPtr->matches);
     }
-    ckfree((char *) regexpPtr);
+    ckfree(regexpPtr);
 }
 
 /*
diff --git a/generic/tclResolve.c b/generic/tclResolve.c
index ba71743..974737e 100644
--- a/generic/tclResolve.c
+++ b/generic/tclResolve.c
@@ -101,9 +101,9 @@ Tcl_AddInterpResolvers(
      * list, so that it overrides existing schemes.
      */
 
-    resPtr = (ResolverScheme *) ckalloc(sizeof(ResolverScheme));
+    resPtr = ckalloc(sizeof(ResolverScheme));
     len = strlen(name) + 1;
-    resPtr->name = (char *) ckalloc(len);
+    resPtr->name = ckalloc(len);
     memcpy(resPtr->name, name, len);
     resPtr->cmdResProc = cmdProc;
     resPtr->varResProc = varProc;
@@ -226,7 +226,7 @@ Tcl_RemoveInterpResolvers(
 
 	*prevPtrPtr = resPtr->nextPtr;
 	ckfree(resPtr->name);
-	ckfree((char *) resPtr);
+	ckfree(resPtr);
 
 	return 1;
     }
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 2a04f18..fad3b82 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -75,7 +75,7 @@ Tcl_SaveInterpState(
     int status)			/* status code for current operation */
 {
     Interp *iPtr = (Interp *) interp;
-    InterpState *statePtr = (InterpState *) ckalloc(sizeof(InterpState));
+    InterpState *statePtr = ckalloc(sizeof(InterpState));
 
     statePtr->status = status;
     statePtr->flags = iPtr->flags & ERR_ALREADY_LOGGED;
@@ -205,7 +205,7 @@ Tcl_DiscardInterpState(
 	Tcl_DecrRefCount(statePtr->errorStack);
     }
     Tcl_DecrRefCount(statePtr->objResult);
-    ckfree((char *) statePtr);
+    ckfree(statePtr);
 }
 
 /*
@@ -331,7 +331,7 @@ Tcl_RestoreResult(
 	 */
 
 	if (iPtr->appendResult != NULL) {
-	    ckfree((char *) iPtr->appendResult);
+	    ckfree(iPtr->appendResult);
 	}
 
 	iPtr->appendResult = statePtr->appendResult;
@@ -428,7 +428,7 @@ Tcl_SetResult(
 	int length = strlen(result);
 
 	if (length > TCL_RESULT_SIZE) {
-	    iPtr->result = ckalloc((unsigned) length+1);
+	    iPtr->result = ckalloc(length + 1);
 	    iPtr->freeProc = TCL_DYNAMIC;
 	} else {
 	    iPtr->result = iPtr->resultSpace;
@@ -831,7 +831,7 @@ SetupAppendBuffer(
 	} else {
 	    totalSpace *= 2;
 	}
-	new = ckalloc((unsigned) totalSpace);
+	new = ckalloc(totalSpace);
 	strcpy(new, iPtr->result);
 	if (iPtr->appendResult != NULL) {
 	    ckfree(iPtr->appendResult);
@@ -983,7 +983,7 @@ ResetObjResult(
     } else {
 	if (objResultPtr->bytes != tclEmptyStringRep) {
 	    if (objResultPtr->bytes) {
-		ckfree((char *) objResultPtr->bytes);
+		ckfree(objResultPtr->bytes);
 	    }
 	    objResultPtr->bytes = tclEmptyStringRep;
 	    objResultPtr->length = 0;
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 0051415..c862be4 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -101,10 +101,9 @@ BuildCharSet(
 	end += Tcl_UtfToUniChar(end, &ch);
     }
 
-    cset->chars = (Tcl_UniChar *)
-	    ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
+    cset->chars = ckalloc(sizeof(Tcl_UniChar) * (end - format - 1));
     if (nranges > 0) {
-	cset->ranges = (struct Range *) ckalloc(sizeof(struct Range)*nranges);
+	cset->ranges = ckalloc(sizeof(struct Range) * nranges);
     } else {
 	cset->ranges = NULL;
     }
@@ -224,9 +223,9 @@ static void
 ReleaseCharSet(
     CharSet *cset)
 {
-    ckfree((char *)cset->chars);
+    ckfree(cset->chars);
     if (cset->ranges) {
-	ckfree((char *)cset->ranges);
+	ckfree(cset->ranges);
     }
 }
 
@@ -590,7 +589,7 @@ Tcl_ScanObjCmd(
      */
 
     if (totalVars > 0) {
-	objs = (Tcl_Obj **) ckalloc(sizeof(Tcl_Obj *) * totalVars);
+	objs = ckalloc(sizeof(Tcl_Obj *) * totalVars);
 	for (i = 0; i < totalVars; i++) {
 	    objs[i] = NULL;
 	}
@@ -1020,7 +1019,7 @@ Tcl_ScanObjCmd(
 	}
     }
     if (objs != NULL) {
-	ckfree((char *) objs);
+	ckfree(objs);
     }
     if (code == TCL_OK) {
 	if (underflow && (nconversions == 0)) {
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 377d44f..d4a3b4b 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -4368,8 +4368,7 @@ TclInitDoubleConversion(void)
 
     maxpow10_wide = (int)
 	    floor(sizeof(Tcl_WideUInt) * CHAR_BIT * log(2.) / log(10.));
-    pow10_wide = (Tcl_WideUInt *)
-	    ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt));
+    pow10_wide = ckalloc((maxpow10_wide + 1) * sizeof(Tcl_WideUInt));
     u = 1;
     for (i = 0; i < maxpow10_wide; ++i) {
 	pow10_wide[i] = u;
@@ -4477,7 +4476,7 @@ TclFinalizeDoubleConversion(void)
 {
     int i;
 
-    ckfree((char *) pow10_wide);
+    ckfree(pow10_wide);
     for (i=0; i<9; ++i) {
 	mp_clear(pow5 + i);
     }
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 956a9f0..7cdbb3e 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -204,7 +204,7 @@ GrowStringBuffer(
     if (flag == 0 || stringPtr->allocated > 0) {
 	attempt = 2 * needed;
 	if (attempt >= 0) {
-	    ptr = attemptckrealloc(objPtr->bytes, (unsigned) attempt + 1);
+	    ptr = attemptckrealloc(objPtr->bytes, attempt + 1);
 	}
 	if (ptr == NULL) {
 	    /*
@@ -217,7 +217,7 @@ GrowStringBuffer(
 	    int growth = (int) ((extra > limit) ? limit : extra);
 
 	    attempt = needed + growth;
-	    ptr = attemptckrealloc(objPtr->bytes, (unsigned) attempt + 1);
+	    ptr = attemptckrealloc(objPtr->bytes, attempt + 1);
 	}
     }
     if (ptr == NULL) {
@@ -226,7 +226,7 @@ GrowStringBuffer(
 	 */
 
 	attempt = needed;
-	ptr = ckrealloc(objPtr->bytes, (unsigned) attempt + 1);
+	ptr = ckrealloc(objPtr->bytes, attempt + 1);
     }
     objPtr->bytes = ptr;
     stringPtr->allocated = attempt;
@@ -834,9 +834,9 @@ Tcl_SetObjLength(
 	     * Need to enlarge the buffer.
 	     */
 	    if (objPtr->bytes == tclEmptyStringRep) {
-		objPtr->bytes = ckalloc((unsigned) length+1);
+		objPtr->bytes = ckalloc(length + 1);
 	    } else {
-		objPtr->bytes = ckrealloc(objPtr->bytes, (unsigned) length+1);
+		objPtr->bytes = ckrealloc(objPtr->bytes, length + 1);
 	    }
 	    stringPtr->allocated = length;
 	}
@@ -940,9 +940,9 @@ Tcl_AttemptSetObjLength(
 	    char *newBytes;
 
 	    if (objPtr->bytes == tclEmptyStringRep) {
-		newBytes = attemptckalloc((unsigned) length+1);
+		newBytes = attemptckalloc(length + 1);
 	    } else {
-		newBytes = attemptckrealloc(objPtr->bytes, (unsigned) length+1);
+		newBytes = attemptckrealloc(objPtr->bytes, length + 1);
 	    }
 	    if (newBytes == NULL) {
 		return 0;
@@ -3061,7 +3061,7 @@ static void
 FreeStringInternalRep(
     Tcl_Obj *objPtr)		/* Object with internal rep to free. */
 {
-    ckfree((char *) GET_STRING(objPtr));
+    ckfree(GET_STRING(objPtr));
     objPtr->typePtr = NULL;
 }
 
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 47d271e..2e9a9e8 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -790,12 +790,12 @@ TestasyncCmd(
 	if (argc != 3) {
 	    goto wrongNumArgs;
 	}
-	asyncPtr = (TestAsyncHandler *) ckalloc(sizeof(TestAsyncHandler));
+	asyncPtr = ckalloc(sizeof(TestAsyncHandler));
 	asyncPtr->id = nextId;
 	nextId++;
 	asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
 		(ClientData) asyncPtr);
-	asyncPtr->command = (char *) ckalloc((unsigned) (strlen(argv[2]) + 1));
+	asyncPtr->command = ckalloc(strlen(argv[2]) + 1);
 	strcpy(asyncPtr->command, argv[2]);
 	asyncPtr->nextPtr = firstHandler;
 	firstHandler = asyncPtr;
@@ -807,7 +807,7 @@ TestasyncCmd(
 		firstHandler = asyncPtr->nextPtr;
 		Tcl_AsyncDelete(asyncPtr->handler);
 		ckfree(asyncPtr->command);
-		ckfree((char *) asyncPtr);
+		ckfree(asyncPtr);
 	    }
 	    return TCL_OK;
 	}
@@ -829,7 +829,7 @@ TestasyncCmd(
 	    }
 	    Tcl_AsyncDelete(asyncPtr->handler);
 	    ckfree(asyncPtr->command);
-	    ckfree((char *) asyncPtr);
+	    ckfree(asyncPtr);
 	    break;
 	}
     } else if (strcmp(argv[1], "mark") == 0) {
@@ -909,7 +909,7 @@ AsyncHandlerProc(
 	 * invoked, it's possible.  Better error checking is needed here.
 	 */
     }
-    ckfree((char *)cmd);
+    ckfree(cmd);
     return code;
 }
 
@@ -1527,9 +1527,9 @@ TestdelCmd(
 	return TCL_ERROR;
     }
 
-    dPtr = (DelCmd *) ckalloc(sizeof(DelCmd));
+    dPtr = ckalloc(sizeof(DelCmd));
     dPtr->interp = interp;
-    dPtr->deleteCmd = (char *) ckalloc((unsigned) (strlen(argv[3]) + 1));
+    dPtr->deleteCmd = ckalloc(strlen(argv[3]) + 1);
     strcpy(dPtr->deleteCmd, argv[3]);
 
     Tcl_CreateCommand(slave, argv[2], DelCmdProc, (ClientData) dPtr,
@@ -1548,7 +1548,7 @@ DelCmdProc(
 
     Tcl_AppendResult(interp, dPtr->deleteCmd, NULL);
     ckfree(dPtr->deleteCmd);
-    ckfree((char *) dPtr);
+    ckfree(dPtr);
     return TCL_OK;
 }
 
@@ -1556,12 +1556,12 @@ static void
 DelDeleteProc(
     ClientData clientData)	/* String command to evaluate. */
 {
-    DelCmd *dPtr = (DelCmd *) clientData;
+    DelCmd *dPtr = clientData;
 
     Tcl_Eval(dPtr->interp, dPtr->deleteCmd);
     Tcl_ResetResult(dPtr->interp);
     ckfree(dPtr->deleteCmd);
-    ckfree((char *) dPtr);
+    ckfree(dPtr);
 }
 
 /*
@@ -1763,11 +1763,11 @@ TestdstringCmd(
 	} else if (strcmp(argv[2], "staticlarge") == 0) {
 	    Tcl_SetResult(interp, "first0 first1 first2 first3 first4 first5 first6 first7 first8 first9\nsecond0 second1 second2 second3 second4 second5 second6 second7 second8 second9\nthird0 third1 third2 third3 third4 third5 third6 third7 third8 third9\nfourth0 fourth1 fourth2 fourth3 fourth4 fourth5 fourth6 fourth7 fourth8 fourth9\nfifth0 fifth1 fifth2 fifth3 fifth4 fifth5 fifth6 fifth7 fifth8 fifth9\nsixth0 sixth1 sixth2 sixth3 sixth4 sixth5 sixth6 sixth7 sixth8 sixth9\nseventh0 seventh1 seventh2 seventh3 seventh4 seventh5 seventh6 seventh7 seventh8 seventh9\n", TCL_STATIC);
 	} else if (strcmp(argv[2], "free") == 0) {
-	    char *s = (char *) ckalloc(100);
+	    char *s = ckalloc(100);
 	    strcpy(s, "This is a malloc-ed string");
 	    Tcl_SetResult(interp, s, TCL_DYNAMIC);
 	} else if (strcmp(argv[2], "special") == 0) {
-	    char *s = (char *) ckalloc(100) + 16;
+	    char *s = ckalloc(100) + 16;
 	    strcpy(s, "This is a specially-allocated string");
 	    Tcl_SetResult(interp, s, SpecialFree);
 	} else {
@@ -1869,15 +1869,15 @@ TestencodingObjCmd(
 	if (objc != 5) {
 	    return TCL_ERROR;
 	}
-	encodingPtr = (TclEncoding *) ckalloc(sizeof(TclEncoding));
+	encodingPtr = ckalloc(sizeof(TclEncoding));
 	encodingPtr->interp = interp;
 
 	string = Tcl_GetStringFromObj(objv[3], &length);
-	encodingPtr->toUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+	encodingPtr->toUtfCmd = ckalloc(length + 1);
 	memcpy(encodingPtr->toUtfCmd, string, (unsigned) length + 1);
 
 	string = Tcl_GetStringFromObj(objv[4], &length);
-	encodingPtr->fromUtfCmd = (char *) ckalloc((unsigned) (length + 1));
+	encodingPtr->fromUtfCmd = ckalloc(length + 1);
 	memcpy(encodingPtr->fromUtfCmd, string, (unsigned) (length + 1));
 
 	string = Tcl_GetStringFromObj(objv[2], &length);
@@ -1972,12 +1972,11 @@ static void
 EncodingFreeProc(
     ClientData clientData)	/* ClientData associated with type. */
 {
-    TclEncoding *encodingPtr;
+    TclEncoding *encodingPtr = clientData;
 
-    encodingPtr = (TclEncoding *) clientData;
-    ckfree((char *) encodingPtr->toUtfCmd);
-    ckfree((char *) encodingPtr->fromUtfCmd);
-    ckfree((char *) encodingPtr);
+    ckfree(encodingPtr->toUtfCmd);
+    ckfree(encodingPtr->fromUtfCmd);
+    ckfree(encodingPtr);
 }
 
 /*
@@ -2132,7 +2131,7 @@ TesteventObjCmd(
 		"position specifier", TCL_EXACT, &posIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	ev = (TestEvent *) ckalloc(sizeof(TestEvent));
+	ev = ckalloc(sizeof(TestEvent));
 	ev->header.proc = TesteventProc;
 	ev->header.nextPtr = NULL;
 	ev->interp = interp;
@@ -2990,7 +2989,7 @@ TestlinkCmd(
 	    if (strcmp(argv[5], "-") == 0) {
 		stringVar = NULL;
 	    } else {
-		stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
+		stringVar = ckalloc(strlen(argv[5]) + 1);
 		strcpy(stringVar, argv[5]);
 	    }
 	}
@@ -3097,7 +3096,7 @@ TestlinkCmd(
 	    if (strcmp(argv[5], "-") == 0) {
 		stringVar = NULL;
 	    } else {
-		stringVar = (char *) ckalloc((unsigned) (strlen(argv[5]) + 1));
+		stringVar = ckalloc(strlen(argv[5]) + 1);
 		strcpy(stringVar, argv[5]);
 	    }
 	    Tcl_UpdateLinkedVar(interp, "string");
@@ -3409,7 +3408,7 @@ CleanupTestSetassocdataTests(
     ClientData clientData,	/* Data to be released. */
     Tcl_Interp *interp)		/* Interpreter being deleted. */
 {
-    ckfree((char *) clientData);
+    ckfree(clientData);
 }
 
 /*
@@ -4108,7 +4107,7 @@ TestsetassocdataCmd(
 	return TCL_ERROR;
     }
 
-    buf = ckalloc((unsigned) strlen(argv[2]) + 1);
+    buf = ckalloc(strlen(argv[2]) + 1);
     strcpy(buf, argv[2]);
 
     /*
@@ -4491,7 +4490,7 @@ TestpanicCmd(
 
     argString = Tcl_Merge(argc-1, argv+1);
     Tcl_Panic("%s", argString);
-    ckfree((char *)argString);
+    ckfree(argString);
 
     return TCL_OK;
 }
@@ -4716,8 +4715,8 @@ GetTimesCmd(
     fprintf(stderr, "alloc & free 100000 6 word items\n");
     Tcl_GetTime(&start);
     for (i = 0;  i < 100000;  i++) {
-	objPtr = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
-	ckfree((char *) objPtr);
+	objPtr = ckalloc(sizeof(Tcl_Obj));
+	ckfree(objPtr);
     }
     Tcl_GetTime(&stop);
     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -4725,10 +4724,10 @@ GetTimesCmd(
 
     /* alloc 5000 times */
     fprintf(stderr, "alloc 5000 6 word items\n");
-    objv = (Tcl_Obj **) ckalloc(5000 * sizeof(Tcl_Obj *));
+    objv = ckalloc(5000 * sizeof(Tcl_Obj *));
     Tcl_GetTime(&start);
     for (i = 0;  i < 5000;  i++) {
-	objv[i] = (Tcl_Obj *) ckalloc(sizeof(Tcl_Obj));
+	objv[i] = ckalloc(sizeof(Tcl_Obj));
     }
     Tcl_GetTime(&stop);
     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -4738,7 +4737,7 @@ GetTimesCmd(
     fprintf(stderr, "free 5000 6 word items\n");
     Tcl_GetTime(&start);
     for (i = 0;  i < 5000;  i++) {
-	ckfree((char *) objv[i]);
+	ckfree(objv[i]);
     }
     Tcl_GetTime(&stop);
     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
@@ -4764,7 +4763,7 @@ GetTimesCmd(
     Tcl_GetTime(&stop);
     timePer = (stop.sec - start.sec)*1000000 + (stop.usec - start.usec);
     fprintf(stderr, "   %.3f usec per Tcl_DecrRefCount\n", timePer/5000);
-    ckfree((char *) objv);
+    ckfree(objv);
 
     /* TclGetString 100000 times */
     fprintf(stderr, "TclGetStringFromObj of \"12345\" 100000 times\n");
@@ -5312,7 +5311,7 @@ TestChannelCmd(
 		    *nextPtrPtr = curPtr->nextPtr;
 		    curPtr->nextPtr = NULL;
 		    chan = curPtr->chan;
-		    ckfree((char *) curPtr);
+		    ckfree(curPtr);
 		    break;
 		}
 	    }
@@ -5382,7 +5381,7 @@ TestChannelCmd(
 
 	/* Remember the channel in the pool of detached channels */
 
-	det = (TestChannel *) ckalloc(sizeof(TestChannel));
+	det = ckalloc(sizeof(TestChannel));
 	det->chan     = chan;
 	det->nextPtr  = firstDetached;
 	firstDetached = det;
@@ -5780,8 +5779,7 @@ TestChannelEventCmd(
 	    return TCL_ERROR;
 	}
 
-	esPtr = (EventScriptRecord *) ckalloc((unsigned)
-		sizeof(EventScriptRecord));
+	esPtr = ckalloc(sizeof(EventScriptRecord));
 	esPtr->nextPtr = statePtr->scriptRecordPtr;
 	statePtr->scriptRecordPtr = esPtr;
 
@@ -5838,7 +5836,7 @@ TestChannelEventCmd(
 	Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
 		TclChannelEventScriptInvoker, (ClientData) esPtr);
 	Tcl_DecrRefCount(esPtr->scriptPtr);
-	ckfree((char *) esPtr);
+	ckfree(esPtr);
 
 	return TCL_OK;
     }
@@ -5879,7 +5877,7 @@ TestChannelEventCmd(
 	    Tcl_DeleteChannelHandler((Tcl_Channel) chanPtr,
 		    TclChannelEventScriptInvoker, (ClientData) esPtr);
 	    Tcl_DecrRefCount(esPtr->scriptPtr);
-	    ckfree((char *) esPtr);
+	    ckfree(esPtr);
 	}
 	statePtr->scriptRecordPtr = NULL;
 	return TCL_OK;
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index e27ce5d..ca8545a 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -545,7 +545,7 @@ TestindexobjCmd(
 	return TCL_ERROR;
     }
 
-    argv = (const char **) ckalloc((unsigned) ((objc-3) * sizeof(char *)));
+    argv = ckalloc((objc-3) * sizeof(char *));
     for (i = 4; i < objc; i++) {
 	argv[i-4] = Tcl_GetString(objv[i]);
     }
@@ -569,7 +569,7 @@ TestindexobjCmd(
 
     result = Tcl_GetIndexFromObj((setError? interp : NULL), objv[3],
 	    argv, "token", (allowAbbrev? 0 : TCL_EXACT), &index);
-    ckfree((char *) argv);
+    ckfree(argv);
     if (result == TCL_OK) {
 	Tcl_SetIntObj(Tcl_GetObjResult(interp), index);
     }
diff --git a/generic/tclThread.c b/generic/tclThread.c
index 46e4139..d1f2691 100644
--- a/generic/tclThread.c
+++ b/generic/tclThread.c
@@ -83,16 +83,17 @@ Tcl_GetThreadData(
     /*
      * Initialize the key for this thread.
      */
+
     result = TclThreadStorageKeyGet(keyPtr);
 
     if (result == NULL) {
-	result = ckalloc((size_t)size);
+	result = ckalloc(size);
 	memset(result, 0, (size_t) size);
 	TclThreadStorageKeySet(keyPtr, result);
     }
 #else /* TCL_THREADS */
     if (*keyPtr == NULL) {
-	result = ckalloc((size_t)size);
+	result = ckalloc(size);
 	memset(result, 0, (size_t)size);
 	*keyPtr = result;
 	RememberSyncObject(keyPtr, &keyRecord);
@@ -178,14 +179,14 @@ RememberSyncObject(
 
     if (recPtr->num >= recPtr->max) {
 	recPtr->max += 8;
-	newList = (void **) ckalloc(recPtr->max * sizeof(void *));
+	newList = ckalloc(recPtr->max * sizeof(void *));
 	for (i=0,j=0 ; i<recPtr->num ; i++) {
 	    if (recPtr->list[i] != NULL) {
 		newList[j++] = recPtr->list[i];
 	    }
 	}
 	if (recPtr->list != NULL) {
-	    ckfree((char *) recPtr->list);
+	    ckfree(recPtr->list);
 	}
 	recPtr->list = newList;
 	recPtr->num = j;
@@ -397,7 +398,7 @@ TclFinalizeSynchronization(void)
 	    blockPtr = *keyPtr;
 	    ckfree(blockPtr);
 	}
-	ckfree((char *) keyRecord.list);
+	ckfree(keyRecord.list);
 	keyRecord.list = NULL;
     }
     keyRecord.max = 0;
@@ -417,7 +418,7 @@ TclFinalizeSynchronization(void)
 	}
     }
     if (mutexRecord.list != NULL) {
-	ckfree((char *) mutexRecord.list);
+	ckfree(mutexRecord.list);
 	mutexRecord.list = NULL;
     }
     mutexRecord.max = 0;
@@ -430,7 +431,7 @@ TclFinalizeSynchronization(void)
 	}
     }
     if (condRecord.list != NULL) {
-	ckfree((char *) condRecord.list);
+	ckfree(condRecord.list);
 	condRecord.list = NULL;
     }
     condRecord.max = 0;
diff --git a/generic/tclThreadJoin.c b/generic/tclThreadJoin.c
index 9f0dbc9..4b09e1c 100644
--- a/generic/tclThreadJoin.c
+++ b/generic/tclThreadJoin.c
@@ -201,7 +201,7 @@ TclJoinThread(
 
     Tcl_ConditionFinalize(&threadPtr->cond);
     Tcl_MutexFinalize(&threadPtr->threadMutex);
-    ckfree((char *) threadPtr);
+    ckfree(threadPtr);
 
     return TCL_OK;
 }
@@ -230,7 +230,7 @@ TclRememberJoinableThread(
 {
     JoinableThread *threadPtr;
 
-    threadPtr = (JoinableThread *) ckalloc(sizeof(JoinableThread));
+    threadPtr = ckalloc(sizeof(JoinableThread));
     threadPtr->id = id;
     threadPtr->done = 0;
     threadPtr->waitedUpon = 0;
diff --git a/generic/tclThreadStorage.c b/generic/tclThreadStorage.c
index 5365672..f24e334 100644
--- a/generic/tclThreadStorage.c
+++ b/generic/tclThreadStorage.c
@@ -117,7 +117,7 @@ TSDTableDelete(
 	     * and must now be deallocated or they will leak.
 	     */
 
-	    ckfree((char *) tsdTablePtr->tablePtr[i]);
+	    ckfree(tsdTablePtr->tablePtr[i]);
 	}
     }
 
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 5d49952..71d5a66 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -436,7 +436,7 @@ ThreadObjCmd(
 	    ckfree(errorProcString);
 	}
 	proc = Tcl_GetString(objv[2]);
-	errorProcString = ckalloc(strlen(proc)+1);
+	errorProcString = ckalloc(strlen(proc) + 1);
 	strcpy(errorProcString, proc);
 	Tcl_MutexUnlock(&threadMutex);
 	return TCL_OK;
@@ -513,7 +513,7 @@ ThreadCreate(
 	    TCL_THREAD_STACK_DEFAULT, joinable) != TCL_OK) {
 	Tcl_MutexUnlock(&threadMutex);
 	Tcl_AppendResult(interp, "can't create a new thread", NULL);
-	ckfree((char *) ctrl.script);
+	ckfree(ctrl.script);
 	return TCL_ERROR;
     }
 
@@ -597,7 +597,7 @@ NewTestThread(
      * eval'ing, for the case that we exit during evaluation
      */
 
-    threadEvalScript = ckalloc(strlen(ctrlPtr->script)+1);
+    threadEvalScript = ckalloc(strlen(ctrlPtr->script) + 1);
     strcpy(threadEvalScript, ctrlPtr->script);
 
     Tcl_CreateThreadExitHandler(ThreadExitProc, threadEvalScript);
@@ -841,13 +841,13 @@ ThreadSend(
      * Create the event for its event queue.
      */
 
-    threadEventPtr = (ThreadEvent *) ckalloc(sizeof(ThreadEvent));
+    threadEventPtr = ckalloc(sizeof(ThreadEvent));
     threadEventPtr->script = ckalloc(strlen(script) + 1);
     strcpy(threadEventPtr->script, script);
     if (!wait) {
 	resultPtr = threadEventPtr->resultPtr = NULL;
     } else {
-	resultPtr = (ThreadEventResult *) ckalloc(sizeof(ThreadEventResult));
+	resultPtr = ckalloc(sizeof(ThreadEventResult));
 	threadEventPtr->resultPtr = resultPtr;
 
 	/*
@@ -930,7 +930,7 @@ ThreadSend(
     Tcl_ConditionFinalize(&resultPtr->done);
     code = resultPtr->code;
 
-    ckfree((char *) resultPtr);
+    ckfree(resultPtr);
 
     return code;
 }
@@ -1083,7 +1083,7 @@ ThreadFreeProc(
     ClientData clientData)
 {
     if (clientData) {
-	ckfree((char *) clientData);
+	ckfree(clientData);
     }
 }
 
@@ -1111,7 +1111,7 @@ ThreadDeleteEvent(
     ClientData clientData)	/* dummy */
 {
     if (eventPtr->proc == ThreadEventProc) {
-	ckfree((char *) ((ThreadEvent *) eventPtr)->script);
+	ckfree(((ThreadEvent *) eventPtr)->script);
 	return 1;
     }
 
@@ -1175,7 +1175,7 @@ ThreadExitProc(
 	    }
 	    resultPtr->nextPtr = resultPtr->prevPtr = 0;
 	    resultPtr->eventPtr->resultPtr = NULL;
-	    ckfree((char *) resultPtr);
+	    ckfree(resultPtr);
 	} else if (resultPtr->dstThreadId == self) {
 	    /*
 	     * Dang. The target is going away. Unblock the caller. The result
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index f70d60f..b6c9208 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -224,7 +224,7 @@ TimerExitProc(
 	timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
 	while (timerHandlerPtr != NULL) {
 	    tsdPtr->firstTimerHandlerPtr = timerHandlerPtr->nextPtr;
-	    ckfree((char *) timerHandlerPtr);
+	    ckfree(timerHandlerPtr);
 	    timerHandlerPtr = tsdPtr->firstTimerHandlerPtr;
 	}
     }
@@ -300,7 +300,7 @@ TclCreateAbsoluteTimerHandler(
     ThreadSpecificData *tsdPtr;
 
     tsdPtr = InitTimer();
-    timerHandlerPtr = (TimerHandler *) ckalloc(sizeof(TimerHandler));
+    timerHandlerPtr = ckalloc(sizeof(TimerHandler));
 
     /*
      * Fill in fields for the event.
@@ -376,7 +376,7 @@ Tcl_DeleteTimerHandler(
 	} else {
 	    prevPtr->nextPtr = timerHandlerPtr->nextPtr;
 	}
-	ckfree((char *) timerHandlerPtr);
+	ckfree(timerHandlerPtr);
 	return;
     }
 }
@@ -491,7 +491,7 @@ TimerCheckProc(
 	if (blockTime.sec == 0 && blockTime.usec == 0 &&
 		!tsdPtr->timerPending) {
 	    tsdPtr->timerPending = 1;
-	    timerEvPtr = (Tcl_Event *) ckalloc(sizeof(Tcl_Event));
+	    timerEvPtr = ckalloc(sizeof(Tcl_Event));
 	    timerEvPtr->proc = TimerHandlerEventProc;
 	    Tcl_QueueEvent(timerEvPtr, TCL_QUEUE_TAIL);
 	}
@@ -594,7 +594,7 @@ TimerHandlerEventProc(
 
 	*nextPtrPtr = timerHandlerPtr->nextPtr;
 	timerHandlerPtr->proc(timerHandlerPtr->clientData);
-	ckfree((char *) timerHandlerPtr);
+	ckfree(timerHandlerPtr);
     }
     TimerSetupProc(NULL, TCL_TIMER_EVENTS);
     return 1;
@@ -628,7 +628,7 @@ Tcl_DoWhenIdle(
     Tcl_Time blockTime;
     ThreadSpecificData *tsdPtr = InitTimer();
 
-    idlePtr = (IdleHandler *) ckalloc(sizeof(IdleHandler));
+    idlePtr = ckalloc(sizeof(IdleHandler));
     idlePtr->proc = proc;
     idlePtr->clientData = clientData;
     idlePtr->generation = tsdPtr->idleGeneration;
@@ -677,7 +677,7 @@ Tcl_CancelIdleCall(
 	while ((idlePtr->proc == proc)
 		&& (idlePtr->clientData == clientData)) {
 	    nextPtr = idlePtr->nextPtr;
-	    ckfree((char *) idlePtr);
+	    ckfree(idlePtr);
 	    idlePtr = nextPtr;
 	    if (prevPtr == NULL) {
 		tsdPtr->idleList = idlePtr;
@@ -752,7 +752,7 @@ TclServiceIdle(void)
 	    tsdPtr->lastIdlePtr = NULL;
 	}
 	idlePtr->proc(idlePtr->clientData);
-	ckfree((char *) idlePtr);
+	ckfree(idlePtr);
     }
     if (tsdPtr->idleList) {
 	blockTime.sec = 0;
@@ -812,7 +812,7 @@ Tcl_AfterObjCmd(
 
     assocPtr = Tcl_GetAssocData(interp, "tclAfter", NULL);
     if (assocPtr == NULL) {
-	assocPtr = (AfterAssocData *) ckalloc(sizeof(AfterAssocData));
+	assocPtr = ckalloc(sizeof(AfterAssocData));
 	assocPtr->interp = interp;
 	assocPtr->firstAfterPtr = NULL;
 	Tcl_SetAssocData(interp, "tclAfter", AfterCleanupProc, assocPtr);
@@ -851,7 +851,7 @@ Tcl_AfterObjCmd(
 	if (objc == 2) {
 	    return AfterDelay(interp, ms);
 	}
-	afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+	afterPtr = ckalloc(sizeof(AfterInfo));
 	afterPtr->assocPtr = assocPtr;
 	if (objc == 3) {
 	    afterPtr->commandPtr = objv[2];
@@ -931,7 +931,7 @@ Tcl_AfterObjCmd(
 	    Tcl_WrongNumArgs(interp, 2, objv, "script ?script ...?");
 	    return TCL_ERROR;
 	}
-	afterPtr = (AfterInfo *) ckalloc((unsigned) (sizeof(AfterInfo)));
+	afterPtr = ckalloc(sizeof(AfterInfo));
 	afterPtr->assocPtr = assocPtr;
 	if (objc == 3) {
 	    afterPtr->commandPtr = objv[2];
@@ -1194,7 +1194,7 @@ AfterProc(
      */
 
     Tcl_DecrRefCount(afterPtr->commandPtr);
-    ckfree((char *) afterPtr);
+    ckfree(afterPtr);
 }
 
 /*
@@ -1232,7 +1232,7 @@ FreeAfterPtr(
 	prevPtr->nextPtr = afterPtr->nextPtr;
     }
     Tcl_DecrRefCount(afterPtr->commandPtr);
-    ckfree((char *) afterPtr);
+    ckfree(afterPtr);
 }
 
 /*
@@ -1271,9 +1271,9 @@ AfterCleanupProc(
 	    Tcl_CancelIdleCall(AfterProc, afterPtr);
 	}
 	Tcl_DecrRefCount(afterPtr->commandPtr);
-	ckfree((char *) afterPtr);
+	ckfree(afterPtr);
     }
-    ckfree((char *) assocPtr);
+    ckfree(assocPtr);
 }
 
 /*
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index d4eb476..d5fb6f6 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -461,9 +461,9 @@ TraceExecutionObjCmd(
 	command = Tcl_GetStringFromObj(objv[5], &commandLength);
 	length = (size_t) commandLength;
 	if ((enum traceOptions) optionIndex == TRACE_ADD) {
-	    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
-		    ckalloc((unsigned) ((TclOffset(TraceCommandInfo, command)
-			    + 1) + length));
+	    TraceCommandInfo *tcmdPtr = ckalloc(
+		    TclOffset(TraceCommandInfo, command) + 1 + length);
+
 	    tcmdPtr->flags = flags;
 	    tcmdPtr->stepTrace = NULL;
 	    tcmdPtr->startLevel = 0;
@@ -479,7 +479,7 @@ TraceExecutionObjCmd(
 	    name = Tcl_GetString(objv[3]);
 	    if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
 		    tcmdPtr) != TCL_OK) {
-		ckfree((char *) tcmdPtr);
+		ckfree(tcmdPtr);
 		return TCL_ERROR;
 	    }
 	} else {
@@ -530,7 +530,7 @@ TraceExecutionObjCmd(
 			Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
 			tcmdPtr->stepTrace = NULL;
 			if (tcmdPtr->startCmd != NULL) {
-			    ckfree((char *) tcmdPtr->startCmd);
+			    ckfree(tcmdPtr->startCmd);
 			}
 		    }
 		    if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
@@ -541,7 +541,7 @@ TraceExecutionObjCmd(
 			tcmdPtr->flags = 0;
 		    }
 		    if ((--tcmdPtr->refCount) <= 0) {
-			ckfree((char *) tcmdPtr);
+			ckfree(tcmdPtr);
 		    }
 		    break;
 		}
@@ -697,9 +697,8 @@ TraceCommandObjCmd(
 	command = Tcl_GetStringFromObj(objv[5], &commandLength);
 	length = (size_t) commandLength;
 	if ((enum traceOptions) optionIndex == TRACE_ADD) {
-	    TraceCommandInfo *tcmdPtr = (TraceCommandInfo *)
-		    ckalloc((unsigned) ((TclOffset(TraceCommandInfo, command)
-			    + 1) + length));
+	    TraceCommandInfo *tcmdPtr = ckalloc(
+		    TclOffset(TraceCommandInfo, command) + 1 + length);
 
 	    tcmdPtr->flags = flags;
 	    tcmdPtr->stepTrace = NULL;
@@ -712,7 +711,7 @@ TraceCommandObjCmd(
 	    name = Tcl_GetString(objv[3]);
 	    if (Tcl_TraceCommand(interp, name, flags, TraceCommandProc,
 		    tcmdPtr) != TCL_OK) {
-		ckfree((char *) tcmdPtr);
+		ckfree(tcmdPtr);
 		return TCL_ERROR;
 	    }
 	} else {
@@ -743,7 +742,7 @@ TraceCommandObjCmd(
 			    TraceCommandProc, clientData);
 		    tcmdPtr->flags |= TCL_TRACE_DESTROYED;
 		    if ((--tcmdPtr->refCount) <= 0) {
-			ckfree((char *) tcmdPtr);
+			ckfree(tcmdPtr);
 		    }
 		    break;
 		}
@@ -898,9 +897,9 @@ TraceVariableObjCmd(
 	command = Tcl_GetStringFromObj(objv[5], &commandLength);
 	length = (size_t) commandLength;
 	if ((enum traceOptions) optionIndex == TRACE_ADD) {
-	    CombinedTraceVarInfo *ctvarPtr = (CombinedTraceVarInfo *)
-		    ckalloc((unsigned) ((TclOffset(CombinedTraceVarInfo,
-			    traceCmdInfo.command) + 1) + length));
+	    CombinedTraceVarInfo *ctvarPtr = ckalloc(
+		    TclOffset(CombinedTraceVarInfo, traceCmdInfo.command)
+		    + 1 + length);
 
 	    ctvarPtr->traceCmdInfo.flags = flags;
 	    if (objv[0] == NULL) {
@@ -915,7 +914,7 @@ TraceVariableObjCmd(
 	    name = Tcl_GetString(objv[3]);
 	    if (TraceVarEx(interp, name, NULL, (VarTrace *) ctvarPtr)
 		    != TCL_OK) {
-		ckfree((char *) ctvarPtr);
+		ckfree(ctvarPtr);
 		return TCL_ERROR;
 	    }
 	} else {
@@ -1109,7 +1108,7 @@ Tcl_TraceCommand(
      * Set up trace information.
      */
 
-    tracePtr = (CommandTrace *) ckalloc(sizeof(CommandTrace));
+    tracePtr = ckalloc(sizeof(CommandTrace));
     tracePtr->traceProc = proc;
     tracePtr->clientData = clientData;
     tracePtr->flags = flags &
@@ -1205,7 +1204,7 @@ Tcl_UntraceCommand(
     tracePtr->flags = 0;
 
     if ((--tracePtr->refCount) <= 0) {
-	ckfree((char *) tracePtr);
+	ckfree(tracePtr);
     }
 
     if (hasExecTraces) {
@@ -1312,7 +1311,7 @@ TraceCommandProc(
 	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
 	    tcmdPtr->stepTrace = NULL;
 	    if (tcmdPtr->startCmd != NULL) {
-		ckfree((char *) tcmdPtr->startCmd);
+		ckfree(tcmdPtr->startCmd);
 	    }
 	}
 	if (tcmdPtr->flags & TCL_TRACE_EXEC_IN_PROGRESS) {
@@ -1355,7 +1354,7 @@ TraceCommandProc(
 	tcmdPtr->refCount--;
     }
     if ((--tcmdPtr->refCount) <= 0) {
-	ckfree((char *) tcmdPtr);
+	ckfree(tcmdPtr);
     }
 }
 
@@ -1447,7 +1446,7 @@ TclCheckExecutionTraces(
 		traceCode = TraceExecutionProc(tcmdPtr, interp, curLevel,
 			command, (Tcl_Command) cmdPtr, objc, objv);
 		if ((--tcmdPtr->refCount) <= 0) {
-		    ckfree((char *) tcmdPtr);
+		    ckfree(tcmdPtr);
 		}
 	    }
 	}
@@ -1690,7 +1689,7 @@ CommandObjTraceDeleted(
     TraceCommandInfo *tcmdPtr = clientData;
 
     if ((--tcmdPtr->refCount) <= 0) {
-	ckfree((char *) tcmdPtr);
+	ckfree(tcmdPtr);
     }
 }
 
@@ -1773,7 +1772,7 @@ TraceExecutionProc(
 	    Tcl_DeleteTrace(interp, tcmdPtr->stepTrace);
 	    tcmdPtr->stepTrace = NULL;
 	    if (tcmdPtr->startCmd != NULL) {
-		ckfree((char *) tcmdPtr->startCmd);
+		ckfree(tcmdPtr->startCmd);
 	    }
 	}
 
@@ -1905,7 +1904,7 @@ TraceExecutionProc(
     }
     if (call) {
 	if ((--tcmdPtr->refCount) <= 0) {
-	    ckfree((char *) tcmdPtr);
+	    ckfree(tcmdPtr);
 	}
     }
     return traceCode;
@@ -2131,7 +2130,7 @@ Tcl_CreateObjTrace(
 	iPtr->tracesForbiddingInline++;
     }
 
-    tracePtr = (Trace *) ckalloc(sizeof(Trace));
+    tracePtr = ckalloc(sizeof(Trace));
     tracePtr->level = level;
     tracePtr->proc = proc;
     tracePtr->clientData = clientData;
@@ -2194,8 +2193,7 @@ Tcl_CreateTrace(
 				 * command. */
     ClientData clientData)	/* Arbitrary value word to pass to proc. */
 {
-    StringTraceData *data = (StringTraceData *)
-	    ckalloc(sizeof(StringTraceData));
+    StringTraceData *data = ckalloc(sizeof(StringTraceData));
 
     data->clientData = clientData;
     data->proc = proc;
@@ -3105,7 +3103,7 @@ Tcl_TraceVar2(
     register VarTrace *tracePtr;
     int result;
 
-    tracePtr = (VarTrace *) ckalloc(sizeof(VarTrace));
+    tracePtr = ckalloc(sizeof(VarTrace));
     tracePtr->traceProc = proc;
     tracePtr->clientData = clientData;
     tracePtr->flags = flags;
@@ -3113,7 +3111,7 @@ Tcl_TraceVar2(
     result = TraceVarEx(interp, part1, part2, tracePtr);
 
     if (result != TCL_OK) {
-	ckfree((char *) tracePtr);
+	ckfree(tracePtr);
     }
     return result;
 }
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index c3c340b..f41830a 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -442,8 +442,7 @@ Tcl_SplitList(
 	}
     }
     length = l - list;
-    argv = (const char **) ckalloc((unsigned)
-	    ((size * sizeof(char *)) + length + 1));
+    argv = ckalloc((size * sizeof(char *)) + length + 1);
     for (i = 0, p = ((char *) argv) + size*sizeof(char *);
 	    *list != 0;  i++) {
 	const char *prevList = list;
@@ -455,14 +454,14 @@ Tcl_SplitList(
 	    if (interp != NULL) {
 		Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL);
 	    }
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    return result;
 	}
 	if (*element == 0) {
 	    break;
 	}
 	if (i >= size) {
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    if (interp != NULL) {
 		Tcl_SetResult(interp, "internal error in Tcl_SplitList",
 			TCL_STATIC);
@@ -870,7 +869,7 @@ Tcl_Merge(
     if (argc <= LOCAL_SIZE) {
 	flagPtr = localFlags;
     } else {
-	flagPtr = (int *) ckalloc((unsigned) argc*sizeof(int));
+	flagPtr = ckalloc(argc * sizeof(int));
     }
     numChars = 1;
     for (i = 0; i < argc; i++) {
@@ -881,7 +880,7 @@ Tcl_Merge(
      * Pass two: copy into the result area.
      */
 
-    result = (char *) ckalloc((unsigned) numChars);
+    result = ckalloc(numChars);
     dst = result;
     for (i = 0; i < argc; i++) {
 	numChars = Tcl_ConvertElement(argv[i], dst,
@@ -897,7 +896,7 @@ Tcl_Merge(
     }
 
     if (flagPtr != localFlags) {
-	ckfree((char *) flagPtr);
+	ckfree(flagPtr);
     }
     return result;
 }
@@ -967,7 +966,7 @@ Tcl_Concat(
     for (totalSize = 1, i = 0; i < argc; i++) {
 	totalSize += strlen(argv[i]) + 1;
     }
-    result = (char *) ckalloc((unsigned) totalSize);
+    result = ckalloc(totalSize);
     if (argc == 0) {
 	*result = '\0';
 	return result;
@@ -1120,7 +1119,7 @@ Tcl_ConcatObj(
      * the terminating NULL byte.
      */
 
-    concatStr = ckalloc((unsigned) allocSize);
+    concatStr = ckalloc(allocSize);
 
     /*
      * Now concatenate the elements. Clip white space off the front and back
@@ -1738,13 +1737,12 @@ Tcl_DStringAppend(
     if (newSize >= dsPtr->spaceAvl) {
 	dsPtr->spaceAvl = newSize * 2;
 	if (dsPtr->string == dsPtr->staticSpace) {
-	    char *newString = ckalloc((unsigned) dsPtr->spaceAvl);
+	    char *newString = ckalloc(dsPtr->spaceAvl);
 
 	    memcpy(newString, dsPtr->string, (size_t) dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
-	    dsPtr->string = ckrealloc((void *) dsPtr->string,
-		    (size_t) dsPtr->spaceAvl);
+	    dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl);
 	}
     }
 
@@ -1800,13 +1798,12 @@ Tcl_DStringAppendElement(
     if (newSize >= dsPtr->spaceAvl) {
 	dsPtr->spaceAvl = newSize * 2;
 	if (dsPtr->string == dsPtr->staticSpace) {
-	    char *newString = ckalloc((unsigned) dsPtr->spaceAvl);
+	    char *newString = ckalloc(dsPtr->spaceAvl);
 
 	    memcpy(newString, dsPtr->string, (size_t) dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
-	    dsPtr->string = (char *) ckrealloc((void *) dsPtr->string,
-		    (size_t) dsPtr->spaceAvl);
+	    dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl);
 	}
     }
 
@@ -1882,13 +1879,12 @@ Tcl_DStringSetLength(
 	    dsPtr->spaceAvl = length + 1;
 	}
 	if (dsPtr->string == dsPtr->staticSpace) {
-	    char *newString = ckalloc((unsigned) dsPtr->spaceAvl);
+	    char *newString = ckalloc(dsPtr->spaceAvl);
 
 	    memcpy(newString, dsPtr->string, (size_t) dsPtr->length);
 	    dsPtr->string = newString;
 	} else {
-	    dsPtr->string = (char *) ckrealloc((void *) dsPtr->string,
-		    (size_t) dsPtr->spaceAvl);
+	    dsPtr->string = ckrealloc(dsPtr->string, dsPtr->spaceAvl);
 	}
     }
     dsPtr->length = length;
@@ -2016,7 +2012,7 @@ Tcl_DStringGetResult(
 	    dsPtr->string = iPtr->result;
 	    dsPtr->spaceAvl = dsPtr->length+1;
 	} else {
-	    dsPtr->string = (char *) ckalloc((unsigned) dsPtr->length+1);
+	    dsPtr->string = ckalloc(dsPtr->length+1);
 	    memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1);
 	    iPtr->freeProc(iPtr->result);
 	}
@@ -2027,7 +2023,7 @@ Tcl_DStringGetResult(
 	    dsPtr->string = dsPtr->staticSpace;
 	    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
 	} else {
-	    dsPtr->string = (char *) ckalloc((unsigned) dsPtr->length+1);
+	    dsPtr->string = ckalloc(dsPtr->length+1);
 	    dsPtr->spaceAvl = dsPtr->length + 1;
 	}
 	memcpy(dsPtr->string, iPtr->result, (unsigned) dsPtr->length+1);
@@ -2885,12 +2881,12 @@ static Tcl_HashTable *
 GetThreadHash(
     Tcl_ThreadDataKey *keyPtr)
 {
-    Tcl_HashTable **tablePtrPtr = (Tcl_HashTable **)
-	    Tcl_GetThreadData(keyPtr, (int) sizeof(Tcl_HashTable *));
+    Tcl_HashTable **tablePtrPtr =
+	    Tcl_GetThreadData(keyPtr, sizeof(Tcl_HashTable *));
 
     if (NULL == *tablePtrPtr) {
-	*tablePtrPtr = (Tcl_HashTable *)ckalloc(sizeof(Tcl_HashTable));
-	Tcl_CreateThreadExitHandler(FreeThreadHash, (ClientData)*tablePtrPtr);
+	*tablePtrPtr = ckalloc(sizeof(Tcl_HashTable));
+	Tcl_CreateThreadExitHandler(FreeThreadHash, *tablePtrPtr);
 	Tcl_InitHashTable(*tablePtrPtr, TCL_ONE_WORD_KEYS);
     }
     return *tablePtrPtr;
@@ -2918,7 +2914,7 @@ FreeThreadHash(
 
     ClearHash(tablePtr);
     Tcl_DeleteHashTable(tablePtr);
-    ckfree((char *) tablePtr);
+    ckfree(tablePtr);
 }
 
 /*
@@ -2936,7 +2932,7 @@ static void
 FreeProcessGlobalValue(
     ClientData clientData)
 {
-    ProcessGlobalValue *pgvPtr = (ProcessGlobalValue *) clientData;
+    ProcessGlobalValue *pgvPtr = clientData;
 
     pgvPtr->epoch++;
     pgvPtr->numBytes = 0;
@@ -2984,7 +2980,7 @@ TclSetProcessGlobalValue(
 	Tcl_CreateExitHandler(FreeProcessGlobalValue, (ClientData) pgvPtr);
     }
     bytes = Tcl_GetStringFromObj(newValue, &pgvPtr->numBytes);
-    pgvPtr->value = ckalloc((unsigned) pgvPtr->numBytes + 1);
+    pgvPtr->value = ckalloc(pgvPtr->numBytes + 1);
     memcpy(pgvPtr->value, bytes, (unsigned) pgvPtr->numBytes + 1);
     if (pgvPtr->encoding) {
 	Tcl_FreeEncoding(pgvPtr->encoding);
@@ -3050,8 +3046,7 @@ TclGetProcessGlobalValue(
 	    Tcl_DStringLength(&native), &newValue);
 	    Tcl_DStringFree(&native);
 	    ckfree(pgvPtr->value);
-	    pgvPtr->value = ckalloc((unsigned)
-		    Tcl_DStringLength(&newValue) + 1);
+	    pgvPtr->value = ckalloc(Tcl_DStringLength(&newValue) + 1);
 	    memcpy(pgvPtr->value, Tcl_DStringValue(&newValue),
 		    (size_t) Tcl_DStringLength(&newValue) + 1);
 	    Tcl_DStringFree(&newValue);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 56524a9..a4b8a69 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -294,7 +294,7 @@ CleanupVar(
 	    && !TclIsVarTraced(varPtr)
 	    && (VarHashRefCount(varPtr) == !TclIsVarDeadHash(varPtr))) {
 	if (VarHashRefCount(varPtr) == 0) {
-	    ckfree((char *) varPtr);
+	    ckfree(varPtr);
 	} else {
 	    VarHashDeleteEntry(varPtr);
 	}
@@ -303,7 +303,7 @@ CleanupVar(
 	    TclIsVarInHash(arrayPtr) && !TclIsVarTraced(arrayPtr) &&
 	    (VarHashRefCount(arrayPtr) == !TclIsVarDeadHash(arrayPtr))) {
 	if (VarHashRefCount(arrayPtr) == 0) {
-	    ckfree((char *) arrayPtr);
+	    ckfree(arrayPtr);
 	} else {
 	    VarHashDeleteEntry(arrayPtr);
 	}
@@ -660,7 +660,7 @@ TclObjLookupVarEx(
 		len2 = len1 - i - 2;
 		len1 = i;
 
-		newPart2 = ckalloc((unsigned) (len2+1));
+		newPart2 = ckalloc(len2 + 1);
 		memcpy(newPart2, part2, (unsigned) len2);
 		*(newPart2+len2) = '\0';
 		part2 = newPart2;
@@ -1024,8 +1024,7 @@ TclLookupSimpleVar(
 	tablePtr = varFramePtr->varTablePtr;
 	if (create) {
 	    if (tablePtr == NULL) {
-		tablePtr = (TclVarHashTable *)
-			ckalloc(sizeof(TclVarHashTable));
+		tablePtr = ckalloc(sizeof(TclVarHashTable));
 		TclInitVarHashTable(tablePtr, NULL);
 		varFramePtr->varTablePtr = tablePtr;
 	    }
@@ -1137,7 +1136,7 @@ TclLookupArrayElement(
 	}
 
 	TclSetVarArray(arrayPtr);
-	tablePtr = (TclVarHashTable *) ckalloc(sizeof(TclVarHashTable));
+	tablePtr = ckalloc(sizeof(TclVarHashTable));
 	arrayPtr->value.tablePtr = tablePtr;
 
 	if (TclIsVarInHash(arrayPtr) && TclGetVarNsPtr(arrayPtr)) {
@@ -2990,8 +2989,7 @@ TclArraySet(
 	}
     }
     TclSetVarArray(varPtr);
-    varPtr->value.tablePtr = (TclVarHashTable *)
-	    ckalloc(sizeof(TclVarHashTable));
+    varPtr->value.tablePtr = ckalloc(sizeof(TclVarHashTable));
     TclInitVarHashTable(varPtr->value.tablePtr, TclGetVarNsPtr(varPtr));
     return TCL_OK;
 }
@@ -3075,7 +3073,7 @@ ArrayStartSearchCmd(
      * Make a new array search with a free name.
      */
 
-    searchPtr = (ArraySearch *) ckalloc(sizeof(ArraySearch));
+    searchPtr = ckalloc(sizeof(ArraySearch));
     hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
     if (isNew) {
 	searchPtr->id = 1;
@@ -3417,7 +3415,7 @@ ArrayDoneSearchCmd(
 	    }
 	}
     }
-    ckfree((char *) searchPtr);
+    ckfree(searchPtr);
     return TCL_OK;
 }
 
@@ -5194,7 +5192,7 @@ DeleteSearches(
 	for (searchPtr = Tcl_GetHashValue(sPtr); searchPtr != NULL;
 		searchPtr = nextPtr) {
 	    nextPtr = searchPtr->nextPtr;
-	    ckfree((char *) searchPtr);
+	    ckfree(searchPtr);
 	}
 	arrayVarPtr->flags &= ~VAR_SEARCH_ACTIVE;
 	Tcl_DeleteHashEntry(sPtr);
@@ -5477,7 +5475,7 @@ DeleteArray(
 	TclClearVarNamespaceVar(elPtr);
     }
     VarHashDeleteTable(varPtr->value.tablePtr);
-    ckfree((char *) varPtr->value.tablePtr);
+    ckfree(varPtr->value.tablePtr);
 }
 
 /*
@@ -5697,7 +5695,7 @@ DupParsedVarName(
     if (arrayPtr != NULL) {
 	Tcl_IncrRefCount(arrayPtr);
 	elemLen = strlen(elem);
-	elemCopy = ckalloc(elemLen+1);
+	elemCopy = ckalloc(elemLen + 1);
 	memcpy(elemCopy, elem, elemLen);
 	*(elemCopy + elemLen) = '\0';
 	elem = elemCopy;
@@ -5730,7 +5728,7 @@ UpdateParsedVarName(
     len2 = strlen(part2);
 
     totalLen = len1 + len2 + 2;
-    p = ckalloc((unsigned) totalLen + 1);
+    p = ckalloc(totalLen + 1);
     objPtr->bytes = p;
     objPtr->length = totalLen;
 
@@ -6366,7 +6364,7 @@ AllocVarEntry(
     Tcl_HashEntry *hPtr;
     Var *varPtr;
 
-    varPtr = (Var *) ckalloc(sizeof(VarInHash));
+    varPtr = ckalloc(sizeof(VarInHash));
     varPtr->flags = VAR_IN_HASHTABLE;
     varPtr->value.objPtr = NULL;
     VarHashRefCount(varPtr) = 1;
@@ -6388,7 +6386,7 @@ FreeVarEntry(
 
     if (TclIsVarUndefined(varPtr) && !TclIsVarTraced(varPtr)
 	    && (VarHashRefCount(varPtr) == 1)) {
-	ckfree((char *) varPtr);
+	ckfree(varPtr);
     } else {
 	VarHashInvalidateEntry(varPtr);
 	TclSetVarUndefined(varPtr);
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 6dabd44..3ddc3fb 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -534,7 +534,7 @@ Tcl_ZlibStreamInit(
 		" TCL_ZLIB_STREAM_INFLATE");
     }
 
-    zshPtr = (ZlibStreamHandle *) ckalloc(sizeof(ZlibStreamHandle));
+    zshPtr = ckalloc(sizeof(ZlibStreamHandle));
     zshPtr->interp = interp;
     zshPtr->mode = mode;
     zshPtr->format = format;
@@ -617,7 +617,7 @@ Tcl_ZlibStreamInit(
 
     return TCL_OK;
  error:
-    ckfree((char *) zshPtr);
+    ckfree(zshPtr);
     return TCL_ERROR;
 }
 
@@ -725,7 +725,7 @@ ZlibStreamCleanup(
 	Tcl_DecrRefCount(zshPtr->currentInput);
     }
 
-    ckfree((char *) zshPtr);
+    ckfree(zshPtr);
 }
 
 /*
@@ -2691,8 +2691,7 @@ ZlibStackChannelTransform(
 				 * use a default. Ignored if not compressing
 				 * to produce gzip-format data. */
 {
-    ZlibChannelData *cd = (ZlibChannelData *)
-	    ckalloc(sizeof(ZlibChannelData));
+    ZlibChannelData *cd = ckalloc(sizeof(ZlibChannelData));
     Tcl_Channel chan;
     int wbits = 0;
     int e;
@@ -2790,7 +2789,7 @@ ZlibStackChannelTransform(
 	ckfree(cd->outBuffer);
 	deflateEnd(&cd->outStream);
     }
-    ckfree((char *) cd);
+    ckfree(cd);
     return NULL;
 }
 
diff --git a/macosx/tclMacOSXNotify.c b/macosx/tclMacOSXNotify.c
index 1b0cb2b..ef80192 100644
--- a/macosx/tclMacOSXNotify.c
+++ b/macosx/tclMacOSXNotify.c
@@ -967,7 +967,7 @@ Tcl_CreateFileHandler(
 	}
     }
     if (filePtr == NULL) {
-	filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+	filePtr = ckalloc(sizeof(FileHandler));
 	filePtr->fd = fd;
 	filePtr->readyMask = 0;
 	filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
@@ -1095,7 +1095,7 @@ Tcl_DeleteFileHandler(
     } else {
 	prevPtr->nextPtr = filePtr->nextPtr;
     }
-    ckfree((char *) filePtr);
+    ckfree(filePtr);
 }
 
 /*
@@ -1350,8 +1350,8 @@ QueueFileEvents(
 	 */
 
 	if (filePtr->readyMask == 0) {
-	    FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
-		    ckalloc(sizeof(FileHandlerEvent));
+	    FileHandlerEvent *fileEvPtr = ckalloc(sizeof(FileHandlerEvent));
+
 	    fileEvPtr->header.proc = FileHandlerEventProc;
 	    fileEvPtr->fd = filePtr->fd;
 	    Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c
index 5341141..aeb06ef 100644
--- a/unix/tclLoadDl.c
+++ b/unix/tclLoadDl.c
@@ -110,7 +110,7 @@ TclpDlopen(
 		Tcl_GetString(pathPtr), "\": ", errorStr, NULL);
 	return TCL_ERROR;
     }
-    newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
+    newHandle = ckalloc(sizeof(*newHandle));
     newHandle->clientData = handle;
     newHandle->findSymbolProcPtr = &FindSymbol;
     newHandle->unloadFileProcPtr = &UnloadFile;
@@ -202,10 +202,10 @@ UnloadFile(
 				 * TclpDlopen(). The loadHandle is a token
 				 * that represents the loaded file. */
 {
-    void *handle = (void *) loadHandle->clientData;
+    void *handle = loadHandle->clientData;
 
     dlclose(handle);
-    ckfree((char *) loadHandle);
+    ckfree(loadHandle);
 }
 
 /*
diff --git a/unix/tclLoadDyld.c b/unix/tclLoadDyld.c
index e2c3bab..4fa1954 100644
--- a/unix/tclLoadDyld.c
+++ b/unix/tclLoadDyld.c
@@ -280,8 +280,7 @@ TclpDlopen(
 			    | NSLINKMODULE_OPTION_RETURN_ON_ERROR);
 		    NSDestroyObjectFileImage(dyldObjFileImage);
 		    if (module) {
-			modulePtr = (Tcl_DyldModuleHandle *)
-				ckalloc(sizeof(Tcl_DyldModuleHandle));
+			modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
 			modulePtr->module = module;
 			modulePtr->nextPtr = NULL;
 			TclLoadDbgMsg("NSLinkModule() successful");
@@ -307,8 +306,7 @@ TclpDlopen(
 	    || dyldLibHeader || modulePtr
 #endif
     ) {
-	dyldLoadHandle = (Tcl_DyldLoadHandle *)
-		ckalloc(sizeof(Tcl_DyldLoadHandle));
+	dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle));
 #if TCL_DYLD_USE_DLFCN
 	dyldLoadHandle->dlHandle = dlHandle;
 #endif
@@ -316,7 +314,7 @@ TclpDlopen(
 	dyldLoadHandle->dyldLibHeader = dyldLibHeader;
 	dyldLoadHandle->modulePtr = modulePtr;
 #endif
-	newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
+	newHandle = ckalloc(sizeof(*newHandle));
 	newHandle->clientData = dyldLoadHandle;
 	newHandle->findSymbolProcPtr = &FindSymbol;
 	newHandle->unloadFileProcPtr = &UnloadFile;
@@ -413,8 +411,7 @@ FindSymbol(
 		    modulePtr = modulePtr->nextPtr;
 		}
 		if (modulePtr == NULL) {
-		    modulePtr = (Tcl_DyldModuleHandle *)
-			    ckalloc(sizeof(Tcl_DyldModuleHandle));
+		    modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
 		    modulePtr->module = module;
 		    modulePtr->nextPtr = dyldLoadHandle->modulePtr;
 		    dyldLoadHandle->modulePtr = modulePtr;
@@ -519,8 +516,8 @@ UnloadFile(
 	}
 #endif /* TCL_DYLD_USE_NSMODULE */
     }
-    ckfree((char *) dyldLoadHandle);
-    ckfree((char *) loadHandle);
+    ckfree(dyldLoadHandle);
+    ckfree(loadHandle);
 }
 
 /*
@@ -765,17 +762,16 @@ TclpLoadMemory(
      * Stash the module reference within the load handle we create and return.
      */
 
-    modulePtr = (Tcl_DyldModuleHandle *) ckalloc(sizeof(Tcl_DyldModuleHandle));
+    modulePtr = ckalloc(sizeof(Tcl_DyldModuleHandle));
     modulePtr->module = module;
     modulePtr->nextPtr = NULL;
-    dyldLoadHandle = (Tcl_DyldLoadHandle *)
-	    ckalloc(sizeof(Tcl_DyldLoadHandle));
+    dyldLoadHandle = ckalloc(sizeof(Tcl_DyldLoadHandle));
 #if TCL_DYLD_USE_DLFCN
     dyldLoadHandle->dlHandle = NULL;
 #endif
     dyldLoadHandle->dyldLibHeader = NULL;
     dyldLoadHandle->modulePtr = modulePtr;
-    newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
+    newHandle = ckalloc(sizeof(*newHandle));
     newHandle->clientData = dyldLoadHandle;
     newHandle->findSymbolProcPtr = &FindSymbol;
     newHandle->unloadFileProcPtr = &UnloadFile;
diff --git a/unix/tclLoadNext.c b/unix/tclLoadNext.c
index b6225f0..c74a29a 100644
--- a/unix/tclLoadNext.c
+++ b/unix/tclLoadNext.c
@@ -101,7 +101,7 @@ TclpDlopen(
     }
     NXCloseMemory(errorStream, NX_FREEBUFFER);
 
-    newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
+    newHandle = ckalloc(sizeof(*newHandle));
     newHandle->clientData = INT2PTR(1);
     newHandle->findSymbolProcPtr = &FindSymbol;
     newHandle->unloadFileProcPtr = &UnloadFile;
@@ -175,7 +175,7 @@ UnloadFile(
 				 * TclpDlopen(). The loadHandle is a token
 				 * that represents the loaded file. */
 {
-    ckfree((char*) loadHandle);
+    ckfree(loadHandle);
 }
 
 /*
diff --git a/unix/tclLoadOSF.c b/unix/tclLoadOSF.c
index 9ed49f2..fbd4d5f 100644
--- a/unix/tclLoadOSF.c
+++ b/unix/tclLoadOSF.c
@@ -124,7 +124,7 @@ TclpDlopen(
     } else {
 	pkg++;
     }
-    newHandle = (Tcl_LoadHandle*) ckalloc(sizeof(*newHandle));
+    newHandle = ckalloc(sizeof(*newHandle));
     newHandle->clientData = pkg;
     newHandle->findSymbolProcPtr = &FindSymbol;
     newHandle->unloadFileProcPtr = &UnloadFile;
@@ -188,7 +188,7 @@ UnloadFile(
 				 * TclpDlopen(). The loadHandle is a token
 				 * that represents the loaded file. */
 {
-    ckfree((char*) loadHandle);
+    ckfree(loadHandle);
 }
 
 /*
diff --git a/unix/tclLoadShl.c b/unix/tclLoadShl.c
index a7b41d7..9656983 100644
--- a/unix/tclLoadShl.c
+++ b/unix/tclLoadShl.c
@@ -104,7 +104,7 @@ TclpDlopen(
 		Tcl_PosixError(interp), (char *) NULL);
 	return TCL_ERROR;
     }
-    newHandle = (Tcl_LoadHandle) ckalloc(sizeof(*newHandle));
+    newHandle = ckalloc(sizeof(*newHandle));
     newHandle->clientData = handle;
     newHandle->findSymbolProcPtr = &FindSymbol;
     newHandle->unloadFileProcPtr = *unloadProcPtr = &UnloadFile;
@@ -190,7 +190,7 @@ UnloadFile(
 
     handle = (shl_t) (loadHandle -> clientData);
     shl_unload(handle);
-    ckfree((char*) loadHandle);
+    ckfree(loadHandle);
 }
 
 /*
diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c
index 302e171..6ee9b89 100644
--- a/unix/tclUnixChan.c
+++ b/unix/tclUnixChan.c
@@ -396,7 +396,7 @@ FileCloseProc(
 	    errorCode = errno;
 	}
     }
-    ckfree((char *) fsPtr);
+    ckfree(fsPtr);
     return errorCode;
 }
 
@@ -720,7 +720,7 @@ TtySetOptionProc(
 		Tcl_AppendResult(interp, "bad value for -xchar: "
 			"should be a list of two elements", NULL);
 	    }
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    return TCL_ERROR;
 	}
 
@@ -733,7 +733,7 @@ TtySetOptionProc(
 	Tcl_UtfToExternalDString(NULL, argv[1], -1, &ds);
 	iostate.c_cc[VSTOP] = *(const cc_t *) Tcl_DStringValue(&ds);
 	Tcl_DStringFree(&ds);
-	ckfree((char *) argv);
+	ckfree(argv);
 
 	SETIOSTATE(fsPtr->fd, &iostate);
 	return TCL_OK;
@@ -771,14 +771,14 @@ TtySetOptionProc(
 		Tcl_AppendResult(interp, "bad value for -ttycontrol: "
 			"should be a list of signal,value pairs", NULL);
 	    }
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    return TCL_ERROR;
 	}
 
 	GETCONTROL(fsPtr->fd, &control);
 	for (i = 0; i < argc-1; i += 2) {
 	    if (Tcl_GetBoolean(interp, argv[i+1], &flag) == TCL_ERROR) {
-		ckfree((char *) argv);
+		ckfree(argv);
 		return TCL_ERROR;
 	    }
 	    if (strncasecmp(argv[i], "DTR", strlen(argv[i])) == 0) {
@@ -790,7 +790,7 @@ TtySetOptionProc(
 		}
 #else /* !TIOCM_DTR */
 		UNSUPPORTED_OPTION("-ttycontrol DTR");
-		ckfree((char *) argv);
+		ckfree(argv);
 		return TCL_ERROR;
 #endif /* TIOCM_DTR */
 	    } else if (strncasecmp(argv[i], "RTS", strlen(argv[i])) == 0) {
@@ -802,7 +802,7 @@ TtySetOptionProc(
 		}
 #else /* !TIOCM_RTS*/
 		UNSUPPORTED_OPTION("-ttycontrol RTS");
-		ckfree((char *) argv);
+		ckfree(argv);
 		return TCL_ERROR;
 #endif /* TIOCM_RTS*/
 	    } else if (strncasecmp(argv[i], "BREAK", strlen(argv[i])) == 0) {
@@ -810,7 +810,7 @@ TtySetOptionProc(
 		SETBREAK(fsPtr->fd, flag);
 #else /* !SETBREAK */
 		UNSUPPORTED_OPTION("-ttycontrol BREAK");
-		ckfree((char *) argv);
+		ckfree(argv);
 		return TCL_ERROR;
 #endif /* SETBREAK */
 	    } else {
@@ -819,13 +819,13 @@ TtySetOptionProc(
 			    "\" for -ttycontrol: must be "
 			    "DTR, RTS or BREAK", NULL);
 		}
-		ckfree((char *) argv);
+		ckfree(argv);
 		return TCL_ERROR;
 	    }
 	} /* -ttycontrol options loop */
 
 	SETCONTROL(fsPtr->fd, &control);
-	ckfree((char *) argv);
+	ckfree(argv);
 	return TCL_OK;
     }
 
@@ -1458,7 +1458,7 @@ TtyInit(
 				 * initialized. */
     int initialize)
 {
-    TtyState *ttyPtr = (TtyState *) ckalloc((unsigned) sizeof(TtyState));
+    TtyState *ttyPtr = ckalloc(sizeof(TtyState));
     int stateUpdated = 0;
 
     GETIOSTATE(fd, &ttyPtr->savedState);
@@ -1609,7 +1609,7 @@ TclpOpenFileChannel(
     {
 	translation = NULL;
 	channelTypePtr = &fileChannelType;
-	fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
+	fsPtr = ckalloc(sizeof(FileState));
     }
 
     fsPtr->validMask = channelPermissions | TCL_EXCEPTION;
@@ -1685,7 +1685,7 @@ Tcl_MakeFileChannel(
 	return TclpMakeTcpClientChannelMode(INT2PTR(fd), mode);
     } else {
 	channelTypePtr = &fileChannelType;
-	fsPtr = (FileState *) ckalloc((unsigned) sizeof(FileState));
+	fsPtr = ckalloc(sizeof(FileState));
 	sprintf(channelName, "file%d", fd);
     }
 
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index b6a8b97..2be68c4 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -705,7 +705,7 @@ TclpGetNativeCwd(
 #endif
 
     if ((clientData == NULL) || strcmp(buffer, (const char*)clientData)) {
-	char *newCd = ckalloc((unsigned) strlen(buffer) + 1);
+	char *newCd = ckalloc(strlen(buffer) + 1);
 
 	strcpy(newCd, buffer);
 	return newCd;
@@ -1109,7 +1109,7 @@ TclNativeCreateNativeRep(
     Tcl_UtfToExternalDString(NULL, str, len, &ds);
     len = Tcl_DStringLength(&ds) + sizeof(char);
     Tcl_DecrRefCount(validPathPtr);
-    nativePathPtr = ckalloc((unsigned) len);
+    nativePathPtr = ckalloc(len);
     memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);
 
     Tcl_DStringFree(&ds);
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index 7bbdc5c..8f872d5 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -473,7 +473,7 @@ TclpInitLibraryPath(
 	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
 	    Tcl_DStringFree(&ds);
 	}
-	ckfree((char *) pathv);
+	ckfree(pathv);
     }
 
     /*
@@ -506,7 +506,7 @@ TclpInitLibraryPath(
 
     *encodingPtr = Tcl_GetEncoding(NULL, NULL);
     str = Tcl_GetStringFromObj(pathPtr, lengthPtr);
-    *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
+    *valuePtr = ckalloc((*lengthPtr) + 1);
     memcpy(*valuePtr, str, (size_t)(*lengthPtr)+1);
     Tcl_DecrRefCount(pathPtr);
 }
diff --git a/unix/tclUnixNotfy.c b/unix/tclUnixNotfy.c
index 34e1fbb..ebbbb78 100644
--- a/unix/tclUnixNotfy.c
+++ b/unix/tclUnixNotfy.c
@@ -460,7 +460,7 @@ Tcl_CreateFileHandler(
 	    }
 	}
 	if (filePtr == NULL) {
-	    filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+	    filePtr = ckalloc(sizeof(FileHandler));
 	    filePtr->fd = fd;
 	    filePtr->readyMask = 0;
 	    filePtr->nextPtr = tsdPtr->firstFileHandlerPtr;
@@ -579,7 +579,7 @@ Tcl_DeleteFileHandler(
 	} else {
 	    prevPtr->nextPtr = filePtr->nextPtr;
 	}
-	ckfree((char *) filePtr);
+	ckfree(filePtr);
     }
 }
 
@@ -870,7 +870,7 @@ Tcl_WaitForEvent(
 	     */
 
 	    if (filePtr->readyMask == 0) {
-		FileHandlerEvent *fileEvPtr = (FileHandlerEvent *)
+		FileHandlerEvent *fileEvPtr =
 			ckalloc(sizeof(FileHandlerEvent));
 
 		fileEvPtr->header.proc = FileHandlerEventProc;
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index 30a6da8..d01624c 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -761,7 +761,7 @@ TclpCreateCommandChannel(
 {
     char channelName[16 + TCL_INTEGER_SPACE];
     int channelId;
-    PipeState *statePtr = (PipeState *) ckalloc((unsigned) sizeof(PipeState));
+    PipeState *statePtr = ckalloc(sizeof(PipeState));
     int mode;
 
     statePtr->inFile = readFile;
@@ -893,7 +893,7 @@ TclGetAndDetachPids(
 	Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
     }
     if (pipePtr->numPids > 0) {
-	ckfree((char *) pipePtr->pidPtr);
+	ckfree(pipePtr->pidPtr);
 	pipePtr->numPids = 0;
     }
 }
@@ -1024,9 +1024,9 @@ PipeClose2Proc(
     }
 
     if (pipePtr->numPids != 0) {
-	ckfree((char *) pipePtr->pidPtr);
+	ckfree(pipePtr->pidPtr);
     }
-    ckfree((char *) pipePtr);
+    ckfree(pipePtr);
     if (errorCode == 0) {
 	return result;
     }
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index b55d1cb..35728e1 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -182,7 +182,7 @@ InitializeHostName(
 	    char *dot = strchr(u.nodename, '.');
 
 	    if (dot != NULL) {
-		char *node = ckalloc((unsigned) (dot - u.nodename + 1));
+		char *node = ckalloc(dot - u.nodename + 1);
 
 		memcpy(node, u.nodename, (size_t) (dot - u.nodename));
 		node[dot - u.nodename] = '\0';
@@ -228,7 +228,7 @@ InitializeHostName(
 
     *encodingPtr = Tcl_GetEncoding(NULL, NULL);
     *lengthPtr = strlen(native);
-    *valuePtr = ckalloc((unsigned) (*lengthPtr) + 1);
+    *valuePtr = ckalloc((*lengthPtr) + 1);
     memcpy(*valuePtr, native, (size_t)(*lengthPtr)+1);
 }
 
@@ -528,9 +528,9 @@ TcpCloseProc(
 	if (close(fds->fd) < 0) {
 	    errorCode = errno;
 	}
-	ckfree((char *) fds);
+	ckfree(fds);
     }
-    ckfree((char *) statePtr);
+    ckfree(statePtr);
     return errorCode;
 }
 
@@ -995,9 +995,9 @@ error:
      * Allocate a new TcpState for this socket.
      */
 
-    statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState));
+    statePtr = ckalloc(sizeof(TcpState));
     statePtr->flags = async ? TCP_ASYNC_CONNECT : 0;
-    statePtr->fds = (TcpFdList *) ckalloc((unsigned) sizeof(TcpFdList));
+    statePtr->fds = ckalloc(sizeof(TcpFdList));
     memset(statePtr->fds, (int) 0, sizeof(TcpFdList));
     statePtr->fds->fd = sock;
 
@@ -1108,8 +1108,8 @@ TclpMakeTcpClientChannelMode(
     TcpState *statePtr;
     char channelName[16 + TCL_INTEGER_SPACE];
 
-    statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState));
-    statePtr->fds = (TcpFdList *) ckalloc((unsigned) sizeof(TcpFdList));
+    statePtr = ckalloc(sizeof(TcpState));
+    statePtr->fds = ckalloc(sizeof(TcpFdList));
     memset(statePtr->fds, (int) 0, sizeof(TcpFdList));
     statePtr->fds->fd = PTR2INT(sock);
     statePtr->flags = 0;
@@ -1239,14 +1239,14 @@ Tcl_OpenTcpServer(
             close(sock);
             continue;
         }
-        newfds = (TcpFdList *) ckalloc((unsigned) sizeof(TcpFdList));
+        newfds = ckalloc(sizeof(TcpFdList));
         memset(newfds, (int) 0, sizeof(TcpFdList));
         if (statePtr == NULL) {
             /*
              * Allocate a new TcpState for this socket.
              */
             
-            statePtr = (TcpState *) ckalloc((unsigned) sizeof(TcpState));
+            statePtr = ckalloc(sizeof(TcpState));
             statePtr->fds = newfds;
             statePtr->acceptProc = acceptProc;
             statePtr->acceptProcData = acceptProcData;
@@ -1310,7 +1310,7 @@ TcpAccept(
     ClientData data,		/* Callback token. */
     int mask)			/* Not used. */
 {
-    TcpFdList *fds;		/* Client data of server socket. */
+    TcpFdList *fds = data;	/* Client data of server socket. */
     int newsock;		/* The new client socket */
     TcpState *newSockState;	/* State for new socket. */
     address addr;		/* The remote address */
@@ -1318,8 +1318,6 @@ TcpAccept(
     char channelName[16 + TCL_INTEGER_SPACE];
     char host[NI_MAXHOST], port[NI_MAXSERV];
     
-    fds = (TcpFdList *) data;
-
     len = sizeof(addr);
     newsock = accept(fds->fd, &(addr.sa), &len);
     if (newsock < 0) {
@@ -1333,10 +1331,10 @@ TcpAccept(
 
     (void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
 
-    newSockState = (TcpState *) ckalloc((unsigned) sizeof(TcpState));
+    newSockState = ckalloc(sizeof(TcpState));
 
     newSockState->flags = 0;
-    newSockState->fds = (TcpFdList *) ckalloc(sizeof(TcpFdList));
+    newSockState->fds = ckalloc(sizeof(TcpFdList));
     memset(newSockState->fds, (int) 0, sizeof(TcpFdList));
     newSockState->fds->fd = newsock;
     newSockState->acceptProc = NULL;
diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c
index 7a4300e..0469d7a 100644
--- a/unix/tclUnixThrd.c
+++ b/unix/tclUnixThrd.c
@@ -430,7 +430,7 @@ Tcl_MutexLock(
 	     * Double inside master lock check to avoid a race condition.
 	     */
 
-	    pmutexPtr = (pthread_mutex_t *) ckalloc(sizeof(pthread_mutex_t));
+	    pmutexPtr = ckalloc(sizeof(pthread_mutex_t));
 	    pthread_mutex_init(pmutexPtr, NULL);
 	    *mutexPtr = (Tcl_Mutex)pmutexPtr;
 	    TclRememberMutex(mutexPtr);
@@ -494,7 +494,7 @@ TclpFinalizeMutex(
 
     if (pmutexPtr != NULL) {
 	pthread_mutex_destroy(pmutexPtr);
-	ckfree((char *) pmutexPtr);
+	ckfree(pmutexPtr);
 	*mutexPtr = NULL;
     }
 }
@@ -540,9 +540,9 @@ Tcl_ConditionWait(
 	 */
 
 	if (*condPtr == NULL) {
-	    pcondPtr = (pthread_cond_t *) ckalloc(sizeof(pthread_cond_t));
+	    pcondPtr = ckalloc(sizeof(pthread_cond_t));
 	    pthread_cond_init(pcondPtr, NULL);
-	    *condPtr = (Tcl_Condition)pcondPtr;
+	    *condPtr = (Tcl_Condition) pcondPtr;
 	    TclRememberCondition(condPtr);
 	}
 	MASTER_UNLOCK;
@@ -624,9 +624,10 @@ TclpFinalizeCondition(
     Tcl_Condition *condPtr)
 {
     pthread_cond_t *pcondPtr = *(pthread_cond_t **)condPtr;
+
     if (pcondPtr != NULL) {
 	pthread_cond_destroy(pcondPtr);
-	ckfree((char *) pcondPtr);
+	ckfree(pcondPtr);
 	*condPtr = NULL;
     }
 }
diff --git a/unix/tclXtNotify.c b/unix/tclXtNotify.c
index 71215f4..50eb4a2 100644
--- a/unix/tclXtNotify.c
+++ b/unix/tclXtNotify.c
@@ -358,7 +358,7 @@ CreateFileHandler(
 	}
     }
     if (filePtr == NULL) {
-	filePtr = (FileHandler *) ckalloc(sizeof(FileHandler));
+	filePtr = ckalloc(sizeof(FileHandler));
 	filePtr->fd = fd;
 	filePtr->read = 0;
 	filePtr->write = 0;
@@ -469,7 +469,7 @@ DeleteFileHandler(
     if (filePtr->mask & TCL_EXCEPTION) {
 	XtRemoveInput(filePtr->except);
     }
-    ckfree((char *) filePtr);
+    ckfree(filePtr);
 }
 
 /*
@@ -524,7 +524,7 @@ FileProc(
      */
 
     filePtr->readyMask |= mask;
-    fileEvPtr = (FileHandlerEvent *) ckalloc(sizeof(FileHandlerEvent));
+    fileEvPtr = ckalloc(sizeof(FileHandlerEvent));
     fileEvPtr->header.proc = FileHandlerEventProc;
     fileEvPtr->fd = filePtr->fd;
     Tcl_QueueEvent((Tcl_Event *) fileEvPtr, TCL_QUEUE_TAIL);
diff --git a/win/tclAppInit.c b/win/tclAppInit.c
index 1f5fd5f..d6da500 100644
--- a/win/tclAppInit.c
+++ b/win/tclAppInit.c
@@ -258,8 +258,8 @@ setargv(
     #undef Tcl_Alloc
     #undef Tcl_DbCkalloc
 
-    argSpace = (TCHAR *) ckalloc(
-	    (unsigned) (size * sizeof(char *) + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR)));
+    argSpace = ckalloc(size * sizeof(char *)
+	    + (_tcslen(cmdLine) * sizeof(TCHAR)) + sizeof(TCHAR));
     argv = (TCHAR **) argSpace;
     argSpace += size * (sizeof(char *)/sizeof(TCHAR));
     size--;
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index adb265d..7972862 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -430,8 +430,8 @@ TclWinEncodingsCleanup(void)
     dlIter = driveLetterLookup;
     while (dlIter != NULL) {
 	dlIter2 = dlIter->nextPtr;
-	ckfree((char *) dlIter->volumeName);
-	ckfree((char *) dlIter);
+	ckfree(dlIter->volumeName);
+	ckfree(dlIter);
 	dlIter = dlIter2;
     }
     Tcl_MutexUnlock(&mountPointMap);
@@ -550,8 +550,8 @@ TclWinDriveLetterForVolMountPoint(
 	     * Now dlPtr2 points to the structure to free.
 	     */
 
-	    ckfree((char *) dlPtr2->volumeName);
-	    ckfree((char *) dlPtr2);
+	    ckfree(dlPtr2->volumeName);
+	    ckfree(dlPtr2);
 
 	    /*
 	     * Restart the loop - we could try to be clever and continue half
@@ -586,7 +586,7 @@ TclWinDriveLetterForVolMountPoint(
 		}
 	    }
 	    if (!alreadyStored) {
-		dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap));
+		dlPtr2 = ckalloc(sizeof(MountPointMap));
 		dlPtr2->volumeName = TclNativeDupInternalRep(Target);
 		dlPtr2->driveLetter = (char) drive[0];
 		dlPtr2->nextPtr = driveLetterLookup;
@@ -612,7 +612,7 @@ TclWinDriveLetterForVolMountPoint(
      * that fact and store '-1' so we don't have to look it up each time.
      */
 
-    dlPtr2 = (MountPointMap *) ckalloc(sizeof(MountPointMap));
+    dlPtr2 = ckalloc(sizeof(MountPointMap));
     dlPtr2->volumeName = TclNativeDupInternalRep((ClientData) mountPoint);
     dlPtr2->driveLetter = -1;
     dlPtr2->nextPtr = driveLetterLookup;
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index bbf7c92..6e1844b 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -274,7 +274,7 @@ FileCheckProc(
 	    infoPtr = infoPtr->nextPtr) {
 	if (infoPtr->watchMask && !(infoPtr->flags & FILE_PENDING)) {
 	    infoPtr->flags |= FILE_PENDING;
-	    evPtr = (FileEvent *) ckalloc(sizeof(FileEvent));
+	    evPtr = ckalloc(sizeof(FileEvent));
 	    evPtr->header.proc = FileEventProc;
 	    evPtr->infoPtr = infoPtr;
 	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -441,7 +441,7 @@ FileCloseProc(
 	    break;
 	}
     }
-    ckfree((char *)fileInfoPtr);
+    ckfree(fileInfoPtr);
     return errorCode;
 }
 
@@ -1322,7 +1322,7 @@ TclWinOpenFileChannel(
 	}
     }
 
-    infoPtr = (FileInfo *) ckalloc((unsigned) sizeof(FileInfo));
+    infoPtr = ckalloc(sizeof(FileInfo));
 
     /*
      * TIP #218. Removed the code inserting the new structure into the global
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
index a056040..1912433 100644
--- a/win/tclWinConsole.c
+++ b/win/tclWinConsole.c
@@ -428,7 +428,7 @@ ConsoleCheckProc(
 
 	if (needEvent) {
 	    infoPtr->flags |= CONSOLE_PENDING;
-	    evPtr = (ConsoleEvent *) ckalloc(sizeof(ConsoleEvent));
+	    evPtr = ckalloc(sizeof(ConsoleEvent));
 	    evPtr->header.proc = ConsoleEventProc;
 	    evPtr->infoPtr = infoPtr;
 	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -654,7 +654,7 @@ ConsoleCloseProc(
 	ckfree(consolePtr->writeBuf);
 	consolePtr->writeBuf = 0;
     }
-    ckfree((char*) consolePtr);
+    ckfree(consolePtr);
 
     return errorCode;
 }
@@ -810,7 +810,7 @@ ConsoleOutputProc(
 		ckfree(infoPtr->writeBuf);
 	    }
 	    infoPtr->writeBufLen = toWrite;
-	    infoPtr->writeBuf = ckalloc((size_t)toWrite);
+	    infoPtr->writeBuf = ckalloc(toWrite);
 	}
 	memcpy(infoPtr->writeBuf, buf, (size_t)toWrite);
 	infoPtr->toWrite = toWrite;
@@ -1343,7 +1343,7 @@ TclWinOpenConsoleChannel(
      * See if a channel with this handle already exists.
      */
 
-    infoPtr = (ConsoleInfo *) ckalloc((unsigned) sizeof(ConsoleInfo));
+    infoPtr = ckalloc(sizeof(ConsoleInfo));
     memset(infoPtr, 0, sizeof(ConsoleInfo));
 
     infoPtr->validMask = permissions;
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 94556e1..75f4345 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -386,9 +386,9 @@ DdeSetServerName(
      * We have found a unique name. Now add it to the registry.
      */
 
-    riPtr = (RegisteredInterp *) ckalloc(sizeof(RegisteredInterp));
+    riPtr = ckalloc(sizeof(RegisteredInterp));
     riPtr->interp = interp;
-    riPtr->name = ckalloc((unsigned int) strlen(actualName) + 1);
+    riPtr->name = ckalloc(strlen(actualName) + 1);
     riPtr->nextPtr = tsdPtr->interpListPtr;
     riPtr->handlerPtr = handlerPtr;
     if (riPtr->handlerPtr != NULL) {
@@ -657,7 +657,7 @@ DdeServerProc(
 	for (riPtr = tsdPtr->interpListPtr; riPtr != NULL;
 		riPtr = riPtr->nextPtr) {
 	    if (strcasecmp(riPtr->name, utilString) == 0) {
-		convPtr = (Conversation *) ckalloc(sizeof(Conversation));
+		convPtr = ckalloc(sizeof(Conversation));
 		convPtr->nextPtr = tsdPtr->currentConversations;
 		convPtr->returnPackagePtr = NULL;
 		convPtr->hConv = hConv;
@@ -687,7 +687,7 @@ DdeServerProc(
 		if (convPtr->returnPackagePtr != NULL) {
 		    Tcl_DecrRefCount(convPtr->returnPackagePtr);
 		}
-		ckfree((char *) convPtr);
+		ckfree(convPtr);
 		break;
 	    }
 	}
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index d37b6f4..07abc83 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -395,8 +395,8 @@ DoRenameFile(
 		Tcl_SetErrno(EXDEV);
 	    }
 
-	    ckfree((char *) srcArgv);
-	    ckfree((char *) dstArgv);
+	    ckfree(srcArgv);
+	    ckfree(dstArgv);
 	}
 
 	/*
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 620c454..a772015 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -173,7 +173,7 @@ static int		WinLink(const TCHAR *LinkSource,
 			    const TCHAR *LinkTarget, int linkAction);
 static int		WinSymLinkDirectory(const TCHAR *LinkDirectory,
 			    const TCHAR *LinkTarget);
-MODULE_SCOPE void tclWinDebugPanic(const char *format, ...);
+MODULE_SCOPE void	tclWinDebugPanic(const char *format, ...);
 
 /*
  *--------------------------------------------------------------------
@@ -199,8 +199,8 @@ WinLink(
      * Get the full path referenced by the target.
      */
 
-    if (!GetFullPathName(linkTargetPath, MAX_PATH,
-	    tempFileName, &tempFilePart)) {
+    if (!GetFullPathName(linkTargetPath, MAX_PATH, tempFileName,
+	    &tempFilePart)) {
 	/*
 	 * Invalid file.
 	 */
@@ -223,8 +223,8 @@ WinLink(
      * Get the full path referenced by the source file/directory.
      */
 
-    if (!GetFullPathName(linkSourcePath, MAX_PATH,
-	    tempFileName, &tempFilePart)) {
+    if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName,
+	    &tempFilePart)) {
 	/*
 	 * Invalid file.
 	 */
@@ -244,8 +244,6 @@ WinLink(
 	 */
 
 	TclWinConvertError(GetLastError());
-	return -1;
-
     } else if ((attr & FILE_ATTRIBUTE_DIRECTORY) == 0) {
 	/*
 	 * It is a file.
@@ -253,27 +251,24 @@ WinLink(
 
 	if (CreateHardLink == NULL) {
 	    Tcl_SetErrno(ENOTDIR);
-	    return -1;
-	}
+	} else if (linkAction & TCL_CREATE_HARD_LINK) {
+	    if (CreateHardLink(linkSourcePath, linkTargetPath, NULL)) {
+		/*
+		 * Success!
+		 */
 
-	if (linkAction & TCL_CREATE_HARD_LINK) {
-	    if (!CreateHardLink(linkSourcePath,
-		    linkTargetPath, NULL)) {
-		TclWinConvertError(GetLastError());
-		return -1;
+		return 0;
 	    }
-	    return 0;
 
+	    TclWinConvertError(GetLastError());
 	} else if (linkAction & TCL_CREATE_SYMBOLIC_LINK) {
 	    /*
 	     * Can't symlink files.
 	     */
 
 	    Tcl_SetErrno(ENOTDIR);
-	    return -1;
 	} else {
 	    Tcl_SetErrno(ENODEV);
-	    return -1;
 	}
     } else {
 	/*
@@ -290,12 +285,11 @@ WinLink(
 	     */
 
 	    Tcl_SetErrno(EISDIR);
-	    return -1;
 	} else {
 	    Tcl_SetErrno(ENODEV);
-	    return -1;
 	}
     }
+    return -1;
 }
 
 /*
@@ -320,8 +314,8 @@ WinReadLink(
      * Get the full path referenced by the target.
      */
 
-    if (!GetFullPathName(linkSourcePath, MAX_PATH,
-	    tempFileName, &tempFilePart)) {
+    if (!GetFullPathName(linkSourcePath, MAX_PATH, tempFileName,
+	    &tempFilePart)) {
 	/*
 	 * Invalid file.
 	 */
@@ -350,9 +344,9 @@ WinReadLink(
 
 	Tcl_SetErrno(ENOTDIR);
 	return NULL;
-    } else {
-	return WinReadLinkDirectory(linkSourcePath);
     }
+
+    return WinReadLinkDirectory(linkSourcePath);
 }
 
 /*
@@ -491,9 +485,8 @@ TclWinSymLinkDelete(
 
     memset(reparseBuffer, 0, sizeof(DUMMY_REPARSE_BUFFER));
     reparseBuffer->ReparseTag = IO_REPARSE_TAG_MOUNT_POINT;
-    hFile = CreateFile(linkOrigPath, GENERIC_WRITE, 0, NULL,
-	    OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT
-	    | FILE_FLAG_BACKUP_SEMANTICS, NULL);
+    hFile = CreateFile(linkOrigPath, GENERIC_WRITE, 0, NULL, OPEN_EXISTING,
+	    FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
 
     if (hFile != INVALID_HANDLE_VALUE) {
 	if (!DeviceIoControl(hFile, FSCTL_DELETE_REPARSE_POINT, reparseBuffer,
@@ -677,9 +670,8 @@ NativeReadReparse(
     HANDLE hFile;
     DWORD returnedLength;
 
-    hFile = CreateFile(linkDirPath, GENERIC_READ, 0, NULL,
-	    OPEN_EXISTING, FILE_FLAG_OPEN_REPARSE_POINT
-	    | FILE_FLAG_BACKUP_SEMANTICS, NULL);
+    hFile = CreateFile(linkDirPath, GENERIC_READ, 0, NULL, OPEN_EXISTING,
+	    FILE_FLAG_OPEN_REPARSE_POINT | FILE_FLAG_BACKUP_SEMANTICS, NULL);
 
     if (hFile == INVALID_HANDLE_VALUE) {
 	/*
@@ -787,8 +779,8 @@ NativeWriteReparse(
  *
  * tclWinDebugPanic --
  *
- *	Display a message. If a debugger is present, present it directly
- *  to the debugger, otherwise use a MessageBox.
+ *	Display a message. If a debugger is present, present it directly to
+ *	the debugger, otherwise use a MessageBox.
  *
  * Results:
  *	None.
@@ -813,20 +805,22 @@ tclWinDebugPanic(
 
     msgString[TCL_MAX_WARN_LEN-1] = L'\0';
     MultiByteToWideChar(CP_UTF8, 0, buf, -1, msgString, TCL_MAX_WARN_LEN);
+
     /*
      * Truncate MessageBox string if it is too long to not overflow the screen
      * and cause possible oversized window error.
      */
+
     if (msgString[TCL_MAX_WARN_LEN-1] != L'\0') {
-		memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
-	}
+	memcpy(msgString + (TCL_MAX_WARN_LEN - 5), L" ...", 5 * sizeof(WCHAR));
+    }
     if (IsDebuggerPresent()) {
 	OutputDebugStringW(msgString);
     } else {
-    MessageBeep(MB_ICONEXCLAMATION);
-    MessageBoxW(NULL, msgString, L"Fatal Error",
-	    MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
-	}
+	MessageBeep(MB_ICONEXCLAMATION);
+	MessageBoxW(NULL, msgString, L"Fatal Error",
+		MB_ICONSTOP | MB_OK | MB_TASKMODAL | MB_SETFOREGROUND);
+    }
 }
 
 /*
@@ -848,7 +842,8 @@ tclWinDebugPanic(
 
 void
 TclpFindExecutable(
-    const char *argv0)		/* If NULL, install PanicMessageBox, otherwise ignore */
+    const char *argv0)		/* If NULL, install PanicMessageBox, otherwise
+				 * ignore. */
 {
     WCHAR wName[MAX_PATH];
     char name[MAX_PATH * TCL_UTF_MAX];
@@ -857,6 +852,7 @@ TclpFindExecutable(
      * Under Windows we ignore argv0, and return the path for the file used to
      * create this process. Only if it is NULL, install a new panic handler.
      */
+
     if (argv0 == NULL) {
 	Tcl_SetPanicProc(tclWinDebugPanic);
     }
@@ -918,6 +914,7 @@ TclpMatchInDirectory(
 
     if (pattern == NULL || (*pattern == '\0')) {
 	Tcl_Obj *norm = Tcl_FSGetNormalizedPath(NULL, pathPtr);
+
 	if (norm != NULL) {
 	    /*
 	     * Match a single file directly.
@@ -1038,6 +1035,7 @@ TclpMatchInDirectory(
 
 	if (handle == INVALID_HANDLE_VALUE) {
 	    DWORD err = GetLastError();
+
 	    Tcl_DStringFree(&ds);
 	    if (err == ERROR_FILE_NOT_FOUND) {
 		/*
@@ -1138,6 +1136,7 @@ TclpMatchInDirectory(
 		if (checkDrive) {
 		    const char *fullname = Tcl_DStringAppend(&dsOrig, utfname,
 			    Tcl_DStringLength(&ds));
+
 		    isDrive = WinIsDrive(fullname, Tcl_DStringLength(&dsOrig));
 		    Tcl_DStringSetLength(&dsOrig, dirLength);
 		} else {
@@ -1328,81 +1327,80 @@ NativeMatchType(
 	 * If invisible, don't return the file.
 	 */
 
-	if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
+	return !(attr & FILE_ATTRIBUTE_HIDDEN && !isDrive);
+    }
+
+    if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
+	/*
+	 * If invisible.
+	 */
+
+	if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
 	    return 0;
 	}
     } else {
-	if (attr & FILE_ATTRIBUTE_HIDDEN && !isDrive) {
-	    /*
-	     * If invisible.
-	     */
-
-	    if ((types->perm == 0) || !(types->perm & TCL_GLOB_PERM_HIDDEN)) {
-		return 0;
-	    }
-	} else {
-	    /*
-	     * Visible.
-	     */
+	/*
+	 * Visible.
+	 */
 
-	    if (types->perm & TCL_GLOB_PERM_HIDDEN) {
-		return 0;
-	    }
+	if (types->perm & TCL_GLOB_PERM_HIDDEN) {
+	    return 0;
 	}
+    }
 
-	if (types->perm != 0) {
-	    if (((types->perm & TCL_GLOB_PERM_RONLY) &&
-			!(attr & FILE_ATTRIBUTE_READONLY)) ||
-		    ((types->perm & TCL_GLOB_PERM_R) &&
-			(0 /* File exists => R_OK on Windows */)) ||
-		    ((types->perm & TCL_GLOB_PERM_W) &&
-			(attr & FILE_ATTRIBUTE_READONLY)) ||
-		    ((types->perm & TCL_GLOB_PERM_X) &&
-			(!(attr & FILE_ATTRIBUTE_DIRECTORY)
-			 && !NativeIsExec(nativeName)))) {
-		return 0;
-	    }
+    if (types->perm != 0) {
+	if (((types->perm & TCL_GLOB_PERM_RONLY) &&
+		    !(attr & FILE_ATTRIBUTE_READONLY)) ||
+		((types->perm & TCL_GLOB_PERM_R) &&
+		    (0 /* File exists => R_OK on Windows */)) ||
+		((types->perm & TCL_GLOB_PERM_W) &&
+		    (attr & FILE_ATTRIBUTE_READONLY)) ||
+		((types->perm & TCL_GLOB_PERM_X) &&
+		    (!(attr & FILE_ATTRIBUTE_DIRECTORY)
+		    && !NativeIsExec(nativeName)))) {
+	    return 0;
 	}
-	if ((types->type & TCL_GLOB_TYPE_DIR)
-		&& (attr & FILE_ATTRIBUTE_DIRECTORY)) {
-	    /*
-	     * Quicker test for directory, which is a common case.
-	     */
+    }
 
-	    return 1;
+    if ((types->type & TCL_GLOB_TYPE_DIR)
+	    && (attr & FILE_ATTRIBUTE_DIRECTORY)) {
+	/*
+	 * Quicker test for directory, which is a common case.
+	 */
 
-	} else if (types->type != 0) {
-	    unsigned short st_mode;
-	    int isExec = NativeIsExec(nativeName);
+	return 1;
 
-	    st_mode = NativeStatMode(attr, 0, isExec);
+    } else if (types->type != 0) {
+	unsigned short st_mode;
+	int isExec = NativeIsExec(nativeName);
 
-	    /*
-	     * In order bcdpfls as in 'find -t'
-	     */
+	st_mode = NativeStatMode(attr, 0, isExec);
+
+	/*
+	 * In order bcdpfls as in 'find -t'
+	 */
 
-	    if (((types->type&TCL_GLOB_TYPE_BLOCK)    && S_ISBLK(st_mode)) ||
-		    ((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) ||
-		    ((types->type&TCL_GLOB_TYPE_DIR)  && S_ISDIR(st_mode)) ||
-		    ((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) ||
+	if (((types->type&TCL_GLOB_TYPE_BLOCK)    && S_ISBLK(st_mode)) ||
+		((types->type&TCL_GLOB_TYPE_CHAR) && S_ISCHR(st_mode)) ||
+		((types->type&TCL_GLOB_TYPE_DIR)  && S_ISDIR(st_mode)) ||
+		((types->type&TCL_GLOB_TYPE_PIPE) && S_ISFIFO(st_mode)) ||
 #ifdef S_ISSOCK
-		    ((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) ||
+		((types->type&TCL_GLOB_TYPE_SOCK) && S_ISSOCK(st_mode)) ||
 #endif
-		    ((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) {
-		/*
-		 * Do nothing - this file is ok.
-		 */
-	    } else {
+		((types->type&TCL_GLOB_TYPE_FILE) && S_ISREG(st_mode))) {
+	    /*
+	     * Do nothing - this file is ok.
+	     */
+	} else {
 #ifdef S_ISLNK
-		if (types->type & TCL_GLOB_TYPE_LINK) {
-		    st_mode = NativeStatMode(attr, 1, isExec);
-		    if (S_ISLNK(st_mode)) {
-			return 1;
-		    }
+	    if (types->type & TCL_GLOB_TYPE_LINK) {
+		st_mode = NativeStatMode(attr, 1, isExec);
+		if (S_ISLNK(st_mode)) {
+		    return 1;
 		}
-#endif
-		return 0;
 	    }
+#endif /* S_ISLNK */
+	    return 0;
 	}
     }
     return 1;
@@ -1450,16 +1448,14 @@ TclpGetUserHome(
     if (domain != NULL) {
 	Tcl_DStringInit(&ds);
 	wName = Tcl_UtfToUniCharDString(domain + 1, -1, &ds);
-	badDomain = NetGetDCName(NULL, wName,
-		(LPBYTE *) wDomainPtr);
+	badDomain = NetGetDCName(NULL, wName, (LPBYTE *) wDomainPtr);
 	Tcl_DStringFree(&ds);
 	nameLen = domain - name;
     }
     if (badDomain == 0) {
 	Tcl_DStringInit(&ds);
 	wName = Tcl_UtfToUniCharDString(name, nameLen, &ds);
-	if (NetUserGetInfo(wDomain, wName, 1,
-		(LPBYTE *) uiPtrPtr) == 0) {
+	if (NetUserGetInfo(wDomain, wName, 1, (LPBYTE *) uiPtrPtr) == 0) {
 	    wHomeDir = uiPtr->usri1_home_dir;
 	    if ((wHomeDir != NULL) && (wHomeDir[0] != L'\0')) {
 		Tcl_UniCharToUtfDString(wHomeDir, lstrlenW(wHomeDir),
@@ -1953,8 +1949,7 @@ TclpObjStat(
 
     TclWinFlushDirtyChannels();
 
-    return NativeStat(Tcl_FSGetNativePath(pathPtr),
-	    statPtr, 0);
+    return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 0);
 }
 
 /*
@@ -2048,21 +2043,19 @@ NativeStat(
 
 	if (GetFileAttributesEx(nativePath,
 		GetFileExInfoStandard, &data) != TRUE) {
-
 	    /*
 	     * We might have just been denied access
 	     */
 
 	    WIN32_FIND_DATA ffd;
-	    HANDLE hFind;
-	    hFind = FindFirstFile(nativePath, &ffd);
-	    if (hFind != INVALID_HANDLE_VALUE) {
-		memcpy(&data, &ffd, sizeof(data));
-		FindClose(hFind);
-	    } else {
+	    HANDLE hFind = FindFirstFile(nativePath, &ffd);
+
+	    if (hFind == INVALID_HANDLE_VALUE) {
 		Tcl_SetErrno(ENOENT);
 		return -1;
 	    }
+	    memcpy(&data, &ffd, sizeof(data));
+	    FindClose(hFind);
 	}
 
 	attr = data.dwFileAttributes;
@@ -2107,9 +2100,7 @@ NativeDev(
     TCHAR *nativePart;
     const char *fullPath;
 
-    GetFullPathName(nativePath, MAX_PATH, nativeFullPath,
-	    &nativePart);
-
+    GetFullPathName(nativePath, MAX_PATH, nativeFullPath, &nativePart);
     fullPath = Tcl_WinTCharToUtf(nativeFullPath, -1, &ds);
 
     if ((fullPath[0] == '\\') && (fullPath[1] == '\\')) {
@@ -2133,8 +2124,7 @@ NativeDev(
 	}
 	nativeVol = Tcl_WinUtfToTChar(fullPath, p - fullPath, &volString);
 	dw = (DWORD) -1;
-	GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL,
-		NULL, NULL, 0);
+	GetVolumeInformation(nativeVol, NULL, 0, &dw, NULL, NULL, NULL, 0);
 
 	/*
 	 * GetFullPathName() turns special devices like "NUL" into "\\.\NUL",
@@ -2246,8 +2236,9 @@ FromCTime(
     FILETIME *fileTime)		/* UTC Time */
 {
     LARGE_INTEGER convertedTime;
+
     convertedTime.QuadPart = ((LONGLONG) posixTime) * 10000000
-	+ POSIX_EPOCH_AS_FILETIME;
+	    + POSIX_EPOCH_AS_FILETIME;
     fileTime->dwLowDateTime = convertedTime.LowPart;
     fileTime->dwHighDateTime = convertedTime.HighPart;
 }
@@ -2314,8 +2305,7 @@ TclpObjLstat(
 
     TclWinFlushDirtyChannels();
 
-    return NativeStat(Tcl_FSGetNativePath(pathPtr),
-	    statPtr, 1);
+    return NativeStat(Tcl_FSGetNativePath(pathPtr), statPtr, 1);
 }
 
 #ifdef S_IFLNK
@@ -2355,7 +2345,7 @@ TclpObjLink(
 	return WinReadLink(LinkSource);
     }
 }
-#endif
+#endif /* S_IFLNK */
 
 /*
  *---------------------------------------------------------------------------
@@ -2396,16 +2386,14 @@ TclpFilesystemPathType(
 
     firstSeparator = strchr(path, '/');
     if (firstSeparator == NULL) {
-	found = GetVolumeInformation(
-			Tcl_FSGetNativePath(pathPtr), NULL, 0, NULL, NULL, NULL,
-		volType, VOL_BUF_SIZE);
+	found = GetVolumeInformation(Tcl_FSGetNativePath(pathPtr),
+		NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
     } else {
 	Tcl_Obj *driveName = Tcl_NewStringObj(path, firstSeparator - path+1);
 
 	Tcl_IncrRefCount(driveName);
-	found = GetVolumeInformation(
-			Tcl_FSGetNativePath(driveName), NULL, 0, NULL, NULL, NULL,
-		volType, VOL_BUF_SIZE);
+	found = GetVolumeInformation(Tcl_FSGetNativePath(driveName),
+		NULL, 0, NULL, NULL, NULL, volType, VOL_BUF_SIZE);
 	Tcl_DecrRefCount(driveName);
     }
 
@@ -2469,6 +2457,8 @@ TclpObjNormalizePath(
     Tcl_DString dsNorm;		/* This will hold the normalized string. */
     char *path, *currentPathEndPosition;
     Tcl_Obj *temp = NULL;
+    int isDrive = 1;
+    Tcl_DString ds;		/* Some workspace. */
 
     Tcl_DStringInit(&dsNorm);
     path = Tcl_GetString(pathPtr);
@@ -2479,11 +2469,11 @@ TclpObjNormalizePath(
 	 * of code. First that the native (NULL) encoding is basically ascii,
 	 * and second that symbolic links are not possible. Both of these
 	 * assumptions appear to be true of these operating systems.
+	 *
+	 * FIXME: This code branch may be derelict as those are not supported
+	 * platforms any more.
 	 */
 
-	int isDrive = 1;
-	Tcl_DString ds;
-
 	currentPathEndPosition = path + nextCheckpoint;
 	if (*currentPathEndPosition == '/') {
 	    currentPathEndPosition++;
@@ -2626,9 +2616,6 @@ TclpObjNormalizePath(
 	 * We're on WinNT (or 2000 or XP; something with an NT core).
 	 */
 
-	int isDrive = 1;
-	Tcl_DString ds;
-
 	currentPathEndPosition = path + nextCheckpoint;
 	if (*currentPathEndPosition == '/') {
 	    currentPathEndPosition++;
@@ -2669,7 +2656,8 @@ TclpObjNormalizePath(
 				    ((WCHAR *) nativePath)[i] = wc;
 				}
 			    }
-			    Tcl_DStringAppend(&dsNorm, (const char *)nativePath,
+			    Tcl_DStringAppend(&dsNorm,
+				    (const char *)nativePath,
 				    (int)(sizeof(WCHAR) * len));
 			    lastValidPathEnd = currentPathEndPosition;
 			}
@@ -2702,7 +2690,7 @@ TclpObjNormalizePath(
 			 * not be normalized, otherwise we could use:
 			 *
 			 * Tcl_GetStringFromObj(to, &pathLen);
-			 * nextCheckpoint = pathLen
+			 * nextCheckpoint = pathLen;
 			 *
 			 * So, instead we have to start from the beginning.
 			 */
@@ -2732,7 +2720,6 @@ TclpObjNormalizePath(
 
 			isDrive = 1;
 			Tcl_DStringFree(&dsNorm);
-			Tcl_DStringInit(&dsNorm);
 			Tcl_DStringFree(&ds);
 			continue;
 		    }
@@ -2747,6 +2734,7 @@ TclpObjNormalizePath(
 
 		if (isDrive) {
 		    WCHAR drive = ((WCHAR *) nativePath)[0];
+
 		    if (drive >= L'a') {
 			drive -= (L'a' - L'A');
 			((WCHAR *) nativePath)[0] = drive;
@@ -2776,9 +2764,10 @@ TclpObjNormalizePath(
 			 * path segment and continue.
 			 */
 
-			Tcl_DStringAppend(&dsNorm,
-				((const char *) nativePath) + Tcl_DStringLength(&ds)
-				- (dotLen * sizeof(TCHAR)), (int)(dotLen * sizeof(TCHAR)));
+			Tcl_DStringAppend(&dsNorm, ((const char *)nativePath)
+				+ Tcl_DStringLength(&ds)
+				- (dotLen * sizeof(TCHAR)),
+				(int)(dotLen * sizeof(TCHAR)));
 		    } else {
 			/*
 			 * Normal path.
@@ -2807,12 +2796,13 @@ TclpObjNormalizePath(
 			    FindClose(handle);
 			    Tcl_DStringAppend(&dsNorm, (const char *) L"/",
 				    sizeof(WCHAR));
-			    Tcl_DStringAppend(&dsNorm, (const char *) nativeName,
+			    Tcl_DStringAppend(&dsNorm,
+				    (const char *) nativeName,
 				    (int) (wcslen(nativeName)*sizeof(WCHAR)));
 			}
 		    }
 		}
-#endif
+#endif /* !TclNORM_LONG_PATH */
 		Tcl_DStringFree(&ds);
 		lastValidPathEnd = currentPathEndPosition;
 		if (cur == 0) {
@@ -2837,7 +2827,7 @@ TclpObjNormalizePath(
 	if (1) {
 	    WCHAR wpath[MAX_PATH];
 	    const TCHAR *nativePath =
-	    		Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds);
+		    Tcl_WinUtfToTChar(path, lastValidPathEnd - path, &ds);
 	    DWORD wpathlen = GetLongPathNameProc(nativePath,
 		    (TCHAR *) wpath, MAX_PATH);
 
@@ -2848,10 +2838,11 @@ TclpObjNormalizePath(
 	    if (wpath[0] >= L'a') {
 		wpath[0] -= (L'a' - L'A');
 	    }
-	    Tcl_DStringAppend(&dsNorm, (const char *)wpath, wpathlen*sizeof(WCHAR));
+	    Tcl_DStringAppend(&dsNorm, (const char *) wpath,
+		    wpathlen * sizeof(WCHAR));
 	    Tcl_DStringFree(&ds);
 	}
-#endif
+#endif /* TclNORM_LONG_PATH */
     }
 
     /*
@@ -2866,11 +2857,9 @@ TclpObjNormalizePath(
 	 * native encoding, so we have to convert it to Utf.
 	 */
 
-	Tcl_DString dsTemp;
-
-	Tcl_WinTCharToUtf((const TCHAR *)Tcl_DStringValue(&dsNorm),
-		Tcl_DStringLength(&dsNorm), &dsTemp);
-	nextCheckpoint = Tcl_DStringLength(&dsTemp);
+	Tcl_WinTCharToUtf((const TCHAR *) Tcl_DStringValue(&dsNorm),
+		Tcl_DStringLength(&dsNorm), &ds);
+	nextCheckpoint = Tcl_DStringLength(&ds);
 	if (*lastValidPathEnd != 0) {
 	    /*
 	     * Not the end of the string.
@@ -2880,7 +2869,7 @@ TclpObjNormalizePath(
 	    char *path;
 	    Tcl_Obj *tmpPathPtr;
 
-	    tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
+	    tmpPathPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
 		    nextCheckpoint);
 	    Tcl_AppendToObj(tmpPathPtr, lastValidPathEnd, -1);
 	    path = Tcl_GetStringFromObj(tmpPathPtr, &len);
@@ -2891,10 +2880,9 @@ TclpObjNormalizePath(
 	     * End of string was reached above.
 	     */
 
-	    Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&dsTemp),
-		    nextCheckpoint);
+	    Tcl_SetStringObj(pathPtr, Tcl_DStringValue(&ds), nextCheckpoint);
 	}
-	Tcl_DStringFree(&dsTemp);
+	Tcl_DStringFree(&ds);
     }
     Tcl_DStringFree(&dsNorm);
 
@@ -3143,7 +3131,7 @@ TclNativeCreateNativeRep(
     Tcl_WinUtfToTChar(str, len, &ds);
     len = Tcl_DStringLength(&ds) + sizeof(WCHAR);
     Tcl_DecrRefCount(validPathPtr);
-    nativePathPtr = ckalloc((unsigned) len);
+    nativePathPtr = ckalloc(len);
     memcpy(nativePathPtr, Tcl_DStringValue(&ds), (size_t) len);
 
     Tcl_DStringFree(&ds);
@@ -3180,7 +3168,7 @@ TclNativeDupInternalRep(
 
     len = sizeof(TCHAR) * (_tcslen((const TCHAR *) clientData) + 1);
 
-    copy = (char *) ckalloc(len);
+    copy = ckalloc(len);
     memcpy(copy, clientData, len);
     return copy;
 }
@@ -3230,8 +3218,8 @@ TclpUtime(
      * savings complications that utime gets wrong.
      */
 
-    fileHandle = CreateFile(native, FILE_WRITE_ATTRIBUTES,
-	    0, NULL, OPEN_EXISTING, flags, NULL);
+    fileHandle = CreateFile(native, FILE_WRITE_ATTRIBUTES, 0, NULL,
+	    OPEN_EXISTING, flags, NULL);
 
     if (fileHandle == INVALID_HANDLE_VALUE ||
 	    !SetFileTime(fileHandle, NULL, &lastAccessTime, &lastModTime)) {
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index 12f3386..fb53685 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -208,7 +208,7 @@ TclpInitLibraryPath(
 
     *encodingPtr = NULL;
     bytes = Tcl_GetStringFromObj(pathPtr, lengthPtr);
-    *valuePtr = ckalloc((unsigned)(*lengthPtr)+1);
+    *valuePtr = ckalloc((*lengthPtr) + 1);
     memcpy(*valuePtr, bytes, (size_t)(*lengthPtr)+1);
     Tcl_DecrRefCount(pathPtr);
 }
@@ -306,7 +306,7 @@ AppendEnvironment(
 	    objPtr = Tcl_NewStringObj(buf, -1);
 	}
 	Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
-	ckfree((char *) pathv);
+	ckfree(pathv);
     }
 }
 
@@ -355,7 +355,7 @@ InitializeDefaultLibraryDir(
     TclWinNoBackslash(name);
     sprintf(end + 1, "lib/tcl%s", TCL_VERSION);
     *lengthPtr = strlen(name);
-    *valuePtr = ckalloc((unsigned int) *lengthPtr + 1);
+    *valuePtr = ckalloc(*lengthPtr + 1);
     *encodingPtr = NULL;
     memcpy(*valuePtr, name, (size_t) *lengthPtr + 1);
 }
@@ -606,7 +606,7 @@ TclpFindVariable(
      */
 
     length = strlen(name);
-    nameUpper = (char *) ckalloc((unsigned) length+1);
+    nameUpper = ckalloc(length + 1);
     memcpy(nameUpper, name, (size_t) length+1);
     Tcl_UtfToUpper(nameUpper);
 
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index e3c4603..e877ebe 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -109,7 +109,7 @@ TclpDlopen(
 	size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
 		FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,
 		(LPTSTR) &lpMsgBuf, 0, NULL);
-	buf = (char *) ckalloc((unsigned) TCL_INTEGER_SPACE + size + 1);
+	buf = ckalloc(TCL_INTEGER_SPACE + size + 1);
 	sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
 #endif
 
@@ -148,8 +148,7 @@ TclpDlopen(
 	}
 	return TCL_ERROR;
     } else {
-	handlePtr =
-	    (Tcl_LoadHandle) ckalloc(sizeof(struct Tcl_LoadHandle_));
+	handlePtr = ckalloc(sizeof(struct Tcl_LoadHandle_));
 	handlePtr->clientData = (ClientData) hInstance;
 	handlePtr->findSymbolProcPtr = &FindSymbol;
 	handlePtr->unloadFileProcPtr = &UnloadFile;
@@ -231,8 +230,9 @@ UnloadFile(
 				 * that represents the loaded file. */
 {
     HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
+
     FreeLibrary(hInstance);
-    ckfree((char*) loadHandle);
+    ckfree(loadHandle);
 }
 
 /*
@@ -336,8 +336,7 @@ TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */
 		}
 	    }
 	    if (status != 0) {
-		dllDirectoryName = (WCHAR*)
-		    ckalloc((nameLen+1) * sizeof(WCHAR));
+		dllDirectoryName = ckalloc((nameLen+1) * sizeof(WCHAR));
 		wcscpy(dllDirectoryName, name);
 	    }
 	}
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 8706f23..74021e9 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -412,7 +412,7 @@ PipeCheckProc(
 
 	if (needEvent) {
 	    infoPtr->flags |= PIPE_PENDING;
-	    evPtr = (PipeEvent *) ckalloc(sizeof(PipeEvent));
+	    evPtr = ckalloc(sizeof(PipeEvent));
 	    evPtr->header.proc = PipeEventProc;
 	    evPtr->infoPtr = infoPtr;
 	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -443,7 +443,7 @@ TclWinMakeFile(
 {
     WinFile *filePtr;
 
-    filePtr = (WinFile *) ckalloc(sizeof(WinFile));
+    filePtr = ckalloc(sizeof(WinFile));
     filePtr->type = WIN_FILE;
     filePtr->handle = handle;
 
@@ -833,7 +833,7 @@ TclpCloseFile(
 	    if (filePtr->handle != NULL &&
 		    CloseHandle(filePtr->handle) == FALSE) {
 		TclWinConvertError(GetLastError());
-		ckfree((char *) filePtr);
+		ckfree(filePtr);
 		return -1;
 	    }
 	}
@@ -843,7 +843,7 @@ TclpCloseFile(
 	Tcl_Panic("TclpCloseFile: unexpected file type");
     }
 
-    ckfree((char *) filePtr);
+    ckfree(filePtr);
     return 0;
 }
 
@@ -1573,7 +1573,7 @@ TclpCreateCommandChannel(
 {
     char channelName[16 + TCL_INTEGER_SPACE];
     DWORD id;
-    PipeInfo *infoPtr = (PipeInfo *) ckalloc((unsigned) sizeof(PipeInfo));
+    PipeInfo *infoPtr = ckalloc(sizeof(PipeInfo));
 
     PipeInit();
 
@@ -1732,7 +1732,7 @@ TclGetAndDetachPids(
 	Tcl_DetachPids(1, &(pipePtr->pidPtr[i]));
     }
     if (pipePtr->numPids > 0) {
-	ckfree((char *) pipePtr->pidPtr);
+	ckfree(pipePtr->pidPtr);
 	pipePtr->numPids = 0;
     }
 }
@@ -1996,7 +1996,7 @@ PipeClose2Proc(
 
 	    errChan = Tcl_MakeFileChannel((ClientData) filePtr->handle,
 		    TCL_READABLE);
-	    ckfree((char *) filePtr);
+	    ckfree(filePtr);
 	} else {
 	    errChan = NULL;
 	}
@@ -2006,14 +2006,14 @@ PipeClose2Proc(
     }
 
     if (pipePtr->numPids > 0) {
-	ckfree((char *) pipePtr->pidPtr);
+	ckfree(pipePtr->pidPtr);
     }
 
     if (pipePtr->writeBuf != NULL) {
 	ckfree(pipePtr->writeBuf);
     }
 
-    ckfree((char*) pipePtr);
+    ckfree(pipePtr);
 
     if (errorCode == 0) {
 	return result;
@@ -2181,7 +2181,7 @@ PipeOutputProc(
 		ckfree(infoPtr->writeBuf);
 	    }
 	    infoPtr->writeBufLen = toWrite;
-	    infoPtr->writeBuf = ckalloc((unsigned int) toWrite);
+	    infoPtr->writeBuf = ckalloc(toWrite);
 	}
 	memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
 	infoPtr->toWrite = toWrite;
@@ -2563,7 +2563,7 @@ Tcl_WaitPid(
      */
 
     CloseHandle(infoPtr->hProcess);
-    ckfree((char*)infoPtr);
+    ckfree(infoPtr);
 
     return result;
 }
@@ -2591,7 +2591,7 @@ TclWinAddProcess(
     void *hProcess,		/* Handle to process */
     unsigned long id)		/* Global process identifier */
 {
-    ProcInfo *procPtr = (ProcInfo *) ckalloc(sizeof(ProcInfo));
+    ProcInfo *procPtr = ckalloc(sizeof(ProcInfo));
 
     PipeInit();
 
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 7c075b0..7462031 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -409,7 +409,7 @@ DeleteKey(
      */
 
     keyName = Tcl_GetStringFromObj(keyNameObj, &length);
-    buffer = ckalloc((unsigned) length + 1);
+    buffer = ckalloc(length + 1);
     strcpy(buffer, keyName);
 
     if (ParseKeyName(interp, buffer, &hostName, &rootKey,
@@ -591,7 +591,7 @@ GetKeyNames(
 	RegCloseKey(key);
 	return TCL_ERROR;
     }
-    buffer = (TCHAR *) ckalloc((maxSubKeyLen+1) * sizeof(TCHAR));
+    buffer = ckalloc((maxSubKeyLen+1) * sizeof(TCHAR));
 
     /*
      * Enumerate the subkeys.
@@ -627,7 +627,7 @@ GetKeyNames(
 	Tcl_SetObjResult(interp, resultPtr);
     }
 
-    ckfree((char *)buffer);
+    ckfree(buffer);
     RegCloseKey(key);
     return result;
 }
@@ -973,7 +973,7 @@ OpenKey(
     DWORD result;
 
     keyName = Tcl_GetStringFromObj(keyNameObj, &length);
-    buffer = ckalloc((unsigned) length + 1);
+    buffer = ckalloc(length + 1);
     strcpy(buffer, keyName);
 
     result = ParseKeyName(interp, buffer, &hostName, &rootKey, &keyName);
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 819d866..2bcc77c 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -529,7 +529,7 @@ SerialCheckProc(
 
 	if (needEvent) {
 	    infoPtr->flags |= SERIAL_PENDING;
-	    evPtr = (SerialEvent *) ckalloc(sizeof(SerialEvent));
+	    evPtr = ckalloc(sizeof(SerialEvent));
 	    evPtr->header.proc = SerialEventProc;
 	    evPtr->infoPtr = infoPtr;
 	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -708,7 +708,7 @@ SerialCloseProc(
 	ckfree(serialPtr->writeBuf);
 	serialPtr->writeBuf = NULL;
     }
-    ckfree((char*) serialPtr);
+    ckfree(serialPtr);
 
     if (errorCode == 0) {
 	return result;
@@ -1073,7 +1073,7 @@ SerialOutputProc(
 		ckfree(infoPtr->writeBuf);
 	    }
 	    infoPtr->writeBufLen = toWrite;
-	    infoPtr->writeBuf = ckalloc((unsigned int) toWrite);
+	    infoPtr->writeBuf = ckalloc(toWrite);
 	}
 	memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
 	infoPtr->toWrite = toWrite;
@@ -1480,7 +1480,7 @@ TclWinOpenSerialChannel(
 
     SerialInit();
 
-    infoPtr = (SerialInfo *) ckalloc((unsigned) sizeof(SerialInfo));
+    infoPtr = ckalloc(sizeof(SerialInfo));
     memset(infoPtr, 0, sizeof(SerialInfo));
 
     infoPtr->validMask = permissions;
@@ -1792,7 +1792,7 @@ SerialSetOptionProc(
 			"a list of two elements with each a single character",
 			NULL);
 	    }
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    return TCL_ERROR;
 	}
 
@@ -1823,7 +1823,7 @@ SerialSetOptionProc(
 	    }
 	    dcb.XoffChar = (char) character;
 	}
-	ckfree((char *) argv);
+	ckfree(argv);
 
 	if (!SetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
@@ -1850,7 +1850,7 @@ SerialSetOptionProc(
 			"\" for -ttycontrol: should be a list of "
 			"signal,value pairs", NULL);
 	    }
-	    ckfree((char *) argv);
+	    ckfree(argv);
 	    return TCL_ERROR;
 	}
 
@@ -1897,7 +1897,7 @@ SerialSetOptionProc(
 	    }
 	}
 
-	ckfree((char *) argv);
+	ckfree(argv);
 	return result;
     }
 
@@ -1923,7 +1923,7 @@ SerialSetOptionProc(
 	    inSize  = atoi(argv[0]);
 	    outSize = atoi(argv[1]);
 	}
-	ckfree((char *) argv);
+	ckfree(argv);
 
 	if ((argc < 1) || (argc > 2) || (inSize <= 0) || (outSize <= 0)) {
 	    if (interp != NULL) {
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index 2722e64..bd5f0f4 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -641,7 +641,7 @@ SocketCheckProc(
 	if ((infoPtr->readyEvents & infoPtr->watchEvents)
 		&& !(infoPtr->flags & SOCKET_PENDING)) {
 	    infoPtr->flags |= SOCKET_PENDING;
-	    evPtr = (SocketEvent *) ckalloc(sizeof(SocketEvent));
+	    evPtr = ckalloc(sizeof(SocketEvent));
 	    evPtr->header.proc = SocketEventProc;
 	    evPtr->socket = infoPtr->sockets->fd;
 	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -875,7 +875,7 @@ TcpCloseProc(
      * fear of damaging the list.
      */
 
-    ckfree((char *) infoPtr);
+    ckfree(infoPtr);
     return errorCode;
 }
 
@@ -951,10 +951,8 @@ static SocketInfo *
 NewSocketInfo(
     SOCKET socket)
 {
-    SocketInfo *infoPtr;
-    TcpFdList *fds;
-    infoPtr = (SocketInfo *) ckalloc((unsigned) sizeof(SocketInfo));
-    fds = (TcpFdList*) ckalloc(sizeof(TcpFdList));
+    SocketInfo *infoPtr = ckalloc(sizeof(SocketInfo));
+    TcpFdList *fds = ckalloc(sizeof(TcpFdList));
 
     fds->fd = socket;
     fds->next = NULL;
@@ -1130,7 +1128,7 @@ CreateSocket(
 		infoPtr->watchEvents |= FD_ACCEPT;
 
 	    } else {
-		newfds = (TcpFdList *) ckalloc((unsigned) sizeof(TcpFdList));
+		newfds = ckalloc(sizeof(TcpFdList));
 		memset(newfds, (int) 0, sizeof(TcpFdList));
 		newfds->fd = sock;
 		newfds->infoPtr = infoPtr;
@@ -2658,7 +2656,7 @@ InitializeHostName(
 
     *encodingPtr = Tcl_GetEncoding(NULL, "utf-8");
     *lengthPtr = Tcl_DStringLength(&ds);
-    *valuePtr = ckalloc((unsigned int) (*lengthPtr)+1);
+    *valuePtr = ckalloc((*lengthPtr) + 1);
     memcpy(*valuePtr, Tcl_DStringValue(&ds), (size_t)(*lengthPtr)+1);
     Tcl_DStringFree(&ds);
 }
diff --git a/win/tclWinTest.c b/win/tclWinTest.c
index e026cbe..6ef1157 100644
--- a/win/tclWinTest.c
+++ b/win/tclWinTest.c
@@ -544,7 +544,7 @@ TestplatformChmod(
 	    goto done;
 	}
 
-	secDesc = (BYTE *) ckalloc(secDescLen);
+	secDesc = ckalloc(secDescLen);
 	if (!GetFileSecurityA(nativePath, infoBits,
 		(PSECURITY_DESCRIPTOR) secDesc, secDescLen, &secDescLen2)
 		|| (secDescLen < secDescLen2)) {
@@ -556,7 +556,7 @@ TestplatformChmod(
      * Get the World SID.
      */
 
-    userSid = (SID *) ckalloc(GetSidLengthRequired((UCHAR) 1));
+    userSid = ckalloc(GetSidLengthRequired((UCHAR) 1));
     InitializeSid(userSid, &userSidAuthority, (BYTE) 1);
     *(GetSidSubAuthority(userSid, 0)) = SECURITY_WORLD_RID;
 
@@ -582,7 +582,7 @@ TestplatformChmod(
 
     newAclSize = ACLSize.AclBytesInUse + sizeof(ACCESS_DENIED_ACE)
 	    + GetLengthSid(userSid) - sizeof(DWORD);
-    newAcl = (ACL *) ckalloc(newAclSize);
+    newAcl = ckalloc(newAclSize);
 
     /*
      * Initialize the new ACL.
@@ -657,16 +657,16 @@ TestplatformChmod(
 
   done:
     if (secDesc) {
-	ckfree((char *) secDesc);
+	ckfree(secDesc);
     }
     if (newAcl) {
-	ckfree((char *) newAcl);
+	ckfree(newAcl);
     }
     if (userSid) {
-	ckfree((char *) userSid);
+	ckfree(userSid);
     }
     if (userDomain) {
-	ckfree((char *) userDomain);
+	ckfree(userDomain);
     }
 
     if (res != 0) {
diff --git a/win/tclWinThrd.c b/win/tclWinThrd.c
index 7ffe867..102fd40 100644
--- a/win/tclWinThrd.c
+++ b/win/tclWinThrd.c
@@ -503,7 +503,7 @@ Tcl_MutexLock(
 	 */
 
 	if (*mutexPtr == NULL) {
-	    csPtr = (CRITICAL_SECTION *) ckalloc(sizeof(CRITICAL_SECTION));
+	    csPtr = ckalloc(sizeof(CRITICAL_SECTION));
 	    InitializeCriticalSection(csPtr);
 	    *mutexPtr = (Tcl_Mutex)csPtr;
 	    TclRememberMutex(mutexPtr);
@@ -564,7 +564,7 @@ TclpFinalizeMutex(
 
     if (csPtr != NULL) {
 	DeleteCriticalSection(csPtr);
-	ckfree((char *) csPtr);
+	ckfree(csPtr);
 	*mutexPtr = NULL;
     }
 }
@@ -646,7 +646,7 @@ Tcl_ConditionWait(
 	 */
 
 	if (*condPtr == NULL) {
-	    winCondPtr = (WinCondition *) ckalloc(sizeof(WinCondition));
+	    winCondPtr = ckalloc(sizeof(WinCondition));
 	    InitializeCriticalSection(&winCondPtr->condLock);
 	    winCondPtr->firstPtr = NULL;
 	    winCondPtr->lastPtr = NULL;
@@ -857,7 +857,7 @@ TclpFinalizeCondition(
 
     if (winCondPtr != NULL) {
 	DeleteCriticalSection(&winCondPtr->condLock);
-	ckfree((char *) winCondPtr);
+	ckfree(winCondPtr);
 	*condPtr = NULL;
     }
 }
-- 
cgit v0.12


From de9eaa2261bbda12a5ba8a76ec1a29d28a8b651b Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 13 Mar 2011 06:59:04 +0000
Subject: * generic/tclExecute.c: remove TEBCreturn()

---
 ChangeLog            |  4 ++++
 generic/tclExecute.c | 37 ++++++++++---------------------------
 2 files changed, 14 insertions(+), 27 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 37bd48b..10f1f55 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-03-13  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclExecute.c: remove TEBCreturn()
+
 2011-03-12  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tcl.h (ckalloc,ckfree,ckrealloc): Moved casts into these
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a1f4479..a93de79 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -715,7 +715,6 @@ static Tcl_NRPostProc	CopyCallback;
 static Tcl_NRPostProc	ExprObjCallback;
 
 static Tcl_NRPostProc   TEBCresume;
-static Tcl_NRPostProc   TEBCreturn;
 
 /*
  * The structure below defines a bytecode Tcl object type to hold the
@@ -1993,13 +1992,9 @@ TclNRExecuteByteCode(
 #endif
 
     /*
-     * Push the callbacks for
-     *  - exception handling and cleanup
-     *  - bytecode execution
+     * Push the callback for bytecode execution
      */
     
-    TclNRAddCallback(interp, TEBCreturn, TD, NULL,
-	    NULL, NULL);
     TclNRAddCallback(interp, TEBCresume, TD,
 	    /*resume*/ INT2PTR(0), NULL, NULL);
     
@@ -2007,26 +2002,6 @@ TclNRExecuteByteCode(
 }
 
 static int
-TEBCreturn(
-    ClientData data[],
-    Tcl_Interp *interp,
-    int result)
-{
-    TEBCdata *TD = data[0];
-    ByteCode *codePtr = TD->codePtr;
-
-    if (--codePtr->refCount <= 0) {
-	TclCleanupByteCode(codePtr);
-    }
-    while (TD->expanded) {
-	TD = TD->expanded;
-    }
-    TclStackFree(interp, TD);	/* free my stack */
-
-    return result;
-}
-
-static int
 TEBCresume(
     ClientData data[],
     Tcl_Interp *interp,
@@ -2132,7 +2107,6 @@ TEBCresume(
 	    result = TCL_ERROR;
 	}
 	NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
-	NRE_ASSERT(TOP_CB(interp)->procPtr == TEBCreturn);
 	iPtr->cmdFramePtr = bcFramePtr->nextPtr;
 	if (iPtr->flags & INTERP_DEBUG_FRAME) {
 	    TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
@@ -6431,8 +6405,17 @@ TEBCresume(
     }
 
     iPtr->cmdFramePtr = bcFramePtr->nextPtr;
+    if (--codePtr->refCount <= 0) {
+	TclCleanupByteCode(codePtr);
+    }
+    while (TD->expanded) {
+	TD = TD->expanded;
+    }
+    TclStackFree(interp, TD);	/* free my stack */
+
     return result;
 }
+
 #undef codePtr
 #undef iPtr
 #undef bcFramePtr
-- 
cgit v0.12


From 444dc1aa718c0939ea6a941227f67bb39535c044 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 13 Mar 2011 12:54:43 +0000
Subject: remove TD->expanded, not needed now

---
 generic/tclExecute.c | 9 +--------
 1 file changed, 1 insertion(+), 8 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a93de79..26d3e04 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -171,8 +171,6 @@ static BuiltinFunc const tclBuiltinFuncTable[] = {
 typedef struct TEBCdata {
     ByteCode *codePtr;		/* Constant until the BC returns */
 				/* -----------------------------------------*/
-    struct TEBCdata *expanded;/* NULL if unchanged, pointer to the succesor
-				 * if it was expanded */
     const unsigned char *pc;	/* These fields are used on return TO this */
     ptrdiff_t *catchTop;	/* this level: they record the state when a */
     int cleanup;		/* new codePtr was received for NR */
@@ -1961,7 +1959,6 @@ TclNRExecuteByteCode(
     esPtr->tosPtr = initTosPtr;
     
     TD->codePtr     = codePtr;
-    TD->expanded    = NULL;
     TD->pc          = codePtr->codeStart;
     TD->catchTop    = initCatchTop;
     TD->cleanup     = 0;
@@ -2681,8 +2678,7 @@ TEBCresume(
 	     */
 
 	    esPtr = iPtr->execEnvPtr->execStackPtr;
-	    TD->expanded = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
-	    TD = TD->expanded;
+	    TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
 
 	    catchTop += moved;
 	    tosPtr += moved;
@@ -6408,9 +6404,6 @@ TEBCresume(
     if (--codePtr->refCount <= 0) {
 	TclCleanupByteCode(codePtr);
     }
-    while (TD->expanded) {
-	TD = TD->expanded;
-    }
     TclStackFree(interp, TD);	/* free my stack */
 
     return result;
-- 
cgit v0.12


From 9c2e378362223c670fe77827649dbdca520715c8 Mon Sep 17 00:00:00 2001
From: Kevin B Kenny <kennykb@acm.org>
Date: Sun, 13 Mar 2011 22:42:24 +0000
Subject: * generic/tclAssembly.c (BBEmitInstInt1): Changed parameter data
 types in an effort to silence a MSVC warning reported by Ashok P. Nadkarni.
 Unable to test, since both forms work on my machine in VC2005, 2008. 2010, in
 both release and debug builds. * tests/tclTest.c (TestdstringCmd): Restored
 MSVC buildability broken by [5574bdd262], which changed the effective return
 type of 'ckalloc' from 'char*' to 'void*'.

---
 ChangeLog             | 11 +++++++++++
 generic/tclAssembly.c |  4 ++--
 generic/tclTest.c     |  2 +-
 3 files changed, 14 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 10f1f55..372542e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2011-03-14  Kevin B. Kenny  <kennykb@acm.org>
+
+	* generic/tclAssembly.c (BBEmitInstInt1): Changed parameter
+	data types in an effort to silence a MSVC warning reported by
+	Ashok P. Nadkarni. Unable to test, since both forms work on
+	my machine in VC2005, 2008. 2010, in both release and debug
+	builds.
+	* tests/tclTest.c (TestdstringCmd): Restored MSVC buildability
+	broken by [5574bdd262], which changed the effective return type
+	of 'ckalloc' from 'char*' to 'void*'.
+
 2011-03-13  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclExecute.c: remove TEBCreturn()
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 45756eb..754941f 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -241,7 +241,7 @@ static void		BBAdjustStackDepth(BasicBlock* bbPtr, int consumed,
 static void		BBUpdateStackReqs(BasicBlock* bbPtr, int tblIdx,
 			    int count);
 static void		BBEmitInstInt1(AssemblyEnv* assemEnvPtr, int tblIdx,
-			    unsigned char opnd, int count);
+			    int opnd, int count);
 static void		BBEmitInstInt4(AssemblyEnv* assemEnvPtr, int tblIdx,
 			    int opnd, int count);
 static void		BBEmitInst1or4(AssemblyEnv* assemEnvPtr, int tblIdx,
@@ -652,7 +652,7 @@ static void
 BBEmitInstInt1(
     AssemblyEnv* assemEnvPtr,	/* Assembly environment */
     int tblIdx,			/* Index in TalInstructionTable of op */
-    unsigned char opnd,		/* 1-byte operand */
+    int opnd,			/* 1-byte operand */
     int count)			/* Operand count for variadic ops */
 {
     BBEmitOpcode(assemEnvPtr, tblIdx, count);
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 2e9a9e8..b757185 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -1767,7 +1767,7 @@ TestdstringCmd(
 	    strcpy(s, "This is a malloc-ed string");
 	    Tcl_SetResult(interp, s, TCL_DYNAMIC);
 	} else if (strcmp(argv[2], "special") == 0) {
-	    char *s = ckalloc(100) + 16;
+	    char *s = (char*)ckalloc(100) + 16;
 	    strcpy(s, "This is a specially-allocated string");
 	    Tcl_SetResult(interp, s, SpecialFree);
 	} else {
-- 
cgit v0.12


From efac6ea792b9082ca65d083e4364b6f7fa7fddda Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 17 Mar 2011 16:12:15 +0000
Subject: [Patch #3124683]: platform specific stuff in (tcl|tk)Main.c

---
 ChangeLog         |   5 +
 generic/tclMain.c | 285 +++++++++++++++++++++++++-----------------------------
 2 files changed, 135 insertions(+), 155 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 21bc07c..4ad8d68 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-03-17  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tkMain.c:  [Patch #3124683]: platform specific
+	stuff in (tcl|tk)Main.c
+
 2011-03-16  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclCkalloc.c: [Bug #3197864] pointer truncation on Win64
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 1b3b091..26383b5 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -2,6 +2,11 @@
  * tclMain.c --
  *
  *	Main program for Tcl shells and other Tcl-based applications.
+ *	This file contains a generic main program for Tcl shells and other
+ *	Tcl-based applications. It can be used as-is for many applications,
+ *	just by supplying a different appInitProc function for each specific
+ *	application. Or, it can be used as a template for creating new main
+ *	programs for Tcl applications.
  *
  * Copyright (c) 1988-1994 The Regents of the University of California.
  * Copyright (c) 1994-1997 Sun Microsystems, Inc.
@@ -45,23 +50,24 @@
 #   define TCHAR char
 #   define TEXT(arg) arg
 #   define _tcscmp strcmp
-#   define _tcslen strlen
-#   define _tcsncmp strncmp
 #endif
 
 /*
- * Further on, in UNICODE mode, we need to use functions like
- * Tcl_GetUnicodeFromObj, while otherwise Tcl_GetStringFromObj
- * is needed. Those macro's assure that the right functions
- * are used depending on the mode.
+ * Further on, in UNICODE mode, we need to use Tcl_NewUnicodeObj,
+ * while otherwise NewNativeObj is needed (which provides proper
+ * conversion from native encoding to UTF-8).
  */
-#ifndef UNICODE
-#   undef Tcl_GetUnicodeFromObj
-#   define Tcl_GetUnicodeFromObj Tcl_GetStringFromObj
-#   undef Tcl_NewUnicodeObj
-#   define Tcl_NewUnicodeObj Tcl_NewStringObj
-#   undef Tcl_WinTCharToUtf
-#   define Tcl_WinTCharToUtf(a,b,c) Tcl_ExternalToUtfDString(NULL,a,b,c)
+#ifdef UNICODE
+#   define NewNativeObj Tcl_NewUnicodeObj
+#else /* !UNICODE */
+    static Tcl_Obj *NewNativeObj(char *string, int length) {
+	Tcl_Obj *obj;
+	Tcl_DString ds;
+	Tcl_ExternalToUtfDString(NULL, string, length, &ds);
+	obj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
+	Tcl_DStringFree(&ds);
+	return obj;
+}
 #endif /* !UNICODE */
 
 /*
@@ -117,7 +123,7 @@ typedef struct InteractiveState {
  */
 
 MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void);
-static void		Prompt(Tcl_Interp *interp, PromptType *promptPtr);
+static void		Prompt(Tcl_Interp *interp, InteractiveState *isPtr);
 static void		StdinProc(ClientData clientData, int mask);
 
 #ifndef TCL_ASCII_MAIN
@@ -229,7 +235,7 @@ Tcl_SourceRCFile(
 {
     Tcl_DString temp;
     const char *fileName;
-    Tcl_Channel errChannel;
+    Tcl_Channel chan;
 
     fileName = Tcl_GetVar(interp, "tcl_rcFileName", TCL_GLOBAL_ONLY);
     if (fileName != NULL) {
@@ -253,10 +259,10 @@ Tcl_SourceRCFile(
 	    if (c != NULL) {
 		Tcl_Close(NULL, c);
 		if (Tcl_EvalFile(interp, fullName) != TCL_OK) {
-		    errChannel = Tcl_GetStdChannel(TCL_STDERR);
-		    if (errChannel) {
-			Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
-			Tcl_WriteChars(errChannel, "\n", 1);
+		    chan = Tcl_GetStdChannel(TCL_STDERR);
+		    if (chan) {
+			Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+			Tcl_WriteChars(chan, "\n", 1);
 		    }
 		}
 	    }
@@ -294,16 +300,19 @@ Tcl_MainEx(
 				 * but before starting to execute commands. */
     Tcl_Interp *interp)
 {
-    Tcl_Obj *path, *resultPtr, *argvPtr, *commandPtr = NULL;
+    Tcl_Obj *path, *resultPtr, *argvPtr, *appName;
     const char *encodingName = NULL;
-    PromptType prompt = PROMPT_START;
-    int code, length, tty, exitCode = 0;
+    int code, exitCode = 0;
     Tcl_MainLoopProc *mainLoopProc;
-    Tcl_Channel inChannel, outChannel, errChannel;
-    Tcl_DString appName;
+    Tcl_Channel chan;
+    InteractiveState is;
 
     Tcl_InitMemory(interp);
 
+    is.interp = interp;
+    is.prompt = PROMPT_START;
+    is.commandPtr = Tcl_NewObj();
+
     /*
      * If the application has not already set a startup script, parse the
      * first few command line arguments to determine the script path and
@@ -320,13 +329,13 @@ Tcl_MainEx(
 
 	if ((argc > 3) && (0 == _tcscmp(TEXT("-encoding"), argv[1]))
 		&& (TEXT('-') != argv[3][0])) {
-		Tcl_Obj *value = Tcl_NewUnicodeObj(argv[2], -1);
-	    Tcl_SetStartupScript(Tcl_NewUnicodeObj(argv[3], -1), Tcl_GetString(value));
+		Tcl_Obj *value = NewNativeObj(argv[2], -1);
+	    Tcl_SetStartupScript(NewNativeObj(argv[3], -1), Tcl_GetString(value));
 	    Tcl_DecrRefCount(value);
 	    argc -= 3;
 	    argv += 3;
 	} else if ((argc > 1) && (TEXT('-') != argv[1][0])) {
-	    Tcl_SetStartupScript(Tcl_NewUnicodeObj(argv[1], -1), NULL);
+	    Tcl_SetStartupScript(NewNativeObj(argv[1], -1), NULL);
 	    argc--;
 	    argv++;
 	}
@@ -334,16 +343,11 @@ Tcl_MainEx(
 
     path = Tcl_GetStartupScript(&encodingName);
     if (path == NULL) {
-	Tcl_WinTCharToUtf(argv[0], -1, &appName);
+	appName = NewNativeObj(argv[0], -1);
     } else {
-	const TCHAR *pathName = Tcl_GetUnicodeFromObj(path, &length);
-
-	Tcl_WinTCharToUtf(pathName, length * sizeof(TCHAR), &appName);
-	path = Tcl_NewStringObj(Tcl_DStringValue(&appName), -1);
-	Tcl_SetStartupScript(path, encodingName);
+	appName = path;
     }
-    Tcl_SetVar(interp, "argv0", Tcl_DStringValue(&appName), TCL_GLOBAL_ONLY);
-    Tcl_DStringFree(&appName);
+    Tcl_SetVar2Ex(interp, "argv0", NULL, appName, TCL_GLOBAL_ONLY);
     argc--;
     argv++;
 
@@ -351,12 +355,7 @@ Tcl_MainEx(
 
     argvPtr = Tcl_NewListObj(0, NULL);
     while (argc--) {
-	Tcl_DString ds;
-
-	Tcl_WinTCharToUtf(*argv++, -1, &ds);
-	Tcl_ListObjAppendElement(NULL, argvPtr, Tcl_NewStringObj(
-		Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
-	Tcl_DStringFree(&ds);
+	Tcl_ListObjAppendElement(NULL, argvPtr, NewNativeObj(*argv++, -1));
     }
     Tcl_SetVar2Ex(interp, "argv", NULL, argvPtr, TCL_GLOBAL_ONLY);
 
@@ -364,9 +363,9 @@ Tcl_MainEx(
      * Set the "tcl_interactive" variable.
      */
 
-    tty = isatty(0);
-    Tcl_SetVar(interp, "tcl_interactive", ((path == NULL) && tty) ? "1" : "0",
-	    TCL_GLOBAL_ONLY);
+    is.tty = isatty(0);
+    Tcl_SetVar2Ex(interp, "tcl_interactive", NULL,
+	    Tcl_NewIntObj(!path && is.tty), TCL_GLOBAL_ONLY);
 
     /*
      * Invoke application-specific initialization.
@@ -374,12 +373,12 @@ Tcl_MainEx(
 
     Tcl_Preserve(interp);
     if (appInitProc(interp) != TCL_OK) {
-	errChannel = Tcl_GetStdChannel(TCL_STDERR);
-	if (errChannel) {
-	    Tcl_WriteChars(errChannel,
+	chan = Tcl_GetStdChannel(TCL_STDERR);
+	if (chan) {
+	    Tcl_WriteChars(chan,
 		    "application-specific initialization failed: ", -1);
-	    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
-	    Tcl_WriteChars(errChannel, "\n", 1);
+	    Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+	    Tcl_WriteChars(chan, "\n", 1);
 	}
     }
     if (Tcl_InterpDeleted(interp)) {
@@ -390,16 +389,17 @@ Tcl_MainEx(
     }
 
     /*
-     * If a script file was specified then just source that file and quit.
-     * Must fetch it again, as the appInitProc might have reset it.
+     * Invoke the script specified on the command line, if any. Must fetch it
+     * again, as the appInitProc might have reset it.
      */
 
     path = Tcl_GetStartupScript(&encodingName);
     if (path != NULL) {
+	Tcl_ResetResult(interp);
 	code = Tcl_FSEvalFileEx(interp, path, encodingName);
 	if (code != TCL_OK) {
-	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
-	    if (errChannel) {
+	    chan = Tcl_GetStdChannel(TCL_STDERR);
+	    if (chan) {
 		Tcl_Obj *options = Tcl_GetReturnOptions(interp, code);
 		Tcl_Obj *keyPtr, *valuePtr;
 
@@ -409,9 +409,9 @@ Tcl_MainEx(
 		Tcl_DecrRefCount(keyPtr);
 
 		if (valuePtr) {
-		    Tcl_WriteObj(errChannel, valuePtr);
+		    Tcl_WriteObj(chan, valuePtr);
 		}
-		Tcl_WriteChars(errChannel, "\n", 1);
+		Tcl_WriteChars(chan, "\n", 1);
 		Tcl_DecrRefCount(options);
 	    }
 	    exitCode = 1;
@@ -435,40 +435,39 @@ Tcl_MainEx(
      * may have been changed.
      */
 
-    commandPtr = Tcl_NewObj();
-    Tcl_IncrRefCount(commandPtr);
+    Tcl_IncrRefCount(is.commandPtr);
 
     /*
      * Get a new value for tty if anyone writes to ::tcl_interactive
      */
 
-    Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty, TCL_LINK_BOOLEAN);
-    inChannel = Tcl_GetStdChannel(TCL_STDIN);
-    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
-    while ((inChannel != NULL) && !Tcl_InterpDeleted(interp)) {
+    Tcl_LinkVar(interp, "tcl_interactive", (char *) &is.tty, TCL_LINK_BOOLEAN);
+    is.input = Tcl_GetStdChannel(TCL_STDIN);
+    while ((is.input != NULL) && !Tcl_InterpDeleted(interp)) {
 	mainLoopProc = TclGetMainLoop();
 	if (mainLoopProc == NULL) {
-	    if (tty) {
-		Prompt(interp, &prompt);
+	    int length;
+	    if (is.tty) {
+		Prompt(interp, &is);
 		if (Tcl_InterpDeleted(interp)) {
 		    break;
 		}
 		if (Tcl_LimitExceeded(interp)) {
 		    break;
 		}
-		inChannel = Tcl_GetStdChannel(TCL_STDIN);
-		if (inChannel == NULL) {
+		is.input = Tcl_GetStdChannel(TCL_STDIN);
+		if (is.input == NULL) {
 		    break;
 		}
 	    }
-	    if (Tcl_IsShared(commandPtr)) {
-		Tcl_DecrRefCount(commandPtr);
-		commandPtr = Tcl_DuplicateObj(commandPtr);
-		Tcl_IncrRefCount(commandPtr);
+	    if (Tcl_IsShared(is.commandPtr)) {
+		Tcl_DecrRefCount(is.commandPtr);
+		is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
+		Tcl_IncrRefCount(is.commandPtr);
 	    }
-	    length = Tcl_GetsObj(inChannel, commandPtr);
+	    length = Tcl_GetsObj(is.input, is.commandPtr);
 	    if (length < 0) {
-		if (Tcl_InputBlocked(inChannel)) {
+		if (Tcl_InputBlocked(is.input)) {
 		    /*
 		     * This can only happen if stdin has been set to
 		     * non-blocking. In that case cycle back and try again.
@@ -493,45 +492,45 @@ Tcl_MainEx(
 	     * a difference. [Bug 1775878]
 	     */
 
-	    if (Tcl_IsShared(commandPtr)) {
-		Tcl_DecrRefCount(commandPtr);
-		commandPtr = Tcl_DuplicateObj(commandPtr);
-		Tcl_IncrRefCount(commandPtr);
+	    if (Tcl_IsShared(is.commandPtr)) {
+		Tcl_DecrRefCount(is.commandPtr);
+		is.commandPtr = Tcl_DuplicateObj(is.commandPtr);
+		Tcl_IncrRefCount(is.commandPtr);
 	    }
-	    Tcl_AppendToObj(commandPtr, "\n", 1);
-	    if (!TclObjCommandComplete(commandPtr)) {
-		prompt = PROMPT_CONTINUE;
+	    Tcl_AppendToObj(is.commandPtr, "\n", 1);
+	    if (!TclObjCommandComplete(is.commandPtr)) {
+		is.prompt = PROMPT_CONTINUE;
 		continue;
 	    }
 
-	    prompt = PROMPT_START;
+	    is.prompt = PROMPT_START;
 
 	    /*
 	     * The final newline is syntactically redundant, and causes some
 	     * error messages troubles deeper in, so lop it back off.
 	     */
 
-	    Tcl_GetStringFromObj(commandPtr, &length);
-	    Tcl_SetObjLength(commandPtr, --length);
-	    code = Tcl_RecordAndEvalObj(interp, commandPtr, TCL_EVAL_GLOBAL);
-	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
-	    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
-	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
-	    Tcl_DecrRefCount(commandPtr);
-	    commandPtr = Tcl_NewObj();
-	    Tcl_IncrRefCount(commandPtr);
+	    Tcl_GetStringFromObj(is.commandPtr, &length);
+	    Tcl_SetObjLength(is.commandPtr, --length);
+	    code = Tcl_RecordAndEvalObj(interp, is.commandPtr, TCL_EVAL_GLOBAL);
+	    is.input = Tcl_GetStdChannel(TCL_STDIN);
+	    Tcl_DecrRefCount(is.commandPtr);
+	    is.commandPtr = Tcl_NewObj();
+	    Tcl_IncrRefCount(is.commandPtr);
 	    if (code != TCL_OK) {
-		if (errChannel) {
-		    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
-		    Tcl_WriteChars(errChannel, "\n", 1);
+		chan = Tcl_GetStdChannel(TCL_STDERR);
+		if (chan) {
+		    Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+		    Tcl_WriteChars(chan, "\n", 1);
 		}
-	    } else if (tty) {
+	    } else if (is.tty) {
 		resultPtr = Tcl_GetObjResult(interp);
 		Tcl_IncrRefCount(resultPtr);
 		Tcl_GetStringFromObj(resultPtr, &length);
-		if ((length > 0) && outChannel) {
-		    Tcl_WriteObj(outChannel, resultPtr);
-		    Tcl_WriteChars(outChannel, "\n", 1);
+		chan = Tcl_GetStdChannel(TCL_STDOUT);
+		if ((length > 0) && chan) {
+		    Tcl_WriteObj(chan, resultPtr);
+		    Tcl_WriteChars(chan, "\n", 1);
 		}
 		Tcl_DecrRefCount(resultPtr);
 	    }
@@ -542,45 +541,21 @@ Tcl_MainEx(
 	     * channel handler for stdin.
 	     */
 
-	    InteractiveState *isPtr = NULL;
-
-	    if (inChannel) {
-		if (tty) {
-		    Prompt(interp, &prompt);
+	    if (is.input) {
+		if (is.tty) {
+		    Prompt(interp, &is);
 		}
-		isPtr = ckalloc(sizeof(InteractiveState));
-		isPtr->input = inChannel;
-		isPtr->tty = tty;
-		isPtr->commandPtr = commandPtr;
-		isPtr->prompt = prompt;
-		isPtr->interp = interp;
-
-		Tcl_UnlinkVar(interp, "tcl_interactive");
-		Tcl_LinkVar(interp, "tcl_interactive", (char *) &isPtr->tty,
-			TCL_LINK_BOOLEAN);
-
-		Tcl_CreateChannelHandler(inChannel, TCL_READABLE, StdinProc,
-			isPtr);
+
+		Tcl_CreateChannelHandler(is.input, TCL_READABLE, StdinProc, &is);
 	    }
 
 	    mainLoopProc();
 	    Tcl_SetMainLoop(NULL);
 
-	    if (inChannel) {
-		tty = isPtr->tty;
-		Tcl_UnlinkVar(interp, "tcl_interactive");
-		Tcl_LinkVar(interp, "tcl_interactive", (char *) &tty,
-			TCL_LINK_BOOLEAN);
-		prompt = isPtr->prompt;
-		commandPtr = isPtr->commandPtr;
-		if (isPtr->input != NULL) {
-		    Tcl_DeleteChannelHandler(isPtr->input, StdinProc, isPtr);
-		}
-		ckfree(isPtr);
+	    if (is.input) {
+		Tcl_DeleteChannelHandler(is.input, StdinProc, &is);
 	    }
-	    inChannel = Tcl_GetStdChannel(TCL_STDIN);
-	    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
-	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
+	    is.input = Tcl_GetStdChannel(TCL_STDIN);
 	}
 #ifdef TCL_MEM_DEBUG
 
@@ -609,8 +584,8 @@ Tcl_MainEx(
 	mainLoopProc();
 	Tcl_SetMainLoop(NULL);
     }
-    if (commandPtr != NULL) {
-	Tcl_DecrRefCount(commandPtr);
+    if (is.commandPtr != NULL) {
+	Tcl_DecrRefCount(is.commandPtr);
     }
 
     /*
@@ -746,11 +721,11 @@ StdinProc(
     ClientData clientData,	/* The state of interactive cmd line */
     int mask)			/* Not used. */
 {
+    int code, length;
     InteractiveState *isPtr = clientData;
     Tcl_Channel chan = isPtr->input;
     Tcl_Obj *commandPtr = isPtr->commandPtr;
     Tcl_Interp *interp = isPtr->interp;
-    int code, length;
 
     if (Tcl_IsShared(commandPtr)) {
 	Tcl_DecrRefCount(commandPtr);
@@ -806,21 +781,21 @@ StdinProc(
 	Tcl_CreateChannelHandler(chan, TCL_READABLE, StdinProc, isPtr);
     }
     if (code != TCL_OK) {
-	Tcl_Channel errChannel = Tcl_GetStdChannel(TCL_STDERR);
+	chan = Tcl_GetStdChannel(TCL_STDERR);
 
-	if (errChannel != NULL) {
-	    Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
-	    Tcl_WriteChars(errChannel, "\n", 1);
+	if (chan != NULL) {
+	    Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+	    Tcl_WriteChars(chan, "\n", 1);
 	}
     } else if (isPtr->tty) {
 	Tcl_Obj *resultPtr = Tcl_GetObjResult(interp);
-	Tcl_Channel outChannel = Tcl_GetStdChannel(TCL_STDOUT);
+	chan = Tcl_GetStdChannel(TCL_STDOUT);
 
 	Tcl_IncrRefCount(resultPtr);
 	Tcl_GetStringFromObj(resultPtr, &length);
-	if ((length >0) && (outChannel != NULL)) {
-	    Tcl_WriteObj(outChannel, resultPtr);
-	    Tcl_WriteChars(outChannel, "\n", 1);
+	if ((length > 0) && (chan != NULL)) {
+	    Tcl_WriteObj(chan, resultPtr);
+	    Tcl_WriteChars(chan, "\n", 1);
 	}
 	Tcl_DecrRefCount(resultPtr);
     }
@@ -831,7 +806,7 @@ StdinProc(
 
   prompt:
     if (isPtr->tty && (isPtr->input != NULL)) {
-	Prompt(interp, &isPtr->prompt);
+	Prompt(interp, isPtr);
 	isPtr->input = Tcl_GetStdChannel(TCL_STDIN);
     }
 }
@@ -856,20 +831,20 @@ StdinProc(
 static void
 Prompt(
     Tcl_Interp *interp,		/* Interpreter to use for prompting. */
-    PromptType *promptPtr)	/* Points to type of prompt to print. Filled
+    InteractiveState *isPtr) /* InteractiveState. Filled
 				 * with PROMPT_NONE after a prompt is
 				 * printed. */
 {
     Tcl_Obj *promptCmdPtr;
     int code;
-    Tcl_Channel outChannel, errChannel;
+    Tcl_Channel chan;
 
-    if (*promptPtr == PROMPT_NONE) {
+    if (isPtr->prompt == PROMPT_NONE) {
 	return;
     }
 
     promptCmdPtr = Tcl_GetVar2Ex(interp,
-	    ((*promptPtr == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
+	    ((isPtr->prompt == PROMPT_CONTINUE) ? "tcl_prompt2" : "tcl_prompt1"),
 	    NULL, TCL_GLOBAL_ONLY);
 
     if (Tcl_InterpDeleted(interp)) {
@@ -877,10 +852,10 @@ Prompt(
     }
     if (promptCmdPtr == NULL) {
     defaultPrompt:
-	if (*promptPtr == PROMPT_START) {
-	    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
-	    if (outChannel != NULL) {
-		Tcl_WriteChars(outChannel, DEFAULT_PRIMARY_PROMPT,
+	if (isPtr->prompt == PROMPT_START) {
+	    chan = Tcl_GetStdChannel(TCL_STDOUT);
+	    if (chan != NULL) {
+		Tcl_WriteChars(chan, DEFAULT_PRIMARY_PROMPT,
 			strlen(DEFAULT_PRIMARY_PROMPT));
 	    }
 	}
@@ -889,20 +864,20 @@ Prompt(
 	if (code != TCL_OK) {
 	    Tcl_AddErrorInfo(interp,
 		    "\n    (script that generates prompt)");
-	    errChannel = Tcl_GetStdChannel(TCL_STDERR);
-	    if (errChannel != NULL) {
-		Tcl_WriteObj(errChannel, Tcl_GetObjResult(interp));
-		Tcl_WriteChars(errChannel, "\n", 1);
+	    chan = Tcl_GetStdChannel(TCL_STDERR);
+	    if (chan != NULL) {
+		Tcl_WriteObj(chan, Tcl_GetObjResult(interp));
+		Tcl_WriteChars(chan, "\n", 1);
 	    }
 	    goto defaultPrompt;
 	}
     }
 
-    outChannel = Tcl_GetStdChannel(TCL_STDOUT);
-    if (outChannel != NULL) {
-	Tcl_Flush(outChannel);
+    chan = Tcl_GetStdChannel(TCL_STDOUT);
+    if (chan != NULL) {
+	Tcl_Flush(chan);
     }
-    *promptPtr = PROMPT_NONE;
+    isPtr->prompt = PROMPT_NONE;
 }
 
 /*
-- 
cgit v0.12


From df469c8ffaea0347ffe69bd2b776e7840a25d645 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 17 Mar 2011 22:00:27 +0000
Subject: Generate errorCode information on failure to parse expressions.

---
 ChangeLog             |  13 ++--
 generic/tclCompExpr.c | 170 ++++++++++++++++++++++++++++++--------------------
 2 files changed, 112 insertions(+), 71 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 4ad8d68..ccf4160 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,12 +1,17 @@
+2011-03-17  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCompExpr.c (ParseExpr): Generate errorCode information on
+	failure to parse expressions.
+
 2011-03-17  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tkMain.c:  [Patch #3124683]: platform specific
-	stuff in (tcl|tk)Main.c
+	* generic/tkMain.c: [Patch 3124683]: Reorganize the platform-specific
+	stuff in (tcl|tk)Main.c.
 
 2011-03-16  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclCkalloc.c: [Bug #3197864] pointer truncation on Win64
-	TCL_MEM_DEBUG builds
+	* generic/tclCkalloc.c: [Bug 3197864]: Pointer truncation on Win64
+	TCL_MEM_DEBUG builds.
 
 2011-03-16  Don Porter  <dgp@users.sourceforge.net>
 
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index d25aa07..a07d6df 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -605,6 +605,12 @@ ParseExpr(
 				 * for the error message, supplying more
 				 * information after the error msg and
 				 * location have been reported. */
+    const char *errCode = NULL;	/* The detail word of the errorCode list, or
+				 * NULL to indicate that no changes to the
+				 * errorCode are to be done. */
+    const char *subErrCode = NULL;
+				/* Extra information for use in generating the
+				 * errorCode. */
     const char *mark = "_@_";	/* In the portion of the complete error
 				 * message where the error location is
 				 * reported, this "mark" substring is inserted
@@ -624,6 +630,7 @@ ParseExpr(
     nodes = attemptckalloc(nodesAvailable * sizeof(OpNode));
     if (nodes == NULL) {
 	TclNewLiteralStringObj(msg, "not enough memory to parse expression");
+	errCode = "NOMEM";
 	goto error;
     }
 
@@ -674,6 +681,7 @@ ParseExpr(
 	    if (newPtr == NULL) {
 		TclNewLiteralStringObj(msg,
 			"not enough memory to parse expression");
+		errCode = "NOMEM";
 		goto error;
 	    }
 	    nodesAvailable = size;
@@ -691,16 +699,23 @@ ParseExpr(
 
 	scanned = ParseLexeme(start, numBytes, &lexeme, &literal);
 
-	/* Use context to categorize the lexemes that are ambiguous. */
+	/*
+	 * Use context to categorize the lexemes that are ambiguous.
+	 */
+
 	if ((NODE_TYPE & lexeme) == 0) {
+	    int b;
+
 	    switch (lexeme) {
 	    case INVALID:
-		msg = Tcl_ObjPrintf(
-			"invalid character \"%.*s\"", scanned, start);
+		msg = Tcl_ObjPrintf("invalid character \"%.*s\"",
+			scanned, start);
+		errCode = "BADCHAR";
 		goto error;
 	    case INCOMPLETE:
-		msg = Tcl_ObjPrintf(
-			"incomplete operator \"%.*s\"", scanned, start);
+		msg = Tcl_ObjPrintf("incomplete operator \"%.*s\"",
+			scanned, start);
+		errCode = "PARTOP";
 		goto error;
 	    case BAREWORD:
 
@@ -723,53 +738,51 @@ ParseExpr(
 		     */
 
 		    Tcl_ListObjAppendElement(NULL, funcList, literal);
+		} else if (Tcl_GetBooleanFromObj(NULL,literal,&b) == TCL_OK) {
+		    lexeme = BOOLEAN;
 		} else {
-		    int b;
-		    if (Tcl_GetBooleanFromObj(NULL, literal, &b) == TCL_OK) {
-			lexeme = BOOLEAN;
-		    } else {
-			Tcl_DecrRefCount(literal);
-			msg = Tcl_ObjPrintf(
-				"invalid bareword \"%.*s%s\"",
-				(scanned < limit) ? scanned : limit - 3, start,
-				(scanned < limit) ? "" : "...");
-			post = Tcl_ObjPrintf(
-				"should be \"$%.*s%s\" or \"{%.*s%s}\"",
-				(scanned < limit) ? scanned : limit - 3,
-				start, (scanned < limit) ? "" : "...",
-				(scanned < limit) ? scanned : limit - 3,
-				start, (scanned < limit) ? "" : "...");
-			Tcl_AppendPrintfToObj(post,
-				" or \"%.*s%s(...)\" or ...",
-				(scanned < limit) ? scanned : limit - 3,
-				start, (scanned < limit) ? "" : "...");
-			if (NotOperator(lastParsed)) {
-			    if ((lastStart[0] == '0')
-				    && ((lastStart[1] == 'o')
-				    || (lastStart[1] == 'O'))
-				    && (lastStart[2] >= '0')
-				    && (lastStart[2] <= '9')) {
-				const char *end = lastStart + 2;
-				Tcl_Obj *copy;
-
-				while (isdigit(UCHAR(*end))) {
-				    end++;
-				}
-				copy = Tcl_NewStringObj(lastStart,
-					end - lastStart);
-				if (TclCheckBadOctal(NULL,
-					Tcl_GetString(copy))) {
-				    Tcl_AppendToObj(post,
-					    "(invalid octal number?)", -1);
-				}
-				Tcl_DecrRefCount(copy);
+		    Tcl_DecrRefCount(literal);
+		    msg = Tcl_ObjPrintf("invalid bareword \"%.*s%s\"",
+			    (scanned < limit) ? scanned : limit - 3, start,
+			    (scanned < limit) ? "" : "...");
+		    post = Tcl_ObjPrintf(
+			    "should be \"$%.*s%s\" or \"{%.*s%s}\"",
+			    (scanned < limit) ? scanned : limit - 3,
+			    start, (scanned < limit) ? "" : "...",
+			    (scanned < limit) ? scanned : limit - 3,
+			    start, (scanned < limit) ? "" : "...");
+		    Tcl_AppendPrintfToObj(post, " or \"%.*s%s(...)\" or ...",
+			    (scanned < limit) ? scanned : limit - 3,
+			    start, (scanned < limit) ? "" : "...");
+		    if (NotOperator(lastParsed)) {
+			errCode = "BADNUMBER";
+			if ((lastStart[0] == '0')
+				&& ((lastStart[1] == 'o')
+				|| (lastStart[1] == 'O'))
+				&& (lastStart[2] >= '0')
+				&& (lastStart[2] <= '9')) {
+			    const char *end = lastStart + 2;
+			    Tcl_Obj *copy;
+
+			    while (isdigit(UCHAR(*end))) {
+				end++;
 			    }
-			    scanned = 0;
-			    insertMark = 1;
-			    parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
+			    copy = Tcl_NewStringObj(lastStart, end-lastStart);
+			    if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
+				Tcl_AppendToObj(post,
+					" (invalid octal number?)", -1);
+				errCode = "BADNUMBER";
+				subErrCode = "OCTAL";
+			    }
+			    Tcl_DecrRefCount(copy);
 			}
-			goto error;
+			scanned = 0;
+			insertMark = 1;
+			parsePtr->errorType = TCL_PARSE_BAD_NUMBER;
+		    } else {
+			errCode = "BAREWORD";
 		    }
+		    goto error;
 		}
 		break;
 	    case PLUS:
@@ -810,12 +823,15 @@ ParseExpr(
 
 	    if (NotOperator(lastParsed)) {
 		msg = Tcl_ObjPrintf("missing operator at %s", mark);
+		errCode = "MISSING";
 		if (lastStart[0] == '0') {
 		    Tcl_Obj *copy = Tcl_NewStringObj(lastStart,
 			    start + scanned - lastStart);
+
 		    if (TclCheckBadOctal(NULL, Tcl_GetString(copy))) {
 			TclNewLiteralStringObj(post,
 				"looks like invalid octal number");
+			errCode = "BADNUMBER_OCTAL";
 		    }
 		    Tcl_DecrRefCount(copy);
 		}
@@ -881,7 +897,7 @@ ParseExpr(
 
 	    case BRACED:
 		code = Tcl_ParseBraces(NULL, start, numBytes,
-			    parsePtr, 1, &end);
+			parsePtr, 1, &end);
 		scanned = end - start;
 		break;
 
@@ -896,6 +912,7 @@ ParseExpr(
 		tokenPtr = parsePtr->tokenPtr + wordIndex + 1;
 		if (code == TCL_OK && tokenPtr->type != TCL_TOKEN_VARIABLE) {
 		    TclNewLiteralStringObj(msg, "invalid character \"$\"");
+		    errCode = "BADCHAR";
 		    goto error;
 		}
 		scanned = tokenPtr->size;
@@ -913,7 +930,7 @@ ParseExpr(
 		end = start + numBytes;
 		start++;
 		while (1) {
-		    code = Tcl_ParseCommand(interp, start, (end - start), 1,
+		    code = Tcl_ParseCommand(interp, start, end - start, 1,
 			    nestedPtr);
 		    if (code != TCL_OK) {
 			parsePtr->term = nestedPtr->term;
@@ -921,10 +938,10 @@ ParseExpr(
 			parsePtr->incomplete = nestedPtr->incomplete;
 			break;
 		    }
-		    start = (nestedPtr->commandStart + nestedPtr->commandSize);
+		    start = nestedPtr->commandStart + nestedPtr->commandSize;
 		    Tcl_FreeParse(nestedPtr);
-		    if ((nestedPtr->term < end) && (*(nestedPtr->term) == ']')
-			    && !(nestedPtr->incomplete)) {
+		    if ((nestedPtr->term < end) && (nestedPtr->term[0] == ']')
+			    && !nestedPtr->incomplete) {
 			break;
 		    }
 
@@ -934,6 +951,7 @@ ParseExpr(
 			parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
 			parsePtr->incomplete = 1;
 			code = TCL_ERROR;
+			errCode = "UNBALANCED";
 			break;
 		    }
 		}
@@ -944,7 +962,7 @@ ParseExpr(
 		tokenPtr->size = scanned;
 		parsePtr->numTokens++;
 		break;
-	    }
+	    }			/* SCRIPT case */
 	    }
 	    if (code != TCL_OK) {
 		/*
@@ -964,6 +982,9 @@ ParseExpr(
 
 		start = parsePtr->term;
 		scanned = parsePtr->incomplete;
+		if (parsePtr->incomplete) {
+		    errCode = "UNBALANCED";
+		}
 		goto error;
 	    }
 
@@ -1013,6 +1034,7 @@ ParseExpr(
 		msg = Tcl_ObjPrintf("missing operator at %s", mark);
 		scanned = 0;
 		insertMark = 1;
+		errCode = "MISSING";
 		goto error;
 	    }
 
@@ -1071,6 +1093,7 @@ ParseExpr(
 		    msg = Tcl_ObjPrintf("empty subexpression at %s", mark);
 		    scanned = 0;
 		    insertMark = 1;
+		    errCode = "EMPTY";
 		    goto error;
 		}
 
@@ -1078,30 +1101,34 @@ ParseExpr(
 		    if (nodePtr[-1].lexeme == OPEN_PAREN) {
 			TclNewLiteralStringObj(msg, "unbalanced open paren");
 			parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
+			errCode = "UNBALANCED";
 		    } else if (nodePtr[-1].lexeme == COMMA) {
 			msg = Tcl_ObjPrintf(
 				"missing function argument at %s", mark);
 			scanned = 0;
 			insertMark = 1;
+			errCode = "MISSING";
 		    } else if (nodePtr[-1].lexeme == START) {
 			TclNewLiteralStringObj(msg, "empty expression");
+			errCode = "EMPTY";
 		    }
-		} else {
-		    if (lexeme == CLOSE_PAREN) {
-			TclNewLiteralStringObj(msg, "unbalanced close paren");
-		    } else if ((lexeme == COMMA)
-			    && (nodePtr[-1].lexeme == OPEN_PAREN)
-			    && (nodePtr[-2].lexeme == FUNCTION)) {
-			msg = Tcl_ObjPrintf(
-				"missing function argument at %s", mark);
-			scanned = 0;
-			insertMark = 1;
-		    }
+		} else if (lexeme == CLOSE_PAREN) {
+		    TclNewLiteralStringObj(msg, "unbalanced close paren");
+		    errCode = "UNBALANCED";
+		} else if ((lexeme == COMMA)
+			&& (nodePtr[-1].lexeme == OPEN_PAREN)
+			&& (nodePtr[-2].lexeme == FUNCTION)) {
+		    msg = Tcl_ObjPrintf("missing function argument at %s",
+			    mark);
+		    scanned = 0;
+		    insertMark = 1;
+		    errCode = "UNBALANCED";
 		}
 		if (msg == NULL) {
 		    msg = Tcl_ObjPrintf("missing operand at %s", mark);
 		    scanned = 0;
 		    insertMark = 1;
+		    errCode = "MISSING";
 		}
 		goto error;
 	    }
@@ -1178,6 +1205,7 @@ ParseExpr(
 			&& (lexeme != CLOSE_PAREN)) {
 		    TclNewLiteralStringObj(msg, "unbalanced open paren");
 		    parsePtr->errorType = TCL_PARSE_MISSING_PAREN;
+		    errCode = "UNBALANCED";
 		    goto error;
 		}
 
@@ -1185,10 +1213,10 @@ ParseExpr(
 		if ((incompletePtr->lexeme == QUESTION)
 			&& (NotOperator(complete)
 			|| (nodes[complete].lexeme != COLON))) {
-		    msg = Tcl_ObjPrintf(
-			    "missing operator \":\" at %s", mark);
+		    msg = Tcl_ObjPrintf("missing operator \":\" at %s", mark);
 		    scanned = 0;
 		    insertMark = 1;
+		    errCode = "MISSING";
 		    goto error;
 		}
 
@@ -1199,6 +1227,7 @@ ParseExpr(
 		    TclNewLiteralStringObj(msg,
 			    "unexpected operator \":\" "
 			    "without preceding \"?\"");
+		    errCode = "SURPRISE";
 		    goto error;
 		}
 
@@ -1261,6 +1290,7 @@ ParseExpr(
 	    if (lexeme == CLOSE_PAREN) {
 		if (incompletePtr->lexeme != OPEN_PAREN) {
 		    TclNewLiteralStringObj(msg, "unbalanced close paren");
+		    errCode = "UNBALANCED";
 		    goto error;
 		}
 	    }
@@ -1271,6 +1301,7 @@ ParseExpr(
 			|| (incompletePtr[-1].lexeme != FUNCTION)) {
 		    TclNewLiteralStringObj(msg,
 			    "unexpected \",\" outside function argument list");
+		    errCode = "SURPRISE";
 		    goto error;
 		}
 	    }
@@ -1279,6 +1310,7 @@ ParseExpr(
 	    if (IsOperator(complete) && (nodes[complete].lexeme == COLON)) {
 		TclNewLiteralStringObj(msg,
 			"unexpected operator \":\" without preceding \"?\"");
+		errCode = "SURPRISE";
 		goto error;
 	    }
 
@@ -1409,6 +1441,10 @@ ParseExpr(
 		"\n    (parsing expression \"%.*s%s\")",
 		(numBytes < limit) ? numBytes : limit - 3,
 		parsePtr->string, (numBytes < limit) ? "" : "..."));
+	if (errCode) {
+	    Tcl_SetErrorCode(interp, "TCL", "PARSE", "EXPR", errCode,
+		    subErrCode, NULL);
+	}
     }
 
     return TCL_ERROR;
-- 
cgit v0.12


From faf9def2a7c70743d49dd1e923d82b8dc0f9d718 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 12:54:54 +0000
Subject: development branch for allocator changes

---
 README.mig-alloc-reform   |   65 ++
 generic/tclAlloc.c        | 1484 +++++++++++++++++++++++++++++++--------------
 generic/tclAssembly.c     |   15 +-
 generic/tclBasic.c        |   50 +-
 generic/tclCkalloc.c      |    4 -
 generic/tclCmdAH.c        |   18 +-
 generic/tclCmdIL.c        |   21 +-
 generic/tclCmdMZ.c        |   22 +-
 generic/tclCompCmds.c     |   26 +-
 generic/tclCompCmdsSZ.c   |   58 +-
 generic/tclCompExpr.c     |   49 +-
 generic/tclCompile.c      |    8 +-
 generic/tclDictObj.c      |   10 +-
 generic/tclEvent.c        |    6 +-
 generic/tclExecute.c      |  642 ++++----------------
 generic/tclFCmd.c         |    4 +-
 generic/tclFileName.c     |    4 +-
 generic/tclIOCmd.c        |    4 +-
 generic/tclIndexObj.c     |    8 +-
 generic/tclInt.decls      |   18 +-
 generic/tclInt.h          |  310 +++-------
 generic/tclIntDecls.h     |   24 +-
 generic/tclInterp.c       |    8 +-
 generic/tclNamesp.c       |   17 +-
 generic/tclOOCall.c       |    4 +-
 generic/tclOODefineCmds.c |   10 +-
 generic/tclOOMethod.c     |   14 +-
 generic/tclObj.c          |   71 +--
 generic/tclParse.c        |   20 +-
 generic/tclProc.c         |   27 +-
 generic/tclScan.c         |    9 +-
 generic/tclStubInit.c     |    6 +-
 generic/tclTest.c         |    8 +-
 generic/tclThreadAlloc.c  | 1081 ---------------------------------
 generic/tclTrace.c        |    8 +-
 tests/nre.test            |    4 +-
 tests/tailcall.test       |   18 +-
 unix/Makefile.in          |   11 +-
 unix/tclUnixPipe.c        |    8 +-
 unix/tclUnixThrd.c        |    7 +-
 40 files changed, 1519 insertions(+), 2662 deletions(-)
 create mode 100644 README.mig-alloc-reform
 delete mode 100755 generic/tclThreadAlloc.c

diff --git a/README.mig-alloc-reform b/README.mig-alloc-reform
new file mode 100644
index 0000000..139af2e
--- /dev/null
+++ b/README.mig-alloc-reform
@@ -0,0 +1,65 @@
+What is mig-alloc-reform?
+  1. A massive simplification of the memory management in Tcl core.
+     a. removal of the Tcl stack, each BC allocates its own stacklet
+     b. TclStackAlloc is gone, replaced with ckalloc; goodbye to sometimes
+        hard sync problems
+     c. removal of the allocCache slot in struct Interp
+     d. retirement of the (unused) Tcl allocator USE_TCLALLOC; replacement
+        with a single-thread special case of zippy
+     e. unify all allocator options in a single file tclAlloc.c
+     d. exploit fast TSD via __thread where available (autoconferry still
+        missing, enable by hand with -DHAVE_FAST_TSD)
+     f. small improvement in zippy's memory usage: try to split blocks in
+        the shared cache before allocating new ones from the system
+
+  2. New allocator options
+     a. purify build (but stop using them, see below). This is suitable to
+        use with a preloaded malloc replacement
+     b. (~NEW) native build: call to sys malloc, but maintain zippy's
+        Tcl_Obj caches (per thread, if threads enabled). Can be switched to
+        run as a purify build via an env var at startup. This is suitable to
+        use with a preloaded malloc replacement. The threaded variant is new. 
+     c. zippy build
+     d. (NEW) multi build: this is a build that can function as any of the
+        other three. Per default it runs as zippy, but can be switched to
+        native or purify via an env var at startup. May or may not be used
+        for deployment, but it will definitely be very useful for
+        development: no need to recompile in order to valgrind, just set an
+        env var!
+     
+ How do you use it? Options are:
+   1. Don't pay any attention to it, build as always. You will get the same
+      allocator as before
+   2. Select the build you want with compiler flags
+        -DTCL_ALLOCATOR=(aNATIVE|aPURIFY|aZIPPY|aMULTI)
+   3. Select behaviour at startup: native can be switched to purify, multi
+      can be switched to any of the others. Define the env var
+      TCL_ALLOCATOR when starting up and you're good to go
+
+
+** PERFORMANCE NOTES **
+   * not measured, but: purify, native and zippy builds should be just as
+     fast as before. The obj-alloc macros have been removed while
+     developing. It is not certain that they provide a speedup, this will
+     be measured and acted accordingly 
+   * multi build should be a only a tad slower, may even be suitable as
+     default build on all platforms 
+
+
+** TO DO LIST **
+   * DEFINITELY
+     - test like crazy
+     - timings: versus older version (in unthreaded, fast-tsd and slow-tsd
+       builds). Determine if the obj-alloc macros should be reenabled
+     - autoconferry to auto-detect HAVE_FAST_TSD
+     - autoconferry to choose allocator flags? Keep USE_THREAD_ALLOC and
+       USE_TCLALLOC for back compat with external build scripts only (and
+       set them too!), but set also the new variants  
+          TCL_ALLOCATOR=(aNATIVE|aPURIFY|aZIPPY|aMULTI)
+     - Makefile.in and autoconferry changes in windows, mac
+     - choose allocators from the command line instead of env vars?
+     - verify interaction with memdebug (should be 'none', but ...)
+
+   * MAYBE
+     - build zippy as malloc-replacement, compile always aNATIVE and
+       preload alternatives
diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index 6fff92b..782a12b 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -1,253 +1,428 @@
 /*
  * tclAlloc.c --
  *
- *	This is a very fast storage allocator. It allocates blocks of a small
- *	number of different sizes, and keeps free lists of each size. Blocks
- *	that don't exactly fit are passed up to the next larger size. Blocks
- *	over a certain size are directly allocated from the system.
+ *      This is a very flexible storage allocator for Tcl, for use with or
+ *      without threads. Depending on the compile flags, it builds as:
  *
- * Copyright (c) 1983 Regents of the University of California.
- * Copyright (c) 1996-1997 Sun Microsystems, Inc.
- * Copyright (c) 1998-1999 by Scriptics Corporation.
+ *      (1) Build flags: TCL_ALLOC_NATIVE
+ *          NATIVE: use the native malloc and a per-thread Tcl_Obj pool, with 
+ *          inter-thread recycling of objects. The per-thread pool can be
+ *          disabled at startup with an env var, thus providing the PURIFY
+ *          behaviour that is useful for valgrind and similar tools. Note that
+ *          the PURIFY costs are negligible when disabled, but when enabled
+ *          Tcl_Obj allocs will be even slower than in a full PURIFY build
+ *          NOTE: the obj pool shares all code with zippy's smallest allocs!
+ *                It does look overcomplicated for this particular case, but
+ *                keeping them together allows simpler maintenance and avoids
+ *                the need for separate debugging
+ *          TODO: in this case build ZIPPY as a preloadable malloc-replacement           
  *
- * Portions contributed by Chris Kingsley, Jack Jansen and Ray Johnson.
+ *      (2) Build flags: TCL_ALLOC_ZIPPY
+ *          ZIPPY: use the ex-tclThreadAlloc, essentially aolserver's
+ *          fast threaded allocator. Mods with respect to the original:
+ *            - change in the block sizes, so that the smallest alloc is
+ *              Tcl_Obj-sized
+ *            - share the Tcl_Obj pool with the smallest allocs pool for
+ *              improved cache usage
+ *            - split blocks in the shared pool before mallocing again for
+ *              improved cache usage
+ *            - ?change in the number of blocks to move to/from the shared
+ *              cache: it used to be a fixed number, it is now computed
+ *              to leave a fixed number in the thread's pool. This improves
+ *              sharing behaviour when one thread uses a lot of memory once
+ *              and rarely again (eg, at startup), at the cost of slowing
+ *              slightly threads that allocate/free large numbers of blocks
+ *              repeatedly
+ *            - stats and Tcl_GetMemoryInfo disabled per default, enable with
+ *              -DZIPPY_STATS
+ *            - adapt for unthreaded usage as replacement of the ex tclAlloc
+ *            - -DHAVE_FAST_TSD: use fast TSD via __thread where available
+ *            - (TODO!) build zippy as a pre-loadable library to use with a
+ *              native build as a malloc replacement. Difficulties are:
+ *                  (a) make that portable (easy enough on modern elf/unix, to
+ *                      be researched on win and mac)
+ *                  (b) coordinate the Tcl_Obj pool and the smallest allocs,
+ *                      as they are now addressed from different files. This
+ *                      might require a special Tcl build with no
+ *                      TclSmallAlloc, and a separate preloadable for use with
+ *                      native builds? Or else separate them again, but that's
+ *                      not really good I think.
+ *
+ *               NOTES:
+ *                  . this would be the best option, instead of MULTI. It
+ *                    could be built in two versions (perf, debug/stats)
+ *                  . would a preloaded zippy be slower than builtin?
+ *                    Possibly, due to extra indirection.
+ *
+ *      (3) Build flags: TCL_ALLOC_MULTI
+ *          MULTI: all of the above, selectable at startup with an env
+ *          var. This build will be very slightly slower than the specific
+ *          builds above, but is completely portable: it does not depend on
+ *          any help from the loader or such.
+ *
+ * All variants can be built for both threaded and unthreaded Tcl.
+ *
+ * The Initial Developer of the Original Code is America Online, Inc.
+ * Portions created by AOL are Copyright (C) 1999 America Online, Inc.
+ *
+ * Copyright (c) 2008-2011 by Miguel Sofer. All rights reserved.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  */
 
-/*
- * Windows and Unix use an alternative allocator when building with threads
- * that has significantly reduced lock contention.
- */
-
 #include "tclInt.h"
-#if !defined(TCL_THREADS) || !defined(USE_THREAD_ALLOC)
 
-#if USE_TCLALLOC
+/*
+ * This macro is used to properly align the memory allocated by Tcl, giving
+ * the same alignment as the native malloc.
+ */
 
-#ifdef TCL_DEBUG
-#   define DEBUG
-/* #define MSTATS */
-#   define RCHECK
+#if defined(__APPLE__)
+#define TCL_ALLOCALIGN	16
+#else
+#define TCL_ALLOCALIGN	(2*sizeof(void *))
 #endif
 
+#undef TclpAlloc
+#undef TclpRealloc
+#undef TclpFree
+#undef TclSmallAlloc
+#undef TclSmallFree
+
+#if (TCL_ALLOCATOR == aNATIVE) || (TCL_ALLOCATOR == aPURIFY)
 /*
- * We should really make use of AC_CHECK_TYPE(caddr_t) here, but it can wait
- * until Tcl uses config.h properly.
+ * Not much of this file is needed, most things are dealt with in the
+ * macros. Just shunt the allocators for use by the library, the core
+ * never calls this.
+ *
+ * This is all that is needed for a TCL_ALLOC_PURIFY build, a native build
+ * needs the Tcl_Obj pools too.
  */
+   
+char *
+TclpAlloc(
+    unsigned int reqSize)
+{
+    return malloc(reqSize);
+}
 
-#if defined(_MSC_VER) || defined(__MINGW32__) || defined(__BORLANDC__)
-typedef unsigned long caddr_t;
-#endif
+char *
+TclpRealloc(  
+    char *ptr,
+    unsigned int reqSize)
+{
+    return realloc(ptr, reqSize);
+}
+
+void
+TclpFree(
+    char *ptr)
+{
+    free(ptr);
+}
+
+#endif /* end of common code for PURIFY and NATIVE*/
+
+#if TCL_ALLOCATOR != aPURIFY
+/*
+ * The rest of this file deals with ZIPPY and MULTI builds, as well as the
+ * Tcl_Obj pools for NATIVE
+ */
 
 /*
- * The overhead on a block is at least 8 bytes. When free, this space contains
- * a pointer to the next free block, and the bottom two bits must be zero.
- * When in use, the first byte is set to MAGIC, and the second byte is the
- * size index. The remaining bytes are for alignment. If range checking is
- * enabled then a second word holds the size of the requested block, less 1,
- * rounded up to a multiple of sizeof(RMAGIC). The order of elements is
- * critical: ov.magic must overlay the low order bits of ov.next, and ov.magic
- * can not be a valid ov.next bit pattern.
+ * Note: we rely on the optimizer to remove unneeded code, instead of setting
+ * up a maze of #ifdefs all over the code.
+ * We should insure that debug builds do at least this much optimization, right?
  */
 
-union overhead {
-    union overhead *next;		/* when free */
-    unsigned char padding[TCL_ALLOCALIGN];	/* align struct to TCL_ALLOCALIGN bytes */
-    struct {
-	unsigned char magic0;		/* magic number */
-	unsigned char index;		/* bucket # */
-	unsigned char unused;		/* unused */
-	unsigned char magic1;		/* other magic number */
-#ifdef RCHECK
-	unsigned short rmagic;		/* range magic number */
-	unsigned long size;		/* actual block size */
-	unsigned short unused2;		/* padding to 8-byte align */
-#endif
-    } ovu;
-#define overMagic0	ovu.magic0
-#define overMagic1	ovu.magic1
-#define bucketIndex	ovu.index
-#define rangeCheckMagic	ovu.rmagic
-#define realBlockSize	ovu.size
-};
-
-
-#define MAGIC		0xef	/* magic # on accounting info */
-#define RMAGIC		0x5555	/* magic # on range info */
-
-#ifdef RCHECK
-#define	RSLOP		sizeof(unsigned short)
+#if TCL_ALLOCATOR == aZIPPY
+#   define allocator aZIPPY
+#   define ALLOCATOR_BASE aZIPPY
+#elif TCL_ALLOCATOR == aNATIVE
+/* Keep the option to switch PURIFY mode on! */
+static int allocator = aNONE;
+#   define ALLOCATOR_BASE aNATIVE
+#   define RCHECK 0
+#   undef ZIPPY_STATS
 #else
-#define	RSLOP		0
+/* MULTI */
+    static int allocator = aNONE;
+#   define ALLOCATOR_BASE aZIPPY
+#endif
+
+#if TCL_ALLOCATOR != aZIPPY
+static void ChooseAllocator();
 #endif
 
-#define OVERHEAD (sizeof(union overhead) + RSLOP)
 
 /*
- * Macro to make it easier to refer to the end-of-block guard magic.
+ * If range checking is enabled, an additional byte will be allocated to store
+ * the magic number at the end of the requested memory.
  */
 
-#define BLOCK_END(overPtr) \
-    (*(unsigned short *)((caddr_t)((overPtr) + 1) + (overPtr)->realBlockSize))
+#ifndef RCHECK
+#  ifdef  NDEBUG
+#    define RCHECK		0
+#  else
+#    define RCHECK		1
+#  endif
+#endif
 
 /*
- * nextf[i] is the pointer to the next free block of size 2^(i+3). The
- * smallest allocatable block is MINBLOCK bytes. The overhead information
- * precedes the data area returned to the user.
+ * The following struct stores accounting information for each block including
+ * two small magic numbers and a bucket number when in use or a next pointer
+ * when free. The original requested size (not including the Block overhead)
+ * is also maintained.
  */
 
-#define MINBLOCK	((sizeof(union overhead) + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1))
-#define NBUCKETS	(13 - (MINBLOCK >> 4))
-#define MAXMALLOC	(1<<(NBUCKETS+2))
-static union overhead *nextf[NBUCKETS];
+typedef struct Block {
+    union {
+	struct Block *next;		/* Next in free list. */
+	struct {
+	    unsigned char magic1;	/* First magic number. */
+	    unsigned char bucket;	/* Bucket block allocated from. */
+	    unsigned char unused;	/* Padding. */
+	    unsigned char magic2;	/* Second magic number. */
+	} s;
+    } u;
+    size_t reqSize;			/* Requested allocation size. */
+} Block;
+
+#define ALIGN(x)    (((x) + TCL_ALLOCALIGN - 1) & ~(TCL_ALLOCALIGN - 1))
+#define OFFSET      ALIGN(sizeof(Block))
+
+#define nextBlock	u.next
+#define sourceBucket	u.s.bucket
+#define magicNum1	u.s.magic1
+#define magicNum2	u.s.magic2
+#define MAGIC		0xEF
+#define blockReqSize	reqSize
 
 /*
- * The following structure is used to keep track of all system memory
- * currently owned by Tcl. When finalizing, all this memory will be returned
- * to the system.
+ * The following defines the minimum and maximum block sizes and the number
+ * of buckets in the bucket cache.
+ *                        32b    64b    Apple-32b
+ *     TCL_ALLOCALIGN       8     16       16
+ *     sizeof(Block)        8     16       16
+ *     OFFSET               8     16       16
+ *     sizeof(Tcl_Obj)     24     48       24
+ *     ALLOCBASE           24     48       24
+ *     MINALLOC            24     48       24
+ *     NBUCKETS            11     10       11
+ *     MAXALLOC         24576  24576    24576
+ *     small allocs      1024    512     1024
+ *        at a time
  */
 
-struct block {
-    struct block *nextPtr;	/* Linked list. */
-    struct block *prevPtr;	/* Linked list for big blocks, ensures 8-byte
-				 * alignment for suballocated blocks. */
-};
+#if TCL_ALLOCATOR == aNATIVE
+#define MINALLOC    MAX(OFFSET, sizeof(Tcl_Obj))
+#else
+#define MINALLOC    ALIGN(MAX(OFFSET+8, sizeof(Tcl_Obj)))
+#endif
 
-static struct block *blockList;	/* Tracks the suballocated blocks. */
-static struct block bigBlocks={	/* Big blocks aren't suballocated. */
-    &bigBlocks, &bigBlocks
-};
+#define NBUCKETS    10 /* previously (11 - (MINALLOC >> 5)) */
+#define MAXALLOC    (MINALLOC << (NBUCKETS - 1))
+
+#if TCL_ALLOCATOR == aNATIVE
+#  define NBUCKETS_0 1
+#  define nBuckets   1
+#else
+#  define NBUCKETS_0 NBUCKETS
+#  if TCL_ALLOCATOR == aZIPPY
+#    define nBuckets NBUCKETS
+#  else
+     static int nBuckets = NBUCKETS;
+#  endif
+#endif
 
 /*
- * The allocator is protected by a special mutex that must be explicitly
- * initialized. Futhermore, because Tcl_Alloc may be used before anything else
- * in Tcl, we make this module self-initializing after all with the allocInit
- * variable.
+ * The following structure defines a bucket of blocks, optionally with various
+ * accounting and statistics information.
  */
 
-#ifdef TCL_THREADS
-static Tcl_Mutex *allocMutexPtr;
+typedef struct Bucket {
+    Block *firstPtr;		/* First block available */
+    long numFree;		/* Number of blocks available */
+#ifdef ZIPPY_STATS
+    /* All fields below for accounting only */
+
+    long numRemoves;		/* Number of removes from bucket */
+    long numInserts;		/* Number of inserts into bucket */
+    long numWaits;		/* Number of waits to acquire a lock */
+    long numLocks;		/* Number of locks acquired */
+    long totalAssigned;		/* Total space assigned to bucket */
 #endif
-static int allocInit = 0;
-
-#ifdef MSTATS
+} Bucket;
 
 /*
- * numMallocs[i] is the difference between the number of mallocs and frees for
- * a given block size.
+ * The following structure defines a cache of buckets, at most one per
+ * thread. 
  */
 
-static	unsigned int numMallocs[NBUCKETS+1];
+typedef struct Cache {
+#if defined(TCL_THREADS)
+    struct Cache *nextPtr;	/* Linked list of cache entries */
+#ifdef ZIPPY_STATS
+    Tcl_ThreadId owner;		/* Which thread's cache is this? */
 #endif
-
-#if defined(DEBUG) || defined(RCHECK)
-#define	ASSERT(p)	if (!(p)) Tcl_Panic(# p)
-#define RANGE_ASSERT(p) if (!(p)) Tcl_Panic(# p)
-#else
-#define	ASSERT(p)
-#define RANGE_ASSERT(p)
 #endif
+#ifdef ZIPPY_STATS
+    int totalAssigned;		/* Total space assigned to thread */
+#endif
+    Bucket buckets[1];	        /* The buckets for this thread */
+} Cache;
+
 
 /*
- * Prototypes for functions used only in this file.
+ * The following array specifies various per-bucket limits and locks. The
+ * values are statically initialized to avoid calculating them repeatedly.
  */
 
-static void		MoreCore(int bucket);
-
+static struct {
+    size_t blockSize;		/* Bucket blocksize. */
+#if defined(TCL_THREADS)
+    int maxBlocks;		/* Max blocks before move to share. */
+    int numMove;		/* Num blocks to move to share. */
+    Tcl_Mutex *lockPtr;		/* Share bucket lock. */
+#endif
+} bucketInfo[NBUCKETS_0];
+
 /*
- *-------------------------------------------------------------------------
- *
- * TclInitAlloc --
- *
- *	Initialize the memory system.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	Initialize the mutex used to serialize allocations.
- *
- *-------------------------------------------------------------------------
+ * Static functions defined in this file.
  */
 
-void
-TclInitAlloc(void)
-{
-    if (!allocInit) {
-	allocInit = 1;
-#ifdef TCL_THREADS
-	allocMutexPtr = Tcl_GetAllocMutex();
+static Cache *	GetCache(void);
+static int	GetBlocks(Cache *cachePtr, int bucket);
+static inline Block *	Ptr2Block(char *ptr);
+static inline char *	Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize);
+
+#if defined(TCL_THREADS)
+
+static Cache *firstCachePtr = NULL;
+static Cache *sharedPtr = NULL;
+
+static Tcl_Mutex *listLockPtr;
+static Tcl_Mutex *objLockPtr;
+
+static void	LockBucket(Cache *cachePtr, int bucket);
+static void	UnlockBucket(Cache *cachePtr, int bucket);
+static void	PutBlocks(Cache *cachePtr, int bucket, int numMove);
+
+#if defined(HAVE_FAST_TSD)
+static __thread Cache *tcachePtr;
+static __thread int allocInitialized = 0;
+
+# define GETCACHE(cachePtr)			\
+    do {					\
+	if (!allocInitialized) {		\
+	    allocInitialized = 1;		\
+	    tcachePtr = GetCache();				\
+	}					\
+	(cachePtr) = tcachePtr;			\
+    } while (0)
+#else
+# define GETCACHE(cachePtr)			\
+    do {					\
+	(cachePtr) = TclpGetAllocCache();	\
+	if ((cachePtr) == NULL) {		\
+	    (cachePtr) = GetCache();		\
+	}					\
+    } while (0)
 #endif
+#else /* NOT THREADS! */
+
+static int allocInitialized = 0;
+
+#define TclpSetAllocCache()
+#define PutBlocks(cachePtr, bucket, numMove) 
+#define firstCachePtr sharedCachePtr
+
+# define GETCACHE(cachePtr)			\
+    do {					\
+	if (!allocInitialized) {		\
+	    allocInitialized = 1;		\
+	    GetCache();				\
+	}					\
+	(cachePtr) = sharedPtr;		\
+    } while (0)
+
+static void *
+TclpGetAllocCache(void)
+{
+    if (!allocInitialized) {
+	allocInitialized = 1;
+	GetCache();
     }
+    return sharedPtr;
 }
+#endif
+
 
 /*
- *-------------------------------------------------------------------------
- *
- * TclFinalizeAllocSubsystem --
+ *----------------------------------------------------------------------
  *
- *	Release all resources being used by this subsystem, including
- *	aggressively freeing all memory allocated by TclpAlloc() that has not
- *	yet been released with TclpFree().
+ * Block2Ptr, Ptr2Block --
  *
- *	After this function is called, all memory allocated with TclpAlloc()
- *	should be considered unusable.
+ *	Convert between internal blocks and user pointers.
  *
  * Results:
- *	None.
+ *	User pointer or internal block.
  *
  * Side effects:
- *	This subsystem is self-initializing, since memory can be allocated
- *	before Tcl is formally initialized. After this call, this subsystem
- *	has been reset to its initial state and is usable again.
+ *	Invalid blocks will abort the server.
  *
- *-------------------------------------------------------------------------
+ *----------------------------------------------------------------------
  */
 
-void
-TclFinalizeAllocSubsystem(void)
+static inline char *
+Block2Ptr(
+    Block *blockPtr,
+    int bucket,
+    unsigned int reqSize)
 {
-    unsigned int i;
-    struct block *blockPtr, *nextPtr;
+    register void *ptr;
+
+    blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC;
+    blockPtr->sourceBucket = bucket;
+    blockPtr->blockReqSize = reqSize;
+    ptr = (void *) (((char *)blockPtr) + OFFSET);
+#if RCHECK
+    ((unsigned char *)(ptr))[reqSize] = MAGIC;
+#endif
+    return (char *) ptr;
+}
 
-    Tcl_MutexLock(allocMutexPtr);
-    for (blockPtr = blockList; blockPtr != NULL; blockPtr = nextPtr) {
-	nextPtr = blockPtr->nextPtr;
-	TclpSysFree(blockPtr);
-    }
-    blockList = NULL;
+static inline Block *
+Ptr2Block(
+    char *ptr)
+{
+    register Block *blockPtr;
 
-    for (blockPtr = bigBlocks.nextPtr; blockPtr != &bigBlocks; ) {
-	nextPtr = blockPtr->nextPtr;
-	TclpSysFree(blockPtr);
-	blockPtr = nextPtr;
+    blockPtr = (Block *) (((char *) ptr) - OFFSET);
+    if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) {
+	Tcl_Panic("alloc: invalid block: %p: %x %x",
+		blockPtr, blockPtr->magicNum1, blockPtr->magicNum2);
     }
-    bigBlocks.nextPtr = &bigBlocks;
-    bigBlocks.prevPtr = &bigBlocks;
-
-    for (i=0 ; i<NBUCKETS ; i++) {
-	nextf[i] = NULL;
-#ifdef MSTATS
-	numMallocs[i] = 0;
-#endif
+#if RCHECK
+    if (((unsigned char *) ptr)[blockPtr->blockReqSize] != MAGIC) {
+	Tcl_Panic("alloc: invalid block: %p: %x %x %x",
+		blockPtr, blockPtr->magicNum1, blockPtr->magicNum2,
+		((unsigned char *) ptr)[blockPtr->blockReqSize]);
     }
-#ifdef MSTATS
-    numMallocs[i] = 0;
 #endif
-    Tcl_MutexUnlock(allocMutexPtr);
+    return blockPtr;
 }
 
 /*
  *----------------------------------------------------------------------
  *
- * TclpAlloc --
+ * GetCache ---
  *
- *	Allocate more memory.
+ *	Gets per-thread memory cache, allocating it if necessary.
  *
  * Results:
- *	None.
+ *	Pointer to cache.
  *
  * Side effects:
  *	None.
@@ -255,183 +430,237 @@ TclFinalizeAllocSubsystem(void)
  *----------------------------------------------------------------------
  */
 
-char *
-TclpAlloc(
-    unsigned int numBytes)	/* Number of bytes to allocate. */
+static Cache *
+GetCache(void)
 {
-    register union overhead *overPtr;
-    register long bucket;
-    register unsigned amount;
-    struct block *bigBlockPtr = NULL;
-
-    if (!allocInit) {
-	/*
-	 * We have to make the "self initializing" because Tcl_Alloc may be
-	 * used before any other part of Tcl. E.g., see main() for tclsh!
+    Cache *cachePtr;
+    unsigned int i;
+#if TCL_ALLOCATOR == aZIPPY
+#define allocSize (sizeof(Cache) + (NBUCKETS -1)*sizeof(Bucket))
+#elif TCL_ALLOCATOR == aNATIVE
+#define allocSize sizeof(Cache)
+#else
+    unsigned int allocSize;
+#endif
+    
+    /*
+     * Set the params for the correct allocator
+     */
+    
+#if TCL_ALLOCATOR != aZIPPY
+    if (allocator == aNONE) {
+	/* This insures that it is set just once, as any changes after
+	 * initialization guarantee a hard crash
 	 */
+	
+	ChooseAllocator();
+    }
 
-	TclInitAlloc();
+#if TCL_ALLOCATOR == aMULTI
+    if (allocator == aZIPPY) {
+	allocSize = (sizeof(Cache) + (NBUCKETS -1)*sizeof(Bucket));
+	nBuckets = NBUCKETS;
+    } else {
+	allocSize = sizeof(Cache);
+	nBuckets = 1;
     }
-    Tcl_MutexLock(allocMutexPtr);
+#endif
+#endif
 
     /*
-     * First the simple case: we simple allocate big blocks directly.
+     * Check for first-time initialization.
      */
 
-    if (numBytes >= MAXMALLOC - OVERHEAD) {
-	if (numBytes <= UINT_MAX - OVERHEAD -sizeof(struct block)) {
-	    bigBlockPtr = (struct block *) TclpSysAlloc((unsigned)
-		    (sizeof(struct block) + OVERHEAD + numBytes), 0);
-	}
-	if (bigBlockPtr == NULL) {
-	    Tcl_MutexUnlock(allocMutexPtr);
-	    return NULL;
-	}
-	bigBlockPtr->nextPtr = bigBlocks.nextPtr;
-	bigBlocks.nextPtr = bigBlockPtr;
-	bigBlockPtr->prevPtr = &bigBlocks;
-	bigBlockPtr->nextPtr->prevPtr = bigBlockPtr;
-
-	overPtr = (union overhead *) (bigBlockPtr + 1);
-	overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
-	overPtr->bucketIndex = 0xff;
-#ifdef MSTATS
-	numMallocs[NBUCKETS]++;
+#if defined(TCL_THREADS)
+    if (listLockPtr == NULL) {
+	Tcl_Mutex *initLockPtr;
+	initLockPtr = Tcl_GetAllocMutex();
+	Tcl_MutexLock(initLockPtr);
+	if (listLockPtr == NULL) {
+	    listLockPtr = TclpNewAllocMutex();
+	    objLockPtr = TclpNewAllocMutex();
 #endif
-
-#ifdef RCHECK
-	/*
-	 * Record allocated size of block and bound space with magic numbers.
-	 */
-
-	overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
-	overPtr->rangeCheckMagic = RMAGIC;
-	BLOCK_END(overPtr) = RMAGIC;
+	    for (i = 0; i < nBuckets; ++i) {
+		bucketInfo[i].blockSize = MINALLOC << i;
+#if defined(TCL_THREADS)
+		/* TODO: clearer logic? Change move to keep? */
+		bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i);
+		bucketInfo[i].numMove = i < NBUCKETS - 1 ?
+			1 << (NBUCKETS - 2 - i) : 1;
+		bucketInfo[i].lockPtr = TclpNewAllocMutex();
 #endif
-
-	Tcl_MutexUnlock(allocMutexPtr);
-	return (void *)(overPtr+1);
+	    }
+#if defined(TCL_THREADS)
+	    sharedPtr = calloc(1, allocSize);
+	    firstCachePtr = sharedPtr;
+	}
+	Tcl_MutexUnlock(initLockPtr);
     }
+#endif
 
+    if (allocator == aPURIFY) {
+	bucketInfo[0].maxBlocks = 0;
+    }
+    
     /*
-     * Convert amount of memory requested into closest block size stored in
-     * hash buckets which satisfies request. Account for space used per block
-     * for accounting.
+     * Get this thread's cache, allocating if necessary.
      */
 
-    amount = MINBLOCK;		/* size of first bucket */
-    bucket = MINBLOCK >> 4;
-
-    while (numBytes + OVERHEAD > amount) {
-	amount <<= 1;
-	if (amount == 0) {
-	    Tcl_MutexUnlock(allocMutexPtr);
-	    return NULL;
+    cachePtr = TclpGetAllocCache();
+    if (cachePtr == NULL) {
+	cachePtr = calloc(1, allocSize);
+	if (cachePtr == NULL) {
+	    Tcl_Panic("alloc: could not allocate new cache");
 	}
-	bucket++;
+#if defined(TCL_THREADS)
+	Tcl_MutexLock(listLockPtr);
+	cachePtr->nextPtr = firstCachePtr;
+	firstCachePtr = cachePtr;
+	Tcl_MutexUnlock(listLockPtr);
+#ifdef ZIPPY_STATS
+	cachePtr->owner = Tcl_GetCurrentThread();
+#endif
+	TclpSetAllocCache(cachePtr);
+#endif
     }
-    ASSERT(bucket < NBUCKETS);
+    return cachePtr;
+}
+
+#if defined(TCL_THREADS)
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFreeAllocCache --
+ *
+ *	Flush and delete a cache, removing from list of caches.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFreeAllocCache(
+    void *arg)
+{
+    Cache *cachePtr = arg;
+    Cache **nextPtrPtr;
+    register unsigned int bucket;
 
     /*
-     * If nothing in hash bucket right now, request more memory from the
-     * system.
+     * Flush blocks.
      */
 
-    if ((overPtr = nextf[bucket]) == NULL) {
-	MoreCore(bucket);
-	if ((overPtr = nextf[bucket]) == NULL) {
-	    Tcl_MutexUnlock(allocMutexPtr);
-	    return NULL;
+    for (bucket = 0; bucket < nBuckets; ++bucket) {
+	if (cachePtr->buckets[bucket].numFree > 0) {
+	    PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].numFree);
 	}
     }
 
     /*
-     * Remove from linked list
+     * Remove from pool list.
      */
 
-    nextf[bucket] = overPtr->next;
-    overPtr->overMagic0 = overPtr->overMagic1 = MAGIC;
-    overPtr->bucketIndex = (unsigned char) bucket;
-
-#ifdef MSTATS
-    numMallocs[bucket]++;
-#endif
-
-#ifdef RCHECK
-    /*
-     * Record allocated size of block and bound space with magic numbers.
-     */
-
-    overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
-    overPtr->rangeCheckMagic = RMAGIC;
-    BLOCK_END(overPtr) = RMAGIC;
-#endif
-
-    Tcl_MutexUnlock(allocMutexPtr);
-    return ((char *)(overPtr + 1));
+    Tcl_MutexLock(listLockPtr);
+    nextPtrPtr = &firstCachePtr;
+    while (*nextPtrPtr != cachePtr) {
+	nextPtrPtr = &(*nextPtrPtr)->nextPtr;
+    }
+    *nextPtrPtr = cachePtr->nextPtr;
+    cachePtr->nextPtr = NULL;
+    Tcl_MutexUnlock(listLockPtr);
+    free(cachePtr);
 }
+#endif
 
+#if TCL_ALLOCATOR != aNATIVE
 /*
  *----------------------------------------------------------------------
  *
- * MoreCore --
- *
- *	Allocate more memory to the indicated bucket.
+ * TclpAlloc --
  *
- *	Assumes Mutex is already held.
+ *	Allocate memory.
  *
  * Results:
- *	None.
+ *	Pointer to memory just beyond Block pointer.
  *
  * Side effects:
- *	Attempts to get more memory from the system.
+ *	May allocate more blocks for a bucket.
  *
  *----------------------------------------------------------------------
  */
 
-static void
-MoreCore(
-    int bucket)			/* What bucket to allocat to. */
+char *
+TclpAlloc(
+    unsigned int reqSize)
 {
-    register union overhead *overPtr;
-    register long size;		/* size of desired block */
-    long amount;		/* amount to allocate */
-    int numBlocks;		/* how many blocks we get */
-    struct block *blockPtr;
-
-    /*
-     * sbrk_size <= 0 only for big, FLUFFY, requests (about 2^30 bytes on a
-     * VAX, I think) or for a negative arg.
-     */
+    Cache *cachePtr;
+    Block *blockPtr;
+    register int bucket;
+    size_t size;
 
-    size = 1 << (bucket + 3);
-    ASSERT(size > 0);
+    if (allocator < aNONE) {
+	return (void *) malloc(reqSize);
+    }
+    
+    GETCACHE(cachePtr);
 
-    amount = MAXMALLOC;
-    numBlocks = amount / size;
-    ASSERT(numBlocks*size == amount);
+#ifndef __LP64__
+    if (sizeof(int) >= sizeof(size_t)) {
+	/* An unsigned int overflow can also be a size_t overflow */
+	const size_t zero = 0;
+	const size_t max = ~zero;
 
-    blockPtr = (struct block *) TclpSysAlloc((unsigned)
-	    (sizeof(struct block) + amount), 1);
-    /* no more room! */
-    if (blockPtr == NULL) {
-	return;
+	if (((size_t) reqSize) > max - OFFSET - RCHECK) {
+	    /* Requested allocation exceeds memory */
+	    return NULL;
+	}
     }
-    blockPtr->nextPtr = blockList;
-    blockList = blockPtr;
-
-    overPtr = (union overhead *) (blockPtr + 1);
+#endif
 
     /*
-     * Add new memory allocated to that on free list for this hash bucket.
+     * Increment the requested size to include room for the Block structure.
+     * Call malloc() directly if the required amount is greater than the
+     * largest block, otherwise pop the smallest block large enough,
+     * allocating more blocks if necessary.
      */
 
-    nextf[bucket] = overPtr;
-    while (--numBlocks > 0) {
-	overPtr->next = (union overhead *)((caddr_t)overPtr + size);
-	overPtr = (union overhead *)((caddr_t)overPtr + size);
+    blockPtr = NULL;
+    size = reqSize + OFFSET;
+#if RCHECK
+    size++;
+#endif
+    if (size > MAXALLOC) {
+	bucket = nBuckets;
+	blockPtr = malloc(size);
+#ifdef ZIPPY_STATS
+	if (blockPtr != NULL) {
+	    cachePtr->totalAssigned += reqSize;
+	}
+#endif
+    } else {
+	bucket = 0;
+	while (bucketInfo[bucket].blockSize < size) {
+	    bucket++;
+	}
+	if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) {
+	    blockPtr = cachePtr->buckets[bucket].firstPtr;
+	    cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock;
+	    cachePtr->buckets[bucket].numFree--;
+#ifdef ZIPPY_STATS
+	    cachePtr->buckets[bucket].numRemoves++;
+	    cachePtr->buckets[bucket].totalAssigned += reqSize;
+#endif
+	}
+    }
+    if (blockPtr == NULL) {
+	return NULL;
     }
-    overPtr->next = NULL;
+    return Block2Ptr(blockPtr, bucket, reqSize);
 }
 
 /*
@@ -439,64 +668,66 @@ MoreCore(
  *
  * TclpFree --
  *
- *	Free memory.
+ *	Return blocks to the thread block cache.
  *
  * Results:
  *	None.
  *
  * Side effects:
- *	None.
+ *	May move blocks to shared cache.
  *
  *----------------------------------------------------------------------
  */
 
 void
 TclpFree(
-    char *oldPtr)		/* Pointer to memory to free. */
+    char *ptr)
 {
-    register long size;
-    register union overhead *overPtr;
-    struct block *bigBlockPtr;
+    Cache *cachePtr;
+    Block *blockPtr;
+    int bucket;
 
-    if (oldPtr == NULL) {
-	return;
+    if (allocator < aNONE) {
+	return free((char *) ptr);
     }
 
-    Tcl_MutexLock(allocMutexPtr);
-    overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead));
+    GETCACHE(cachePtr);
 
-    ASSERT(overPtr->overMagic0 == MAGIC);	/* make sure it was in use */
-    ASSERT(overPtr->overMagic1 == MAGIC);
-    if (overPtr->overMagic0 != MAGIC || overPtr->overMagic1 != MAGIC) {
-	Tcl_MutexUnlock(allocMutexPtr);
+    if (ptr == NULL) {
 	return;
     }
 
-    RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
-    RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
-    size = overPtr->bucketIndex;
-    if (size == 0xff) {
-#ifdef MSTATS
-	numMallocs[NBUCKETS]--;
-#endif
-
-	bigBlockPtr = (struct block *) overPtr - 1;
-	bigBlockPtr->prevPtr->nextPtr = bigBlockPtr->nextPtr;
-	bigBlockPtr->nextPtr->prevPtr = bigBlockPtr->prevPtr;
-	TclpSysFree(bigBlockPtr);
+    /*
+     * Get the block back from the user pointer and call system free directly
+     * for large blocks. Otherwise, push the block back on the bucket and move
+     * blocks to the shared cache if there are now too many free.
+     */
 
-	Tcl_MutexUnlock(allocMutexPtr);
+    blockPtr = Ptr2Block(ptr);
+    bucket = blockPtr->sourceBucket;
+    if (bucket == nBuckets) {
+#ifdef ZIPPY_STATS
+	cachePtr->totalAssigned -= blockPtr->blockReqSize;
+#endif
+	free(blockPtr);
 	return;
     }
-    ASSERT(size < NBUCKETS);
-    overPtr->next = nextf[size];	/* also clobbers overMagic */
-    nextf[size] = overPtr;
 
-#ifdef MSTATS
-    numMallocs[size]--;
+#ifdef ZIPPY_STATS
+    cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
+#endif
+    blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr;
+    cachePtr->buckets[bucket].firstPtr = blockPtr;
+    cachePtr->buckets[bucket].numFree++;
+#ifdef ZIPPY_STATS
+    cachePtr->buckets[bucket].numInserts++;
+#endif
+#if defined(TCL_THREADS)
+    if (cachePtr != sharedPtr &&
+	    cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) {
+	PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove);
+    }
 #endif
-
-    Tcl_MutexUnlock(allocMutexPtr);
 }
 
 /*
@@ -504,138 +735,308 @@ TclpFree(
  *
  * TclpRealloc --
  *
- *	Reallocate memory.
+ *	Re-allocate memory to a larger or smaller size.
  *
  * Results:
- *	None.
+ *	Pointer to memory just beyond Block pointer.
  *
  * Side effects:
- *	None.
+ *	Previous memory, if any, may be freed.
  *
  *----------------------------------------------------------------------
  */
 
 char *
-TclpRealloc(
-    char *oldPtr,		/* Pointer to alloced block. */
-    unsigned int numBytes)	/* New size of memory. */
+TclpRealloc(  
+    char *ptr,
+    unsigned int reqSize)
 {
-    int i;
-    union overhead *overPtr;
-    struct block *bigBlockPtr;
-    int expensive;
-    unsigned long maxSize;
-
-    if (oldPtr == NULL) {
-	return TclpAlloc(numBytes);
+    Cache *cachePtr;
+    Block *blockPtr;
+    void *newPtr;
+    size_t size, min;
+    int bucket;
+
+    if (allocator < aNONE) {
+	return (void *) realloc((char *) ptr, reqSize);
     }
 
-    Tcl_MutexLock(allocMutexPtr);
-
-    overPtr = (union overhead *)((caddr_t)oldPtr - sizeof(union overhead));
+    GETCACHE(cachePtr);
 
-    ASSERT(overPtr->overMagic0 == MAGIC);	/* make sure it was in use */
-    ASSERT(overPtr->overMagic1 == MAGIC);
-    if (overPtr->overMagic0 != MAGIC || overPtr->overMagic1 != MAGIC) {
-	Tcl_MutexUnlock(allocMutexPtr);
-	return NULL;
+    if (ptr == NULL) {
+	return TclpAlloc(reqSize);
     }
 
-    RANGE_ASSERT(overPtr->rangeCheckMagic == RMAGIC);
-    RANGE_ASSERT(BLOCK_END(overPtr) == RMAGIC);
-    i = overPtr->bucketIndex;
+#ifndef __LP64__
+    if (sizeof(int) >= sizeof(size_t)) {
+	/* An unsigned int overflow can also be a size_t overflow */
+	const size_t zero = 0;
+	const size_t max = ~zero;
+
+	if (((size_t) reqSize) > max - OFFSET - RCHECK) {
+	    /* Requested allocation exceeds memory */
+	    return NULL;
+	}
+    }
+#endif
 
     /*
-     * If the block isn't in a bin, just realloc it.
+     * If the block is not a system block and fits in place, simply return the
+     * existing pointer. Otherwise, if the block is a system block and the new
+     * size would also require a system block, call realloc() directly.
      */
 
-    if (i == 0xff) {
-	struct block *prevPtr, *nextPtr;
-	bigBlockPtr = (struct block *) overPtr - 1;
-	prevPtr = bigBlockPtr->prevPtr;
-	nextPtr = bigBlockPtr->nextPtr;
-	bigBlockPtr = (struct block *) TclpSysRealloc(bigBlockPtr,
-		sizeof(struct block) + OVERHEAD + numBytes);
-	if (bigBlockPtr == NULL) {
-	    Tcl_MutexUnlock(allocMutexPtr);
+    blockPtr = Ptr2Block(ptr);
+    size = reqSize + OFFSET;
+#if RCHECK
+    size++;
+#endif
+    bucket = blockPtr->sourceBucket;
+    if (bucket != nBuckets) {
+	if (bucket > 0) {
+	    min = bucketInfo[bucket-1].blockSize;
+	} else {
+	    min = 0;
+	}
+	if (size > min && size <= bucketInfo[bucket].blockSize) {
+#ifdef ZIPPY_STATS
+	    cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
+	    cachePtr->buckets[bucket].totalAssigned += reqSize;
+#endif
+	    return Block2Ptr(blockPtr, bucket, reqSize);
+	}
+    } else if (size > MAXALLOC) {
+#ifdef ZIPPY_STATS
+	cachePtr->totalAssigned -= blockPtr->blockReqSize;
+	cachePtr->totalAssigned += reqSize;
+#endif
+	blockPtr = realloc(blockPtr, size);
+	if (blockPtr == NULL) {
 	    return NULL;
 	}
+	return Block2Ptr(blockPtr, nBuckets, reqSize);
+    }
 
-	if (prevPtr->nextPtr != bigBlockPtr) {
-	    /*
-	     * If the block has moved, splice the new block into the list
-	     * where the old block used to be.
-	     */
+    /*
+     * Finally, perform an expensive malloc/copy/free.
+     */
 
-	    prevPtr->nextPtr = bigBlockPtr;
-	    nextPtr->prevPtr = bigBlockPtr;
+    newPtr = TclpAlloc(reqSize);
+    if (newPtr != NULL) {
+	if (reqSize > blockPtr->blockReqSize) {
+	    reqSize = blockPtr->blockReqSize;
 	}
+	memcpy(newPtr, ptr, reqSize);
+	TclpFree(ptr);
+    }
+    return newPtr;
+}
+#ifdef ZIPPY_STATS
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_GetMemoryInfo --
+ *
+ *	Return a list-of-lists of memory stats.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	List appended to given dstring.
+ *
+ *----------------------------------------------------------------------
+ */
 
-	overPtr = (union overhead *) (bigBlockPtr + 1);
-
-#ifdef MSTATS
-	numMallocs[NBUCKETS]++;
+void
+Tcl_GetMemoryInfo(
+    Tcl_DString *dsPtr)
+{
+    Cache *cachePtr;
+    char buf[200];
+    unsigned int n;
+
+    Tcl_MutexLock(listLockPtr);
+    cachePtr = firstCachePtr;
+    while (cachePtr != NULL) {
+	Tcl_DStringStartSublist(dsPtr);
+#if defined(TCL_THREADS)
+	if (cachePtr == sharedPtr) {
+	    Tcl_DStringAppendElement(dsPtr, "shared");
+	} else {
+	    sprintf(buf, "thread%p", cachePtr->owner);
+	    Tcl_DStringAppendElement(dsPtr, buf);
+	}
+#else
+	Tcl_DStringAppendElement(dsPtr, "unthreaded");	    
 #endif
-
-#ifdef RCHECK
-	/*
-	 * Record allocated size of block and update magic number bounds.
-	 */
-
-	overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
-	BLOCK_END(overPtr) = RMAGIC;
+	for (n = 0; n < nBuckets; ++n) {
+	    sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld",
+		    (unsigned long) bucketInfo[n].blockSize,
+		    cachePtr->buckets[n].numFree,
+		    cachePtr->buckets[n].numRemoves,
+		    cachePtr->buckets[n].numInserts,
+		    cachePtr->buckets[n].totalAssigned,
+		    cachePtr->buckets[n].numLocks,
+		    cachePtr->buckets[n].numWaits);
+	    Tcl_DStringAppendElement(dsPtr, buf);
+	}
+	Tcl_DStringEndSublist(dsPtr);
+#if defined(TCL_THREADS)
+	cachePtr = cachePtr->nextPtr;
+#else
+	cachePtr = NULL;
 #endif
-
-	Tcl_MutexUnlock(allocMutexPtr);
-	return (char *)(overPtr+1);
     }
-    maxSize = 1 << (i+3);
-    expensive = 0;
-    if (numBytes+OVERHEAD > maxSize) {
-	expensive = 1;
-    } else if (i>0 && numBytes+OVERHEAD < maxSize/2) {
-	expensive = 1;
+    Tcl_MutexUnlock(listLockPtr);
+}
+#endif /* ZIPPY_STATS */
+#endif /* code above only for NATIVE allocator */
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSmallAlloc --
+ *
+ *	Allocate a Tcl_Obj sized block from the per-thread cache.
+ *
+ * Results:
+ *	Pointer to uninitialized memory.
+ *
+ * Side effects:
+ *	May move blocks from shared cached or allocate new blocks if
+ *	list is empty.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void *
+TclSmallAlloc(void)
+{
+    Cache *cachePtr;
+    Block *blockPtr;
+    Bucket *bucketPtr;
+
+    GETCACHE(cachePtr);
+    bucketPtr = &cachePtr->buckets[0];
+
+    blockPtr = bucketPtr->firstPtr;
+    if (bucketPtr->numFree || GetBlocks(cachePtr, 0)) {
+        blockPtr = bucketPtr->firstPtr;
+ 	bucketPtr->firstPtr = blockPtr->nextBlock;
+ 	bucketPtr->numFree--;
+#ifdef ZIPPY_STATS
+ 	bucketPtr->numRemoves++;
+ 	bucketPtr->totalAssigned += sizeof(Tcl_Obj);
+#endif
     }
+    return blockPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclSmallFree --
+ *
+ *	Return a free Tcl_Obj-sized block to the per-thread cache.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	May move free blocks to shared list upon hitting high water mark.
+ *
+ *----------------------------------------------------------------------
+ */
 
-    if (expensive) {
-	void *newPtr;
+void
+TclSmallFree(
+    void *ptr)
+{
+    Cache *cachePtr;
+    Block *blockPtr = ptr;
+    Bucket *bucketPtr;
 
-	Tcl_MutexUnlock(allocMutexPtr);
+    GETCACHE(cachePtr);
+    bucketPtr = &cachePtr->buckets[0];
 
-	newPtr = TclpAlloc(numBytes);
-	if (newPtr == NULL) {
-	    return NULL;
-	}
-	maxSize -= OVERHEAD;
-	if (maxSize < numBytes) {
-	    numBytes = maxSize;
+#ifdef ZIPPY_STATS
+    bucketPtr->totalAssigned -= sizeof(Tcl_Obj);
+#endif
+    blockPtr->nextBlock = bucketPtr->firstPtr;
+    bucketPtr->firstPtr = blockPtr;
+    bucketPtr->numFree++;
+#ifdef ZIPPY_STATS
+    bucketPtr->numInserts++;
+#endif
+    
+    if (bucketPtr->numFree > bucketInfo[0].maxBlocks) {
+	if (allocator == aPURIFY) {
+	    /* undo */
+	    bucketPtr->numFree = 0;
+	    bucketPtr->firstPtr = NULL;
+	    free((char *) blockPtr);
+	    return;
 	}
-	memcpy(newPtr, oldPtr, (size_t) numBytes);
-	TclpFree(oldPtr);
-	return newPtr;
+#if defined(TCL_THREADS)
+	PutBlocks(cachePtr, 0, bucketInfo[0].numMove);
+#endif
     }
+}
+
+#if defined(TCL_THREADS)
+/*
+ *----------------------------------------------------------------------
+ *
+ * LockBucket, UnlockBucket --
+ *
+ *	Set/unset the lock to access a bucket in the shared cache.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	Lock activity and contention are monitored globally and on a per-cache
+ *	basis.
+ *
+ *----------------------------------------------------------------------
+ */
 
-    /*
-     * Ok, we don't have to copy, it fits as-is
-     */
-
-#ifdef RCHECK
-    overPtr->realBlockSize = (numBytes + RSLOP - 1) & ~(RSLOP - 1);
-    BLOCK_END(overPtr) = RMAGIC;
+static void
+LockBucket(
+    Cache *cachePtr,
+    int bucket)
+{
+#if 0
+    if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) {
+	Tcl_MutexLock(bucketInfo[bucket].lockPtr);
+	cachePtr->buckets[bucket].numWaits++;
+	sharedPtr->buckets[bucket].numWaits++;
+    }
+#else
+    Tcl_MutexLock(bucketInfo[bucket].lockPtr);
 #endif
+#ifdef ZIPPY_STATS
+    cachePtr->buckets[bucket].numLocks++;
+    sharedPtr->buckets[bucket].numLocks++;
+#endif
+}
 
-    Tcl_MutexUnlock(allocMutexPtr);
-    return(oldPtr);
+static void
+UnlockBucket(
+    Cache *cachePtr,
+    int bucket)
+{
+    Tcl_MutexUnlock(bucketInfo[bucket].lockPtr);
 }
 
 /*
  *----------------------------------------------------------------------
  *
- * mstats --
+ * PutBlocks --
  *
- *	Prints two lines of numbers, one showing the length of the free list
- *	for each size category, the second showing the number of mallocs -
- *	frees for each size category.
+ *	Return unused blocks to the shared cache.
  *
  * Results:
  *	None.
@@ -646,95 +1047,203 @@ TclpRealloc(
  *----------------------------------------------------------------------
  */
 
-#ifdef MSTATS
-void
-mstats(
-    char *s)			/* Where to write info. */
+static void
+PutBlocks(
+    Cache *cachePtr,
+    int bucket,
+    int numMove)
 {
-    register int i, j;
-    register union overhead *overPtr;
-    int totalFree = 0, totalUsed = 0;
+    register Block *lastPtr, *firstPtr;
+    register int n = numMove;
 
-    Tcl_MutexLock(allocMutexPtr);
-
-    fprintf(stderr, "Memory allocation statistics %s\nTclpFree:\t", s);
-    for (i = 0; i < NBUCKETS; i++) {
-	for (j=0, overPtr=nextf[i]; overPtr; overPtr=overPtr->next, j++) {
-	    fprintf(stderr, " %d", j);
-	}
-	totalFree += j * (1 << (i + 3));
-    }
+    /*
+     * Before acquiring the lock, walk the block list to find the last block
+     * to be moved.
+     */
 
-    fprintf(stderr, "\nused:\t");
-    for (i = 0; i < NBUCKETS; i++) {
-	fprintf(stderr, " %d", numMallocs[i]);
-	totalUsed += numMallocs[i] * (1 << (i + 3));
+    firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr;
+    while (--n > 0) {
+	lastPtr = lastPtr->nextBlock;
     }
+    cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock;
+    cachePtr->buckets[bucket].numFree -= numMove;
 
-    fprintf(stderr, "\n\tTotal small in use: %d, total free: %d\n",
-	    totalUsed, totalFree);
-    fprintf(stderr, "\n\tNumber of big (>%d) blocks in use: %d\n",
-	    MAXMALLOC, numMallocs[NBUCKETS]);
+    /*
+     * Aquire the lock and place the list of blocks at the front of the shared
+     * cache bucket.
+     */
 
-    Tcl_MutexUnlock(allocMutexPtr);
+    LockBucket(cachePtr, bucket);
+    lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr;
+    sharedPtr->buckets[bucket].firstPtr = firstPtr;
+    sharedPtr->buckets[bucket].numFree += numMove;
+    UnlockBucket(cachePtr, bucket);
 }
 #endif
-
-#else	/* !USE_TCLALLOC */
 
 /*
  *----------------------------------------------------------------------
  *
- * TclpAlloc --
+ * GetBlocks --
  *
- *	Allocate more memory.
+ *	Get more blocks for a bucket.
  *
  * Results:
- *	None.
+ *	1 if blocks where allocated, 0 otherwise.
  *
  * Side effects:
- *	None.
+ *	Cache may be filled with available blocks.
  *
  *----------------------------------------------------------------------
  */
 
-char *
-TclpAlloc(
-    unsigned int numBytes)	/* Number of bytes to allocate. */
+static int
+GetBlocks(
+    Cache *cachePtr,
+    int bucket)
 {
-    return (char *) malloc(numBytes);
+    register Block *blockPtr = NULL;
+    register int n;
+
+    if (allocator == aPURIFY) {
+	if (bucket) {
+	    Tcl_Panic("purify mode asking for blocks?");
+	}
+	cachePtr->buckets[0].firstPtr = (Block *) calloc(1, MINALLOC);
+	cachePtr->buckets[0].numFree = 1;
+	return 1;
+    }
+
+#if defined(TCL_THREADS)
+    /*
+     * First, atttempt to move blocks from the shared cache. Note the
+     * potentially dirty read of numFree before acquiring the lock which is a
+     * slight performance enhancement. The value is verified after the lock is
+     * actually acquired.
+     */
+
+    if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) {
+	LockBucket(cachePtr, bucket);
+	if (sharedPtr->buckets[bucket].numFree > 0) {
+
+	    /*
+	     * Either move the entire list or walk the list to find the last
+	     * block to move.
+	     */
+
+	    n = bucketInfo[bucket].numMove;
+	    if (n >= sharedPtr->buckets[bucket].numFree) {
+		cachePtr->buckets[bucket].firstPtr =
+			sharedPtr->buckets[bucket].firstPtr;
+		cachePtr->buckets[bucket].numFree =
+			sharedPtr->buckets[bucket].numFree;
+		sharedPtr->buckets[bucket].firstPtr = NULL;
+		sharedPtr->buckets[bucket].numFree = 0;
+	    } else {
+		blockPtr = sharedPtr->buckets[bucket].firstPtr;
+		cachePtr->buckets[bucket].firstPtr = blockPtr;
+		sharedPtr->buckets[bucket].numFree -= n;
+		cachePtr->buckets[bucket].numFree = n;
+		while (--n > 0) {
+		    blockPtr = blockPtr->nextBlock;
+		}
+		sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock;
+		blockPtr->nextBlock = NULL;
+	    }
+	}
+	UnlockBucket(cachePtr, bucket);
+    }
+#endif
+    
+    if (cachePtr->buckets[bucket].numFree == 0) {
+	register size_t size;
+
+#if TCL_ALLOCATOR != aNATIVE
+	/*
+	 * If no blocks could be moved from shared, first look for a larger
+	 * block in this cache OR the shared cache to split up.
+	 */
+
+	n = nBuckets;
+	size = 0; /* lint */
+	while (--n > bucket) {
+	    size = bucketInfo[n].blockSize;
+	    if (cachePtr->buckets[n].numFree > 0) {
+		blockPtr = cachePtr->buckets[n].firstPtr;
+		cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
+		cachePtr->buckets[n].numFree--;
+		break;
+	    } else if (sharedPtr->buckets[n].numFree > 0){
+		LockBucket(cachePtr, n);
+		if (sharedPtr->buckets[n].numFree > 0) {
+		    blockPtr = sharedPtr->buckets[n].firstPtr;
+		    sharedPtr->buckets[n].firstPtr = blockPtr->nextBlock;
+		    sharedPtr->buckets[n].numFree--;
+		    UnlockBucket(cachePtr, n);
+		    break;		
+		}
+		UnlockBucket(cachePtr, n);
+	    }
+	}
+#endif
+
+	/*
+	 * Otherwise, allocate a big new block directly.
+	 */
+
+	if (blockPtr == NULL) {
+	    size = MAXALLOC;
+	    blockPtr = malloc(size);
+	    if (blockPtr == NULL) {
+		return 0;
+	    }
+	}
+
+	/*
+	 * Split the larger block into smaller blocks for this bucket.
+	 */
+
+	n = size / bucketInfo[bucket].blockSize;
+	cachePtr->buckets[bucket].numFree = n;
+	cachePtr->buckets[bucket].firstPtr = blockPtr;
+	while (--n > 0) {
+	    blockPtr->nextBlock = (Block *)
+		((char *) blockPtr + bucketInfo[bucket].blockSize);
+	    blockPtr = blockPtr->nextBlock;
+	}
+	blockPtr->nextBlock = NULL;
+    }
+    return 1;
 }
 
 /*
- *----------------------------------------------------------------------
+ *-------------------------------------------------------------------------
  *
- * TclpFree --
+ * TclInitAlloc --
  *
- *	Free memory.
+ *	Initialize the memory system.
  *
  * Results:
  *	None.
  *
  * Side effects:
- *	None.
+ *	Initialize the mutex used to serialize allocations.
  *
- *----------------------------------------------------------------------
+ *-------------------------------------------------------------------------
  */
 
 void
-TclpFree(
-    char *oldPtr)		/* Pointer to memory to free. */
+TclInitAlloc(void)
 {
-    free(oldPtr);
-    return;
 }
 
 /*
  *----------------------------------------------------------------------
  *
- * TclpRealloc --
+ * TclFinalizeAlloc --
  *
- *	Reallocate memory.
+ *	This procedure is used to destroy all private resources used in this
+ *	file.
  *
  * Results:
  *	None.
@@ -745,16 +1254,55 @@ TclpFree(
  *----------------------------------------------------------------------
  */
 
-char *
-TclpRealloc(
-    char *oldPtr,		/* Pointer to alloced block. */
-    unsigned int numBytes)	/* New size of memory. */
+void
+TclFinalizeAlloc(void)
 {
-    return (char *) realloc(oldPtr, numBytes);
+#if defined(TCL_THREADS)
+    unsigned int i;
+
+    for (i = 0; i < nBuckets; ++i) {
+	TclpFreeAllocMutex(bucketInfo[i].lockPtr);
+	bucketInfo[i].lockPtr = NULL;
+    }
+
+    TclpFreeAllocMutex(objLockPtr);
+    objLockPtr = NULL;
+
+    TclpFreeAllocMutex(listLockPtr);
+    listLockPtr = NULL;
+
+    TclpFreeAllocCache(NULL);
+#endif
 }
+
+#if TCL_ALLOCATOR != aZIPPY
+static void
+ChooseAllocator()
+{
+    char *choice = getenv("TCL_ALLOCATOR");
+
+    /*
+     * This is only called with ALLOCATOR_BASE aZIPPY (when compiled with 
+     * aMULTI) or aNATIVE (when compiled with aNATIVE).
+     */
+    
+    allocator = ALLOCATOR_BASE;
+
+    if (choice) {
+	/*
+	 * Only override the base when requesting native or purify
+	 */
+	
+	if (!strcmp(choice, "aNATIVE")) {
+	    allocator = aNATIVE;
+	} else if (!strcmp(choice, "aPURIFY")) {
+	    allocator = aPURIFY;
+	}
+    }
+}
+#endif
 
-#endif /* !USE_TCLALLOC */
-#endif /* !TCL_THREADS */
+#endif /* end of !PURIFY */
 
 /*
  * Local Variables:
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 754941f..2562558 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -1095,11 +1095,9 @@ NewAssemblyEnv(
 				 * generation*/
     int flags)			/* Compilation flags (TCL_EVAL_DIRECT) */
 {
-    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
-				/* Tcl interpreter */
-    AssemblyEnv* assemEnvPtr = TclStackAlloc(interp, sizeof(AssemblyEnv));
+    AssemblyEnv* assemEnvPtr = ckalloc(sizeof(AssemblyEnv));
 				/* Assembler environment under construction */
-    Tcl_Parse* parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+    Tcl_Parse* parsePtr = ckalloc(sizeof(Tcl_Parse));
 				/* Parse of one line of assembly code */
 
     assemEnvPtr->envPtr = envPtr;
@@ -1144,11 +1142,6 @@ static void
 FreeAssemblyEnv(
     AssemblyEnv* assemEnvPtr)	/* Environment to free */
 {
-    CompileEnv* envPtr = assemEnvPtr->envPtr;
-				/* Compilation environment being used for code
-				 * generation */
-    Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
-				/* Tcl interpreter */
     BasicBlock* thisBB;		/* Pointer to a basic block being deleted */
     BasicBlock* nextBB;		/* Pointer to a deleted basic block's
 				 * successor */
@@ -1191,8 +1184,8 @@ FreeAssemblyEnv(
      * Dispose what's left.
      */
 
-    TclStackFree(interp, assemEnvPtr->parsePtr);
-    TclStackFree(interp, assemEnvPtr);
+    ckfree(assemEnvPtr->parsePtr);
+    ckfree(assemEnvPtr);
 }
 
 /*
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5f2b301..5e676ba 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -728,11 +728,6 @@ Tcl_CreateInterp(void)
      * cache was already initialised by the call to alloc the interp struct.
      */
 
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
-    iPtr->allocCache = TclpGetAllocCache();
-#else
-    iPtr->allocCache = NULL;
-#endif
     iPtr->pendingObjDataPtr = NULL;
     iPtr->asyncReadyPtr = TclGetAsyncReadyPtr();
     iPtr->deferredCallbacks = NULL;
@@ -2319,8 +2314,7 @@ TclInvokeStringCommand(
 {
     Command *cmdPtr = clientData;
     int i, result;
-    const char **argv =
-	    TclStackAlloc(interp, (unsigned)(objc + 1) * sizeof(char *));
+    const char **argv = ckalloc((unsigned)(objc + 1) * sizeof(char *));
 
     for (i = 0; i < objc; i++) {
 	argv[i] = Tcl_GetString(objv[i]);
@@ -2333,7 +2327,7 @@ TclInvokeStringCommand(
 
     result = cmdPtr->proc(cmdPtr->clientData, interp, objc, argv);
 
-    TclStackFree(interp, (void *) argv);
+    ckfree((void *) argv);
     return result;
 }
 
@@ -2368,8 +2362,7 @@ TclInvokeObjectCommand(
     Command *cmdPtr = clientData;
     Tcl_Obj *objPtr;
     int i, length, result;
-    Tcl_Obj **objv =
-	    TclStackAlloc(interp, (unsigned)(argc * sizeof(Tcl_Obj *)));
+    Tcl_Obj **objv = ckalloc((unsigned)(argc * sizeof(Tcl_Obj *)));
 
     for (i = 0; i < argc; i++) {
 	length = strlen(argv[i]);
@@ -2405,7 +2398,7 @@ TclInvokeObjectCommand(
 	objPtr = objv[i];
 	Tcl_DecrRefCount(objPtr);
     }
-    TclStackFree(interp, objv);
+    ckfree(objv);
     return result;
 }
 
@@ -4563,7 +4556,7 @@ TEOV_NotFound(
     Tcl_ListObjGetElements(NULL, currNsPtr->unknownHandlerPtr,
 	    &handlerObjc, &handlerObjv);
     newObjc = objc + handlerObjc;
-    newObjv = TclStackAlloc(interp, (int) sizeof(Tcl_Obj *) * newObjc);
+    newObjv = ckalloc((int) sizeof(Tcl_Obj *) * newObjc);
 
     /*
      * Copy command prefix from unknown handler and add on the real command's
@@ -4602,7 +4595,7 @@ TEOV_NotFound(
 	for (i = 0; i < handlerObjc; ++i) {
 	    Tcl_DecrRefCount(newObjv[i]);
 	}
-	TclStackFree(interp, newObjv);
+	ckfree(newObjv);
 	return TCL_ERROR;
     }
 
@@ -4640,7 +4633,7 @@ TEOV_NotFoundCallback(
     for (i = 0; i < objc; ++i) {
 	Tcl_DecrRefCount(objv[i]);
     }
-    TclStackFree(interp, objv);
+    ckfree(objv);
 
     return result;
 }
@@ -4937,12 +4930,11 @@ TclEvalEx(
 				 * state has been allocated while evaluating
 				 * the script, so that it can be freed
 				 * properly if an error occurs. */
-    Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
-    CmdFrame *eeFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
-    Tcl_Obj **stackObjArray =
-	    TclStackAlloc(interp, minObjs * sizeof(Tcl_Obj *));
-    int *expandStack = TclStackAlloc(interp, minObjs * sizeof(int));
-    int *linesStack = TclStackAlloc(interp, minObjs * sizeof(int));
+    Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
+    CmdFrame *eeFramePtr = ckalloc(sizeof(CmdFrame));
+    Tcl_Obj **stackObjArray = ckalloc(minObjs * sizeof(Tcl_Obj *));
+    int *expandStack = ckalloc(minObjs * sizeof(int));
+    int *linesStack = ckalloc(minObjs * sizeof(int));
 				/* TIP #280 Structures for tracking of command
 				 * locations. */
     int *clNext = NULL;		/* Pointer for the tracking of invisible
@@ -5338,11 +5330,11 @@ TclEvalEx(
     if (eeFramePtr->type == TCL_LOCATION_SOURCE) {
 	Tcl_DecrRefCount(eeFramePtr->data.eval.path);
     }
-    TclStackFree(interp, linesStack);
-    TclStackFree(interp, expandStack);
-    TclStackFree(interp, stackObjArray);
-    TclStackFree(interp, eeFramePtr);
-    TclStackFree(interp, parsePtr);
+    ckfree(linesStack);
+    ckfree(expandStack);
+    ckfree(stackObjArray);
+    ckfree(eeFramePtr);
+    ckfree(parsePtr);
 
     return code;
 }
@@ -5980,7 +5972,7 @@ TclNREvalObjEx(
 	     * should be pushed, as needed by alias and ensemble redirections.
 	     */
 
-	    eoFramePtr = TclStackAlloc(interp, sizeof(CmdFrame));
+	    eoFramePtr = ckalloc(sizeof(CmdFrame));
 	    eoFramePtr->nline = 0;
 	    eoFramePtr->line = NULL;
 
@@ -6098,7 +6090,7 @@ TclNREvalObjEx(
 	     */
 
 	    int pc = 0;
-	    CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+	    CmdFrame *ctxPtr = ckalloc(sizeof(CmdFrame));
 
 	    *ctxPtr = *invoker;
 	    if (invoker->type == TCL_LOCATION_BC) {
@@ -6139,7 +6131,7 @@ TclNREvalObjEx(
 
 		Tcl_DecrRefCount(ctxPtr->data.eval.path);
 	    }
-	    TclStackFree(interp, ctxPtr);
+	    ckfree(ctxPtr);
 	}
 
 	/*
@@ -6218,7 +6210,7 @@ TEOEx_ListCallback(
 
     if (eoFramePtr) {
 	iPtr->cmdFramePtr = eoFramePtr->nextPtr;
-	TclStackFree(interp, eoFramePtr);
+	ckfree(eoFramePtr);
     }
     TclDecrRefCount(listPtr);
 
diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 9d63ebf..3b51f68 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -1296,10 +1296,6 @@ TclFinalizeMemorySubsystem(void)
 
     Tcl_MutexUnlock(ckallocMutexPtr);
 #endif
-
-#if USE_TCLALLOC
-    TclFinalizeAllocSubsystem();
-#endif
 }
 
 /*
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 3edfa54..b4afdef 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -2348,7 +2348,7 @@ TclNRForObjCmd(
 	return TCL_ERROR;
     }
 
-    TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr);
+    TclCkSmallAlloc(sizeof(ForIterData), iterPtr);
     iterPtr->cond = objv[2];
     iterPtr->body = objv[4];
     iterPtr->next = objv[3];
@@ -2376,7 +2376,7 @@ ForSetupCallback(
 	if (result == TCL_ERROR) {
 	    Tcl_AddErrorInfo(interp, "\n    (\"for\" initial command)");
 	}
-	TclSmallFreeEx(interp, iterPtr);
+	TclSmallFree(iterPtr);
 	return result;
     }
     TclNRAddCallback(interp, TclNRForIterCallback, iterPtr, NULL, NULL, NULL);
@@ -2414,7 +2414,7 @@ TclNRForIterCallback(
 	Tcl_AppendObjToErrorInfo(interp,
 		Tcl_ObjPrintf(iterPtr->msg, Tcl_GetErrorLine(interp)));
     }
-    TclSmallFreeEx(interp, iterPtr);
+    TclSmallFree(iterPtr);
     return result;
 }
 
@@ -2431,11 +2431,11 @@ ForCondCallback(
 
     if (result != TCL_OK) {
 	Tcl_DecrRefCount(boolObj);
-	TclSmallFreeEx(interp, iterPtr);
+	TclSmallFree(iterPtr);
 	return result;
     } else if (Tcl_GetBooleanFromObj(interp, boolObj, &value) != TCL_OK) {
 	Tcl_DecrRefCount(boolObj);
-	TclSmallFreeEx(interp, iterPtr);
+	TclSmallFree(iterPtr);
 	return TCL_ERROR;
     }
     Tcl_DecrRefCount(boolObj);
@@ -2452,7 +2452,7 @@ ForCondCallback(
 	return TclNREvalObjEx(interp, iterPtr->body, 0, iPtr->cmdFramePtr,
 		iterPtr->word);
     }
-    TclSmallFreeEx(interp, iterPtr);
+    TclSmallFree(iterPtr);
     return result;
 }
 
@@ -2492,7 +2492,7 @@ ForPostNextCallback(
     if ((result != TCL_BREAK) && (result != TCL_OK)) {
 	if (result == TCL_ERROR) {
 	    Tcl_AddErrorInfo(interp, "\n    (\"for\" loop-end command)");
-	    TclSmallFreeEx(interp, iterPtr);
+	    TclSmallFree(iterPtr);
 	}
 	return result;
     }
@@ -2560,7 +2560,7 @@ TclNRForeachCmd(
      * allocation for better performance.
      */
 
-    statePtr = TclStackAlloc(interp,
+    statePtr = ckalloc(
 	    sizeof(struct ForeachState) + 3 * numLists * sizeof(int)
 	    + 2 * numLists * (sizeof(Tcl_Obj **) + sizeof(Tcl_Obj *)));
     memset(statePtr, 0,
@@ -2754,7 +2754,7 @@ ForeachCleanup(
 	    TclDecrRefCount(statePtr->aCopyList[i]);
 	}
     }
-    TclStackFree(interp, statePtr);
+    ckfree(statePtr);
 }
 
 /*
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b38ec9f..cd4a72b 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1313,7 +1313,7 @@ TclInfoFrame(
 	 * Execution of bytecode. Talk to the BC engine to fill out the frame.
 	 */
 
-	CmdFrame *fPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+	CmdFrame *fPtr = ckalloc(sizeof(CmdFrame));
 
 	*fPtr = *framePtr;
 
@@ -1347,7 +1347,7 @@ TclInfoFrame(
 
 	ADD_PAIR("cmd",
 		Tcl_NewStringObj(fPtr->cmd.str.cmd, fPtr->cmd.str.len));
-	TclStackFree(interp, fPtr);
+	ckfree(fPtr);
 	break;
     }
 
@@ -3016,7 +3016,7 @@ Tcl_LsearchObjCmd(
 	    int j;
 
 	    if (sortInfo.indexc > 1) {
-		TclStackFree(interp, sortInfo.indexv);
+		ckfree(sortInfo.indexv);
 	    }
 	    if (i > objc-4) {
 		if (startPtr != NULL) {
@@ -3051,7 +3051,7 @@ Tcl_LsearchObjCmd(
 		break;
 	    default:
 		sortInfo.indexv =
-			TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+			ckalloc(sizeof(int) * sortInfo.indexc);
 	    }
 
 	    /*
@@ -3158,7 +3158,7 @@ Tcl_LsearchObjCmd(
 
 	if (offset > listc-1) {
 	    if (sortInfo.indexc > 1) {
-		TclStackFree(interp, sortInfo.indexv);
+		ckfree(sortInfo.indexv);
 	    }
 	    if (allMatches || inlineReturn) {
 		Tcl_ResetResult(interp);
@@ -3483,7 +3483,7 @@ Tcl_LsearchObjCmd(
 
   done:
     if (sortInfo.indexc > 1) {
-	TclStackFree(interp, sortInfo.indexv);
+	ckfree(sortInfo.indexv);
     }
     return result;
 }
@@ -3770,7 +3770,7 @@ Tcl_LsortObjCmd(
             break;
         default:
             sortInfo.indexv =
-		    TclStackAlloc(interp, sizeof(int) * sortInfo.indexc);
+		    ckalloc(sizeof(int) * sortInfo.indexc);
             allocatedIndexVector = 1;	/* Cannot use indexc field, as it
                                          * might be decreased by 1 later. */
         }
@@ -3865,6 +3865,7 @@ Tcl_LsortObjCmd(
 		/*
 		 * Do not shrink the actual memory block used; that doesn't
 		 * work with TclStackAlloc-allocated memory. [Bug 2918962]
+                 * FIXME: TclStackAlloc is now retired, we could shrink it.
 		 */
 
 		for (i = 0; i < sortInfo.indexc; i++) {
@@ -3902,7 +3903,7 @@ Tcl_LsortObjCmd(
      * begins sorting it into the sublists as it appears.
      */
 
-    elementArray = TclStackAlloc(interp, length * sizeof(SortElement));
+    elementArray = ckalloc(length * sizeof(SortElement));
 
     for (i=0; i < length; i++){
 	idx = groupSize * i + groupOffset;
@@ -4026,7 +4027,7 @@ Tcl_LsortObjCmd(
     }
 
   done1:
-    TclStackFree(interp, elementArray);
+    ckfree(elementArray);
 
   done:
     if (sortInfo.sortMode == SORTMODE_COMMAND) {
@@ -4036,7 +4037,7 @@ Tcl_LsortObjCmd(
     }
   done2:
     if (allocatedIndexVector) {
-	TclStackFree(interp, sortInfo.indexv);
+	ckfree(sortInfo.indexv);
     }
     return sortInfo.resultCode;
 }
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 05f2e5d..d85cd83 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1835,7 +1835,7 @@ StringMapCmd(
 	 * adapt this code...
 	 */
 
-	mapElemv = TclStackAlloc(interp, sizeof(Tcl_Obj *) * mapElemc);
+	mapElemv = ckalloc(sizeof(Tcl_Obj *) * mapElemc);
 	Tcl_DictObjFirst(interp, objv[objc-2], &search, mapElemv+0,
 		mapElemv+1, &done);
 	for (i=2 ; i<mapElemc ; i+=2) {
@@ -1944,10 +1944,10 @@ StringMapCmd(
 	 * case.
 	 */
 
-	mapStrings = TclStackAlloc(interp, mapElemc*2*sizeof(Tcl_UniChar *));
-	mapLens = TclStackAlloc(interp, mapElemc * 2 * sizeof(int));
+	mapStrings = ckalloc(mapElemc*2*sizeof(Tcl_UniChar *));
+	mapLens = ckalloc(mapElemc * 2 * sizeof(int));
 	if (nocase) {
-	    u2lc = TclStackAlloc(interp, mapElemc * sizeof(Tcl_UniChar));
+	    u2lc = ckalloc(mapElemc * sizeof(Tcl_UniChar));
 	}
 	for (index = 0; index < mapElemc; index++) {
 	    mapStrings[index] = Tcl_GetUnicodeFromObj(mapElemv[index],
@@ -1997,10 +1997,10 @@ StringMapCmd(
 	    }
 	}
 	if (nocase) {
-	    TclStackFree(interp, u2lc);
+	    ckfree(u2lc);
 	}
-	TclStackFree(interp, mapLens);
-	TclStackFree(interp, mapStrings);
+	ckfree(mapLens);
+	ckfree(mapStrings);
     }
     if (p != ustring1) {
 	/*
@@ -2012,7 +2012,7 @@ StringMapCmd(
     Tcl_SetObjResult(interp, resultPtr);
   done:
     if (mapWithDict) {
-	TclStackFree(interp, mapElemv);
+	ckfree(mapElemv);
     }
     if (copySource) {
 	Tcl_DecrRefCount(sourceObj);
@@ -3849,7 +3849,7 @@ TclNRSwitchObjCmd(
      */
 
   matchFound:
-    ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+    ctxPtr = ckalloc(sizeof(CmdFrame));
     *ctxPtr = *iPtr->cmdFramePtr;
 
     if (splitObjs) {
@@ -3966,7 +3966,7 @@ SwitchPostProc(
 		(overflow ? limit : patternLength), pattern,
 		(overflow ? "..." : ""), Tcl_GetErrorLine(interp)));
     }
-    TclStackFree(interp, ctxPtr);
+    ckfree(ctxPtr);
     return result;
 }
 
@@ -4729,7 +4729,7 @@ TclNRWhileObjCmd(
      * We reuse [for]'s callback, passing a NULL for the 'next' script.
      */
 
-    TclSmallAllocEx(interp, sizeof(ForIterData), iterPtr);
+    TclCkSmallAlloc(sizeof(ForIterData), iterPtr);
     iterPtr->cond = objv[1];
     iterPtr->body = objv[2];
     iterPtr->next = NULL;
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 083f530..2fda2b9 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -1021,8 +1021,7 @@ TclCompileDictUpdateCmd(
 
     duiPtr = ckalloc(sizeof(DictUpdateInfo) + sizeof(int) * (numVars - 1));
     duiPtr->length = numVars;
-    keyTokenPtrs = TclStackAlloc(interp,
-	    sizeof(Tcl_Token *) * numVars);
+    keyTokenPtrs = ckalloc(sizeof(Tcl_Token *) * numVars);
     tokenPtr = TokenAfter(dictVarTokenPtr);
 
     for (i=0 ; i<numVars ; i++) {
@@ -1060,7 +1059,7 @@ TclCompileDictUpdateCmd(
     if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
     failedUpdateInfoAssembly:
 	ckfree(duiPtr);
-	TclStackFree(interp, keyTokenPtrs);
+	ckfree(keyTokenPtrs);
 	return TCL_ERROR;
     }
     bodyTokenPtr = tokenPtr;
@@ -1124,7 +1123,7 @@ TclCompileDictUpdateCmd(
 	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
 		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
     }
-    TclStackFree(interp, keyTokenPtrs);
+    ckfree(keyTokenPtrs);
     return TCL_OK;
 }
 
@@ -1637,10 +1636,9 @@ TclCompileForeachCmd(
      */
 
     numLists = (numWords - 2)/2;
-    varcList = TclStackAlloc(interp, numLists * sizeof(int));
+    varcList = ckalloc(numLists * sizeof(int));
     memset(varcList, 0, numLists * sizeof(int));
-    varvList = (const char ***) TclStackAlloc(interp,
-	    numLists * sizeof(const char **));
+    varvList = (const char ***) ckalloc(numLists * sizeof(const char **));
     memset((char*) varvList, 0, numLists * sizeof(const char **));
 
     /*
@@ -1867,8 +1865,8 @@ TclCompileForeachCmd(
 	    ckfree(varvList[loopIndex]);
 	}
     }
-    TclStackFree(interp, (void *)varvList);
-    TclStackFree(interp, varcList);
+    ckfree((void *)varvList);
+    ckfree(varcList);
     return code;
 }
 
@@ -3516,7 +3514,7 @@ TclCompileReturnCmd(
      * Allocate some working space.
      */
 
-    objv = TclStackAlloc(interp, numOptionWords * sizeof(Tcl_Obj *));
+    objv = ckalloc(numOptionWords * sizeof(Tcl_Obj *));
 
     /*
      * Scan through the return options. If any are unknown at compile time,
@@ -3540,7 +3538,7 @@ TclCompileReturnCmd(
     while (--objc >= 0) {
 	TclDecrRefCount(objv[objc]);
     }
-    TclStackFree(interp, objv);
+    ckfree(objv);
     if (TCL_ERROR == status) {
 	/*
 	 * Something was bogus in the return options. Clear the error message,
@@ -4028,7 +4026,7 @@ PushVarName(
 		 * assemble the corresponding token.
 		 */
 
-		elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
+		elemTokenPtr = ckalloc(sizeof(Tcl_Token));
 		allocedTokens = 1;
 		elemTokenPtr->type = TCL_TOKEN_TEXT;
 		elemTokenPtr->start = elName;
@@ -4081,7 +4079,7 @@ PushVarName(
 		 * token.
 		 */
 
-		elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
+		elemTokenPtr = ckalloc(n * sizeof(Tcl_Token));
 		allocedTokens = 1;
 		elemTokenPtr->type = TCL_TOKEN_TEXT;
 		elemTokenPtr->start = elName;
@@ -4169,7 +4167,7 @@ PushVarName(
 	varTokenPtr[removedParen].size++;
     }
     if (allocedTokens) {
-	TclStackFree(interp, elemTokenPtr);
+	ckfree(elemTokenPtr);
     }
     *localIndexPtr = localIndex;
     *simpleVarNamePtr = simpleVarName;
diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c
index d956819..ff494f2 100644
--- a/generic/tclCompCmdsSZ.c
+++ b/generic/tclCompCmdsSZ.c
@@ -595,7 +595,7 @@ TclCompileSubstCmd(
 	return TCL_ERROR;
     }
 
-    objv = TclStackAlloc(interp, /*numArgs*/ numOpts * sizeof(Tcl_Obj *));
+    objv = ckalloc(/*numArgs*/ numOpts * sizeof(Tcl_Obj *));
 
     for (objc = 0; objc < /*numArgs*/ numOpts; objc++) {
 	objv[objc] = Tcl_NewObj();
@@ -628,7 +628,7 @@ TclCompileSubstCmd(
     while (--objc >= 0) {
 	TclDecrRefCount(objv[objc]);
     }
-    TclStackFree(interp, objv);
+    ckfree(objv);
     if (/*toSubst == NULL*/ code != TCL_OK) {
 	return TCL_ERROR;
     }
@@ -1320,8 +1320,8 @@ IssueSwitchChainedTests(
 
     contFixIndex = -1;
     contFixCount = 0;
-    fixupArray = TclStackAlloc(interp, sizeof(JumpFixup) * numBodyTokens);
-    fixupTargetArray = TclStackAlloc(interp, sizeof(int) * numBodyTokens);
+    fixupArray = ckalloc(sizeof(JumpFixup) * numBodyTokens);
+    fixupTargetArray = ckalloc(sizeof(int) * numBodyTokens);
     memset(fixupTargetArray, 0, numBodyTokens * sizeof(int));
     fixupCount = 0;
     foundDefault = 0;
@@ -1520,8 +1520,8 @@ IssueSwitchChainedTests(
 	    }
 	}
     }
-    TclStackFree(interp, fixupTargetArray);
-    TclStackFree(interp, fixupArray);
+    ckfree(fixupTargetArray);
+    ckfree(fixupArray);
 
     envPtr->currStackDepth = savedStackDepth + 1;
 }
@@ -1582,7 +1582,7 @@ IssueSwitchJumpTable(
     jtPtr = ckalloc(sizeof(JumptableInfo));
     Tcl_InitHashTable(&jtPtr->hashTable, TCL_STRING_KEYS);
     infoIndex = TclCreateAuxData(jtPtr, &tclJumptableInfoType, envPtr);
-    finalFixups = TclStackAlloc(interp, sizeof(int) * (numBodyTokens/2));
+    finalFixups = ckalloc(sizeof(int) * (numBodyTokens/2));
     foundDefault = 0;
     mustGenerate = 1;
 
@@ -1720,7 +1720,7 @@ IssueSwitchJumpTable(
      * Clean up all our temporary space and return.
      */
 
-    TclStackFree(interp, finalFixups);
+    ckfree(finalFixups);
 }
 
 /*
@@ -1975,12 +1975,12 @@ TclCompileTryCmd(
     numHandlers = numWords >> 2;
     numWords -= numHandlers * 4;
     if (numHandlers > 0) {
-	handlerTokens = TclStackAlloc(interp, sizeof(Tcl_Token*)*numHandlers);
-	matchClauses = TclStackAlloc(interp, sizeof(Tcl_Obj *) * numHandlers);
+	handlerTokens = ckalloc(sizeof(Tcl_Token*)*numHandlers);
+	matchClauses = ckalloc(sizeof(Tcl_Obj *) * numHandlers);
 	memset(matchClauses, 0, sizeof(Tcl_Obj *) * numHandlers);
-	matchCodes = TclStackAlloc(interp, sizeof(int) * numHandlers);
-	resultVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
-	optionVarIndices = TclStackAlloc(interp, sizeof(int) * numHandlers);
+	matchCodes = ckalloc(sizeof(int) * numHandlers);
+	resultVarIndices = ckalloc(sizeof(int) * numHandlers);
+	optionVarIndices = ckalloc(sizeof(int) * numHandlers);
 
 	for (i=0 ; i<numHandlers ; i++) {
 	    Tcl_Obj *tmpObj, **objv;
@@ -2139,11 +2139,11 @@ TclCompileTryCmd(
 		TclDecrRefCount(matchClauses[i]);
 	    }
 	}
-	TclStackFree(interp, optionVarIndices);
-	TclStackFree(interp, resultVarIndices);
-	TclStackFree(interp, matchCodes);
-	TclStackFree(interp, matchClauses);
-	TclStackFree(interp, handlerTokens);
+	ckfree(optionVarIndices);
+	ckfree(resultVarIndices);
+	ckfree(matchCodes);
+	ckfree(matchClauses);
+	ckfree(handlerTokens);
     }
     return result;
 }
@@ -2219,8 +2219,8 @@ IssueTryInstructions(
      * Slight overallocation, but reduces size of this function.
      */
 
-    addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
-    forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+    addrsToFix = ckalloc(sizeof(int)*numHandlers);
+    forwardsToFix = ckalloc(sizeof(int)*numHandlers);
 
     for (i=0 ; i<numHandlers ; i++) {
 	sprintf(buf, "%d", matchCodes[i]);
@@ -2307,8 +2307,8 @@ IssueTryInstructions(
     for (i=0 ; i<numHandlers ; i++) {
 	FIXJUMP(addrsToFix[i]);
     }
-    TclStackFree(interp, forwardsToFix);
-    TclStackFree(interp, addrsToFix);
+    ckfree(forwardsToFix);
+    ckfree(addrsToFix);
     return TCL_OK;
 }
 
@@ -2370,8 +2370,8 @@ IssueTryFinallyInstructions(
 	 * Slight overallocation, but reduces size of this function.
 	 */
 
-	addrsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
-	forwardsToFix = TclStackAlloc(interp, sizeof(int)*numHandlers);
+	addrsToFix = ckalloc(sizeof(int)*numHandlers);
+	forwardsToFix = ckalloc(sizeof(int)*numHandlers);
 
 	for (i=0 ; i<numHandlers ; i++) {
 	    sprintf(buf, "%d", matchCodes[i]);
@@ -2503,8 +2503,8 @@ IssueTryFinallyInstructions(
 	for (i=0 ; i<numHandlers-1 ; i++) {
 	    FIXJUMP(addrsToFix[i]);
 	}
-	TclStackFree(interp, forwardsToFix);
-	TclStackFree(interp, addrsToFix);
+	ckfree(forwardsToFix);
+	ckfree(addrsToFix);
     }
 
     /*
@@ -2900,7 +2900,7 @@ PushVarName(
 		 * assemble the corresponding token.
 		 */
 
-		elemTokenPtr = TclStackAlloc(interp, sizeof(Tcl_Token));
+		elemTokenPtr = ckalloc(sizeof(Tcl_Token));
 		allocedTokens = 1;
 		elemTokenPtr->type = TCL_TOKEN_TEXT;
 		elemTokenPtr->start = elName;
@@ -2953,7 +2953,7 @@ PushVarName(
 		 * token.
 		 */
 
-		elemTokenPtr = TclStackAlloc(interp, n * sizeof(Tcl_Token));
+		elemTokenPtr = ckalloc(n * sizeof(Tcl_Token));
 		allocedTokens = 1;
 		elemTokenPtr->type = TCL_TOKEN_TEXT;
 		elemTokenPtr->start = elName;
@@ -3041,7 +3041,7 @@ PushVarName(
 	varTokenPtr[removedParen].size++;
     }
     if (allocedTokens) {
-	TclStackFree(interp, elemTokenPtr);
+	ckfree(elemTokenPtr);
     }
     *localIndexPtr = localIndex;
     *simpleVarNamePtr = simpleVarName;
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index a07d6df..396448b 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -920,7 +920,7 @@ ParseExpr(
 
 	    case SCRIPT: {
 		Tcl_Parse *nestedPtr =
-			TclStackAlloc(interp, sizeof(Tcl_Parse));
+			ckalloc(sizeof(Tcl_Parse));
 
 		tokenPtr = parsePtr->tokenPtr + parsePtr->numTokens;
 		tokenPtr->type = TCL_TOKEN_COMMAND;
@@ -955,7 +955,7 @@ ParseExpr(
 			break;
 		    }
 		}
-		TclStackFree(interp, nestedPtr);
+		ckfree(nestedPtr);
 		end = start;
 		start = tokenPtr->start;
 		scanned = end - start;
@@ -1821,7 +1821,7 @@ Tcl_ParseExpr(
     OpNode *opTree = NULL;	/* Will point to the tree of operators. */
     Tcl_Obj *litList = Tcl_NewObj();	/* List to hold the literals. */
     Tcl_Obj *funcList = Tcl_NewObj();	/* List to hold the functon names. */
-    Tcl_Parse *exprParsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+    Tcl_Parse *exprParsePtr = ckalloc(sizeof(Tcl_Parse));
 				/* Holds the Tcl_Tokens of substitutions. */
 
     if (numBytes < 0) {
@@ -1843,7 +1843,7 @@ Tcl_ParseExpr(
     }
 
     Tcl_FreeParse(exprParsePtr);
-    TclStackFree(interp, exprParsePtr);
+    ckfree(exprParsePtr);
     ckfree(opTree);
     return code;
 }
@@ -2072,7 +2072,7 @@ TclCompileExpr(
     OpNode *opTree = NULL;	/* Will point to the tree of operators */
     Tcl_Obj *litList = Tcl_NewObj();	/* List to hold the literals */
     Tcl_Obj *funcList = Tcl_NewObj();	/* List to hold the functon names*/
-    Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+    Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
 				/* Holds the Tcl_Tokens of substitutions */
 
     int code = ParseExpr(interp, script, numBytes, &opTree, litList,
@@ -2100,7 +2100,7 @@ TclCompileExpr(
     }
 
     Tcl_FreeParse(parsePtr);
-    TclStackFree(interp, parsePtr);
+    ckfree(parsePtr);
     Tcl_DecrRefCount(funcList);
     Tcl_DecrRefCount(litList);
     ckfree(opTree);
@@ -2143,7 +2143,7 @@ ExecConstantExprTree(
      * bytecode, so there's no need to tend to TIP 280 issues.
      */
 
-    envPtr = TclStackAlloc(interp, sizeof(CompileEnv));
+    envPtr = ckalloc(sizeof(CompileEnv));
     TclInitCompileEnv(interp, envPtr, NULL, 0, NULL, 0);
     CompileExprTree(interp, nodes, index, litObjvPtr, NULL, NULL, envPtr,
 	    0 /* optimize */);
@@ -2151,7 +2151,7 @@ ExecConstantExprTree(
     Tcl_IncrRefCount(byteCodeObj);
     TclInitByteCodeObj(byteCodeObj, envPtr);
     TclFreeCompileEnv(envPtr);
-    TclStackFree(interp, envPtr);
+    ckfree(envPtr);
     byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr;
     TclNRExecuteByteCode(interp, byteCodePtr);
     code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
@@ -2208,10 +2208,10 @@ CompileExprTree(
 
 	    switch (nodePtr->lexeme) {
 	    case QUESTION:
-		newJump = TclStackAlloc(interp, sizeof(JumpList));
+		newJump = ckalloc(sizeof(JumpList));
 		newJump->next = jumpPtr;
 		jumpPtr = newJump;
-		newJump = TclStackAlloc(interp, sizeof(JumpList));
+		newJump = ckalloc(sizeof(JumpList));
 		newJump->next = jumpPtr;
 		jumpPtr = newJump;
 		jumpPtr->depth = envPtr->currStackDepth;
@@ -2219,13 +2219,13 @@ CompileExprTree(
 		break;
 	    case AND:
 	    case OR:
-		newJump = TclStackAlloc(interp, sizeof(JumpList));
+		newJump = ckalloc(sizeof(JumpList));
 		newJump->next = jumpPtr;
 		jumpPtr = newJump;
-		newJump = TclStackAlloc(interp, sizeof(JumpList));
+		newJump = ckalloc(sizeof(JumpList));
 		newJump->next = jumpPtr;
 		jumpPtr = newJump;
-		newJump = TclStackAlloc(interp, sizeof(JumpList));
+		newJump = ckalloc(sizeof(JumpList));
 		newJump->next = jumpPtr;
 		jumpPtr = newJump;
 		jumpPtr->depth = envPtr->currStackDepth;
@@ -2331,10 +2331,10 @@ CompileExprTree(
 		envPtr->currStackDepth = jumpPtr->depth + 1;
 		freePtr = jumpPtr;
 		jumpPtr = jumpPtr->next;
-		TclStackFree(interp, freePtr);
+		ckfree(freePtr);
 		freePtr = jumpPtr;
 		jumpPtr = jumpPtr->next;
-		TclStackFree(interp, freePtr);
+		ckfree(freePtr);
 		break;
 	    case AND:
 	    case OR:
@@ -2358,13 +2358,13 @@ CompileExprTree(
 		envPtr->currStackDepth = jumpPtr->depth + 1;
 		freePtr = jumpPtr;
 		jumpPtr = jumpPtr->next;
-		TclStackFree(interp, freePtr);
+		ckfree(freePtr);
 		freePtr = jumpPtr;
 		jumpPtr = jumpPtr->next;
-		TclStackFree(interp, freePtr);
+		ckfree(freePtr);
 		freePtr = jumpPtr;
 		jumpPtr = jumpPtr->next;
-		TclStackFree(interp, freePtr);
+		ckfree(freePtr);
 		break;
 	    default:
 		TclEmitOpcode(instruction[nodePtr->lexeme], envPtr);
@@ -2541,9 +2541,8 @@ TclSortingOpCmd(
 	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(1));
     } else {
 	TclOpCmdClientData *occdPtr = clientData;
-	Tcl_Obj **litObjv = TclStackAlloc(interp,
-		2 * (objc-2) * sizeof(Tcl_Obj *));
-	OpNode *nodes = TclStackAlloc(interp, 2 * (objc-2) * sizeof(OpNode));
+	Tcl_Obj **litObjv = ckalloc(2 * (objc-2) * sizeof(Tcl_Obj *));
+	OpNode *nodes = ckalloc(2 * (objc-2) * sizeof(OpNode));
 	unsigned char lexeme;
 	int i, lastAnd = 1;
 	Tcl_Obj *const *litObjPtrPtr = litObjv;
@@ -2583,8 +2582,8 @@ TclSortingOpCmd(
 
 	code = ExecConstantExprTree(interp, nodes, 0, &litObjPtrPtr);
 
-	TclStackFree(interp, nodes);
-	TclStackFree(interp, litObjv);
+	ckfree(nodes);
+	ckfree(litObjv);
     }
     return code;
 }
@@ -2670,7 +2669,7 @@ TclVariadicOpCmd(
 	return code;
     } else {
 	Tcl_Obj *const *litObjv = objv + 1;
-	OpNode *nodes = TclStackAlloc(interp, (objc-1) * sizeof(OpNode));
+	OpNode *nodes = ckalloc((objc-1) * sizeof(OpNode));
 	int i, lastOp = OT_LITERAL;
 
 	nodes[0].lexeme = START;
@@ -2703,7 +2702,7 @@ TclVariadicOpCmd(
 
 	code = ExecConstantExprTree(interp, nodes, 0, &litObjv);
 
-	TclStackFree(interp, nodes);
+	ckfree(nodes);
 	return code;
     }
 }
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index aed9e3b..4d6bf33 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1202,7 +1202,7 @@ TclInitCompileEnv(
 	 * ...) which may make change the type as well.
 	 */
 
-	CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+	CmdFrame *ctxPtr = ckalloc(sizeof(CmdFrame));
 	int pc = 0;
 
 	*ctxPtr = *invoker;
@@ -1255,7 +1255,7 @@ TclInitCompileEnv(
 	    }
 	}
 
-	TclStackFree(interp, ctxPtr);
+	ckfree(ctxPtr);
     }
 
     envPtr->extCmdMapPtr->start = envPtr->line;
@@ -1461,7 +1461,7 @@ TclCompileScript(
     /* TIP #280 */
     ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
     int *wlines, wlineat, cmdLine, *clNext;
-    Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+    Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
 
     Tcl_DStringInit(&ds);
 
@@ -1877,7 +1877,7 @@ TclCompileScript(
     }
 
     envPtr->numSrcBytes = p - script;
-    TclStackFree(interp, parsePtr);
+    ckfree(parsePtr);
     Tcl_DStringFree(&ds);
 }
 
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3da91a3..4ed3fe6 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -2425,14 +2425,14 @@ DictForNRCmd(
 		TCL_STATIC);
 	return TCL_ERROR;
     }
-    searchPtr = TclStackAlloc(interp, sizeof(Tcl_DictSearch));
+    searchPtr = ckalloc(sizeof(Tcl_DictSearch));
     if (Tcl_DictObjFirst(interp, objv[2], searchPtr, &keyObj, &valueObj,
 	    &done) != TCL_OK) {
-	TclStackFree(interp, searchPtr);
+	ckfree(searchPtr);
 	return TCL_ERROR;
     }
     if (done) {
-	TclStackFree(interp, searchPtr);
+	ckfree(searchPtr);
 	return TCL_OK;
     }
     TclListObjGetElements(NULL, objv[1], &varc, &varv);
@@ -2488,7 +2488,7 @@ DictForNRCmd(
     TclDecrRefCount(valueVarObj);
     TclDecrRefCount(scriptObj);
     Tcl_DictObjDone(searchPtr);
-    TclStackFree(interp, searchPtr);
+    ckfree(searchPtr);
     return TCL_ERROR;
 }
 
@@ -2574,7 +2574,7 @@ DictForLoopCallback(
     TclDecrRefCount(valueVarObj);
     TclDecrRefCount(scriptObj);
     Tcl_DictObjDone(searchPtr);
-    TclStackFree(interp, searchPtr);
+    ckfree(searchPtr);
     return result;
 }
 
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 78bd7b8..49e8137 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1032,9 +1032,7 @@ TclInitSubsystems(void)
 
 	    TclInitThreadStorage();     /* Creates master hash table for
 					 * thread local storage */
-#if USE_TCLALLOC
 	    TclInitAlloc();		/* Process wide mutex init */
-#endif
 #ifdef TCL_MEM_DEBUG
 	    TclInitDbCkalloc();		/* Process wide mutex init */
 #endif
@@ -1211,9 +1209,7 @@ Tcl_Finalize(void)
      * Close down the thread-specific object allocator.
      */
 
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
-    TclFinalizeThreadAlloc();
-#endif
+    TclFinalizeAlloc();
 
     /*
      * We defer unloading of packages until very late to avoid memory access
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 26d3e04..b340144 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -171,19 +171,21 @@ static BuiltinFunc const tclBuiltinFuncTable[] = {
 typedef struct TEBCdata {
     ByteCode *codePtr;		/* Constant until the BC returns */
 				/* -----------------------------------------*/
+    Tcl_Obj **tosPtr;
     const unsigned char *pc;	/* These fields are used on return TO this */
-    ptrdiff_t *catchTop;	/* this level: they record the state when a */
+    int catchDepth;	        /* this level: they record the state when a */
     int cleanup;		/* new codePtr was received for NR */
     Tcl_Obj *auxObjList;	/* execution. */
     int checkInterp;
     CmdFrame cmdFrame;
+    unsigned int capacity;
     void * stack[1];            /* Start of the actual combined catch and obj
 				 * stacks; the struct will be expanded as
 				 * necessary */
 } TEBCdata;
 
 #define TEBC_YIELD()					\
-    esPtr->tosPtr = tosPtr;				\
+    TD->tosPtr = tosPtr;				\
     TD->pc = pc;					\
     TD->cleanup = cleanup;				\
     TclNRAddCallback(interp, TEBCresume, TD,	\
@@ -192,7 +194,7 @@ typedef struct TEBCdata {
 #define TEBC_DATA_DIG()				\
     pc = TD->pc;				\
     cleanup = TD->cleanup;			\
-    tosPtr = esPtr->tosPtr
+    tosPtr = TD->tosPtr
     
 
 #define PUSH_TAUX_OBJ(objPtr) \
@@ -296,20 +298,6 @@ VarHashCreateVar(
     } while (0)
 
 /*
- * Macros used to cache often-referenced Tcl evaluation stack information
- * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
- * pair must surround any call inside TclNRExecuteByteCode (and a few other
- * procedures that use this scheme) that could result in a recursive call
- * to TclNRExecuteByteCode.
- */
-
-#define CACHE_STACK_INFO() \
-    checkInterp = 1
-
-#define DECACHE_STACK_INFO() \
-    esPtr->tosPtr = tosPtr
-
-/*
  * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
  * increments the object's ref count since it makes the stack have another
  * reference pointing to the object. However, POP_OBJECT does not decrement
@@ -683,7 +671,6 @@ static void		ValidatePcAndStackTop(ByteCode *codePtr,
 			    int stackLowerBound, int checkStack);
 #endif /* TCL_COMPILE_DEBUG */
 static ByteCode *	CompileExprObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
-static void		DeleteExecStack(ExecStack *esPtr);
 static void		DupExprCodeInternalRep(Tcl_Obj *srcPtr,
 			    Tcl_Obj *copyPtr);
 MODULE_SCOPE int	TclCompareTwoNumbers(Tcl_Obj *valuePtr,
@@ -699,16 +686,10 @@ static ExceptionRange *	GetExceptRangeForPc(const unsigned char *pc,
 static const char *	GetSrcInfoForPc(const unsigned char *pc,
 			    ByteCode *codePtr, int *lengthPtr,
 			    const unsigned char **pcBeg);
-static Tcl_Obj **	GrowEvaluationStack(ExecEnv *eePtr, int growth,
-			    int move);
 static void		IllegalExprOperandType(Tcl_Interp *interp,
 			    const unsigned char *pc, Tcl_Obj *opndPtr);
 static void		InitByteCodeExecution(Tcl_Interp *interp);
-static inline int	OFFSET(void *ptr);
 static void		ReleaseDictIterator(Tcl_Obj *objPtr);
-/* Useful elsewhere, make available in tclInt.h or stubs? */
-static Tcl_Obj **	StackAllocWords(Tcl_Interp *interp, int numWords);
-static Tcl_Obj **	StackReallocWords(Tcl_Interp *interp, int numWords);
 static Tcl_NRPostProc	CopyCallback;
 static Tcl_NRPostProc	ExprObjCallback;
 
@@ -845,10 +826,7 @@ TclCreateExecEnv(
 				 * [sizeof(Tcl_Obj*)] */
 {
     ExecEnv *eePtr = ckalloc(sizeof(ExecEnv));
-    ExecStack *esPtr = ckalloc(sizeof(ExecStack)
-	    + (size_t) (size-1) * sizeof(Tcl_Obj *));
 
-    eePtr->execStackPtr = esPtr;
     TclNewBooleanObj(eePtr->constants[0], 0);
     Tcl_IncrRefCount(eePtr->constants[0]);
     TclNewBooleanObj(eePtr->constants[1], 1);
@@ -858,12 +836,6 @@ TclCreateExecEnv(
     eePtr->corPtr = NULL;
     eePtr->rewind = 0;
 
-    esPtr->prevPtr = NULL;
-    esPtr->nextPtr = NULL;
-    esPtr->markerPtr = NULL;
-    esPtr->endPtr = &esPtr->stackWords[size-1];
-    esPtr->tosPtr = &esPtr->stackWords[-1];
-
     Tcl_MutexLock(&execMutex);
     if (!execInitialized) {
 	TclInitAuxDataTypeTable();
@@ -892,42 +864,14 @@ TclCreateExecEnv(
  *----------------------------------------------------------------------
  */
 
-static void
-DeleteExecStack(
-    ExecStack *esPtr)
-{
-    if (esPtr->markerPtr) {
-	Tcl_Panic("freeing an execStack which is still in use");
-    }
-
-    if (esPtr->prevPtr) {
-	esPtr->prevPtr->nextPtr = esPtr->nextPtr;
-    }
-    if (esPtr->nextPtr) {
-	esPtr->nextPtr->prevPtr = esPtr->prevPtr;
-    }
-    ckfree(esPtr);
-}
-
 void
 TclDeleteExecEnv(
     ExecEnv *eePtr)		/* Execution environment to free. */
 {
-    ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
-
     /*
      * Delete all stacks in this exec env.
      */
 
-    while (esPtr->nextPtr) {
-	esPtr = esPtr->nextPtr;
-    }
-    while (esPtr) {
-	tmpPtr = esPtr;
-	esPtr = tmpPtr->prevPtr;
-	DeleteExecStack(tmpPtr);
-    }
-
     TclDecrRefCount(eePtr->constants[0]);
     TclDecrRefCount(eePtr->constants[1]);
     if (eePtr->callbackPtr) {
@@ -967,339 +911,6 @@ TclFinalizeExecution(void)
 }
 
 /*
- * Auxiliary code to insure that GrowEvaluationStack always returns correctly
- * aligned memory.
- *
- * WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN
- * represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a
- * multiple of the wordsize 'sizeof(Tcl_Obj *)'.
- */
-
-#define WALLOCALIGN \
-    (TCL_ALLOCALIGN/sizeof(Tcl_Obj *))
-
-/*
- * OFFSET computes how many words have to be skipped until the next aligned
- * word. Note that we are only interested in the low order bits of ptr, so
- * that any possible information loss in PTR2INT is of no consequence.
- */
-
-static inline int
-OFFSET(
-    void *ptr)
-{
-    int mask = TCL_ALLOCALIGN-1;
-    int base = PTR2INT(ptr) & mask;
-    return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *);
-}
-
-/*
- * Given a marker, compute where the following aligned memory starts.
- */
-
-#define MEMSTART(markerPtr) \
-    ((markerPtr) + OFFSET(markerPtr))
-
-/*
- *----------------------------------------------------------------------
- *
- * GrowEvaluationStack --
- *
- *	This procedure grows a Tcl evaluation stack stored in an ExecEnv,
- *	copying over the words since the last mark if so requested. A mark is
- *	set at the beginning of the new area when no copying is requested.
- *
- * Results:
- *	Returns a pointer to the first usable word in the (possibly) grown
- *	stack.
- *
- * Side effects:
- *	The size of the evaluation stack may be grown, a marker is set
- *
- *----------------------------------------------------------------------
- */
-
-static Tcl_Obj **
-GrowEvaluationStack(
-    ExecEnv *eePtr,		/* Points to the ExecEnv with an evaluation
-				 * stack to enlarge. */
-    int growth,			/* How much larger than the current used
-				 * size. */
-    int move)			/* 1 if move words since last marker. */
-{
-    ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
-    int newBytes, newElems, currElems;
-    int needed = growth - (esPtr->endPtr - esPtr->tosPtr);
-    Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;
-    int moveWords = 0;
-
-    if (move) {
-	if (!markerPtr) {
-	    Tcl_Panic("STACK: Reallocating with no previous alloc");
-	}
-	if (needed <= 0) {
-	    return MEMSTART(markerPtr);
-	}
-    } else {
-	Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
-	int offset = OFFSET(tmpMarkerPtr);
-
-	if (needed + offset < 0) {
-	    /*
-	     * Put a marker pointing to the previous marker in this stack, and
-	     * store it in esPtr as the current marker. Return a pointer to
-	     * the start of aligned memory.
-	     */
-
-	    esPtr->markerPtr = tmpMarkerPtr;
-	    memStart = tmpMarkerPtr + offset;
-	    esPtr->tosPtr = memStart - 1;
-	    *esPtr->markerPtr = (Tcl_Obj *) markerPtr;
-	    return memStart;
-	}
-    }
-
-    /*
-     * Reset move to hold the number of words to be moved to new stack (if
-     * any) and growth to hold the complete stack requirements: add one for
-     * the marker, (WALLOCALIGN-1) for the maximal possible offset.
-     */
-
-    if (move) {
-	moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
-    }
-    needed = growth + moveWords + WALLOCALIGN;
-
-    /*
-     * Check if there is enough room in the next stack (if there is one, it
-     * should be both empty and the last one!)
-     */
-
-    if (esPtr->nextPtr) {
-	oldPtr = esPtr;
-	esPtr = oldPtr->nextPtr;
-	currElems = esPtr->endPtr - &esPtr->stackWords[-1];
-	if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) {
-	    Tcl_Panic("STACK: Stack after current is in use");
-	}
-	if (esPtr->nextPtr) {
-	    Tcl_Panic("STACK: Stack after current is not last");
-	}
-	if (needed <= currElems) {
-	    goto newStackReady;
-	}
-	DeleteExecStack(esPtr);
-	esPtr = oldPtr;
-    } else {
-	currElems = esPtr->endPtr - &esPtr->stackWords[-1];
-    }
-
-    /*
-     * We need to allocate a new stack! It needs to store 'growth' words,
-     * including the elements to be copied over and the new marker.
-     */
-
-    newElems = 2*currElems;
-    while (needed > newElems) {
-	newElems *= 2;
-    }
-    newBytes = sizeof(ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
-
-    oldPtr = esPtr;
-    esPtr = ckalloc(newBytes);
-
-    oldPtr->nextPtr = esPtr;
-    esPtr->prevPtr = oldPtr;
-    esPtr->nextPtr = NULL;
-    esPtr->endPtr = &esPtr->stackWords[newElems-1];
-
-  newStackReady:
-    eePtr->execStackPtr = esPtr;
-
-    /*
-     * Store a NULL marker at the beginning of the stack, to indicate that
-     * this is the first marker in this stack and that rewinding to here
-     * should actually be a return to the previous stack.
-     */
-
-    esPtr->stackWords[0] = NULL;
-    esPtr->markerPtr = &esPtr->stackWords[0];
-    memStart = MEMSTART(esPtr->markerPtr);
-    esPtr->tosPtr = memStart - 1;
-
-    if (move) {
-	memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *));
-	esPtr->tosPtr += moveWords;
-	oldPtr->markerPtr = (Tcl_Obj **) *markerPtr;
-	oldPtr->tosPtr = markerPtr-1;
-    }
-
-    /*
-     * Free the old stack if it is now unused.
-     */
-
-    if (!oldPtr->markerPtr) {
-	DeleteExecStack(oldPtr);
-    }
-
-    return memStart;
-}
-
-/*
- *--------------------------------------------------------------
- *
- * TclStackAlloc, TclStackRealloc, TclStackFree --
- *
- *	Allocate memory from the execution stack; it has to be returned later
- *	with a call to TclStackFree.
- *
- * Results:
- *	A pointer to the first byte allocated, or panics if the allocation did
- *	not succeed.
- *
- * Side effects:
- *	The execution stack may be grown.
- *
- *--------------------------------------------------------------
- */
-
-static Tcl_Obj **
-StackAllocWords(
-    Tcl_Interp *interp,
-    int numWords)
-{
-    /*
-     * Note that GrowEvaluationStack sets a marker in the stack. This marker
-     * is read when rewinding, e.g., by TclStackFree.
-     */
-
-    Interp *iPtr = (Interp *) interp;
-    ExecEnv *eePtr = iPtr->execEnvPtr;
-    Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0);
-
-    eePtr->execStackPtr->tosPtr += numWords;
-    return resPtr;
-}
-
-static Tcl_Obj **
-StackReallocWords(
-    Tcl_Interp *interp,
-    int numWords)
-{
-    Interp *iPtr = (Interp *) interp;
-    ExecEnv *eePtr = iPtr->execEnvPtr;
-    Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1);
-
-    eePtr->execStackPtr->tosPtr += numWords;
-    return resPtr;
-}
-
-void
-TclStackFree(
-    Tcl_Interp *interp,
-    void *freePtr)
-{
-    Interp *iPtr = (Interp *) interp;
-    ExecEnv *eePtr;
-    ExecStack *esPtr;
-    Tcl_Obj **markerPtr, *marker;
-
-    if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
-	Tcl_Free((char *) freePtr);
-	return;
-    }
-
-    /*
-     * Rewind the stack to the previous marker position. The current marker,
-     * as set in the last call to GrowEvaluationStack, contains a pointer to
-     * the previous marker.
-     */
-
-    eePtr = iPtr->execEnvPtr;
-    esPtr = eePtr->execStackPtr;
-    markerPtr = esPtr->markerPtr;
-    marker = *markerPtr;
-
-    if ((freePtr != NULL) && (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr)) {
-	Tcl_Panic("TclStackFree: incorrect freePtr (%p != %p). Call out of sequence?",
-		freePtr, MEMSTART(markerPtr));
-    }
-
-    esPtr->tosPtr = markerPtr - 1;
-    esPtr->markerPtr = (Tcl_Obj **) marker;
-    if (marker) {
-	return;
-    }
-
-    /*
-     * Return to previous active stack. Note that repeated expansions or
-     * reallocs could have generated several unused intervening stacks: free
-     * them too.
-     */
-
-    while (esPtr->nextPtr) {
-	esPtr = esPtr->nextPtr;
-    }
-    esPtr->tosPtr = &esPtr->stackWords[-1];
-    while (esPtr->prevPtr) {
-	ExecStack *tmpPtr = esPtr->prevPtr;
-	if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) {
-	    DeleteExecStack(tmpPtr);
-	} else {
-	    break;
-	}
-    }
-    if (esPtr->prevPtr) {
-	eePtr->execStackPtr = esPtr->prevPtr;
-    } else {
-	eePtr->execStackPtr = esPtr;
-    }	
-}
-
-void *
-TclStackAlloc(
-    Tcl_Interp *interp,
-    int numBytes)
-{
-    Interp *iPtr = (Interp *) interp;
-    int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
-
-    if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
-	return (void *) Tcl_Alloc(numBytes);
-    }
-
-    return (void *) StackAllocWords(interp, numWords);
-}
-
-void *
-TclStackRealloc(
-    Tcl_Interp *interp,
-    void *ptr,
-    int numBytes)
-{
-    Interp *iPtr = (Interp *) interp;
-    ExecEnv *eePtr;
-    ExecStack *esPtr;
-    Tcl_Obj **markerPtr;
-    int numWords;
-
-    if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
-	return (void *) Tcl_Realloc((char *) ptr, numBytes);
-    }
-
-    eePtr = iPtr->execEnvPtr;
-    esPtr = eePtr->execStackPtr;
-    markerPtr = esPtr->markerPtr;
-
-    if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) {
-	Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?");
-    }
-
-    numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
-    return (void *) StackReallocWords(interp, numWords);
-}
-
-/*
  *--------------------------------------------------------------
  *
  * Tcl_ExprObj --
@@ -1697,7 +1308,7 @@ TclCompileObj(
 		int redo = 0;
 
 		if (invoker) {
-		    CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame));
+		    CmdFrame *ctxPtr = ckalloc(sizeof(CmdFrame));
 		    *ctxPtr = *invoker;
 
 		    if (invoker->type == TCL_LOCATION_BC) {
@@ -1736,7 +1347,7 @@ TclCompileObj(
 				    && (ctxPtr->type == TCL_LOCATION_SOURCE));
 		    }
 
-		    TclStackFree(interp, ctxPtr);
+		    ckfree(ctxPtr);
 		}
 
 		if (redo) {
@@ -1921,9 +1532,8 @@ TclIncrObj(
  *----------------------------------------------------------------------
  */
 #define	bcFramePtr	(&TD->cmdFrame)
-#define	initCatchTop	((ptrdiff_t *) (&TD->stack[-1]))
-#define	initTosPtr	((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
-#define esPtr           (iPtr->execEnvPtr->execStackPtr)
+#define	catchStack	(TD->stack)
+#define	initTosPtr	((Tcl_Obj **) &TD->stack[codePtr->maxExceptDepth - 1])
 
 int
 TclNRExecuteByteCode(
@@ -1932,10 +1542,8 @@ TclNRExecuteByteCode(
 {
     Interp *iPtr = (Interp *) interp;
     TEBCdata *TD;
-    int size = sizeof(TEBCdata) -1 + 
-	    + (codePtr->maxStackDepth + codePtr->maxExceptDepth)
-	         *(sizeof(void *));
-    int numWords = (size + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *);
+    unsigned int size = sizeof(TEBCdata) + sizeof(void *) *
+	  (codePtr->maxStackDepth + codePtr->maxExceptDepth - 1);       
     
     if (iPtr->execEnvPtr->rewind) {
 	return TCL_ERROR;
@@ -1955,15 +1563,16 @@ TclNRExecuteByteCode(
      * execution stack is large enough to execute this ByteCode.
      */
 
-    TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0);
-    esPtr->tosPtr = initTosPtr;
+    TD = ckalloc(size);
+    TD->tosPtr = initTosPtr;
     
     TD->codePtr     = codePtr;
     TD->pc          = codePtr->codeStart;
-    TD->catchTop    = initCatchTop;
+    TD->catchDepth  = -1;
     TD->cleanup     = 0;
     TD->auxObjList  = NULL;
     TD->checkInterp = 0;
+    TD->capacity = codePtr->maxStackDepth;
     
     /*
      * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
@@ -2048,11 +1657,11 @@ TEBCresume(
 
     TEBCdata *TD = data[0];
 #define auxObjList	(TD->auxObjList)
-#define catchTop	(TD->catchTop)
+#define catchDepth	(TD->catchDepth)
 #define codePtr         (TD->codePtr)
 #define checkInterp	(TD->checkInterp)
                         /* Indicates when a check of interp readyness
-			 * is necessary. Set by CACHE_STACK_INFO() */
+			 * is necessary. Set by checkInterp = 1 */
 
     /*
      * Globals: variables that store state, must remain valid at all times.
@@ -2113,7 +1722,7 @@ TEBCresume(
 	    codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
 	}
 
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	if (result == TCL_OK) {
 #ifndef TCL_COMPILE_DEBUG
 	    if (*pc == INST_POP) {
@@ -2253,29 +1862,28 @@ TEBCresume(
      */
 
     if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
-	DECACHE_STACK_INFO();
 	if (TclAsyncReady(iPtr)) {
 	    result = Tcl_AsyncInvoke(interp, result);
 	    if (result == TCL_ERROR) {
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 		goto gotError;
 	    }
 	}
 
 	if (TclCanceled(iPtr)) {
 	    if (Tcl_Canceled(interp, TCL_LEAVE_ERR_MSG) == TCL_ERROR) {
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 		goto gotError;
 	    }
 	}
 
 	if (TclLimitReady(iPtr->limit)) {
 	    if (Tcl_LimitCheck(interp) == TCL_ERROR) {
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 		goto gotError;
 	    }
 	}
-	CACHE_STACK_INFO();
+	checkInterp = 1;
     }
 
     TCL_DTRACE_INST_NEXT();
@@ -2643,7 +2251,7 @@ TEBCresume(
 
     case INST_EXPAND_STKTOP: {
 	int i;
-	ptrdiff_t moved;
+	unsigned int reqWords;
 
 	/*
 	 * Make sure that the element at stackTop is a list; if not, just
@@ -2657,7 +2265,6 @@ TEBCresume(
 		    Tcl_GetObjResult(interp));
 	    goto gotError;
 	}
-	(void) POP_OBJECT();
 
 	/*
 	 * Make sure there is enough room in the stack to expand this list
@@ -2666,24 +2273,26 @@ TEBCresume(
 	 * stack depth, as seen by the compiler.
 	 */
 
-	length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
-	DECACHE_STACK_INFO();
-	moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
-		- (Tcl_Obj **) TD;
-	if (moved) {
-	    /*
-	     * Change the global data to point to the new stack: move the
-	     * TEBCdataPtr TD, recompute the position of every other
-	     * stack-allocated parameter, update the stack pointers.
-	     */
-
-	    esPtr = iPtr->execEnvPtr->execStackPtr;
-	    TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
+	reqWords =
+	    /* how many were needed originally */
+	    codePtr->maxStackDepth
+	    /* plus how many we already consumed in previous expansions */
+	    + (CURR_DEPTH - TclGetInt4AtPtr(pc+1))
+	    /* plus how many are needed for this expansion */
+	    + objc - 1;
 
-	    catchTop += moved;
-	    tosPtr += moved;
+	(void) POP_OBJECT();
+	if (reqWords > TD->capacity) {
+	    ptrdiff_t depth;
+	    unsigned int size = sizeof(TEBCdata) + sizeof(void *) *
+		+ (reqWords + codePtr->maxExceptDepth - 1);
+	    
+	    depth = tosPtr - initTosPtr;
+	    TD = ckrealloc(TD, size);
+	    tosPtr = initTosPtr + depth;
+	    TD->capacity = reqWords;
 	}
-
+	
 	/*
 	 * Expand the list at stacktop onto the stack; free the list. Knowing
 	 * that it has a freeIntRepProc we use Tcl_DecrRefCount().
@@ -2702,9 +2311,8 @@ TEBCresume(
 
 	bcFramePtr->data.tebc.pc = (char *) pc;
 	iPtr->cmdFramePtr = bcFramePtr;
-	DECACHE_STACK_INFO();
 	newCodePtr = CompileExprObj(interp, OBJ_AT_TOS);
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	cleanup = 1;
 	pc++;
 	TEBC_YIELD();
@@ -2790,8 +2398,6 @@ TEBCresume(
 		    codePtr, bcFramePtr, pc - codePtr->codeStart);
 	}
 
-	DECACHE_STACK_INFO();
-
 	pc += pcAdjustment;
 	TEBC_YIELD();
 	return TclNREvalObjv(interp, objc, objv,
@@ -3016,10 +2622,9 @@ TEBCresume(
 	 * TclPtrGetVar to process fully.
 	 */
 
-	DECACHE_STACK_INFO();
 	objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
 		part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	if (!objResultPtr) {
 	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
 	    goto gotError;
@@ -3263,10 +2868,9 @@ TEBCresume(
 	part1Ptr = part2Ptr = NULL;
 
     doCallPtrSetVar:
-	DECACHE_STACK_INFO();
 	objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
 		part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	if (!objResultPtr) {
 	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
 	    goto gotError;
@@ -3527,10 +3131,9 @@ TEBCresume(
 	    }
 	    Tcl_DecrRefCount(incrPtr);
 	} else {
-	    DECACHE_STACK_INFO();
 	    objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr,
 		    part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    Tcl_DecrRefCount(incrPtr);
 	    if (objResultPtr == NULL) {
 		TRACE_APPEND(("ERROR: %.30s\n",
@@ -3562,10 +3165,9 @@ TEBCresume(
 	}
 	TRACE(("%u => ", opnd));
 	if (ReadTraced(varPtr)) {
-	    DECACHE_STACK_INFO();
 	    TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL,
 		    TCL_TRACE_READS, 0, opnd);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    if (TclIsVarUndefined(varPtr)) {
 		TclCleanupVar(varPtr, NULL);
 		varPtr = NULL;
@@ -3598,10 +3200,9 @@ TEBCresume(
 		0, 1, arrayPtr, opnd);
 	if (varPtr) {
 	    if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
-		DECACHE_STACK_INFO();
 		TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr,
 			TCL_TRACE_READS, 0, opnd);
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 	    }
 	    if (TclIsVarUndefined(varPtr)) {
 		TclCleanupVar(varPtr, arrayPtr);
@@ -3631,10 +3232,9 @@ TEBCresume(
 		/*createPart1*/0, /*createPart2*/1, &arrayPtr);
 	if (varPtr) {
 	    if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
-		DECACHE_STACK_INFO();
 		TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr,
 			TCL_TRACE_READS, 0, -1);
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 	    }
 	    if (TclIsVarUndefined(varPtr)) {
 		TclCleanupVar(varPtr, arrayPtr);
@@ -3678,12 +3278,11 @@ TEBCresume(
 	}
 
     slowUnsetScalar:
-	DECACHE_STACK_INFO();
 	if (TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags,
 		opnd) != TCL_OK && flags) {
 	    goto errorInUnset;
 	}
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	NEXT_INST_F(6, 0, 0);
 
     case INST_UNSET_ARRAY:
@@ -3720,7 +3319,6 @@ TEBCresume(
 	    }
 	}
     slowUnsetArray:
-	DECACHE_STACK_INFO();
 	varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset",
 		0, 0, arrayPtr, opnd);
 	if (!varPtr) {
@@ -3731,7 +3329,7 @@ TEBCresume(
 		flags, opnd) != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) {
 	    goto errorInUnset;
 	}
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	NEXT_INST_F(6, 1, 0);
 
     case INST_UNSET_ARRAY_STK:
@@ -3751,16 +3349,15 @@ TEBCresume(
 	TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr)));
 
     doUnsetStk:
-	DECACHE_STACK_INFO();
 	if (TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags) != TCL_OK
 		&& (flags & TCL_LEAVE_ERR_MSG)) {
 	    goto errorInUnset;
 	}
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	NEXT_INST_V(2, cleanup, 0);
 
     errorInUnset:
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
 	goto gotError;
 
@@ -3781,9 +3378,8 @@ TEBCresume(
 	    }
 	    varPtr->value.objPtr = NULL;
 	} else {
-	    DECACHE_STACK_INFO();
 	    TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	}
 	NEXT_INST_F(5, 0, 0);
     }
@@ -4024,18 +3620,16 @@ TEBCresume(
 	if (TclGetBooleanFromObj(NULL, valuePtr, &i1) != TCL_OK) {
 	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
 		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, valuePtr);
-	    CACHE_STACK_INFO();	    
+	    checkInterp = 1;	    
 	    goto gotError;
 	}
 
 	if (TclGetBooleanFromObj(NULL, value2Ptr, &i2) != TCL_OK) {
 	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
 		    (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, value2Ptr);
-	    CACHE_STACK_INFO();	    
+	    checkInterp = 1;	    
 	    goto gotError;
 	}
 
@@ -4812,9 +4406,8 @@ TEBCresume(
 	    TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
 		    O2S(value2Ptr), (valuePtr->typePtr?
 		    valuePtr->typePtr->name : "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, valuePtr);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    goto gotError;
 	}
 
@@ -4823,9 +4416,8 @@ TEBCresume(
 	    TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
 		    O2S(value2Ptr), (value2Ptr->typePtr?
 		    value2Ptr->typePtr->name : "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, value2Ptr);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    goto gotError;
 	}
 
@@ -4883,11 +4475,10 @@ TEBCresume(
 		    Tcl_SetResult(interp, "negative shift argument",
 			    TCL_STATIC);
 #if 0
-		    DECACHE_STACK_INFO();
 		    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
 			    "domain error: argument not in valid range",
 			    NULL);
-		    CACHE_STACK_INFO();
+		    checkInterp = 1;
 #endif
 		    goto gotError;
 		} else if (l1 == 0) {
@@ -4931,11 +4522,10 @@ TEBCresume(
 		    Tcl_SetResult(interp, "negative shift argument",
 			    TCL_STATIC);
 #if 0
-		    DECACHE_STACK_INFO();
 		    Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
 			    "domain error: argument not in valid range",
 			    NULL);
-		    CACHE_STACK_INFO();
+		    checkInterp = 1;
 #endif
 		    goto gotError;
 		} else if (l1 == 0) {
@@ -4955,10 +4545,9 @@ TEBCresume(
 			    "integer value too large to represent",
 			    TCL_STATIC);
 #if 0
-		    DECACHE_STACK_INFO();
 		    Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
 			    "integer value too large to represent", NULL);
-		    CACHE_STACK_INFO();
+		    checkInterp = 1;
 #endif
 		    goto gotError;
 		} else {
@@ -5041,9 +4630,8 @@ TEBCresume(
 	    TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
 		    O2S(value2Ptr), O2S(valuePtr),
 		    (valuePtr->typePtr? valuePtr->typePtr->name: "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, valuePtr);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    goto gotError;
 	}
 
@@ -5062,9 +4650,8 @@ TEBCresume(
 	    TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
 		    O2S(value2Ptr), O2S(valuePtr),
 		    (value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, value2Ptr);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    goto gotError;
 	}
 
@@ -5211,9 +4798,8 @@ TEBCresume(
 	if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) {
 	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
 		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, valuePtr);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    goto gotError;
 	}
 	/* TODO: Consider peephole opt. */
@@ -5231,9 +4817,8 @@ TEBCresume(
 
 	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
 		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, valuePtr);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    goto gotError;
 	}
 	if (type1 == TCL_NUMBER_LONG) {
@@ -5258,9 +4843,8 @@ TEBCresume(
 		|| IsErroringNaNType(type1)) {
 	    TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
 		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
-	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, valuePtr);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    goto gotError;
 	}
 	switch (type1) {
@@ -5304,9 +4888,8 @@ TEBCresume(
 
 		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
 			(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
-		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, valuePtr);
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 		goto gotError;
 	    }
 
@@ -5322,9 +4905,8 @@ TEBCresume(
 
 		TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
 			(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
-		DECACHE_STACK_INFO();
 		IllegalExprOperandType(interp, pc, valuePtr);
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 	    } else {
 		/*
 		 * Numeric conversion of NaN -> error.
@@ -5332,9 +4914,8 @@ TEBCresume(
 
 		TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
 			O2S(objResultPtr)));
-		DECACHE_STACK_INFO();
 		TclExprFloatError(interp, *((const double *) ptr1));
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 	    }
 	    goto gotError;
 	}
@@ -5379,9 +4960,8 @@ TEBCresume(
 
     case INST_BREAK:
 	/*
-	DECACHE_STACK_INFO();
 	Tcl_ResetResult(interp);
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	*/
 	result = TCL_BREAK;
 	cleanup = 0;
@@ -5389,9 +4969,8 @@ TEBCresume(
 
     case INST_CONTINUE:
 	/*
-	DECACHE_STACK_INFO();
 	Tcl_ResetResult(interp);
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	*/
 	result = TCL_CONTINUE;
 	cleanup = 0;
@@ -5524,17 +5103,16 @@ TEBCresume(
 			    Tcl_IncrRefCount(valuePtr);
 			}
 		    } else {
-			DECACHE_STACK_INFO();
 			if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
 				valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
-			    CACHE_STACK_INFO();
+			    checkInterp = 1;
 			    TRACE_WITH_OBJ((
 				    "%u => ERROR init. index temp %d: ",
 				    opnd,varIndex), Tcl_GetObjResult(interp));
 			    TclDecrRefCount(listPtr);
 			    goto gotError;
 			}
-			CACHE_STACK_INFO();
+			checkInterp = 1;
 		    }
 		    valIndex++;
 		}
@@ -5566,19 +5144,18 @@ TEBCresume(
 	 * stack.
 	 */
 
-	*(++catchTop) = CURR_DEPTH;
-	TRACE(("%u => catchTop=%d, stackTop=%d\n",
-		TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
+	catchStack[++catchDepth] = INT2PTR(CURR_DEPTH);
+	TRACE(("%u => catchDepth=%d, stackTop=%d\n",
+		TclGetUInt4AtPtr(pc+1), (int) (catchDepth),
 		(int) CURR_DEPTH));
 	NEXT_INST_F(5, 0, 0);
 
     case INST_END_CATCH:
-	catchTop--;
-	DECACHE_STACK_INFO();
+	catchDepth--;
 	Tcl_ResetResult(interp);
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	result = TCL_OK;
-	TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1)));
+	TRACE(("=> catchDepth=%d\n", (int) (catchDepth)));
 	NEXT_INST_F(1, 0, 0);
 
     case INST_PUSH_RESULT:
@@ -5600,9 +5177,8 @@ TEBCresume(
 	NEXT_INST_F(1, 0, 1);
 
     case INST_PUSH_RETURN_OPTIONS:
-	DECACHE_STACK_INFO();
 	objResultPtr = Tcl_GetReturnOptions(interp, result);
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 	TRACE_WITH_OBJ(("=> "), objResultPtr);
 	NEXT_INST_F(1, 0, 1);
 
@@ -5654,13 +5230,12 @@ TEBCresume(
 		TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
 		NEXT_INST_V(5, opnd+1, 1);
 	    }
-	    DECACHE_STACK_INFO();
 	    Tcl_ResetResult(interp);
 	    Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS),
 		    "\" not known in dictionary", NULL);
 	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
 		    TclGetString(OBJ_AT_TOS), NULL);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
 	} else {
 	    TRACE_WITH_OBJ((
@@ -5683,9 +5258,8 @@ TEBCresume(
 	if (TclIsVarDirectReadable(varPtr)) {
 	    dictPtr = varPtr->value.objPtr;
 	} else {
-	    DECACHE_STACK_INFO();
 	    dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	}
 	if (dictPtr == NULL) {
 	    TclNewObj(dictPtr);
@@ -5757,10 +5331,9 @@ TEBCresume(
 	    objResultPtr = dictPtr;
 	} else {
 	    Tcl_IncrRefCount(dictPtr);
-	    DECACHE_STACK_INFO();
 	    objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
 		    dictPtr, TCL_LEAVE_ERR_MSG, opnd2);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    TclDecrRefCount(dictPtr);
 	    if (objResultPtr == NULL) {
 		TRACE_APPEND(("ERROR: %.30s\n",
@@ -5787,9 +5360,8 @@ TEBCresume(
 	if (TclIsVarDirectReadable(varPtr)) {
 	    dictPtr = varPtr->value.objPtr;
 	} else {
-	    DECACHE_STACK_INFO();
 	    dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	}
 	if (dictPtr == NULL) {
 	    TclNewObj(dictPtr);
@@ -5893,10 +5465,9 @@ TEBCresume(
 	    objResultPtr = dictPtr;
 	} else {
 	    Tcl_IncrRefCount(dictPtr);
-	    DECACHE_STACK_INFO();
 	    objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
 		    dictPtr, TCL_LEAVE_ERR_MSG, opnd);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    TclDecrRefCount(dictPtr);
 	    if (objResultPtr == NULL) {
 		TRACE_APPEND(("ERROR: %.30s\n",
@@ -5998,10 +5569,9 @@ TEBCresume(
 	if (TclIsVarDirectReadable(varPtr)) {
 	    dictPtr = varPtr->value.objPtr;
 	} else {
-	    DECACHE_STACK_INFO();
 	    dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL,
 		    TCL_LEAVE_ERR_MSG, opnd);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    if (dictPtr == NULL) {
 		goto gotError;
 	    }
@@ -6022,7 +5592,6 @@ TEBCresume(
 	    while (TclIsVarLink(varPtr)) {
 		varPtr = varPtr->value.linkPtr;
 	    }
-	    DECACHE_STACK_INFO();
 	    if (valuePtr == NULL) {
 		TclObjUnsetVar2(interp,
 			localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
@@ -6030,10 +5599,10 @@ TEBCresume(
 	    } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
 		    valuePtr, TCL_LEAVE_ERR_MSG,
 		    duiPtr->varIndices[i]) == NULL) {
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 		goto gotError;
 	    }
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	}
 	NEXT_INST_F(9, 0, 0);
 
@@ -6049,9 +5618,8 @@ TEBCresume(
 	if (TclIsVarDirectReadable(varPtr)) {
 	    dictPtr = varPtr->value.objPtr;
 	} else {
-	    DECACHE_STACK_INFO();
 	    dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	}
 	if (dictPtr == NULL) {
 	    NEXT_INST_F(9, 1, 0);
@@ -6077,10 +5645,9 @@ TEBCresume(
 	    if (TclIsVarDirectReadable(var2Ptr)) {
 		valuePtr = var2Ptr->value.objPtr;
 	    } else {
-		DECACHE_STACK_INFO();
 		valuePtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0,
 			duiPtr->varIndices[i]);
-		CACHE_STACK_INFO();
+		checkInterp = 1;
 	    }
 	    if (valuePtr == NULL) {
 		Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);
@@ -6096,10 +5663,9 @@ TEBCresume(
 	    TclDecrRefCount(varPtr->value.objPtr);
 	    varPtr->value.objPtr = dictPtr;
 	} else {
-	    DECACHE_STACK_INFO();
 	    objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
 		    dictPtr, TCL_LEAVE_ERR_MSG, opnd);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	    if (objResultPtr == NULL) {
 		if (allocdict) {
 		    TclDecrRefCount(dictPtr);
@@ -6215,10 +5781,9 @@ TEBCresume(
 	 */
 
     divideByZero:
-	DECACHE_STACK_INFO();	
 	Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
 	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
-	CACHE_STACK_INFO();	
+	checkInterp = 1;	
 	goto gotError;
 
 	/*
@@ -6227,12 +5792,11 @@ TEBCresume(
 	 */
 
     exponOfZero:
-	DECACHE_STACK_INFO();	
 	Tcl_SetResult(interp, "exponentiation of zero by negative power",
 		TCL_STATIC);
 	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
 		"exponentiation of zero by negative power", NULL);
-	CACHE_STACK_INFO();
+	checkInterp = 1;
 
 	/*
 	 * Almost all error paths feed through here rather than assigning to
@@ -6258,9 +5822,8 @@ TEBCresume(
 	    const unsigned char *pcBeg;
 
 	    bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg);
-	    DECACHE_STACK_INFO();
 	    TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr);
-	    CACHE_STACK_INFO();
+	    checkInterp = 1;
 	}
 	iPtr->flags &= ~ERR_ALREADY_LOGGED;
 
@@ -6270,8 +5833,8 @@ TEBCresume(
 	 */
 
 	while (auxObjList) {
-	    if ((catchTop != initCatchTop) && (*catchTop >
-		    (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) {
+	    if ((catchDepth >=0) && (PTR2INT(catchStack[catchDepth]) >
+		        PTR2INT(auxObjList->internalRep.twoPtrValue.ptr1))) {
 		break;
 	    }
 	    POP_TAUX_OBJ();
@@ -6311,7 +5874,7 @@ TEBCresume(
 #endif
 	    goto abnormalReturn;
 	}
-	if (catchTop == initCatchTop) {
+	if (catchDepth == -1) {
 #ifdef TCL_COMPILE_DEBUG
 	    if (traceInstructions) {
 		fprintf(stdout, "   ... no enclosing catch, returning %s\n",
@@ -6346,16 +5909,16 @@ TEBCresume(
 	 */
 
     processCatch:
-	while (CURR_DEPTH > *catchTop) {
+	while (CURR_DEPTH > PTR2INT(catchStack[catchDepth])) {
 	    valuePtr = POP_OBJECT();
 	    TclDecrRefCount(valuePtr);
 	}
 #ifdef TCL_COMPILE_DEBUG
 	if (traceInstructions) {
-	    fprintf(stdout, "  ... found catch at %d, catchTop=%d, "
+	    fprintf(stdout, "  ... found catch at %d, catchDepth=%d, "
 		    "unwound to %ld, new pc %u\n",
-		    rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1),
-		    (long) *catchTop, (unsigned) rangePtr->catchOffset);
+		    rangePtr->codeOffset, (int) catchDepth,
+		    PTR2INT(catchStack[catchDepth]), (unsigned) rangePtr->catchOffset);
 	}
 #endif
 	pc = (codePtr->codeStart + rangePtr->catchOffset);
@@ -6404,7 +5967,7 @@ TEBCresume(
     if (--codePtr->refCount <= 0) {
 	TclCleanupByteCode(codePtr);
     }
-    TclStackFree(interp, TD);	/* free my stack */
+    ckfree(TD);	/* free my stack */
 
     return result;
 }
@@ -6412,10 +5975,9 @@ TEBCresume(
 #undef codePtr
 #undef iPtr
 #undef bcFramePtr
-#undef initCatchTop
 #undef initTosPtr
 #undef auxObjList
-#undef catchTop
+#undef catchDepth
 #undef TCONST
 
 /*
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 6d3c013..52ad278 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -999,7 +999,7 @@ TclFileAttrsCmd(
 	    goto end;
 	}
 	attributeStringsAllocated = (const char **)
-		TclStackAlloc(interp, (1+numObjStrings) * sizeof(char *));
+		ckalloc((1+numObjStrings) * sizeof(char *));
 	for (index = 0; index < numObjStrings; index++) {
 	    Tcl_ListObjIndex(interp, objStrings, index, &objPtr);
 	    attributeStringsAllocated[index] = TclGetString(objPtr);
@@ -1110,7 +1110,7 @@ TclFileAttrsCmd(
 	 * Free up the array we allocated.
 	 */
 
-	TclStackFree(interp, (void *) attributeStringsAllocated);
+	ckfree((void *) attributeStringsAllocated);
 
 	/*
 	 * We don't need this object that was passed to us any more.
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index d53c271..eff1010 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -1422,7 +1422,7 @@ Tcl_GlobObjCmd(
 	if (length <= 0) {
 	    goto skipTypes;
 	}
-	globTypes = TclStackAlloc(interp, sizeof(Tcl_GlobTypeData));
+	globTypes = ckalloc(sizeof(Tcl_GlobTypeData));
 	globTypes->type = 0;
 	globTypes->perm = 0;
 	globTypes->macType = NULL;
@@ -1638,7 +1638,7 @@ Tcl_GlobObjCmd(
 	if (globTypes->macCreator != NULL) {
 	    Tcl_DecrRefCount(globTypes->macCreator);
 	}
-	TclStackFree(interp, globTypes);
+	ckfree(globTypes);
     }
     return result;
 }
diff --git a/generic/tclIOCmd.c b/generic/tclIOCmd.c
index 1f0e4a9..ffa172a 100644
--- a/generic/tclIOCmd.c
+++ b/generic/tclIOCmd.c
@@ -929,7 +929,7 @@ Tcl_ExecObjCmd(
      */
 
     argc = objc - skip;
-    argv = TclStackAlloc(interp, (unsigned)(argc + 1) * sizeof(char *));
+    argv = ckalloc((unsigned)(argc + 1) * sizeof(char *));
 
     /*
      * Copy the string conversions of each (post option) object into the
@@ -947,7 +947,7 @@ Tcl_ExecObjCmd(
      * Free the argv array.
      */
 
-    TclStackFree(interp, (void *) argv);
+    ckfree((void *) argv);
 
     if (chan == NULL) {
 	return TCL_ERROR;
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index d98842e..f9511af 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -952,12 +952,12 @@ Tcl_WrongNumArgs(
 	    len = Tcl_ScanCountedElement(elementStr, elemLen, &flags);
 
 	    if (MAY_QUOTE_WORD && len != elemLen) {
-		char *quotedElementStr = TclStackAlloc(interp, (unsigned)len);
+		char *quotedElementStr = ckalloc((unsigned)len);
 
 		len = Tcl_ConvertCountedElement(elementStr, elemLen,
 			quotedElementStr, flags);
 		Tcl_AppendToObj(objPtr, quotedElementStr, len);
-		TclStackFree(interp, quotedElementStr);
+		ckfree(quotedElementStr);
 	    } else {
 		Tcl_AppendToObj(objPtr, elementStr, elemLen);
 	    }
@@ -1006,12 +1006,12 @@ Tcl_WrongNumArgs(
 	    len = Tcl_ScanCountedElement(elementStr, elemLen, &flags);
 
 	    if (MAY_QUOTE_WORD && len != elemLen) {
-		char *quotedElementStr = TclStackAlloc(interp,(unsigned) len);
+		char *quotedElementStr = ckalloc((unsigned) len);
 
 		len = Tcl_ConvertCountedElement(elementStr, elemLen,
 			quotedElementStr, flags);
 		Tcl_AppendToObj(objPtr, quotedElementStr, len);
-		TclStackFree(interp, quotedElementStr);
+		ckfree(quotedElementStr);
 	    } else {
 		Tcl_AppendToObj(objPtr, elementStr, elemLen);
 	    }
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index df60dae..6330836 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -35,9 +35,9 @@ scspec EXTERN
 #declare 2 {
 #    int TclAccessInsertProc(TclAccessProc_ *proc)
 #}
-declare 3 {
-    void TclAllocateFreeObjects(void)
-}
+#declare 3 {
+#    void TclAllocateFreeObjects(void)
+#}
 # Replaced by TclpChdir in 8.1:
 #  declare 4 {
 #      int TclChdir(Tcl_Interp *interp, char *dirName)
@@ -867,12 +867,12 @@ declare 213 {
 declare 214 {
     void TclSetObjNameOfExecutable(Tcl_Obj *name, Tcl_Encoding encoding)
 }
-declare 215 {
-    void *TclStackAlloc(Tcl_Interp *interp, int numBytes)
-}
-declare 216 {
-    void TclStackFree(Tcl_Interp *interp, void *freePtr)
-}
+#declare 215 {
+#    void *TclStackAlloc(Tcl_Interp *interp, unsigned int numBytes)
+#}
+#declare 216 {
+#    void TclStackFree(Tcl_Interp *interp, void *freePtr)
+#}
 declare 217 {
     int TclPushStackFrame(Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr,
             Tcl_Namespace *namespacePtr, int isProcCallFrame)
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 42e2212..45eaf7e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -10,7 +10,7 @@
  * Copyright (c) 2001, 2002 by Kevin B. Kenny.  All rights reserved.
  * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
  * Copyright (c) 2006-2008 by Joe Mistachkin.  All rights reserved.
- * Copyright (c) 2008 by Miguel Sofer. All rights reserved.
+ * Copyright (c) 2008-2011 by Miguel Sofer. All rights reserved.
  *
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -1390,13 +1390,6 @@ MODULE_SCOPE void	TclThreadDataKeySet(Tcl_ThreadDataKey *keyPtr,
   (ThreadSpecificData *)Tcl_GetThreadData((keyPtr), sizeof(ThreadSpecificData))
 
 /*
- *----------------------------------------------------------------
- * Data structures related to bytecode compilation and execution. These are
- * used primarily in tclCompile.c, tclExecute.c, and tclBasic.c.
- *----------------------------------------------------------------
- */
-
-/*
  * Forward declaration to prevent errors when the forward references to
  * Tcl_Parse and CompileEnv are encountered in the procedure type CompileProc
  * declared below.
@@ -1438,19 +1431,6 @@ typedef int (CompileHookProc)(Tcl_Interp *interp,
 	struct CompileEnv *compEnvPtr, ClientData clientData);
 
 /*
- * The data structure for a (linked list of) execution stacks.
- */
-
-typedef struct ExecStack {
-    struct ExecStack *prevPtr;
-    struct ExecStack *nextPtr;
-    Tcl_Obj **markerPtr;
-    Tcl_Obj **endPtr;
-    Tcl_Obj **tosPtr;
-    Tcl_Obj *stackWords[1];
-} ExecStack;
-
-/*
  * The data structure defining the execution environment for ByteCode's.
  * There is one ExecEnv structure per Tcl interpreter. It holds the evaluation
  * stack that holds command operands and results. The stack grows towards
@@ -1487,8 +1467,6 @@ typedef struct CoroutineData {
 } CoroutineData;
 
 typedef struct ExecEnv {
-    ExecStack *execStackPtr;	/* Points to the first item in the evaluation
-				 * stack on the heap. */
     Tcl_Obj *constants[2];	/* Pointers to constant "0" and "1" objs. */
     struct Tcl_Interp *interp;
     struct NRE_callback *callbackPtr;
@@ -1769,24 +1747,6 @@ enum PkgPreferOptions {
 
 /*
  *----------------------------------------------------------------
- * This structure shadows the first few fields of the memory cache for the
- * allocator defined in tclThreadAlloc.c; it has to be kept in sync with the
- * definition there.
- * Some macros require knowledge of some fields in the struct in order to
- * avoid hitting the TSD unnecessarily. In order to facilitate this, a pointer
- * to the relevant fields is kept in the objCache field in struct Interp.
- *----------------------------------------------------------------
- */
-
-typedef struct AllocCache {
-    struct Cache *nextPtr;	/* Linked list of cache entries. */
-    Tcl_ThreadId owner;		/* Which thread's cache is this? */
-    Tcl_Obj *firstObjPtr;	/* List of free objects for thread. */
-    int numObjects;		/* Number of objects for thread. */
-} AllocCache;
-
-/*
- *----------------------------------------------------------------
  * This structure defines an interpreter, which is a collection of commands
  * plus other state information related to interpreting commands, such as
  * variable storage. Primary responsibility for this data structure is in
@@ -2118,7 +2078,6 @@ typedef struct Interp {
      * They are used by the macros defined below.
      */
 
-    AllocCache *allocCache;
     void *pendingObjDataPtr;	/* Pointer to the Cache and PendingObjData
 				 * structs for this interp's thread; see
 				 * tclObj.c and tclThreadAlloc.c */
@@ -2351,17 +2310,6 @@ struct LimitHandler {
 #define UCHAR(c) ((unsigned char) (c))
 
 /*
- * This macro is used to properly align the memory allocated by Tcl, giving
- * the same alignment as the native malloc.
- */
-
-#if defined(__APPLE__)
-#define TCL_ALLOCALIGN	16
-#else
-#define TCL_ALLOCALIGN	(2*sizeof(void *))
-#endif
-
-/*
  * This macro is used to determine the offset needed to safely allocate any
  * data structure in memory. Given a starting offset or size, it "rounds up"
  * or "aligns" the offset to the next 8-byte boundary so that any data
@@ -2902,7 +2850,6 @@ MODULE_SCOPE void	TclCreateLateExitHandler(Tcl_ExitProc *proc,
 			    ClientData clientData);
 MODULE_SCOPE void	TclDeleteLateExitHandler(Tcl_ExitProc *proc,
 			    ClientData clientData);
-MODULE_SCOPE void	TclFinalizeAllocSubsystem(void);
 MODULE_SCOPE void	TclFinalizeAsync(void);
 MODULE_SCOPE void	TclFinalizeDoubleConversion(void);
 MODULE_SCOPE void	TclFinalizeEncodingSubsystem(void);
@@ -2919,7 +2866,6 @@ MODULE_SCOPE void	TclFinalizeNotifier(void);
 MODULE_SCOPE void	TclFinalizeObjects(void);
 MODULE_SCOPE void	TclFinalizePreserve(void);
 MODULE_SCOPE void	TclFinalizeSynchronization(void);
-MODULE_SCOPE void	TclFinalizeThreadAlloc(void);
 MODULE_SCOPE void	TclFinalizeThreadData(void);
 MODULE_SCOPE void	TclFinalizeThreadObjects(void);
 MODULE_SCOPE double	TclFloor(const mp_int *a);
@@ -3097,8 +3043,6 @@ MODULE_SCOPE void	TclSetDuplicateObj(Tcl_Obj *dupPtr, Tcl_Obj *objPtr);
 MODULE_SCOPE void	TclSetProcessGlobalValue(ProcessGlobalValue *pgvPtr,
 			    Tcl_Obj *newValue, Tcl_Encoding encoding);
 MODULE_SCOPE void	TclSignalExitThread(Tcl_ThreadId id, int result);
-MODULE_SCOPE void *	TclStackRealloc(Tcl_Interp *interp, void *ptr,
-			    int numBytes);
 MODULE_SCOPE int	TclStringMatch(const char *str, int strLen,
 			    const char *pattern, int ptnLen, int flags);
 MODULE_SCOPE int	TclStringMatchObj(Tcl_Obj *stringObj,
@@ -3808,10 +3752,10 @@ typedef const char *TclDTraceStr;
 #endif /* TCL_COMPILE_STATS */
 
 #  define TclAllocObjStorage(objPtr)		\
-	TclAllocObjStorageEx(NULL, (objPtr))
+    (objPtr) = TclSmallAlloc()
 
 #  define TclFreeObjStorage(objPtr)		\
-	TclFreeObjStorageEx(NULL, (objPtr))
+    TclSmallFree(objPtr)
 
 #ifndef TCL_MEM_DEBUG
 # define TclNewObj(objPtr) \
@@ -3846,128 +3790,122 @@ typedef const char *TclDTraceStr;
 	} \
     }
 
-#if defined(PURIFY)
+#else /* TCL_MEM_DEBUG */
+MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
+			    int line);
 
-/*
- * The PURIFY mode is like the regular mode, but instead of doing block
- * Tcl_Obj allocation and keeping a freed list for efficiency, it always
- * allocates and frees a single Tcl_Obj so that tools like Purify can better
- * track memory leaks.
- */
+# define TclDbNewObj(objPtr, file, line) \
+    do { \
+	TclIncrObjsAllocated();						\
+	(objPtr) = (Tcl_Obj *)						\
+		Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line));		\
+	TclDbInitNewObj((objPtr), (file), (line));			\
+	TCL_DTRACE_OBJ_CREATE(objPtr);					\
+    } while (0)
 
-#  define TclAllocObjStorageEx(interp, objPtr) \
-	(objPtr) = (Tcl_Obj *) Tcl_Alloc(sizeof(Tcl_Obj))
+# define TclNewObj(objPtr) \
+    TclDbNewObj(objPtr, __FILE__, __LINE__);
 
-#  define TclFreeObjStorageEx(interp, objPtr) \
-	ckfree((char *) (objPtr))
+# define TclDecrRefCount(objPtr) \
+    Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
 
-#undef USE_THREAD_ALLOC
-#elif defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
+# define TclNewListObjDirect(objc, objv) \
+    TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__)
+
+#endif /* TCL_MEM_DEBUG */
 
 /*
+ * Macros that drive the allocator behaviour
+ */
+
+#if defined(TCL_THREADS)
+/*
  * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
  * per-thread caches.
  */
-
-MODULE_SCOPE Tcl_Obj *	TclThreadAllocObj(void);
-MODULE_SCOPE void	TclThreadFreeObj(Tcl_Obj *);
-MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
-MODULE_SCOPE void	TclFreeAllocCache(void *);
+MODULE_SCOPE void	TclpFreeAllocCache(void *);
 MODULE_SCOPE void *	TclpGetAllocCache(void);
 MODULE_SCOPE void	TclpSetAllocCache(void *);
+MODULE_SCOPE void	TclFreeAllocCache(void *);
 MODULE_SCOPE void	TclpFreeAllocMutex(Tcl_Mutex *mutex);
-MODULE_SCOPE void	TclpFreeAllocCache(void *);
+MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
+#endif
 
 /*
- * These macros need to be kept in sync with the code of TclThreadAllocObj()
- * and TclThreadFreeObj().
- *
- * Note that the optimiser should resolve the case (interp==NULL) at compile
- * time.
+ * List of valid allocators. Have to respect the following convention:
+ *  - allocators that shunt TclpAlloc to malloc are below aNONE
+ *  - allocators that use zippy are above aNONE
  */
 
-#  define ALLOC_NOBJHIGH 1200
+#define aNATIVE    0
+#define aPURIFY    1
+#define aNONE      2 
+#define aZIPPY     3
+#define aMULTI     4
 
-#  define TclAllocObjStorageEx(interp, objPtr)				\
-    do {								\
-	AllocCache *cachePtr;						\
-	if (((interp) == NULL) ||					\
-		((cachePtr = ((Interp *)(interp))->allocCache),		\
-			(cachePtr->numObjects == 0))) {			\
-	    (objPtr) = TclThreadAllocObj();				\
-	} else {							\
-	    (objPtr) = cachePtr->firstObjPtr;				\
-	    cachePtr->firstObjPtr = (objPtr)->internalRep.otherValuePtr; \
-	    --cachePtr->numObjects;					\
-	}								\
-    } while (0)
-
-#  define TclFreeObjStorageEx(interp, objPtr)				\
-    do {								\
-	AllocCache *cachePtr;						\
-	if (((interp) == NULL) ||					\
-		((cachePtr = ((Interp *)(interp))->allocCache),		\
-			(cachePtr->numObjects >= ALLOC_NOBJHIGH))) {	\
-	    TclThreadFreeObj(objPtr);					\
-	} else {							\
-	    (objPtr)->internalRep.otherValuePtr = cachePtr->firstObjPtr; \
-	    cachePtr->firstObjPtr = objPtr;				\
-	    ++cachePtr->numObjects;					\
-	}								\
-    } while (0)
-
-#else /* not PURIFY or USE_THREAD_ALLOC */
+#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI))
+#undef TCL_ALLOCATOR
+#endif
 
-#ifdef TCL_THREADS
-/* declared in tclObj.c */
-MODULE_SCOPE Tcl_Mutex	tclObjMutex;
+#ifdef PURIFY
+#  undef TCL_ALLOCATOR
+#  define TCL_ALLOCATOR aPURIFY
 #endif
 
-#  define TclAllocObjStorageEx(interp, objPtr) \
-    do {								\
-	Tcl_MutexLock(&tclObjMutex);					\
-	if (tclFreeObjList == NULL) {					\
-	    TclAllocateFreeObjects();					\
-	}								\
-	(objPtr) = tclFreeObjList;					\
-	tclFreeObjList = (Tcl_Obj *)					\
-		tclFreeObjList->internalRep.otherValuePtr;		\
-	Tcl_MutexUnlock(&tclObjMutex);					\
-    } while (0)
+#if !defined(TCL_ALLOCATOR)
+#  if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC)
+#    define TCL_ALLOCATOR aZIPPY
+#  else
+#    define TCL_ALLOCATOR aNATIVE
+#  endif
+#endif
 
-#  define TclFreeObjStorageEx(interp, objPtr) \
-    do {							       \
-	Tcl_MutexLock(&tclObjMutex);				       \
-	(objPtr)->internalRep.otherValuePtr = (void *) tclFreeObjList; \
-	tclFreeObjList = (objPtr);				       \
-	Tcl_MutexUnlock(&tclObjMutex);				       \
-    } while (0)
+#if TCL_ALLOCATOR < aNONE /* native or purify */
+#    define TclpAlloc(size) ckalloc(size)
+#    define TclpRealloc(ptr, size) ckrealloc((ptr),(size))
+#    define TclpFree(size) ckfree(size)
+#else
+   MODULE_SCOPE char * TclpAlloc(unsigned int size);
+   MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size);
+   MODULE_SCOPE void   TclpFree(char * ptr);
 #endif
 
-#else /* TCL_MEM_DEBUG */
-MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
-			    int line);
+#if TCL_ALLOCATOR == aPURIFY
+#  define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj))
+#  define TclSmallFree(ptr) ckfree(ptr)
+#  define TclInitAlloc()
+#  define TclFinalizeAlloc()
+#else
+   MODULE_SCOPE void * TclSmallAlloc();
+   MODULE_SCOPE void   TclSmallFree(void *ptr);
+   MODULE_SCOPE void   TclInitAlloc(void);
+   MODULE_SCOPE void   TclFinalizeAlloc(void);
+#endif
 
-# define TclDbNewObj(objPtr, file, line) \
-    do { \
-	TclIncrObjsAllocated();						\
-	(objPtr) = (Tcl_Obj *)						\
-		Tcl_DbCkalloc(sizeof(Tcl_Obj), (file), (line));		\
-	TclDbInitNewObj((objPtr), (file), (line));			\
-	TCL_DTRACE_OBJ_CREATE(objPtr);					\
+#define TclCkSmallAlloc(nbytes, memPtr)					\
+    do {								\
+	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
+	memPtr = TclSmallAlloc();					\
     } while (0)
 
-# define TclNewObj(objPtr) \
-    TclDbNewObj(objPtr, __FILE__, __LINE__);
+/*
+ * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
+ */
 
-# define TclDecrRefCount(objPtr) \
-    Tcl_DbDecrRefCount(objPtr, __FILE__, __LINE__)
+#if (TCL_ALLOCATOR == aPURIFY) && defined(__clang__)
+#if __has_feature(attribute_analyzer_noreturn) && \
+       !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
+void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
+#endif
+#if !defined(CLANG_ASSERT)
+#include <assert.h>
+#define CLANG_ASSERT(x) assert(x)
+#endif
+#elif !defined(CLANG_ASSERT)
+ #define CLANG_ASSERT(x)
+#endif /* PURIFY && __clang__ */
 
-# define TclNewListObjDirect(objc, objv) \
-    TclDbNewListObjDirect(objc, objv, __FILE__, __LINE__)
 
-#undef USE_THREAD_ALLOC
-#endif /* TCL_MEM_DEBUG */
 
 /*
  *----------------------------------------------------------------
@@ -4471,73 +4409,11 @@ MODULE_SCOPE Tcl_PackageInitProc Procbodytest_SafeInit;
     {enum { ct_assert_value = 1/(!!(e)) };}
 
 /*
- *----------------------------------------------------------------
- * Allocator for small structs (<=sizeof(Tcl_Obj)) using the Tcl_Obj pool.
- * Only checked at compile time.
- *
- * ONLY USE FOR CONSTANT nBytes.
- *
- * DO NOT LET THEM CROSS THREAD BOUNDARIES
- *----------------------------------------------------------------
- */
-
-#define TclSmallAlloc(nbytes, memPtr) \
-    TclSmallAllocEx(NULL, (nbytes), (memPtr))
-
-#define TclSmallFree(memPtr) \
-    TclSmallFreeEx(NULL, (memPtr))
-
-#ifndef TCL_MEM_DEBUG
-#define TclSmallAllocEx(interp, nbytes, memPtr) \
-    do {								\
-	Tcl_Obj *objPtr;						\
-	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
-	TclIncrObjsAllocated();						\
-	TclAllocObjStorageEx((interp), (objPtr));			\
-	memPtr = (ClientData) (objPtr);					\
-    } while (0)
-
-#define TclSmallFreeEx(interp, memPtr) \
-    do {								\
-	TclFreeObjStorageEx((interp), (Tcl_Obj *) (memPtr));		\
-	TclIncrObjsFreed();						\
-    } while (0)
-
-#else    /* TCL_MEM_DEBUG */
-#define TclSmallAllocEx(interp, nbytes, memPtr) \
-    do {								\
-	Tcl_Obj *objPtr;						\
-	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
-	TclNewObj(objPtr);						\
-	memPtr = (ClientData) objPtr;					\
-    } while (0)
-
-#define TclSmallFreeEx(interp, memPtr) \
-    do {								\
-	Tcl_Obj *objPtr = (Tcl_Obj *) memPtr;				\
-	objPtr->bytes = NULL;						\
-	objPtr->typePtr = NULL;						\
-	objPtr->refCount = 1;						\
-	TclDecrRefCount(objPtr);					\
-    } while (0)
-#endif   /* TCL_MEM_DEBUG */
-
-/*
  * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
  */
 
-#if defined(PURIFY) && defined(__clang__)
-#if __has_feature(attribute_analyzer_noreturn) && \
-	!defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
-void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
-#endif
-#if !defined(CLANG_ASSERT)
-#include <assert.h>
-#define CLANG_ASSERT(x) assert(x)
-#endif
-#elif !defined(CLANG_ASSERT)
 #define CLANG_ASSERT(x)
-#endif /* PURIFY && __clang__ */
+
 
 /*
  *----------------------------------------------------------------
@@ -4610,8 +4486,8 @@ typedef struct NRE_callback {
 
 #if NRE_USE_SMALL_ALLOC
 #define TCLNR_ALLOC(interp, ptr) \
-    TclSmallAllocEx(interp, sizeof(NRE_callback), (ptr))
-#define TCLNR_FREE(interp, ptr)  TclSmallFreeEx((interp), (ptr))
+    TclCkSmallAlloc(sizeof(NRE_callback), (ptr))
+#define TCLNR_FREE(interp, ptr)  TclSmallFree(ptr)
 #else
 #define TCLNR_ALLOC(interp, ptr) \
     (ptr = ((ClientData) ckalloc(sizeof(NRE_callback))))
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index b294e4f..0966d32 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -58,8 +58,7 @@
 /* Slot 0 is reserved */
 /* Slot 1 is reserved */
 /* Slot 2 is reserved */
-/* 3 */
-EXTERN void		TclAllocateFreeObjects(void);
+/* Slot 3 is reserved */
 /* Slot 4 is reserved */
 /* 5 */
 EXTERN int		TclCleanupChildren(Tcl_Interp *interp, int numPids,
@@ -506,10 +505,8 @@ EXTERN Tcl_Obj *	TclGetObjNameOfExecutable(void);
 /* 214 */
 EXTERN void		TclSetObjNameOfExecutable(Tcl_Obj *name,
 				Tcl_Encoding encoding);
-/* 215 */
-EXTERN void *		TclStackAlloc(Tcl_Interp *interp, int numBytes);
-/* 216 */
-EXTERN void		TclStackFree(Tcl_Interp *interp, void *freePtr);
+/* Slot 215 is reserved */
+/* Slot 216 is reserved */
 /* 217 */
 EXTERN int		TclPushStackFrame(Tcl_Interp *interp,
 				Tcl_CallFrame **framePtrPtr,
@@ -609,7 +606,7 @@ typedef struct TclIntStubs {
     void (*reserved0)(void);
     void (*reserved1)(void);
     void (*reserved2)(void);
-    void (*tclAllocateFreeObjects) (void); /* 3 */
+    void (*reserved3)(void);
     void (*reserved4)(void);
     int (*tclCleanupChildren) (Tcl_Interp *interp, int numPids, Tcl_Pid *pidPtr, Tcl_Channel errorChan); /* 5 */
     void (*tclCleanupCommand) (Command *cmdPtr); /* 6 */
@@ -821,8 +818,8 @@ typedef struct TclIntStubs {
     void (*tclpFindExecutable) (const char *argv0); /* 212 */
     Tcl_Obj * (*tclGetObjNameOfExecutable) (void); /* 213 */
     void (*tclSetObjNameOfExecutable) (Tcl_Obj *name, Tcl_Encoding encoding); /* 214 */
-    void * (*tclStackAlloc) (Tcl_Interp *interp, int numBytes); /* 215 */
-    void (*tclStackFree) (Tcl_Interp *interp, void *freePtr); /* 216 */
+    void (*reserved215)(void);
+    void (*reserved216)(void);
     int (*tclPushStackFrame) (Tcl_Interp *interp, Tcl_CallFrame **framePtrPtr, Tcl_Namespace *namespacePtr, int isProcCallFrame); /* 217 */
     void (*tclPopStackFrame) (Tcl_Interp *interp); /* 218 */
     void (*reserved219)(void);
@@ -876,8 +873,7 @@ extern const TclIntStubs *tclIntStubsPtr;
 /* Slot 0 is reserved */
 /* Slot 1 is reserved */
 /* Slot 2 is reserved */
-#define TclAllocateFreeObjects \
-	(tclIntStubsPtr->tclAllocateFreeObjects) /* 3 */
+/* Slot 3 is reserved */
 /* Slot 4 is reserved */
 #define TclCleanupChildren \
 	(tclIntStubsPtr->tclCleanupChildren) /* 5 */
@@ -1216,10 +1212,8 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclGetObjNameOfExecutable) /* 213 */
 #define TclSetObjNameOfExecutable \
 	(tclIntStubsPtr->tclSetObjNameOfExecutable) /* 214 */
-#define TclStackAlloc \
-	(tclIntStubsPtr->tclStackAlloc) /* 215 */
-#define TclStackFree \
-	(tclIntStubsPtr->tclStackFree) /* 216 */
+/* Slot 215 is reserved */
+/* Slot 216 is reserved */
 #define TclPushStackFrame \
 	(tclIntStubsPtr->tclPushStackFrame) /* 217 */
 #define TclPopStackFrame \
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 67761ed..46a5f42 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -1169,7 +1169,7 @@ Tcl_CreateAlias(
     int i;
     int result;
 
-    objv = TclStackAlloc(slaveInterp, (unsigned) sizeof(Tcl_Obj *) * argc);
+    objv = ckalloc((unsigned) sizeof(Tcl_Obj *) * argc);
     for (i = 0; i < argc; i++) {
 	objv[i] = Tcl_NewStringObj(argv[i], -1);
 	Tcl_IncrRefCount(objv[i]);
@@ -1187,7 +1187,7 @@ Tcl_CreateAlias(
     for (i = 0; i < argc; i++) {
 	Tcl_DecrRefCount(objv[i]);
     }
-    TclStackFree(slaveInterp, objv);
+    ckfree(objv);
     Tcl_DecrRefCount(targetObjPtr);
     Tcl_DecrRefCount(slaveObjPtr);
 
@@ -1863,7 +1863,7 @@ AliasObjCmd(
     if (cmdc <= ALIAS_CMDV_PREALLOC) {
 	cmdv = cmdArr;
     } else {
-	cmdv = TclStackAlloc(interp, cmdc * sizeof(Tcl_Obj *));
+	cmdv = ckalloc(cmdc * sizeof(Tcl_Obj *));
     }
 
     prefv = &aliasPtr->objPtr;
@@ -1930,7 +1930,7 @@ AliasObjCmd(
 	Tcl_DecrRefCount(cmdv[i]);
     }
     if (cmdv != cmdArr) {
-	TclStackFree(interp, cmdv);
+	ckfree(cmdv);
     }
     return result;
 #undef ALIAS_CMDV_PREALLOC
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index ad233b9..08a9443 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -465,7 +465,7 @@ TclPushStackFrame(
 				 * treated as references to namespace
 				 * variables. */
 {
-    *framePtrPtr = TclStackAlloc(interp, sizeof(CallFrame));
+    *framePtrPtr = ckalloc(sizeof(CallFrame));
     return Tcl_PushCallFrame(interp, *framePtrPtr, namespacePtr,
 	    isProcCallFrame);
 }
@@ -477,7 +477,7 @@ TclPopStackFrame(
     CallFrame *freePtr = ((Interp *) interp)->framePtr;
 
     Tcl_PopCallFrame(interp);
-    TclStackFree(interp, freePtr);
+    ckfree(freePtr);
 }
 
 /*
@@ -2632,8 +2632,7 @@ TclResetShadowedCmdRefs(
     int found, i;
     int trailFront = -1;
     int trailSize = 5;		/* Formerly NUM_TRAIL_ELEMS. */
-    Namespace **trailPtr = TclStackAlloc(interp,
-	    trailSize * sizeof(Namespace *));
+    Namespace **trailPtr = ckalloc(trailSize * sizeof(Namespace *));
 
     /*
      * Start at the namespace containing the new command, and work up through
@@ -2722,13 +2721,12 @@ TclResetShadowedCmdRefs(
 	if (trailFront == trailSize) {
 	    int newSize = 2 * trailSize;
 
-	    trailPtr = TclStackRealloc(interp, trailPtr,
-		    newSize * sizeof(Namespace *));
+	    trailPtr = ckrealloc(trailPtr, newSize * sizeof(Namespace *));
 	    trailSize = newSize;
 	}
 	trailPtr[trailFront] = nsPtr;
     }
-    TclStackFree(interp, trailPtr);
+    ckfree(trailPtr);
 }
 
 /*
@@ -3970,8 +3968,7 @@ NamespacePathCmd(
 	goto badNamespace;
     }
     if (nsObjc != 0) {
-	namespaceList = TclStackAlloc(interp,
-		sizeof(Tcl_Namespace *) * nsObjc);
+	namespaceList = ckalloc(sizeof(Tcl_Namespace *) * nsObjc);
 
 	for (i=0 ; i<nsObjc ; i++) {
 	    if (TclGetNamespaceFromObj(interp, nsObjv[i],
@@ -3990,7 +3987,7 @@ NamespacePathCmd(
     result = TCL_OK;
   badNamespace:
     if (namespaceList != NULL) {
-	TclStackFree(interp, namespaceList);
+	ckfree(namespaceList);
     }
     return result;
 }
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 1e8d1a3..8814819 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -104,7 +104,7 @@ TclOODeleteContext(
     register Object *oPtr = contextPtr->oPtr;
 
     TclOODeleteChain(contextPtr->callPtr);
-    TclStackFree(oPtr->fPtr->interp, contextPtr);
+    ckfree(contextPtr);
     DelRef(oPtr);
 }
 
@@ -1087,7 +1087,7 @@ TclOOGetCallContext(
     }
 
   returnContext:
-    contextPtr = TclStackAlloc(oPtr->fPtr->interp, sizeof(CallContext));
+    contextPtr = ckalloc(sizeof(CallContext));
     contextPtr->oPtr = oPtr;
     AddRef(oPtr);
     contextPtr->callPtr = callPtr;
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 8d8eb85..cc3a0ad 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -455,7 +455,7 @@ TclOOUnknownDefinition(
 	 * Got one match, and only one match!
 	 */
 
-	Tcl_Obj **newObjv = TclStackAlloc(interp, sizeof(Tcl_Obj*)*(objc-1));
+	Tcl_Obj **newObjv = ckalloc(sizeof(Tcl_Obj*)*(objc-1));
 	int result;
 
 	newObjv[0] = Tcl_NewStringObj(matchedStr, -1);
@@ -465,7 +465,7 @@ TclOOUnknownDefinition(
 	}
 	result = Tcl_EvalObjv(interp, objc-1, newObjv, 0);
 	Tcl_DecrRefCount(newObjv[0]);
-	TclStackFree(interp, newObjv);
+	ckfree(newObjv);
 	return result;
     }
 
@@ -1546,7 +1546,7 @@ TclOODefineMixinObjCmd(
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
 	return TCL_ERROR;
     }
-    mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
+    mixins = ckalloc(sizeof(Class *) * (objc-1));
 
     for (i=1 ; i<objc ; i++) {
 	Class *clsPtr = GetClassInOuterContext(interp, objv[i],
@@ -1568,11 +1568,11 @@ TclOODefineMixinObjCmd(
 	TclOOClassSetMixins(interp, oPtr->classPtr, objc-1, mixins);
     }
 
-    TclStackFree(interp, mixins);
+    ckfree(mixins);
     return TCL_OK;
 
   freeAndError:
-    TclStackFree(interp, mixins);
+    ckfree(mixins);
     return TCL_ERROR;
 }
 
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 112d663..0996eab 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -686,7 +686,7 @@ InvokeProcedureMethod(
      * Allocate the special frame data.
      */
 
-    fdPtr = TclStackAlloc(interp, sizeof(PMFrameData));
+    fdPtr = ckalloc(sizeof(PMFrameData));
 
     /*
      * Create a call frame for this method.
@@ -695,7 +695,7 @@ InvokeProcedureMethod(
     result = PushMethodCallFrame(interp, (CallContext *) context, pmPtr,
 	    objc, objv, fdPtr);
     if (result != TCL_OK) {
-	TclStackFree(interp, fdPtr);
+	ckfree(fdPtr);
 	return result;
     }
     pmPtr->refCount++;
@@ -719,11 +719,11 @@ InvokeProcedureMethod(
 	    pmPtr->procPtr->cmdPtr = fdPtr->oldCmdPtr;
 
 	    Tcl_PopCallFrame(interp);
-	    TclStackFree(interp, fdPtr->framePtr);
+	    ckfree(fdPtr->framePtr);
 	    if (--pmPtr->refCount < 1) {
 		DeleteProcedureMethodRecord(pmPtr);
 	    }
-	    TclStackFree(interp, fdPtr);
+	    ckfree(fdPtr);
 	    return result;
 	}
     }
@@ -774,7 +774,7 @@ FinalizePMCall(
     if (--pmPtr->refCount < 1) {
 	DeleteProcedureMethodRecord(pmPtr);
     }
-    TclStackFree(interp, fdPtr);
+    ckfree(fdPtr);
     return result;
 }
 
@@ -1447,7 +1447,7 @@ FinalizeForwardCall(
 {
     Tcl_Obj **argObjs = data[0];
     
-    TclStackFree(interp, argObjs);
+    ckfree(argObjs);
     return result;
 }
 
@@ -1576,7 +1576,7 @@ InitEnsembleRewrite(
     Tcl_Obj **argObjs;
     unsigned len = rewriteLength + objc - toRewrite;
 
-    argObjs = TclStackAlloc(interp, sizeof(Tcl_Obj *) * len);
+    argObjs = ckalloc(sizeof(Tcl_Obj *) * len);
     memcpy(argObjs, rewriteObjs, rewriteLength * sizeof(Tcl_Obj *));
     memcpy(argObjs + rewriteLength, objv + toRewrite,
 	    sizeof(Tcl_Obj *) * (objc - toRewrite));
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 3bc6f12..5056c1c 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -27,12 +27,6 @@ static int typeTableInitialized = 0;	/* 0 means not yet initialized. */
 TCL_DECLARE_MUTEX(tableMutex)
 
 /*
- * Head of the list of free Tcl_Obj structs we maintain.
- */
-
-Tcl_Obj *tclFreeObjList = NULL;
-
-/*
  * The object allocator is single threaded. This mutex is referenced by the
  * TclNewObj macro, however, so must be visible.
  */
@@ -475,7 +469,7 @@ TclFinalizeThreadObjects(void)
  * TclFinalizeObjects --
  *
  *	This function is called by Tcl_Finalize to clean up all registered
- *	Tcl_ObjType's and to reset the tclFreeObjList.
+ *	Tcl_ObjType's
  *
  * Results:
  *	None.
@@ -495,15 +489,6 @@ TclFinalizeObjects(void)
 	typeTableInitialized = 0;
     }
     Tcl_MutexUnlock(&tableMutex);
-
-    /*
-     * All we do here is reset the head pointer of the linked list of free
-     * Tcl_Obj's to NULL; the memory finalization will take care of releasing
-     * memory for us.
-     */
-    Tcl_MutexLock(&tclObjMutex);
-    tclFreeObjList = NULL;
-    Tcl_MutexUnlock(&tclObjMutex);
 }
 
 /*
@@ -1238,59 +1223,6 @@ Tcl_DbNewObj(
 /*
  *----------------------------------------------------------------------
  *
- * TclAllocateFreeObjects --
- *
- *	Function to allocate a number of free Tcl_Objs. This is done using a
- *	single ckalloc to reduce the overhead for Tcl_Obj allocation.
- *
- *	Assumes mutex is held.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	tclFreeObjList, the head of the list of free Tcl_Objs, is set to the
- *	first of a number of free Tcl_Obj's linked together by their
- *	internalRep.otherValuePtrs.
- *
- *----------------------------------------------------------------------
- */
-
-#define OBJS_TO_ALLOC_EACH_TIME 100
-
-void
-TclAllocateFreeObjects(void)
-{
-    size_t bytesToAlloc = (OBJS_TO_ALLOC_EACH_TIME * sizeof(Tcl_Obj));
-    char *basePtr;
-    register Tcl_Obj *prevPtr, *objPtr;
-    register int i;
-
-    /*
-     * This has been noted by Purify to be a potential leak. The problem is
-     * that Tcl, when not TCL_MEM_DEBUG compiled, keeps around all allocated
-     * Tcl_Obj's, pointed to by tclFreeObjList, when freed instead of actually
-     * freeing the memory. TclFinalizeObjects() does not ckfree() this memory,
-     * but leaves it to Tcl's memory subsystem finalization to release it.
-     * Purify apparently can't figure that out, and fires a false alarm.
-     */
-
-    basePtr = ckalloc(bytesToAlloc);
-
-    prevPtr = NULL;
-    objPtr = (Tcl_Obj *) basePtr;
-    for (i = 0; i < OBJS_TO_ALLOC_EACH_TIME; i++) {
-	objPtr->internalRep.otherValuePtr = prevPtr;
-	prevPtr = objPtr;
-	objPtr++;
-    }
-    tclFreeObjList = prevPtr;
-}
-#undef OBJS_TO_ALLOC_EACH_TIME
-
-/*
- *----------------------------------------------------------------------
- *
  * TclFreeObj --
  *
  *	This function frees the memory associated with the argument object.
@@ -1404,7 +1336,6 @@ TclFreeObj(
      */
 
     TclInvalidateStringRep(objPtr);
-    objPtr->length = -1;
 
     if (!objPtr->typePtr || !objPtr->typePtr->freeIntRepProc) {
 	/*
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 9bfe608..afd4c0b 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -1129,14 +1129,14 @@ ParseTokens(
 
 	    src++;
 	    numBytes--;
-	    nestedPtr = TclStackAlloc(parsePtr->interp, sizeof(Tcl_Parse));
+	    nestedPtr = ckalloc(sizeof(Tcl_Parse));
 	    while (1) {
 		if (Tcl_ParseCommand(parsePtr->interp, src, numBytes, 1,
 			nestedPtr) != TCL_OK) {
 		    parsePtr->errorType = nestedPtr->errorType;
 		    parsePtr->term = nestedPtr->term;
 		    parsePtr->incomplete = nestedPtr->incomplete;
-		    TclStackFree(parsePtr->interp, nestedPtr);
+		    ckfree(nestedPtr);
 		    return TCL_ERROR;
 		}
 		src = nestedPtr->commandStart + nestedPtr->commandSize;
@@ -1162,11 +1162,11 @@ ParseTokens(
 		    parsePtr->errorType = TCL_PARSE_MISSING_BRACKET;
 		    parsePtr->term = tokenPtr->start;
 		    parsePtr->incomplete = 1;
-		    TclStackFree(parsePtr->interp, nestedPtr);
+		    ckfree(nestedPtr);
 		    return TCL_ERROR;
 		}
 	    }
-	    TclStackFree(parsePtr->interp, nestedPtr);
+	    ckfree(nestedPtr);
 	    tokenPtr->type = TCL_TOKEN_COMMAND;
 	    tokenPtr->size = src - tokenPtr->start;
 	    parsePtr->numTokens++;
@@ -1526,10 +1526,10 @@ Tcl_ParseVar(
 {
     register Tcl_Obj *objPtr;
     int code;
-    Tcl_Parse *parsePtr = TclStackAlloc(interp, sizeof(Tcl_Parse));
+    Tcl_Parse *parsePtr = ckalloc(sizeof(Tcl_Parse));
 
     if (Tcl_ParseVarName(interp, start, -1, parsePtr, 0) != TCL_OK) {
-	TclStackFree(interp, parsePtr);
+	ckfree(parsePtr);
 	return NULL;
     }
 
@@ -1541,13 +1541,13 @@ Tcl_ParseVar(
 	 * There isn't a variable name after all: the $ is just a $.
 	 */
 
-	TclStackFree(interp, parsePtr);
+	ckfree(parsePtr);
 	return "$";
     }
 
     code = TclSubstTokens(interp, parsePtr->tokenPtr, parsePtr->numTokens,
 	    NULL, 1, NULL, NULL);
-    TclStackFree(interp, parsePtr);
+    ckfree(parsePtr);
     if (code != TCL_OK) {
 	return NULL;
     }
@@ -2008,7 +2008,7 @@ TclSubstParse(
 		Tcl_Token *tokenPtr;
 		const char *lastTerm = parsePtr->term;
 		Tcl_Parse *nestedPtr =
-			TclStackAlloc(interp, sizeof(Tcl_Parse));
+			ckalloc(sizeof(Tcl_Parse));
 
 		while (TCL_OK ==
 			Tcl_ParseCommand(NULL, p, length, 0, nestedPtr)) {
@@ -2026,7 +2026,7 @@ TclSubstParse(
 		    }
 		    lastTerm = nestedPtr->term;
 		}
-		TclStackFree(interp, nestedPtr);
+		ckfree(nestedPtr);
 
 		if (lastTerm == parsePtr->term) {
 		    /*
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 6cd5bb2..63dd61d 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -222,7 +222,7 @@ Tcl_ProcObjCmd(
      */
 
     if (iPtr->cmdFramePtr) {
-	CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+	CmdFrame *contextPtr = ckalloc(sizeof(CmdFrame));
 
 	*contextPtr = *iPtr->cmdFramePtr;
 	if (contextPtr->type == TCL_LOCATION_BC) {
@@ -300,7 +300,7 @@ Tcl_ProcObjCmd(
 	    Tcl_DecrRefCount(contextPtr->data.eval.path);
 	    contextPtr->data.eval.path = NULL;
 	}
-	TclStackFree(interp, contextPtr);
+	ckfree(contextPtr);
     }
 
     /*
@@ -1096,8 +1096,7 @@ ProcWrongNumArgs(
      */
 
     numArgs = framePtr->procPtr->numArgs;
-    desiredObjs = TclStackAlloc(interp,
-	    (int) sizeof(Tcl_Obj *) * (numArgs+1));
+    desiredObjs = ckalloc((int) sizeof(Tcl_Obj *) * (numArgs+1));
 
     if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
 	desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
@@ -1135,7 +1134,7 @@ ProcWrongNumArgs(
     for (i=0 ; i<=numArgs ; i++) {
 	Tcl_DecrRefCount(desiredObjs[i]);
     }
-    TclStackFree(interp, desiredObjs);
+    ckfree(desiredObjs);
     return TCL_ERROR;
 }
 
@@ -1449,7 +1448,7 @@ InitArgsAndLocals(
      * parameters.
      */
 
-    varPtr = TclStackAlloc(interp, (int)(localCt * sizeof(Var)));
+    varPtr = ckalloc((int)(localCt * sizeof(Var)));
     framePtr->compiledLocals = varPtr;
     framePtr->numCompiledLocals = localCt;
 
@@ -1740,9 +1739,9 @@ TclNRInterpProcCore(
     if (result != TCL_OK) {
 	freePtr = iPtr->framePtr;
 	Tcl_PopCallFrame(interp);	/* Pop but do not free. */
-	TclStackFree(interp, freePtr->compiledLocals);
+	ckfree(freePtr->compiledLocals);
 					/* Free compiledLocals. */
-	TclStackFree(interp, freePtr);	/* Free CallFrame. */
+	ckfree(freePtr);	/* Free CallFrame. */
 	return TCL_ERROR;
     }
 
@@ -1912,9 +1911,9 @@ InterpProcNR2(
 
     freePtr = iPtr->framePtr;
     Tcl_PopCallFrame(interp);		/* Pop but do not free. */
-    TclStackFree(interp, freePtr->compiledLocals);
+    ckfree(freePtr->compiledLocals);
 					/* Free compiledLocals. */
-    TclStackFree(interp, freePtr);	/* Free CallFrame. */
+    ckfree(freePtr);	/* Free CallFrame. */
 
     return result;
 }
@@ -2516,7 +2515,7 @@ SetLambdaFromAny(
      */
 
     if (iPtr->cmdFramePtr) {
-	CmdFrame *contextPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+	CmdFrame *contextPtr = ckalloc(sizeof(CmdFrame));
 
 	*contextPtr = *iPtr->cmdFramePtr;
 	if (contextPtr->type == TCL_LOCATION_BC) {
@@ -2580,7 +2579,7 @@ SetLambdaFromAny(
 
 	    Tcl_DecrRefCount(contextPtr->data.eval.path);
 	}
-	TclStackFree(interp, contextPtr);
+	ckfree(contextPtr);
     }
 
     /*
@@ -2717,7 +2716,7 @@ TclNRApplyObjCmd(
 	return TCL_ERROR;
     }
 
-    extraPtr = TclStackAlloc(interp, sizeof(ApplyExtraData));
+    extraPtr = ckalloc(sizeof(ApplyExtraData));
     memset(&extraPtr->cmd, 0, sizeof(Command));
     procPtr->cmdPtr = &extraPtr->cmd;
     extraPtr->cmd.nsPtr = (Namespace *) nsPtr;
@@ -2768,7 +2767,7 @@ ApplyNR2(
 	((Interp *) interp)->ensembleRewrite.sourceObjs = NULL;
     }
 
-    TclStackFree(interp, extraPtr);
+    ckfree(extraPtr);
     return result;
 }
 
diff --git a/generic/tclScan.c b/generic/tclScan.c
index c862be4..45f970d 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -259,7 +259,7 @@ ValidateFormat(
     char *end;
     Tcl_UniChar ch;
     int objIndex, xpgSize, nspace = numVars;
-    int *nassign = TclStackAlloc(interp, nspace * sizeof(int));
+    int *nassign = ckalloc(nspace * sizeof(int));
     char buf[TCL_UTF_MAX+1];
 
     /*
@@ -465,8 +465,7 @@ ValidateFormat(
 		} else {
 		    nspace += 16;	/* formerly STATIC_LIST_SIZE */
 		}
-		nassign = TclStackRealloc(interp, nassign,
-			nspace * sizeof(int));
+		nassign = ckrealloc(nassign, nspace * sizeof(int));
 		for (i = value; i < nspace; i++) {
 		    nassign[i] = 0;
 		}
@@ -509,7 +508,7 @@ ValidateFormat(
 	}
     }
 
-    TclStackFree(interp, nassign);
+    ckfree(nassign);
     return TCL_OK;
 
   badIndex:
@@ -523,7 +522,7 @@ ValidateFormat(
     }
 
   error:
-    TclStackFree(interp, nassign);
+    ckfree(nassign);
     return TCL_ERROR;
 }
 
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index eb9a9be..84c1ea9 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -57,7 +57,7 @@ static const TclIntStubs tclIntStubs = {
     0, /* 0 */
     0, /* 1 */
     0, /* 2 */
-    TclAllocateFreeObjects, /* 3 */
+    0, /* 3 */
     0, /* 4 */
     TclCleanupChildren, /* 5 */
     TclCleanupCommand, /* 6 */
@@ -269,8 +269,8 @@ static const TclIntStubs tclIntStubs = {
     TclpFindExecutable, /* 212 */
     TclGetObjNameOfExecutable, /* 213 */
     TclSetObjNameOfExecutable, /* 214 */
-    TclStackAlloc, /* 215 */
-    TclStackFree, /* 216 */
+    0, /* 215 */
+    0, /* 216 */
     TclPushStackFrame, /* 217 */
     TclPopStackFrame, /* 218 */
     0, /* 219 */
diff --git a/generic/tclTest.c b/generic/tclTest.c
index b757185..2878c8d 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -6720,7 +6720,7 @@ TestNRELevels(
     Interp *iPtr = (Interp *) interp;
     static ptrdiff_t *refDepth = NULL;
     ptrdiff_t depth;
-    Tcl_Obj *levels[6];
+    Tcl_Obj *levels[5];
     int i = 0;
     NRE_callback *cbPtr = iPtr->execEnvPtr->callbackPtr;
 
@@ -6734,16 +6734,14 @@ TestNRELevels(
     levels[1] = Tcl_NewIntObj(iPtr->numLevels);
     levels[2] = Tcl_NewIntObj(iPtr->cmdFramePtr->level);
     levels[3] = Tcl_NewIntObj(iPtr->varFramePtr->level);
-    levels[4] = Tcl_NewIntObj(iPtr->execEnvPtr->execStackPtr->tosPtr
-	    - iPtr->execEnvPtr->execStackPtr->stackWords);
 
     while (cbPtr) {
 	i++;
 	cbPtr = cbPtr->nextPtr;
     }
-    levels[5] = Tcl_NewIntObj(i);
+    levels[4] = Tcl_NewIntObj(i);
 
-    Tcl_SetObjResult(interp, Tcl_NewListObj(6, levels));
+    Tcl_SetObjResult(interp, Tcl_NewListObj(5, levels));
     return TCL_OK;
 }
 
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
deleted file mode 100755
index c3acb2a..0000000
--- a/generic/tclThreadAlloc.c
+++ /dev/null
@@ -1,1081 +0,0 @@
-/*
- * tclThreadAlloc.c --
- *
- *	This is a very fast storage allocator for used with threads (designed
- *	avoid lock contention). The basic strategy is to allocate memory in
- *	fixed size blocks from block caches.
- *
- * The Initial Developer of the Original Code is America Online, Inc.
- * Portions created by AOL are Copyright (C) 1999 America Online, Inc.
- *
- * See the file "license.terms" for information on usage and redistribution of
- * this file, and for a DISCLAIMER OF ALL WARRANTIES.
- */
-
-#include "tclInt.h"
-#if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
-
-/*
- * If range checking is enabled, an additional byte will be allocated to store
- * the magic number at the end of the requested memory.
- */
-
-#ifndef RCHECK
-#ifdef  NDEBUG
-#define RCHECK		0
-#else
-#define RCHECK		1
-#endif
-#endif
-
-/*
- * The following define the number of Tcl_Obj's to allocate/move at a time and
- * the high water mark to prune a per-thread cache. On a 32 bit system,
- * sizeof(Tcl_Obj) = 24 so 800 * 24 = ~16k.
- */
-
-#define NOBJALLOC	800
-
-/* Actual definition moved to tclInt.h */
-#define NOBJHIGH	ALLOC_NOBJHIGH
-
-/*
- * The following union stores accounting information for each block including
- * two small magic numbers and a bucket number when in use or a next pointer
- * when free. The original requested size (not including the Block overhead)
- * is also maintained.
- */
-
-typedef union Block {
-    struct {
-	union {
-	    union Block *next;		/* Next in free list. */
-	    struct {
-		unsigned char magic1;	/* First magic number. */
-		unsigned char bucket;	/* Bucket block allocated from. */
-		unsigned char unused;	/* Padding. */
-		unsigned char magic2;	/* Second magic number. */
-	    } s;
-	} u;
-	size_t reqSize;			/* Requested allocation size. */
-    } b;
-    unsigned char padding[TCL_ALLOCALIGN];
-} Block;
-#define nextBlock	b.u.next
-#define sourceBucket	b.u.s.bucket
-#define magicNum1	b.u.s.magic1
-#define magicNum2	b.u.s.magic2
-#define MAGIC		0xEF
-#define blockReqSize	b.reqSize
-
-/*
- * The following defines the minimum and and maximum block sizes and the number
- * of buckets in the bucket cache.
- */
-
-#define MINALLOC	((sizeof(Block) + 8 + (TCL_ALLOCALIGN-1)) & ~(TCL_ALLOCALIGN-1))
-#define NBUCKETS	(11 - (MINALLOC >> 5))
-#define MAXALLOC	(MINALLOC << (NBUCKETS - 1))
-
-/*
- * The following structure defines a bucket of blocks with various accounting
- * and statistics information.
- */
-
-typedef struct Bucket {
-    Block *firstPtr;		/* First block available */
-    long numFree;		/* Number of blocks available */
-
-    /* All fields below for accounting only */
-
-    long numRemoves;		/* Number of removes from bucket */
-    long numInserts;		/* Number of inserts into bucket */
-    long numWaits;		/* Number of waits to acquire a lock */
-    long numLocks;		/* Number of locks acquired */
-    long totalAssigned;		/* Total space assigned to bucket */
-} Bucket;
-
-/*
- * The following structure defines a cache of buckets and objs, of which there
- * will be (at most) one per thread. Any changes need to be reflected in the
- * struct AllocCache defined in tclInt.h, possibly also in the initialisation
- * code in Tcl_CreateInterp().
- */
-
-typedef struct Cache {
-    struct Cache *nextPtr;	/* Linked list of cache entries */
-    Tcl_ThreadId owner;		/* Which thread's cache is this? */
-    Tcl_Obj *firstObjPtr;	/* List of free objects for thread */
-    int numObjects;		/* Number of objects for thread */
-    int totalAssigned;		/* Total space assigned to thread */
-    Bucket buckets[NBUCKETS];	/* The buckets for this thread */
-} Cache;
-
-/*
- * The following array specifies various per-bucket limits and locks. The
- * values are statically initialized to avoid calculating them repeatedly.
- */
-
-static struct {
-    size_t blockSize;		/* Bucket blocksize. */
-    int maxBlocks;		/* Max blocks before move to share. */
-    int numMove;		/* Num blocks to move to share. */
-    Tcl_Mutex *lockPtr;		/* Share bucket lock. */
-} bucketInfo[NBUCKETS];
-
-/*
- * Static functions defined in this file.
- */
-
-static Cache *	GetCache(void);
-static void	LockBucket(Cache *cachePtr, int bucket);
-static void	UnlockBucket(Cache *cachePtr, int bucket);
-static void	PutBlocks(Cache *cachePtr, int bucket, int numMove);
-static int	GetBlocks(Cache *cachePtr, int bucket);
-static Block *	Ptr2Block(char *ptr);
-static char *	Block2Ptr(Block *blockPtr, int bucket, unsigned int reqSize);
-static void	MoveObjs(Cache *fromPtr, Cache *toPtr, int numMove);
-
-/*
- * Local variables defined in this file and initialized at startup.
- */
-
-static Tcl_Mutex *listLockPtr;
-static Tcl_Mutex *objLockPtr;
-static Cache sharedCache;
-static Cache *sharedPtr = &sharedCache;
-static Cache *firstCachePtr = &sharedCache;
-
-/*
- *----------------------------------------------------------------------
- *
- * GetCache ---
- *
- *	Gets per-thread memory cache, allocating it if necessary.
- *
- * Results:
- *	Pointer to cache.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-static Cache *
-GetCache(void)
-{
-    Cache *cachePtr;
-
-    /*
-     * Check for first-time initialization.
-     */
-
-    if (listLockPtr == NULL) {
-	Tcl_Mutex *initLockPtr;
-	unsigned int i;
-
-	initLockPtr = Tcl_GetAllocMutex();
-	Tcl_MutexLock(initLockPtr);
-	if (listLockPtr == NULL) {
-	    listLockPtr = TclpNewAllocMutex();
-	    objLockPtr = TclpNewAllocMutex();
-	    for (i = 0; i < NBUCKETS; ++i) {
-		bucketInfo[i].blockSize = MINALLOC << i;
-		bucketInfo[i].maxBlocks = 1 << (NBUCKETS - 1 - i);
-		bucketInfo[i].numMove = i < NBUCKETS - 1 ?
-			1 << (NBUCKETS - 2 - i) : 1;
-		bucketInfo[i].lockPtr = TclpNewAllocMutex();
-	    }
-	}
-	Tcl_MutexUnlock(initLockPtr);
-    }
-
-    /*
-     * Get this thread's cache, allocating if necessary.
-     */
-
-    cachePtr = TclpGetAllocCache();
-    if (cachePtr == NULL) {
-	cachePtr = calloc(1, sizeof(Cache));
-	if (cachePtr == NULL) {
-	    Tcl_Panic("alloc: could not allocate new cache");
-	}
-	Tcl_MutexLock(listLockPtr);
-	cachePtr->nextPtr = firstCachePtr;
-	firstCachePtr = cachePtr;
-	Tcl_MutexUnlock(listLockPtr);
-	cachePtr->owner = Tcl_GetCurrentThread();
-	TclpSetAllocCache(cachePtr);
-    }
-    return cachePtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFreeAllocCache --
- *
- *	Flush and delete a cache, removing from list of caches.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclFreeAllocCache(
-    void *arg)
-{
-    Cache *cachePtr = arg;
-    Cache **nextPtrPtr;
-    register unsigned int bucket;
-
-    /*
-     * Flush blocks.
-     */
-
-    for (bucket = 0; bucket < NBUCKETS; ++bucket) {
-	if (cachePtr->buckets[bucket].numFree > 0) {
-	    PutBlocks(cachePtr, bucket, cachePtr->buckets[bucket].numFree);
-	}
-    }
-
-    /*
-     * Flush objs.
-     */
-
-    if (cachePtr->numObjects > 0) {
-	Tcl_MutexLock(objLockPtr);
-	MoveObjs(cachePtr, sharedPtr, cachePtr->numObjects);
-	Tcl_MutexUnlock(objLockPtr);
-    }
-
-    /*
-     * Remove from pool list.
-     */
-
-    Tcl_MutexLock(listLockPtr);
-    nextPtrPtr = &firstCachePtr;
-    while (*nextPtrPtr != cachePtr) {
-	nextPtrPtr = &(*nextPtrPtr)->nextPtr;
-    }
-    *nextPtrPtr = cachePtr->nextPtr;
-    cachePtr->nextPtr = NULL;
-    Tcl_MutexUnlock(listLockPtr);
-    free(cachePtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpAlloc --
- *
- *	Allocate memory.
- *
- * Results:
- *	Pointer to memory just beyond Block pointer.
- *
- * Side effects:
- *	May allocate more blocks for a bucket.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclpAlloc(
-    unsigned int reqSize)
-{
-    Cache *cachePtr;
-    Block *blockPtr;
-    register int bucket;
-    size_t size;
-
-#ifndef __LP64__
-    if (sizeof(int) >= sizeof(size_t)) {
-	/* An unsigned int overflow can also be a size_t overflow */
-	const size_t zero = 0;
-	const size_t max = ~zero;
-
-	if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
-	    /* Requested allocation exceeds memory */
-	    return NULL;
-	}
-    }
-#endif
-
-    cachePtr = TclpGetAllocCache();
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
-
-    /*
-     * Increment the requested size to include room for the Block structure.
-     * Call malloc() directly if the required amount is greater than the
-     * largest block, otherwise pop the smallest block large enough,
-     * allocating more blocks if necessary.
-     */
-
-    blockPtr = NULL;
-    size = reqSize + sizeof(Block);
-#if RCHECK
-    size++;
-#endif
-    if (size > MAXALLOC) {
-	bucket = NBUCKETS;
-	blockPtr = malloc(size);
-	if (blockPtr != NULL) {
-	    cachePtr->totalAssigned += reqSize;
-	}
-    } else {
-	bucket = 0;
-	while (bucketInfo[bucket].blockSize < size) {
-	    bucket++;
-	}
-	if (cachePtr->buckets[bucket].numFree || GetBlocks(cachePtr, bucket)) {
-	    blockPtr = cachePtr->buckets[bucket].firstPtr;
-	    cachePtr->buckets[bucket].firstPtr = blockPtr->nextBlock;
-	    cachePtr->buckets[bucket].numFree--;
-	    cachePtr->buckets[bucket].numRemoves++;
-	    cachePtr->buckets[bucket].totalAssigned += reqSize;
-	}
-    }
-    if (blockPtr == NULL) {
-	return NULL;
-    }
-    return Block2Ptr(blockPtr, bucket, reqSize);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpFree --
- *
- *	Return blocks to the thread block cache.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	May move blocks to shared cache.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclpFree(
-    char *ptr)
-{
-    Cache *cachePtr;
-    Block *blockPtr;
-    int bucket;
-
-    if (ptr == NULL) {
-	return;
-    }
-
-    cachePtr = TclpGetAllocCache();
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
-
-    /*
-     * Get the block back from the user pointer and call system free directly
-     * for large blocks. Otherwise, push the block back on the bucket and move
-     * blocks to the shared cache if there are now too many free.
-     */
-
-    blockPtr = Ptr2Block(ptr);
-    bucket = blockPtr->sourceBucket;
-    if (bucket == NBUCKETS) {
-	cachePtr->totalAssigned -= blockPtr->blockReqSize;
-	free(blockPtr);
-	return;
-    }
-
-    cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
-    blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr;
-    cachePtr->buckets[bucket].firstPtr = blockPtr;
-    cachePtr->buckets[bucket].numFree++;
-    cachePtr->buckets[bucket].numInserts++;
-
-    if (cachePtr != sharedPtr &&
-	    cachePtr->buckets[bucket].numFree > bucketInfo[bucket].maxBlocks) {
-	PutBlocks(cachePtr, bucket, bucketInfo[bucket].numMove);
-    }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclpRealloc --
- *
- *	Re-allocate memory to a larger or smaller size.
- *
- * Results:
- *	Pointer to memory just beyond Block pointer.
- *
- * Side effects:
- *	Previous memory, if any, may be freed.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclpRealloc(
-    char *ptr,
-    unsigned int reqSize)
-{
-    Cache *cachePtr;
-    Block *blockPtr;
-    void *newPtr;
-    size_t size, min;
-    int bucket;
-
-    if (ptr == NULL) {
-	return TclpAlloc(reqSize);
-    }
-
-#ifndef __LP64__
-    if (sizeof(int) >= sizeof(size_t)) {
-	/* An unsigned int overflow can also be a size_t overflow */
-	const size_t zero = 0;
-	const size_t max = ~zero;
-
-	if (((size_t) reqSize) > max - sizeof(Block) - RCHECK) {
-	    /* Requested allocation exceeds memory */
-	    return NULL;
-	}
-    }
-#endif
-
-    cachePtr = TclpGetAllocCache();
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
-
-    /*
-     * If the block is not a system block and fits in place, simply return the
-     * existing pointer. Otherwise, if the block is a system block and the new
-     * size would also require a system block, call realloc() directly.
-     */
-
-    blockPtr = Ptr2Block(ptr);
-    size = reqSize + sizeof(Block);
-#if RCHECK
-    size++;
-#endif
-    bucket = blockPtr->sourceBucket;
-    if (bucket != NBUCKETS) {
-	if (bucket > 0) {
-	    min = bucketInfo[bucket-1].blockSize;
-	} else {
-	    min = 0;
-	}
-	if (size > min && size <= bucketInfo[bucket].blockSize) {
-	    cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
-	    cachePtr->buckets[bucket].totalAssigned += reqSize;
-	    return Block2Ptr(blockPtr, bucket, reqSize);
-	}
-    } else if (size > MAXALLOC) {
-	cachePtr->totalAssigned -= blockPtr->blockReqSize;
-	cachePtr->totalAssigned += reqSize;
-	blockPtr = realloc(blockPtr, size);
-	if (blockPtr == NULL) {
-	    return NULL;
-	}
-	return Block2Ptr(blockPtr, NBUCKETS, reqSize);
-    }
-
-    /*
-     * Finally, perform an expensive malloc/copy/free.
-     */
-
-    newPtr = TclpAlloc(reqSize);
-    if (newPtr != NULL) {
-	if (reqSize > blockPtr->blockReqSize) {
-	    reqSize = blockPtr->blockReqSize;
-	}
-	memcpy(newPtr, ptr, reqSize);
-	TclpFree(ptr);
-    }
-    return newPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclThreadAllocObj --
- *
- *	Allocate a Tcl_Obj from the per-thread cache.
- *
- * Results:
- *	Pointer to uninitialized Tcl_Obj.
- *
- * Side effects:
- *	May move Tcl_Obj's from shared cached or allocate new Tcl_Obj's if
- *	list is empty.
- *
- * Note:
- *	If this code is updated, the changes need to be reflected in the macro
- *	TclAllocObjStorageEx() defined in tclInt.h
- *
- *----------------------------------------------------------------------
- */
-
-Tcl_Obj *
-TclThreadAllocObj(void)
-{
-    register Cache *cachePtr = TclpGetAllocCache();
-    register Tcl_Obj *objPtr;
-
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
-
-    /*
-     * Get this thread's obj list structure and move or allocate new objs if
-     * necessary.
-     */
-
-    if (cachePtr->numObjects == 0) {
-	register int numMove;
-
-	Tcl_MutexLock(objLockPtr);
-	numMove = sharedPtr->numObjects;
-	if (numMove > 0) {
-	    if (numMove > NOBJALLOC) {
-		numMove = NOBJALLOC;
-	    }
-	    MoveObjs(sharedPtr, cachePtr, numMove);
-	}
-	Tcl_MutexUnlock(objLockPtr);
-	if (cachePtr->numObjects == 0) {
-	    Tcl_Obj *newObjsPtr;
-
-	    cachePtr->numObjects = numMove = NOBJALLOC;
-	    newObjsPtr = malloc(sizeof(Tcl_Obj) * numMove);
-	    if (newObjsPtr == NULL) {
-		Tcl_Panic("alloc: could not allocate %d new objects", numMove);
-	    }
-	    while (--numMove >= 0) {
-		objPtr = &newObjsPtr[numMove];
-		objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
-		cachePtr->firstObjPtr = objPtr;
-	    }
-	}
-    }
-
-    /*
-     * Pop the first object.
-     */
-
-    objPtr = cachePtr->firstObjPtr;
-    cachePtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
-    cachePtr->numObjects--;
-    return objPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclThreadFreeObj --
- *
- *	Return a free Tcl_Obj to the per-thread cache.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	May move free Tcl_Obj's to shared list upon hitting high water mark.
- *
- * Note:
- *	If this code is updated, the changes need to be reflected in the macro
- *	TclAllocObjStorageEx() defined in tclInt.h
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclThreadFreeObj(
-    Tcl_Obj *objPtr)
-{
-    Cache *cachePtr = TclpGetAllocCache();
-
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
-
-    /*
-     * Get this thread's list and push on the free Tcl_Obj.
-     */
-
-    objPtr->internalRep.otherValuePtr = cachePtr->firstObjPtr;
-    cachePtr->firstObjPtr = objPtr;
-    cachePtr->numObjects++;
-
-    /*
-     * If the number of free objects has exceeded the high water mark, move
-     * some blocks to the shared list.
-     */
-
-    if (cachePtr->numObjects > NOBJHIGH) {
-	Tcl_MutexLock(objLockPtr);
-	MoveObjs(cachePtr, sharedPtr, NOBJALLOC);
-	Tcl_MutexUnlock(objLockPtr);
-    }
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetMemoryInfo --
- *
- *	Return a list-of-lists of memory stats.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	List appended to given dstring.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_GetMemoryInfo(
-    Tcl_DString *dsPtr)
-{
-    Cache *cachePtr;
-    char buf[200];
-    unsigned int n;
-
-    Tcl_MutexLock(listLockPtr);
-    cachePtr = firstCachePtr;
-    while (cachePtr != NULL) {
-	Tcl_DStringStartSublist(dsPtr);
-	if (cachePtr == sharedPtr) {
-	    Tcl_DStringAppendElement(dsPtr, "shared");
-	} else {
-	    sprintf(buf, "thread%p", cachePtr->owner);
-	    Tcl_DStringAppendElement(dsPtr, buf);
-	}
-	for (n = 0; n < NBUCKETS; ++n) {
-	    sprintf(buf, "%lu %ld %ld %ld %ld %ld %ld",
-		    (unsigned long) bucketInfo[n].blockSize,
-		    cachePtr->buckets[n].numFree,
-		    cachePtr->buckets[n].numRemoves,
-		    cachePtr->buckets[n].numInserts,
-		    cachePtr->buckets[n].totalAssigned,
-		    cachePtr->buckets[n].numLocks,
-		    cachePtr->buckets[n].numWaits);
-	    Tcl_DStringAppendElement(dsPtr, buf);
-	}
-	Tcl_DStringEndSublist(dsPtr);
-	cachePtr = cachePtr->nextPtr;
-    }
-    Tcl_MutexUnlock(listLockPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * MoveObjs --
- *
- *	Move Tcl_Obj's between caches.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-MoveObjs(
-    Cache *fromPtr,
-    Cache *toPtr,
-    int numMove)
-{
-    register Tcl_Obj *objPtr = fromPtr->firstObjPtr;
-    Tcl_Obj *fromFirstObjPtr = objPtr;
-
-    toPtr->numObjects += numMove;
-    fromPtr->numObjects -= numMove;
-
-    /*
-     * Find the last object to be moved; set the next one (the first one not
-     * to be moved) as the first object in the 'from' cache.
-     */
-
-    while (--numMove) {
-	objPtr = objPtr->internalRep.otherValuePtr;
-    }
-    fromPtr->firstObjPtr = objPtr->internalRep.otherValuePtr;
-
-    /*
-     * Move all objects as a block - they are already linked to each other, we
-     * just have to update the first and last.
-     */
-
-    objPtr->internalRep.otherValuePtr = toPtr->firstObjPtr;
-    toPtr->firstObjPtr = fromFirstObjPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * Block2Ptr, Ptr2Block --
- *
- *	Convert between internal blocks and user pointers.
- *
- * Results:
- *	User pointer or internal block.
- *
- * Side effects:
- *	Invalid blocks will abort the server.
- *
- *----------------------------------------------------------------------
- */
-
-static char *
-Block2Ptr(
-    Block *blockPtr,
-    int bucket,
-    unsigned int reqSize)
-{
-    register void *ptr;
-
-    blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC;
-    blockPtr->sourceBucket = bucket;
-    blockPtr->blockReqSize = reqSize;
-    ptr = ((void *) (blockPtr + 1));
-#if RCHECK
-    ((unsigned char *)(ptr))[reqSize] = MAGIC;
-#endif
-    return (char *) ptr;
-}
-
-static Block *
-Ptr2Block(
-    char *ptr)
-{
-    register Block *blockPtr;
-
-    blockPtr = (((Block *) ptr) - 1);
-    if (blockPtr->magicNum1 != MAGIC || blockPtr->magicNum2 != MAGIC) {
-	Tcl_Panic("alloc: invalid block: %p: %x %x",
-		blockPtr, blockPtr->magicNum1, blockPtr->magicNum2);
-    }
-#if RCHECK
-    if (((unsigned char *) ptr)[blockPtr->blockReqSize] != MAGIC) {
-	Tcl_Panic("alloc: invalid block: %p: %x %x %x",
-		blockPtr, blockPtr->magicNum1, blockPtr->magicNum2,
-		((unsigned char *) ptr)[blockPtr->blockReqSize]);
-    }
-#endif
-    return blockPtr;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * LockBucket, UnlockBucket --
- *
- *	Set/unset the lock to access a bucket in the shared cache.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	Lock activity and contention are monitored globally and on a per-cache
- *	basis.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-LockBucket(
-    Cache *cachePtr,
-    int bucket)
-{
-#if 0
-    if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) {
-	Tcl_MutexLock(bucketInfo[bucket].lockPtr);
-	cachePtr->buckets[bucket].numWaits++;
-	sharedPtr->buckets[bucket].numWaits++;
-    }
-#else
-    Tcl_MutexLock(bucketInfo[bucket].lockPtr);
-#endif
-    cachePtr->buckets[bucket].numLocks++;
-    sharedPtr->buckets[bucket].numLocks++;
-}
-
-static void
-UnlockBucket(
-    Cache *cachePtr,
-    int bucket)
-{
-    Tcl_MutexUnlock(bucketInfo[bucket].lockPtr);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * PutBlocks --
- *
- *	Return unused blocks to the shared cache.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-static void
-PutBlocks(
-    Cache *cachePtr,
-    int bucket,
-    int numMove)
-{
-    register Block *lastPtr, *firstPtr;
-    register int n = numMove;
-
-    /*
-     * Before acquiring the lock, walk the block list to find the last block
-     * to be moved.
-     */
-
-    firstPtr = lastPtr = cachePtr->buckets[bucket].firstPtr;
-    while (--n > 0) {
-	lastPtr = lastPtr->nextBlock;
-    }
-    cachePtr->buckets[bucket].firstPtr = lastPtr->nextBlock;
-    cachePtr->buckets[bucket].numFree -= numMove;
-
-    /*
-     * Aquire the lock and place the list of blocks at the front of the shared
-     * cache bucket.
-     */
-
-    LockBucket(cachePtr, bucket);
-    lastPtr->nextBlock = sharedPtr->buckets[bucket].firstPtr;
-    sharedPtr->buckets[bucket].firstPtr = firstPtr;
-    sharedPtr->buckets[bucket].numFree += numMove;
-    UnlockBucket(cachePtr, bucket);
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * GetBlocks --
- *
- *	Get more blocks for a bucket.
- *
- * Results:
- *	1 if blocks where allocated, 0 otherwise.
- *
- * Side effects:
- *	Cache may be filled with available blocks.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-GetBlocks(
-    Cache *cachePtr,
-    int bucket)
-{
-    register Block *blockPtr;
-    register int n;
-
-    /*
-     * First, atttempt to move blocks from the shared cache. Note the
-     * potentially dirty read of numFree before acquiring the lock which is a
-     * slight performance enhancement. The value is verified after the lock is
-     * actually acquired.
-     */
-
-    if (cachePtr != sharedPtr && sharedPtr->buckets[bucket].numFree > 0) {
-	LockBucket(cachePtr, bucket);
-	if (sharedPtr->buckets[bucket].numFree > 0) {
-
-	    /*
-	     * Either move the entire list or walk the list to find the last
-	     * block to move.
-	     */
-
-	    n = bucketInfo[bucket].numMove;
-	    if (n >= sharedPtr->buckets[bucket].numFree) {
-		cachePtr->buckets[bucket].firstPtr =
-			sharedPtr->buckets[bucket].firstPtr;
-		cachePtr->buckets[bucket].numFree =
-			sharedPtr->buckets[bucket].numFree;
-		sharedPtr->buckets[bucket].firstPtr = NULL;
-		sharedPtr->buckets[bucket].numFree = 0;
-	    } else {
-		blockPtr = sharedPtr->buckets[bucket].firstPtr;
-		cachePtr->buckets[bucket].firstPtr = blockPtr;
-		sharedPtr->buckets[bucket].numFree -= n;
-		cachePtr->buckets[bucket].numFree = n;
-		while (--n > 0) {
-		    blockPtr = blockPtr->nextBlock;
-		}
-		sharedPtr->buckets[bucket].firstPtr = blockPtr->nextBlock;
-		blockPtr->nextBlock = NULL;
-	    }
-	}
-	UnlockBucket(cachePtr, bucket);
-    }
-
-    if (cachePtr->buckets[bucket].numFree == 0) {
-	register size_t size;
-
-	/*
-	 * If no blocks could be moved from shared, first look for a larger
-	 * block in this cache to split up.
-	 */
-
-	blockPtr = NULL;
-	n = NBUCKETS;
-	size = 0; /* lint */
-	while (--n > bucket) {
-	    if (cachePtr->buckets[n].numFree > 0) {
-		size = bucketInfo[n].blockSize;
-		blockPtr = cachePtr->buckets[n].firstPtr;
-		cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
-		cachePtr->buckets[n].numFree--;
-		break;
-	    }
-	}
-
-	/*
-	 * Otherwise, allocate a big new block directly.
-	 */
-
-	if (blockPtr == NULL) {
-	    size = MAXALLOC;
-	    blockPtr = malloc(size);
-	    if (blockPtr == NULL) {
-		return 0;
-	    }
-	}
-
-	/*
-	 * Split the larger block into smaller blocks for this bucket.
-	 */
-
-	n = size / bucketInfo[bucket].blockSize;
-	cachePtr->buckets[bucket].numFree = n;
-	cachePtr->buckets[bucket].firstPtr = blockPtr;
-	while (--n > 0) {
-	    blockPtr->nextBlock = (Block *)
-		((char *) blockPtr + bucketInfo[bucket].blockSize);
-	    blockPtr = blockPtr->nextBlock;
-	}
-	blockPtr->nextBlock = NULL;
-    }
-    return 1;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFinalizeThreadAlloc --
- *
- *	This procedure is used to destroy all private resources used in this
- *	file.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclFinalizeThreadAlloc(void)
-{
-    unsigned int i;
-
-    for (i = 0; i < NBUCKETS; ++i) {
-	TclpFreeAllocMutex(bucketInfo[i].lockPtr);
-	bucketInfo[i].lockPtr = NULL;
-    }
-
-    TclpFreeAllocMutex(objLockPtr);
-    objLockPtr = NULL;
-
-    TclpFreeAllocMutex(listLockPtr);
-    listLockPtr = NULL;
-
-    TclpFreeAllocCache(NULL);
-}
-
-#else /* !(TCL_THREADS && USE_THREAD_ALLOC) */
-/*
- *----------------------------------------------------------------------
- *
- * Tcl_GetMemoryInfo --
- *
- *	Return a list-of-lists of memory stats.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	List appended to given dstring.
- *
- *----------------------------------------------------------------------
- */
-
-void
-Tcl_GetMemoryInfo(
-    Tcl_DString *dsPtr)
-{
-    Tcl_Panic("Tcl_GetMemoryInfo called when threaded memory allocator not in use");
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclFinalizeThreadAlloc --
- *
- *	This procedure is used to destroy all private resources used in this
- *	file.
- *
- * Results:
- *	None.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclFinalizeThreadAlloc(void)
-{
-    Tcl_Panic("TclFinalizeThreadAlloc called when threaded memory allocator not in use");
-}
-#endif /* TCL_THREADS && USE_THREAD_ALLOC */
-
-/*
- * Local Variables:
- * mode: c
- * c-basic-offset: 4
- * fill-column: 78
- * End:
- */
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index d5fb6f6..ffbaa17 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -1650,7 +1650,7 @@ CallTraceFunction(
      * Copy the command characters into a new string.
      */
 
-    commandCopy = TclStackAlloc(interp, (unsigned) numChars + 1);
+    commandCopy = ckalloc((unsigned) numChars + 1);
     memcpy(commandCopy, command, (size_t) numChars);
     commandCopy[numChars] = '\0';
 
@@ -1661,7 +1661,7 @@ CallTraceFunction(
     traceCode = tracePtr->proc(tracePtr->clientData, (Tcl_Interp *) iPtr,
 	    iPtr->numLevels, commandCopy, (Tcl_Command) cmdPtr, objc, objv);
 
-    TclStackFree(interp, commandCopy);
+    ckfree(commandCopy);
     return traceCode;
 }
 
@@ -2237,7 +2237,7 @@ StringTraceProc(
      * which uses strings for everything.
      */
 
-    argv = (const char **) TclStackAlloc(interp,
+    argv = (const char **) ckalloc(
 	    (unsigned) ((objc + 1) * sizeof(const char *)));
     for (i = 0; i < objc; i++) {
 	argv[i] = Tcl_GetString(objv[i]);
@@ -2252,7 +2252,7 @@ StringTraceProc(
 
     data->proc(data->clientData, interp, level, (char *) command,
 	    cmdPtr->proc, cmdPtr->clientData, objc, argv);
-    TclStackFree(interp, (void *) argv);
+    ckfree((void *) argv);
 
     return TCL_OK;
 }
diff --git a/tests/nre.test b/tests/nre.test
index 295f02e..17f9a51 100644
--- a/tests/nre.test
+++ b/tests/nre.test
@@ -25,8 +25,8 @@ if {[testConstraint testnrelevels]} {
     namespace eval testnre {
 	namespace path ::tcl::mathop
 	#
-	# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
-	# cmdFrame level, callFrame level, tosPtr and callback depth 
+	# [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels,
+	# cmdFrame level, callFrame level and callback depth 
 	#
 	variable last [testnrelevels] 
 	proc depthDiff {} {
diff --git a/tests/tailcall.test b/tests/tailcall.test
index e9ec188..af496fc 100644
--- a/tests/tailcall.test
+++ b/tests/tailcall.test
@@ -24,8 +24,8 @@ testConstraint testnrelevels [llength [info commands testnrelevels]]
 if {[testConstraint testnrelevels]} {
     namespace eval testnre {
 	#
-	# [testnrelevels] returns a 6-list with: C-stack depth, iPtr->numlevels,
-	# cmdFrame level, callFrame level, tosPtr and callback depth 
+	# [testnrelevels] returns a 5-list with: C-stack depth, iPtr->numlevels,
+	# cmdFrame level, callFrame level and callback depth 
 	#
 	variable last [testnrelevels] 
 	proc depthDiff {} {
@@ -66,7 +66,7 @@ test tailcall-0.1 {tailcall is constant space} -constraints testnrelevels -setup
     a 0
 } -cleanup {
     rename a {}
-} -result {0 0 0 0 0 0}
+} -result {0 0 0 0 0}
 
 test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup {
     set a { i {
@@ -83,7 +83,7 @@ test tailcall-0.2 {tailcall is constant space} -constraints testnrelevels -setup
     apply $a 0
 } -cleanup {
     unset a
-} -result {0 0 0 0 0 0}
+} -result {0 0 0 0 0}
 
 test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup {
     proc a i {
@@ -101,7 +101,7 @@ test tailcall-0.3 {tailcall is constant space} -constraints testnrelevels -setup
 } -cleanup {
     rename a {}
     rename b {}
-} -result {0 0 0 0 0 0}
+} -result {0 0 0 0 0}
 
 test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup {
     namespace eval ::ns {
@@ -124,7 +124,7 @@ test tailcall-0.4 {tailcall is constant space} -constraints testnrelevels -setup
 } -cleanup {
     rename b {}
     namespace delete ::ns
-} -result {0 0 0 0 0 0}
+} -result {0 0 0 0 0}
 
 test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup {
     proc b i {
@@ -142,7 +142,7 @@ test tailcall-0.5 {tailcall is constant space} -constraints testnrelevels -setup
 } -cleanup {
     rename a {}
     rename b {}
-} -result {0 0 0 0 0 0}
+} -result {0 0 0 0 0}
 
 test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels knownBug} -setup {
     #
@@ -167,7 +167,7 @@ test tailcall-0.6 {tailcall is constant space} -constraints {testnrelevels known
     rename a {}
     rename c {}
     rename d {}
-} -result {0 0 0 0 0 0}
+} -result {0 0 0 0 0}
 
 test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup {
     catch {rename foo {}}
@@ -188,7 +188,7 @@ test tailcall-0.7 {tailcall is constant space} -constraints testnrelevels -setup
 } -cleanup {
     rename a {}
     rename foo {}
-} -result {0 0 0 0 0 0}
+} -result {0 0 0 0 0}
 
 test tailcall-1 {tailcall} -body {
     namespace eval a {
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 20ba896..2b5f867 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -304,7 +304,7 @@ GENERIC_OBJS = regcomp.o regexec.o regfree.o regerror.o tclAlloc.o \
 	tclPreserve.o tclProc.o tclRegexp.o \
 	tclResolve.o tclResult.o tclScan.o tclStringObj.o \
 	tclStrToD.o tclThread.o \
-	tclThreadAlloc.o tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
+	tclThreadJoin.o tclThreadStorage.o tclStubInit.o \
 	tclTimer.o tclTrace.o tclUtf.o tclUtil.o tclVar.o tclZlib.o \
 	tclTomMathInterface.o \
 	tclAssembly.o
@@ -445,7 +445,6 @@ GENERIC_SRCS = \
 	$(GENERIC_DIR)/tclTestObj.c \
 	$(GENERIC_DIR)/tclTestProcBodyObj.c \
 	$(GENERIC_DIR)/tclThread.c \
-	$(GENERIC_DIR)/tclThreadAlloc.c \
 	$(GENERIC_DIR)/tclThreadJoin.c \
 	$(GENERIC_DIR)/tclThreadStorage.c \
 	$(GENERIC_DIR)/tclTimer.c \
@@ -1007,11 +1006,8 @@ regerror.o: $(REGHDRS) $(GENERIC_DIR)/regerrs.h $(GENERIC_DIR)/regerror.c
 tclAppInit.o: $(UNIX_DIR)/tclAppInit.c
 	$(CC) -c $(APP_CC_SWITCHES) $(UNIX_DIR)/tclAppInit.c
 
-# On Unix we want to use the normal malloc/free implementation, so we
-# specifically set the USE_TCLALLOC flag.
-
 tclAlloc.o: $(GENERIC_DIR)/tclAlloc.c
-	$(CC) -c $(CC_SWITCHES) -DUSE_TCLALLOC=0 $(GENERIC_DIR)/tclAlloc.c
+	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAlloc.c
 
 tclAssembly.o: $(GENERIC_DIR)/tclAssembly.c $(COMPILEHDR)
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclAssembly.c
@@ -1286,9 +1282,6 @@ tclTimer.o: $(GENERIC_DIR)/tclTimer.c
 tclThread.o: $(GENERIC_DIR)/tclThread.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThread.c
 
-tclThreadAlloc.o: $(GENERIC_DIR)/tclThreadAlloc.c
-	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadAlloc.c
-
 tclThreadJoin.o: $(GENERIC_DIR)/tclThreadJoin.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclThreadJoin.c
 
diff --git a/unix/tclUnixPipe.c b/unix/tclUnixPipe.c
index d01624c..f6645fd 100644
--- a/unix/tclUnixPipe.c
+++ b/unix/tclUnixPipe.c
@@ -452,8 +452,8 @@ TclpCreateProcess(
      * deallocated later
      */
 
-    dsArray = TclStackAlloc(interp, argc * sizeof(Tcl_DString));
-    newArgv = TclStackAlloc(interp, (argc+1) * sizeof(char *));
+    dsArray = ckalloc(argc * sizeof(Tcl_DString));
+    newArgv = ckalloc((argc+1) * sizeof(char *));
     newArgv[argc] = NULL;
     for (i = 0; i < argc; i++) {
 	newArgv[i] = Tcl_UtfToExternalDString(NULL, argv[i], -1, &dsArray[i]);
@@ -524,8 +524,8 @@ TclpCreateProcess(
     for (i = 0; i < argc; i++) {
 	Tcl_DStringFree(&dsArray[i]);
     }
-    TclStackFree(interp, newArgv);
-    TclStackFree(interp, dsArray);
+    ckfree(newArgv);
+    ckfree(dsArray);
 
     if (pid == -1) {
 	Tcl_AppendResult(interp, "couldn't fork child process: ",
diff --git a/unix/tclUnixThrd.c b/unix/tclUnixThrd.c
index 0469d7a..a4db0df 100644
--- a/unix/tclUnixThrd.c
+++ b/unix/tclUnixThrd.c
@@ -676,12 +676,11 @@ TclpInetNtoa(
 #endif
 }
 
-#ifdef TCL_THREADS
+#if defined(TCL_THREADS)
 /*
  * Additions by AOL for specialized thread memory allocator.
  */
 
-#ifdef USE_THREAD_ALLOC
 static volatile int initialized = 0;
 static pthread_key_t key;
 
@@ -718,6 +717,7 @@ TclpFreeAllocMutex(
     free(lockPtr);
 }
 
+
 void
 TclpFreeAllocCache(
     void *ptr)
@@ -760,8 +760,9 @@ TclpSetAllocCache(
 {
     pthread_setspecific(key, arg);
 }
-#endif /* USE_THREAD_ALLOC */
+#endif
 
+#ifdef TCL_THREADS
 void *
 TclpThreadCreateKey(void)
 {
-- 
cgit v0.12


From 3504143b6c065a392dd1e98e22e06c53e0fc4e4e Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 13:10:03 +0000
Subject: README addition

---
 README.mig-alloc-reform | 4 ++++
 1 file changed, 4 insertions(+)

diff --git a/README.mig-alloc-reform b/README.mig-alloc-reform
index 139af2e..92debc3 100644
--- a/README.mig-alloc-reform
+++ b/README.mig-alloc-reform
@@ -38,6 +38,10 @@ What is mig-alloc-reform?
 
 
 ** PERFORMANCE NOTES **
+   * do enable HAVE_FAST_TSD on threaded build where available! Without
+     that it is probably slower than before. Note that __thread is not
+     available on macosx, but the "slow" version should be quite fast there
+     (or so they say)
    * not measured, but: purify, native and zippy builds should be just as
      fast as before. The obj-alloc macros have been removed while
      developing. It is not certain that they provide a speedup, this will
-- 
cgit v0.12


From 46c7a6bcac3a7466a3bf33ce1aaf81c4f5563afa Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 13:25:23 +0000
Subject: README addition

---
 README.mig-alloc-reform | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/README.mig-alloc-reform b/README.mig-alloc-reform
index 92debc3..5a52c26 100644
--- a/README.mig-alloc-reform
+++ b/README.mig-alloc-reform
@@ -48,7 +48,7 @@ What is mig-alloc-reform?
      be measured and acted accordingly 
    * multi build should be a only a tad slower, may even be suitable as
      default build on all platforms 
-
+   * zippy stats not enabled by default, -DZIPPY_STATS switches them on
 
 ** TO DO LIST **
    * DEFINITELY
-- 
cgit v0.12


From eed4991d081bb530cc04accd03144a4d815d2b3a Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 13:32:33 +0000
Subject: README addition

---
 README.mig-alloc-reform | 6 ++++--
 1 file changed, 4 insertions(+), 2 deletions(-)

diff --git a/README.mig-alloc-reform b/README.mig-alloc-reform
index 5a52c26..302812a 100644
--- a/README.mig-alloc-reform
+++ b/README.mig-alloc-reform
@@ -9,8 +9,10 @@ What is mig-alloc-reform?
      e. unify all allocator options in a single file tclAlloc.c
      d. exploit fast TSD via __thread where available (autoconferry still
         missing, enable by hand with -DHAVE_FAST_TSD)
-     f. small improvement in zippy's memory usage: try to split blocks in
-        the shared cache before allocating new ones from the system
+     f. small improvements in zippy's memory usage: 
+         . try to split blocks in the shared cache before allocating new
+           ones from the system 
+         . use the same bucket for Tcl_Objs and smallest allocs
 
   2. New allocator options
      a. purify build (but stop using them, see below). This is suitable to
-- 
cgit v0.12


From 8fa8bd69eb29f77d7d92d3f3c79385ee28f87ccc Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 16:16:09 +0000
Subject: New function TclAllocMaximize(). Let tclListObj.c find out the real
 allocated size, thus reducing the number of reallocs. It's good to avoid the
 interplay between List and Alloc both doubling just-in-case.

---
 generic/tclAlloc.c   | 70 ++++++++++++++++++++++++++++++++++++++++++++--------
 generic/tclInt.h     |  2 ++
 generic/tclListObj.c | 28 ++++++++++++++++-----
 3 files changed, 84 insertions(+), 16 deletions(-)

diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index 782a12b..ff04c2b 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -197,7 +197,6 @@ typedef struct Block {
 #define magicNum1	u.s.magic1
 #define magicNum2	u.s.magic2
 #define MAGIC		0xEF
-#define blockReqSize	reqSize
 
 /*
  * The following defines the minimum and maximum block sizes and the number
@@ -385,7 +384,7 @@ Block2Ptr(
 
     blockPtr->magicNum1 = blockPtr->magicNum2 = MAGIC;
     blockPtr->sourceBucket = bucket;
-    blockPtr->blockReqSize = reqSize;
+    blockPtr->reqSize = reqSize;
     ptr = (void *) (((char *)blockPtr) + OFFSET);
 #if RCHECK
     ((unsigned char *)(ptr))[reqSize] = MAGIC;
@@ -405,10 +404,10 @@ Ptr2Block(
 		blockPtr, blockPtr->magicNum1, blockPtr->magicNum2);
     }
 #if RCHECK
-    if (((unsigned char *) ptr)[blockPtr->blockReqSize] != MAGIC) {
+    if (((unsigned char *) ptr)[blockPtr->reqSize] != MAGIC) {
 	Tcl_Panic("alloc: invalid block: %p: %x %x %x",
 		blockPtr, blockPtr->magicNum1, blockPtr->magicNum2,
-		((unsigned char *) ptr)[blockPtr->blockReqSize]);
+		((unsigned char *) ptr)[blockPtr->reqSize]);
     }
 #endif
     return blockPtr;
@@ -707,14 +706,14 @@ TclpFree(
     bucket = blockPtr->sourceBucket;
     if (bucket == nBuckets) {
 #ifdef ZIPPY_STATS
-	cachePtr->totalAssigned -= blockPtr->blockReqSize;
+	cachePtr->totalAssigned -= blockPtr->reqSize;
 #endif
 	free(blockPtr);
 	return;
     }
 
 #ifdef ZIPPY_STATS
-    cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
+    cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize;
 #endif
     blockPtr->nextBlock = cachePtr->buckets[bucket].firstPtr;
     cachePtr->buckets[bucket].firstPtr = blockPtr;
@@ -800,14 +799,14 @@ TclpRealloc(
 	}
 	if (size > min && size <= bucketInfo[bucket].blockSize) {
 #ifdef ZIPPY_STATS
-	    cachePtr->buckets[bucket].totalAssigned -= blockPtr->blockReqSize;
+	    cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize;
 	    cachePtr->buckets[bucket].totalAssigned += reqSize;
 #endif
 	    return Block2Ptr(blockPtr, bucket, reqSize);
 	}
     } else if (size > MAXALLOC) {
 #ifdef ZIPPY_STATS
-	cachePtr->totalAssigned -= blockPtr->blockReqSize;
+	cachePtr->totalAssigned -= blockPtr->reqSize;
 	cachePtr->totalAssigned += reqSize;
 #endif
 	blockPtr = realloc(blockPtr, size);
@@ -823,14 +822,65 @@ TclpRealloc(
 
     newPtr = TclpAlloc(reqSize);
     if (newPtr != NULL) {
-	if (reqSize > blockPtr->blockReqSize) {
-	    reqSize = blockPtr->blockReqSize;
+	if (reqSize > blockPtr->reqSize) {
+	    reqSize = blockPtr->reqSize;
 	}
 	memcpy(newPtr, ptr, reqSize);
 	TclpFree(ptr);
     }
     return newPtr;
 }
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclAllocMaximize --
+ *
+ * Given a TclpAlloc'ed pointer, it returns the maximal size that can be used
+ * by the allocated memory. This is almost always larger than the requested
+ * size, as it corresponds to the bucket's size.
+ *
+ * Results:
+ *	New size.
+ *
+ *----------------------------------------------------------------------
+ */
+ unsigned int
+ TclAllocMaximize(
+     void *ptr)
+{
+    Block *blockPtr;
+    int bucket;
+    size_t oldSize, newSize;
+
+    if (allocator < aNONE) {
+	/*
+	 * No info, return UINT_MAX as a signal.
+	 */
+	
+	return UINT_MAX;
+    }
+    
+    blockPtr = Ptr2Block(ptr);
+    bucket = blockPtr->sourceBucket;
+    
+    if (bucket == nBuckets) {
+	/*
+	 * System malloc'ed: no info
+	 */
+	
+	return UINT_MAX;
+    }
+
+    oldSize = blockPtr->reqSize;
+    newSize = bucketInfo[bucket].blockSize - OFFSET - RCHECK;
+    blockPtr->reqSize = newSize;
+#if RCHECK
+    ((unsigned char *)(ptr))[newSize] = MAGIC;
+#endif    
+    return newSize;
+}
+
 #ifdef ZIPPY_STATS
 
 /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 45eaf7e..1f1e1d3 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3864,10 +3864,12 @@ MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
 #    define TclpAlloc(size) ckalloc(size)
 #    define TclpRealloc(ptr, size) ckrealloc((ptr),(size))
 #    define TclpFree(size) ckfree(size)
+#    define TclAllocMaximize(ptr) UINT_MAX
 #else
    MODULE_SCOPE char * TclpAlloc(unsigned int size);
    MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size);
    MODULE_SCOPE void   TclpFree(char * ptr);
+   MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr);
 #endif
 
 #if TCL_ALLOCATOR == aPURIFY
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 46710d6..814acd7 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -67,13 +67,23 @@ const Tcl_ObjType tclListType = {
  *----------------------------------------------------------------------
  */
 
+#define Elems2Size(n)					\
+    ((n > 1)						\
+	    ? (sizeof(List) + (n-1)*sizeof(Tcl_Obj *))	\
+	    : (sizeof(List)))
+#define Size2Elems(s)							\
+    ((s > sizeof(List) + sizeof(Tcl_Obj *) -1)				\
+	    ? (s - sizeof(List) + sizeof(Tcl_Obj *))/sizeof(Tcl_Obj *)	\
+	    : 1)
+
 static List *
 NewListIntRep(
     int objc,
     Tcl_Obj *const objv[])
 {
     List *listRepPtr;
-
+    unsigned int allocSize;
+    
     if (objc <= 0) {
 	return NULL;
     }
@@ -89,14 +99,17 @@ NewListIntRep(
 	return NULL;
     }
 
-    listRepPtr = attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj*)));
+    listRepPtr = attemptckalloc(Elems2Size(objc));
     if (listRepPtr == NULL) {
 	return NULL;
     }
-
+    allocSize = TclAllocMaximize(listRepPtr);
+    
     listRepPtr->canonicalFlag = 0;
     listRepPtr->refCount = 0;
-    listRepPtr->maxElemCount = objc;
+    listRepPtr->maxElemCount = (allocSize == UINT_MAX)
+	? objc
+	: Size2Elems(allocSize);
 
     if (objv) {
 	Tcl_Obj **elemPtrs;
@@ -576,7 +589,7 @@ Tcl_ListObjAppendElement(
 
     if (numRequired > listRepPtr->maxElemCount){
 	newMax = 2 * numRequired;
-	newSize = sizeof(List) + ((newMax-1) * sizeof(Tcl_Obj *));
+	newSize = Elems2Size(newMax);
     } else {
 	newMax = listRepPtr->maxElemCount;
 	newSize = 0;
@@ -601,7 +614,10 @@ Tcl_ListObjAppendElement(
 	oldListRepPtr->refCount--;
     } else if (newSize) {
 	listRepPtr = ckrealloc(listRepPtr, newSize);
-	listRepPtr->maxElemCount = newMax;
+	newSize = TclAllocMaximize(listRepPtr);
+	listRepPtr->maxElemCount = (newSize == UINT_MAX)
+	    ? newMax
+	    : Size2Elems(newSize);
     }
     listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
 
-- 
cgit v0.12


From b1edda8715f1cab75c0f12e7ba71c6e8d5e6e0a7 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 18:06:59 +0000
Subject: remove unused mutex

---
 generic/tclObj.c | 10 ----------
 1 file changed, 10 deletions(-)

diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5056c1c..5ee957d 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -27,16 +27,6 @@ static int typeTableInitialized = 0;	/* 0 means not yet initialized. */
 TCL_DECLARE_MUTEX(tableMutex)
 
 /*
- * The object allocator is single threaded. This mutex is referenced by the
- * TclNewObj macro, however, so must be visible.
- */
-
-#ifdef TCL_THREADS
-MODULE_SCOPE Tcl_Mutex tclObjMutex;
-Tcl_Mutex tclObjMutex;
-#endif
-
-/*
  * Pointer to a heap-allocated string of length zero that the Tcl core uses as
  * the value of an empty string representation for an object. This value is
  * shared by all new objects allocated by Tcl_NewObj.
-- 
cgit v0.12


From 0c6e7852c9f3570adf39a45c72ad1e0b9850b470 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 18:57:35 +0000
Subject: let TEBC also use TclAllocMaximize

---
 generic/tclExecute.c | 27 +++++++++++++++++++++------
 1 file changed, 21 insertions(+), 6 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b340144..2ed1537 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1535,6 +1535,12 @@ TclIncrObj(
 #define	catchStack	(TD->stack)
 #define	initTosPtr	((Tcl_Obj **) &TD->stack[codePtr->maxExceptDepth - 1])
 
+#define capacity2size(cap)						\
+    (sizeof(TEBCdata) + sizeof(void *)*(cap + codePtr->maxExceptDepth - 1))
+
+#define size2capacity(s) \
+    (((s - sizeof(TEBCdata))/sizeof(void *)) - codePtr->maxExceptDepth + 1)
+    
 int
 TclNRExecuteByteCode(
     Tcl_Interp *interp,		/* Token for command interpreter. */
@@ -1542,8 +1548,7 @@ TclNRExecuteByteCode(
 {
     Interp *iPtr = (Interp *) interp;
     TEBCdata *TD;
-    unsigned int size = sizeof(TEBCdata) + sizeof(void *) *
-	  (codePtr->maxStackDepth + codePtr->maxExceptDepth - 1);       
+    unsigned int size = capacity2size(codePtr->maxStackDepth);
     
     if (iPtr->execEnvPtr->rewind) {
 	return TCL_ERROR;
@@ -1564,6 +1569,13 @@ TclNRExecuteByteCode(
      */
 
     TD = ckalloc(size);
+    size = TclAllocMaximize(TD);
+    if (size == UINT_MAX) {
+	TD->capacity = codePtr->maxStackDepth;
+    } else {
+	TD->capacity = size2capacity(size);
+    }
+        
     TD->tosPtr = initTosPtr;
     
     TD->codePtr     = codePtr;
@@ -1572,7 +1584,6 @@ TclNRExecuteByteCode(
     TD->cleanup     = 0;
     TD->auxObjList  = NULL;
     TD->checkInterp = 0;
-    TD->capacity = codePtr->maxStackDepth;
     
     /*
      * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
@@ -2284,13 +2295,17 @@ TEBCresume(
 	(void) POP_OBJECT();
 	if (reqWords > TD->capacity) {
 	    ptrdiff_t depth;
-	    unsigned int size = sizeof(TEBCdata) + sizeof(void *) *
-		+ (reqWords + codePtr->maxExceptDepth - 1);
+	    unsigned int size = capacity2size(reqWords);
 	    
 	    depth = tosPtr - initTosPtr;
 	    TD = ckrealloc(TD, size);
+	    size = TclAllocMaximize(TD);
+	    if (size == UINT_MAX) {
+		TD->capacity = reqWords;
+	    } else {
+		TD->capacity = size2capacity(size);
+	    }
 	    tosPtr = initTosPtr + depth;
-	    TD->capacity = reqWords;
 	}
 	
 	/*
-- 
cgit v0.12


From 5d469a215fdc4fdb33b70cbd29969293680963e5 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 19:18:36 +0000
Subject: let TclAllocMaximize maintain zippys stats

---
 generic/tclAlloc.c | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index ff04c2b..f5fe3ee 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -877,7 +877,14 @@ TclpRealloc(
     blockPtr->reqSize = newSize;
 #if RCHECK
     ((unsigned char *)(ptr))[newSize] = MAGIC;
-#endif    
+#endif
+#ifdef ZIPPY_STATS
+    {
+	Cache *cachePtr;
+	GETCACHE(cachePtr);
+	cachePtr->buckets[bucket].totalAssigned += (newSize - oldSize);
+    }
+#endif
     return newSize;
 }
 
-- 
cgit v0.12


From f8767a126788d49a650721c15333965c47492abd Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 22:42:48 +0000
Subject: move the allocator stuff to the end of tclInt.h, in order not to
 interfere with tclIntDecls.h

---
 generic/tclInt.h | 191 ++++++++++++++++++++++++++++---------------------------
 1 file changed, 96 insertions(+), 95 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1f1e1d3..6bc8f49 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3815,101 +3815,6 @@ MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
 #endif /* TCL_MEM_DEBUG */
 
 /*
- * Macros that drive the allocator behaviour
- */
-
-#if defined(TCL_THREADS)
-/*
- * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
- * per-thread caches.
- */
-MODULE_SCOPE void	TclpFreeAllocCache(void *);
-MODULE_SCOPE void *	TclpGetAllocCache(void);
-MODULE_SCOPE void	TclpSetAllocCache(void *);
-MODULE_SCOPE void	TclFreeAllocCache(void *);
-MODULE_SCOPE void	TclpFreeAllocMutex(Tcl_Mutex *mutex);
-MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
-#endif
-
-/*
- * List of valid allocators. Have to respect the following convention:
- *  - allocators that shunt TclpAlloc to malloc are below aNONE
- *  - allocators that use zippy are above aNONE
- */
-
-#define aNATIVE    0
-#define aPURIFY    1
-#define aNONE      2 
-#define aZIPPY     3
-#define aMULTI     4
-
-#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI))
-#undef TCL_ALLOCATOR
-#endif
-
-#ifdef PURIFY
-#  undef TCL_ALLOCATOR
-#  define TCL_ALLOCATOR aPURIFY
-#endif
-
-#if !defined(TCL_ALLOCATOR)
-#  if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC)
-#    define TCL_ALLOCATOR aZIPPY
-#  else
-#    define TCL_ALLOCATOR aNATIVE
-#  endif
-#endif
-
-#if TCL_ALLOCATOR < aNONE /* native or purify */
-#    define TclpAlloc(size) ckalloc(size)
-#    define TclpRealloc(ptr, size) ckrealloc((ptr),(size))
-#    define TclpFree(size) ckfree(size)
-#    define TclAllocMaximize(ptr) UINT_MAX
-#else
-   MODULE_SCOPE char * TclpAlloc(unsigned int size);
-   MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size);
-   MODULE_SCOPE void   TclpFree(char * ptr);
-   MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr);
-#endif
-
-#if TCL_ALLOCATOR == aPURIFY
-#  define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj))
-#  define TclSmallFree(ptr) ckfree(ptr)
-#  define TclInitAlloc()
-#  define TclFinalizeAlloc()
-#else
-   MODULE_SCOPE void * TclSmallAlloc();
-   MODULE_SCOPE void   TclSmallFree(void *ptr);
-   MODULE_SCOPE void   TclInitAlloc(void);
-   MODULE_SCOPE void   TclFinalizeAlloc(void);
-#endif
-
-#define TclCkSmallAlloc(nbytes, memPtr)					\
-    do {								\
-	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
-	memPtr = TclSmallAlloc();					\
-    } while (0)
-
-/*
- * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
- */
-
-#if (TCL_ALLOCATOR == aPURIFY) && defined(__clang__)
-#if __has_feature(attribute_analyzer_noreturn) && \
-       !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
-void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
-#endif
-#if !defined(CLANG_ASSERT)
-#include <assert.h>
-#define CLANG_ASSERT(x) assert(x)
-#endif
-#elif !defined(CLANG_ASSERT)
- #define CLANG_ASSERT(x)
-#endif /* PURIFY && __clang__ */
-
-
-
-/*
  *----------------------------------------------------------------
  * Macro used by the Tcl core to set a Tcl_Obj's string representation to a
  * copy of the "len" bytes starting at "bytePtr". This code works even if the
@@ -4506,6 +4411,102 @@ typedef struct NRE_callback {
 #include "tclIntPlatDecls.h"
 #include "tclTomMathDecls.h"
 
+/*
+ * Macros that drive the allocator behaviour
+ * WARNING: these have to come AFTER tclIntDecls.h, as some macros may
+ * interfere with those declarations.
+ */
+
+#if defined(TCL_THREADS)
+/*
+ * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
+ * per-thread caches.
+ */
+MODULE_SCOPE void	TclpFreeAllocCache(void *);
+MODULE_SCOPE void *	TclpGetAllocCache(void);
+MODULE_SCOPE void	TclpSetAllocCache(void *);
+MODULE_SCOPE void	TclFreeAllocCache(void *);
+MODULE_SCOPE void	TclpFreeAllocMutex(Tcl_Mutex *mutex);
+MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
+#endif
+
+/*
+ * List of valid allocators. Have to respect the following convention:
+ *  - allocators that shunt TclpAlloc to malloc are below aNONE
+ *  - allocators that use zippy are above aNONE
+ */
+
+#define aNATIVE    0
+#define aPURIFY    1
+#define aNONE      2 
+#define aZIPPY     3
+#define aMULTI     4
+
+#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI))
+#undef TCL_ALLOCATOR
+#endif
+
+#ifdef PURIFY
+#  undef TCL_ALLOCATOR
+#  define TCL_ALLOCATOR aPURIFY
+#endif
+
+#if !defined(TCL_ALLOCATOR)
+#  if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC)
+#    define TCL_ALLOCATOR aZIPPY
+#  else
+#    define TCL_ALLOCATOR aNATIVE
+#  endif
+#endif
+
+#if TCL_ALLOCATOR < aNONE /* native or purify */
+#    define TclpAlloc(size) ckalloc(size)
+#    define TclpRealloc(ptr, size) ckrealloc((ptr),(size))
+#    define TclpFree(size) ckfree(size)
+#    define TclAllocMaximize(ptr) UINT_MAX
+#else
+   MODULE_SCOPE char * TclpAlloc(unsigned int size);
+   MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size);
+   MODULE_SCOPE void   TclpFree(char * ptr);
+   MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr);
+#endif
+
+#if TCL_ALLOCATOR == aPURIFY
+#  define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj))
+#  define TclSmallFree(ptr) ckfree(ptr)
+#  define TclInitAlloc()
+#  define TclFinalizeAlloc()
+#else
+   MODULE_SCOPE void * TclSmallAlloc();
+   MODULE_SCOPE void   TclSmallFree(void *ptr);
+   MODULE_SCOPE void   TclInitAlloc(void);
+   MODULE_SCOPE void   TclFinalizeAlloc(void);
+#endif
+
+#define TclCkSmallAlloc(nbytes, memPtr)					\
+    do {								\
+	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
+	memPtr = TclSmallAlloc();					\
+    } while (0)
+
+/*
+ * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
+ */
+
+#if (TCL_ALLOCATOR == aPURIFY) && defined(__clang__)
+#if __has_feature(attribute_analyzer_noreturn) && \
+       !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
+void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
+#endif
+#if !defined(CLANG_ASSERT)
+#include <assert.h>
+#define CLANG_ASSERT(x) assert(x)
+#endif
+#elif !defined(CLANG_ASSERT)
+ #define CLANG_ASSERT(x)
+#endif /* PURIFY && __clang__ */
+
+
 #endif /* _TCLINT */
 
 /*
-- 
cgit v0.12


From edd8ea9b6b9bc1370a799e86323a6ecc3618668d Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 22:57:06 +0000
Subject: remove TclpAlloc and friends from internal stubs

---
 generic/tclInt.decls  |  18 ++---
 generic/tclInt.h      | 191 +++++++++++++++++++++++++-------------------------
 generic/tclIntDecls.h |  24 +++----
 generic/tclStubInit.c |   6 +-
 4 files changed, 116 insertions(+), 123 deletions(-)

diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 6330836..75cb20a 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -290,9 +290,9 @@ declare 64 {
 #declare 68 {
 #    int TclpAccess(const char *path, int mode)
 #}
-declare 69 {
-    char *TclpAlloc(unsigned int size)
-}
+#declare 69 {
+#    char *TclpAlloc(unsigned int size)
+#}
 #declare 70 {
 #    int TclpCopyFile(const char *source, const char *dest)
 #}
@@ -306,9 +306,9 @@ declare 69 {
 #declare 73 {
 #    int TclpDeleteFile(const char *path)
 #}
-declare 74 {
-    void TclpFree(char *ptr)
-}
+#declare 74 {
+#    void TclpFree(char *ptr)
+#}
 declare 75 {
     unsigned long TclpGetClicks(void)
 }
@@ -332,9 +332,9 @@ declare 78 {
 #    Tcl_Channel TclpOpenFileChannel(Tcl_Interp *interp, char *fileName,
 #	    char *modeString, int permissions)
 #}
-declare 81 {
-    char *TclpRealloc(char *ptr, unsigned int size)
-}
+#declare 81 {
+#    char *TclpRealloc(char *ptr, unsigned int size)
+#}
 #declare 82 {
 #    int TclpRemoveDirectory(const char *path, int recursive,
 #	    Tcl_DString *errorPtr)
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 6bc8f49..1f1e1d3 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3815,6 +3815,101 @@ MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
 #endif /* TCL_MEM_DEBUG */
 
 /*
+ * Macros that drive the allocator behaviour
+ */
+
+#if defined(TCL_THREADS)
+/*
+ * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
+ * per-thread caches.
+ */
+MODULE_SCOPE void	TclpFreeAllocCache(void *);
+MODULE_SCOPE void *	TclpGetAllocCache(void);
+MODULE_SCOPE void	TclpSetAllocCache(void *);
+MODULE_SCOPE void	TclFreeAllocCache(void *);
+MODULE_SCOPE void	TclpFreeAllocMutex(Tcl_Mutex *mutex);
+MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
+#endif
+
+/*
+ * List of valid allocators. Have to respect the following convention:
+ *  - allocators that shunt TclpAlloc to malloc are below aNONE
+ *  - allocators that use zippy are above aNONE
+ */
+
+#define aNATIVE    0
+#define aPURIFY    1
+#define aNONE      2 
+#define aZIPPY     3
+#define aMULTI     4
+
+#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI))
+#undef TCL_ALLOCATOR
+#endif
+
+#ifdef PURIFY
+#  undef TCL_ALLOCATOR
+#  define TCL_ALLOCATOR aPURIFY
+#endif
+
+#if !defined(TCL_ALLOCATOR)
+#  if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC)
+#    define TCL_ALLOCATOR aZIPPY
+#  else
+#    define TCL_ALLOCATOR aNATIVE
+#  endif
+#endif
+
+#if TCL_ALLOCATOR < aNONE /* native or purify */
+#    define TclpAlloc(size) ckalloc(size)
+#    define TclpRealloc(ptr, size) ckrealloc((ptr),(size))
+#    define TclpFree(size) ckfree(size)
+#    define TclAllocMaximize(ptr) UINT_MAX
+#else
+   MODULE_SCOPE char * TclpAlloc(unsigned int size);
+   MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size);
+   MODULE_SCOPE void   TclpFree(char * ptr);
+   MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr);
+#endif
+
+#if TCL_ALLOCATOR == aPURIFY
+#  define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj))
+#  define TclSmallFree(ptr) ckfree(ptr)
+#  define TclInitAlloc()
+#  define TclFinalizeAlloc()
+#else
+   MODULE_SCOPE void * TclSmallAlloc();
+   MODULE_SCOPE void   TclSmallFree(void *ptr);
+   MODULE_SCOPE void   TclInitAlloc(void);
+   MODULE_SCOPE void   TclFinalizeAlloc(void);
+#endif
+
+#define TclCkSmallAlloc(nbytes, memPtr)					\
+    do {								\
+	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
+	memPtr = TclSmallAlloc();					\
+    } while (0)
+
+/*
+ * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
+ */
+
+#if (TCL_ALLOCATOR == aPURIFY) && defined(__clang__)
+#if __has_feature(attribute_analyzer_noreturn) && \
+       !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
+void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
+#endif
+#if !defined(CLANG_ASSERT)
+#include <assert.h>
+#define CLANG_ASSERT(x) assert(x)
+#endif
+#elif !defined(CLANG_ASSERT)
+ #define CLANG_ASSERT(x)
+#endif /* PURIFY && __clang__ */
+
+
+
+/*
  *----------------------------------------------------------------
  * Macro used by the Tcl core to set a Tcl_Obj's string representation to a
  * copy of the "len" bytes starting at "bytePtr". This code works even if the
@@ -4411,102 +4506,6 @@ typedef struct NRE_callback {
 #include "tclIntPlatDecls.h"
 #include "tclTomMathDecls.h"
 
-/*
- * Macros that drive the allocator behaviour
- * WARNING: these have to come AFTER tclIntDecls.h, as some macros may
- * interfere with those declarations.
- */
-
-#if defined(TCL_THREADS)
-/*
- * The TCL_THREADS mode is like the regular mode but allocates Tcl_Obj's from
- * per-thread caches.
- */
-MODULE_SCOPE void	TclpFreeAllocCache(void *);
-MODULE_SCOPE void *	TclpGetAllocCache(void);
-MODULE_SCOPE void	TclpSetAllocCache(void *);
-MODULE_SCOPE void	TclFreeAllocCache(void *);
-MODULE_SCOPE void	TclpFreeAllocMutex(Tcl_Mutex *mutex);
-MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
-#endif
-
-/*
- * List of valid allocators. Have to respect the following convention:
- *  - allocators that shunt TclpAlloc to malloc are below aNONE
- *  - allocators that use zippy are above aNONE
- */
-
-#define aNATIVE    0
-#define aPURIFY    1
-#define aNONE      2 
-#define aZIPPY     3
-#define aMULTI     4
-
-#if defined(TCL_ALLOCATOR) && ((TCL_ALLOCATOR < 0) || (TCL_ALLOCATOR > aMULTI))
-#undef TCL_ALLOCATOR
-#endif
-
-#ifdef PURIFY
-#  undef TCL_ALLOCATOR
-#  define TCL_ALLOCATOR aPURIFY
-#endif
-
-#if !defined(TCL_ALLOCATOR)
-#  if defined(USE_THREAD_ALLOC) || defined(USE_TCLALLOC)
-#    define TCL_ALLOCATOR aZIPPY
-#  else
-#    define TCL_ALLOCATOR aNATIVE
-#  endif
-#endif
-
-#if TCL_ALLOCATOR < aNONE /* native or purify */
-#    define TclpAlloc(size) ckalloc(size)
-#    define TclpRealloc(ptr, size) ckrealloc((ptr),(size))
-#    define TclpFree(size) ckfree(size)
-#    define TclAllocMaximize(ptr) UINT_MAX
-#else
-   MODULE_SCOPE char * TclpAlloc(unsigned int size);
-   MODULE_SCOPE char * TclpRealloc(char * ptr, unsigned int size);
-   MODULE_SCOPE void   TclpFree(char * ptr);
-   MODULE_SCOPE unsigned int TclAllocMaximize(void *ptr);
-#endif
-
-#if TCL_ALLOCATOR == aPURIFY
-#  define TclSmallAlloc() ckalloc(sizeof(Tcl_Obj))
-#  define TclSmallFree(ptr) ckfree(ptr)
-#  define TclInitAlloc()
-#  define TclFinalizeAlloc()
-#else
-   MODULE_SCOPE void * TclSmallAlloc();
-   MODULE_SCOPE void   TclSmallFree(void *ptr);
-   MODULE_SCOPE void   TclInitAlloc(void);
-   MODULE_SCOPE void   TclFinalizeAlloc(void);
-#endif
-
-#define TclCkSmallAlloc(nbytes, memPtr)					\
-    do {								\
-	TCL_CT_ASSERT((nbytes)<=sizeof(Tcl_Obj));			\
-	memPtr = TclSmallAlloc();					\
-    } while (0)
-
-/*
- * Support for Clang Static Analyzer <http://clang-analyzer.llvm.org>
- */
-
-#if (TCL_ALLOCATOR == aPURIFY) && defined(__clang__)
-#if __has_feature(attribute_analyzer_noreturn) && \
-       !defined(Tcl_Panic) && defined(Tcl_Panic_TCL_DECLARED)
-void Tcl_Panic(const char *, ...) __attribute__((analyzer_noreturn));
-#endif
-#if !defined(CLANG_ASSERT)
-#include <assert.h>
-#define CLANG_ASSERT(x) assert(x)
-#endif
-#elif !defined(CLANG_ASSERT)
- #define CLANG_ASSERT(x)
-#endif /* PURIFY && __clang__ */
-
-
 #endif /* _TCLINT */
 
 /*
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index 0966d32..dce5dae 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -199,14 +199,12 @@ EXTERN int		TclObjInvoke(Tcl_Interp *interp, int objc,
 /* Slot 66 is reserved */
 /* Slot 67 is reserved */
 /* Slot 68 is reserved */
-/* 69 */
-EXTERN char *		TclpAlloc(unsigned int size);
+/* Slot 69 is reserved */
 /* Slot 70 is reserved */
 /* Slot 71 is reserved */
 /* Slot 72 is reserved */
 /* Slot 73 is reserved */
-/* 74 */
-EXTERN void		TclpFree(char *ptr);
+/* Slot 74 is reserved */
 /* 75 */
 EXTERN unsigned long	TclpGetClicks(void);
 /* 76 */
@@ -217,8 +215,7 @@ EXTERN void		TclpGetTime(Tcl_Time *time);
 EXTERN int		TclpGetTimeZone(unsigned long time);
 /* Slot 79 is reserved */
 /* Slot 80 is reserved */
-/* 81 */
-EXTERN char *		TclpRealloc(char *ptr, unsigned int size);
+/* Slot 81 is reserved */
 /* Slot 82 is reserved */
 /* Slot 83 is reserved */
 /* Slot 84 is reserved */
@@ -672,19 +669,19 @@ typedef struct TclIntStubs {
     void (*reserved66)(void);
     void (*reserved67)(void);
     void (*reserved68)(void);
-    char * (*tclpAlloc) (unsigned int size); /* 69 */
+    void (*reserved69)(void);
     void (*reserved70)(void);
     void (*reserved71)(void);
     void (*reserved72)(void);
     void (*reserved73)(void);
-    void (*tclpFree) (char *ptr); /* 74 */
+    void (*reserved74)(void);
     unsigned long (*tclpGetClicks) (void); /* 75 */
     unsigned long (*tclpGetSeconds) (void); /* 76 */
     void (*tclpGetTime) (Tcl_Time *time); /* 77 */
     int (*tclpGetTimeZone) (unsigned long time); /* 78 */
     void (*reserved79)(void);
     void (*reserved80)(void);
-    char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */
+    void (*reserved81)(void);
     void (*reserved82)(void);
     void (*reserved83)(void);
     void (*reserved84)(void);
@@ -977,14 +974,12 @@ extern const TclIntStubs *tclIntStubsPtr;
 /* Slot 66 is reserved */
 /* Slot 67 is reserved */
 /* Slot 68 is reserved */
-#define TclpAlloc \
-	(tclIntStubsPtr->tclpAlloc) /* 69 */
+/* Slot 69 is reserved */
 /* Slot 70 is reserved */
 /* Slot 71 is reserved */
 /* Slot 72 is reserved */
 /* Slot 73 is reserved */
-#define TclpFree \
-	(tclIntStubsPtr->tclpFree) /* 74 */
+/* Slot 74 is reserved */
 #define TclpGetClicks \
 	(tclIntStubsPtr->tclpGetClicks) /* 75 */
 #define TclpGetSeconds \
@@ -995,8 +990,7 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclpGetTimeZone) /* 78 */
 /* Slot 79 is reserved */
 /* Slot 80 is reserved */
-#define TclpRealloc \
-	(tclIntStubsPtr->tclpRealloc) /* 81 */
+/* Slot 81 is reserved */
 /* Slot 82 is reserved */
 /* Slot 83 is reserved */
 /* Slot 84 is reserved */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 84c1ea9..0583961 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -123,19 +123,19 @@ static const TclIntStubs tclIntStubs = {
     0, /* 66 */
     0, /* 67 */
     0, /* 68 */
-    TclpAlloc, /* 69 */
+    0, /* 69 */
     0, /* 70 */
     0, /* 71 */
     0, /* 72 */
     0, /* 73 */
-    TclpFree, /* 74 */
+    0, /* 74 */
     TclpGetClicks, /* 75 */
     TclpGetSeconds, /* 76 */
     TclpGetTime, /* 77 */
     TclpGetTimeZone, /* 78 */
     0, /* 79 */
     0, /* 80 */
-    TclpRealloc, /* 81 */
+    0, /* 81 */
     0, /* 82 */
     0, /* 83 */
     0, /* 84 */
-- 
cgit v0.12


From 4843669df511f30ec9024092dcdd019a5a5792df Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Fri, 18 Mar 2011 23:04:03 +0000
Subject: getting aPURIFY to build?

---
 generic/tclInt.h | 1 +
 1 file changed, 1 insertion(+)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 1f1e1d3..92c494e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3877,6 +3877,7 @@ MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
 #  define TclSmallFree(ptr) ckfree(ptr)
 #  define TclInitAlloc()
 #  define TclFinalizeAlloc()
+#  define TclFreeAllocCache(ptr)
 #else
    MODULE_SCOPE void * TclSmallAlloc();
    MODULE_SCOPE void   TclSmallFree(void *ptr);
-- 
cgit v0.12


From c2c2d39a30718bca7a5243506be96f9a59a84322 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sat, 19 Mar 2011 12:24:43 +0000
Subject: get purify and native to build by removing ref to ckalloc and friends

---
 generic/tclInt.h | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 92c494e..a05007f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3861,9 +3861,9 @@ MODULE_SCOPE Tcl_Mutex *TclpNewAllocMutex(void);
 #endif
 
 #if TCL_ALLOCATOR < aNONE /* native or purify */
-#    define TclpAlloc(size) ckalloc(size)
-#    define TclpRealloc(ptr, size) ckrealloc((ptr),(size))
-#    define TclpFree(size) ckfree(size)
+#    define TclpAlloc(size) malloc(size)
+#    define TclpRealloc(ptr, size) realloc((ptr),(size))
+#    define TclpFree(size) free(size)
 #    define TclAllocMaximize(ptr) UINT_MAX
 #else
    MODULE_SCOPE char * TclpAlloc(unsigned int size);
-- 
cgit v0.12


From 7594338af93c41ff22ddc17d9172d97b4a376d6c Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sat, 19 Mar 2011 17:23:05 +0000
Subject: tclListObj.c: simplify macros

---
 generic/tclListObj.c | 11 ++++-------
 1 file changed, 4 insertions(+), 7 deletions(-)

diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 814acd7..4c1e219 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -67,14 +67,11 @@ const Tcl_ObjType tclListType = {
  *----------------------------------------------------------------------
  */
 
-#define Elems2Size(n)					\
-    ((n > 1)						\
-	    ? (sizeof(List) + (n-1)*sizeof(Tcl_Obj *))	\
-	    : (sizeof(List)))
+#define Elems2Size(n)				\
+    (sizeof(List) - sizeof(Tcl_Obj *) + n*sizeof(Tcl_Obj *))
+
 #define Size2Elems(s)							\
-    ((s > sizeof(List) + sizeof(Tcl_Obj *) -1)				\
-	    ? (s - sizeof(List) + sizeof(Tcl_Obj *))/sizeof(Tcl_Obj *)	\
-	    : 1)
+    (s - (sizeof(List) - sizeof(Tcl_Obj *)))/sizeof(Tcl_Obj *)
 
 static List *
 NewListIntRep(
-- 
cgit v0.12


From ad01c2a5d674e9304c376a1872a4ec39e03972b8 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sat, 19 Mar 2011 17:56:06 +0000
Subject: look at all blocks in this thread before looking in the shared cache

---
 generic/tclAlloc.c | 24 ++++++++++++++++--------
 1 file changed, 16 insertions(+), 8 deletions(-)

diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index f5fe3ee..efaf6ac 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -1230,20 +1230,28 @@ GetBlocks(
 		cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
 		cachePtr->buckets[n].numFree--;
 		break;
-	    } else if (sharedPtr->buckets[n].numFree > 0){
-		LockBucket(cachePtr, n);
+	    }
+	}
+#if defined(TCL_THREADS)
+	if (blockPtr == NULL) {
+	    n = nBuckets;
+	    size = 0; /* lint */
+	    while (--n > bucket) {
 		if (sharedPtr->buckets[n].numFree > 0) {
-		    blockPtr = sharedPtr->buckets[n].firstPtr;
-		    sharedPtr->buckets[n].firstPtr = blockPtr->nextBlock;
-		    sharedPtr->buckets[n].numFree--;
+		    LockBucket(cachePtr, n);
+		    if (sharedPtr->buckets[n].numFree > 0) {
+			blockPtr = sharedPtr->buckets[n].firstPtr;
+			sharedPtr->buckets[n].firstPtr = blockPtr->nextBlock;
+			sharedPtr->buckets[n].numFree--;
+			UnlockBucket(cachePtr, n);
+			break;		
+		    }
 		    UnlockBucket(cachePtr, n);
-		    break;		
 		}
-		UnlockBucket(cachePtr, n);
 	    }
 	}
 #endif
-
+#endif
 	/*
 	 * Otherwise, allocate a big new block directly.
 	 */
-- 
cgit v0.12


From f91eaa901468a1b6066b1cd8d7bc0b05684f17c3 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sat, 19 Mar 2011 19:00:19 +0000
Subject: uninited var in last commit

---
 generic/tclAlloc.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index efaf6ac..f186d67 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -387,6 +387,7 @@ Block2Ptr(
     blockPtr->reqSize = reqSize;
     ptr = (void *) (((char *)blockPtr) + OFFSET);
 #if RCHECK
+    TclPanic("RCHECK??");
     ((unsigned char *)(ptr))[reqSize] = MAGIC;
 #endif
     return (char *) ptr;
@@ -1224,8 +1225,8 @@ GetBlocks(
 	n = nBuckets;
 	size = 0; /* lint */
 	while (--n > bucket) {
-	    size = bucketInfo[n].blockSize;
 	    if (cachePtr->buckets[n].numFree > 0) {
+		size = bucketInfo[n].blockSize;
 		blockPtr = cachePtr->buckets[n].firstPtr;
 		cachePtr->buckets[n].firstPtr = blockPtr->nextBlock;
 		cachePtr->buckets[n].numFree--;
@@ -1238,6 +1239,7 @@ GetBlocks(
 	    size = 0; /* lint */
 	    while (--n > bucket) {
 		if (sharedPtr->buckets[n].numFree > 0) {
+		    size = bucketInfo[n].blockSize;
 		    LockBucket(cachePtr, n);
 		    if (sharedPtr->buckets[n].numFree > 0) {
 			blockPtr = sharedPtr->buckets[n].firstPtr;
-- 
cgit v0.12


From 8acfdb842be3b3b543602a913afd70257c3adbe1 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sat, 19 Mar 2011 19:35:23 +0000
Subject: remove stray panic set for debugging

---
 generic/tclAlloc.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index f186d67..85f7036 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -387,7 +387,6 @@ Block2Ptr(
     blockPtr->reqSize = reqSize;
     ptr = (void *) (((char *)blockPtr) + OFFSET);
 #if RCHECK
-    TclPanic("RCHECK??");
     ((unsigned char *)(ptr))[reqSize] = MAGIC;
 #endif
     return (char *) ptr;
-- 
cgit v0.12


From f178c1aaf71fda7178990a0b5bf8f7910af7c87e Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sat, 19 Mar 2011 19:44:20 +0000
Subject: early return on freeing a NULL pointer

---
 generic/tclAlloc.c | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index 85f7036..9c0ab02 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -686,16 +686,16 @@ TclpFree(
     Block *blockPtr;
     int bucket;
 
+    if (ptr == NULL) {
+	return;
+    }
+
     if (allocator < aNONE) {
 	return free((char *) ptr);
     }
 
     GETCACHE(cachePtr);
 
-    if (ptr == NULL) {
-	return;
-    }
-
     /*
      * Get the block back from the user pointer and call system free directly
      * for large blocks. Otherwise, push the block back on the bucket and move
-- 
cgit v0.12


From 22ed38f5b9c16b297220948b460e412253b807fb Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sat, 19 Mar 2011 21:47:07 +0000
Subject: adding benchmarks on core.tcl.tk; still some weirdos, but looking
 good

---
 normBench | 662 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 662 insertions(+)
 create mode 100644 normBench

diff --git a/normBench b/normBench
new file mode 100644
index 0000000..e3be695
--- /dev/null
+++ b/normBench
@@ -0,0 +1,662 @@
+TCL_INTERP: 1:8.6b1.2 2:8.6b1.2 3:8.6b1.2 4:8.6b1.2 5:8.6b1.2 6:8.6b1.2
+STARTED 2011-03-19 13:34:03 (runbench.tcl v1.30)
+Benchmark 1:8.6b1.2 /home/mig/testbench/tclsh/tclsh.trunk
+aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:20 elapsed
+Benchmark 2:8.6b1.2 /home/mig/testbench/tclsh/tclsh.fast
+aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:18 elapsed
+Benchmark 3:8.6b1.2 /home/mig/testbench/tclsh/tclsh.base
+aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:24 elapsed
+Benchmark 4:8.6b1.2 /home/mig/testbench/tclsh/tclsh.multi
+aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:19 elapsed
+Benchmark 5:8.6b1.2 /home/mig/testbench/tclsh/tclsh.purify
+aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:47 elapsed
+Benchmark 6:8.6b1.2 /home/mig/testbench/tclsh/tclsh.native
+aabbccdeeefffghkllmmmmnpprrssstuuvw 00:01:23 elapsed
+R1 R2 R3 R4 R5 
+000 VERSIONS:                            1:8.6b1.2 2:8.6b1.2 3:8.6b1.2 4:8.6b1.2 5:8.6b1.2 6:8.6b1.2
+001 ARRAY format genKeys 50                 1.00    0.92    1.03    0.93    1.37    1.09
+002 ARRAY format genKeys 500                1.00    0.91    1.01    0.91    1.35    1.08
+003 ARRAY makeHash 500 50                   1.00    0.93    0.94    0.92    1.02    0.84
+004 ascii85 strlen 2690                     1.00    1.02    1.12    1.01    1.47    1.08
+005 ascii85 strlen 269000                   1.00    1.02    1.09    0.98    1.40    1.04
+006 BASE64 decode 10                        1.00    0.94    1.00    0.95    1.26    1.07
+007 BASE64 decode 100                       1.00    0.94    1.00    0.93    1.23    1.03
+008 BASE64 decode 1000                      1.00    0.94    1.01    0.94    1.22    1.02
+009 BASE64 decode 10000                     1.00    0.94    0.99    0.95    1.22    1.04
+010 BASE64 decode2 10                       1.00    0.96    1.01    0.99    1.29    1.08
+011 BASE64 decode2 100                      1.00    0.94    0.99    0.95    1.25    1.03
+012 BASE64 decode2 1000                     1.00    0.95    1.00    0.95    1.24    1.03
+013 BASE64 decode2 10000                    1.00    0.94    0.99    0.96    1.23    1.03
+014 BASE64 decode3 10                       1.00    0.97    1.05    0.99    1.33    1.08
+015 BASE64 decode3 100                      1.00    0.99    1.06    1.00    1.31    1.04
+016 BASE64 decode3 1000                     1.00    1.00    1.07    1.02    1.32    1.03
+017 BASE64 decode3 10000                    1.00    1.00    1.08    1.02    1.29    1.03
+018 BASE64 encode 10                        1.00    0.90    1.02    0.94    1.23    1.04
+019 BASE64 encode 100                       1.00    0.90    1.02    0.96    1.20    0.99
+020 BASE64 encode 1000                      1.00    0.90    1.01    0.96    1.18    1.00
+021 BASE64 encode 10000                     1.00    0.90    1.02    0.96    1.19    1.02
+022 BASE64 encode2 10                       1.00    0.91    1.02    0.94    1.22    1.02
+023 BASE64 encode2 100                      1.00    0.93    1.03    0.97    1.20    0.97
+024 BASE64 encode2 1000                     1.00    0.93    1.02    0.97    1.17    0.97
+025 BASE64 encode2 10000                    1.00    0.93    1.02    0.96    1.17    0.98
+026 BASE64 encode3 10                       1.00    0.96    1.01    0.94    1.24    1.03
+027 BASE64 encode3 100                      1.00    1.01    1.03    1.00    1.16    0.98
+028 BASE64 encode3 1000                     1.00    1.01    1.03    0.97    1.13    0.94
+029 BASE64 encode3 10000                    1.00    1.01    1.03    0.99    1.11    0.95
+030 BIN bitset-v1 1000 chars                1.00    1.10    1.15    1.07    1.54    1.13
+031 BIN bitset-v1 5000 chars                1.00    1.10    1.14    1.07    1.53    1.11
+032 BIN bitset-v1 10000 chars               1.00    1.10    1.13    1.06    1.52    1.10
+033 BIN bitset-v2 1000 chars                1.00    1.06    1.13    1.02    1.48    1.08
+034 BIN bitset-v2 5000 chars                1.00    1.05    1.12    1.02    1.47    1.06
+035 BIN bitset-v2 10000 chars               1.00    1.05    1.13    1.01    1.47    1.07
+036 BIN bitset-v3 1000 chars                1.00    1.01    1.11    0.94    1.33    1.05
+037 BIN bitset-v3 5000 chars                1.00    1.00    1.11    0.94    1.28    1.03
+038 BIN bitset-v3 10000 chars               1.00    1.03    1.10    0.95    1.28    1.04
+039 BIN c scan, 1000b                       1.00    0.90    0.98    0.90    1.33    1.16
+040 BIN c scan, 5000b                       1.00    0.96    1.01    1.01    1.12    1.05
+041 BIN c scan, 10000b                      1.00    0.99    1.03    1.04    1.11    1.11
+042 BIN chars, 10000b                       1.00    1.03    1.07    0.96    1.25    1.05
+043 BIN rand string 100b                    1.00    1.09    1.19    1.07    1.67    1.10
+044 BIN rand string 5000b                   1.00    1.10    1.21    1.08    1.66    1.10
+045 BIN rand2 string 100b                   1.00    0.98    1.10    0.99    1.65    1.00
+046 BIN rand2 string 5000b                  1.00    0.98    1.11    0.99    1.62    1.00
+047 BIN u char, 10000b                      1.00    0.98    1.02    1.00    1.08    1.05
+048 CATCH error, complex                    1.00    0.93    1.07    0.93    1.38    1.06
+049 CATCH no catch used                     1.00    1.09    1.25    1.10    1.93    1.37
+050 CATCH return error                      1.00    0.94    1.06    0.94    1.42    1.10
+051 CATCH return except                     1.00    1.12    1.26    1.12    1.88    1.40
+052 CATCH return ok                         1.00    1.10    1.29    1.10    1.94    1.33
+053 DATA access in a list                   1.00    1.01    1.06    1.06    1.06    1.04
+054 DATA access in an array                 1.00    0.97    0.99    1.00    1.09    1.07
+055 DATA create in a list                   1.00    0.87    0.96    0.93    1.10    0.90
+056 DATA create in an array                 1.00    0.89    0.92    0.88    1.23    1.09
+057 ENC iso2022-jp, gets                    1.00    1.03    1.08    1.02    1.21    0.99
+058 ENC iso2022-jp, read                    1.00    1.03    1.09    1.02    1.20    1.01
+059 ENC iso2022-jp, read & size             1.00    1.02    1.11    1.02    1.20    1.01
+060 ENC iso8859-2, gets                     1.00    0.95    1.02    0.97    1.21    1.07
+061 ENC iso8859-2, read                     1.00    0.99    1.03    1.00    1.12    1.08
+062 ENC iso8859-2, read & size              1.00    1.00    1.04    1.01    1.18    1.11
+063 EVAL cmd and mixed lists                1.00    1.03    1.08    1.02    1.51    1.25
+064 EVAL cmd eval as list                   1.00    1.00    1.15    1.04    1.93    1.18
+065 EVAL cmd eval as string                 1.00    0.98    1.09    1.01    1.55    1.25
+066 EVAL cmd eval in list obj var           1.00    1.07    1.22    1.11    2.07    1.18
+067 EVAL cmd eval in list obj {*}           1.00    1.02    1.14    1.03    1.88    1.16
+068 EVAL list cmd and mixed lists           1.00    1.05    1.11    1.05    1.47    1.25
+069 EVAL list cmd and pure lists            1.00    2.44    2.38    2.45    2.42    1.19
+070 EXPR $a != $b dbl                       1.00    1.11    1.27    1.09    2.00    1.47
+071 EXPR $a != $b int                       1.00    1.13    1.28    1.13    2.13    1.43
+072 EXPR $a != $b str (!= len)              1.00    1.00    1.14    1.06    1.54    1.14
+073 EXPR $a != $b str (== len)              1.00    0.98    1.12    1.03    1.47    1.11
+074 EXPR $a == $b dbl                       1.00    1.09    1.23    1.05    1.91    1.43
+075 EXPR $a == $b int                       1.00    1.10    1.25    1.10    2.12    1.44
+076 EXPR $a == $b str (!= len)              1.00    1.00    1.12    1.06    1.56    1.12
+077 EXPR $a == $b str (== len)              1.00    0.96    1.09    1.00    1.43    1.07
+078 EXPR abs as expr                        1.00    1.02    1.27    1.00    1.98    1.54
+079 EXPR abs builtin                        1.00    1.07    1.30    1.05    2.09    1.46
+080 EXPR braced                             1.00    1.09    1.18    1.00    1.65    1.17
+081 EXPR builtin dyn                        1.00    0.96    1.00    0.96    1.62    1.26
+082 EXPR builtin sin                        1.00    1.06    1.27    1.03    2.08    1.30
+083 EXPR cast double                        1.00    1.07    1.35    1.07    2.23    1.32
+084 EXPR cast int                           1.00    1.00    1.26    1.04    2.07    1.28
+085 EXPR fifty operands                     1.00    1.07    1.12    1.03    1.36    1.15
+086 EXPR incr with expr                     1.00    1.14    1.38    1.08    2.32    1.49
+087 EXPR incr with incr                     1.00    1.08    1.36    1.06    2.36    1.44
+088 EXPR inline                             1.00    1.05    1.16    1.08    1.24    1.03
+089 EXPR one operand                        1.00    1.11    1.36    1.14    2.42    1.47
+090 EXPR rand range                         1.00    1.03    1.22    1.04    1.99    1.26
+091 EXPR rand range func                    1.00    1.06    1.31    1.07    2.14    1.33
+092 EXPR ten operands                       1.00    1.09    1.25    1.05    1.85    1.31
+093 EXPR unbraced                           1.00    0.97    1.01    0.97    1.57    1.29
+094 EXPR unbraced long                      1.00    0.96    1.02    0.93    1.33    1.14
+095 EXPR UpdStrOfDbl+1.23 prec0             1.00    0.99    1.16    1.00    1.68    1.28
+096 EXPR UpdStrOfDbl+1.23 prec12            1.00    1.01    1.22    1.05    1.75    1.28
+097 EXPR UpdStrOfDbl+1.23 prec17            1.00    0.99    1.12    1.01    1.43    1.18
+098 EXPR UpdStrOfDbl+1e-4 prec0             1.00    1.01    1.17    1.01    1.57    1.23
+099 EXPR UpdStrOfDbl+1e-4 prec12            1.00    0.99    1.20    1.06    1.73    1.26
+100 EXPR UpdStrOfDbl+1e-4 prec17            1.00    0.99    1.12    1.02    1.47    1.17
+101 EXPR UpdStrOfDbl+1e27 prec0             1.00    0.96    1.14    0.96    1.51    1.29
+102 EXPR UpdStrOfDbl+1e27 prec12            1.00    0.99    1.25    1.00    1.65    1.37
+103 EXPR UpdStrOfDbl+1e27 prec17            1.00    0.94    1.10    0.93    1.43    1.21
+104 FCOPY binary: 160K                      1.00    1.00    0.97    0.99    0.97    1.00
+105 FCOPY encoding: 160K                    1.00    0.97    1.03    0.96    0.96    0.93
+106 FCOPY std: 160K                         1.00    0.99    0.96    0.98    0.97    0.99
+107 FILE exec interp                        1.00    0.96    1.01    0.99    1.08    1.05
+108 FILE exec interp: pkg require           1.00    1.00    1.00    0.99    1.12    1.06
+109 FILE exists tmpfile (obj)               1.00    1.04    1.09    1.07    1.24    1.04
+110 FILE exists ~                           1.00    1.03    1.06    1.03    1.26    1.12
+111 FILE exists! tmpfile (obj)              1.00    1.01    1.09    1.02    1.25    1.02
+112 FILE exists! tmpfile (str)              1.00    0.94    0.97    0.96    1.14    0.99
+113 FILE glob  tmpdir (60 entries)          1.00    0.93    1.00    0.97    1.23    1.11
+114 FILE glob / all subcommands             1.00    1.00    1.03    1.00    1.13    1.03
+115 FILE glob / atime                       1.00    0.95    0.99    0.96    1.13    1.06
+116 FILE glob / attributes                  1.00    1.00    1.01    1.00    1.05    1.03
+117 FILE glob / dirname                     1.00    1.00    1.06    0.99    1.44    1.12
+118 FILE glob / executable                  1.00    0.95    1.00    0.96    1.13    1.05
+119 FILE glob / exists                      1.00    0.95    0.99    0.97    1.14    1.04
+120 FILE glob / extension                   1.00    0.99    1.06    0.99    1.42    1.09
+121 FILE glob / isdirectory                 1.00    0.93    0.98    0.97    1.13    1.04
+122 FILE glob / isfile                      1.00    0.94    0.99    0.96    1.13    1.04
+123 FILE glob / mtime                       1.00    0.94    0.99    0.97    1.13    1.05
+124 FILE glob / owned                       1.00    0.93    0.97    0.95    1.13    1.04
+125 FILE glob / readable                    1.00    0.94    0.98    0.97    1.13    1.04
+126 FILE glob / rootname                    1.00    1.02    1.10    0.98    1.43    1.11
+127 FILE glob / size                        1.00    0.94    0.98    0.97    1.14    1.04
+128 FILE glob / tail                        1.00    1.00    1.07    1.00    1.43    1.11
+129 FILE glob / writable                    1.00    0.95    0.99    0.95    1.14    1.04
+130 FILE recurse / -dir                     1.00    0.95    1.01    0.97    1.24    1.09
+131 FILE recurse / cd                       1.00    0.94    1.00    0.97    1.23    1.06
+132 FORMAT gen                              1.00    0.93    1.04    0.93    1.66    1.19
+133 GCCont_cpb::cGCC 50                     1.00    0.93    1.01    0.95    1.20    0.98
+134 GCCont_cpb::cGCC 500                    1.00    0.93    0.99    0.93    1.16    0.91
+135 GCCont_cpb::cGCC 5000                   1.00    0.95    1.00    0.94    1.15    0.93
+136 GCCont_cpbre1::cGCC 50                  1.00    0.97    1.02    0.98    1.13    1.01
+137 GCCont_cpbre1::cGCC 500                 1.00    0.97    1.01    0.97    1.02    1.00
+138 GCCont_cpbre1::cGCC 5000                1.00    0.97    1.01    0.97    1.01    0.99
+139 GCCont_cpbre2::cGCC 50                  1.00    0.97    1.02    0.97    1.09    1.01
+140 GCCont_cpbre2::cGCC 500                 1.00    0.97    1.02    0.98    1.02    1.00
+141 GCCont_cpbre2::cGCC 5000                1.00    0.97    1.02    0.98    1.02    1.01
+142 GCCont_cpbrs2::cGCC 50                  1.00    0.96    1.07    1.01    1.33    1.07
+143 GCCont_cpbrs2::cGCC 500                 1.00    1.01    1.02    1.03    1.17    1.06
+144 GCCont_cpbrs2::cGCC 5000                1.00    0.99    1.01    1.04    1.09    1.02
+145 GCCont_cpbrs::cGCC1 50                  1.00    0.94    0.97    0.99    1.28    0.99
+146 GCCont_cpbrs::cGCC1 500                 1.00    0.99    0.99    1.01    1.14    1.01
+147 GCCont_cpbrs::cGCC1 5000                1.00    0.99    1.00    1.02    1.02    0.99
+148 GCCont_cpbrs::cGCC2 50                  1.00    0.92    0.96    0.96    1.29    0.98
+149 GCCont_cpbrs::cGCC2 500                 1.00    0.98    0.99    1.01    1.17    1.01
+150 GCCont_cpbrs::cGCC2 5000                1.00    1.00    1.00    1.02    1.05    0.99
+151 GCCont_cpbrs_trap::cGCC 50              1.00    0.96    1.01    0.97    1.09    1.00
+152 GCCont_cpbrs_trap::cGCC 500             1.00    0.97    1.01    0.98    1.03    1.00
+153 GCCont_cpbrs_trap::cGCC 5000            1.00    0.96    1.02    0.98    1.02    1.00
+154 GCCont_expr::cGCC 50                    1.00    0.97    1.04    0.97    1.38    1.15
+155 GCCont_expr::cGCC 500                   1.00    0.98    1.04    0.99    1.29    1.11
+156 GCCont_expr::cGCC 5000                  1.00    0.95    1.00    0.94    1.32    1.07
+157 GCCont_i::cGCC1 50                      1.00    0.96    1.02    0.96    1.16    1.02
+158 GCCont_i::cGCC1 500                     1.00    1.00    1.03    0.99    1.13    0.98
+159 GCCont_i::cGCC1 5000                    1.00    0.99    1.03    0.98    1.12    0.99
+160 GCCont_i::cGCC2 50                      1.00    0.99    1.04    0.98    1.21    1.01
+161 GCCont_i::cGCC2 500                     1.00    1.00    1.03    0.99    1.17    0.95
+162 GCCont_i::cGCC2 5000                    1.00    1.02    1.05    0.99    1.14    0.97
+163 GCCont_i::cGCC3 50                      1.00    0.95    1.04    0.98    1.26    1.04
+164 GCCont_i::cGCC3 500                     1.00    0.96    1.03    1.00    1.18    0.98
+165 GCCont_i::cGCC3 5000                    1.00    0.97    1.03    0.99    1.18    0.99
+166 GCCont_r1::cGCC 50                      1.00    1.01    1.06    0.96    1.22    1.02
+167 GCCont_r1::cGCC 500                     1.00    0.99    1.01    0.96    1.15    0.98
+168 GCCont_r1::cGCC 5000                    1.00    1.02    1.03    0.94    1.15    0.99
+169 GCCont_r2::cGCC 50                      1.00    0.97    1.01    0.96    1.23    1.01
+170 GCCont_r2::cGCC 500                     1.00    0.99    1.02    1.00    1.17    0.96
+171 GCCont_r2::cGCC 5000                    1.00    0.99    1.02    0.97    1.18    1.00
+172 GCCont_r3::cGCC 50                      1.00    0.98    1.04    0.98    1.24    1.03
+173 GCCont_r3::cGCC 500                     1.00    0.98    1.03    0.98    1.19    0.97
+174 GCCont_r3::cGCC 5000                    1.00    0.98    1.01    0.95    1.18    0.99
+175 GCCont_rsf1::cGCC 50                    1.00    0.96    1.04    0.99    1.19    1.02
+176 GCCont_rsf1::cGCC 500                   1.00    0.97    1.03    1.00    1.14    0.99
+177 GCCont_rsf1::cGCC 5000                  1.00    0.99    1.04    1.00    1.13    1.00
+178 GCCont_rsf2::cGCC1 50                   1.00    0.98    1.05    0.99    1.23    1.05
+179 GCCont_rsf2::cGCC1 500                  1.00    0.98    1.03    1.00    1.16    1.01
+180 GCCont_rsf2::cGCC1 5000                 1.00    0.97    1.03    1.01    1.12    1.00
+181 GCCont_rsf2::cGCC2 50                   1.00    0.96    1.04    0.99    1.26    1.06
+182 GCCont_rsf2::cGCC2 500                  1.00    0.96    1.02    0.98    1.15    1.00
+183 GCCont_rsf2::cGCC2 5000                 1.00    0.96    1.01    0.99    1.13    0.99
+184 GCCont_rsf3::cGCC 50                    1.00    0.98    1.05    1.00    1.27    1.05
+185 GCCont_rsf3::cGCC 500                   1.00    0.96    1.03    1.00    1.18    1.01
+186 GCCont_rsf3::cGCC 5000                  1.00    0.96    1.02    0.98    1.11    1.00
+187 GCCont_turing::cGCC 50                  1.00    1.01    1.06    0.98    1.28    1.13
+188 GCCont_turing::cGCC 500                 1.00    1.00    1.02    0.98    1.07    1.01
+189 GCCont_turing::cGCC 5000                1.00    1.01    1.02    1.01    1.04    0.99
+190 HEAPSORT size 10                        1.00    0.97    1.02    0.98    1.13    1.05
+191 HEAPSORT size 50                        1.00    0.97    1.00    0.96    1.10    1.04
+192 HEAPSORT size 100                       1.00    0.97    1.00    0.98    1.12    1.05
+193 HEAPSORT2 size 10                       1.00    1.04    1.04    1.01    1.11    0.99
+194 HEAPSORT2 size 50                       1.00    1.04    1.03    1.02    1.08    1.00
+195 HEAPSORT2 size 100                      1.00    1.03    1.03    1.02    1.08    0.99
+196 IF 1/0 check                            1.00    1.05    1.31    1.10    2.14    1.38
+197 IF else true al                         1.00    0.99    1.09    1.00    1.51    1.12
+198 IF else true numeric                    1.00    1.11    1.24    1.10    1.78    1.33
+199 IF elseif true al                       1.00    1.00    1.06    0.98    1.48    1.14
+200 IF elseif true numeric                  1.00    1.10    1.22    1.10    1.81    1.40
+201 IF if false al/al                       1.00    1.01    1.14    1.00    1.65    1.17
+202 IF if false al/num                      1.00    1.01    1.13    1.00    1.65    1.29
+203 IF if false num/num                     1.00    1.09    1.26    1.09    2.00    1.44
+204 IF if true al                           1.00    1.04    1.13    1.03    1.75    1.25
+205 IF if true al/al                        1.00    1.09    1.22    1.06    1.78    1.29
+206 IF if true num/num                      1.00    1.11    1.30    1.11    1.94    1.45
+207 IF if true numeric                      1.00    1.09    1.23    1.08    1.92    1.42
+208 IF multi 1st true                       1.00    1.04    1.18    1.09    1.82    1.34
+209 IF multi 2nd true                       1.00    1.03    1.18    1.08    1.75    1.31
+210 IF multi 9th true                       1.00    1.07    1.16    1.07    1.49    1.20
+211 IF multi default true                   1.00    1.06    1.15    1.05    1.53    1.21
+212 KLIST shuffle0 llength 1                1.00    0.94    1.01    0.96    1.41    1.03
+213 KLIST shuffle0 llength 10               1.00    0.95    1.01    0.95    1.30    1.01
+214 KLIST shuffle0 llength 100              1.00    0.99    1.06    0.97    1.26    1.01
+215 KLIST shuffle0 llength 1000             1.00    0.98    1.04    0.97    1.27    1.00
+216 KLIST shuffle0 llength 10000            1.00    0.99    1.02    0.95    1.22    0.98
+217 KLIST shuffle1-s llength 1              1.00    1.00    1.12    1.01    1.70    1.16
+218 KLIST shuffle1-s llength 10             1.00    1.00    1.13    1.00    1.61    1.16
+219 KLIST shuffle1-s llength 100            1.00    0.98    1.10    0.99    1.64    1.22
+220 KLIST shuffle1-s llength 1000           1.00    1.34    1.39    1.35    1.85    1.37
+221 KLIST shuffle1a llength 1               1.00    1.05    1.16    1.03    1.77    1.23
+222 KLIST shuffle1a llength 10              1.00    1.05    1.18    1.05    1.79    1.27
+223 KLIST shuffle1a llength 100             1.00    1.06    1.18    1.06    1.80    1.25
+224 KLIST shuffle1a llength 1000            1.00    1.05    1.18    1.05    1.80    1.26
+225 KLIST shuffle1a llength 10000           1.00    1.06    1.18    1.06    1.81    1.29
+226 KLIST shuffle2 llength 1                1.00    0.98    1.10    1.03    1.51    1.20
+227 KLIST shuffle2 llength 10               1.00    1.00    1.11    1.01    1.44    1.16
+228 KLIST shuffle2 llength 100              1.00    0.99    1.09    1.01    1.41    1.16
+229 KLIST shuffle2 llength 1000             1.00    1.01    1.10    1.02    1.40    1.16
+230 KLIST shuffle2 llength 10000            1.00    0.99    1.06    1.00    1.26    1.04
+231 KLIST shuffle3 llength 1                1.00    1.01    1.16    1.02    1.76    1.24
+232 KLIST shuffle3 llength 10               1.00    1.05    1.19    1.05    1.75    1.24
+233 KLIST shuffle3 llength 100              1.00    1.05    1.19    1.05    1.79    1.23
+234 KLIST shuffle3 llength 1000             1.00    1.05    1.16    1.04    1.70    1.22
+235 KLIST shuffle3 llength 10000            1.00    1.02    1.09    1.03    1.39    1.15
+236 KLIST shuffle4 llength 1                1.00    1.01    1.15    1.04    1.71    1.23
+237 KLIST shuffle4 llength 10               1.00    1.03    1.16    1.03    1.71    1.22
+238 KLIST shuffle4 llength 100              1.00    1.03    1.16    1.03    1.74    1.23
+239 KLIST shuffle4 llength 1000             1.00    1.05    1.17    1.04    1.74    1.23
+240 KLIST shuffle4 llength 10000            1.00    1.04    1.17    1.03    1.74    1.22
+241 KLIST shuffle5-s llength 1              1.00    0.99    1.11    1.01    1.70    1.15
+242 KLIST shuffle5-s llength 10             1.00    1.00    1.12    1.02    1.65    1.18
+243 KLIST shuffle5-s llength 100            1.00    1.00    1.10    1.01    1.66    1.19
+244 KLIST shuffle5-s llength 1000           1.00    1.05    1.10    1.05    1.55    1.20
+245 KLIST shuffle5a llength 1               1.00    1.01    1.14    1.01    1.77    1.19
+246 KLIST shuffle5a llength 10              1.00    1.04    1.18    1.06    1.79    1.24
+247 KLIST shuffle5a llength 100             1.00    1.05    1.18    1.06    1.80    1.27
+248 KLIST shuffle5a llength 1000            1.00    1.02    1.16    1.04    1.73    1.24
+249 KLIST shuffle5a llength 10000           1.00    1.04    1.09    1.04    1.43    1.12
+250 KLIST shuffle6 llength 1                1.00    1.02    1.24    1.15    1.93    1.39
+251 KLIST shuffle6 llength 10               1.00    1.00    1.06    0.99    1.41    1.04
+252 KLIST shuffle6 llength 100              1.00    1.02    1.05    1.01    1.41    1.04
+253 KLIST shuffle6 llength 1000             1.00    1.02    1.08    1.02    1.40    1.04
+254 KLIST shuffle6 llength 10000            1.00    1.05    1.09    1.03    1.43    1.05
+255 LIST append to list                     1.00    1.00    1.24    0.98    2.06    1.38
+256 LIST concat APPEND 2x10                 1.00    0.88    0.99    0.89    1.47    1.14
+257 LIST concat APPEND 2x100                1.00    0.89    0.98    0.88    1.79    1.25
+258 LIST concat APPEND 2x1000               1.00    0.91    1.00    0.91    1.65    1.20
+259 LIST concat APPEND 2x10000              1.00    0.95    1.04    0.95    1.67    1.20
+260 LIST concat CONCAT 2x10                 1.00    1.00    1.13    1.05    1.63    1.20
+261 LIST concat CONCAT 2x100                1.00    1.01    1.09    1.03    1.57    1.19
+262 LIST concat CONCAT 2x1000               1.00    0.98    1.01    0.99    1.10    1.03
+263 LIST concat CONCAT 2x10000              1.00    1.02    0.94    1.02    1.01    1.06
+264 LIST concat EVAL/LAPPEND 2x10           1.00    1.03    1.18    1.06    1.68    1.22
+265 LIST concat EVAL/LAPPEND 2x100          1.00    1.00    1.09    1.01    1.61    1.19
+266 LIST concat EVAL/LAPPEND 2x1000         1.00    0.88    0.90    0.90    0.99    0.94
+267 LIST concat EVAL/LAPPEND 2x10000        1.00    0.94    0.96    0.94    0.95    1.01
+268 LIST concat FOREACH/LAPPEND 2x10        1.00    0.99    1.09    0.99    1.35    1.12
+269 LIST concat FOREACH/LAPPEND 2x100       1.00    1.01    1.08    0.97    1.17    1.07
+270 LIST concat FOREACH/LAPPEND 2x1000      1.00    1.05    1.09    0.98    1.13    1.03
+271 LIST concat FOREACH/LAPPEND 2x10000     1.00    1.05    1.06    0.96    1.11    1.05
+272 LIST concat SET 2x10                    1.00    0.89    1.00    0.89    1.48    1.19
+273 LIST concat SET 2x100                   1.00    0.90    1.02    0.90    1.84    1.31
+274 LIST concat SET 2x1000                  1.00    0.90    0.99    0.89    1.69    1.22
+275 LIST concat SET 2x10000                 1.00    0.95    1.04    0.95    1.71    1.23
+276 LIST exact search, first item           1.00    1.09    1.20    1.11    1.92    1.23
+277 LIST exact search, last item            1.00    0.99    1.04    1.01    1.28    1.06
+278 LIST exact search, middle item          1.00    1.02    1.10    1.05    1.60    1.15
+279 LIST exact search, non-item             1.00    1.02    1.02    1.04    1.13    1.04
+280 LIST exact search, typed item           1.00    1.00    1.05    1.03    1.33    1.05
+281 LIST exact search, untyped item         1.00    1.00    1.05    1.00    1.30    1.08
+282 LIST index first element                1.00    1.00    1.20    1.04    1.86    1.33
+283 LIST index last element                 1.00    1.00    1.20    1.04    1.92    1.24
+284 LIST index middle element               1.00    0.98    1.20    1.02    1.88    1.27
+285 LIST insert an item at "end"            1.00    1.64    1.70    1.61    1.90    1.11
+286 LIST insert an item at middle           1.00    1.63    1.69    1.60    1.87    1.12
+287 LIST insert an item at start            1.00    1.69    1.75    1.65    1.97    1.16
+288 LIST iterate list                       1.00    1.00    1.03    0.99    1.16    0.89
+289 LIST join list                          1.00    0.99    1.00    0.99    1.01    1.01
+290 LIST large, early range                 1.00    0.95    1.09    0.99    1.67    1.19
+291 LIST large, late range                  1.00    1.00    1.12    1.01    1.66    1.20
+292 LIST length, pure list                  1.00    0.96    1.19    1.04    1.88    1.40
+293 LIST list                               1.00    0.98    1.04    0.97    1.35    1.06
+294 LIST lset foreach  l                    1.00    0.81    0.84    0.90    1.33    1.13
+295 LIST lset foreach  list                 1.00    0.88    0.87    0.90    1.37    1.14
+296 LIST lset foreach ""s l                 1.00    1.03    1.04    0.98    1.16    1.01
+297 LIST lset foreach ""s list              1.00    1.04    1.06    1.00    1.17    1.00
+298 LIST regexp search, first item          1.00    1.06    1.19    1.12    1.87    1.20
+299 LIST regexp search, last item           1.00    1.00    1.01    1.01    1.05    1.01
+300 LIST regexp search, non-item            1.00    1.04    1.01    1.03    1.05    1.02
+301 LIST remove first element               1.00    1.64    1.71    1.61    2.06    1.15
+302 LIST remove in mixed list               1.00    1.44    1.44    1.48    2.00    1.08
+303 LIST remove last element                1.00    1.68    1.73    1.64    2.10    1.15
+304 LIST remove middle element              1.00    1.64    1.69    1.60    2.05    1.13
+305 LIST replace first el with multiple     1.00    1.74    1.69    1.58    2.02    1.15
+306 LIST replace first element              1.00    1.69    1.72    1.65    2.03    1.13
+307 LIST replace in mixed list              1.00    1.47    1.48    1.49    2.01    0.99
+308 LIST replace last el with multiple      1.00    1.76    1.70    1.56    2.13    1.15
+309 LIST replace last element               1.00    1.73    1.71    1.56    2.09    1.13
+310 LIST replace middle el with multiple    1.00    1.69    1.67    1.54    2.01    1.13
+311 LIST replace middle element             1.00    1.74    1.76    1.69    2.09    1.14
+312 LIST replace range                      1.00    0.98    1.06    0.97    1.56    1.24
+313 LIST reverse core                       1.00    1.27    1.33    1.19    1.41    1.06
+314 LIST reverse lappend                    1.00    1.08    1.13    1.05    1.04    1.09
+315 LIST small, early range                 1.00    1.00    1.17    1.03    1.72    1.26
+316 LIST small, late range                  1.00    0.99    1.17    1.03    1.72    1.19
+317 LIST sort                               1.00    1.07    1.07    1.07    1.08    1.01
+318 LIST sorted search, first item          1.00    0.99    1.13    1.06    1.71    1.25
+319 LIST sorted search, last item           1.00    0.99    1.13    1.03    1.74    1.17
+320 LIST sorted search, middle item         1.00    1.01    1.13    1.04    1.75    1.18
+321 LIST sorted search, non-item            1.00    1.03    1.15    1.07    1.77    1.21
+322 LIST sorted search, typed item          1.00    1.03    1.21    1.13    1.82    1.19
+323 LIST typed sort                         1.00    1.08    1.07    1.07    1.08    1.06
+324 LOOP for (to 1000)                      1.00    1.03    1.04    1.13    1.05    1.04
+325 LOOP for, iterate list                  1.00    0.99    1.07    1.12    1.06    1.08
+326 LOOP for, iterate string                1.00    0.94    1.01    0.97    1.25    1.03
+327 LOOP foreach, iterate list              1.00    0.94    0.98    0.95    1.14    0.92
+328 LOOP foreach, iterate string            1.00    0.96    1.04    0.98    1.19    1.02
+329 LOOP while (to 1000)                    1.00    1.07    1.05    1.15    1.08    1.05
+330 LOOP while 1 (to 1000)                  1.00    0.98    1.00    1.03    0.91    0.90
+331 MAP ([chars])-case regsub               1.00    0.96    1.00    0.96    1.06    1.01
+332 MAP http mapReply                       1.00    0.98    0.98    0.97    1.02    1.00
+333 MAP regsub -nocase, no match            1.00    1.03    1.00    1.01    1.02    1.00
+334 MAP regsub 1 val                        1.00    1.00    1.02    1.04    0.98    0.95
+335 MAP regsub 1 val -nocase                1.00    1.02    1.03    1.01    0.99    0.98
+336 MAP regsub 2 val                        1.00    1.04    1.08    1.08    1.04    0.97
+337 MAP regsub 2 val -nocase                1.00    1.03    1.04    1.02    1.00    0.99
+338 MAP regsub 3 val                        1.00    1.05    1.07    1.07    1.06    0.98
+339 MAP regsub 3 val -nocase                1.00    1.03    1.04    1.03    1.00    0.98
+340 MAP regsub 4 val                        1.00    1.02    1.04    1.04    1.06    0.97
+341 MAP regsub 4 val -nocase                1.00    1.02    1.02    1.03    1.02    0.99
+342 MAP regsub short                        1.00    1.00    1.07    1.03    1.53    1.24
+343 MAP regsub, no match                    1.00    1.02    1.02    1.01    1.05    1.03
+344 MAP string -nocase, no match            1.00    1.02    1.05    1.00    1.05    1.02
+345 MAP string 1 val                        1.00    0.99    1.00    1.00    0.98    0.93
+346 MAP string 1 val -nocase                1.00    1.02    1.01    1.02    1.03    1.01
+347 MAP string 2 val                        1.00    1.01    1.14    1.03    1.03    0.99
+348 MAP string 2 val -nocase                1.00    0.93    0.95    0.92    1.00    0.92
+349 MAP string 3 val                        1.00    1.01    1.02    1.04    1.04    0.98
+350 MAP string 3 val -nocase                1.00    0.97    0.97    0.95    1.02    0.97
+351 MAP string 4 val                        1.00    1.00    1.03    1.07    1.07    0.96
+352 MAP string 4 val -nocase                1.00    0.96    0.97    0.97    1.03    0.96
+353 MAP string short                        1.00    1.01    1.15    1.02    1.60    1.21
+354 MAP string, no match                    1.00    1.00    1.03    1.00    1.02    1.00
+355 MAP |-case regsub                       1.00    0.94    1.03    0.95    1.08    1.02
+356 MAP |-case strmap                       1.00    1.02    1.20    1.04    1.65    1.29
+357 MATRIX mult 5x5                         1.00    0.94    0.98    0.90    1.26    0.99
+358 MATRIX mult 10x10                       1.00    0.95    1.00    0.91    1.29    0.99
+359 MATRIX mult 15x15                       1.00    0.95    1.00    0.91    1.31    0.98
+360 MATRIX transposition-0                  1.00    0.96    0.96    0.95    1.10    1.06
+361 MATRIX transposition-1                  1.00    1.00    1.06    0.98    1.06    1.05
+362 MD5 msg len 10                          1.00    0.98    1.07    0.99    1.64    1.11
+363 MD5 msg len 100                         1.00    0.99    1.08    0.99    1.66    1.11
+364 MD5 msg len 1000                        1.00    0.98    1.07    0.98    1.62    1.15
+365 MD5 msg len 10000                       1.00    0.91    1.02    0.90    1.41    1.20
+366 MTHD array stored proc call             1.00    1.04    1.23    1.09    2.00    1.39
+367 MTHD call absolute                      1.00    1.10    1.38    1.09    2.30    1.44
+368 MTHD call relative                      1.00    1.06    1.33    1.06    2.08    1.35
+369 MTHD direct ns proc call                1.00    1.14    1.36    1.11    2.42    1.44
+370 MTHD imported ns proc call              1.00    1.07    1.33    1.07    2.45    1.45
+371 MTHD indirect proc eval                 1.00    1.03    1.23    1.03    2.05    1.26
+372 MTHD indirect proc eval #2              1.00    1.10    1.31    1.09    2.19    1.33
+373 MTHD inline call                        1.00    1.12    1.19    1.06    1.69    1.25
+374 MTHD interp alias proc call             1.00    1.13    1.34    1.20    2.28    1.44
+375 MTHD ns lookup call                     1.00    0.95    1.08    0.96    1.54    1.08
+376 MTHD switch method call                 1.00    1.04    1.22    1.03    1.98    1.23
+377 NS alternating                          1.00    0.89    1.08    0.90    1.54    1.19
+378 PARSE html form upload (7978)           1.00    0.97    1.07    1.02    1.37    0.99
+379 PARSE html form upload (993570)         1.00    0.99    1.09    1.04    1.38    1.00
+380 PROC do-nothing, no args                1.00    1.09    1.30    1.09    2.27    1.45
+381 PROC do-nothing, one arg                1.00    1.11    1.34    1.11    2.31    1.49
+382 PROC empty, no args                     1.00    1.22    1.33    1.22    2.44    1.44
+383 PROC empty, use args                    1.00    1.22    1.33    1.22    2.11    1.44
+384 PROC explicit return                    1.00    1.12    1.35    1.12    2.41    1.50
+385 PROC explicit return (2)                1.00    1.15    1.32    1.12    2.35    1.53
+386 PROC explicit return (3)                1.00    1.15    1.35    1.15    2.41    1.50
+387 PROC heavily commented                  1.00    1.11    1.31    1.11    2.29    1.60
+388 PROC implicit return                    1.00    1.11    1.30    1.08    2.30    1.46
+389 PROC implicit return (2)                1.00    1.14    1.31    1.11    2.37    1.49
+390 PROC implicit return (3)                1.00    1.15    1.35    1.15    2.35    1.62
+391 PROC local links with global            1.00    1.05    1.03    1.00    1.07    1.04
+392 PROC local links with upvar             1.00    1.05    1.03    1.00    1.06    1.04
+393 PROC local links with variable          1.00    1.01    1.04    1.00    1.07    1.02
+394 RE 1-char long-end                      1.00    1.00    1.02    1.01    1.08    1.03
+395 RE 1-char long-end catching             1.00    1.00    1.03    1.01    1.10    1.04
+396 RE 1-char long-middle                   1.00    1.01    1.04    1.03    1.14    1.04
+397 RE 1-char long-middle catching          1.00    1.00    1.04    1.02    1.15    1.06
+398 RE 1-char long-start                    1.00    1.03    1.13    1.09    1.46    1.13
+399 RE 1-char long-start catching           1.00    1.00    1.07    1.03    1.27    1.13
+400 RE 1-char short                         1.00    1.03    1.15    1.09    1.48    1.12
+401 RE 1-char short catching                1.00    0.99    1.07    1.02    1.26    1.09
+402 RE basic                                1.00    1.03    1.17    1.09    1.49    1.15
+403 RE basic catching                       1.00    0.99    1.04    1.01    1.22    1.08
+404 RE c-comment long                       1.00    1.00    1.02    1.01    1.11    1.06
+405 RE c-comment long catching              1.00    0.99    1.01    1.00    1.09    1.05
+406 RE c-comment long nomatch               1.00    1.00    1.01    1.00    1.07    1.03
+407 RE c-comment long nomatch catching      1.00    1.00    1.01    1.01    1.08    1.04
+408 RE c-comment long pmatch                1.00    1.00    1.01    1.01    1.06    1.04
+409 RE c-comment long pmatch catching       1.00    1.00    1.01    1.01    1.07    1.04
+410 RE c-comment many *s                    1.00    0.99    1.01    1.00    1.06    1.04
+411 RE c-comment many *s catching           1.00    0.99    1.00    0.99    1.04    1.03
+412 RE c-comment nomatch                    1.00    0.98    1.10    1.02    1.55    1.30
+413 RE c-comment nomatch catching           1.00    0.97    1.08    1.04    1.53    1.27
+414 RE c-comment simple                     1.00    0.97    1.05    0.99    1.31    1.15
+415 RE c-comment simple catching            1.00    0.97    1.01    0.98    1.16    1.09
+416 RE count all matches                    1.00    0.99    1.03    1.00    1.10    1.04
+417 RE extract all matches                  1.00    0.98    1.02    0.98    1.12    1.04
+418 RE ini file                             1.00    1.00    1.00    1.00    1.00    1.00
+419 RE ini file ng                          1.00    1.00    1.01    1.00    1.02    1.01
+420 RE literal regexp                       1.00    0.95    1.09    0.97    1.24    1.02
+421 RE n-char long-end                      1.00    1.00    1.03    1.01    1.08    1.03
+422 RE n-char long-end catching             1.00    0.99    1.02    1.00    1.08    1.02
+423 RE n-char long-middle                   1.00    1.00    1.04    1.02    1.13    1.04
+424 RE n-char long-middle catching          1.00    0.99    1.02    1.00    1.11    1.03
+425 RE n-char long-start                    1.00    1.01    1.12    1.06    1.42    1.12
+426 RE n-char long-start catching           1.00    0.98    1.04    1.01    1.18    1.04
+427 RE n-char short                         1.00    1.02    1.13    1.06    1.43    1.12
+428 RE n-char short catching                1.00    0.99    1.06    1.02    1.21    1.06
+429 RE static anchored match                1.00    1.14    1.33    1.14    2.33    1.47
+430 RE static anchored match dot            1.00    1.13    1.34    1.13    2.32    1.47
+431 RE static anchored nomatch              1.00    1.14    1.36    1.14    2.39    1.50
+432 RE static anchored nomatch dot          1.00    1.14    1.36    1.14    2.39    1.47
+433 RE static l-anchored match              1.00    1.14    1.32    1.14    2.35    1.51
+434 RE static l-anchored nomatch            1.00    1.08    1.30    1.11    2.41    1.46
+435 RE static long match                    1.00    1.12    1.12    1.16    1.39    1.15
+436 RE static long nomatch                  1.00    1.16    1.08    1.18    1.28    1.11
+437 RE static r-anchored match              1.00    1.10    1.31    1.15    2.23    1.44
+438 RE static r-anchored nomatch            1.00    1.15    1.36    1.15    2.28    1.44
+439 RE static short match                   1.00    1.10    1.36    1.10    2.28    1.54
+440 RE static short nomatch                 1.00    1.13    1.37    1.13    2.39    1.58
+441 RE var ***= directive match             1.00    1.11    1.13    1.15    1.47    1.15
+442 RE var ***= directive nomatch           1.00    1.11    1.10    1.13    1.49    1.17
+443 RE var . match                          1.00    1.02    1.16    1.06    1.75    1.22
+444 RE var [0-9] match                      1.00    0.99    1.08    1.03    1.26    1.07
+445 RE var \d match                         1.00    1.00    1.08    1.03    1.26    1.07
+446 RE var ^$ nomatch                       1.00    1.02    1.16    1.03    1.73    1.23
+447 RE var backtrack case                   1.00    1.02    1.08    1.05    1.21    1.07
+448 RE var-based regexp                     1.00    0.94    1.08    0.97    1.22    1.02
+449 READ 595K, cat                          1.00    0.95    0.98    0.96    1.22    0.98
+450 READ 595K, gets                         1.00    0.93    0.95    0.91    1.22    0.97
+451 READ 595K, glob-grep match              1.00    0.95    0.97    0.94    1.20    1.04
+452 READ 595K, glob-grep nomatch            1.00    0.94    0.97    0.94    1.18    1.00
+453 READ 595K, read                         1.00    1.00    1.00    1.00    1.00    0.92
+454 READ 595K, read & size                  1.00    1.00    1.00    1.00    1.00    0.92
+455 READ 595K, read dyn buf                 1.00    1.01    0.98    1.01    1.01    0.93
+456 READ 595K, read small buf               1.00    0.98    0.97    0.98    0.98    1.00
+457 READ 3050b, cat                         1.00    0.96    1.03    0.96    1.21    1.00
+458 READ 3050b, gets                        1.00    0.94    0.97    0.94    1.23    1.01
+459 READ 3050b, glob-grep match             1.00    0.94    0.97    0.93    1.21    1.04
+460 READ 3050b, glob-grep nomatch           1.00    0.94    0.97    0.95    1.18    1.03
+461 READ 3050b, read                        1.00    0.99    0.97    1.00    1.08    1.01
+462 READ 3050b, read & size                 1.00    0.99    0.99    1.00    1.11    1.03
+463 READ 3050b, read dyn buf                1.00    0.99    0.98    1.00    1.08    1.02
+464 READ 3050b, read small buf              1.00    0.97    1.00    1.00    0.98    1.01
+465 READ bin 595K, cat                      1.00    1.06    1.12    0.96    1.42    1.03
+466 READ bin 595K, gets                     1.00    1.04    1.06    0.92    1.36    1.04
+467 READ bin 595K, glob-grep match          1.00    1.10    1.06    0.93    1.34    1.03
+468 READ bin 595K, glob-grep nomatch        1.00    1.18    1.08    0.92    1.36    1.05
+469 READ bin 595K, read                     1.00    0.99    0.99    0.99    0.98    0.98
+470 READ bin 595K, read & size              1.00    1.00    1.00    1.00    0.99    0.99
+471 READ bin 595K, read dyn buf             1.00    1.04    1.06    1.05    1.02    1.00
+472 READ bin 595K, read small buf           1.00    1.01    1.00    1.02    1.01    1.03
+473 READ bin 3050b, cat                     1.00    1.05    1.08    0.96    1.36    1.06
+474 READ bin 3050b, gets                    1.00    1.06    1.09    0.97    1.36    1.10
+475 READ bin 3050b, glob-grep match         1.00    0.99    1.07    0.93    1.33    1.16
+476 READ bin 3050b, glob-grep nomatch       1.00    0.99    1.08    0.94    1.31    1.11
+477 READ bin 3050b, read                    1.00    0.98    1.04    0.99    1.24    1.11
+478 READ bin 3050b, read & size             1.00    0.99    1.06    1.00    1.26    1.12
+479 READ bin 3050b, read dyn buf            1.00    0.99    1.03    0.98    1.22    1.11
+480 READ bin 3050b, read small buf          1.00    0.99    0.98    0.99    0.99    1.01
+481 SHA1 msg len 10                         1.00    0.97    1.04    1.00    1.28    1.02
+482 SHA1 msg len 100                        1.00    0.97    1.04    1.00    1.27    1.01
+483 SHA1 msg len 1000                       1.00    0.96    1.05    1.00    1.24    1.00
+484 SHA1 msg len 10000                      1.00    0.97    1.04    1.01    1.23    0.99
+485 SPLIT iter, 4000 uchars                 1.00    0.97    1.03    0.95    1.17    1.01
+486 SPLIT iter, 4010 chars                  1.00    0.95    1.01    0.94    1.15    0.99
+487 SPLIT iter, rand 100 c                  1.00    0.89    1.01    0.89    1.32    1.10
+488 SPLIT iter, rand 1000 c                 1.00    0.94    1.01    0.93    1.26    1.07
+489 SPLIT iter, rand 10000 c                1.00    0.95    1.02    0.94    1.15    0.99
+490 SPLIT on 'c', 4000 uchars               1.00    0.88    0.99    0.89    1.28    1.03
+491 SPLIT on 'c', 4010 chars                1.00    0.87    0.98    0.88    1.29    0.99
+492 SPLIT on 'cz', 4000 uchars              1.00    0.89    0.98    0.90    1.17    0.99
+493 SPLIT on 'cz', 4010 chars               1.00    0.92    0.99    0.93    1.20    1.01
+494 SPLIT on 'cû', 4000 uchars              1.00    0.91    0.99    0.92    1.22    1.05
+495 SPLIT on 'cû', 4010 chars               1.00    0.91    0.99    0.91    1.21    1.00
+496 SPLIT, 4000 uchars                      1.00    0.99    1.03    0.99    1.05    1.00
+497 SPLIT, 4010 chars                       1.00    1.00    1.05    1.01    1.02    1.02
+498 SPLIT, rand 100 c                       1.00    0.86    0.98    0.86    1.41    1.16
+499 SPLIT, rand 1000 c                      1.00    0.93    1.02    0.93    1.50    1.26
+500 SPLIT, rand 10000 c                     1.00    0.98    1.02    0.99    1.08    1.04
+501 STR append                              1.00    1.00    1.06    1.07    1.25    1.09
+502 STR append (1KB + 1KB)                  1.00    1.00    1.05    1.02    1.58    1.29
+503 STR append (1MB + (1b+1K+1b)*100)       1.00    0.98    0.99    0.99    1.02    0.99
+504 STR append (1MB + 1KB)                  1.00    0.98    0.98    0.98    0.98    0.98
+505 STR append (1MB + 1KB*20)               1.00    0.98    0.98    0.98    0.98    0.98
+506 STR append (1MB + 1KB*1000)             1.00    0.99    1.00    0.98    0.97    0.98
+507 STR append (1MB + 1MB*3)                1.00    1.00    1.00    1.00    0.99    0.99
+508 STR append (1MB + 1MB*5)                1.00    0.99    0.99    0.99    0.99    0.99
+509 STR append (1MB + 2b*1000)              1.00    0.99    1.00    0.99    0.99    0.99
+510 STR append (10KB + 1KB)                 1.00    1.04    1.12    1.10    1.07    1.15
+511 STR first (failure)                     1.00    0.80    1.05    0.81    0.94    1.86
+512 STR first (failure) utf                 1.00    0.81    1.05    0.82    0.95    1.87
+513 STR first (success)                     1.00    1.02    1.21    1.06    1.82    1.23
+514 STR first (success) utf                 1.00    1.03    1.20    1.10    1.79    1.22
+515 STR first (total failure)               1.00    0.75    1.04    0.77    0.92    2.07
+516 STR first (total failure) utf           1.00    0.75    1.04    0.76    0.93    2.11
+517 STR index 0                             1.00    1.02    1.14    1.05    1.72    1.31
+518 STR index 100                           1.00    1.03    1.17    1.06    1.77    1.27
+519 STR index 500                           1.00    1.05    1.19    1.10    1.79    1.29
+520 STR info locals match                   1.00    1.06    1.06    1.05    1.07    1.04
+521 STR last (failure)                      1.00    0.86    1.03    0.87    0.96    0.88
+522 STR last (success)                      1.00    1.04    1.20    1.08    1.76    1.14
+523 STR last (total failure)                1.00    0.84    1.03    0.84    0.94    0.85
+524 STR length (==4010)                     1.00    1.04    1.23    1.11    2.09    1.38
+525 STR length growing (1000)               1.00    1.09    1.08    1.10    1.01    1.07
+526 STR length growing uc (1000)            1.00    1.10    1.12    1.13    1.03    1.04
+527 STR length of a LIST                    1.00    1.02    1.28    1.09    2.04    1.35
+528 STR length static str                   1.00    1.11    1.36    1.17    2.39    1.50
+529 STR match, complex (failure)            1.00    1.15    1.02    1.16    1.06    1.02
+530 STR match, complex (success early)      1.00    1.09    1.30    1.17    1.87    1.39
+531 STR match, complex (success late)       1.00    1.13    0.98    1.14    1.03    1.01
+532 STR match, complex (total failure)      1.00    1.23    1.03    1.25    1.09    1.04
+533 STR match, exact (failure)              1.00    1.14    1.36    1.14    2.47    1.58
+534 STR match, exact (success)              1.00    1.11    1.30    1.11    2.24    1.51
+535 STR match, exact -nocase (failure)      1.00    1.08    1.29    1.11    2.18    1.53
+536 STR match, exact -nocase (success)      1.00    1.08    1.23    1.09    2.00    1.40
+537 STR match, recurse (fail backtrack)     1.00    1.00    1.01    1.00    1.04    1.01
+538 STR match, recurse (fail bt1)           1.00    1.00    1.00    1.01    1.04    1.01
+539 STR match, recurse (fail bt2)           1.00    1.00    0.99    1.01    1.03    1.00
+540 STR match, recurse (fail ranchor)       1.00    1.25    1.00    1.25    1.00    1.00
+541 STR match, recurse (success bt2)        1.00    0.98    1.02    1.01    1.24    1.07
+542 STR match, recurse2 (fail)              1.00    1.16    0.99    1.16    0.99    0.98
+543 STR match, recurse2 (success)           1.00    1.15    1.01    1.16    1.06    1.01
+544 STR match, simple (failure)             1.00    1.13    1.37    1.11    2.34    1.55
+545 STR match, simple (success)             1.00    1.13    1.36    1.10    2.21    1.51
+546 STR range, index 100..200 of 4010       1.00    1.05    1.18    1.09    1.79    1.18
+547 STR repeat, 4010 chars * 10             1.00    1.01    1.05    1.02    1.26    1.03
+548 STR repeat, 4010 chars * 100            1.00    1.00    1.01    1.01    1.05    1.01
+549 STR repeat, abcdefghij * 10             1.00    1.01    1.19    1.02    1.84    1.18
+550 STR repeat, abcdefghij * 100            1.00    1.02    1.13    1.04    1.71    1.16
+551 STR repeat, abcdefghij * 1000           1.00    0.92    1.03    1.02    1.34    1.04
+552 STR replace, equal replacement          1.00    0.90    0.97    0.91    1.56    0.95
+553 STR replace, longer replacement         1.00    1.07    1.13    1.08    1.61    0.98
+554 STR replace, no replacement             1.00    1.13    1.22    1.16    1.46    1.08
+555 STR reverse core, 10 c                  1.00    1.07    1.19    1.09    1.78    1.24
+556 STR reverse core, 10 uc                 1.00    1.06    1.21    1.07    1.78    1.25
+557 STR reverse core, 100 c                 1.00    1.04    1.13    1.05    1.74    1.15
+558 STR reverse core, 100 uc                1.00    1.04    1.13    1.06    1.76    1.16
+559 STR reverse core, 400 c                 1.00    1.03    1.04    1.04    1.78    1.14
+560 STR reverse core, 400 uc                1.00    1.05    1.05    1.05    1.83    1.13
+561 STR reverse iter/append, 10 c           1.00    0.92    1.04    0.95    1.37    1.13
+562 STR reverse iter/append, 10 uc          1.00    0.89    1.01    0.95    1.32    1.10
+563 STR reverse iter/append, 100 c          1.00    0.86    0.99    0.92    1.20    1.03
+564 STR reverse iter/append, 100 uc         1.00    0.86    1.00    0.92    1.21    1.03
+565 STR reverse iter/append, 400 c          1.00    0.86    0.97    0.88    1.18    1.00
+566 STR reverse iter/append, 400 uc         1.00    0.86    1.01    0.89    1.20    1.00
+567 STR reverse iter/set, 10 c              1.00    0.91    1.04    0.95    1.41    1.10
+568 STR reverse iter/set, 10 uc             1.00    0.90    1.02    0.94    1.39    1.09
+569 STR reverse iter/set, 100 c             1.00    0.85    0.98    0.90    1.31    1.04
+570 STR reverse iter/set, 100 uc            1.00    0.86    0.98    0.90    1.31    1.04
+571 STR reverse iter/set, 400 c             1.00    0.87    0.98    0.90    1.37    1.06
+572 STR reverse iter/set, 400 uc            1.00    0.87    0.99    0.90    1.40    1.08
+573 STR reverse recursive, 10 c             1.00    0.97    1.16    1.04    1.69    1.19
+574 STR reverse recursive, 10 uc            1.00    0.96    1.15    1.04    1.70    1.18
+575 STR reverse recursive, 100 c            1.00    1.02    1.20    1.07    1.71    1.21
+576 STR reverse recursive, 100 uc           1.00    1.02    1.21    1.07    1.71    1.22
+577 STR reverse recursive, 400 c            1.00    1.07    1.23    1.11    1.65    1.21
+578 STR reverse recursive, 400 uc           1.00    1.07    1.24    1.12    1.65    1.21
+579 STR str $a eq $b                        1.00    1.07    1.15    1.06    1.65    1.27
+580 STR str $a eq $b (same obj)             1.00    1.07    1.14    1.10    1.58    1.30
+581 STR str $a equal ""                     1.00    1.06    1.16    1.06    1.84    1.26
+582 STR str $a ne $b                        1.00    1.06    1.12    1.07    1.58    1.16
+583 STR str $a ne $b (same obj)             1.00    1.02    1.11    1.02    1.58    1.22
+584 STR str num == ""                       1.00    1.10    1.19    1.10    1.84    1.32
+585 STR strcmp bin long eq                  1.00    0.97    1.03    0.97    1.34    1.08
+586 STR strcmp bin long neq                 1.00    0.97    1.02    0.98    1.33    1.10
+587 STR strcmp bin long neqS                1.00    1.01    1.12    1.03    1.66    1.23
+588 STR strcmp bin short eq                 1.00    0.97    1.09    0.98    1.73    1.16
+589 STR streq bin long eq                   1.00    0.96    1.02    0.97    1.34    1.09
+590 STR streq bin long neq                  1.00    0.97    1.02    0.99    1.32    1.10
+591 STR streq bin long neqS                 1.00    0.96    1.05    0.97    1.54    1.16
+592 STR streq bin short eq                  1.00    0.97    1.06    0.98    1.64    1.15
+593 STR string compare                      1.00    1.00    1.17    1.01    1.76    1.28
+594 STR string compare ""                   1.00    1.07    1.19    1.10    1.70    1.30
+595 STR string compare long                 1.00    0.98    1.06    1.02    1.28    1.08
+596 STR string compare long (same obj)      1.00    1.03    1.16    1.06    1.71    1.26
+597 STR string compare mixed long           1.00    0.93    1.00    0.93    1.05    1.00
+598 STR string compare uni long             1.00    1.03    1.01    1.04    1.23    1.21
+599 STR string equal ""                     1.00    1.03    1.12    1.05    1.78    1.26
+600 STR string equal long (!= len)          1.00    1.01    1.08    1.03    1.66    1.19
+601 STR string equal long (== len)          1.00    0.99    1.05    1.02    1.24    1.11
+602 STR string equal long (same obj)        1.00    1.04    1.11    1.11    1.54    1.21
+603 STR string equal mixed long             1.00    1.06    1.11    1.08    1.53    1.19
+604 STR string equal uni long               1.00    1.01    1.04    1.02    1.18    1.07
+605 STR/LIST length, obj shimmer            1.00    0.87    0.97    0.87    1.59    1.17
+606 SWITCH 1st true                         1.00    1.14    1.30    1.12    1.98    1.34
+607 SWITCH 2nd true                         1.00    1.12    1.26    1.10    2.08    1.40
+608 SWITCH 9th true                         1.00    1.10    1.28    1.08    1.96    1.36
+609 SWITCH default true                     1.00    1.09    1.26    1.06    2.06    1.36
+610 TRACE all set (rwu)                     1.00    0.99    1.15    1.01    1.63    1.15
+611 TRACE no trace set                      1.00    1.01    1.16    1.04    1.70    1.25
+612 TRACE read                              1.00    0.96    1.14    1.00    1.62    1.16
+613 TRACE unset                             1.00    0.99    1.17    1.01    1.62    1.15
+614 TRACE write                             1.00    0.97    1.15    1.00    1.64    1.18
+615 UNSET catch var !exist                  1.00    0.89    1.00    0.89    1.33    1.09
+616 UNSET catch var exists                  1.00    1.14    1.29    1.14    2.19    1.45
+617 UNSET info check var !exist             1.00    1.07    1.27    1.16    2.27    1.48
+618 UNSET info check var exists             1.00    1.10    1.26    1.12    2.24    1.38
+619 UNSET nocomplain var !exist             1.00    1.13    1.28    1.10    2.31    1.46
+620 UNSET nocomplain var exists             1.00    1.11    1.29    1.08    2.34    1.47
+621 UNSET var exists                        1.00    1.11    1.29    1.08    2.32    1.47
+622 UPLEVEL none                            1.00    1.06    1.04    1.02    1.35    0.99
+623 UPLEVEL primed                          1.00    1.09    1.22    1.02    1.89    1.16
+624 UPLEVEL to nseval                       1.00    0.99    1.06    1.00    1.47    1.04
+625 UPLEVEL to proc                         1.00    1.11    1.19    1.09    1.68    1.12
+626 VAR 'array set' of 100 elems            1.00    1.02    1.04    1.07    1.23    1.09
+627 VAR 100 'set's in array                 1.00    1.00    1.01    1.05    1.08    1.02
+628 VAR access global                       1.00    1.02    1.16    1.08    1.79    1.43
+629 VAR access local proc arg               1.00    1.11    1.28    1.09    2.07    1.50
+630 VAR access locally set                  1.00    1.06    1.25    1.04    1.94    1.31
+631 VAR access upvar                        1.00    1.05    1.23    1.11    1.82    1.43
+632 VAR incr global var 1000x               1.00    0.94    1.06    1.01    1.17    1.00
+633 VAR incr local var 1000x                1.00    1.02    1.11    1.11    1.20    1.02
+634 VAR incr upvar var 1000x                1.00    0.97    1.15    1.06    1.24    1.02
+635 VAR mset                                1.00    0.99    1.13    0.99    1.51    1.19
+636 VAR mset (foreach)                      1.00    1.02    1.17    1.03    1.80    1.32
+637 VAR ref absolute                        1.00    1.05    1.04    1.09    1.26    1.06
+638 VAR ref local                           1.00    1.06    1.14    1.12    1.33    1.11
+639 VAR ref variable                        1.00    1.01    1.11    1.07    1.29    1.18
+640 VAR set array element                   1.00    1.06    1.15    1.09    1.91    1.28
+641 VAR set scalar                          1.00    1.11    1.30    1.11    2.24    1.38
+642 WORDCOUNT wc1                           1.00    0.94    1.00    0.95    1.09    1.00
+643 WORDCOUNT wc2                           1.00    0.90    1.00    0.93    1.34    1.13
+644 WORDCOUNT wc3                           1.00    0.90    0.99    0.90    1.37    1.13
+644 BENCHMARKS                           1:8.6b1.2 2:8.6b1.2 3:8.6b1.2 4:8.6b1.2 5:8.6b1.2 6:8.6b1.2
+FINISHED 2011-03-19 14:37:46
-- 
cgit v0.12


From 7600d398a17f132b2978f536be9a954ffdc43532 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 20 Mar 2011 11:10:59 +0000
Subject: * generic/tclThreadAlloc.c: imported HAVE_FAST_TSD support from
 mig-alloc-reform. The feature has to be enabled by hand: no autoconf support
 has been added. It is not clear how universal a build using this will be: it
 also requires some loader support.

---
 generic/tclThreadAlloc.c | 49 ++++++++++++++++++++++++++++--------------------
 1 file changed, 29 insertions(+), 20 deletions(-)

diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index c3acb2a..18ae9cc 100755
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -145,6 +145,28 @@ static Tcl_Mutex *objLockPtr;
 static Cache sharedCache;
 static Cache *sharedPtr = &sharedCache;
 static Cache *firstCachePtr = &sharedCache;
+
+#if defined(HAVE_FAST_TSD)
+static __thread Cache *tcachePtr;
+static __thread int allocInitialized = 0;
+
+# define GETCACHE(cachePtr)			\
+    do {					\
+	if (!allocInitialized) {		\
+	    allocInitialized = 1;		\
+	    tcachePtr = GetCache();				\
+	}					\
+	(cachePtr) = tcachePtr;			\
+    } while (0)
+#else
+# define GETCACHE(cachePtr)			\
+    do {					\
+	(cachePtr) = TclpGetAllocCache();	\
+	if ((cachePtr) == NULL) {		\
+	    (cachePtr) = GetCache();		\
+	}					\
+    } while (0)
+#endif
 
 /*
  *----------------------------------------------------------------------
@@ -308,10 +330,7 @@ TclpAlloc(
     }
 #endif
 
-    cachePtr = TclpGetAllocCache();
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
+    GETCACHE(cachePtr);
 
     /*
      * Increment the requested size to include room for the Block structure.
@@ -378,10 +397,7 @@ TclpFree(
 	return;
     }
 
-    cachePtr = TclpGetAllocCache();
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
+    GETCACHE(cachePtr);
 
     /*
      * Get the block back from the user pointer and call system free directly
@@ -453,10 +469,7 @@ TclpRealloc(
     }
 #endif
 
-    cachePtr = TclpGetAllocCache();
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
+    GETCACHE(cachePtr);
 
     /*
      * If the block is not a system block and fits in place, simply return the
@@ -530,12 +543,10 @@ TclpRealloc(
 Tcl_Obj *
 TclThreadAllocObj(void)
 {
-    register Cache *cachePtr = TclpGetAllocCache();
+    register Cache *cachePtr;
     register Tcl_Obj *objPtr;
 
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
+    GETCACHE(cachePtr);
 
     /*
      * Get this thread's obj list structure and move or allocate new objs if
@@ -604,11 +615,9 @@ void
 TclThreadFreeObj(
     Tcl_Obj *objPtr)
 {
-    Cache *cachePtr = TclpGetAllocCache();
+    Cache *cachePtr;
 
-    if (cachePtr == NULL) {
-	cachePtr = GetCache();
-    }
+    GETCACHE(cachePtr);
 
     /*
      * Get this thread's list and push on the free Tcl_Obj.
-- 
cgit v0.12


From aabe179206fe559570c3e4cd5bc1741b197555b9 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 20 Mar 2011 11:40:13 +0000
Subject: changelog entry

---
 ChangeLog | 7 +++++++
 1 file changed, 7 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index ccf4160..0d9bc52 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-03-20  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclThreadAlloc.c: imported HAVE_FAST_TSD support from
+	mig-alloc-reform. The feature has to be enabled by hand: no
+	autoconf support has been added. It is not clear how universal
+	a build using this will be: it also requires some loader support.
+
 2011-03-17  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclCompExpr.c (ParseExpr): Generate errorCode information on
-- 
cgit v0.12


From 060fd2cde91e18a0c1277d336f092cb708b48659 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 21 Mar 2011 11:42:06 +0000
Subject: small opts

---
 generic/tclAlloc.c | 14 ++++++++++----
 1 file changed, 10 insertions(+), 4 deletions(-)

diff --git a/generic/tclAlloc.c b/generic/tclAlloc.c
index 9c0ab02..e641e97 100644
--- a/generic/tclAlloc.c
+++ b/generic/tclAlloc.c
@@ -628,7 +628,6 @@ TclpAlloc(
      * allocating more blocks if necessary.
      */
 
-    blockPtr = NULL;
     size = reqSize + OFFSET;
 #if RCHECK
     size++;
@@ -642,6 +641,7 @@ TclpAlloc(
 	}
 #endif
     } else {
+	blockPtr = NULL;
 	bucket = 0;
 	while (bucketInfo[bucket].blockSize < size) {
 	    bucket++;
@@ -655,9 +655,9 @@ TclpAlloc(
 	    cachePtr->buckets[bucket].totalAssigned += reqSize;
 #endif
 	}
-    }
-    if (blockPtr == NULL) {
-	return NULL;
+	if (blockPtr == NULL) {
+	    return NULL;
+	}
     }
     return Block2Ptr(blockPtr, bucket, reqSize);
 }
@@ -694,7 +694,9 @@ TclpFree(
 	return free((char *) ptr);
     }
 
+#ifdef ZIPPY_STATS
     GETCACHE(cachePtr);
+#endif
 
     /*
      * Get the block back from the user pointer and call system free directly
@@ -712,6 +714,10 @@ TclpFree(
 	return;
     }
 
+#ifndef ZIPPY_STATS
+    GETCACHE(cachePtr);
+#endif
+
 #ifdef ZIPPY_STATS
     cachePtr->buckets[bucket].totalAssigned -= blockPtr->reqSize;
 #endif
-- 
cgit v0.12


From 23e778541ae5ff3bf0ef8b74c37bcd13b8f8ef94 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 21 Mar 2011 11:42:46 +0000
Subject: some cleanup re obj deletion

---
 generic/tclInt.decls  |  6 +++---
 generic/tclInt.h      |  7 -------
 generic/tclIntDecls.h |  8 +++-----
 generic/tclObj.c      | 32 +++++---------------------------
 generic/tclStubInit.c |  2 +-
 5 files changed, 12 insertions(+), 43 deletions(-)

diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 75cb20a..4da999e 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -891,9 +891,9 @@ declare 225 {
     Tcl_Obj *TclTraceDictPath(Tcl_Interp *interp, Tcl_Obj *rootPtr,
 	    int keyc, Tcl_Obj *const keyv[], int flags)
 }
-declare 226 {
-    int TclObjBeingDeleted(Tcl_Obj *objPtr)
-}
+#declare 226 {
+#    int TclObjBeingDeleted(Tcl_Obj *objPtr)
+#}
 declare 227 {
     void TclSetNsPath(Namespace *nsPtr, int pathLength,
             Tcl_Namespace *pathAry[])
diff --git a/generic/tclInt.h b/generic/tclInt.h
index a05007f..911cea6 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2668,13 +2668,6 @@ MODULE_SCOPE const Tcl_HashKeyType tclOneWordHashKeyType;
 MODULE_SCOPE const Tcl_HashKeyType tclStringHashKeyType;
 MODULE_SCOPE const Tcl_HashKeyType tclObjHashKeyType;
 
-/*
- * The head of the list of free Tcl objects, and the total number of Tcl
- * objects ever allocated and freed.
- */
-
-MODULE_SCOPE Tcl_Obj *	tclFreeObjList;
-
 #ifdef TCL_COMPILE_STATS
 MODULE_SCOPE long	tclObjsAlloced;
 MODULE_SCOPE long	tclObjsFreed;
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index dce5dae..0e9d54f 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -522,8 +522,7 @@ EXTERN TclPlatformType * TclGetPlatform(void);
 EXTERN Tcl_Obj *	TclTraceDictPath(Tcl_Interp *interp,
 				Tcl_Obj *rootPtr, int keyc,
 				Tcl_Obj *const keyv[], int flags);
-/* 226 */
-EXTERN int		TclObjBeingDeleted(Tcl_Obj *objPtr);
+/* Slot 226 is reserved */
 /* 227 */
 EXTERN void		TclSetNsPath(Namespace *nsPtr, int pathLength,
 				Tcl_Namespace *pathAry[]);
@@ -826,7 +825,7 @@ typedef struct TclIntStubs {
     void (*reserved223)(void);
     TclPlatformType * (*tclGetPlatform) (void); /* 224 */
     Tcl_Obj * (*tclTraceDictPath) (Tcl_Interp *interp, Tcl_Obj *rootPtr, int keyc, Tcl_Obj *const keyv[], int flags); /* 225 */
-    int (*tclObjBeingDeleted) (Tcl_Obj *objPtr); /* 226 */
+    void (*reserved226)(void);
     void (*tclSetNsPath) (Namespace *nsPtr, int pathLength, Tcl_Namespace *pathAry[]); /* 227 */
     void (*reserved228)(void);
     int (*tclPtrMakeUpvar) (Tcl_Interp *interp, Var *otherP1Ptr, const char *myName, int myFlags, int index); /* 229 */
@@ -1221,8 +1220,7 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclGetPlatform) /* 224 */
 #define TclTraceDictPath \
 	(tclIntStubsPtr->tclTraceDictPath) /* 225 */
-#define TclObjBeingDeleted \
-	(tclIntStubsPtr->tclObjBeingDeleted) /* 226 */
+/* Slot 226 is reserved */
 #define TclSetNsPath \
 	(tclIntStubsPtr->tclSetNsPath) /* 227 */
 /* Slot 228 is reserved */
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5ee957d..4298f62 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -26,6 +26,10 @@ static Tcl_HashTable typeTable;
 static int typeTableInitialized = 0;	/* 0 means not yet initialized. */
 TCL_DECLARE_MUTEX(tableMutex)
 
+#if defined(TCL_THREADS) && defined(TCL_COMPILE_STATS)
+static Tcl_Mutex tclObjMutex;
+#endif
+
 /*
  * Pointer to a heap-allocated string of length zero that the Tcl core uses as
  * the value of an empty string representation for an object. This value is
@@ -459,7 +463,7 @@ TclFinalizeThreadObjects(void)
  * TclFinalizeObjects --
  *
  *	This function is called by Tcl_Finalize to clean up all registered
- *	Tcl_ObjType's
+ *	Tcl_ObjType's and to reset the tclFreeObjList.
  *
  * Results:
  *	None.
@@ -1258,7 +1262,6 @@ TclFreeObj(
      */
 
     TclInvalidateStringRep(objPtr);
-    objPtr->length = -1;
 
     if (ObjDeletePending(context)) {
 	PushObjToDelete(context, objPtr);
@@ -1408,31 +1411,6 @@ TclFreeObj(
 /*
  *----------------------------------------------------------------------
  *
- * TclObjBeingDeleted --
- *
- *	This function returns 1 when the Tcl_Obj is being deleted. It is
- *	provided for the rare cases where the reason for the loss of an
- *	internal rep might be relevant. [FR 1512138]
- *
- * Results:
- *	1 if being deleted, 0 otherwise.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclObjBeingDeleted(
-    Tcl_Obj *objPtr)
-{
-    return (objPtr->length == -1);
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * Tcl_DuplicateObj --
  *
  *	Create and return a new object that is a duplicate of the argument
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 0583961..dcf6005 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -280,7 +280,7 @@ static const TclIntStubs tclIntStubs = {
     0, /* 223 */
     TclGetPlatform, /* 224 */
     TclTraceDictPath, /* 225 */
-    TclObjBeingDeleted, /* 226 */
+    0, /* 226 */
     TclSetNsPath, /* 227 */
     0, /* 228 */
     TclPtrMakeUpvar, /* 229 */
-- 
cgit v0.12


From e2f462108ea96728189ad727b14d981ef17ec18d Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 21 Mar 2011 13:41:50 +0000
Subject: remove one level of indirection in non-mem-debug builds

---
 generic/tclCkalloc.c | 12 ++++++------
 generic/tclInt.h     |  6 ++++++
 2 files changed, 12 insertions(+), 6 deletions(-)

diff --git a/generic/tclCkalloc.c b/generic/tclCkalloc.c
index 3b51f68..afc6594 100644
--- a/generic/tclCkalloc.c
+++ b/generic/tclCkalloc.c
@@ -20,6 +20,12 @@
 #define FALSE	0
 #define TRUE	1
 
+#undef Tcl_Alloc
+#undef Tcl_Free
+#undef Tcl_Realloc
+#undef Tcl_AttemptAlloc
+#undef Tcl_AttemptRealloc
+
 #ifdef TCL_MEM_DEBUG
 
 /*
@@ -736,12 +742,6 @@ Tcl_AttemptDbCkrealloc(
  *----------------------------------------------------------------------
  */
 
-#undef Tcl_Alloc
-#undef Tcl_Free
-#undef Tcl_Realloc
-#undef Tcl_AttemptAlloc
-#undef Tcl_AttemptRealloc
-
 char *
 Tcl_Alloc(
     unsigned int size)
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 911cea6..f728a80 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4500,6 +4500,12 @@ typedef struct NRE_callback {
 #include "tclIntPlatDecls.h"
 #include "tclTomMathDecls.h"
 
+#if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
+#define Tcl_AttemptAlloc   TclpAlloc
+#define Tcl_AttemptRealloc TclpRealloc
+#define Tcl_Free           TclpFree
+#endif
+
 #endif /* _TCLINT */
 
 /*
-- 
cgit v0.12


From b3db9be3e756f6c6e6267a5691d47d6c5d5acf6d Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 21 Mar 2011 14:38:05 +0000
Subject: fix last commit

---
 generic/tclInt.h | 6 +++---
 1 file changed, 3 insertions(+), 3 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index f728a80..a22348f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4501,9 +4501,9 @@ typedef struct NRE_callback {
 #include "tclTomMathDecls.h"
 
 #if !defined(USE_TCL_STUBS) && !defined(TCL_MEM_DEBUG)
-#define Tcl_AttemptAlloc   TclpAlloc
-#define Tcl_AttemptRealloc TclpRealloc
-#define Tcl_Free           TclpFree
+#define Tcl_AttemptAlloc(size)        TclpAlloc(size)
+#define Tcl_AttemptRealloc(ptr, size) TclpRealloc((ptr), (size))
+#define Tcl_Free(ptr)                 TclpFree(ptr)
 #endif
 
 #endif /* _TCLINT */
-- 
cgit v0.12


From 67162828dd33594491f2b480482a6d6f8436b1f0 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 22 Mar 2011 10:15:17 +0000
Subject: typo

---
 ChangeLog | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index da3f605..5344725 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -23,7 +23,7 @@
 
 2011-03-17  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tkMain.c: [Patch 3124683]: Reorganize the platform-specific
+	* generic/tclMain.c: [Patch 3124683]: Reorganize the platform-specific
 	stuff in (tcl|tk)Main.c.
 
 2011-03-16  Jan Nijtmans  <nijtmans@users.sf.net>
-- 
cgit v0.12


From 95f9acf8cd7767e4e519e48f3e7c2946a20f4381 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Tue, 22 Mar 2011 10:52:03 +0000
Subject: simpler initialization of Cache	under HAVE_FAST_TSD, from
 mig-alloc-reform.

---
 ChangeLog                | 5 +++++
 generic/tclThreadAlloc.c | 6 ++----
 2 files changed, 7 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5344725..07bcdf5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-03-22  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclThreadAlloc.c: simpler initialization of Cache
+	under HAVE_FAST_TSD, from mig-alloc-reform.
+
 2011-03-21  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* unix/tclLoadDl.c:    [Bug #3216070] Loading extension libraries
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index 18ae9cc..ad1d510 100755
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -148,13 +148,11 @@ static Cache *firstCachePtr = &sharedCache;
 
 #if defined(HAVE_FAST_TSD)
 static __thread Cache *tcachePtr;
-static __thread int allocInitialized = 0;
 
 # define GETCACHE(cachePtr)			\
     do {					\
-	if (!allocInitialized) {		\
-	    allocInitialized = 1;		\
-	    tcachePtr = GetCache();				\
+	if (!tcachePtr) {			\
+	    tcachePtr = GetCache();		\
 	}					\
 	(cachePtr) = tcachePtr;			\
     } while (0)
-- 
cgit v0.12


From d68b078b5ccb7111f9c82f5d536184052563a8bd Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Wed, 23 Mar 2011 13:11:16 +0000
Subject: * generic/tclObj.c: exploit HAVE_FAST_TSD for the deletion context in
 TclFreeObj()

---
 ChangeLog        | 5 +++++
 generic/tclObj.c | 4 ++++
 2 files changed, 9 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 07bcdf5..0b0297c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-03-23  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclObj.c: exploit HAVE_FAST_TSD for the deletion context
+	in TclFreeObj()
+
 2011-03-22  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclThreadAlloc.c: simpler initialization of Cache
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 3bc6f12..5fc8142 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -162,6 +162,10 @@ typedef struct PendingObjData {
 static PendingObjData pendingObjData;
 #define ObjInitDeletionContext(contextPtr) \
     PendingObjData *const contextPtr = &pendingObjData
+#elif HAVE_FAST_TSD
+static __thread PendingObjData pendingObjData;
+#define ObjInitDeletionContext(contextPtr) \
+    PendingObjData *const contextPtr = &pendingObjData
 #else
 static Tcl_ThreadDataKey pendingObjDataKey;
 #define ObjInitDeletionContext(contextPtr) \
-- 
cgit v0.12


From fe3d6b650e607816bf94213b17c95b2c6b1d05f0 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 24 Mar 2011 09:12:17 +0000
Subject: Correct bizarre name of enumeration member.

---
 generic/tclEvent.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 78bd7b8..a8bab0b 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -1479,7 +1479,7 @@ Tcl_UpdateObjCmd(
     int optionIndex;
     int flags = 0;		/* Initialized to avoid compiler warning. */
     static const char *const updateOptions[] = {"idletasks", NULL};
-    enum updateOptions {REGEXP_IDLETASKS};
+    enum updateOptions {OPT_IDLETASKS};
 
     if (objc == 1) {
 	flags = TCL_ALL_EVENTS|TCL_DONT_WAIT;
@@ -1489,7 +1489,7 @@ Tcl_UpdateObjCmd(
 	    return TCL_ERROR;
 	}
 	switch ((enum updateOptions) optionIndex) {
-	case REGEXP_IDLETASKS:
+	case OPT_IDLETASKS:
 	    flags = TCL_WINDOW_EVENTS|TCL_IDLE_EVENTS|TCL_DONT_WAIT;
 	    break;
 	default:
-- 
cgit v0.12


From 884ba1c7869af6d659c880a2dc8a9d7a76f034bd Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 24 Mar 2011 16:43:38 +0000
Subject: Restored C++ usability to the memory allocation and free macros.

---
 ChangeLog                |  5 +++++
 generic/tcl.h            | 12 ++++++------
 generic/tclThreadAlloc.c |  0
 3 files changed, 11 insertions(+), 6 deletions(-)
 mode change 100644 => 100755 generic/tclThreadAlloc.c

diff --git a/ChangeLog b/ChangeLog
index c327093..3440a14 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-03-24  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tcl.h (ckfree,etc.): Restored C++ usability to the memory
+	allocation and free macros.
+
 2011-03-24  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclFCmd.c (TclFileAttrsCmd): Ensure that any reference to
diff --git a/generic/tcl.h b/generic/tcl.h
index 2abbb1a..b491944 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2405,13 +2405,13 @@ EXTERN void		Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
 #   define ckalloc(x) \
     ((VOID *) Tcl_DbCkalloc((unsigned)(x), __FILE__, __LINE__))
 #   define ckfree(x) \
-    Tcl_DbCkfree((VOID *)(x), __FILE__, __LINE__)
+    Tcl_DbCkfree((char *)(x), __FILE__, __LINE__)
 #   define ckrealloc(x,y) \
-    ((VOID *) Tcl_DbCkrealloc((VOID *)(x), (unsigned)(y), __FILE__, __LINE__))
+    ((VOID *) Tcl_DbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
 #   define attemptckalloc(x) \
     ((VOID *) Tcl_AttemptDbCkalloc((unsigned)(x), __FILE__, __LINE__))
 #   define attemptckrealloc(x,y) \
-    ((VOID *) Tcl_AttemptDbCkrealloc((VOID *)(x), (unsigned)(y), __FILE__, __LINE__))
+    ((VOID *) Tcl_AttemptDbCkrealloc((char *)(x), (unsigned)(y), __FILE__, __LINE__))
 
 #else /* !TCL_MEM_DEBUG */
 
@@ -2424,13 +2424,13 @@ EXTERN void		Tcl_GetMemoryInfo(Tcl_DString *dsPtr);
 #   define ckalloc(x) \
     ((VOID *) Tcl_Alloc((unsigned)(x)))
 #   define ckfree(x) \
-    Tcl_Free((VOID *)(x))
+    Tcl_Free((char *)(x))
 #   define ckrealloc(x,y) \
-    ((VOID *) Tcl_Realloc((VOID *)(x), (unsigned)(y)))
+    ((VOID *) Tcl_Realloc((char *)(x), (unsigned)(y)))
 #   define attemptckalloc(x) \
     ((VOID *) Tcl_AttemptAlloc((unsigned)(x)))
 #   define attemptckrealloc(x,y) \
-    ((VOID *) Tcl_AttemptRealloc((VOID *)(x), (unsigned)(y)))
+    ((VOID *) Tcl_AttemptRealloc((char *)(x), (unsigned)(y)))
 #   undef  Tcl_InitMemory
 #   define Tcl_InitMemory(x)
 #   undef  Tcl_DumpActiveMemory
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
old mode 100644
new mode 100755
-- 
cgit v0.12


From 77029bd1e96f8df35c93b67699e5aee7c4546d72 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 26 Mar 2011 11:53:59 +0000
Subject: Reduce the number of casts used to manage Tcl_Obj internal
 representations.

---
 ChangeLog              |   7 +++
 generic/tcl.h          |  13 +++--
 generic/tclCompExpr.c  |   2 +-
 generic/tclCompile.c   |   2 +-
 generic/tclExecute.c   | 147 +++++++++++++++++++++++--------------------------
 generic/tclListObj.c   | 124 +++++++++++++++++++++--------------------
 generic/tclNamesp.c    |   6 +-
 generic/tclObj.c       |   2 +-
 generic/tclStringObj.c |   5 +-
 generic/tclTestObj.c   |  10 ++--
 generic/tclUtil.c      |   2 +-
 11 files changed, 162 insertions(+), 158 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 3440a14..051880e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-03-26  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCompExpr.c, generic/tclCompile.c, generic/tclExecute.c:
+	* generic/tclListObj.c, generic/tclNamesp.c, generic/tclObj.c:
+	* generic/tclStringObj.c, generic/tclUtil.c: Reduce the number of
+	casts used to manage Tcl_Obj internal representations.
+
 2011-03-24  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tcl.h (ckfree,etc.): Restored C++ usability to the memory
diff --git a/generic/tcl.h b/generic/tcl.h
index b491944..3285c3c 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -799,11 +799,14 @@ typedef struct Tcl_Obj {
 	    void *ptr1;
 	    void *ptr2;
 	} twoPtrValue;
-	struct {		/*   - internal rep as a wide int, tightly
-				 *     packed fields. */
-	    void *ptr;		/* Pointer to digits. */
-	    unsigned long value;/* Alloc, used, and signum packed into a
-				 * single word. */
+	struct {		/*   - internal rep as a pointer and a long,
+				 *     the main use of which is a bignum's
+				 *     tightly packed fields, where the alloc,
+				 *     used and signum flags are packed into a
+				 *     single word with everything else hung
+				 *     off the pointer. */
+	    void *ptr;
+	    unsigned long value;
 	} ptrAndLongRep;
     } internalRep;
 } Tcl_Obj;
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index a07d6df..d1d7403 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2152,7 +2152,7 @@ ExecConstantExprTree(
     TclInitByteCodeObj(byteCodeObj, envPtr);
     TclFreeCompileEnv(envPtr);
     TclStackFree(interp, envPtr);
-    byteCodePtr = (ByteCode *) byteCodeObj->internalRep.otherValuePtr;
+    byteCodePtr = byteCodeObj->internalRep.otherValuePtr;
     TclNRExecuteByteCode(interp, byteCodePtr);
     code = TclNRRunCallbacks(interp, TCL_OK, rootPtr);
     Tcl_DecrRefCount(byteCodeObj);
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index aed9e3b..5565342 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -1001,7 +1001,7 @@ CompileSubstObj(
     if (objPtr->typePtr == &substCodeType) {
 	Namespace *nsPtr = iPtr->varFramePtr->nsPtr;
 
-	codePtr = (ByteCode *) objPtr->internalRep.ptrAndLongRep.ptr;
+	codePtr = objPtr->internalRep.ptrAndLongRep.ptr;
 	if ((unsigned long)flags != objPtr->internalRep.ptrAndLongRep.value
 		|| ((Interp *) *codePtr->interpHandle != iPtr)
 		|| (codePtr->compileEpoch != iPtr->compileEpoch)
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 26d3e04..f1b8504 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -189,7 +189,7 @@ typedef struct TEBCdata {
     TclNRAddCallback(interp, TEBCresume, TD,	\
 	    INT2PTR(1), NULL, NULL)
     
-#define TEBC_DATA_DIG()				\
+#define TEBC_DATA_DIG() \
     pc = TD->pc;				\
     cleanup = TD->cleanup;			\
     tosPtr = esPtr->tosPtr
@@ -197,15 +197,15 @@ typedef struct TEBCdata {
 
 #define PUSH_TAUX_OBJ(objPtr) \
     do {							\
-	objPtr->internalRep.twoPtrValue.ptr2 = auxObjList;	\
+	objPtr->internalRep.ptrAndLongRep.ptr = auxObjList;	\
 	auxObjList = objPtr;					\
     } while (0)
 
 #define POP_TAUX_OBJ() \
-    do {								\
-	tmpPtr = auxObjList;						\
-	auxObjList = (Tcl_Obj *) tmpPtr->internalRep.twoPtrValue.ptr2;	\
-	Tcl_DecrRefCount(tmpPtr);					\
+    do {							\
+	tmpPtr = auxObjList;					\
+	auxObjList = tmpPtr->internalRep.ptrAndLongRep.ptr;	\
+	Tcl_DecrRefCount(tmpPtr);				\
     } while (0)
 
 /*
@@ -1460,7 +1460,7 @@ CompileExprObj(
     if (objPtr->typePtr == &exprCodeType) {
 	Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
 
-	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+	codePtr = objPtr->internalRep.otherValuePtr;
 	if (((Interp *) *codePtr->interpHandle != iPtr)
 		|| (codePtr->compileEpoch != iPtr->compileEpoch)
 		|| (codePtr->nsPtr != namespacePtr)
@@ -1500,7 +1500,7 @@ CompileExprObj(
 	TclInitByteCodeObj(objPtr, &compEnv);
 	objPtr->typePtr = &exprCodeType;
 	TclFreeCompileEnv(&compEnv);
-	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+	codePtr = objPtr->internalRep.otherValuePtr;
 	if (iPtr->varFramePtr->localCachePtr) {
 	    codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
 	    codePtr->localCachePtr->refCount++;
@@ -1572,7 +1572,7 @@ static void
 FreeExprCodeInternalRep(
     Tcl_Obj *objPtr)
 {
-    ByteCode *codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+    ByteCode *codePtr = objPtr->internalRep.otherValuePtr;
 
     objPtr->typePtr = NULL;
     objPtr->internalRep.otherValuePtr = NULL;
@@ -1633,7 +1633,7 @@ TclCompileObj(
 	 * here.
 	 */
 
-	codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+	codePtr = objPtr->internalRep.otherValuePtr;
 	if (((Interp *) *codePtr->interpHandle != iPtr)
 		|| (codePtr->compileEpoch != iPtr->compileEpoch)
 		|| (codePtr->nsPtr != namespacePtr)
@@ -1691,67 +1691,59 @@ TclCompileObj(
 	{
 	    Tcl_HashEntry *hePtr =
 		    Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
+	    ExtCmdLoc *eclPtr;
+	    CmdFrame *ctxPtr;
+	    int redo;
 
-	    if (hePtr) {
-		ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
-		int redo = 0;
-
-		if (invoker) {
-		    CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame));
-		    *ctxPtr = *invoker;
+	    if (!hePtr || !invoker) {
+		return codePtr;
+	    }
 
-		    if (invoker->type == TCL_LOCATION_BC) {
-			/*
-			 * Note: Type BC => ctx.data.eval.path    is not used.
-			 *		    ctx.data.tebc.codePtr used instead
-			 */
+	    eclPtr = Tcl_GetHashValue(hePtr);
+	    redo = 0;
+	    ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+	    *ctxPtr = *invoker;
 
-			TclGetSrcInfoForPc(ctxPtr);
-			if (ctxPtr->type == TCL_LOCATION_SOURCE) {
-			    /*
-			     * The reference made by 'TclGetSrcInfoForPc' is
-			     * dead.
-			     */
+	    if (invoker->type == TCL_LOCATION_BC) {
+		/*
+		 * Note: Type BC => ctx.data.eval.path    is not used.
+		 *		    ctx.data.tebc.codePtr used instead
+		 */
 
-			    Tcl_DecrRefCount(ctxPtr->data.eval.path);
-			    ctxPtr->data.eval.path = NULL;
-			}
-		    }
+		TclGetSrcInfoForPc(ctxPtr);
+		if (ctxPtr->type == TCL_LOCATION_SOURCE) {
+		    /*
+		     * The reference made by 'TclGetSrcInfoForPc' is dead.
+		     */
 
-		    if (word < ctxPtr->nline) {
-			/*
-			 * Note: We do not care if the line[word] is -1. This
-			 * is a difference and requires a recompile (location
-			 * changed from absolute to relative, literal is used
-			 * fixed and through variable)
-			 *
-			 * Example:
-			 * test info-32.0 using literal of info-24.8
-			 *     (dict with ... vs           set body ...).
-			 */
+		    Tcl_DecrRefCount(ctxPtr->data.eval.path);
+		    ctxPtr->data.eval.path = NULL;
+		}
+	    }
 
-			redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
-				    && (eclPtr->start != ctxPtr->line[word]))
-				|| ((eclPtr->type == TCL_LOCATION_BC)
-				    && (ctxPtr->type == TCL_LOCATION_SOURCE));
-		    }
+	    if (word < ctxPtr->nline) {
+		/*
+		 * Note: We do not care if the line[word] is -1. This is a
+		 * difference and requires a recompile (location changed from
+		 * absolute to relative, literal is used fixed and through
+		 * variable)
+		 *
+		 * Example:
+		 * test info-32.0 using literal of info-24.8
+		 *     (dict with ... vs           set body ...).
+		 */
 
-		    TclStackFree(interp, ctxPtr);
-		}
+		redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
+			    && (eclPtr->start != ctxPtr->line[word]))
+			|| ((eclPtr->type == TCL_LOCATION_BC)
+			    && (ctxPtr->type == TCL_LOCATION_SOURCE));
+	    }
 
-		if (redo) {
-		    goto recompileObj;
-		}
+	    TclStackFree(interp, ctxPtr);
+	    if (!redo) {
+		return codePtr;
 	    }
 	}
-
-	/*
-	 * Increment the code's ref count while it is being executed. If
-	 * afterwards no references to it remain, free the code.
-	 */
-
-    runCompiledObj:
-	return codePtr;
     }
 
   recompileObj:
@@ -1773,7 +1765,7 @@ TclCompileObj(
 	codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr;
 	codePtr->localCachePtr->refCount++;
     }
-    goto runCompiledObj;
+    return codePtr;
 }
 
 /*
@@ -2121,8 +2113,8 @@ TEBCresume(
 	    }
 #endif
 	    /*
-	     * Push the call's object result and continue execution with
-	     * the next instruction.
+	     * Push the call's object result and continue execution with the
+	     * next instruction.
 	     */
 	    
 	    TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
@@ -2132,15 +2124,13 @@ TEBCresume(
 	    
 	    /*
 	     * Reset the interp's result to avoid possible duplications of
-	     * large objects [Bug 781585]. We do not call Tcl_ResetResult
-	     * to avoid any side effects caused by the resetting of
-	     * errorInfo and errorCode [Bug 804681], which are not needed
-	     * here. We chose instead to manipulate the interp's object
-	     * result directly. 
+	     * large objects [Bug 781585]. We do not call Tcl_ResetResult to
+	     * avoid any side effects caused by the resetting of errorInfo and
+	     * errorCode [Bug 804681], which are not needed here. We chose
+	     * instead to manipulate the interp's object result directly.
 	     *
-	     * Note that the result object is now in objResultPtr, it
-	     * keeps the refCount it had in its role of
-	     * iPtr->objResultPtr. 
+	     * Note that the result object is now in objResultPtr, it keeps
+	     * the refCount it had in its role of iPtr->objResultPtr.
 	     */
 	    
 	    TclNewObj(objPtr);
@@ -2637,7 +2627,7 @@ TEBCresume(
 	 */
 
 	TclNewObj(objPtr);
-	objPtr->internalRep.twoPtrValue.ptr1 = (void *) CURR_DEPTH;
+	objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH;
 	PUSH_TAUX_OBJ(objPtr);
 	NEXT_INST_F(1, 0, 0);
 
@@ -2727,8 +2717,7 @@ TEBCresume(
 
     case INST_INVOKE_EXPANDED:
 	CLANG_ASSERT(auxObjList);
-	objc = CURR_DEPTH
-		- (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1;
+	objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
 	POP_TAUX_OBJ();
 	if (objc) {
 	    pcAdjustment = 1;
@@ -4415,6 +4404,7 @@ TEBCresume(
 	     * strings.  We can use memcmp in all (n)eq cases because we
 	     * don't need to worry about lexical LE/BE variance.
 	     */
+
 	    typedef int (*memCmpFn_t)(const void*, const void*, size_t);
 	    memCmpFn_t memCmpFn;
 	    int checkEq = ((*pc == INST_EQ) || (*pc == INST_NEQ)
@@ -6259,7 +6249,8 @@ TEBCresume(
 
 	    bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg);
 	    DECACHE_STACK_INFO();
-	    TclLogCommandInfo(interp, codePtr->source, bytes, bytes ? length : 0, pcBeg, tosPtr);
+	    TclLogCommandInfo(interp, codePtr->source, bytes,
+		    bytes ? length : 0, pcBeg, tosPtr);
 	    CACHE_STACK_INFO();
 	}
 	iPtr->flags &= ~ERR_ALREADY_LOGGED;
@@ -6270,8 +6261,8 @@ TEBCresume(
 	 */
 
 	while (auxObjList) {
-	    if ((catchTop != initCatchTop) && (*catchTop >
-		    (ptrdiff_t) auxObjList->internalRep.twoPtrValue.ptr1)) {
+	    if ((catchTop != initCatchTop) &&
+		    (*catchTop>auxObjList->internalRep.ptrAndLongRep.value)) {
 		break;
 	    }
 	    POP_TAUX_OBJ();
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 46710d6..b27163d 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -181,7 +181,7 @@ Tcl_NewListObj(
      */
 
     Tcl_InvalidateStringRep(listPtr);
-    listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+    listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
     listPtr->internalRep.twoPtrValue.ptr2 = NULL;
     listPtr->typePtr = &tclListType;
     listRepPtr->refCount++;
@@ -253,7 +253,7 @@ Tcl_DbNewListObj(
      */
 
     Tcl_InvalidateStringRep(listPtr);
-    listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+    listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
     listPtr->internalRep.twoPtrValue.ptr2 = NULL;
     listPtr->typePtr = &tclListType;
     listRepPtr->refCount++;
@@ -329,7 +329,7 @@ Tcl_SetListObj(
 	if (!listRepPtr) {
 	    Tcl_Panic("Cannot allocate enough memory for Tcl_SetListObj");
 	}
-	objPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+	objPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
 	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
 	objPtr->typePtr = &tclListType;
 	listRepPtr->refCount++;
@@ -446,7 +446,7 @@ Tcl_ListObjGetElements(
 	    return result;
 	}
     }
-    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+    listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
     *objcPtr = listRepPtr->elemCount;
     *objvPtr = &listRepPtr->elements;
     return TCL_OK;
@@ -564,7 +564,7 @@ Tcl_ListObjAppendElement(
 	}
     }
 
-    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+    listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
     numElems = listRepPtr->elemCount;
     numRequired = numElems + 1 ;
 
@@ -674,7 +674,7 @@ Tcl_ListObjIndex(
 	}
     }
 
-    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+    listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
     if ((index < 0) || (index >= listRepPtr->elemCount)) {
 	*objPtrPtr = NULL;
     } else {
@@ -729,7 +729,7 @@ Tcl_ListObjLength(
 	}
     }
 
-    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+    listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
     *intPtr = listRepPtr->elemCount;
     return TCL_OK;
 }
@@ -816,7 +816,7 @@ Tcl_ListObjReplace(
      * Resist any temptation to optimize this case.
      */
 
-    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+    listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
     elemPtrs = &listRepPtr->elements;
     numElems = listRepPtr->elemCount;
 
@@ -887,7 +887,7 @@ Tcl_ListObjReplace(
 	    Tcl_Panic("Not enough memory to allocate list");
 	}
 
-	listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+	listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
 	listRepPtr->refCount++;
 
 	elemPtrs = &listRepPtr->elements;
@@ -1228,8 +1228,8 @@ TclLsetList(
  *
  * Results:
  *	Returns the new value of the list variable, or NULL if an error
- *	occurred. The returned object includes one reference count for
- *	the pointer returned.
+ *	occurred. The returned object includes one reference count for the
+ *	pointer returned.
  *
  * Side effects:
  *	On entry, the reference count of the variable value does not reflect
@@ -1275,8 +1275,8 @@ TclLsetFlat(
     Tcl_Obj *subListPtr, *retValuePtr, *chainPtr;
 
     /*
-     * If there are no indices, simply return the new value.
-     * (Without indices, [lset] is a synonym for [set].
+     * If there are no indices, simply return the new value.  (Without
+     * indices, [lset] is a synonym for [set].
      */
 
     if (indexCount == 0) {
@@ -1285,14 +1285,14 @@ TclLsetFlat(
     }
 
     /*
-     * If the list is shared, make a copy we can modify (copy-on-write).
-     * We use Tcl_DuplicateObj() instead of TclListObjCopy() for a few
-     * reasons: 1) we have not yet confirmed listPtr is actually a list;
-     * 2) We make a verbatim copy of any existing string rep, and when
-     * we combine that with the delayed invalidation of string reps of
-     * modified Tcl_Obj's implemented below, the outcome is that any
-     * error condition that causes this routine to return NULL, will
-     * leave the string rep of listPtr and all elements to be unchanged.
+     * If the list is shared, make a copy we can modify (copy-on-write).  We
+     * use Tcl_DuplicateObj() instead of TclListObjCopy() for a few reasons:
+     * 1) we have not yet confirmed listPtr is actually a list; 2) We make a
+     * verbatim copy of any existing string rep, and when we combine that with
+     * the delayed invalidation of string reps of modified Tcl_Obj's
+     * implemented below, the outcome is that any error condition that causes
+     * this routine to return NULL, will leave the string rep of listPtr and
+     * all elements to be unchanged.
      */
 
     subListPtr = Tcl_IsShared(listPtr) ? Tcl_DuplicateObj(listPtr) : listPtr;
@@ -1306,8 +1306,8 @@ TclLsetFlat(
     chainPtr = NULL;
 
     /*
-     * Loop through all the index arguments, and for each one dive
-     * into the appropriate sublist.
+     * Loop through all the index arguments, and for each one dive into the
+     * appropriate sublist.
      */
 
     do {
@@ -1343,10 +1343,10 @@ TclLsetFlat(
 	}
 
 	/*
-	 * No error conditions.  As long as we're not yet on the last
-	 * index, determine the next sublist for the next pass through
-	 * the loop, and take steps to make sure it is an unshared copy,
-	 * as we intend to modify it.
+	 * No error conditions.  As long as we're not yet on the last index,
+	 * determine the next sublist for the next pass through the loop, and
+	 * take steps to make sure it is an unshared copy, as we intend to
+	 * modify it.
 	 */
 
 	result = TCL_OK;
@@ -1366,8 +1366,8 @@ TclLsetFlat(
 	     * we know to be unshared.  This call will also deal with the
 	     * situation where parentList shares its intrep with other
 	     * Tcl_Obj's.  Dealing with the shared intrep case can cause
-	     * subListPtr to become shared again, so detect that case and
-	     * make and store another copy.
+	     * subListPtr to become shared again, so detect that case and make
+	     * and store another copy.
 	     */
 
 	    if (index == elemCount) {
@@ -1381,61 +1381,67 @@ TclLsetFlat(
 	    }
 
 	    /*
-	     * The TclListObjSetElement() calls do not spoil the string
-	     * rep of parentList, and that's fine for now, since all we've
-	     * done so far is replace a list element with an unshared copy.
-	     * The list value remains the same, so the string rep. is still
-	     * valid, and unchanged, which is good because if this whole
-	     * routine returns NULL, we'd like to leave no change to the
-	     * value of the lset variable.  Later on, when we set valuePtr
-	     * in its proper place, then all containing lists will have
-	     * their values changed, and will need their string reps spoiled.
-	     * We maintain a list of all those Tcl_Obj's (via a little intrep
-	     * surgery) so we can spoil them at that time.
+	     * The TclListObjSetElement() calls do not spoil the string rep of
+	     * parentList, and that's fine for now, since all we've done so
+	     * far is replace a list element with an unshared copy.  The list
+	     * value remains the same, so the string rep. is still valid, and
+	     * unchanged, which is good because if this whole routine returns
+	     * NULL, we'd like to leave no change to the value of the lset
+	     * variable.  Later on, when we set valuePtr in its proper place,
+	     * then all containing lists will have their values changed, and
+	     * will need their string reps spoiled.  We maintain a list of all
+	     * those Tcl_Obj's (via a little intrep surgery) so we can spoil
+	     * them at that time.
 	     */
 
-	    parentList->internalRep.twoPtrValue.ptr2 = (void *) chainPtr;
+	    parentList->internalRep.twoPtrValue.ptr2 = chainPtr;
 	    chainPtr = parentList;
 	}
     } while (indexCount > 0);
 
     /*
-     * Either we've detected and error condition, and exited the loop
-     * with result == TCL_ERROR, or we've successfully reached the last
-     * index, and we're ready to store valuePtr.  In either case, we
-     * need to clean up our string spoiling list of Tcl_Obj's.
+     * Either we've detected and error condition, and exited the loop with
+     * result == TCL_ERROR, or we've successfully reached the last index, and
+     * we're ready to store valuePtr.  In either case, we need to clean up our
+     * string spoiling list of Tcl_Obj's.
      */
 
     while (chainPtr) {
 	Tcl_Obj *objPtr = chainPtr;
 
 	if (result == TCL_OK) {
-
 	    /*
-	     * We're going to store valuePtr, so spoil string reps
-	     * of all containing lists.
+	     * We're going to store valuePtr, so spoil string reps of all
+	     * containing lists.
 	     */
 
 	    Tcl_InvalidateStringRep(objPtr);
 	}
 
-	/* Clear away our intrep surgery mess */
-	chainPtr = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
+	/*
+	 * Clear away our intrep surgery mess.
+	 */
+
+	chainPtr = objPtr->internalRep.twoPtrValue.ptr2;
 	objPtr->internalRep.twoPtrValue.ptr2 = NULL;
     }
 
     if (result != TCL_OK) {
 	/*
-	 * Error return; message is already in interp. Clean up
-	 * any excess memory.
+	 * Error return; message is already in interp. Clean up any excess
+	 * memory.
 	 */
+
 	if (retValuePtr != listPtr) {
 	    Tcl_DecrRefCount(retValuePtr);
 	}
 	return NULL;
     }
 
-    /* Store valuePtr in proper sublist and return */
+    /*
+     * Store valuePtr in proper sublist and return.
+     */
+
     Tcl_ListObjLength(NULL, subListPtr, &len);
     if (index == len) {
 	Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
@@ -1513,7 +1519,7 @@ TclListObjSetElement(
 	}
     }
 
-    listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+    listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
     elemCount = listRepPtr->elemCount;
     elemPtrs = &listRepPtr->elements;
 
@@ -1550,7 +1556,7 @@ TclListObjSetElement(
 	}
 	listRepPtr->refCount++;
 	listRepPtr->elemCount = elemCount;
-	listPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+	listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
 	oldListRepPtr->refCount--;
     }
 
@@ -1598,7 +1604,7 @@ static void
 FreeListInternalRep(
     Tcl_Obj *listPtr)		/* List object with internal rep to free. */
 {
-    register List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+    register List *listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
     register Tcl_Obj **elemPtrs = &listRepPtr->elements;
     register Tcl_Obj *objPtr;
     int numElems = listRepPtr->elemCount;
@@ -1639,10 +1645,10 @@ DupListInternalRep(
     Tcl_Obj *srcPtr,		/* Object with internal rep to copy. */
     Tcl_Obj *copyPtr)		/* Object with internal rep to set. */
 {
-    List *listRepPtr = (List *) srcPtr->internalRep.twoPtrValue.ptr1;
+    List *listRepPtr = srcPtr->internalRep.twoPtrValue.ptr1;
 
     listRepPtr->refCount++;
-    copyPtr->internalRep.twoPtrValue.ptr1 = (void *) listRepPtr;
+    copyPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
     copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
     copyPtr->typePtr = &tclListType;
 }
@@ -1861,7 +1867,7 @@ UpdateStringOfList(
 {
 #   define LOCAL_SIZE 20
     int localFlags[LOCAL_SIZE], *flagPtr;
-    List *listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
+    List *listRepPtr = listPtr->internalRep.twoPtrValue.ptr1;
     int numElems = listRepPtr->elemCount;
     register int i;
     const char *elem;
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index ad233b9..0f1eb4d 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -2798,18 +2798,18 @@ GetNamespaceFromObj(
 	 * cross interps.
 	 */
 
-	resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
+	resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
 	nsPtr = resNamePtr->nsPtr;
 	refNsPtr = resNamePtr->refNsPtr;
 	if (!(nsPtr->flags & NS_DYING) && (interp == nsPtr->interp) &&
 		(!refNsPtr || ((interp == refNsPtr->interp) &&
-		 (refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))) {
+		(refNsPtr== (Namespace *) Tcl_GetCurrentNamespace(interp))))){
 	    *nsPtrPtr = (Tcl_Namespace *) nsPtr;
 	    return TCL_OK;
 	}
     }
     if (SetNsNameFromAny(interp, objPtr) == TCL_OK) {
-	resNamePtr = (ResolvedNsName *) objPtr->internalRep.twoPtrValue.ptr1;
+	resNamePtr = objPtr->internalRep.twoPtrValue.ptr1;
 	*nsPtrPtr = (Tcl_Namespace *) resNamePtr->nsPtr;
 	return TCL_OK;
     }
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 5fc8142..321ed67 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -4397,7 +4397,7 @@ SetCmdNameFromAny(
 
     if (cmdPtr) {
 	cmdPtr->refCount++;
-	resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
+	resPtr = objPtr->internalRep.otherValuePtr;
 	if ((objPtr->typePtr == &tclCmdNameType)
 		&& resPtr && (resPtr->refCount == 1)) {
 	    /*
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 7cdbb3e..cf635bc 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -134,10 +134,9 @@ typedef struct String {
 #define stringAlloc(numChars) \
 	(String *) ckalloc((unsigned) STRING_SIZE(numChars) )
 #define stringRealloc(ptr, numChars) \
-	(String *) ckrealloc((char *) ptr, (unsigned) STRING_SIZE(numChars) )
+    (String *) ckrealloc((ptr), (unsigned) STRING_SIZE(numChars) )
 #define stringAttemptRealloc(ptr, numChars) \
-	(String *) attemptckrealloc((char *) ptr, \
-		(unsigned) STRING_SIZE(numChars) )
+    (String *) attemptckrealloc((ptr), (unsigned) STRING_SIZE(numChars) )
 #define GET_STRING(objPtr) \
 	((String *) (objPtr)->internalRep.otherValuePtr)
 #define SET_STRING(objPtr, stringPtr) \
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index ca8545a..1ef1dc3 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -523,7 +523,7 @@ TestindexobjCmd(
 	}
 
 	Tcl_GetIndexFromObj(NULL, objv[1], tablePtr, "token", 0, &index);
-	indexRep = (struct IndexRep *) objv[1]->internalRep.otherValuePtr;
+	indexRep = objv[1]->internalRep.otherValuePtr;
 	indexRep->index = index2;
 	result = Tcl_GetIndexFromObj(NULL, objv[1],
 		tablePtr, "token", 0, &index);
@@ -560,7 +560,7 @@ TestindexobjCmd(
 
     if (objv[3]->typePtr != NULL
 	    && !strcmp("index", objv[3]->typePtr->name)) {
-	indexRep = (struct IndexRep *) objv[3]->internalRep.otherValuePtr;
+	indexRep = objv[3]->internalRep.otherValuePtr;
 	if (indexRep->tablePtr == (void *) argv) {
 	    objv[3]->typePtr->freeIntRepProc(objv[3]);
 	    objv[3]->typePtr = NULL;
@@ -1200,8 +1200,7 @@ TeststringobjCmd(
 	    if (varPtr[varIndex] != NULL) {
 		Tcl_ConvertToType(NULL, varPtr[varIndex],
 			Tcl_GetObjType("string"));
-		strPtr = (TestString *)
-		    (varPtr[varIndex])->internalRep.otherValuePtr;
+		strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
 		length = (int) strPtr->allocated;
 	    } else {
 		length = -1;
@@ -1255,8 +1254,7 @@ TeststringobjCmd(
 	    if (varPtr[varIndex] != NULL) {
 		Tcl_ConvertToType(NULL, varPtr[varIndex],
 			Tcl_GetObjType("string"));
-		strPtr = (TestString *)
-		    (varPtr[varIndex])->internalRep.otherValuePtr;
+		strPtr = varPtr[varIndex]->internalRep.otherValuePtr;
 		length = strPtr->maxChars;
 	    } else {
 		length = -1;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index f41830a..69bd4d2 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1057,7 +1057,7 @@ Tcl_ConcatObj(
 		continue;
 	    }
 	}
-	listRepPtr = (List *) objPtr->internalRep.twoPtrValue.ptr1;
+	listRepPtr = objPtr->internalRep.twoPtrValue.ptr1;
 	if (objPtr->bytes != NULL && !listRepPtr->canonicalFlag) {
 	    break;
 	}
-- 
cgit v0.12


From a4188bb98c1fdf3fff44c3552a26944064b0e8b1 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 26 Mar 2011 11:58:37 +0000
Subject: Squelch another unnecessary cast.

---
 generic/tclNamesp.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 0f1eb4d..62ead7d 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -911,7 +911,7 @@ Tcl_DeleteNamespace(
 
     for (entryPtr = Tcl_FirstHashEntry(&nsPtr->cmdTable, &search);
 	    entryPtr != NULL;) {
-	cmdPtr = (Command *) Tcl_GetHashValue(entryPtr);
+	cmdPtr = Tcl_GetHashValue(entryPtr);
 	if (cmdPtr->nreProc == NRInterpCoroutine) {
 	    Tcl_DeleteCommandFromToken((Tcl_Interp *) iPtr,
 		    (Tcl_Command) cmdPtr);
-- 
cgit v0.12


From 5d8e6c3cce8cdfbf23d812e1048233a2357c8edc Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 26 Mar 2011 12:12:14 +0000
Subject: More generation of errorCode information.

---
 ChangeLog           | 3 +++
 generic/tclNamesp.c | 6 ++++++
 2 files changed, 9 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 051880e..cb9f5c3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
 2011-03-26  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclNamesp.c (Tcl_Export, Tcl_Import, DoImport): More
+	generation of errorCode information.
+
 	* generic/tclCompExpr.c, generic/tclCompile.c, generic/tclExecute.c:
 	* generic/tclListObj.c, generic/tclNamesp.c, generic/tclObj.c:
 	* generic/tclStringObj.c, generic/tclUtil.c: Reduce the number of
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 62ead7d..3a08221 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -1335,6 +1335,7 @@ Tcl_Export(
     if ((exportNsPtr != nsPtr) || (strcmp(pattern, simplePattern) != 0)) {
 	Tcl_AppendResult(interp, "invalid export pattern \"", pattern,
 		"\": pattern can't specify a namespace", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "EXPORT", "INVALID", NULL);
 	return TCL_ERROR;
     }
 
@@ -1539,6 +1540,7 @@ Tcl_Import(
 
     if (strlen(pattern) == 0) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
+        Tcl_SetErrorCode(interp, "TCL", "IMPORT", "EMPTY", NULL);
 	return TCL_ERROR;
     }
     TclGetNamespaceForQualName(interp, pattern, nsPtr,
@@ -1556,10 +1558,12 @@ Tcl_Import(
 	    Tcl_AppendResult(interp,
 		    "no namespace specified in import pattern \"", pattern,
 		    "\"", NULL);
+            Tcl_SetErrorCode(interp, "TCL", "IMPORT", "ORIGIN", NULL);
 	} else {
 	    Tcl_AppendResult(interp, "import pattern \"", pattern,
 		    "\" tries to import from namespace \"",
 		    importNsPtr->name, "\" into itself", NULL);
+            Tcl_SetErrorCode(interp, "TCL", "IMPORT", "SELF", NULL);
 	}
 	return TCL_ERROR;
     }
@@ -1681,6 +1685,7 @@ DoImport(
 			    "\" would create a loop containing command \"",
 			    Tcl_DStringValue(&ds), "\"", NULL);
 		    Tcl_DStringFree(&ds);
+                    Tcl_SetErrorCode(interp, "TCL", "IMPORT", "LOOP", NULL);
 		    return TCL_ERROR;
 		}
 	    }
@@ -1720,6 +1725,7 @@ DoImport(
 	}
 	Tcl_AppendResult(interp, "can't import command \"", cmdName,
 		"\": already exists", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "IMPORT", "OVERWRITE", NULL);
 	return TCL_ERROR;
     }
     return TCL_OK;
-- 
cgit v0.12


From ebe7cfc96d8d03998cc3df2030e3d56733082640 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Sun, 27 Mar 2011 22:43:42 +0000
Subject: * generic/tclBasic.c (TclNREvalObjEx): fix performance issue, notably
 apparent in tclbench's 'LIST lset foreach'. Many thanks to twylite for
 patiently researching the issue and explaining it to me: a missing
 Tcl_ResetObjResult that causes unwanted sharing of the current result
 Tcl_Obj.

---
 ChangeLog          | 8 ++++++++
 generic/tclBasic.c | 3 +++
 2 files changed, 11 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index cb9f5c3..23b91b7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2011-03-27  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclBasic.c (TclNREvalObjEx): fix performance issue,
+	notably apparent in tclbench's "LIST lset foreach". Many thanks to
+	twylite for patiently researching the issue and explaining it to
+	me: a missing Tcl_ResetObjResult that causes unwanted sharing of
+	the current result Tcl_Obj. 
+
 2011-03-26  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclNamesp.c (Tcl_Export, Tcl_Import, DoImport): More
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5f2b301..b34209b 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -6018,6 +6018,9 @@ TclNREvalObjEx(
 						 * iPtr->varFramePtr in case
 						 * TCL_EVAL_GLOBAL was set. */
 
+        if (TclInterpReady(interp) != TCL_OK) {
+            return TCL_ERROR;
+        }
 	if (flags & TCL_EVAL_GLOBAL) {
 	    savedVarFramePtr = iPtr->varFramePtr;
 	    iPtr->varFramePtr = iPtr->rootFramePtr;
-- 
cgit v0.12


From aff97042289b6c2c5fd35cb8413deca7054ab0a7 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 28 Mar 2011 10:56:38 +0000
Subject: Use the error messages generated by the variable management code
 rather than creating our own in [regexp] and [regsub].

---
 ChangeLog             |  8 +++++++-
 generic/tclCmdMZ.c    | 13 ++++---------
 tests/regexp.test     | 47 ++++++++++++++++++++++++++---------------------
 tests/regexpComp.test | 35 ++++++++++++++++++++---------------
 4 files changed, 57 insertions(+), 46 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 23b91b7..703dc72 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,16 @@
+2011-03-28  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the
+	error messages generated by the variable management code rather than
+	creating our own.
+
 2011-03-27  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclBasic.c (TclNREvalObjEx): fix performance issue,
 	notably apparent in tclbench's "LIST lset foreach". Many thanks to
 	twylite for patiently researching the issue and explaining it to
 	me: a missing Tcl_ResetObjResult that causes unwanted sharing of
-	the current result Tcl_Obj. 
+	the current result Tcl_Obj.
 
 2011-03-26  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 05f2e5d..e39ae06 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -383,12 +383,8 @@ Tcl_RegexpObjCmd(
 		    return TCL_ERROR;
 		}
 	    } else {
-		Tcl_Obj *valuePtr;
-
-		valuePtr = Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr, 0);
-		if (valuePtr == NULL) {
-		    Tcl_AppendResult(interp, "couldn't set variable \"",
-			    TclGetString(objv[i]), "\"", NULL);
+		if (Tcl_ObjSetVar2(interp, objv[i], NULL, newPtr,
+			TCL_LEAVE_ERR_MSG) == NULL) {
 		    return TCL_ERROR;
 		}
 	    }
@@ -816,9 +812,8 @@ Tcl_RegsubObjCmd(
 	Tcl_AppendUnicodeToObj(resultPtr, wstring + offset, wlen - offset);
     }
     if (objc == 4) {
-	if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr, 0) == NULL) {
-	    Tcl_AppendResult(interp, "couldn't set variable \"",
-		    TclGetString(objv[3]), "\"", NULL);
+	if (Tcl_ObjSetVar2(interp, objv[3], NULL, resultPtr,
+		TCL_LEAVE_ERR_MSG) == NULL) {
 	    result = TCL_ERROR;
 	} else {
 	    /*
diff --git a/tests/regexp.test b/tests/regexp.test
index 632a19d..7cafd1b 100644
--- a/tests/regexp.test
+++ b/tests/regexp.test
@@ -11,12 +11,12 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-if {[lsearch [namespace children] ::tcltest] == -1} {
+if {"::tcltest" ni [namespace children]} {
     package require tcltest 2
     namespace import -force ::tcltest::*
 }
 
-catch {unset foo}
+unset -nocomplain foo
 
 testConstraint exec [llength [info commands exec]]
 
@@ -196,7 +196,7 @@ set x $x$x$x$x$x$x$x$x$x$x$x$x
 test regexp-4.4 {case conversion in regexp} {
     list [regexp -nocase $x $x foo] $foo
 } "1 $x"
-catch {unset x}
+unset -nocomplain x
 
 test regexp-5.1 {exercise cache of compiled expressions} {
     regexp .*a b
@@ -260,11 +260,12 @@ test regexp-6.6 {regexp errors} {
 test regexp-6.7 {regexp errors} {
     list [catch {regexp (x)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.)(.) xyzzy} msg] $msg
 } {0 0}
-test regexp-6.8 {regexp errors} {
-    catch {unset f1}
+test regexp-6.8 {regexp errors} -setup {
+    unset -nocomplain f1
+} -body {
     set f1 44
-    list [catch {regexp abc abc f1(f2)} msg] $msg
-} {1 {couldn't set variable "f1(f2)"}}
+    regexp abc abc f1(f2)
+} -returnCodes error -result {can't set "f1(f2)": variable isn't array}
 test regexp-6.9 {regexp errors, -start bad int check} {
     list [catch {regexp -start bogus {^$} {}} msg] $msg
 } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
@@ -456,11 +457,12 @@ test regexp-11.5 {regsub errors} {
 test regexp-11.6 {regsub errors} {
     list [catch {regsub -nocase a( b c d} msg] $msg
 } {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
-test regexp-11.7 {regsub errors} {
-    catch {unset f1}
+test regexp-11.7 {regsub errors} -setup {
+    unset -nocomplain f1
+} -body {
     set f1 44
-    list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
-} {1 {couldn't set variable "f1(f2)"}}
+    regsub -nocase aaa aaa xxx f1(f2)
+} -returnCodes error -result {can't set "f1(f2)": variable isn't array}
 test regexp-11.8 {regsub errors, -start bad int check} {
     list [catch {regsub -start bogus pattern string rep var} msg] $msg
 } {1 {bad index "bogus": must be integer?[+-]integer? or end?[+-]integer?}}
@@ -527,23 +529,23 @@ test regexp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache} -co
 } -result 1
 
 test regexp-15.1 {regexp -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start -10 {\d} 1abc2de3 x] $x
 } {1 1}
 test regexp-15.2 {regexp -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start 2 {\d} 1abc2de3 x] $x
 } {1 2}
 test regexp-15.3 {regexp -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start 4 {\d} 1abc2de3 x] $x
 } {1 2}
 test regexp-15.4 {regexp -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start 5 {\d} 1abc2de3 x] $x
 } {1 3}
 test regexp-15.5 {regexp -start, over end of string} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
 } {0 0}
 test regexp-15.6 {regexp -start, loss of ^$ behavior} {
@@ -556,11 +558,11 @@ test regexp-15.8 {regexp -start, double option} {
     regexp -start 0 -start 2 a abc
 } 0
 test regexp-15.9 {regexp -start, end relative index} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start end {\d} 1abc2de3 x] [info exists x]
 } {0 0}
 test regexp-15.10 {regexp -start, end relative index} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start end-1 {\d} 1abc2de3 x] [info exists x] $x
 } {1 1 3}
 test regexp-15.11 {regexp -start, over end of string} {
@@ -569,15 +571,15 @@ test regexp-15.11 {regexp -start, over end of string} {
 } {1 {}}
 
 test regexp-16.1 {regsub -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
 } {4 a1b/2c/3d/4e/5}
 test regexp-16.2 {regsub -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regsub -all -start -25 {z} hello {/&} x] $x
 } {0 hello}
 test regexp-16.3 {regsub -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regsub -all -start 3 {z} hello {/&} x] $x
 } {0 hello}
 test regexp-16.4 {regsub -start, \A behavior} {
@@ -1065,3 +1067,6 @@ test regexp-26.13 {regexp without -line option} {
 ::tcltest::cleanupTests
 return
 
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/tests/regexpComp.test b/tests/regexpComp.test
index 6f0b688..94fb90e 100644
--- a/tests/regexpComp.test
+++ b/tests/regexpComp.test
@@ -29,7 +29,8 @@ proc evalInProc { script } {
     #return [list $status $result]
 }
 
-catch {unset foo}
+unset -nocomplain foo
+
 test regexpComp-1.1 {basic regexp operation} {
     evalInProc {
 	regexp ab*c abbbc
@@ -258,7 +259,7 @@ test regexpComp-4.4 {case conversion in regexp} {
 	list [regexp -nocase $::x $::x foo] $foo
     }
 } "1 $x"
-catch {unset ::x}
+unset -nocomplain ::x
 
 test regexpComp-5.1 {exercise cache of compiled expressions} {
     evalInProc {
@@ -348,11 +349,11 @@ test regexpComp-6.7 {regexp errors} {
 } {0 0}
 test regexpComp-6.8 {regexp errors} {
     evalInProc {
-	catch {unset f1}
+	unset -nocomplain f1
 	set f1 44
 	list [catch {regexp abc abc f1(f2)} msg] $msg
     }
-} {1 {couldn't set variable "f1(f2)"}}
+} {1 {can't set "f1(f2)": variable isn't array}}
 test regexpComp-6.9 {regexp errors, -start bad int check} {
     evalInProc {
 	list [catch {regexp -start bogus {^$} {}} msg] $msg
@@ -589,11 +590,11 @@ test regexpComp-11.6 {regsub errors} {
 } {1 {couldn't compile regular expression pattern: parentheses () not balanced}}
 test regexpComp-11.7 {regsub errors} {
     evalInProc {
-	catch {unset f1}
+	unset -nocomplain f1
 	set f1 44
 	list [catch {regsub -nocase aaa aaa xxx f1(f2)} msg] $msg
     }
-} {1 {couldn't set variable "f1(f2)"}}
+} {1 {can't set "f1(f2)": variable isn't array}}
 test regexpComp-11.8 {regsub errors, -start bad int check} {
     evalInProc {
 	list [catch {regsub -start bogus pattern string rep var} msg] $msg
@@ -660,23 +661,23 @@ test regexpComp-14.3 {CompileRegexp: regexp cache, empty regexp and empty cache}
 } -result 1
 
 test regexpComp-15.1 {regexp -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start -10 {\d} 1abc2de3 x] $x
 } {1 1}
 test regexpComp-15.2 {regexp -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start 2 {\d} 1abc2de3 x] $x
 } {1 2}
 test regexpComp-15.3 {regexp -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start 4 {\d} 1abc2de3 x] $x
 } {1 2}
 test regexpComp-15.4 {regexp -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start 5 {\d} 1abc2de3 x] $x
 } {1 3}
 test regexpComp-15.5 {regexp -start, over end of string} {
-    catch {unset x}
+    unset -nocomplain x
     list [regexp -start [string length 1abc2de3] {\d} 1abc2de3 x] [info exists x]
 } {0 0}
 test regexpComp-15.6 {regexp -start, loss of ^$ behavior} {
@@ -684,15 +685,15 @@ test regexpComp-15.6 {regexp -start, loss of ^$ behavior} {
 } {0}
 
 test regexpComp-16.1 {regsub -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regsub -all -start 2 {\d} a1b2c3d4e5 {/&} x] $x
 } {4 a1b/2c/3d/4e/5}
 test regexpComp-16.2 {regsub -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regsub -all -start -25 {z} hello {/&} x] $x
 } {0 hello}
 test regexpComp-16.3 {regsub -start} {
-    catch {unset x}
+    unset -nocomplain x
     list [regsub -all -start 3 {z} hello {/&} x] $x
 } {0 hello}
 test regexpComp-16.4 {regsub -start, \A behavior} {
@@ -981,7 +982,11 @@ test regexpComp-24.11 {regexp command compiling tests} {
 	regexp -- $re $text
     }
 } 1
-
+
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End:
-- 
cgit v0.12


From 8c516639abe302098e2202d7824bd9a23f8ca532 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 28 Mar 2011 11:40:35 +0000
Subject: set default MODULE_SCOPE=extern, in case no other value is determined

---
 unix/configure | 22 ++++++++++++++++++++++
 unix/tcl.m4    |  9 ++++++++-
 win/configure  |  5 +++++
 win/tcl.m4     |  1 +
 4 files changed, 36 insertions(+), 1 deletion(-)

diff --git a/unix/configure b/unix/configure
index 9fbb864..8701f7e 100755
--- a/unix/configure
+++ b/unix/configure
@@ -6543,6 +6543,11 @@ echo "${ECHO_T}$tcl_cv_cc_visibility_hidden" >&6
 
 	CFLAGS="$CFLAGS -fvisibility=hidden"
 
+cat >>confdefs.h <<\_ACEOF
+#define MODULE_SCOPE extern
+_ACEOF
+
+
 else
 
 
@@ -8164,6 +8169,7 @@ cat >>confdefs.h <<\_ACEOF
 #define MODULE_SCOPE __private_extern__
 _ACEOF
 
+		tcl_cv_cc_visibility_hidden=yes
 
 fi
 
@@ -9036,6 +9042,22 @@ fi
 fi
 
 
+    if test "$tcl_cv_cc_visibility_hidden" != yes; then
+
+
+cat >>confdefs.h <<\_ACEOF
+#define MODULE_SCOPE extern
+_ACEOF
+
+
+cat >>confdefs.h <<\_ACEOF
+#define NO_VIZ
+_ACEOF
+
+
+fi
+
+
     if test "$SHARED_LIB_SUFFIX" = ""; then
 
 	SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 9e533f0..8c9eaf0 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1055,8 +1055,8 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
     ])
     AS_IF([test $tcl_cv_cc_visibility_hidden = yes], [
 	CFLAGS="$CFLAGS -fvisibility=hidden"
+	AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden])
     ], [
-	AC_DEFINE(NO_VIZ, [], [No visibility attribute])
 	hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
 	AC_TRY_LINK([
 	    extern __attribute__((__visibility__("hidden"))) void f(void);
@@ -1663,6 +1663,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 	    AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
 		AC_DEFINE(MODULE_SCOPE, [__private_extern__],
 		    [Compiler support for module scope symbols])
+		tcl_cv_cc_visibility_hidden=yes
 	    ])
 	    CC_SEARCH_FLAGS=""
 	    LD_SEARCH_FLAGS=""
@@ -2061,6 +2062,12 @@ dnl # preprocessing tests use only CPPFLAGS.
 	    *) SHLIB_CFLAGS="-fPIC" ;;
 	esac])
 
+    AS_IF([test "$tcl_cv_cc_visibility_hidden" != yes], [
+	AC_DEFINE(MODULE_SCOPE, [extern],
+	    [No Compiler support for module scope symbols])
+	AC_DEFINE(NO_VIZ, [], [No visibility attribute])
+    ])
+
     AS_IF([test "$SHARED_LIB_SUFFIX" = ""], [
 	SHARED_LIB_SUFFIX='${VERSION}${SHLIB_SUFFIX}'])
     AS_IF([test "$UNSHARED_LIB_SUFFIX" = ""], [
diff --git a/win/configure b/win/configure
index e505fb2..d1d50e2 100755
--- a/win/configure
+++ b/win/configure
@@ -3932,6 +3932,11 @@ echo "${ECHO_T}$CELIB_DIR" >&6
     # Set some defaults (may get changed below)
     EXTRA_CFLAGS=""
 
+cat >>confdefs.h <<\_ACEOF
+#define MODULE_SCOPE extern
+_ACEOF
+
+
     # Extract the first word of "cygpath", so it can be a program name with args.
 set dummy cygpath; ac_word=$2
 echo "$as_me:$LINENO: checking for $ac_word" >&5
diff --git a/win/tcl.m4 b/win/tcl.m4
index 51498d6..6e3f3f9 100644
--- a/win/tcl.m4
+++ b/win/tcl.m4
@@ -402,6 +402,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 
     # Set some defaults (may get changed below)
     EXTRA_CFLAGS=""
+	AC_DEFINE(MODULE_SCOPE, [extern], [No need to mark inidividual symbols as hidden])
 
     AC_CHECK_PROG(CYGPATH, cygpath, cygpath -w, echo)
 
-- 
cgit v0.12


From 5b43ec40f8e8d1787c1d12eec18205bfbf1fef1e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 28 Mar 2011 12:15:07 +0000
Subject: Corrected odd comment

---
 generic/tclVar.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclVar.c b/generic/tclVar.c
index a4b8a69..28151c0 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -5481,7 +5481,7 @@ DeleteArray(
 /*
  *----------------------------------------------------------------------
  *
- * TclTclObjVarErrMsg --
+ * TclObjVarErrMsg --
  *
  *	Generate a reasonable error message describing why a variable
  *	operation failed.
-- 
cgit v0.12


From ce1706f3395619dee86a51d89a76c9537e4d8fe3 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 29 Mar 2011 15:06:26 +0000
Subject: More generation of errorCode information, notably when lists are
 mis-parsed.

---
 ChangeLog           |   4 +++
 generic/tclCmdMZ.c  |  42 ++++++++++++++++++++++
 generic/tclConfig.c |   7 +++-
 generic/tclUtil.c   | 101 ++++++++++++++++++++++++++++------------------------
 4 files changed, 107 insertions(+), 47 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 703dc72..8e81f98 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2011-03-28  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More
+	generation of errorCode information, notably when lists are
+	mis-parsed.
+
 	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the
 	error messages generated by the variable management code rather than
 	creating our own.
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index e39ae06..61de8de 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1794,6 +1794,8 @@ StringMapCmd(
 	} else {
 	    Tcl_AppendResult(interp, "bad option \"", string,
 		    "\": must be -nocase", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
+		    string, NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -1856,6 +1858,8 @@ StringMapCmd(
 
 	    Tcl_SetObjResult(interp,
 		    Tcl_NewStringObj("char map list unbalanced", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "MAP",
+		    "UNBALANCED", NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -2057,6 +2061,8 @@ StringMatchCmd(
 	} else {
 	    Tcl_AppendResult(interp, "bad option \"", string,
 		    "\": must be -nocase", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
+		    string, NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -2189,6 +2195,7 @@ StringReptCmd(
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"result exceeds max size for a Tcl value (%d bytes)",
 		INT_MAX));
+	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 	return TCL_ERROR;
     }
     length2 = length1 * count;
@@ -2209,6 +2216,7 @@ StringReptCmd(
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 		"string size overflow, out of memory allocating %u bytes",
 		length2 + 1));
+	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 	return TCL_ERROR;
     }
     for (index = 0; index < count; index++) {
@@ -2514,6 +2522,8 @@ StringEqualCmd(
 	} else {
 	    Tcl_AppendResult(interp, "bad option \"", string2,
 		    "\": must be -nocase or -length", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
+		    string2, NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -2661,6 +2671,8 @@ StringCmpCmd(
 	} else {
 	    Tcl_AppendResult(interp, "bad option \"", string2,
 		    "\": must be -nocase or -length", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "option",
+		    string2, NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -3558,6 +3570,8 @@ TclNRSwitchObjCmd(
 		Tcl_AppendResult(interp, "bad option \"",
 			TclGetString(objv[i]), "\": ", options[mode],
 			" option already found", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+			"DOUBLEOPT", NULL);
 		return TCL_ERROR;
 	    }
 	    foundmode = 1;
@@ -3574,6 +3588,8 @@ TclNRSwitchObjCmd(
 	    if (i >= objc-2) {
 		Tcl_AppendResult(interp, "missing variable name argument to ",
 			"-indexvar", " option", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+			"NOVAR", NULL);
 		return TCL_ERROR;
 	    }
 	    indexVarObj = objv[i];
@@ -3584,6 +3600,8 @@ TclNRSwitchObjCmd(
 	    if (i >= objc-2) {
 		Tcl_AppendResult(interp, "missing variable name argument to ",
 			"-matchvar", " option", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+			"NOVAR", NULL);
 		return TCL_ERROR;
 	    }
 	    matchVarObj = objv[i];
@@ -3601,11 +3619,15 @@ TclNRSwitchObjCmd(
     if (indexVarObj != NULL && mode != OPT_REGEXP) {
 	Tcl_AppendResult(interp,
 		"-indexvar option requires -regexp option", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+		"MODERESTRICTION", NULL);
 	return TCL_ERROR;
     }
     if (matchVarObj != NULL && mode != OPT_REGEXP) {
 	Tcl_AppendResult(interp,
 		"-matchvar option requires -regexp option", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+		"MODERESTRICTION", NULL);
 	return TCL_ERROR;
     }
 
@@ -3653,6 +3675,8 @@ TclNRSwitchObjCmd(
     if (objc % 2) {
 	Tcl_ResetResult(interp);
 	Tcl_AppendResult(interp, "extra switch pattern with no body", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
+		NULL);
 
 	/*
 	 * Check if this can be due to a badly placed comment in the switch
@@ -3669,6 +3693,8 @@ TclNRSwitchObjCmd(
 			    "comment incorrectly placed outside of a "
 			    "switch body - see the \"switch\" "
 			    "documentation", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH",
+			    "BADARM", "COMMENT?", NULL);
 		    break;
 		}
 	    }
@@ -3686,6 +3712,8 @@ TclNRSwitchObjCmd(
 	Tcl_ResetResult(interp);
 	Tcl_AppendResult(interp, "no body specified for pattern \"",
 		TclGetString(objv[objc-2]), "\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SWITCH", "BADARM",
+		"FALLTHROUGH", NULL);
 	return TCL_ERROR;
     }
 
@@ -4006,6 +4034,8 @@ Tcl_ThrowObjCmd(
 	return TCL_ERROR;
     } else if (len < 1) {
 	Tcl_AppendResult(interp, "type must be non-empty list", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "THROW", "BADEXCEPTION",
+		NULL);
 	return TCL_ERROR;
     }
 
@@ -4189,12 +4219,16 @@ TclNRTryObjCmd(
 	    if (i < objc-2) {
 		Tcl_AppendResult(interp, "finally clause must be last", NULL);
 		Tcl_DecrRefCount(handlersObj);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
+			"NONTERMINAL", NULL);
 		return TCL_ERROR;
 	    } else if (i == objc-1) {
 		Tcl_AppendResult(interp, "wrong # args to finally clause: ",
 			"must be \"", TclGetString(objv[0]),
 			" ... finally script\"", NULL);
 		Tcl_DecrRefCount(handlersObj);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "FINALLY",
+			"ARGUMENT", NULL);
 		return TCL_ERROR;
 	    }
 	    finallyObj = objv[++i];
@@ -4206,6 +4240,8 @@ TclNRTryObjCmd(
 			"must be \"", TclGetString(objv[0]),
 			" ... on code variableList script\"", NULL);
 		Tcl_DecrRefCount(handlersObj);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "ON",
+			"ARGUMENT", NULL);
 		return TCL_ERROR;
 	    }
 	    if (TCL_ERROR == TclGetCompletionCodeFromObj(interp, objv[i+1], &code)) {
@@ -4221,6 +4257,8 @@ TclNRTryObjCmd(
 			"must be \"... trap pattern variableList script\"",
 			NULL);
 		Tcl_DecrRefCount(handlersObj);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
+			"ARGUMENT", NULL);
 		return TCL_ERROR;
 	    }
 	    code = 1;
@@ -4229,6 +4267,8 @@ TclNRTryObjCmd(
 			"bad prefix '%s': must be a list",
 			Tcl_GetString(objv[i+1])));
 		Tcl_DecrRefCount(handlersObj);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "TRAP",
+			"EXNFORMAT", NULL);
 		return TCL_ERROR;
 	    }
 	    info[2] = objv[i+1];
@@ -4260,6 +4300,8 @@ TclNRTryObjCmd(
 		"last non-finally clause must not have a body of \"-\"",
 		NULL);
 	Tcl_DecrRefCount(handlersObj);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRY", "BADFALLTHROUGH",
+		NULL);
 	return TCL_ERROR;
     }
     if (!haveHandlers) {
diff --git a/generic/tclConfig.c b/generic/tclConfig.c
index 8d42e21..3ad5dfd 100644
--- a/generic/tclConfig.c
+++ b/generic/tclConfig.c
@@ -237,6 +237,8 @@ QueryConfigObjCmd(
 	 */
 
 	Tcl_SetResult(interp, "package not known", TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "FATAL", "PKGCFG_BASE",
+		Tcl_GetString(pkgName), NULL);
 	return TCL_ERROR;
     }
 
@@ -247,9 +249,11 @@ QueryConfigObjCmd(
 	    return TCL_ERROR;
 	}
 
-	if (Tcl_DictObjGet(interp, pkgDict, objv [2], &val) != TCL_OK
+	if (Tcl_DictObjGet(interp, pkgDict, objv[2], &val) != TCL_OK
 		|| val == NULL) {
 	    Tcl_SetResult(interp, "key not known", TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CONFIG",
+		    Tcl_GetString(objv[2]), NULL);
 	    return TCL_ERROR;
 	}
 
@@ -268,6 +272,7 @@ QueryConfigObjCmd(
 	if (!listPtr) {
 	    Tcl_SetResult(interp, "insufficient memory to create list",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 	    return TCL_ERROR;
 	}
 
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 69bd4d2..5e1efde 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -221,6 +221,8 @@ TclFindElement(
 		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 			    "list element in braces followed by \"%.*s\" "
 			    "instead of space", (int) (p2-p), p));
+		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
+			    NULL);
 		}
 		return TCL_ERROR;
 	    }
@@ -280,6 +282,8 @@ TclFindElement(
 		    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
 			    "list element in quotes followed by \"%.*s\" "
 			    "instead of space", (int) (p2-p), p));
+		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "JUNK",
+			    NULL);
 		}
 		return TCL_ERROR;
 	    }
@@ -297,12 +301,16 @@ TclFindElement(
 	    if (interp != NULL) {
 		Tcl_SetResult(interp, "unmatched open brace in list",
 			TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "BRACE",
+			NULL);
 	    }
 	    return TCL_ERROR;
 	} else if (inQuotes) {
 	    if (interp != NULL) {
 		Tcl_SetResult(interp, "unmatched open quote in list",
 			TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", "QUOTE",
+			NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -451,9 +459,6 @@ Tcl_SplitList(
 		&elSize, &brace);
 	length -= (list - prevList);
 	if (result != TCL_OK) {
-	    if (interp != NULL) {
-		Tcl_SetErrorCode(interp, "TCL", "VALUE", "LIST", NULL);
-	    }
 	    ckfree(argv);
 	    return result;
 	}
@@ -2119,10 +2124,9 @@ Tcl_PrintDouble(
     char *p, c;
     int exponent;
     int signum;
-    char* digits;
-    char* end;
-
-    int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int)sizeof(int));
+    char *digits;
+    char *end;
+    int *precisionPtr = Tcl_GetThreadData(&precisionKey, (int) sizeof(int));
 
     /*
      * Handle NaN.
@@ -2156,26 +2160,26 @@ Tcl_PrintDouble(
     
     if (*precisionPtr == 0) {
 	digits = TclDoubleDigits(value, -1, TCL_DD_SHORTEST,
-				 &exponent, &signum, &end);
+		&exponent, &signum, &end);
     } else {
 	/*
 	 * There are at least two possible interpretations for tcl_precision.
 	 *
 	 * The first is, "choose the decimal representation having
-	 * $tcl_precision digits of significance that is nearest to the
-	 * given number, breaking ties by rounding to even, and then
-	 * trimming trailing zeros." This gives the greatest possible
-	 * precision in the decimal string, but offers the anomaly that
-	 * [expr 0.1] will be "0.10000000000000001".
+	 * $tcl_precision digits of significance that is nearest to the given
+	 * number, breaking ties by rounding to even, and then trimming
+	 * trailing zeros." This gives the greatest possible precision in the
+	 * decimal string, but offers the anomaly that [expr 0.1] will be
+	 * "0.10000000000000001".
 	 *
-	 * The second is "choose the decimal representation having at
-	 * most $tcl_precision digits of significance that is nearest
-	 * to the given number. If no such representation converts
-	 * exactly to the given number, choose the one that is closest,
-	 * breaking ties by rounding to even. If more than one such
-	 * representation converts exactly to the given number, choose
-	 * the shortest, breaking ties in favour of the nearest, breaking
-	 * remaining ties in favour of the one ending in an even digit."
+	 * The second is "choose the decimal representation having at most
+	 * $tcl_precision digits of significance that is nearest to the given
+	 * number. If no such representation converts exactly to the given
+	 * number, choose the one that is closest, breaking ties by rounding
+	 * to even. If more than one such representation converts exactly to
+	 * the given number, choose the shortest, breaking ties in favour of
+	 * the nearest, breaking remaining ties in favour of the one ending in
+	 * an even digit."
 	 *
 	 * Tcl 8.4 implements the first of these, which gives rise to
 	 * anomalies in formatting:
@@ -2188,13 +2192,13 @@ Tcl_PrintDouble(
 	 * 9.9999999999999995e-08
 	 *
 	 * For human readability, it appears better to choose the second rule,
-	 * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we
-	 * prefer the first (the recommended zero value for tcl_precision
-	 * avoids the problem entirely).
+	 * and let [expr 0.1] return 0.1. But for 8.4 compatibility, we prefer
+	 * the first (the recommended zero value for tcl_precision avoids the
+	 * problem entirely).
 	 *
-	 * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the
-	 * method that allows floating point values to be shortened if
-	 * it can be done without loss of precision.
+	 * Uncomment TCL_DD_SHORTEN_FLAG in the next call to prefer the method
+	 * that allows floating point values to be shortened if it can be done
+	 * without loss of precision.
 	 */
 
 	digits = TclDoubleDigits(value, *precisionPtr,
@@ -2219,10 +2223,12 @@ Tcl_PrintDouble(
 		c = *++p;
 	    }
 	}
+
 	/*
 	 * Tcl 8.4 appears to format with at least a two-digit exponent;
 	 * preserve that behaviour when tcl_precision != 0
 	 */
+
 	if (*precisionPtr == 0) {
 	    sprintf(dst, "e%+d", exponent);
 	} else {
@@ -2410,6 +2416,7 @@ TclNeedSpace(
 	 * NOTE: Remove this if other Unicode spaces ever get accepted as
 	 * list-element separators.
 	 */
+
 	return 1;
     }
     switch (*end) {
@@ -2434,19 +2441,19 @@ TclNeedSpace(
  *	This procedure formats an integer into a sequence of decimal digit
  *	characters in a buffer. If the integer is negative, a minus sign is
  *	inserted at the start of the buffer. A null character is inserted at
- *	the end of the formatted characters. It is the caller's
- *	responsibility to ensure that enough storage is available. This
- *	procedure has the effect of sprintf(buffer, "%ld", n) but is faster
- *	as proven in benchmarks.  This is key to UpdateStringOfInt, which
- *	is a common path for a lot of code (e.g. int-indexed arrays).
+ *	the end of the formatted characters. It is the caller's responsibility
+ *	to ensure that enough storage is available. This procedure has the
+ *	effect of sprintf(buffer, "%ld", n) but is faster as proven in
+ *	benchmarks.  This is key to UpdateStringOfInt, which is a common path
+ *	for a lot of code (e.g. int-indexed arrays).
  *
  * Results:
  *	An integer representing the number of characters formatted, not
  *	including the terminating \0.
  *
  * Side effects:
- *	The formatted characters are written into the storage pointer to
- *	by the "buffer" argument.
+ *	The formatted characters are written into the storage pointer to by
+ *	the "buffer" argument.
  *
  *----------------------------------------------------------------------
  */
@@ -2733,7 +2740,7 @@ SetEndOffsetFromAny(
 	 */
 
 	if (isspace(UCHAR(bytes[4]))) {
-	    return TCL_ERROR;
+	    goto badIndexFormat;
 	}
 	if (Tcl_GetInt(interp, bytes+4, &offset) != TCL_OK) {
 	    return TCL_ERROR;
@@ -2746,6 +2753,7 @@ SetEndOffsetFromAny(
 	 * Conversion failed. Report the error.
 	 */
 
+    badIndexFormat:
 	if (interp != NULL) {
 	    Tcl_ResetResult(interp);
 	    Tcl_AppendResult(interp, "bad index \"", bytes,
@@ -2853,7 +2861,8 @@ ClearHash(
 
     for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
 	    hPtr = Tcl_NextHashEntry(&search)) {
-	Tcl_Obj *objPtr = (Tcl_Obj *) Tcl_GetHashValue(hPtr);
+	Tcl_Obj *objPtr = Tcl_GetHashValue(hPtr);
+
 	Tcl_DecrRefCount(objPtr);
 	Tcl_DeleteHashEntry(hPtr);
     }
@@ -2910,7 +2919,7 @@ static void
 FreeThreadHash(
     ClientData clientData)
 {
-    Tcl_HashTable *tablePtr = (Tcl_HashTable *) clientData;
+    Tcl_HashTable *tablePtr = clientData;
 
     ClearHash(tablePtr);
     Tcl_DeleteHashTable(tablePtr);
@@ -2996,8 +3005,7 @@ TclSetProcessGlobalValue(
     Tcl_IncrRefCount(newValue);
     cacheMap = GetThreadHash(&pgvPtr->key);
     ClearHash(cacheMap);
-    hPtr = Tcl_CreateHashEntry(cacheMap,
-	    INT2PTR(pgvPtr->epoch), &dummy);
+    hPtr = Tcl_CreateHashEntry(cacheMap, INT2PTR(pgvPtr->epoch), &dummy);
     Tcl_SetHashValue(hPtr, newValue);
     Tcl_MutexUnlock(&pgvPtr->mutex);
 }
@@ -3273,9 +3281,10 @@ TclReToGlob(
 
     if ((reStrLen >= 4) && (memcmp("***=", reStr, 4) == 0)) {
 	/*
-	 * At most, the glob pattern has length 2*reStrLen + 2 to
-	 * backslash escape every character and have * at each end.
+	 * At most, the glob pattern has length 2*reStrLen + 2 to backslash
+	 * escape every character and have * at each end.
 	 */
+
 	Tcl_DStringSetLength(dsPtr, reStrLen + 2);
 	dsStr = dsStrStart = Tcl_DStringValue(dsPtr);
 	*dsStr++ = '*';
@@ -3299,8 +3308,8 @@ TclReToGlob(
     }
 
     /*
-     * At most, the glob pattern has length reStrLen + 2 to account
-     * for possible * at each end.
+     * At most, the glob pattern has length reStrLen + 2 to account for
+     * possible * at each end.
      */
 
     Tcl_DStringSetLength(dsPtr, reStrLen + 2);
@@ -3310,9 +3319,8 @@ TclReToGlob(
      * Check for anchored REs (ie ^foo$), so we can use string equal if
      * possible. Do not alter the start of str so we can free it correctly.
      *
-     * Keep track of the last char being an unescaped star to prevent
-     * multiple instances.  Simpler than checking that the last star
-     * may be escaped.
+     * Keep track of the last char being an unescaped star to prevent multiple
+     * instances.  Simpler than checking that the last star may be escaped.
      */
 
     msg = NULL;
@@ -3420,6 +3428,7 @@ TclReToGlob(
 	 * Heuristic: if >1 non-anchoring *, the risk is large that glob
 	 * matching is slower than the RE engine, so report invalid.
 	 */
+
 	msg = "excessive recursive glob backtrack potential";
 	goto invalidGlob;
     }
-- 
cgit v0.12


From 86d9abcd45aaf8619a159ae299d8df3fd30f2acf Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 31 Mar 2011 10:04:07 +0000
Subject: TclClockOldscanObjCmd: More generation of errorCode information.

---
 ChangeLog                | 5 +++++
 generic/tclDate.c        | 8 ++++++++
 generic/tclGetDate.y     | 8 ++++++++
 generic/tclThreadAlloc.c | 0
 4 files changed, 21 insertions(+)
 mode change 100755 => 100644 generic/tclThreadAlloc.c

diff --git a/ChangeLog b/ChangeLog
index 8e81f98..e3d93dd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-03-31  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclGetDate.y, generic/tclDate.c (TclClockOldscanObjCmd):
+	More generation of errorCode information.
+
 2011-03-28  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More
diff --git a/generic/tclDate.c b/generic/tclDate.c
index 8aebbf3..14bac51 100644
--- a/generic/tclDate.c
+++ b/generic/tclDate.c
@@ -2800,10 +2800,12 @@ TclClockOldscanObjCmd(
     if (status == 1) {
 	Tcl_SetObjResult(interp, dateInfo.messages);
 	Tcl_DecrRefCount(dateInfo.messages);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL);
 	return TCL_ERROR;
     } else if (status == 2) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
 	Tcl_DecrRefCount(dateInfo.messages);
+	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 	return TCL_ERROR;
     } else if (status != 0) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
@@ -2811,6 +2813,7 @@ TclClockOldscanObjCmd(
 						  "report this error as a "
 						  "bug in Tcl.", -1));
 	Tcl_DecrRefCount(dateInfo.messages);
+	Tcl_SetErrorCode(interp, "TCL", "BUG", NULL);
 	return TCL_ERROR;
     }
     Tcl_DecrRefCount(dateInfo.messages);
@@ -2818,26 +2821,31 @@ TclClockOldscanObjCmd(
     if (yyHaveDate > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one date in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
     if (yyHaveTime > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one time of day in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
     if (yyHaveZone > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one time zone in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
     if (yyHaveDay > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one weekday in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
     if (yyHaveOrdinalMonth > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one ordinal month in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclGetDate.y b/generic/tclGetDate.y
index 720b71c..da4c3fd 100644
--- a/generic/tclGetDate.y
+++ b/generic/tclGetDate.y
@@ -1011,10 +1011,12 @@ TclClockOldscanObjCmd(
     if (status == 1) {
 	Tcl_SetObjResult(interp, dateInfo.messages);
 	Tcl_DecrRefCount(dateInfo.messages);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "PARSE", NULL);
 	return TCL_ERROR;
     } else if (status == 2) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj("memory exhausted", -1));
 	Tcl_DecrRefCount(dateInfo.messages);
+	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 	return TCL_ERROR;
     } else if (status != 0) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj("Unknown status returned "
@@ -1022,6 +1024,7 @@ TclClockOldscanObjCmd(
 						  "report this error as a "
 						  "bug in Tcl.", -1));
 	Tcl_DecrRefCount(dateInfo.messages);
+	Tcl_SetErrorCode(interp, "TCL", "BUG", NULL);
 	return TCL_ERROR;
     }
     Tcl_DecrRefCount(dateInfo.messages);
@@ -1029,26 +1032,31 @@ TclClockOldscanObjCmd(
     if (yyHaveDate > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one date in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
     if (yyHaveTime > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one time of day in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
     if (yyHaveZone > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one time zone in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
     if (yyHaveDay > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one weekday in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
     if (yyHaveOrdinalMonth > 1) {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("more than one ordinal month in string", -1));
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "DATE", "MULTIPLE", NULL);
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
old mode 100755
new mode 100644
-- 
cgit v0.12


From c8eb649431a107df0b9828649d96894768c00591 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Fri, 1 Apr 2011 09:29:24 +0000
Subject: Implement TIP#131

---
 ChangeLog        |  4 ++++
 library/init.tcl | 15 +++++++++++++++
 2 files changed, 19 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index e3d93dd..86ef9e4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-04-01  Reinhard Max  <max@suse.de>
+
+	* library/init.tcl: TIP#131 implementation.
+
 2011-03-31  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclGetDate.y, generic/tclDate.c (TclClockOldscanObjCmd):
diff --git a/library/init.tcl b/library/init.tcl
index 33b6b33..e6e69c3 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -821,3 +821,18 @@ proc tcl::CopyDirectory {action src dest} {
     }
     return
 }
+
+# TIP 131
+proc tcl::rmmadwiw {} {
+    set magic {
+        42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe
+        ff f5 fa f3 e1 c7 f9 f2 fd ff f9 fe f9 ed f4 fa f6 e6 f9 f2 e6 fd f9
+        ff f9 f6 e6 fa fd ff fc fb fc f9 f1 ed
+    }
+    foreach mystic [lassign $magic tragic] {
+        set comic [expr (0x$mystic ^ 0x$tragic) - 255 + 0x$tragic]
+        append logic [format %x $comic]
+        set tragic $mystic
+    }
+    binary format H* $logic
+}
-- 
cgit v0.12


From 4502b1fa0696dd647f8a38b72b8f689433bf98cd Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Fri, 1 Apr 2011 10:48:21 +0000
Subject: mathematical version of TIP#131

---
 library/init.tcl | 11 +++++++++++
 1 file changed, 11 insertions(+)

diff --git a/library/init.tcl b/library/init.tcl
index e6e69c3..d85fe2a 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -836,3 +836,14 @@ proc tcl::rmmadwiw {} {
     }
     binary format H* $logic
 }
+
+proc tcl::mathfunc::rmmadwiw {} {
+    set age [expr {9*6}]
+    set mind ""
+    while {$age} {
+        lappend mind [expr {$age%13}]
+        set age [expr {$age/13}]
+    }
+    set matter [lreverse $mind]
+    return [join $matter ""]
+}
-- 
cgit v0.12


From f4b7658650c49deb8518bb22558332a16264cdf6 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 2 Apr 2011 12:17:32 +0000
Subject: More generation of errorCode information (default [bgerror] and
 [glob]).

---
 ChangeLog             |  5 +++++
 generic/tclEvent.c    |  2 ++
 generic/tclFileName.c | 17 +++++++++++++++++
 3 files changed, 24 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 86ef9e4..f0d5bcc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-04-02  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclEvent.c, generic/tclFileName.c: More generation of
+	errorCode information (default [bgerror] and [glob]).
+
 2011-04-01  Reinhard Max  <max@suse.de>
 
 	* library/init.tcl: TIP#131 implementation.
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index a8bab0b..6816487 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -333,6 +333,7 @@ TclDefaultBgErrorHandlerObjCmd(
     if (valuePtr == NULL) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"missing return option \"-level\"", -1));
+	Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 	return TCL_ERROR;
     }
     if (Tcl_GetIntFromObj(interp, valuePtr, &level) == TCL_ERROR) {
@@ -345,6 +346,7 @@ TclDefaultBgErrorHandlerObjCmd(
     if (valuePtr == NULL) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"missing return option \"-code\"", -1));
+	Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 	return TCL_ERROR;
     }
     if (Tcl_GetIntFromObj(interp, valuePtr, &code) == TCL_ERROR) {
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index d53c271..05ecb04 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -1258,11 +1258,14 @@ Tcl_GlobObjCmd(
 	    if (i == (objc-1)) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			"missing argument to \"-directory\"", -1));
+		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 		return TCL_ERROR;
 	    }
 	    if (dir != PATH_NONE) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			"\"-directory\" cannot be used with \"-path\"", -1));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+			"BADOPTIONCOMBINATION", NULL);
 		return TCL_ERROR;
 	    }
 	    dir = PATH_DIR;
@@ -1280,11 +1283,14 @@ Tcl_GlobObjCmd(
 	    if (i == (objc-1)) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			"missing argument to \"-path\"", -1));
+		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 		return TCL_ERROR;
 	    }
 	    if (dir != PATH_NONE) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			"\"-path\" cannot be used with \"-directory\"", -1));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+			"BADOPTIONCOMBINATION", NULL);
 		return TCL_ERROR;
 	    }
 	    dir = PATH_GENERAL;
@@ -1295,6 +1301,7 @@ Tcl_GlobObjCmd(
 	    if (i == (objc-1)) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			"missing argument to \"-types\"", -1));
+		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 		return TCL_ERROR;
 	    }
 	    typePtr = objv[i+1];
@@ -1314,6 +1321,8 @@ Tcl_GlobObjCmd(
 	Tcl_AppendResult(interp,
 		"\"-tails\" must be used with either "
 		"\"-directory\" or \"-path\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB",
+		"BADOPTIONCOMBINATION", NULL);
 	return TCL_ERROR;
     }
 
@@ -1523,6 +1532,7 @@ Tcl_GlobObjCmd(
 		Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
 		Tcl_AppendObjToObj(resultPtr, look);
 		Tcl_SetObjResult(interp, resultPtr);
+		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
 		result = TCL_ERROR;
 		join = 0;
 		goto endOfGlob;
@@ -1532,6 +1542,7 @@ Tcl_GlobObjCmd(
 			"only one MacOS type or creator argument"
 			" to \"-types\" allowed", -1));
 		result = TCL_ERROR;
+		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
 		join = 0;
 		goto endOfGlob;
 	    }
@@ -1620,6 +1631,8 @@ Tcl_GlobObjCmd(
 		}
 	    }
 	    Tcl_AppendResult(interp, "\"", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "NOMATCH",
+		    NULL);
 	    result = TCL_ERROR;
 	}
     }
@@ -2250,11 +2263,15 @@ DoGlob(
 	    }
 	    Tcl_SetResult(interp, "unmatched open-brace in file name",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
+		    NULL);
 	    return TCL_ERROR;
 
 	} else if (*p == '}') {
 	    Tcl_SetResult(interp, "unmatched close-brace in file name",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "GLOB", "BALANCE",
+		    NULL);
 	    return TCL_ERROR;
 	}
     }
-- 
cgit v0.12


From d2275aefb3bc8e96e7ae22e4609ba2c7604f86fe Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 2 Apr 2011 17:22:01 +0000
Subject: More generation of errorCodes ([interp], [lset], [load], [unload]).

---
 ChangeLog            |   3 +
 generic/tclInterp.c  | 161 +++++++++++++++++++++++++--------------------------
 generic/tclListObj.c |   6 ++
 generic/tclLoad.c    |  36 +++++++++++-
 4 files changed, 122 insertions(+), 84 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f0d5bcc..3179b6e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
 2011-04-02  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclInterp.c, generic/tclListObj.c, generic/tclLoad.c:
+	More generation of errorCodes ([interp], [lset], [load], [unload]).
+
 	* generic/tclEvent.c, generic/tclFileName.c: More generation of
 	errorCode information (default [bgerror] and [glob]).
 
diff --git a/generic/tclInterp.c b/generic/tclInterp.c
index 67761ed..a156a57 100644
--- a/generic/tclInterp.c
+++ b/generic/tclInterp.c
@@ -300,8 +300,8 @@ Tcl_Init(
 {
     if (tclPreInitScript != NULL) {
 	if (Tcl_Eval(interp, tclPreInitScript) == TCL_ERROR) {
-	    return (TCL_ERROR);
-	};
+	    return TCL_ERROR;
+	}
     }
 
     /*
@@ -559,6 +559,7 @@ Tcl_InterpObjCmd(
     int objc,				/* Number of arguments. */
     Tcl_Obj *const objv[])		/* Argument objects. */
 {
+    Tcl_Interp *slaveInterp;
     int index;
     static const char *const options[] = {
 	"alias",	"aliases",	"bgerror",	"cancel",
@@ -588,7 +589,7 @@ Tcl_InterpObjCmd(
     }
     switch ((enum option) index) {
     case OPT_ALIAS: {
-	Tcl_Interp *slaveInterp, *masterInterp;
+	Tcl_Interp *masterInterp;
 
 	if (objc < 4) {
 	aliasArgs:
@@ -622,18 +623,13 @@ Tcl_InterpObjCmd(
 	}
 	goto aliasArgs;
     }
-    case OPT_ALIASES: {
-	Tcl_Interp *slaveInterp;
-
+    case OPT_ALIASES:
 	slaveInterp = GetInterp2(interp, objc, objv);
 	if (slaveInterp == NULL) {
 	    return TCL_ERROR;
 	}
 	return AliasList(interp, slaveInterp);
-    }
-    case OPT_BGERROR: {
-	Tcl_Interp *slaveInterp;
-
+    case OPT_BGERROR:
 	if (objc != 3 && objc != 4) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "path ?cmdPrefix?");
 	    return TCL_ERROR;
@@ -643,10 +639,8 @@ Tcl_InterpObjCmd(
 	    return TCL_ERROR;
 	}
 	return SlaveBgerror(interp, slaveInterp, objc - 3, objv + 3);
-    }
     case OPT_CANCEL: {
 	int i, flags;
-	Tcl_Interp *slaveInterp;
 	Tcl_Obj *resultObjPtr;
 	static const char *const cancelOptions[] = {
 	    "-unwind",	"--",	NULL
@@ -680,8 +674,7 @@ Tcl_InterpObjCmd(
 	    }
 	}
 
-	endOfForLoop:
-
+    endOfForLoop:
 	if ((i + 2) < objc) {
 	    Tcl_WrongNumArgs(interp, 2, objv,
 		    "?-unwind? ?--? ?path? ?result?");
@@ -689,35 +682,34 @@ Tcl_InterpObjCmd(
 	}
 
 	/*
-	 * Did they specify a slave interp to cancel the script in
-	 * progress in?  If not, use the current interp.
+	 * Did they specify a slave interp to cancel the script in progress
+	 * in?  If not, use the current interp.
 	 */
 
 	if (i < objc) {
 	    slaveInterp = GetInterp(interp, objv[i]);
+	    if (slaveInterp == NULL) {
+		return TCL_ERROR;
+	    }
 	    i++;
 	} else {
 	    slaveInterp = interp;
 	}
 
-	if (slaveInterp != NULL) {
-	    if (i < objc) {
-		resultObjPtr = objv[i];
-
-		/*
-		 * Tcl_CancelEval removes this reference.
-		 */
+	if (i < objc) {
+	    resultObjPtr = objv[i];
 
-		Tcl_IncrRefCount(resultObjPtr);
-		i++;
-	    } else {
-		resultObjPtr = NULL;
-	    }
+	    /*
+	     * Tcl_CancelEval removes this reference.
+	     */
 
-	    return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
+	    Tcl_IncrRefCount(resultObjPtr);
+	    i++;
 	} else {
-	    return TCL_ERROR;
+	    resultObjPtr = NULL;
 	}
+
+	return Tcl_CancelEval(slaveInterp, resultObjPtr, 0, flags);
     }
     case OPT_CREATE: {
 	int i, last, safe;
@@ -787,13 +779,11 @@ Tcl_InterpObjCmd(
 	Tcl_SetObjResult(interp, slavePtr);
 	return TCL_OK;
     }
-    case OPT_DEBUG: {
-	/* TIP #378 */
-	Tcl_Interp *slaveInterp;
-
+    case OPT_DEBUG:		/* TIP #378 */
 	/*
 	 * Currently only -frame supported, otherwise ?-option ?value??
 	 */
+
 	if (objc < 3 || objc > 5) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "path ?-frame ?bool??");
 	    return TCL_ERROR;
@@ -803,11 +793,9 @@ Tcl_InterpObjCmd(
 	    return TCL_ERROR;
 	}
 	return SlaveDebugCmd(interp, slaveInterp, objc - 3, objv + 3);
-    }
     case OPT_DELETE: {
 	int i;
 	InterpInfo *iiPtr;
-	Tcl_Interp *slaveInterp;
 
 	for (i = 2; i < objc; i++) {
 	    slaveInterp = GetInterp(interp, objv[i]);
@@ -816,6 +804,8 @@ Tcl_InterpObjCmd(
 	    } else if (slaveInterp == interp) {
 		Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			"cannot delete the current interpreter", -1));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+			"DELETESELF", NULL);
 		return TCL_ERROR;
 	    }
 	    iiPtr = (InterpInfo *) ((Interp *) slaveInterp)->interpInfo;
@@ -824,9 +814,7 @@ Tcl_InterpObjCmd(
 	}
 	return TCL_OK;
     }
-    case OPT_EVAL: {
-	Tcl_Interp *slaveInterp;
-
+    case OPT_EVAL:
 	if (objc < 4) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "path arg ?arg ...?");
 	    return TCL_ERROR;
@@ -836,12 +824,9 @@ Tcl_InterpObjCmd(
 	    return TCL_ERROR;
 	}
 	return SlaveEval(interp, slaveInterp, objc - 3, objv + 3);
-    }
     case OPT_EXISTS: {
-	int exists;
-	Tcl_Interp *slaveInterp;
+	int exists = 1;
 
-	exists = 1;
 	slaveInterp = GetInterp2(interp, objc, objv);
 	if (slaveInterp == NULL) {
 	    if (objc > 3) {
@@ -853,9 +838,7 @@ Tcl_InterpObjCmd(
 	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(exists));
 	return TCL_OK;
     }
-    case OPT_EXPOSE: {
-	Tcl_Interp *slaveInterp;
-
+    case OPT_EXPOSE:
 	if ((objc < 4) || (objc > 5)) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "path hiddenCmdName ?cmdName?");
 	    return TCL_ERROR;
@@ -865,10 +848,7 @@ Tcl_InterpObjCmd(
 	    return TCL_ERROR;
 	}
 	return SlaveExpose(interp, slaveInterp, objc - 3, objv + 3);
-    }
-    case OPT_HIDE: {
-	Tcl_Interp *slaveInterp;		/* A slave. */
-
+    case OPT_HIDE:
 	if ((objc < 4) || (objc > 5)) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "path cmdName ?hiddenCmdName?");
 	    return TCL_ERROR;
@@ -878,30 +858,22 @@ Tcl_InterpObjCmd(
 	    return TCL_ERROR;
 	}
 	return SlaveHide(interp, slaveInterp, objc - 3, objv + 3);
-    }
-    case OPT_HIDDEN: {
-	Tcl_Interp *slaveInterp;		/* A slave. */
-
+    case OPT_HIDDEN:
 	slaveInterp = GetInterp2(interp, objc, objv);
 	if (slaveInterp == NULL) {
 	    return TCL_ERROR;
 	}
 	return SlaveHidden(interp, slaveInterp);
-    }
-    case OPT_ISSAFE: {
-	Tcl_Interp *slaveInterp;
-
+    case OPT_ISSAFE:
 	slaveInterp = GetInterp2(interp, objc, objv);
 	if (slaveInterp == NULL) {
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, Tcl_NewBooleanObj(Tcl_IsSafe(slaveInterp)));
 	return TCL_OK;
-    }
     case OPT_INVOKEHID: {
 	int i;
 	const char *namespaceName;
-	Tcl_Interp *slaveInterp;
 	static const char *const hiddenOptions[] = {
 	    "-global",	"-namespace",	"--", NULL
 	};
@@ -944,7 +916,6 @@ Tcl_InterpObjCmd(
 		objv + i);
     }
     case OPT_LIMIT: {
-	Tcl_Interp *slaveInterp;
 	static const char *const limitTypes[] = {
 	    "commands", "time", NULL
 	};
@@ -973,9 +944,7 @@ Tcl_InterpObjCmd(
 	    return SlaveTimeLimitCmd(interp, slaveInterp, 4, objc, objv);
 	}
     }
-    case OPT_MARKTRUSTED: {
-	Tcl_Interp *slaveInterp;
-
+    case OPT_MARKTRUSTED:
 	if (objc != 3) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "path");
 	    return TCL_ERROR;
@@ -985,10 +954,7 @@ Tcl_InterpObjCmd(
 	    return TCL_ERROR;
 	}
 	return SlaveMarkTrusted(interp, slaveInterp);
-    }
-    case OPT_RECLIMIT: {
-	Tcl_Interp *slaveInterp;
-
+    case OPT_RECLIMIT:
 	if (objc != 3 && objc != 4) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "path ?newlimit?");
 	    return TCL_ERROR;
@@ -998,9 +964,7 @@ Tcl_InterpObjCmd(
 	    return TCL_ERROR;
 	}
 	return SlaveRecursionLimit(interp, slaveInterp, objc - 3, objv + 3);
-    }
     case OPT_SLAVES: {
-	Tcl_Interp *slaveInterp;
 	InterpInfo *iiPtr;
 	Tcl_Obj *resultPtr;
 	Tcl_HashEntry *hPtr;
@@ -1024,8 +988,7 @@ Tcl_InterpObjCmd(
     }
     case OPT_TRANSFER:
     case OPT_SHARE: {
-	Tcl_Interp *slaveInterp;		/* A slave. */
-	Tcl_Interp *masterInterp;		/* Its master. */
+	Tcl_Interp *masterInterp;	/* The master of the slave. */
 	Tcl_Channel chan;
 
 	if (objc != 5) {
@@ -1060,7 +1023,6 @@ Tcl_InterpObjCmd(
 	return TCL_OK;
     }
     case OPT_TARGET: {
-	Tcl_Interp *slaveInterp;
 	InterpInfo *iiPtr;
 	Tcl_HashEntry *hPtr;
 	Alias *aliasPtr;
@@ -1093,6 +1055,8 @@ Tcl_InterpObjCmd(
 	    Tcl_AppendResult(interp, "target interpreter for alias \"",
 		    aliasName, "\" in path \"", Tcl_GetString(objv[2]),
 		    "\" is not my descendant", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+		    "TARGETSHROUDED", NULL);
 	    return TCL_ERROR;
 	}
 	return TCL_OK;
@@ -1437,6 +1401,8 @@ TclPreventAliasLoop(
 	    Tcl_AppendResult(interp, "cannot define or rename alias \"",
 		    Tcl_GetCommandName(cmdInterp, cmd),
 		    "\": would create a loop", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+		    "ALIASLOOP", NULL);
 	    return TCL_ERROR;
 	}
 
@@ -2292,6 +2258,8 @@ SlaveBgerror(
 		|| (length < 1)) {
 	    Tcl_AppendResult(interp, "cmdPrefix must be list of length >= 1",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+		    "BGERRORFORMAT", NULL);
 	    return TCL_ERROR;
 	}
 	TclSetBgErrorHandler(slaveInterp, objv[0]);
@@ -2728,8 +2696,8 @@ SlaveDebugCmd(
 		Tcl_NewBooleanObj(iPtr->flags & INTERP_DEBUG_FRAME));
 	Tcl_SetObjResult(interp, resultPtr);
     } else {
-	if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes,
-			"debug option", 0, &debugType) != TCL_OK) {
+	if (Tcl_GetIndexFromObj(interp, objv[0], debugTypes, "debug option",
+		0, &debugType) != TCL_OK) {
 	    return TCL_ERROR;
 	}
 	if (debugType == DEBUG_TYPE_FRAME) {
@@ -2738,11 +2706,13 @@ SlaveDebugCmd(
 			!= TCL_OK) {
 		    return TCL_ERROR;
 		}
+
 		/*
-		 * Quietly ignore attempts to disable interp debugging.
-		 * This is a one-way switch as frame debug info is maintained
-		 * in a stack that must be consistent once turned on.
+		 * Quietly ignore attempts to disable interp debugging.  This
+		 * is a one-way switch as frame debug info is maintained in a
+		 * stack that must be consistent once turned on.
 		 */
+
 		if (debugType) {
 		    iPtr->flags |= INTERP_DEBUG_FRAME;
 		}
@@ -2847,6 +2817,8 @@ SlaveExpose(
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"permission denied: safe interpreter cannot expose commands",
 		-1));
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+		NULL);
 	return TCL_ERROR;
     }
 
@@ -2890,6 +2862,8 @@ SlaveRecursionLimit(
 	if (Tcl_IsSafe(interp)) {
 	    Tcl_AppendResult(interp, "permission denied: "
 		    "safe interpreters cannot change recursion limit", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	if (TclGetIntFromObj(interp, objv[0], &limit) == TCL_ERROR) {
@@ -2898,6 +2872,8 @@ SlaveRecursionLimit(
 	if (limit <= 0) {
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		    "recursion limit must be > 0", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "BADLIMIT",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	Tcl_SetRecursionLimit(slaveInterp, limit);
@@ -2905,6 +2881,7 @@ SlaveRecursionLimit(
 	if (interp == slaveInterp && iPtr->numLevels > limit) {
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		    "falling back due to new recursion limit", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "RECURSION", NULL);
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, objv[0]);
@@ -2946,6 +2923,8 @@ SlaveHide(
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"permission denied: safe interpreter cannot hide commands",
 		-1));
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+		NULL);
 	return TCL_ERROR;
     }
 
@@ -3028,6 +3007,8 @@ SlaveInvokeHidden(
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"not allowed to invoke hidden commands from safe interpreter",
 		-1));
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+		NULL);
 	return TCL_ERROR;
     }
 
@@ -3082,6 +3063,8 @@ SlaveMarkTrusted(
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		"permission denied: safe interpreter cannot mark trusted",
 		-1));
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP", "UNSAFE",
+		NULL);
 	return TCL_ERROR;
     }
     ((Interp *) slaveInterp)->flags &= ~SAFE_INTERP;
@@ -3339,6 +3322,7 @@ Tcl_LimitCheck(
 	} else if (iPtr->limit.exceeded & TCL_LIMIT_COMMANDS) {
 	    Tcl_ResetResult(interp);
 	    Tcl_AppendResult(interp, "command count limit exceeded", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LIMIT", "COMMANDS", NULL);
 	    Tcl_Release(interp);
 	    return TCL_ERROR;
 	}
@@ -3364,6 +3348,7 @@ Tcl_LimitCheck(
 	    } else if (iPtr->limit.exceeded & TCL_LIMIT_TIME) {
 		Tcl_ResetResult(interp);
 		Tcl_AppendResult(interp, "time limit exceeded", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "LIMIT", "TIME", NULL);
 		Tcl_Release(interp);
 		return TCL_ERROR;
 	    }
@@ -4429,8 +4414,7 @@ SlaveCommandLimitCmd(
 	}
 	return TCL_OK;
     } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
-	Tcl_WrongNumArgs(interp, consumedObjc, objv,
-		"?-option value ...?");
+	Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
 	return TCL_ERROR;
     } else {
 	int i, scriptLen = 0, limitLen = 0;
@@ -4455,6 +4439,8 @@ SlaveCommandLimitCmd(
 		if (gran < 1) {
 		    Tcl_AppendResult(interp, "granularity must be at "
 			    "least 1", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+			    "BADVALUE", NULL);
 		    return TCL_ERROR;
 		}
 		break;
@@ -4470,6 +4456,8 @@ SlaveCommandLimitCmd(
 		if (limit < 0) {
 		    Tcl_AppendResult(interp, "command limit value must be at "
 			    "least 0", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+			    "BADVALUE", NULL);
 		    return TCL_ERROR;
 		}
 		break;
@@ -4617,8 +4605,7 @@ SlaveTimeLimitCmd(
 	}
 	return TCL_OK;
     } else if ((objc-consumedObjc) & 1 /* isOdd(objc-consumedObjc) */) {
-	Tcl_WrongNumArgs(interp, consumedObjc, objv,
-		"?-option value ...?");
+	Tcl_WrongNumArgs(interp, consumedObjc, objv, "?-option value ...?");
 	return TCL_ERROR;
     } else {
 	int i, scriptLen = 0, milliLen = 0, secLen = 0;
@@ -4647,6 +4634,8 @@ SlaveTimeLimitCmd(
 		if (gran < 1) {
 		    Tcl_AppendResult(interp, "granularity must be at "
 			    "least 1", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+			    "BADVALUE", NULL);
 		    return TCL_ERROR;
 		}
 		break;
@@ -4662,6 +4651,8 @@ SlaveTimeLimitCmd(
 		if (tmp < 0) {
 		    Tcl_AppendResult(interp, "milliseconds must be at least 0",
 			    NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+			    "BADVALUE", NULL);
 		    return TCL_ERROR;
 		}
 		limitMoment.usec = ((long)tmp)*1000;
@@ -4678,6 +4669,8 @@ SlaveTimeLimitCmd(
 		if (tmp < 0) {
 		    Tcl_AppendResult(interp, "seconds must be at least 0",
 			    NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+			    "BADVALUE", NULL);
 		    return TCL_ERROR;
 		}
 		limitMoment.sec = tmp;
@@ -4694,11 +4687,15 @@ SlaveTimeLimitCmd(
 		if (secObj != NULL && secLen == 0 && milliLen > 0) {
 		    Tcl_AppendResult(interp, "may only set -milliseconds "
 			    "if -seconds is not also being reset", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+			    "BADUSAGE", NULL);
 		    return TCL_ERROR;
 		}
 		if (milliLen == 0 && (secObj == NULL || secLen > 0)) {
 		    Tcl_AppendResult(interp, "may only reset -milliseconds "
 			    "if -seconds is also being reset", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "INTERP",
+			    "BADUSAGE", NULL);
 		    return TCL_ERROR;
 		}
 	    }
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index b27163d..9128333 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -1339,6 +1339,8 @@ TclLsetFlat(
 	    /* ...the index points outside the sublist. */
 	    Tcl_SetObjResult(interp,
 		    Tcl_NewStringObj("list index out of range", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+		    NULL);
 	    break;
 	}
 
@@ -1511,6 +1513,8 @@ TclListObjSetElement(
 	if (!length) {
 	    Tcl_SetObjResult(interp,
 		    Tcl_NewStringObj("list index out of range", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	result = SetListFromAny(interp, listPtr);
@@ -1531,6 +1535,8 @@ TclListObjSetElement(
 	if (interp != NULL) {
 	    Tcl_SetObjResult(interp,
 		    Tcl_NewStringObj("list index out of range", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
+		    NULL);
 	}
 	return TCL_ERROR;
     }
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 371a437..707d6ec 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -160,6 +160,8 @@ Tcl_LoadObjCmd(
 	Tcl_SetResult(interp,
 		"must specify either file name or package name",
 		TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOLIBRARY",
+		NULL);
 	code = TCL_ERROR;
 	goto done;
     }
@@ -226,6 +228,8 @@ Tcl_LoadObjCmd(
 	    Tcl_AppendResult(interp, "file \"", fullFileName,
 		    "\" is already loaded for package \"",
 		    pkgPtr->packageName, "\"", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
+		    "SPLITPERSONALITY", NULL);
 	    code = TCL_ERROR;
 	    Tcl_MutexUnlock(&packageMutex);
 	    goto done;
@@ -261,6 +265,8 @@ Tcl_LoadObjCmd(
 	if (fullFileName[0] == 0) {
 	    Tcl_AppendResult(interp, "package \"", packageName,
 		    "\" isn't loaded statically", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "NOTSTATIC",
+		    NULL);
 	    code = TCL_ERROR;
 	    goto done;
 	}
@@ -312,6 +318,8 @@ Tcl_LoadObjCmd(
 		    Tcl_AppendResult(interp,
 			    "couldn't figure out package name for ",
 			    fullFileName, NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD",
+			    "WHATPACKAGE", NULL);
 		    code = TCL_ERROR;
 		    goto done;
 		}
@@ -407,11 +415,22 @@ Tcl_LoadObjCmd(
 	    Tcl_AppendResult(interp,
 		    "can't use package in a safe interpreter: no ",
 		    pkgPtr->packageName, "_SafeInit procedure", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "UNSAFE",
+		    NULL);
 	    code = TCL_ERROR;
 	    goto done;
 	}
 	code = pkgPtr->safeInitProc(target);
     } else {
+	if (pkgPtr->initProc == NULL) {
+	    Tcl_AppendResult(interp,
+		    "can't attach package to interpreter: no ",
+		    pkgPtr->packageName, "_Init procedure", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LOAD", "ENTRYPOINT",
+		    NULL);
+	    code = TCL_ERROR;
+	    goto done;
+	}
 	code = pkgPtr->initProc(target);
     }
 
@@ -555,6 +574,8 @@ Tcl_UnloadObjCmd(
 	Tcl_SetResult(interp,
 		"must specify either file name or package name",
 		TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NOLIBRARY",
+		NULL);
 	code = TCL_ERROR;
 	goto done;
     }
@@ -626,6 +647,8 @@ Tcl_UnloadObjCmd(
 
 	Tcl_AppendResult(interp, "package \"", packageName,
 		"\" is loaded statically and cannot be unloaded", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "STATIC",
+		NULL);
 	code = TCL_ERROR;
 	goto done;
     }
@@ -636,6 +659,8 @@ Tcl_UnloadObjCmd(
 
 	Tcl_AppendResult(interp, "file \"", fullFileName,
 		"\" has never been loaded", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
+		NULL);
 	code = TCL_ERROR;
 	goto done;
     }
@@ -663,6 +688,8 @@ Tcl_UnloadObjCmd(
 
 	Tcl_AppendResult(interp, "file \"", fullFileName,
 		"\" has never been loaded in this interpreter", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "NEVERLOADED",
+		NULL);
 	code = TCL_ERROR;
 	goto done;
     }
@@ -677,6 +704,8 @@ Tcl_UnloadObjCmd(
 	if (pkgPtr->safeUnloadProc == NULL) {
 	    Tcl_AppendResult(interp, "file \"", fullFileName,
 		    "\" cannot be unloaded under a safe interpreter", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+		    NULL);
 	    code = TCL_ERROR;
 	    goto done;
 	}
@@ -685,6 +714,8 @@ Tcl_UnloadObjCmd(
 	if (pkgPtr->unloadProc == NULL) {
 	    Tcl_AppendResult(interp, "file \"", fullFileName,
 		    "\" cannot be unloaded under a trusted interpreter", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "CANNOT",
+		    NULL);
 	    code = TCL_ERROR;
 	    goto done;
 	}
@@ -771,8 +802,7 @@ Tcl_UnloadObjCmd(
 	 */
 
 	if (pkgPtr->fileName[0] != '\0') {
-
-		Tcl_MutexLock(&packageMutex);
+	    Tcl_MutexLock(&packageMutex);
 	    if (Tcl_FSUnloadFile(interp, pkgPtr->loadHandle) == TCL_OK) {
 		/*
 		 * Remove this library from the loaded library cache.
@@ -824,6 +854,8 @@ Tcl_UnloadObjCmd(
 #else
 	Tcl_AppendResult(interp, "file \"", fullFileName,
 		"\" cannot be unloaded: unloading disabled", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "UNLOAD", "DISABLED",
+		NULL);
 	code = TCL_ERROR;
 #endif
     }
-- 
cgit v0.12


From 2205a28b9e00ec29977d2b21e2f2bda3b77aaaf4 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 3 Apr 2011 06:05:13 +0000
Subject: More generation of error codes (namespace creation, path
 normalization, pipeline creation, package handling, procedures, [scan]
 formats)

---
 ChangeLog            |  8 +++++++
 generic/tclNamesp.c  |  4 ++++
 generic/tclObj.c     |  2 ++
 generic/tclPathObj.c |  6 +++++
 generic/tclPipe.c    | 18 ++++++++++++++
 generic/tclPkg.c     | 44 +++++++++++++++++++++++-----------
 generic/tclProc.c    | 68 ++++++++++++++++++++++++++++++++++++++--------------
 generic/tclResult.c  | 15 +++++++-----
 generic/tclScan.c    | 11 +++++++++
 tests/ioCmd.test     |  6 ++---
 10 files changed, 141 insertions(+), 41 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 23b3f1e..b734896 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2011-04-03  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c:
+	* generic/tclPipe.c, generic/tclPkg.c, generic/tclProc.c:
+	* generic/tclScan.c: More generation of error codes (namespace
+	creation, path normalization, pipeline creation, package handling,
+	procedures, [scan] formats)
+
 2011-04-02  Kevin B. Kenny  <kennykb@acm.org>
 
 	* generic/tclStrToD.c (QuickConversion): Replaced another couple
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 3a08221..45b9f6d 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -690,6 +690,8 @@ Tcl_CreateNamespace(
 	Tcl_ResetResult(interp);
 	Tcl_AppendResult(interp, "can't create namespace \"\": "
 		"only global namespace can have empty name", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+                "CREATEGLOBAL", NULL);
 	return NULL;
     } else {
 	/*
@@ -725,6 +727,8 @@ Tcl_CreateNamespace(
 	) {
 	    Tcl_AppendResult(interp, "can't create namespace \"", name,
 		    "\": already exists", NULL);
+            Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NAMESPACE",
+                    "CREATEEXISTING", NULL);
 	    return NULL;
 	}
     }
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 321ed67..630226f 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -2265,6 +2265,8 @@ Tcl_GetDoubleFromObj(
 		if (interp != NULL) {
 		    Tcl_SetObjResult(interp, Tcl_NewStringObj(
 			    "floating point value is Not a Number", -1));
+                    Tcl_SetErrorCode(interp, "TCL", "VALUE", "DOUBLE", "NAN",
+                            NULL);
 		}
 		return TCL_ERROR;
 	    }
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 81007a2..01a297b 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -1523,6 +1523,8 @@ TclFSMakePathFromNormalized(
 		    Tcl_ResetResult(interp);
 		    Tcl_AppendResult(interp, "can't find object"
 			    "string representation", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "WTF",
+			    NULL);
 		}
 		return TCL_ERROR;
 	    }
@@ -2423,6 +2425,8 @@ SetFsPathFromAny(
 		    Tcl_ResetResult(interp);
 		    Tcl_AppendResult(interp, "couldn't find HOME environment "
 			    "variable to expand path", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH",
+			    "HOMELESS", NULL);
 		}
 		return TCL_ERROR;
 	    }
@@ -2440,6 +2444,8 @@ SetFsPathFromAny(
 		    Tcl_ResetResult(interp);
 		    Tcl_AppendResult(interp, "user \"", name+1,
 			    "\" doesn't exist", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "PATH", "NOUSER",
+			    NULL);
 		}
 		Tcl_DStringFree(&temp);
 		if (split != len) {
diff --git a/generic/tclPipe.c b/generic/tclPipe.c
index c24d136..5f59c38 100644
--- a/generic/tclPipe.c
+++ b/generic/tclPipe.c
@@ -109,6 +109,8 @@ FileForRedirect(
 		Tcl_AppendResult(interp, "channel \"",
 			Tcl_GetChannelName(chan), "\" wasn't opened for ",
 			((writing) ? "writing" : "reading"), NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+			"BADCHAN", NULL);
 	    }
 	    return NULL;
 	}
@@ -151,6 +153,7 @@ FileForRedirect(
   badLastArg:
     Tcl_AppendResult(interp, "can't specify \"", arg,
 	    "\" as last word in command", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "SYNTAX", NULL);
     return NULL;
 }
 
@@ -342,6 +345,8 @@ TclCleanupChildren(
 		} else {
 		    Tcl_AppendResult(interp,
 			    "child wait status didn't make sense\n", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+			    "ODDWAITRESULT", msg1, NULL);
 		}
 	    }
 	}
@@ -539,6 +544,8 @@ TclCreatePipeline(
 		if ((i == (lastBar + 1)) || (i == (argc - 1))) {
 		    Tcl_SetResult(interp, "illegal use of | or |& in command",
 			    TCL_STATIC);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+			    "PIPESYNTAX", NULL);
 		    goto error;
 		}
 	    }
@@ -565,6 +572,8 @@ TclCreatePipeline(
 		    if (inputLiteral == NULL) {
 			Tcl_AppendResult(interp, "can't specify \"", argv[i],
 				"\" as last word in command", NULL);
+			Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+				"PIPESYNTAX", NULL);
 			goto error;
 		    }
 		    skip = 2;
@@ -673,6 +682,8 @@ TclCreatePipeline(
 		if (i != argc-1) {
 		    Tcl_AppendResult(interp, "must specify \"", argv[i],
 			    "\" as last word in command", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+			    "PIPESYNTAX", NULL);
 		    goto error;
 		}
 		errorFile = outputFile;
@@ -713,6 +724,8 @@ TclCreatePipeline(
 
 	Tcl_SetResult(interp, "illegal use of | or |& in command",
 		TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "PIPESYNTAX",
+		NULL);
 	goto error;
     }
 
@@ -1063,11 +1076,15 @@ Tcl_OpenCommandChannel(
 	if ((flags & TCL_STDOUT) && (outPipe == NULL)) {
 	    Tcl_AppendResult(interp, "can't read output from command:"
 		    " standard output was redirected", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+		    "BADREDIRECT", NULL);
 	    goto error;
 	}
 	if ((flags & TCL_STDIN) && (inPipe == NULL)) {
 	    Tcl_AppendResult(interp, "can't write input to command:"
 		    " standard input was redirected", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC",
+		    "BADREDIRECT", NULL);
 	    goto error;
 	}
     }
@@ -1078,6 +1095,7 @@ Tcl_OpenCommandChannel(
     if (channel == NULL) {
 	Tcl_AppendResult(interp, "pipe for command could not be created",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "NOPIPE", NULL);
 	goto error;
     }
     return channel;
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 53be4af..67503cb 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -156,6 +156,7 @@ Tcl_PkgProvideEx(
     }
     Tcl_AppendResult(interp, "conflicting versions provided for package \"",
 	    name, "\": ", pkgPtr->version, ", then ", version, NULL);
+    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT", NULL);
     return TCL_ERROR;
 }
 
@@ -286,6 +287,7 @@ Tcl_PkgRequireEx(
 	Tcl_AppendResult(interp, "Cannot load package \"", name,
 		"\" in standalone executable: This package is not "
 		"compiled with stub support", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNSTUBBED", NULL);
 	return NULL;
     }
 
@@ -376,6 +378,7 @@ PkgRequireCore(
 		    "attempt to provide ", name, " ",
 		    (char *) pkgPtr->clientData, " requires ", name, NULL);
 	    AddRequirementsToResult(interp, reqc, reqv);
+	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "CIRCULARITY", NULL);
 	    return NULL;
 	}
 
@@ -422,7 +425,9 @@ PkgRequireCore(
 		}
 	    }
 
-	    /* We have found a version which is better than our max. */
+	    /*
+	     * We have found a version which is better than our max.
+	     */
 
 	    if (reqc > 0) {
 		/* Check satisfaction of requirements. */
@@ -493,6 +498,8 @@ PkgRequireCore(
 			    name, " ", versionToProvide,
 			    " failed: no version of package ", name,
 			    " provided", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNPROVIDED",
+			    NULL);
 		} else {
 		    char *pvi, *vi;
 
@@ -515,6 +522,8 @@ PkgRequireCore(
 				    versionToProvide, " failed: package ",
 				    name, " ", pkgPtr->version,
 				    " provided instead", NULL);
+			    Tcl_SetErrorCode(interp, "TCL", "PACKAGE",
+				    "WRONGPROVIDE", NULL);
 			}
 		    }
 		}
@@ -525,6 +534,7 @@ PkgRequireCore(
 		Tcl_AppendResult(interp, "attempt to provide package ", name,
 			" ", versionToProvide, " failed: bad return code: ",
 			TclGetString(codePtr), NULL);
+		Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
 		TclDecrRefCount(codePtr);
 		code = TCL_ERROR;
 	    }
@@ -582,9 +592,11 @@ PkgRequireCore(
 
 	    if ((code != TCL_OK) && (code != TCL_ERROR)) {
 		Tcl_Obj *codePtr = Tcl_NewIntObj(code);
+
 		Tcl_ResetResult(interp);
 		Tcl_AppendResult(interp, "bad return code: ",
 			TclGetString(codePtr), NULL);
+		Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "BADRESULT", NULL);
 		Tcl_DecrRefCount(codePtr);
 		code = TCL_ERROR;
 	    }
@@ -599,6 +611,7 @@ PkgRequireCore(
 
     if (pkgPtr->version == NULL) {
 	Tcl_AppendResult(interp, "can't find package ", name, NULL);
+	Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "UNFOUND", NULL);
 	AddRequirementsToResult(interp, reqc, reqv);
 	return NULL;
     }
@@ -608,27 +621,28 @@ PkgRequireCore(
      * provided version meets the current requirements.
      */
 
-    if (reqc == 0) {
-	satisfies = 1;
-    } else {
+    if (reqc != 0) {
 	CheckVersionAndConvert(interp, pkgPtr->version, &pkgVersionI, NULL);
 	satisfies = SomeRequirementSatisfied(pkgVersionI, reqc, reqv);
 
 	ckfree(pkgVersionI);
-    }
 
-    if (satisfies) {
-	if (clientDataPtr) {
-		const void **ptr = (const void **) clientDataPtr;
-	    *ptr = pkgPtr->clientData;
+	if (!satisfies) {
+	    Tcl_AppendResult(interp, "version conflict for package \"", name,
+		    "\": have ", pkgPtr->version, ", need", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "PACKAGE", "VERSIONCONFLICT",
+		    NULL);
+	    AddRequirementsToResult(interp, reqc, reqv);
+	    return NULL;
 	}
-	return pkgPtr->version;
     }
 
-    Tcl_AppendResult(interp, "version conflict for package \"", name,
-	    "\": have ", pkgPtr->version, ", need", NULL);
-    AddRequirementsToResult(interp, reqc, reqv);
-    return NULL;
+    if (clientDataPtr) {
+	const void **ptr = (const void **) clientDataPtr;
+
+	*ptr = pkgPtr->clientData;
+    }
+    return pkgPtr->version;
 }
 
 /*
@@ -1328,6 +1342,7 @@ CheckVersionAndConvert(
     ckfree(ibuf);
     Tcl_AppendResult(interp, "expected version number but got \"", string,
 	    "\"", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSION", NULL);
     return TCL_ERROR;
 }
 
@@ -1590,6 +1605,7 @@ CheckRequirement(
 
 	Tcl_AppendResult(interp, "expected versionMin-versionMax but got \"",
 		string, "\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "VERSIONRANGE", NULL);
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 6cd5bb2..9f4ba29 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -154,11 +154,13 @@ Tcl_ProcObjCmd(
     if (nsPtr == NULL) {
 	Tcl_AppendResult(interp, "can't create procedure \"", fullName,
 		"\": unknown namespace", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
 	return TCL_ERROR;
     }
     if (procName == NULL) {
 	Tcl_AppendResult(interp, "can't create procedure \"", fullName,
 		"\": bad procedure name", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
 	return TCL_ERROR;
     }
     if ((nsPtr != iPtr->globalNsPtr)
@@ -166,6 +168,7 @@ Tcl_ProcObjCmd(
 	Tcl_AppendResult(interp, "can't create procedure \"", procName,
 		"\" in non-global namespace with name starting with \":\"",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMMAND", NULL);
 	return TCL_ERROR;
     }
 
@@ -490,6 +493,8 @@ TclCreateProc(
 		    "procedure \"%s\": arg list contains %d entries, "
 		    "precompiled header expects %d", procName, numArgs,
 		    procPtr->numArgs));
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+		    "BYTECODELIES", NULL);
 	    goto procError;
 	}
 	localPtr = procPtr->firstLocalPtr;
@@ -516,11 +521,15 @@ TclCreateProc(
 	    Tcl_AppendResult(interp,
 		    "too many fields in argument specifier \"",
 		    argArray[i], "\"", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+		    "FORMALARGUMENTFORMAT", NULL);
 	    goto procError;
 	}
 	if ((fieldCount == 0) || (*fieldValues[0] == 0)) {
 	    ckfree(fieldValues);
 	    Tcl_AppendResult(interp, "argument with no name", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+		    "FORMALARGUMENTFORMAT", NULL);
 	    goto procError;
 	}
 
@@ -547,12 +556,16 @@ TclCreateProc(
 		    Tcl_AppendResult(interp, "formal parameter \"",
 			    fieldValues[0], "\" is an array element", NULL);
 		    ckfree(fieldValues);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			    "FORMALARGUMENTFORMAT", NULL);
 		    goto procError;
 		}
 	    } else if ((*p == ':') && (*(p+1) == ':')) {
 		Tcl_AppendResult(interp, "formal parameter \"",
 			fieldValues[0], "\" is not a simple name", NULL);
 		ckfree(fieldValues);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			"FORMALARGUMENTFORMAT", NULL);
 		goto procError;
 	    }
 	    p++;
@@ -580,6 +593,8 @@ TclCreateProc(
 			"procedure \"%s\": formal parameter %d is "
 			"inconsistent with precompiled body", procName, i));
 		ckfree(fieldValues);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			"BYTECODELIES", NULL);
 		goto procError;
 	    }
 
@@ -599,6 +614,8 @@ TclCreateProc(
 			    "default value inconsistent with precompiled body",
 			    procName, fieldValues[0]));
 		    ckfree(fieldValues);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			    "BYTECODELIES", NULL);
 		    goto procError;
 		}
 	    }
@@ -752,6 +769,7 @@ TclGetFrame(
   levelError:
     Tcl_ResetResult(interp);
     Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
     return -1;
 }
 
@@ -884,7 +902,7 @@ TclObjGetFrame(
   levelError:
     Tcl_ResetResult(interp);
     Tcl_AppendResult(interp, "bad level \"", name, "\"", NULL);
-    Tcl_SetErrorCode(interp, "TCL", "VALUE", "LEVEL", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "VALUE", "STACKLEVEL", NULL);
     return -1;
 }
 
@@ -1863,6 +1881,7 @@ InterpProcNR2(
 	Tcl_AppendResult(interp, "invoked \"",
 		((result == TCL_BREAK) ? "break" : "continue"),
 		"\" outside of a loop", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "RESULT", "UNEXPECTED", NULL);
 	result = TCL_ERROR;
 
 	/*
@@ -1980,6 +1999,8 @@ TclProcCompileProc(
 	    if ((Interp *) *codePtr->interpHandle != iPtr) {
 		Tcl_AppendResult(interp,
 			"a precompiled script jumped interps", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PROC",
+			"CROSSINTERPBYTECODE", NULL);
 		return TCL_ERROR;
 	    }
 	    codePtr->compileEpoch = iPtr->compileEpoch;
@@ -2468,6 +2489,7 @@ SetLambdaFromAny(
 	Tcl_AppendObjToObj(errPtr, objPtr);
 	Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1);
 	Tcl_SetObjResult(interp, errPtr);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
 	return TCL_ERROR;
     }
 
@@ -2893,26 +2915,28 @@ Tcl_DisassembleObjCmd(
 	if (objc != 3) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "procName");
 	    return TCL_ERROR;
-	} else {
-	    procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
-	    if (procPtr == NULL) {
-		Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
-			"\" isn't a procedure", NULL);
-		return TCL_ERROR;
-	    }
+	}
 
-	    /*
-	     * Compile (if uncompiled) and disassemble a procedure.
-	     */
+	procPtr = TclFindProc((Interp *) interp, TclGetString(objv[2]));
+	if (procPtr == NULL) {
+	    Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
+		    "\" isn't a procedure", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "PROC",
+		    TclGetString(objv[2]), NULL);
+	    return TCL_ERROR;
+	}
 
-	    result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
-	    if (result != TCL_OK) {
-		return result;
-	    }
-	    TclPopStackFrame(interp);
-	    codeObjPtr = procPtr->bodyPtr;
-	    break;
+	/*
+	 * Compile (if uncompiled) and disassemble a procedure.
+	 */
+
+	result = PushProcCallFrame(procPtr, interp, 2, objv+1, 1);
+	if (result != TCL_OK) {
+	    return result;
 	}
+	TclPopStackFrame(interp);
+	codeObjPtr = procPtr->bodyPtr;
+	break;
     case DISAS_SCRIPT:
 	/*
 	 * Compile and disassemble a script.
@@ -2947,6 +2971,8 @@ Tcl_DisassembleObjCmd(
 	if (oPtr->classPtr == NULL) {
 	    Tcl_AppendResult(interp, "\"", TclGetString(objv[2]),
 		    "\" is not a class", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+		    TclGetString(objv[2]), NULL);
 	    return TCL_ERROR;
 	}
 	hPtr = Tcl_FindHashEntry(&oPtr->classPtr->classMethods,
@@ -2980,12 +3006,16 @@ Tcl_DisassembleObjCmd(
 	unknownMethod:
 	    Tcl_AppendResult(interp, "unknown method \"",
 		    TclGetString(objv[3]), "\"", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		    TclGetString(objv[3]), NULL);
 	    return TCL_ERROR;
 	}
 	procPtr = TclOOGetProcFromMethod(Tcl_GetHashValue(hPtr));
 	if (procPtr == NULL) {
 	    Tcl_AppendResult(interp,
 		    "body not available for this kind of method", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+		    "METHODTYPE", NULL);
 	    return TCL_ERROR;
 	}
 	if (procPtr->bodyPtr->typePtr != &tclByteCodeType) {
@@ -3019,6 +3049,8 @@ Tcl_DisassembleObjCmd(
     if (((ByteCode *) codeObjPtr->internalRep.otherValuePtr)->flags
 	    & TCL_BYTECODE_PRECOMPILED) {
 	Tcl_AppendResult(interp,"may not disassemble prebuilt bytecode",NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "DISASSEMBLE",
+		"BYTECODE", NULL);
 	return TCL_ERROR;
     }
     Tcl_SetObjResult(interp, TclDisassembleByteCodeObj(codeObjPtr));
diff --git a/generic/tclResult.c b/generic/tclResult.c
index fad3b82..6a71ee2 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -1487,9 +1487,10 @@ TclMergeReturnOptions(
 	     */
 	    Tcl_ResetResult(interp);
 	    Tcl_AppendResult(interp, "bad -errorstack value: "
-			     "expected a list but got \"",
-			     TclGetString(valuePtr), "\"", NULL);
-	    Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK", NULL);
+		    "expected a list but got \"", TclGetString(valuePtr),
+                    "\"", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "RESULT", "NONLIST_ERRORSTACK",
+                    NULL);
 	    goto error;
 	}
         if (length % 2) {
@@ -1497,9 +1498,11 @@ TclMergeReturnOptions(
              * Errorstack must always be an even-sized list
              */
             Tcl_ResetResult(interp);
-	    Tcl_AppendResult(interp, "forbidden odd-sized list for -errorstack: \"",
-			     TclGetString(valuePtr), "\"", NULL);
-	    Tcl_SetErrorCode(interp, "TCL", "RESULT", "ODDSIZEDLIST_ERRORSTACK", NULL);
+	    Tcl_AppendResult(interp,
+                    "forbidden odd-sized list for -errorstack: \"",
+		    TclGetString(valuePtr), "\"", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "RESULT",
+                    "ODDSIZEDLIST_ERRORSTACK", NULL);
 	    goto error;
         }
     }
diff --git a/generic/tclScan.c b/generic/tclScan.c
index c862be4..68b8d21 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -331,6 +331,7 @@ ValidateFormat(
 	    Tcl_SetResult(interp,
 		    "cannot mix \"%\" and \"%n$\" conversion specifiers",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "MIXEDSPECTYPES", NULL);
 	    goto error;
 	}
 
@@ -377,6 +378,7 @@ ValidateFormat(
 		Tcl_SetResult(interp,
 			"field width may not be specified in %c conversion",
 			TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADWIDTH", NULL);
 		goto error;
 	    }
 	    /*
@@ -390,6 +392,7 @@ ValidateFormat(
 		Tcl_AppendResult(interp,
 			"field size modifier may not be specified in %", buf,
 			" conversion", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADSIZE", NULL);
 		goto error;
 	    }
 	    /*
@@ -408,6 +411,7 @@ ValidateFormat(
 	    if (flags & SCAN_BIG) {
 		Tcl_SetResult(interp,
 			"unsigned bignum scans are invalid", TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADUNSIGNED",NULL);
 		goto error;
 	    }
 	    break;
@@ -444,11 +448,13 @@ ValidateFormat(
 	badSet:
 	    Tcl_SetResult(interp, "unmatched [ in format string",
 		    TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BRACKET", NULL);
 	    goto error;
 	default:
 	    buf[Tcl_UniCharToUtf(ch, buf)] = '\0';
 	    Tcl_AppendResult(interp, "bad scan conversion character \"", buf,
 		    "\"", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
 	    goto error;
 	}
 	if (!(flags & SCAN_SUPPRESS)) {
@@ -495,6 +501,7 @@ ValidateFormat(
 	    Tcl_SetResult(interp,
 		    "variable is assigned by multiple \"%n$\" conversion specifiers",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "POLYASSIGNED", NULL);
 	    goto error;
 	} else if (!xpgSize && (nassign[i] == 0)) {
 	    /*
@@ -505,6 +512,7 @@ ValidateFormat(
 	    Tcl_SetResult(interp,
 		    "variable is not assigned by any conversion specifiers",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "FORMAT", "UNASSIGNED", NULL);
 	    goto error;
 	}
     }
@@ -516,10 +524,12 @@ ValidateFormat(
     if (gotXpg) {
 	Tcl_SetResult(interp, "\"%n$\" argument index out of range",
 		TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "FORMAT", "INDEXRANGE", NULL);
     } else {
 	Tcl_SetResult(interp,
 		"different numbers of variable names and field specifiers",
 		TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "FORMAT", "FIELDVARMISMATCH", NULL);
     }
 
   error:
@@ -991,6 +1001,7 @@ Tcl_ScanObjCmd(
 		continue;
 	    }
 	    result++;
+#warning Why make your own error message? Why?
 	    if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) {
 		Tcl_AppendResult(interp, "couldn't set variable \"",
 			TclGetString(objv[i+3]), "\"", NULL);
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index c83d174..82f83db 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -386,13 +386,13 @@ test iocmd-11.1 {I/O to command pipelines} {unixOrPc unixExecs} {
     set f [open $path(test4) w]
     close $f
     list [catch {open "| cat < \"$path(test4)\" > \"$path(test5)\"" w} msg] $msg $::errorCode
-} {1 {can't write input to command: standard input was redirected} NONE}
+} {1 {can't write input to command: standard input was redirected} {TCL OPERATION EXEC BADREDIRECT}}
 test iocmd-11.2 {I/O to command pipelines} {unixOrPc unixExecs} {
     list [catch {open "| echo > \"$path(test5)\"" r} msg] $msg $::errorCode
-} {1 {can't read output from command: standard output was redirected} NONE}
+} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
 test iocmd-11.3 {I/O to command pipelines} {unixOrPc unixExecs} {
     list [catch {open "| echo > \"$path(test5)\"" r+} msg] $msg $::errorCode
-} {1 {can't read output from command: standard output was redirected} NONE}
+} {1 {can't read output from command: standard output was redirected} {TCL OPERATION EXEC BADREDIRECT}}
 test iocmd-11.4 {I/O to command pipelines} unixOrPc {
     list [catch {open "| no_such_command_exists" rb} msg] $msg $::errorCode
 } {1 {couldn't execute "no_such_command_exists": no such file or directory} {POSIX ENOENT {no such file or directory}}}
-- 
cgit v0.12


From 25e4dca4916e5ae7be29bb21c40e59f3adb4b5ec Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 4 Apr 2011 13:40:01 +0000
Subject: Better error-message in case of errors related to setting a variable

---
 ChangeLog            | 11 +++++++++++
 generic/tclCmdAH.c   | 10 ++--------
 generic/tclCmdIL.c   | 22 ++++++++--------------
 generic/tclDictObj.c | 20 ++++----------------
 generic/tclScan.c    |  8 ++++----
 generic/tclTest.c    |  4 +---
 tests/error.test     | 38 +++++++++++++++++++-------------------
 tests/info.test      |  6 +++---
 tests/scan.test      | 14 +++++++-------
 9 files changed, 59 insertions(+), 74 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b734896..63e4391 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2011-04-04  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclCmdAH.c:  Better error-message in case of errors
+	* generic/tclCmdIL.c:  related to setting a variable. This fixes
+	* generic/tclDictObj.c: a warning: "Why make your own error
+	* generic/tclScan.c:   message? Why?"
+	* generic/tclTest.c:
+	* test/error.test:
+	* test/info.test:
+	* test/scan.test:
+
 2011-04-03  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclNamesp.c, generic/tclObj.c, generic/tclPathObj.c:
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 3edfa54..8b5f13d 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -345,10 +345,7 @@ CatchObjCmdCallback(
 
     if (objc >= 3) {
 	if (NULL == Tcl_ObjSetVar2(interp, varNamePtr, NULL,
-		Tcl_GetObjResult(interp), 0)) {
-	    Tcl_ResetResult(interp);
-	    Tcl_AppendResult(interp,
-		    "couldn't save command result in variable", NULL);
+		Tcl_GetObjResult(interp), TCL_LEAVE_ERR_MSG)) {
 	    return TCL_ERROR;
 	}
     }
@@ -356,11 +353,8 @@ CatchObjCmdCallback(
 	Tcl_Obj *options = Tcl_GetReturnOptions(interp, result);
 
 	if (NULL == Tcl_ObjSetVar2(interp, optionVarNamePtr, NULL,
-		options, 0)) {
+		options, TCL_LEAVE_ERR_MSG)) {
 	    Tcl_DecrRefCount(options);
-	    Tcl_ResetResult(interp);
-	    Tcl_AppendResult(interp,
-		    "couldn't save return options in variable", NULL);
 	    return TCL_ERROR;
 	}
     }
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index b38ec9f..c42a54b 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -966,7 +966,7 @@ InfoDefaultCmd(
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
     Interp *iPtr = (Interp *) interp;
-    const char *procName, *argName, *varName;
+    const char *procName, *argName;
     Proc *procPtr;
     CompiledLocal *localPtr;
     Tcl_Obj *valueObjPtr;
@@ -993,18 +993,18 @@ InfoDefaultCmd(
 		&& (strcmp(argName, localPtr->name) == 0)) {
 	    if (localPtr->defValuePtr != NULL) {
 		valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
-			localPtr->defValuePtr, 0);
+			localPtr->defValuePtr, TCL_LEAVE_ERR_MSG);
 		if (valueObjPtr == NULL) {
-		    goto defStoreError;
+		    return TCL_ERROR;
 		}
 		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
 	    } else {
 		Tcl_Obj *nullObjPtr = Tcl_NewObj();
 
 		valueObjPtr = Tcl_ObjSetVar2(interp, objv[3], NULL,
-			nullObjPtr, 0);
+			nullObjPtr, TCL_LEAVE_ERR_MSG);
 		if (valueObjPtr == NULL) {
-		    goto defStoreError;
+		    return TCL_ERROR;
 		}
 		Tcl_SetObjResult(interp, Tcl_NewIntObj(0));
 	    }
@@ -1016,12 +1016,6 @@ InfoDefaultCmd(
 	    "\" doesn't have an argument \"", argName, "\"", NULL);
     Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "ARGUMENT", argName, NULL);
     return TCL_ERROR;
-
-  defStoreError:
-    varName = TclGetString(objv[3]);
-    Tcl_AppendResult(interp, "couldn't store default value in variable \"",
-	    varName, "\"", NULL);
-    return TCL_ERROR;
 }
 
 /*
@@ -1058,7 +1052,7 @@ InfoErrorStackCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "?interp?");
 	return TCL_ERROR;
     }
-    
+
     target = interp;
     if (objc == 2) {
         target = Tcl_GetSlave(interp, Tcl_GetString(objv[1]));
@@ -1069,7 +1063,7 @@ InfoErrorStackCmd(
 
     iPtr = (Interp *) target;
     Tcl_SetObjResult(interp, iPtr->errorStack);
-    
+
     return TCL_OK;
 }
 
@@ -1163,7 +1157,7 @@ InfoFrameCmd(
         CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
         CmdFrame *runPtr = iPtr->cmdFramePtr;
         CmdFrame *lastPtr = NULL;
-        
+
         topLevel += corPtr->caller.cmdFramePtr->level;
         while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) {
             lastPtr = runPtr;
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 3da91a3..508c2af 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -2456,18 +2456,12 @@ DictForNRCmd(
      */
 
     Tcl_IncrRefCount(valueObj);
-    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "couldn't set key variable: \"",
-		TclGetString(keyVarObj), "\"", NULL);
+    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
 	TclDecrRefCount(valueObj);
 	goto error;
     }
     TclDecrRefCount(valueObj);
-    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "couldn't set value variable: \"",
-		TclGetString(valueVarObj), "\"", NULL);
+    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
 	goto error;
     }
 
@@ -2540,19 +2534,13 @@ DictForLoopCallback(
      */
 
     Tcl_IncrRefCount(valueObj);
-    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, 0) == NULL) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "couldn't set key variable: \"",
-		TclGetString(keyVarObj), "\"", NULL);
+    if (Tcl_ObjSetVar2(interp, keyVarObj, NULL, keyObj, TCL_LEAVE_ERR_MSG) == NULL) {
 	TclDecrRefCount(valueObj);
 	result = TCL_ERROR;
 	goto done;
     }
     TclDecrRefCount(valueObj);
-    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, 0) == NULL) {
-	Tcl_ResetResult(interp);
-	Tcl_AppendResult(interp, "couldn't set value variable: \"",
-		TclGetString(valueVarObj), "\"", NULL);
+    if (Tcl_ObjSetVar2(interp, valueVarObj, NULL, valueObj, TCL_LEAVE_ERR_MSG) == NULL) {
 	result = TCL_ERROR;
 	goto done;
     }
diff --git a/generic/tclScan.c b/generic/tclScan.c
index 68b8d21..06e66e4 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -1001,10 +1001,10 @@ Tcl_ScanObjCmd(
 		continue;
 	    }
 	    result++;
-#warning Why make your own error message? Why?
-	    if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i], 0) == NULL) {
-		Tcl_AppendResult(interp, "couldn't set variable \"",
-			TclGetString(objv[i+3]), "\"", NULL);
+	    /* In case of multiple errors in setting variables, just report
+	     * the first one. */
+	    if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i],
+		    (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) {
 		code = TCL_ERROR;
 	    }
 	    Tcl_DecrRefCount(objs[i]);
diff --git a/generic/tclTest.c b/generic/tclTest.c
index b757185..bac0c7f 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -3939,10 +3939,8 @@ TestregexpObjCmd(
 			info.matches[ii].end - 1);
 	    }
 	}
-	valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, 0);
+	valuePtr = Tcl_ObjSetVar2(interp, varPtr, NULL, newPtr, TCL_LEAVE_ERR_MSG);
 	if (valuePtr == NULL) {
-	    Tcl_AppendResult(interp, "couldn't set variable \"",
-		    Tcl_GetString(varPtr), "\"", NULL);
 	    return TCL_ERROR;
 	}
     }
diff --git a/tests/error.test b/tests/error.test
index c34ccb0..97bcc0a 100644
--- a/tests/error.test
+++ b/tests/error.test
@@ -138,7 +138,7 @@ test error-3.3 {errors in catch command} {
     catch {unset a}
     set a(0) 22
     list [catch {catch {format 44} a} msg] $msg
-} {1 {couldn't save command result in variable}}
+} {1 {can't set "a": variable is array}}
 catch {unset a}
 
 # More tests related to errorInfo and errorCode
@@ -417,7 +417,7 @@ test error-12.4 {try with result/opts variable assignment in on handler} {
 } {bar,FOO}
 test error-12.5 {try with result/opts variable assignment in on handler, vars remain in scope} {
     try { throw FOO bar } on error {res opts} { list d e f }
-    set r "$res,[dict get $opts -errorcode]"  
+    set r "$res,[dict get $opts -errorcode]"
 } {bar,FOO}
 test error-12.6 {try result is propagated if no matching handler} {
     try { list a b c } on error {} { list d e f }
@@ -459,7 +459,7 @@ test error-13.8 {try with multiple handlers and finally (ok)} {
     try list on error {} {} trap {} {} {} finally {}
 } {}
 test error-13.9 {last handler body can't be a fallthrough #1} -body {
-    try list on error {} {} on break {} - 
+    try list on error {} {} on break {} -
 } -returnCodes error -result {last non-finally clause must not have a body of "-"}
 test error-13.10 {last handler body can't be a fallthrough #2} -body {
     try list on error {} {} on break {} - finally { list d e f }
@@ -471,7 +471,7 @@ test error-14.1 {try with multiple handlers (only one matches) #1} {
     try { throw FOO bar } on ok {} { list a b c } trap FOO {} { list d e f }
 } {d e f}
 test error-14.2 {try with multiple handlers (only one matches) #2} {
-    try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c } 
+    try { throw FOO bar } trap FOO {} { list d e f } on ok {} { list a b c }
 } {d e f}
 test error-14.3 {try with multiple handlers (only one matches) #3} {
     try {
@@ -482,7 +482,7 @@ test error-14.3 {try with multiple handlers (only one matches) #3} {
 	list d e f
     } on ok {} {
 	list a b c
-    } 
+    }
 } {d e f}
 test error-14.4 {try with multiple matching handlers (only the first in left-to-right order runs) #1} {
     try { throw FOO bar } on error {} { list a b c } trap FOO {} { list d e f }
@@ -593,16 +593,16 @@ test error-16.6 {try with variable assignment and propagation #1} {
     catch {
 	try { throw FOO bar } trap FOO {em} { throw BAR baz }
     }
-    set em  
+    set em
 } {bar}
 test error-16.7 {try with variable assignment and propagation #2} {
     catch {
 	try { throw FOO bar } trap FOO {em opts} { throw BAR baz }
     }
-    list $em [dict get $opts -errorcode]  
+    list $em [dict get $opts -errorcode]
 } {bar FOO}
 test error-16.8 {exception chaining (try=ok, handler=error)} {
-    #FIXME is the intent of this test correct?  
+    #FIXME is the intent of this test correct?
     catch {
 	try { list a b c } on ok {em opts} { throw BAR baz }
     } tryem tryopts
@@ -686,7 +686,7 @@ test error-17.11 {successful finally doesn't affect variable assignment or propa
     catch {
 	try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { list d e f }
     }
-    list $em [dict get $opts -errorcode]  
+    list $em [dict get $opts -errorcode]
 } {bar FOO}
 
 # try tests - propagation (exceptions in finally, exception chaining)
@@ -707,11 +707,11 @@ test error-18.5 {exception in finally doesn't affect variable assignment} {
     catch {
 	try { throw FOO bar } trap FOO {em opts} { throw BAR baz } finally { throw BAZ zing }
     }
-    list $em [dict get $opts -errorcode]  
+    list $em [dict get $opts -errorcode]
 } {bar FOO}
 test error-18.6 {exception chaining in finally (try=ok)} {
     catch {
-	list a b c 
+	list a b c
     } em expopts
     catch {
 	try { list a b c } finally { throw BAR foo }
@@ -782,14 +782,14 @@ test error-19.1 {try with fallthrough body #1} {
 } {1}
 test error-19.2 {try with fallthrough body #2} {
     set RES {}
-    try { 
-	throw FOO bar 
+    try {
+	throw FOO bar
     } trap BAR {} {
     } trap FOO {} - trap {} {} {
 	set RES foo
     } on error {} {
 	set RES err
-    }  
+    }
     set RES
 } {foo}
 test error-19.3 {try with cascade fallthrough} {
@@ -805,22 +805,22 @@ test error-19.4 {multiple unrelated fallthroughs #1} {
     set RES {}
     try {
 	throw FOO bar
-    } trap FOO {} - trap BAR {} { 
+    } trap FOO {} - trap BAR {} {
 	set RES foo
     } trap {} {} - on error {} {
 	set RES err
-    } 
+    }
     set RES
 } {foo}
 test error-19.5 {multiple unrelated fallthroughs #2} {
     set RES {}
     try {
 	throw BAZ zing
-    } trap FOO {} - trap BAR {} { 
+    } trap FOO {} - trap BAR {} {
 	set RES foo
     } trap {} {} - on error {} {
 	set RES err
-    } 
+    }
     set RES
 } {err}
 proc addmsg msg {
@@ -1054,7 +1054,7 @@ namespace delete ::tcl::test::error
 # cleanup
 catch {rename p ""}
 ::tcltest::cleanupTests
-return 
+return
 
 # Local Variables:
 # mode: tcl
diff --git a/tests/info.test b/tests/info.test
index 9977054..3323281 100644
--- a/tests/info.test
+++ b/tests/info.test
@@ -215,14 +215,14 @@ test info-6.9 {info default option} -returnCodes error -setup {
     set a(0) 88
     proc t1 {a b} {}
     info default t1 a a
-} -returnCodes error -result {couldn't store default value in variable "a"}
+} -returnCodes error -result {can't set "a": variable is array}
 test info-6.10 {info default option} -setup {
     catch {unset a}
 } -cleanup {unset a} -body {
     set a(0) 88
     proc t1 {{a 18} b} {}
     info default t1 a a
-} -returnCodes error -result {couldn't store default value in variable "a"}
+} -returnCodes error -result {can't set "a": variable is array}
 test info-6.11 {info default option} {
     catch {namespace delete test_ns_info2}
     namespace eval test_ns_info2 {
@@ -1826,7 +1826,7 @@ test info-30.46 {TIP 280 for compiled [subst]} {
 } YES
 test info-30.47 {TIP 280 for compiled [subst]} {
     unset -nocomplain a
-    set a(\n1831) YES;  set a(\n1830) 1830; set a(\n1832) 1832 
+    set a(\n1831) YES;  set a(\n1830) 1830; set a(\n1832) 1832
     subst {$a(
 [dict get [info frame 0] line])} ; # 1831
 } YES
diff --git a/tests/scan.test b/tests/scan.test
index 6e1ccb0..84f22b4 100644
--- a/tests/scan.test
+++ b/tests/scan.test
@@ -328,7 +328,7 @@ test scan-4.60 {Tcl_ScanObjCmd, set errors} {
 	    $msg $x $y]
     unset z
     set result
-} {1 {couldn't set variable "z"} abc ghi}
+} {1 {can't set "z": variable is array} abc ghi}
 test scan-4.61 {Tcl_ScanObjCmd, set errors} {
     set x {}
     catch {unset y}; array set y {}
@@ -338,7 +338,7 @@ test scan-4.61 {Tcl_ScanObjCmd, set errors} {
     unset y
     unset z
     set result
-} {1 {couldn't set variable "z"couldn't set variable "y"} abc}
+} {1 {can't set "z": variable is array} abc}
 
 # procedure that returns the range of integers
 
@@ -545,27 +545,27 @@ test scan-8.12 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %d a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 test scan-8.13 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %c a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 test scan-8.14 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %s a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 test scan-8.15 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %f a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 test scan-8.16 {error conditions} {
     catch {unset a}
     set a(0) 44
     list [catch {scan 44 %f a} msg] $msg
-} {1 {couldn't set variable "a"}}
+} {1 {can't set "a": variable is array}}
 catch {unset a}
 test scan-8.17 {error conditions} {
     list [catch {scan 44 %2c a} msg] $msg
-- 
cgit v0.12


From 6965ff95a63177a766b1be29435d3cf3592f593b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 Apr 2011 13:46:33 +0000
Subject: Minor tinkering with style.

---
 generic/tclScan.c | 10 +++++++---
 1 file changed, 7 insertions(+), 3 deletions(-)

diff --git a/generic/tclScan.c b/generic/tclScan.c
index 06e66e4..d21bfaf 100644
--- a/generic/tclScan.c
+++ b/generic/tclScan.c
@@ -1001,8 +1001,12 @@ Tcl_ScanObjCmd(
 		continue;
 	    }
 	    result++;
-	    /* In case of multiple errors in setting variables, just report
-	     * the first one. */
+
+	    /*
+	     * In case of multiple errors in setting variables, just report
+	     * the first one.
+	     */
+
 	    if (Tcl_ObjSetVar2(interp, objv[i+3], NULL, objs[i],
 		    (code == TCL_OK) ? TCL_LEAVE_ERR_MSG : 0) == NULL) {
 		code = TCL_ERROR;
@@ -1050,7 +1054,7 @@ Tcl_ScanObjCmd(
     }
     return code;
 }
-
+
 /*
  * Local Variables:
  * mode: c
-- 
cgit v0.12


From 875ed401f93f459fbac8cfd682d6e015b10f7ad3 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 Apr 2011 13:55:06 +0000
Subject: More generation of error codes ([format], [after], [trace], RE
 optimizer).

---
 ChangeLog              |   6 +++
 generic/tclBasic.c     | 126 ++++++++++++++++++++++++-------------------------
 generic/tclStringObj.c |  22 ++++++++-
 generic/tclTimer.c     |  34 +++++++------
 generic/tclTrace.c     |   8 ++++
 generic/tclUtil.c      |  11 ++++-
 6 files changed, 125 insertions(+), 82 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 63e4391..4724598 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-04-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclBasic.c, generic/tclStringObj.c, generic/tclTimer.c,
+	* generic/tclTrace.c, generic/tclUtil.c: More generation of error
+	codes ([format], [after], [trace], RE optimizer).
+
 2011-04-04  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclCmdAH.c:  Better error-message in case of errors
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index b34209b..f00864f 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -2498,7 +2498,8 @@ TclRenameCommand(
     if (Tcl_FindHashEntry(&newNsPtr->cmdTable, newTail) != NULL) {
 	Tcl_AppendResult(interp, "can't rename to \"", newName,
 		 "\": command already exists", NULL);
-        Tcl_SetErrorCode(interp, "TCL", "RENAME", "TARGET_EXISTS", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "OPERATION", "RENAME",
+                "TARGET_EXISTS", NULL);
 	result = TCL_ERROR;
 	goto done;
     }
@@ -3883,82 +3884,79 @@ Tcl_Canceled(
     register Interp *iPtr = (Interp *) interp;
 
     /*
-	 * Has the current script in progress for this interpreter been
-	 * canceled or is the stack being unwound due to the previous script
-	 * cancellation?
-	 */
+     * Has the current script in progress for this interpreter been canceled
+     * or is the stack being unwound due to the previous script cancellation?
+     */
 
-    if (TclCanceled(iPtr)) {
-	    /*
-	     * The CANCELED flag is a one-shot flag that is reset immediately
-	     * upon being detected; however, if the TCL_CANCEL_UNWIND flag is
-	     * set we will continue to report that the script in progress has
-	     * been canceled thereby allowing the evaluation stack for the
-	     * interp to be fully unwound.
-	     */
+    if (!TclCanceled(iPtr)) {
+        return TCL_OK;
+    }
 
-	    iPtr->flags &= ~CANCELED;
+    /*
+     * The CANCELED flag is a one-shot flag that is reset immediately upon
+     * being detected; however, if the TCL_CANCEL_UNWIND flag is set we will
+     * continue to report that the script in progress has been canceled
+     * thereby allowing the evaluation stack for the interp to be fully
+     * unwound.
+     */
 
-	    /*
-	     * The CANCELED flag was detected and reset; however, if the
-	     * caller specified the TCL_CANCEL_UNWIND flag, we only return
-	     * TCL_ERROR (indicating that the script in progress has been
-	     * canceled) if the evaluation stack for the interp is being fully
-	     * unwound.
-	     */
+    iPtr->flags &= ~CANCELED;
 
-	    if (!(flags & TCL_CANCEL_UNWIND)
-		    || (iPtr->flags & TCL_CANCEL_UNWIND)) {
-		/*
-		 * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error
-		 * in the interp's result; otherwise, we leave it alone.
-		 */
+    /*
+     * The CANCELED flag was detected and reset; however, if the caller
+     * specified the TCL_CANCEL_UNWIND flag, we only return TCL_ERROR
+     * (indicating that the script in progress has been canceled) if the
+     * evaluation stack for the interp is being fully unwound.
+     */
 
-		if (flags & TCL_LEAVE_ERR_MSG) {
-		    const char *id, *message = NULL;
-		    int length;
+    if ((flags & TCL_CANCEL_UNWIND) && !(iPtr->flags & TCL_CANCEL_UNWIND)) {
+        return TCL_OK;
+    }
 
-		    /*
-		     * Setup errorCode variables so that we can differentiate
-		     * between being canceled and unwound.
-		     */
+    /*
+     * If the TCL_LEAVE_ERR_MSG flags bit is set, place an error in the
+     * interp's result; otherwise, we leave it alone.
+     */
 
-		    if (iPtr->asyncCancelMsg != NULL) {
-			message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg,
-				&length);
-		    } else {
-			length = 0;
-		    }
+    if (flags & TCL_LEAVE_ERR_MSG) {
+        const char *id, *message = NULL;
+        int length;
 
-		    if (iPtr->flags & TCL_CANCEL_UNWIND) {
-			id = "IUNWIND";
-			if (length == 0) {
-			    message = "eval unwound";
-			}
-		    } else {
-			id = "ICANCEL";
-			if (length == 0) {
-			    message = "eval canceled";
-			}
-		    }
+        /*
+         * Setup errorCode variables so that we can differentiate between
+         * being canceled and unwound.
+         */
 
-		    Tcl_ResetResult(interp);
-		    Tcl_AppendResult(interp, message, NULL);
-		    Tcl_SetErrorCode(interp, "TCL", id, message, NULL);
-		}
+        if (iPtr->asyncCancelMsg != NULL) {
+            message = Tcl_GetStringFromObj(iPtr->asyncCancelMsg, &length);
+        } else {
+            length = 0;
+        }
 
-		/*
-		 * Return TCL_ERROR to the caller (not necessarily just the
-		 * Tcl core itself) that indicates further processing of the
-		 * script or command in progress should halt gracefully and as
-		 * soon as possible.
-		 */
+        if (iPtr->flags & TCL_CANCEL_UNWIND) {
+            id = "IUNWIND";
+            if (length == 0) {
+                message = "eval unwound";
+            }
+        } else {
+            id = "ICANCEL";
+            if (length == 0) {
+                message = "eval canceled";
+            }
+        }
 
-		return TCL_ERROR;
-	    }
+        Tcl_ResetResult(interp);
+        Tcl_AppendResult(interp, message, NULL);
+        Tcl_SetErrorCode(interp, "TCL", "CANCEL", id, message, NULL);
     }
 
-    return TCL_OK;
+    /*
+     * Return TCL_ERROR to the caller (not necessarily just the Tcl core
+     * itself) that indicates further processing of the script or command in
+     * progress should halt gracefully and as soon as possible.
+     */
+
+    return TCL_ERROR;
 }
 
 /*
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index cf635bc..fe6d0af 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -1609,7 +1609,6 @@ AppendUtfToUtfRep(
     objPtr->bytes[newLength] = 0;
     objPtr->length = newLength;
 }
-
 
 /*
  *----------------------------------------------------------------------
@@ -1706,7 +1705,7 @@ Tcl_AppendFormatToObj(
     int objc,
     Tcl_Obj *const objv[])
 {
-    const char *span = format, *msg;
+    const char *span = format, *msg, *errCode;
     int numBytes = 0, objIndex = 0, gotXpg = 0, gotSequential = 0;
     int originalLength, limit;
     static const char *mixedXPG =
@@ -1744,6 +1743,7 @@ Tcl_AppendFormatToObj(
 	if (numBytes) {
 	    if (numBytes > limit) {
 		msg = overflow;
+		errCode = "OVERFLOW";
 		goto errorMsg;
 	    }
 	    Tcl_AppendToObj(appendObj, span, numBytes);
@@ -1783,18 +1783,21 @@ Tcl_AppendFormatToObj(
 	if (newXpg) {
 	    if (gotSequential) {
 		msg = mixedXPG;
+		errCode = "MIXEDSPECTYPES";
 		goto errorMsg;
 	    }
 	    gotXpg = 1;
 	} else {
 	    if (gotXpg) {
 		msg = mixedXPG;
+		errCode = "MIXEDSPECTYPES";
 		goto errorMsg;
 	    }
 	    gotSequential = 1;
 	}
 	if ((objIndex < 0) || (objIndex >= objc)) {
 	    msg = badIndex[gotXpg];
+	    errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
 	    goto errorMsg;
 	}
 
@@ -1842,6 +1845,7 @@ Tcl_AppendFormatToObj(
 	} else if (ch == '*') {
 	    if (objIndex >= objc - 1) {
 		msg = badIndex[gotXpg];
+		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
 		goto errorMsg;
 	    }
 	    if (TclGetIntFromObj(interp, objv[objIndex], &width) != TCL_OK) {
@@ -1857,6 +1861,7 @@ Tcl_AppendFormatToObj(
 	}
 	if (width > limit) {
 	    msg = overflow;
+	    errCode = "OVERFLOW";
 	    goto errorMsg;
 	}
 
@@ -1877,6 +1882,7 @@ Tcl_AppendFormatToObj(
 	} else if (ch == '*') {
 	    if (objIndex >= objc - 1) {
 		msg = badIndex[gotXpg];
+		errCode = gotXpg ? "INDEXRANGE" : "FIELDVARMISMATCH";
 		goto errorMsg;
 	    }
 	    if (TclGetIntFromObj(interp, objv[objIndex], &precision)
@@ -1934,6 +1940,7 @@ Tcl_AppendFormatToObj(
 	switch (ch) {
 	case '\0':
 	    msg = "format string ended in middle of field specifier";
+	    errCode = "INCOMPLETE";
 	    goto errorMsg;
 	case 's':
 	    if (gotPrecision) {
@@ -1963,6 +1970,7 @@ Tcl_AppendFormatToObj(
 	case 'u':
 	    if (useBig) {
 		msg = "unsigned bignum format is invalid";
+		errCode = "BADUNSIGNED";
 		goto errorMsg;
 	    }
 	case 'd':
@@ -2110,6 +2118,7 @@ Tcl_AppendFormatToObj(
 		}
 		if (toAppend > segmentLimit) {
 		    msg = overflow;
+		    errCode = "OVERFLOW";
 		    goto errorMsg;
 		}
 		Tcl_AppendToObj(segment, bytes, toAppend);
@@ -2165,6 +2174,7 @@ Tcl_AppendFormatToObj(
 		    }
 		    if (numDigits > INT_MAX) {
 			msg = overflow;
+			errCode = "OVERFLOW";
 			goto errorMsg;
 		    }
 		} else if (!useBig) {
@@ -2232,6 +2242,7 @@ Tcl_AppendFormatToObj(
 		}
 		if (toAppend > segmentLimit) {
 		    msg = overflow;
+		    errCode = "OVERFLOW";
 		    goto errorMsg;
 		}
 		Tcl_AppendObjToObj(segment, pure);
@@ -2285,6 +2296,7 @@ Tcl_AppendFormatToObj(
 		p += sprintf(p, "%d", precision);
 		if (precision > INT_MAX - length) {
 		    msg = overflow;
+		    errCode = "OVERFLOW";
 		    goto errorMsg;
 		}
 		length += precision;
@@ -2301,11 +2313,13 @@ Tcl_AppendFormatToObj(
 	    allocSegment = 1;
 	    if (!Tcl_AttemptSetObjLength(segment, length)) {
 		msg = overflow;
+		errCode = "OVERFLOW";
 		goto errorMsg;
 	    }
 	    bytes = TclGetString(segment);
 	    if (!Tcl_AttemptSetObjLength(segment, sprintf(bytes, spec, d))) {
 		msg = overflow;
+		errCode = "OVERFLOW";
 		goto errorMsg;
 	    }
 	    break;
@@ -2314,6 +2328,7 @@ Tcl_AppendFormatToObj(
 	    if (interp != NULL) {
 		Tcl_SetObjResult(interp,
 			Tcl_ObjPrintf("bad field specifier \"%c\"", ch));
+		Tcl_SetErrorCode(interp, "TCL", "FORMAT", "BADTYPE", NULL);
 	    }
 	    goto error;
 	}
@@ -2345,6 +2360,7 @@ Tcl_AppendFormatToObj(
 		Tcl_DecrRefCount(segment);
 	    }
 	    msg = overflow;
+	    errCode = "OVERFLOW";
 	    goto errorMsg;
 	}
 	Tcl_AppendObjToObj(appendObj, segment);
@@ -2367,6 +2383,7 @@ Tcl_AppendFormatToObj(
     if (numBytes) {
 	if (numBytes > limit) {
 	    msg = overflow;
+	    errCode = "OVERFLOW";
 	    goto errorMsg;
 	}
 	Tcl_AppendToObj(appendObj, span, numBytes);
@@ -2379,6 +2396,7 @@ Tcl_AppendFormatToObj(
   errorMsg:
     if (interp != NULL) {
 	Tcl_SetObjResult(interp, Tcl_NewStringObj(msg, -1));
+	Tcl_SetErrorCode(interp, "TCL", "FORMAT", errCode, NULL);
     }
   error:
     Tcl_SetObjLength(appendObj, originalLength);
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index b6c9208..6682d21 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -831,9 +831,12 @@ Tcl_AfterObjCmd(
 		    &index) != TCL_OK)) {
 	index = -1;
 	if (Tcl_GetWideIntFromObj(NULL, objv[1], &ms) != TCL_OK) {
-	    Tcl_AppendResult(interp, "bad argument \"",
-		    Tcl_GetString(objv[1]),
+            const char *arg = Tcl_GetString(objv[1]);
+
+	    Tcl_AppendResult(interp, "bad argument \"", arg,
 		    "\": must be cancel, idle, info, or an integer", NULL);
+            Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", "argument",
+                    arg, NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -947,9 +950,7 @@ Tcl_AfterObjCmd(
 	Tcl_DoWhenIdle(AfterProc, afterPtr);
 	Tcl_SetObjResult(interp, Tcl_ObjPrintf("after#%d", afterPtr->id));
 	break;
-    case AFTER_INFO: {
-	Tcl_Obj *resultListPtr;
-
+    case AFTER_INFO:
 	if (objc == 2) {
 	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
 		    afterPtr = afterPtr->nextPtr) {
@@ -966,17 +967,22 @@ Tcl_AfterObjCmd(
 	}
 	afterPtr = GetAfterEvent(assocPtr, objv[2]);
 	if (afterPtr == NULL) {
-	    Tcl_AppendResult(interp, "event \"", TclGetString(objv[2]),
-		    "\" doesn't exist", NULL);
+            const char *eventStr = TclGetString(objv[2]);
+
+	    Tcl_AppendResult(interp, "event \"", eventStr, "\" doesn't exist",
+                    NULL);
+            Tcl_SetErrorCode(interp, "TCL","LOOKUP","EVENT", eventStr, NULL);
 	    return TCL_ERROR;
-	}
-	resultListPtr = Tcl_NewObj();
-	Tcl_ListObjAppendElement(interp, resultListPtr, afterPtr->commandPtr);
-	Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
-		(afterPtr->token == NULL) ? "idle" : "timer", -1));
-	Tcl_SetObjResult(interp, resultListPtr);
+	} else {
+            Tcl_Obj *resultListPtr = Tcl_NewObj();
+
+            Tcl_ListObjAppendElement(interp, resultListPtr,
+                    afterPtr->commandPtr);
+            Tcl_ListObjAppendElement(interp, resultListPtr, Tcl_NewStringObj(
+		    (afterPtr->token == NULL) ? "idle" : "timer", -1));
+            Tcl_SetObjResult(interp, resultListPtr);
+        }
 	break;
-    }
     default:
 	Tcl_Panic("Tcl_AfterObjCmd: bad subcommand index to afterSubCmds");
     }
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index d5fb6f6..a60a80b 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -368,6 +368,7 @@ Tcl_TraceObjCmd(
   badVarOps:
     Tcl_AppendResult(interp, "bad operations \"", flagOps,
 	    "\": should be one or more of rwua", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "BADOPS", NULL);
     return TCL_ERROR;
 }
 
@@ -436,6 +437,8 @@ TraceExecutionObjCmd(
 	    Tcl_SetResult(interp, "bad operation list \"\": must be "
 		    "one or more of enter, leave, enterstep, or leavestep",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	for (i = 0; i < listLen; i++) {
@@ -676,6 +679,8 @@ TraceCommandObjCmd(
 	if (listLen == 0) {
 	    Tcl_SetResult(interp, "bad operation list \"\": must be "
 		    "one or more of delete or rename", TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 
@@ -872,6 +877,8 @@ TraceVariableObjCmd(
 	if (listLen == 0) {
 	    Tcl_SetResult(interp, "bad operation list \"\": must be "
 		    "one or more of array, read, unset, or write", TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "TRACE", "NOOPS",
+		    NULL);
 	    return TCL_ERROR;
 	}
 	for (i = 0; i < listLen ; i++) {
@@ -2021,6 +2028,7 @@ TraceVarProc(
 	    }
 	    if (code != TCL_OK) {		/* copy error msg to result */
 		Tcl_Obj *errMsgObj = Tcl_GetObjResult(interp);
+
 		Tcl_IncrRefCount(errMsgObj);
 		result = (char *) errMsgObj;
 	    }
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 5e1efde..64aa824 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -470,6 +470,8 @@ Tcl_SplitList(
 	    if (interp != NULL) {
 		Tcl_SetResult(interp, "internal error in Tcl_SplitList",
 			TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "INTERNAL", "Tcl_SplitList",
+			NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -3270,7 +3272,7 @@ TclReToGlob(
 {
     int anchorLeft, anchorRight, lastIsStar, numStars;
     char *dsStr, *dsStrStart;
-    const char *msg, *p, *strEnd;
+    const char *msg, *p, *strEnd, *code;
 
     strEnd = reStr + reStrLen;
     Tcl_DStringInit(dsPtr);
@@ -3324,6 +3326,7 @@ TclReToGlob(
      */
 
     msg = NULL;
+    code = NULL;
     p = reStr;
     anchorRight = 0;
     lastIsStar = 0;
@@ -3380,6 +3383,7 @@ TclReToGlob(
 		break;
 	    default:
 		msg = "invalid escape sequence";
+		code = "BADESCAPE";
 		goto invalidGlob;
 	    }
 	    break;
@@ -3408,6 +3412,7 @@ TclReToGlob(
 	case '$':
 	    if (p+1 != strEnd) {
 		msg = "$ not anchor";
+		code = "NONANCHOR";
 		goto invalidGlob;
 	    }
 	    anchorRight = 1;
@@ -3415,8 +3420,8 @@ TclReToGlob(
 	case '*': case '+': case '?': case '|': case '^':
 	case '{': case '}': case '(': case ')': case '[': case ']':
 	    msg = "unhandled RE special char";
+	    code = "UNHANDLED";
 	    goto invalidGlob;
-	    break;
 	default:
 	    *dsStr++ = *p;
 	    break;
@@ -3430,6 +3435,7 @@ TclReToGlob(
 	 */
 
 	msg = "excessive recursive glob backtrack potential";
+	code = "OVERCOMPLEX";
 	goto invalidGlob;
     }
 
@@ -3458,6 +3464,7 @@ TclReToGlob(
 #endif
     if (interp != NULL) {
 	Tcl_AppendResult(interp, msg, NULL);
+	Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
     }
     Tcl_DStringFree(dsPtr);
     return TCL_ERROR;
-- 
cgit v0.12


From caf48c369e8ba6e8bcbb7f3a0aa6a0303dc2b56e Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 4 Apr 2011 14:01:30 +0000
Subject: Remove unused header file: unix/tclUnixThrd.h

---
 ChangeLog                            | 1 +
 macosx/Tcl.xcode/project.pbxproj     | 2 --
 macosx/Tcl.xcodeproj/project.pbxproj | 2 --
 3 files changed, 1 insertion(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 4724598..fd79840 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -14,6 +14,7 @@
 	* test/error.test:
 	* test/info.test:
 	* test/scan.test:
+	* unix/tclUnixThrd.h:  Remove this unused header file.
 
 2011-04-03  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/macosx/Tcl.xcode/project.pbxproj b/macosx/Tcl.xcode/project.pbxproj
index e62ded2..54d9e02 100644
--- a/macosx/Tcl.xcode/project.pbxproj
+++ b/macosx/Tcl.xcode/project.pbxproj
@@ -829,7 +829,6 @@
 		F96D446708F272B9004A47F5 /* tclUnixSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixSock.c; sourceTree = "<group>"; };
 		F96D446808F272B9004A47F5 /* tclUnixTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTest.c; sourceTree = "<group>"; };
 		F96D446908F272B9004A47F5 /* tclUnixThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixThrd.c; sourceTree = "<group>"; };
-		F96D446A08F272B9004A47F5 /* tclUnixThrd.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclUnixThrd.h; sourceTree = "<group>"; };
 		F96D446B08F272B9004A47F5 /* tclUnixTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTime.c; sourceTree = "<group>"; };
 		F96D446C08F272B9004A47F5 /* tclXtNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtNotify.c; sourceTree = "<group>"; };
 		F96D446D08F272B9004A47F5 /* tclXtTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtTest.c; sourceTree = "<group>"; };
@@ -1732,7 +1731,6 @@
 				F96D446708F272B9004A47F5 /* tclUnixSock.c */,
 				F96D446808F272B9004A47F5 /* tclUnixTest.c */,
 				F96D446908F272B9004A47F5 /* tclUnixThrd.c */,
-				F96D446A08F272B9004A47F5 /* tclUnixThrd.h */,
 				F96D446B08F272B9004A47F5 /* tclUnixTime.c */,
 				F96D446C08F272B9004A47F5 /* tclXtNotify.c */,
 				F96D446D08F272B9004A47F5 /* tclXtTest.c */,
diff --git a/macosx/Tcl.xcodeproj/project.pbxproj b/macosx/Tcl.xcodeproj/project.pbxproj
index 002ab80..3cc34d7 100644
--- a/macosx/Tcl.xcodeproj/project.pbxproj
+++ b/macosx/Tcl.xcodeproj/project.pbxproj
@@ -829,7 +829,6 @@
 		F96D446708F272B9004A47F5 /* tclUnixSock.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixSock.c; sourceTree = "<group>"; };
 		F96D446808F272B9004A47F5 /* tclUnixTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTest.c; sourceTree = "<group>"; };
 		F96D446908F272B9004A47F5 /* tclUnixThrd.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixThrd.c; sourceTree = "<group>"; };
-		F96D446A08F272B9004A47F5 /* tclUnixThrd.h */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.h; path = tclUnixThrd.h; sourceTree = "<group>"; };
 		F96D446B08F272B9004A47F5 /* tclUnixTime.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclUnixTime.c; sourceTree = "<group>"; };
 		F96D446C08F272B9004A47F5 /* tclXtNotify.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtNotify.c; sourceTree = "<group>"; };
 		F96D446D08F272B9004A47F5 /* tclXtTest.c */ = {isa = PBXFileReference; fileEncoding = 4; lastKnownFileType = sourcecode.c.c; path = tclXtTest.c; sourceTree = "<group>"; };
@@ -1732,7 +1731,6 @@
 				F96D446708F272B9004A47F5 /* tclUnixSock.c */,
 				F96D446808F272B9004A47F5 /* tclUnixTest.c */,
 				F96D446908F272B9004A47F5 /* tclUnixThrd.c */,
-				F96D446A08F272B9004A47F5 /* tclUnixThrd.h */,
 				F96D446B08F272B9004A47F5 /* tclUnixTime.c */,
 				F96D446C08F272B9004A47F5 /* tclXtNotify.c */,
 				F96D446D08F272B9004A47F5 /* tclXtTest.c */,
-- 
cgit v0.12


From 0d695fcd80cec0f53ad553a4b0abacbd29aad68c Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 Apr 2011 14:10:01 +0000
Subject: Disable tcl::mathfunc::rmmadwiw by default to make test suite work;
 automated test frameworks have no mind to read...

---
 ChangeLog        | 3 +++
 library/init.tcl | 2 ++
 2 files changed, 5 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index fd79840..976cc58 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
 2011-04-04  Donal K. Fellows  <dkf@users.sf.net>
 
+	* library/init.tcl (tcl::mathfunc::rmmadwiw): Disable by default to
+	make test suite work.
+
 	* generic/tclBasic.c, generic/tclStringObj.c, generic/tclTimer.c,
 	* generic/tclTrace.c, generic/tclUtil.c: More generation of error
 	codes ([format], [after], [trace], RE optimizer).
diff --git a/library/init.tcl b/library/init.tcl
index d85fe2a..f1d6a64 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -823,6 +823,7 @@ proc tcl::CopyDirectory {action src dest} {
 }
 
 # TIP 131
+if 0 {
 proc tcl::rmmadwiw {} {
     set magic {
         42 83 fe f6 ff f8 f1 e5 c6 f9 eb fd ff fb f1 e5 cc f5 ec f5 e3 fd fe
@@ -847,3 +848,4 @@ proc tcl::mathfunc::rmmadwiw {} {
     set matter [lreverse $mind]
     return [join $matter ""]
 }
+}
-- 
cgit v0.12

-- 
cgit v0.12


From 01361668457830c504cc69e5f90269188565a087 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 Apr 2011 20:07:09 +0000
Subject: More generation of error codes (miscellaneous commands mostly already
 handled).

---
 ChangeLog          |  5 +++++
 generic/tclCmdAH.c | 10 ++++++++++
 generic/tclCmdIL.c | 37 +++++++++++++++++++++++++++++++------
 3 files changed, 46 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index bbff697..5f66c86 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-04-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCmdAH.c, generic/tclCmdIL.c: More generation of error
+	codes (miscellaneous commands mostly already handled).
+
 2011-04-04  Don Porter  <dgp@users.sourceforge.net>
 
 	* README:	Updated README files, repairing broken URLs and
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 8b5f13d..765c9dc 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -641,6 +641,8 @@ EncodingDirsObjCmd(
     if (Tcl_SetEncodingSearchPath(objv[1]) == TCL_ERROR) {
 	Tcl_AppendResult(interp, "expected directory list but got \"",
 		TclGetString(objv[1]), "\"", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "ENCODING", "BADPATH",
+		NULL);
 	return TCL_ERROR;
     }
     Tcl_SetObjResult(interp, objv[1]);
@@ -1782,6 +1784,8 @@ PathFilesystemCmd(
     fsInfo = Tcl_FSFileSystemInfo(objv[1]);
     if (fsInfo == NULL) {
 	Tcl_SetResult(interp, "unrecognised path", TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
+		Tcl_GetString(objv[1]), NULL);
 	return TCL_ERROR;
     }
     Tcl_SetObjResult(interp, fsInfo);
@@ -1933,6 +1937,8 @@ PathSplitCmd(
     if (res == NULL) {
 	Tcl_AppendResult(interp, "could not read \"", TclGetString(objv[1]),
 		"\": no such file or directory", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OPERATION", "PATHSPLIT", "NONESUCH",
+		NULL);
 	return TCL_ERROR;
     }
     Tcl_SetObjResult(interp, res);
@@ -2032,6 +2038,8 @@ FilesystemSeparatorCmd(
 
 	if (separatorObj == NULL) {
 	    Tcl_SetResult(interp, "unrecognised path", TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "FILESYSTEM",
+		    Tcl_GetString(objv[1]), NULL);
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, separatorObj);
@@ -2586,6 +2594,8 @@ TclNRForeachCmd(
 		&statePtr->varcList[i], &statePtr->varvList[i]);
 	if (statePtr->varcList[i] < 1) {
 	    Tcl_AppendResult(interp, "foreach varlist is empty", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FOREACH",
+		    "NEEDVARS", NULL);
 	    result = TCL_ERROR;
 	    goto done;
 	}
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index c42a54b..a6af227 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1515,6 +1515,7 @@ InfoHostnameCmd(
 	return TCL_OK;
     }
     Tcl_SetResult(interp, "unable to determine name of host", TCL_STATIC);
+    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "HOSTNAME", "UNKNOWN", NULL);
     return TCL_ERROR;
 }
 
@@ -1632,6 +1633,7 @@ InfoLibraryCmd(
 	return TCL_OK;
     }
     Tcl_SetResult(interp, "no library has been specified for Tcl",TCL_STATIC);
+    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "VARIABLE", "tcl_library",NULL);
     return TCL_ERROR;
 }
 
@@ -2261,11 +2263,11 @@ Tcl_LindexObjCmd(
 
     if (elemPtr == NULL) {
 	return TCL_ERROR;
-    } else {
-	Tcl_SetObjResult(interp, elemPtr);
-	Tcl_DecrRefCount(elemPtr);
-	return TCL_OK;
     }
+
+    Tcl_SetObjResult(interp, elemPtr);
+    Tcl_DecrRefCount(elemPtr);
+    return TCL_OK;
 }
 
 /*
@@ -2379,7 +2381,7 @@ Tcl_ListObjCmd(
      */
 
     if (objc > 1) {
-	Tcl_SetObjResult(interp, Tcl_NewListObj((objc-1), &(objv[1])));
+	Tcl_SetObjResult(interp, Tcl_NewListObj(objc-1, &objv[1]));
     }
     return TCL_OK;
 }
@@ -2502,7 +2504,7 @@ Tcl_LrangeObjCmd(
     if (Tcl_IsShared(objv[1]) ||
 	    (((List *) objv[1]->internalRep.twoPtrValue.ptr1)->refCount > 1)) {
 	Tcl_SetObjResult(interp, Tcl_NewListObj(last - first + 1,
-		&(elemPtrs[first])));
+		&elemPtrs[first]));
     } else {
 	/*
 	 * In-place is possible.
@@ -2568,6 +2570,7 @@ Tcl_LrepeatObjCmd(
     if (elementCount < 0) {
 	Tcl_SetObjResult(interp, Tcl_Format(NULL,
 		"bad count \"%d\": must be integer >= 0", 1, objv+1));
+        Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPEAT","NEGARG", NULL);
 	return TCL_ERROR;
     }
 
@@ -2588,10 +2591,12 @@ Tcl_LrepeatObjCmd(
     if (totalElems != 0 && (totalElems/objc != elementCount
 	    || totalElems/elementCount != objc)) {
 	Tcl_AppendResult(interp, "too many elements in result list", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 	return TCL_ERROR;
     }
     if (totalElems >= 0x20000000) {
 	Tcl_AppendResult(interp, "too many elements in result list", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
 	return TCL_ERROR;
     }
 
@@ -2707,6 +2712,7 @@ Tcl_LreplaceObjCmd(
     if ((first >= listLen) && (listLen > 0)) {
 	Tcl_AppendResult(interp, "list doesn't contain element ",
 		TclGetString(objv[2]), NULL);
+        Tcl_SetErrorCode(interp, "TCL","OPERATION","LREPLACE","BADIDX", NULL);
 	return TCL_ERROR;
     }
     if (last >= listLen) {
@@ -2987,6 +2993,7 @@ Tcl_LsearchObjCmd(
 	    }
 	    if (i > objc-4) {
 		Tcl_AppendResult(interp, "missing starting index", NULL);
+                Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 		result = TCL_ERROR;
 		goto done;
 	    }
@@ -3019,6 +3026,7 @@ Tcl_LsearchObjCmd(
 		Tcl_AppendResult(interp,
 			"\"-index\" option must be followed by list index",
 			NULL);
+                Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 		return TCL_ERROR;
 	    }
 
@@ -3078,12 +3086,16 @@ Tcl_LsearchObjCmd(
 	}
 	Tcl_AppendResult(interp,
 		"-subindices cannot be used without -index option", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+                "BAD_OPTION_MIX", NULL);
 	return TCL_ERROR;
     }
 
     if (bisect && (allMatches || negatedMatch)) {
 	Tcl_AppendResult(interp,
 		"-bisect is not compatible with -all or -not", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSEARCH",
+                "BAD_OPTION_MIX", NULL);
 	return TCL_ERROR;
     }
 
@@ -3651,6 +3663,7 @@ Tcl_LsortObjCmd(
 		Tcl_AppendResult(interp,
 			"\"-command\" option must be followed "
 			"by comparison command", NULL);
+                Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 		sortInfo.resultCode = TCL_ERROR;
 		goto done2;
 	    }
@@ -3674,6 +3687,7 @@ Tcl_LsortObjCmd(
 	    if (i == objc-2) {
 		Tcl_AppendResult(interp, "\"-index\" option must be "
 			"followed by list index", NULL);
+                Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
                 sortInfo.resultCode = TCL_ERROR;
                 goto done2;
 	    }
@@ -3723,6 +3737,7 @@ Tcl_LsortObjCmd(
 	    if (i == objc-2) {
 		Tcl_AppendResult(interp, "\"-stride\" option must be ",
 			"followed by stride length", NULL);
+                Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "MISSING", NULL);
 		sortInfo.resultCode = TCL_ERROR;
 		goto done2;
 	    }
@@ -3733,6 +3748,8 @@ Tcl_LsortObjCmd(
 	    if (groupSize < 2) {
 		Tcl_AppendResult(interp, "stride length must be at least 2",
 			NULL);
+                Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+                        "BADSTRIDE", NULL);
 		sortInfo.resultCode = TCL_ERROR;
 		goto done2;
 	    }
@@ -3829,6 +3846,8 @@ Tcl_LsortObjCmd(
 	    Tcl_AppendResult(interp,
 		    "list size must be a multiple of the stride length",
 		    NULL);
+            Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT", "BADSTRIDE",
+                    NULL);
 	    sortInfo.resultCode = TCL_ERROR;
 	    goto done;
 	}
@@ -3847,6 +3866,8 @@ Tcl_LsortObjCmd(
 		Tcl_AppendResult(interp, "when used with \"-stride\", the "
 			"leading \"-index\" value must be within the group",
 			NULL);
+                Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+                        "BADINDEX", NULL);
 		sortInfo.resultCode = TCL_ERROR;
 		goto done;
 	    }
@@ -4233,6 +4254,8 @@ SortCompare(
 	    Tcl_ResetResult(infoPtr->interp);
 	    Tcl_AppendResult(infoPtr->interp,
 		    "-compare command returned non-integer result", NULL);
+            Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+                    "COMPARISONFAILED", NULL);
 	    infoPtr->resultCode = TCL_ERROR;
 	    return 0;
 	}
@@ -4449,6 +4472,8 @@ SelectObjFromSublist(
 	    Tcl_AppendResult(infoPtr->interp, "element ", buffer,
 		    " missing from sublist \"", TclGetString(objPtr), "\"",
 		    NULL);
+            Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+                    "INDEXFAILED", NULL);
 	    infoPtr->resultCode = TCL_ERROR;
 	    return NULL;
 	}
-- 
cgit v0.12


From 94153a5def93c7aa8fb86247f30c40b138c2e57e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 Apr 2011 20:17:32 +0000
Subject: Test _before_ commit, not after...

---
 generic/tclCmdIL.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index a6af227..0a2784d 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -4254,7 +4254,7 @@ SortCompare(
 	    Tcl_ResetResult(infoPtr->interp);
 	    Tcl_AppendResult(infoPtr->interp,
 		    "-compare command returned non-integer result", NULL);
-            Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+            Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
                     "COMPARISONFAILED", NULL);
 	    infoPtr->resultCode = TCL_ERROR;
 	    return 0;
@@ -4472,7 +4472,7 @@ SelectObjFromSublist(
 	    Tcl_AppendResult(infoPtr->interp, "element ", buffer,
 		    " missing from sublist \"", TclGetString(objPtr), "\"",
 		    NULL);
-            Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSORT",
+            Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
                     "INDEXFAILED", NULL);
 	    infoPtr->resultCode = TCL_ERROR;
 	    return NULL;
-- 
cgit v0.12


From 4b3579029f185d116b809a5697720ceeb868c022 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 4 Apr 2011 22:53:26 +0000
Subject: More generation of error codes (TclOO miscellany).

---
 ChangeLog                 |  4 ++++
 generic/tclOO.c           | 16 ++++++++++++++++
 generic/tclOOBasic.c      |  3 +++
 generic/tclOODefineCmds.c | 31 +++++++++++++++++++++++++++++++
 generic/tclOOInfo.c       | 22 +++++++++-------------
 generic/tclOOMethod.c     |  2 ++
 6 files changed, 65 insertions(+), 13 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5f66c86..c516389 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2011-04-04  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclOO.c, generic/tclOOBasic.c, generic/tclOODefineCmds.c
+	* generic/tclOOInfo.c, generic/tclOOMethod.c: More generation of
+	error codes (TclOO miscellany).
+
 	* generic/tclCmdAH.c, generic/tclCmdIL.c: More generation of error
 	codes (miscellaneous commands mostly already handled).
 
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 047b4c5..6ae82d1 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1401,6 +1401,7 @@ Tcl_NewObjectInstance(
 	    TCL_NAMESPACE_ONLY)) {
 	Tcl_AppendResult(interp, "can't create object \"", nameStr,
 		"\": command already exists with that name", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
 	return NULL;
     }
 
@@ -1459,6 +1460,7 @@ Tcl_NewObjectInstance(
 	    if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
 		Tcl_SetResult(interp, "object deleted in constructor",
 			TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
 		result = TCL_ERROR;
 	    }
 	    TclOODeleteContext(contextPtr);
@@ -1514,6 +1516,7 @@ TclNRNewObjectInstance(
 	    TCL_NAMESPACE_ONLY)) {
 	Tcl_AppendResult(interp, "can't create object \"", nameStr,
 		"\": command already exists with that name", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "OVERWRITE_OBJECT", NULL);
 	return TCL_ERROR;
     }
 
@@ -1592,6 +1595,7 @@ FinalizeAlloc(
 
     if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
 	Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
 	result = TCL_ERROR;
     }
     TclOODeleteContext(contextPtr);
@@ -1646,10 +1650,12 @@ Tcl_CopyObjectInstance(
     if (targetName == NULL && oPtr->classPtr != NULL) {
 	Tcl_AppendResult(interp, "must supply a name when copying a class",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
 	return NULL;
     }
     if (oPtr->flags & ROOT_CLASS) {
 	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
 	return NULL;
     }
 
@@ -2265,6 +2271,8 @@ TclOOObjectCmdCore(
 	    Tcl_AppendResult(interp, "impossible to invoke method \"",
 		    TclGetString(methodNamePtr),
 		    "\": no defined method or unknown method", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD_MAPPED",
+		    TclGetString(methodNamePtr), NULL);
 	    return TCL_ERROR;
 	}
     } else {
@@ -2279,6 +2287,8 @@ TclOOObjectCmdCore(
 	    Tcl_AppendResult(interp, "impossible to invoke method \"",
 		    TclGetString(methodNamePtr),
 		    "\": no defined method or unknown method", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		    TclGetString(methodNamePtr), NULL);
 	    return TCL_ERROR;
 	}
     }
@@ -2304,6 +2314,8 @@ TclOOObjectCmdCore(
 	if (contextPtr->index >= contextPtr->callPtr->numChain) {
 	    Tcl_SetResult(interp, "no valid method implementation",
 		    TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		    TclGetString(methodNamePtr), NULL);
 	    TclOODeleteContext(contextPtr);
 	    return TCL_ERROR;
 	}
@@ -2384,6 +2396,7 @@ Tcl_ObjectContextInvokeNext(
 
 	Tcl_AppendResult(interp, "no next ", methodType, " implementation",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
 	return TCL_ERROR;
     }
 
@@ -2452,6 +2465,7 @@ TclNRObjectContextInvokeNext(
 
 	Tcl_AppendResult(interp, "no next ", methodType, " implementation",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
 	return TCL_ERROR;
     }
 
@@ -2529,6 +2543,8 @@ Tcl_GetObjectFromObj(
   notAnObject:
     Tcl_AppendResult(interp, TclGetString(objPtr),
 	    " does not refer to an object", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "OBJECT", TclGetString(objPtr),
+	    NULL);
     return NULL;
 }
 
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 3fee439..0d38dcd 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -100,6 +100,7 @@ TclOO_Class_Create(
 
 	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
 		"\" is not a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
 
@@ -163,6 +164,7 @@ TclOO_Class_CreateNs(
 
 	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
 		"\" is not a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
 
@@ -231,6 +233,7 @@ TclOO_Class_New(
 
 	Tcl_AppendResult(interp, "object \"", TclGetString(cmdnameObj),
 		"\" is not a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "INSTANTIATE_NONCLASS", NULL);
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 8d8eb85..72732da 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -342,6 +342,8 @@ RenameDeleteMethod(
 	noSuchMethod:
 	    Tcl_AppendResult(interp, "method ", TclGetString(fromPtr),
 		    " does not exist", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "METHOD",
+		    TclGetString(fromPtr), NULL);
 	    return TCL_ERROR;
 	}
 	hPtr = Tcl_FindHashEntry(oPtr->methodsPtr, (char *) fromPtr);
@@ -355,11 +357,13 @@ RenameDeleteMethod(
 	    renameToSelf:
 		Tcl_AppendResult(interp, "cannot rename method to itself",
 			NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_TO_SELF", NULL);
 		return TCL_ERROR;
 	    } else if (!isNew) {
 	    renameToExisting:
 		Tcl_AppendResult(interp, "method called ",
 			TclGetString(toPtr), " already exists", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "RENAME_OVER", NULL);
 		return TCL_ERROR;
 	    }
 	}
@@ -427,6 +431,7 @@ TclOOUnknownDefinition(
 
     if (objc < 2) {
 	Tcl_AppendResult(interp, "bad call of unknown handler", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_UNKNOWN", NULL);
 	return TCL_ERROR;
     }
     if (TclOOGetDefineCmdContext(interp) == NULL) {
@@ -471,6 +476,7 @@ TclOOUnknownDefinition(
 
   noMatch:
     Tcl_AppendResult(interp, "invalid command name \"",soughtStr,"\"", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND", soughtStr, NULL);
     return TCL_ERROR;
 }
 
@@ -560,6 +566,7 @@ InitDefineContext(
 	Tcl_AppendResult(interp,
 		"cannot process definitions; support namespace deleted",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -598,6 +605,7 @@ TclOOGetDefineCmdContext(
 	Tcl_AppendResult(interp, "this command may only be called from within"
 		" the context of an ::oo::define or ::oo::objdefine command",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return NULL;
     }
     return (Tcl_Object) iPtr->varFramePtr->clientData;
@@ -638,6 +646,8 @@ GetClassInOuterContext(
     }
     if (oPtr->classPtr == NULL) {
 	Tcl_AppendResult(interp, errMsg, NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+		TclGetString(className), NULL);
 	return NULL;
     }
     return oPtr->classPtr;
@@ -679,6 +689,8 @@ TclOODefineObjCmd(
     if (oPtr->classPtr == NULL) {
 	Tcl_AppendResult(interp, TclGetString(objv[1]),
 		" does not refer to a class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
+		TclGetString(objv[1]), NULL);
 	return TCL_ERROR;
     }
 
@@ -1038,11 +1050,13 @@ TclOODefineClassObjCmd(
     if (oPtr->flags & ROOT_OBJECT) {
 	Tcl_AppendResult(interp,
 		"may not modify the class of the root object class", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
     if (oPtr->flags & ROOT_CLASS) {
 	Tcl_AppendResult(interp,
 		"may not modify the class of the class of classes", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1070,6 +1084,7 @@ TclOODefineClassObjCmd(
 	Tcl_AppendResult(interp, "may not change a ",
 		(oPtr->classPtr==NULL ? "non-" : ""), "class object into a ",
 		(oPtr->classPtr==NULL ? "" : "non-"), "class object", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "TRANSMUTATION", NULL);
 	return TCL_ERROR;
     }
 
@@ -1190,6 +1205,7 @@ TclOODefineDeleteMethodObjCmd(
     }
     if (!isInstanceDeleteMethod && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1312,6 +1328,7 @@ TclOODefineExportObjCmd(
     clsPtr = oPtr->classPtr;
     if (!isInstanceExport && !clsPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1393,6 +1410,7 @@ TclOODefineFilterObjCmd(
     }
     if (!isInstanceFilter && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1438,6 +1456,7 @@ TclOODefineForwardObjCmd(
     }
     if (!isInstanceForward && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
     isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
@@ -1494,6 +1513,7 @@ TclOODefineMethodObjCmd(
     }
     if (!isInstanceMethod && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
     isPublic = Tcl_StringMatch(TclGetString(objv[1]), "[a-z]*")
@@ -1544,6 +1564,7 @@ TclOODefineMixinObjCmd(
     }
     if (!isInstanceMixin && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
     mixins = TclStackAlloc(interp, sizeof(Class *) * (objc-1));
@@ -1557,6 +1578,7 @@ TclOODefineMixinObjCmd(
 	}
 	if (!isInstanceMixin && TclOOIsReachable(oPtr->classPtr, clsPtr)) {
 	    Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
 	    goto freeAndError;
 	}
 	mixins[i-1] = clsPtr;
@@ -1607,6 +1629,7 @@ TclOODefineRenameMethodObjCmd(
     }
     if (!isInstanceRenameMethod && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1667,11 +1690,13 @@ TclOODefineSuperclassObjCmd(
     if (oPtr->classPtr == NULL) {
 	Tcl_AppendResult(interp, "only classes may have superclasses defined",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "OBJECT_NOT_CLASS", NULL);
 	return TCL_ERROR;
     }
     if (oPtr->flags & ROOT_OBJECT) {
 	Tcl_AppendResult(interp,
 		"may not modify the superclass of the root object", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1696,12 +1721,14 @@ TclOODefineSuperclassObjCmd(
 	    if (superclasses[j] == clsPtr) {
 		Tcl_AppendResult(interp,
 			"class should only be a direct superclass once",NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
 		goto failedAfterAlloc;
 	    }
 	}
 	if (TclOOIsReachable(oPtr->classPtr, clsPtr)) {
 	    Tcl_AppendResult(interp,
 		    "attempt to form circular dependency graph", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
 	failedAfterAlloc:
 	    ckfree(superclasses);
 	    return TCL_ERROR;
@@ -1768,6 +1795,7 @@ TclOODefineUnexportObjCmd(
     clsPtr = oPtr->classPtr;
     if (!isInstanceUnexport && !clsPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1851,6 +1879,7 @@ TclOODefineVariablesObjCmd(
     }
     if (!isInstanceVars && !oPtr->classPtr) {
 	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
 	return TCL_ERROR;
     }
 
@@ -1861,11 +1890,13 @@ TclOODefineVariablesObjCmd(
 	    Tcl_AppendResult(interp, "invalid declared variable name \"",
 		    varName, "\": must not contain namespace separators",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
 	    return TCL_ERROR;
 	}
 	if (Tcl_StringMatch(varName, "*(*)")) {
 	    Tcl_AppendResult(interp, "invalid declared variable name \"",
 		    varName, "\": must not refer to an array element", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
 	    return TCL_ERROR;
 	}
     }
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 2cd7cc3..4f25772 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -216,30 +216,22 @@ InfoObjectClassCmd(
 		TclOOObjectName(interp, oPtr->selfCls->thisPtr));
 	return TCL_OK;
     } else {
-	Object *o2Ptr;
-	Class *mixinPtr;
+	Class *mixinPtr, *o2clsPtr;
 	int i;
 
-	o2Ptr = (Object *) Tcl_GetObjectFromObj(interp, objv[2]);
-	if (o2Ptr == NULL) {
-	    return TCL_ERROR;
-	}
-	if (o2Ptr->classPtr == NULL) {
-	    Tcl_AppendResult(interp, "object \"", TclGetString(objv[2]),
-		    "\" is not a class", NULL);
-	    Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "CLASS",
-		    TclGetString(objv[2]), NULL);
+	o2clsPtr = GetClassFromObj(interp, objv[2]);
+	if (o2clsPtr == NULL) {
 	    return TCL_ERROR;
 	}
 
 	FOREACH(mixinPtr, oPtr->mixins) {
-	    if (TclOOIsReachable(o2Ptr->classPtr, mixinPtr)) {
+	    if (TclOOIsReachable(o2clsPtr, mixinPtr)) {
 		Tcl_SetObjResult(interp, Tcl_NewIntObj(1));
 		return TCL_OK;
 	    }
 	}
 	Tcl_SetObjResult(interp, Tcl_NewIntObj(
-		TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)));
+		TclOOIsReachable(o2clsPtr, oPtr->selfCls)));
 	return TCL_OK;
     }
 }
@@ -496,6 +488,7 @@ InfoObjectIsACmd(
 	}
 	if (o2Ptr->classPtr == NULL) {
 	    Tcl_AppendResult(interp, "non-classes cannot be mixins", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
 	    return TCL_ERROR;
 	} else {
 	    Class *mixinPtr;
@@ -520,6 +513,7 @@ InfoObjectIsACmd(
 	}
 	if (o2Ptr->classPtr == NULL) {
 	    Tcl_AppendResult(interp, "non-classes cannot be types", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "NONCLASS", NULL);
 	    return TCL_ERROR;
 	}
 	if (TclOOIsReachable(o2Ptr->classPtr, oPtr->selfCls)) {
@@ -882,6 +876,7 @@ InfoClassConstrCmd(
     if (procPtr == NULL) {
 	Tcl_AppendResult(interp,
 		"definition not available for this kind of method", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
 	return TCL_ERROR;
     }
 
@@ -1009,6 +1004,7 @@ InfoClassDestrCmd(
     if (procPtr == NULL) {
 	Tcl_AppendResult(interp,
 		"definition not available for this kind of method", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "METHOD_TYPE", NULL);
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 112d663..4e7edb8 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1340,6 +1340,7 @@ TclOONewForwardInstanceMethod(
     if (prefixLen < 1) {
 	Tcl_AppendResult(interp, "method forward prefix must be non-empty",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
 	return NULL;
     }
 
@@ -1381,6 +1382,7 @@ TclOONewForwardMethod(
     if (prefixLen < 1) {
 	Tcl_AppendResult(interp, "method forward prefix must be non-empty",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_FORWARD", NULL);
 	return NULL;
     }
 
-- 
cgit v0.12


From a6cc2f3c23ebe5374eabe590cb06cb4c4b419dbc Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 6 Apr 2011 13:05:44 +0000
Subject: More generation of error codes (most platform-specific parts not
 already using Tcl_PosixError).

---
 generic/tclFCmd.c      |  8 +++++
 macosx/tclMacOSXFCmd.c |  3 ++
 unix/tclUnixChan.c     | 21 ++++++++++++
 unix/tclUnixFCmd.c     |  5 +++
 win/tclWinChan.c       |  2 ++
 win/tclWinDde.c        | 16 ++++++++-
 win/tclWinFCmd.c       |  5 ++-
 win/tclWinLoad.c       | 27 ++++++++++-----
 win/tclWinPipe.c       |  2 ++
 win/tclWinReg.c        |  2 ++
 win/tclWinSerial.c     | 65 ++++++++++++++++++++++++++++--------
 win/tclWinSock.c       | 90 ++++++++++++++++++++++----------------------------
 12 files changed, 173 insertions(+), 73 deletions(-)

diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index c3a0a5e..e9176ca 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -1060,6 +1060,7 @@ TclFileAttrsCmd(
 	    Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
 		    "\", there are no file attributes in this filesystem.",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
 	    goto end;
 	}
 
@@ -1086,6 +1087,7 @@ TclFileAttrsCmd(
 	    Tcl_AppendResult(interp, "bad option \"", TclGetString(objv[0]),
 		    "\", there are no file attributes in this filesystem.",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL","OPERATION","FATTR","NONE", NULL);
 	    goto end;
 	}
 
@@ -1100,6 +1102,8 @@ TclFileAttrsCmd(
 	    if (i + 1 == objc) {
 		Tcl_AppendResult(interp, "value for \"",
 			TclGetString(objv[i]), "\" missing", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FATTR",
+			"NOVALUE", NULL);
 		goto end;
 	    }
 	    if (Tcl_FSFileAttrsSet(interp, index, filePtr,
@@ -1213,6 +1217,7 @@ TclFileLinkCmd(
 		Tcl_AppendResult(interp, "could not create new link \"",
 			TclGetString(objv[index]),
 			"\": that path already exists", NULL);
+		Tcl_PosixError(interp);
 	    } else if (errno == ENOENT) {
 		/*
 		 * There are two cases here: either the target doesn't exist,
@@ -1232,11 +1237,14 @@ TclFileLinkCmd(
 		    Tcl_AppendResult(interp, "could not create new link \"",
 			    TclGetString(objv[index]),
 			    "\": no such file or directory", NULL);
+		    Tcl_PosixError(interp);
 		} else {
 		    Tcl_AppendResult(interp, "could not create new link \"",
 			    TclGetString(objv[index]), "\": target \"",
 			    TclGetString(objv[index+1]), "\" doesn't exist",
 			    NULL);
+		    errno = ENOENT;
+		    Tcl_PosixError(interp);
 		}
 	    } else {
 		Tcl_AppendResult(interp, "could not create new link \"",
diff --git a/macosx/tclMacOSXFCmd.c b/macosx/tclMacOSXFCmd.c
index 717c947..64cbbea 100644
--- a/macosx/tclMacOSXFCmd.c
+++ b/macosx/tclMacOSXFCmd.c
@@ -200,6 +200,7 @@ TclMacOSXGetFileAttribute(
     return TCL_OK;
 #else
     Tcl_AppendResult(interp, "Mac OS X file attributes not supported", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
     return TCL_ERROR;
 #endif
 }
@@ -329,6 +330,7 @@ TclMacOSXSetFileAttribute(
 	    if (newRsrcForkSize != 0) {
 		Tcl_AppendResult(interp,
 			"setting nonzero rsrclength not supported", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
 		return TCL_ERROR;
 	    }
 
@@ -369,6 +371,7 @@ TclMacOSXSetFileAttribute(
     return TCL_OK;
 #else
     Tcl_AppendResult(interp, "Mac OS X file attributes not supported", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);
     return TCL_ERROR;
 #endif
 }
diff --git a/unix/tclUnixChan.c b/unix/tclUnixChan.c
index 6ee9b89..866d77d 100644
--- a/unix/tclUnixChan.c
+++ b/unix/tclUnixChan.c
@@ -139,6 +139,7 @@ typedef struct TtyAttrs {
     if (interp) {						\
 	Tcl_AppendResult(interp, (detail),			\
 		" not supported for this platform", NULL);	\
+	Tcl_SetErrorCode(interp, "TCL", "UNSUPPORTED", NULL);	\
     }
 
 /*
@@ -699,6 +700,8 @@ TtySetOptionProc(
 		Tcl_AppendResult(interp, "bad value for -handshake: "
 			"must be one of xonxoff, rtscts, dtrdsr or none",
 			NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
+			"VALUE", NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -719,6 +722,8 @@ TtySetOptionProc(
 	    if (interp) {
 		Tcl_AppendResult(interp, "bad value for -xchar: "
 			"should be a list of two elements", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
+			"VALUE", NULL);
 	    }
 	    ckfree(argv);
 	    return TCL_ERROR;
@@ -770,6 +775,8 @@ TtySetOptionProc(
 	    if (interp) {
 		Tcl_AppendResult(interp, "bad value for -ttycontrol: "
 			"should be a list of signal,value pairs", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
+			"VALUE", NULL);
 	    }
 	    ckfree(argv);
 	    return TCL_ERROR;
@@ -818,6 +825,8 @@ TtySetOptionProc(
 		    Tcl_AppendResult(interp, "bad signal \"", argv[i],
 			    "\" for -ttycontrol: must be "
 			    "DTR, RTS or BREAK", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "FCONFIGURE",
+			"VALUE", NULL);
 		}
 		ckfree(argv);
 		return TCL_ERROR;
@@ -1381,6 +1390,7 @@ TtyParseMode(
 	if (interp != NULL) {
 	    Tcl_AppendResult(interp, bad, ": should be baud,parity,data,stop",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
 	}
 	return TCL_ERROR;
     }
@@ -1409,6 +1419,7 @@ TtyParseMode(
 		    "n, o, or e",
 #endif /* PAREXT|USE_TERMIO */
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
 	}
 	return TCL_ERROR;
     }
@@ -1417,12 +1428,14 @@ TtyParseMode(
 	if (interp != NULL) {
 	    Tcl_AppendResult(interp, bad, " data: should be 5, 6, 7, or 8",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
 	}
 	return TCL_ERROR;
     }
     if ((*stopPtr < 0) || (*stopPtr > 2)) {
 	if (interp != NULL) {
 	    Tcl_AppendResult(interp, bad, " stop: should be 1 or 2", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
 	}
 	return TCL_ERROR;
     }
@@ -1832,10 +1845,14 @@ Tcl_GetOpenFile(
     if ((forWriting) && ((chanMode & TCL_WRITABLE) == 0)) {
 	Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for writing",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_WRITABLE",
+		NULL);
 	return TCL_ERROR;
     } else if ((!forWriting) && ((chanMode & TCL_READABLE) == 0)) {
 	Tcl_AppendResult(interp, "\"", chanID, "\" wasn't opened for reading",
 		NULL);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NOT_READABLE",
+		NULL);
 	return TCL_ERROR;
     }
 
@@ -1866,6 +1883,8 @@ Tcl_GetOpenFile(
 	    if (f == NULL) {
 		Tcl_AppendResult(interp, "cannot get a FILE * for \"", chanID,
 			"\"", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL",
+			"FILE_FAILURE", NULL);
 		return TCL_ERROR;
 	    }
 	    *filePtr = f;
@@ -1875,6 +1894,8 @@ Tcl_GetOpenFile(
 
     Tcl_AppendResult(interp, "\"", chanID,
 	    "\" cannot be used to get a FILE *", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "NO_DESCRIPTOR",
+	    NULL);
     return TCL_ERROR;
 }
 
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index c71ccd0..e3d9022 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -1483,6 +1483,8 @@ SetGroupAttribute(
 		Tcl_AppendResult(interp, "could not set group for file \"",
 			TclGetString(fileName), "\": group \"", string,
 			"\" does not exist", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETGRP",
+			"NO_GROUP", NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1547,6 +1549,8 @@ SetOwnerAttribute(
 		Tcl_AppendResult(interp, "could not set owner for file \"",
 			TclGetString(fileName), "\": user \"", string,
 			"\" does not exist", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "SETOWN",
+			"NO_USER", NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1640,6 +1644,7 @@ SetPermissionsAttribute(
 	    if (interp != NULL) {
 		Tcl_AppendResult(interp, "unknown permission string format \"",
 			modeStringPtr, "\"", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "PERMISSION", NULL);
 	    }
 	    return TCL_ERROR;
 	}
diff --git a/win/tclWinChan.c b/win/tclWinChan.c
index 6e1844b..517aa20 100644
--- a/win/tclWinChan.c
+++ b/win/tclWinChan.c
@@ -997,6 +997,8 @@ TclpOpenFileChannel(
 	channel = NULL;
 	Tcl_AppendResult(interp, "couldn't open \"", TclGetString(pathPtr),
 		"\": bad file type", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "VALUE", "CHANNEL", "BAD_TYPE",
+		NULL);
 	break;
     }
 
diff --git a/win/tclWinDde.c b/win/tclWinDde.c
index 75f4345..6523357 100644
--- a/win/tclWinDde.c
+++ b/win/tclWinDde.c
@@ -531,6 +531,7 @@ ExecuteRemoteObject(
 	Tcl_SetObjResult(riPtr->interp, Tcl_NewStringObj("permission denied: "
 		"a handler procedure must be defined for use in a safe "
 		"interp", -1));
+	Tcl_SetErrorCode(riPtr->interp, "TCL", "DDE", "SECURITY_CHECK", NULL);
 	result = TCL_ERROR;
     }
 
@@ -898,6 +899,7 @@ MakeDdeConnection(
 	if (interp != NULL) {
 	    Tcl_AppendResult(interp, "no registered server named \"",
 		    name, "\"", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
 	}
 	return TCL_ERROR;
     }
@@ -1100,25 +1102,30 @@ static void
 SetDdeError(
     Tcl_Interp *interp)	    /* The interp to put the message in. */
 {
-    const char *errorMessage;
+    const char *errorMessage, *errorCode;
 
     switch (DdeGetLastError(ddeInstance)) {
     case DMLERR_DATAACKTIMEOUT:
     case DMLERR_EXECACKTIMEOUT:
     case DMLERR_POKEACKTIMEOUT:
 	errorMessage = "remote interpreter did not respond";
+	errorCode = "TIMEOUT";
 	break;
     case DMLERR_BUSY:
 	errorMessage = "remote server is busy";
+	errorCode = "BUSY";
 	break;
     case DMLERR_NOTPROCESSED:
 	errorMessage = "remote server cannot handle this command";
+	errorCode = "NOCANDO";
 	break;
     default:
 	errorMessage = "dde command failed";
+	errorCode = "FAILED";
     }
 
     Tcl_SetObjResult(interp, Tcl_NewStringObj(errorMessage, -1));
+    Tcl_SetErrorCode(interp, "TCL", "DDE", errorCode, NULL);
 }
 
 /*
@@ -1355,6 +1362,7 @@ DdeObjCmd(
 	if (dataLength == 0) {
 	    Tcl_SetObjResult(interp,
 		    Tcl_NewStringObj("cannot execute null data", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
 	    result = TCL_ERROR;
 	    break;
 	}
@@ -1397,6 +1405,7 @@ DdeObjCmd(
 	if (length == 0) {
 	    Tcl_SetObjResult(interp,
 		    Tcl_NewStringObj("cannot request value of null data", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
 	    result = TCL_ERROR;
 	    goto cleanup;
 	}
@@ -1447,6 +1456,7 @@ DdeObjCmd(
 	if (length == 0) {
 	    Tcl_SetObjResult(interp,
 		    Tcl_NewStringObj("cannot have a null item", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "DDE", "NULL", NULL);
 	    result = TCL_ERROR;
 	    goto cleanup;
 	}
@@ -1489,6 +1499,7 @@ DdeObjCmd(
 	if (serviceName == NULL) {
 	    Tcl_SetObjResult(interp,
 		    Tcl_NewStringObj("invalid service name \"\"", -1));
+	    Tcl_SetErrorCode(interp, "TCL", "DDE", "NO_SERVER", NULL);
 	    result = TCL_ERROR;
 	    goto cleanup;
 	}
@@ -1536,6 +1547,8 @@ DdeObjCmd(
 		Tcl_SetResult(riPtr->interp, "permission denied: "
 			"a handler procedure must be defined for use in "
 			"a safe interp", TCL_STATIC);
+		Tcl_SetErrorCode(interp, "TCL", "DDE", "SECURITY_CHECK",
+			NULL);
 		result = TCL_ERROR;
 	    }
 
@@ -1600,6 +1613,7 @@ DdeObjCmd(
 		Tcl_SetObjResult(interp,
 			Tcl_NewStringObj("invalid data returned from server",
 			-1));
+		Tcl_SetErrorCode(interp, "TCL", "DDE", "BAD_RESPONSE", NULL);
 		result = TCL_ERROR;
 		goto cleanup;
 	    }
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index 07abc83..fea9ddb 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -1653,6 +1653,8 @@ ConvertFileNameFormat(
 	    Tcl_AppendResult(interp, "could not read \"",
 		    Tcl_GetString(fileName), "\": no such file or directory",
 		    (char *) NULL);
+	    errno = ENOENT;
+	    Tcl_PosixError(interp);
 	}
 	goto cleanup;
     }
@@ -1944,9 +1946,10 @@ CannotSetAttribute(
     Tcl_AppendResult(interp, "cannot set attribute \"",
 	    tclpFileAttrStrings[objIndex], "\" for file \"",
 	    Tcl_GetString(fileName), "\": attribute is readonly", NULL);
+    errno = EINVAL;
+    Tcl_PosixError(interp);
     return TCL_ERROR;
 }
-
 
 /*
  *---------------------------------------------------------------------------
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index e877ebe..3f4d4d9 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -125,20 +125,27 @@ TclpDlopen(
 
 	switch (lastError) {
 	case ERROR_MOD_NOT_FOUND:
+	    Tcl_SetErrorCode(interp, "WIN_LOAD", "MOD_NOT_FOUND", NULL);
+	    goto notFoundMsg;
 	case ERROR_DLL_NOT_FOUND:
+	    Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_NOT_FOUND", NULL);
+	notFoundMsg:
 	    Tcl_AppendResult(interp, "this library or a dependent library"
 		    " could not be found in library path", NULL);
 	    break;
 	case ERROR_PROC_NOT_FOUND:
+	    Tcl_SetErrorCode(interp, "WIN_LOAD", "PROC_NOT_FOUND", NULL);
 	    Tcl_AppendResult(interp, "A function specified in the import"
 		    " table could not be resolved by the system.  Windows"
 		    " is not telling which one, I'm sorry.", NULL);
 	    break;
 	case ERROR_INVALID_DLL:
+	    Tcl_SetErrorCode(interp, "WIN_LOAD", "INVALID_DLL", NULL);
 	    Tcl_AppendResult(interp, "this library or a dependent library"
 		    " is damaged", NULL);
 	    break;
 	case ERROR_DLL_INIT_FAILED:
+	    Tcl_SetErrorCode(interp, "WIN_LOAD", "DLL_INIT_FAILED", NULL);
 	    Tcl_AppendResult(interp, "the library initialization"
 		    " routine failed", NULL);
 	    break;
@@ -147,14 +154,18 @@ TclpDlopen(
 	    Tcl_AppendResult(interp, Tcl_PosixError(interp), NULL);
 	}
 	return TCL_ERROR;
-    } else {
-	handlePtr = ckalloc(sizeof(struct Tcl_LoadHandle_));
-	handlePtr->clientData = (ClientData) hInstance;
-	handlePtr->findSymbolProcPtr = &FindSymbol;
-	handlePtr->unloadFileProcPtr = &UnloadFile;
-	*loadHandle = handlePtr;
-	*unloadProcPtr = &UnloadFile;
     }
+
+    /*
+     * Succeded; package everything up for Tcl.
+     */
+
+    handlePtr = ckalloc(sizeof(struct Tcl_LoadHandle_));
+    handlePtr->clientData = (ClientData) hInstance;
+    handlePtr->findSymbolProcPtr = &FindSymbol;
+    handlePtr->unloadFileProcPtr = &UnloadFile;
+    *loadHandle = handlePtr;
+    *unloadProcPtr = &UnloadFile;
     return TCL_OK;
 }
 
@@ -344,7 +355,7 @@ TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */
     }
     if (dllDirectoryName == NULL) {
 	Tcl_AppendResult(interp, "couldn't create temporary directory: ",
-			 Tcl_PosixError(interp), NULL);
+		Tcl_PosixError(interp), NULL);
     }
     fileName = TclpNativeToNormalized(dllDirectoryName);
     tail = TclPathPart(interp, path, TCL_PATH_TAIL);
diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index 74021e9..b9b881c 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -1136,6 +1136,8 @@ TclpCreateProcess(
 	    Tcl_AppendResult(interp,
 		    "DOS application process not supported on this platform",
 		    (char *) NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "EXEC", "DOS_APP",
+		    NULL);
 	    goto end;
 	}
     }
diff --git a/win/tclWinReg.c b/win/tclWinReg.c
index 7462031..1390415 100644
--- a/win/tclWinReg.c
+++ b/win/tclWinReg.c
@@ -421,6 +421,7 @@ DeleteKey(
     if (*keyName == '\0') {
 	Tcl_SetObjResult(interp,
 		Tcl_NewStringObj("bad key: cannot delete root keys", -1));
+	Tcl_SetErrorCode(interp, "WIN_REG", "DEL_ROOT_KEY", NULL);
 	ckfree(buffer);
 	return TCL_ERROR;
     }
@@ -1123,6 +1124,7 @@ ParseKeyName(
     if (!rootName) {
 	Tcl_AppendResult(interp, "bad key \"", name,
 		"\": must start with a valid root", NULL);
+	Tcl_SetErrorCode(interp, "WIN_REG", "NO_ROOT_KEY", NULL);
 	return TCL_ERROR;
     }
 
diff --git a/win/tclWinSerial.c b/win/tclWinSerial.c
index 2bcc77c..503358b 100644
--- a/win/tclWinSerial.c
+++ b/win/tclWinSerial.c
@@ -1676,7 +1676,9 @@ SerialSetOptionProc(
     if ((len > 2) && (strncmp(optionName, "-mode", len) == 0)) {
 	if (!GetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't get comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't get comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1688,6 +1690,7 @@ SerialSetOptionProc(
 	    if (interp != NULL) {
 		Tcl_AppendResult(interp, "bad value \"", value,
 			"\" for -mode: should be baud,parity,data,stop", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "SERIALMODE", NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1703,7 +1706,9 @@ SerialSetOptionProc(
 
 	if (!SetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't set comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't set comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1717,7 +1722,9 @@ SerialSetOptionProc(
     if ((len > 1) && (strncmp(optionName, "-handshake", len) == 0)) {
 	if (!GetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't get comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't get comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1757,13 +1764,16 @@ SerialSetOptionProc(
 		Tcl_AppendResult(interp, "bad value \"", value,
 			"\" for -handshake: must be one of xonxoff, rtscts, "
 			"dtrdsr or none", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "HANDSHAKE", NULL);
 	    }
 	    return TCL_ERROR;
 	}
 
 	if (!SetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't set comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't set comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1777,7 +1787,9 @@ SerialSetOptionProc(
     if ((len > 1) && (strncmp(optionName, "-xchar", len) == 0)) {
 	if (!GetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't get comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't get comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1791,6 +1803,7 @@ SerialSetOptionProc(
 		Tcl_AppendResult(interp, "bad value for -xchar: should be "
 			"a list of two elements with each a single character",
 			NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "XCHAR", NULL);
 	    }
 	    ckfree(argv);
 	    return TCL_ERROR;
@@ -1827,7 +1840,9 @@ SerialSetOptionProc(
 
 	if (!SetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't set comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't set comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1849,6 +1864,7 @@ SerialSetOptionProc(
 		Tcl_AppendResult(interp, "bad value \"", value,
 			"\" for -ttycontrol: should be a list of "
 			"signal,value pairs", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTYCONTROL", NULL);
 	    }
 	    ckfree(argv);
 	    return TCL_ERROR;
@@ -1864,6 +1880,8 @@ SerialSetOptionProc(
 			(DWORD) (flag ? SETDTR : CLRDTR))) {
 		    if (interp != NULL) {
 			Tcl_AppendResult(interp, "can't set DTR signal", NULL);
+			Tcl_SetErrorCode(interp, "TCL", "OPERATION",
+				"FCONFIGURE", "TTY_SIGNAL", NULL);
 		    }
 		    result = TCL_ERROR;
 		    break;
@@ -1873,6 +1891,8 @@ SerialSetOptionProc(
 			(DWORD) (flag ? SETRTS : CLRRTS))) {
 		    if (interp != NULL) {
 			Tcl_AppendResult(interp, "can't set RTS signal", NULL);
+			Tcl_SetErrorCode(interp, "TCL", "OPERATION",
+				"FCONFIGURE", "TTY_SIGNAL", NULL);
 		    }
 		    result = TCL_ERROR;
 		    break;
@@ -1882,6 +1902,8 @@ SerialSetOptionProc(
 			(DWORD) (flag ? SETBREAK : CLRBREAK))) {
 		    if (interp != NULL) {
 			Tcl_AppendResult(interp,"can't set BREAK signal",NULL);
+			Tcl_SetErrorCode(interp, "TCL", "OPERATION",
+				"FCONFIGURE", "TTY_SIGNAL", NULL);
 		    }
 		    result = TCL_ERROR;
 		    break;
@@ -1891,6 +1913,8 @@ SerialSetOptionProc(
 		    Tcl_AppendResult(interp, "bad signal name \"", argv[i],
 			    "\" for -ttycontrol: must be DTR, RTS or BREAK",
 			    NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "TTY_SIGNAL",
+			    NULL);
 		}
 		result = TCL_ERROR;
 		break;
@@ -1930,13 +1954,16 @@ SerialSetOptionProc(
 		Tcl_AppendResult(interp, "bad value \"", value,
 			"\" for -sysbuffer: should be a list of one or two "
 			"integers > 0", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "SYS_BUFFER", NULL);
 	    }
 	    return TCL_ERROR;
 	}
 
 	if (!SetupComm(infoPtr->handle, inSize, outSize)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't setup comm buffers", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't setup comm buffers: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1950,7 +1977,9 @@ SerialSetOptionProc(
 
 	if (!GetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't get comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't get comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1958,7 +1987,9 @@ SerialSetOptionProc(
 	dcb.XoffLim = (WORD) (infoPtr->sysBufRead*1/4);
 	if (!SetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't set comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't set comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1990,7 +2021,9 @@ SerialSetOptionProc(
 	tout.ReadTotalTimeoutConstant = msec;
 	if (!SetCommTimeouts(infoPtr->handle, &tout)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't set comm timeouts", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't set comm timeouts: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -2057,7 +2090,9 @@ SerialGetOptionProc(
 
 	if (!GetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't get comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't get comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -2125,7 +2160,9 @@ SerialGetOptionProc(
 
 	if (!GetCommState(infoPtr->handle, &dcb)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't get comm state", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't get comm state: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -2201,7 +2238,9 @@ SerialGetOptionProc(
 
 	if (!GetCommModemStatus(infoPtr->handle, &status)) {
 	    if (interp != NULL) {
-		Tcl_AppendResult(interp, "can't get tty status", NULL);
+		TclWinConvertError(GetLastError());
+		Tcl_AppendResult(interp, "can't get tty status: ",
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index bd5f0f4..4134420 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -287,8 +287,7 @@ InitSockets(void)
     DWORD id;
     WSADATA wsaData;
     DWORD err;
-    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
-	    TclThreadDataKeyGet(&dataKey);
+    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
     if (!initialized) {
 	initialized = 1;
@@ -482,9 +481,8 @@ SocketExitHandler(
 void
 TclpFinalizeSockets(void)
 {
-    ThreadSpecificData *tsdPtr;
+    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
-    tsdPtr = (ThreadSpecificData *) TclThreadDataKeyGet(&dataKey);
     if (tsdPtr != NULL) {
 	if (tsdPtr->socketThread != NULL) {
 	    if (tsdPtr->hwnd != NULL) {
@@ -810,7 +808,7 @@ TcpBlockProc(
     int mode)			/* TCL_MODE_BLOCKING or
 				 * TCL_MODE_NONBLOCKING. */
 {
-    SocketInfo *infoPtr = (SocketInfo *) instanceData;
+    SocketInfo *infoPtr = instanceData;
 
     if (mode == TCL_MODE_NONBLOCKING) {
 	infoPtr->flags |= SOCKET_ASYNC;
@@ -844,7 +842,7 @@ TcpCloseProc(
     ClientData instanceData,	/* The socket to close. */
     Tcl_Interp *interp)		/* Unused. */
 {
-    SocketInfo *infoPtr = (SocketInfo *) instanceData;
+    SocketInfo *infoPtr = instanceData;
     /* TIP #218 */
     int errorCode = 0;
     /* ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); */
@@ -902,7 +900,7 @@ TcpClose2Proc(
     Tcl_Interp *interp,		/* For error reporting. */
     int flags)			/* Flags that indicate which side to close. */
 {
-    SocketInfo *infoPtr = (SocketInfo *) instanceData;
+    SocketInfo *infoPtr = instanceData;
     int errorCode = 0;
     int sd;
 
@@ -919,7 +917,8 @@ TcpClose2Proc(
 	    break;
 	default:
 	    if (interp) {
-		Tcl_AppendResult(interp, "Socket close2proc called bidirectionally", NULL);
+		Tcl_AppendResult(interp,
+			"Socket close2proc called bidirectionally", NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -1018,8 +1017,7 @@ CreateSocket(
     const char *errorMsg = NULL;
     SOCKET sock = INVALID_SOCKET;
     SocketInfo *infoPtr = NULL;	/* The returned value. */
-    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
-	    TclThreadDataKeyGet(&dataKey);
+    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
     /*
      * Check that WinSock is initialized; do not call it if not, to prevent
@@ -1138,10 +1136,10 @@ CreateSocket(
 	    }
 	}
     } else {
-        for (addrPtr = addrlist; addrPtr != NULL;
-             addrPtr = addrPtr->ai_next) {
-            for (myaddrPtr = myaddrlist; myaddrPtr != NULL;
-                 myaddrPtr = myaddrPtr->ai_next) {
+	for (addrPtr = addrlist; addrPtr != NULL;
+		addrPtr = addrPtr->ai_next) {
+	    for (myaddrPtr = myaddrlist; myaddrPtr != NULL;
+		    myaddrPtr = myaddrPtr->ai_next) {
 		/*
 		 * No need to try combinations of local and remote addresses
 		 * of different families.
@@ -1365,8 +1363,7 @@ WaitForSocketEvent(
 {
     int result = 1;
     int oldMode;
-    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
-	    TclThreadDataKeyGet(&dataKey);
+    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
     /*
      * Be sure to disable event servicing so we are truly modal.
@@ -1498,7 +1495,7 @@ Tcl_MakeTcpClientChannel(
 	return NULL;
     }
 
-    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
+    tsdPtr = TclThreadDataKeyGet(&dataKey);
 
     /*
      * Set kernel space buffering and non-blocking.
@@ -1609,8 +1606,7 @@ TcpAccept(
     SOCKADDR_IN addr;
     int len;
     char channelName[16 + TCL_INTEGER_SPACE];
-    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
-	    TclThreadDataKeyGet(&dataKey);
+    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
     /*
      * Accept the incoming connection request.
@@ -1723,11 +1719,10 @@ TcpInputProc(
     int toRead,			/* Maximum number of bytes to read. */
     int *errorCodePtr)		/* Where to store error codes. */
 {
-    SocketInfo *infoPtr = (SocketInfo *) instanceData;
+    SocketInfo *infoPtr = instanceData;
     int bytesRead;
     DWORD error;
-    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
-	    TclThreadDataKeyGet(&dataKey);
+    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
     *errorCodePtr = 0;
 
@@ -1861,11 +1856,10 @@ TcpOutputProc(
     int toWrite,		/* Maximum number of bytes to write. */
     int *errorCodePtr)		/* Where to store error codes. */
 {
-    SocketInfo *infoPtr = (SocketInfo *) instanceData;
+    SocketInfo *infoPtr = instanceData;
     int bytesWritten;
     DWORD error;
-    ThreadSpecificData *tsdPtr = (ThreadSpecificData *)
-	    TclThreadDataKeyGet(&dataKey);
+    ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
     *errorCodePtr = 0;
 
@@ -1970,7 +1964,7 @@ TcpSetOptionProc(
     const char *optionName,	/* Name of the option to set. */
     const char *value)		/* New value for option. */
 {
-    SocketInfo *infoPtr;
+    SocketInfo *infoPtr = instanceData;
     SOCKET sock;
 
     /*
@@ -1986,7 +1980,6 @@ TcpSetOptionProc(
 	return TCL_ERROR;
     }
 
-    infoPtr = (SocketInfo *) instanceData;
     sock = infoPtr->sockets->fd;
 
 #ifdef TCL_FEATURE_KEEPALIVE_NAGLE
@@ -2070,7 +2063,7 @@ TcpGetOptionProc(
     Tcl_DString *dsPtr)		/* Where to store the computed value;
 				 * initialized by caller. */
 {
-    SocketInfo *infoPtr;
+    SocketInfo *infoPtr = instanceData;
     char host[NI_MAXHOST], port[NI_MAXSERV];
     SOCKET sock;
     size_t len = 0;
@@ -2090,7 +2083,6 @@ TcpGetOptionProc(
 	return TCL_ERROR;
     }
 
-    infoPtr = (SocketInfo *) instanceData;
     sock = infoPtr->sockets->fd;
     if (optionName != NULL) {
 	len = strlen(optionName);
@@ -2116,7 +2108,7 @@ TcpGetOptionProc(
     }
 
     if (interp != NULL && Tcl_GetVar(interp, SUPPRESS_RDNS_VAR, 0) != NULL) {
-        reverseDNS = NI_NUMERICHOST;
+	reverseDNS = NI_NUMERICHOST;
     }
 
     if ((len == 0) || ((len > 1) && (optionName[1] == 'p') &&
@@ -2130,10 +2122,10 @@ TcpGetOptionProc(
 	    }
 
 	    getnameinfo(&(peername.sa), size, host, sizeof(host),
-                        NULL, 0, NI_NUMERICHOST);
+		    NULL, 0, NI_NUMERICHOST);
 	    Tcl_DStringAppendElement(dsPtr, host);
 	    getnameinfo(&(peername.sa), size, host, sizeof(host),
-                        port, sizeof(port), reverseDNS | NI_NUMERICSERV);
+		    port, sizeof(port), reverseDNS | NI_NUMERICSERV);
 	    Tcl_DStringAppendElement(dsPtr, host);
 	    Tcl_DStringAppendElement(dsPtr, port);
 	    if (len == 0) {
@@ -2162,10 +2154,9 @@ TcpGetOptionProc(
 
     if ((len == 0) || ((len > 1) && (optionName[1] == 's') &&
 	    (strncmp(optionName, "-sockname", len) == 0))) {
-
 	TcpFdList *fds;
-        address sockname;
-        socklen_t size;
+	address sockname;
+	socklen_t size;
 	int found = 0;
 
 	if (len == 0) {
@@ -2180,7 +2171,7 @@ TcpGetOptionProc(
 		found = 1;
 
 		getnameinfo(&sockname.sa, size, host, sizeof(host),
-			    NULL, 0, NI_NUMERICHOST);
+			NULL, 0, NI_NUMERICHOST);
 		Tcl_DStringAppendElement(dsPtr, host);
 
 		/*
@@ -2194,17 +2185,17 @@ TcpGetOptionProc(
 		    }
 		} else if (sockname.sa.sa_family == AF_INET6) {
 		    if ((IN6_ARE_ADDR_EQUAL(&sockname.sa6.sin6_addr,
-					    &in6addr_any))
-			|| (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr) &&
-			    sockname.sa6.sin6_addr.s6_addr[12] == 0 &&
-			    sockname.sa6.sin6_addr.s6_addr[13] == 0 &&
-			    sockname.sa6.sin6_addr.s6_addr[14] == 0 &&
-			    sockname.sa6.sin6_addr.s6_addr[15] == 0)) {
+				&in6addr_any)) ||
+			    (IN6_IS_ADDR_V4MAPPED(&sockname.sa6.sin6_addr)
+			    && sockname.sa6.sin6_addr.s6_addr[12] == 0
+			    && sockname.sa6.sin6_addr.s6_addr[13] == 0
+			    && sockname.sa6.sin6_addr.s6_addr[14] == 0
+			    && sockname.sa6.sin6_addr.s6_addr[15] == 0)) {
 			flags |= NI_NUMERICHOST;
 		    }
 		}
 		getnameinfo(&sockname.sa, size, host, sizeof(host),
-			    port, sizeof(port), flags);
+			port, sizeof(port), flags);
 		Tcl_DStringAppendElement(dsPtr, host);
 		Tcl_DStringAppendElement(dsPtr, port);
 	    }
@@ -2219,7 +2210,7 @@ TcpGetOptionProc(
 	    if (interp) {
 		TclWinConvertWSAError((DWORD) WSAGetLastError());
 		Tcl_AppendResult(interp, "can't get sockname: ",
-				 Tcl_PosixError(interp), NULL);
+			Tcl_PosixError(interp), NULL);
 	    }
 	    return TCL_ERROR;
 	}
@@ -2253,8 +2244,7 @@ TcpGetOptionProc(
 	    Tcl_DStringAppendElement(dsPtr, "-nagle");
 	}
 	optlen = sizeof(BOOL);
-	getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt,
-		&optlen);
+	getsockopt(sock, IPPROTO_TCP, TCP_NODELAY, (char *)&opt, &optlen);
 	if (opt) {
 	    Tcl_DStringAppendElement(dsPtr, "0");
 	} else {
@@ -2303,7 +2293,7 @@ TcpWatchProc(
 				 * TCL_READABLE, TCL_WRITABLE and
 				 * TCL_EXCEPTION. */
 {
-    SocketInfo *infoPtr = (SocketInfo *) instanceData;
+    SocketInfo *infoPtr = instanceData;
 
     /*
      * Update the watch events mask. Only if the socket is not a server
@@ -2354,7 +2344,7 @@ TcpGetHandleProc(
     int direction,		/* Not used. */
     ClientData *handlePtr)	/* Where to store the handle. */
 {
-    SocketInfo *statePtr = (SocketInfo *) instanceData;
+    SocketInfo *statePtr = instanceData;
 
     *handlePtr = INT2PTR(statePtr->sockets->fd);
     return TCL_OK;
@@ -2381,7 +2371,7 @@ SocketThread(
     LPVOID arg)
 {
     MSG msg;
-    ThreadSpecificData *tsdPtr = (ThreadSpecificData *) arg;
+    ThreadSpecificData *tsdPtr = arg;
 
     /*
      * Create a dummy window receiving socket events.
@@ -2779,7 +2769,7 @@ TcpThreadActionProc(
     int action)
 {
     ThreadSpecificData *tsdPtr;
-    SocketInfo *infoPtr = (SocketInfo *) instanceData;
+    SocketInfo *infoPtr = instanceData;
     int notifyCmd;
 
     if (action == TCL_CHANNEL_THREAD_INSERT) {
-- 
cgit v0.12


From 5a78efcb890f211902b3dfa661ace0d9c531c056 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 6 Apr 2011 13:07:31 +0000
Subject: Added missing Changelog entry.

---
 ChangeLog | 9 +++++++++
 1 file changed, 9 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 491d0f9..197deaf 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2011-04-06  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclFCmd.c, macosx/tclMacOSXFCmd.c, unix/tclUnixChan.c,
+	* unix/tclUnixFCmd.c, win/tclWinChan.c, win/tclWinDde.c,
+	* win/tclWinFCmd.c, win/tclWinLoad.c, win/tclWinPipe.c,
+	* win/tclWinReg.c, win/tclWinSerial.c, win/tclWinSock.c: More
+	generation of error codes (most platform-specific parts not already
+	using Tcl_PosixError).
+
 2011-04-05  Venkat Iyer <venkat@comit.com>
 
 	* library/tzdata/Africa/Casablanca: Update to Olson's tzdata2011e
-- 
cgit v0.12


From 963891f74c97d0fecfcf5b4825bd5148f67a103c Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 6 Apr 2011 13:09:11 +0000
Subject: Don't use MODULE_SCOPE in module implementation, only in declaration.

---
 generic/tclCompile.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 5565342..3330315 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -4366,7 +4366,7 @@ TclGetInnerContext(
  *----------------------------------------------------------------------
  */
 
-MODULE_SCOPE Tcl_Obj *
+Tcl_Obj *
 TclNewInstNameObj(
     unsigned char inst)
 {
-- 
cgit v0.12


From 7207d9a57abd342956e228d594c8e4a70a03030a Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 6 Apr 2011 13:10:05 +0000
Subject: Make symbols "main" and "Tcl_AppInit" MODULE_SCOPE: there is
 absolutely no reason for exporting them.

---
 ChangeLog         | 5 +++++
 unix/tclAppInit.c | 5 ++++-
 2 files changed, 9 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 197deaf..3ac06bd 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-04-06  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* unix/tclAppInit.c:  Make symbols "main" and "Tcl_AppInit"
+	MODULE_SCOPE: there is absolutely no reason for exporting them.
+
 2011-04-06  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclFCmd.c, macosx/tclMacOSXFCmd.c, unix/tclUnixChan.c,
diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c
index 11ab0d1..0d2a6c4 100644
--- a/unix/tclAppInit.c
+++ b/unix/tclAppInit.c
@@ -12,6 +12,8 @@
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  */
 
+#undef BUILD_tcl
+#undef STATIC_BUILD
 #include "tcl.h"
 
 #ifdef TCL_TEST
@@ -33,7 +35,8 @@ extern int		Tclxttest_Init(Tcl_Interp *interp);
 #ifndef TCL_LOCAL_APPINIT
 #define TCL_LOCAL_APPINIT Tcl_AppInit
 #endif
-extern int TCL_LOCAL_APPINIT(Tcl_Interp *interp);
+MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *);
+MODULE_SCOPE int main(int, char **);
 
 /*
  * The following #if block allows you to change how Tcl finds the startup
-- 
cgit v0.12


From 963b72a978e2d4330b46c084effc90fd45b503d5 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 6 Apr 2011 14:51:57 +0000
Subject: Don't use -fvisibility=hidden with static libraries
 (--disable-shared)

---
 ChangeLog      | 2 ++
 unix/configure | 7 +------
 unix/tcl.m4    | 2 +-
 3 files changed, 4 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 3ac06bd..15cc7a8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,8 @@
 
 	* unix/tclAppInit.c:  Make symbols "main" and "Tcl_AppInit"
 	MODULE_SCOPE: there is absolutely no reason for exporting them.
+	* unix/tcl.m4:        Don't use -fvisibility=hidden with static
+	* unix/configure      libraries (--disable-shared)
 
 2011-04-06  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/unix/configure b/unix/configure
index 8701f7e..4fdddd4 100755
--- a/unix/configure
+++ b/unix/configure
@@ -6479,7 +6479,7 @@ if test "${tcl_cv_cc_visibility_hidden+set}" = set; then
   echo $ECHO_N "(cached) $ECHO_C" >&6
 else
 
-	    if test "$GCC" = yes; then
+	    if test "$GCC" = yes -a "$SHARED_BUILD" = 1; then
 
 		hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror"
 		cat >conftest.$ac_ext <<_ACEOF
@@ -6550,11 +6550,6 @@ _ACEOF
 
 else
 
-
-cat >>confdefs.h <<\_ACEOF
-#define NO_VIZ
-_ACEOF
-
 	hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -Werror"
 	cat >conftest.$ac_ext <<_ACEOF
 /* confdefs.h.  */
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 8c9eaf0..9a02e4c 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1044,7 +1044,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 
     AC_CACHE_CHECK([if compiler supports visibility "hidden"],
 	tcl_cv_cc_visibility_hidden, [
-	    AS_IF([test "$GCC" = yes], [
+	    AS_IF([test "$GCC" = yes -a "$SHARED_BUILD" = 1], [
 		hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror"
 		AC_TRY_COMPILE(,, tcl_cv_cc_visibility_hidden=yes,
 		    tcl_cv_cc_visibility_hidden=no)
-- 
cgit v0.12


From 90b847d5ece274f9530fc51ffe85bc14531d67b6 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Wed, 6 Apr 2011 23:35:17 +0000
Subject: * generic/tclExecute.c: fix for [Bug 3274728], making *catchTop an
 unsigned long.

---
 ChangeLog            | 5 +++++
 generic/tclExecute.c | 4 ++--
 2 files changed, 7 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 15cc7a8..062184f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-04-06  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclExecute.c: fix for [Bug 3274728], making *catchTop an
+	unsigned long.
+	
 2011-04-06  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* unix/tclAppInit.c:  Make symbols "main" and "Tcl_AppInit"
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index f1b8504..3539945 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -172,7 +172,7 @@ typedef struct TEBCdata {
     ByteCode *codePtr;		/* Constant until the BC returns */
 				/* -----------------------------------------*/
     const unsigned char *pc;	/* These fields are used on return TO this */
-    ptrdiff_t *catchTop;	/* this level: they record the state when a */
+    unsigned long *catchTop;	/* this level: they record the state when a */
     int cleanup;		/* new codePtr was received for NR */
     Tcl_Obj *auxObjList;	/* execution. */
     int checkInterp;
@@ -1913,7 +1913,7 @@ TclIncrObj(
  *----------------------------------------------------------------------
  */
 #define	bcFramePtr	(&TD->cmdFrame)
-#define	initCatchTop	((ptrdiff_t *) (&TD->stack[-1]))
+#define	initCatchTop	((unsigned long *) (&TD->stack[-1]))
 #define	initTosPtr	((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
 #define esPtr           (iPtr->execEnvPtr->execStackPtr)
 
-- 
cgit v0.12


From 37684dd968c4300c5b34816c65e2b9b551842fe6 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Thu, 7 Apr 2011 00:11:48 +0000
Subject: last bugfix was incomplete

---
 generic/tclExecute.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 3539945..e11527f 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -335,7 +335,7 @@ VarHashCreateVar(
 
 #define OBJ_AT_DEPTH(n)	*(tosPtr-(n))
 
-#define CURR_DEPTH	(tosPtr - initTosPtr)
+#define CURR_DEPTH	((unsigned long) (tosPtr - initTosPtr))
 
 /*
  * Macros used to trace instruction execution. The macros TRACE,
-- 
cgit v0.12


From 886982eaaeb8e06d1b44c7cf39b1fa4d4c38bffc Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 7 Apr 2011 10:19:46 +0000
Subject: Add some (temporary) test cases showing the problem with
 --export-dynamic

---
 tests/load.test     |  4 ++++
 unix/dltest/pkga.c  | 17 ++++++++++++++++-
 unix/dltest/pkgua.c | 13 ++++++++++++-
 unix/tclAppInit.c   |  8 ++++++++
 4 files changed, 40 insertions(+), 2 deletions(-)

diff --git a/tests/load.test b/tests/load.test
index b7c1a59..2ca6e96 100644
--- a/tests/load.test
+++ b/tests/load.test
@@ -82,6 +82,10 @@ test load-2.3 {loading with no _Init procedure} -constraints [list $dll $loaded]
 test load-2.4 {loading with no _SafeInit procedure} [list $dll $loaded] {
     list [catch {load [file join $testDir pkga$ext] {} child} msg] $msg
 } {1 {can't use package in a safe interpreter: no Pkga_SafeInit procedure}}
+# This test fails due to --export-dynamic
+test load-2.5 {loading package with symbol conflict, this test fails when using  --export-dynamic} [list $dll $loaded] {
+    pkga_quote
+} {I'm in pkga.c}
 
 test load-3.1 {error in _Init procedure, same interpreter} \
 	[list $dll $loaded] {
diff --git a/unix/dltest/pkga.c b/unix/dltest/pkga.c
index c4d3f32..a014458 100644
--- a/unix/dltest/pkga.c
+++ b/unix/dltest/pkga.c
@@ -29,6 +29,17 @@ static int    Pkga_EqObjCmd(ClientData clientData,
 		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
 static int    Pkga_QuoteObjCmd(ClientData clientData,
 		Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]);
+/*
+ * Function to be backlinked from the tcltest executable
+ */
+#if 0
+extern const char *Tcltest_Foo();
+#else
+EXTERN const char *Tcltest_Foo() {
+    return "I'm in pkga.c";
+}
+#endif
+
 
 /*
  *----------------------------------------------------------------------
@@ -99,11 +110,15 @@ Pkga_QuoteObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument strings. */
 {
-    if (objc != 2) {
+    if (objc > 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "value");
 	return TCL_ERROR;
     }
+    if (objc == 1) {
+	Tcl_SetResult(interp, (char *) Tcltest_Foo(), TCL_VOLATILE);
+    } else {
     Tcl_SetObjResult(interp, objv[1]);
+    }
     return TCL_OK;
 }
 
diff --git a/unix/dltest/pkgua.c b/unix/dltest/pkgua.c
index 417bedb..b022c3c 100644
--- a/unix/dltest/pkgua.c
+++ b/unix/dltest/pkgua.c
@@ -13,6 +13,7 @@
 
 #undef STATIC_BUILD
 #include "tcl.h"
+#include <stdio.h>
 
 /*
  * TCL_STORAGE_CLASS is set unconditionally to DLLEXPORT because the
@@ -175,11 +176,21 @@ PkguaQuoteObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument strings. */
 {
-    if (objc != 2) {
+    if (objc > 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "value");
 	return TCL_ERROR;
     }
+    if (objc == 1) {
+	int major, minor, patch, type;
+	char result[128];
+
+#undef Tcl_GetVersion /* Link this symbol without stubs */
+	Tcl_GetVersion(&major, &minor, &patch, &type);
+	sprintf(result, "%d %d %d %d", major, minor, patch, type);
+	Tcl_SetResult(interp, result, TCL_VOLATILE);
+    } else {
     Tcl_SetObjResult(interp, objv[1]);
+    }
     return TCL_OK;
 }
 
diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c
index 0d2a6c4..910a233 100644
--- a/unix/tclAppInit.c
+++ b/unix/tclAppInit.c
@@ -154,6 +154,14 @@ Tcl_AppInit(
 
     return TCL_OK;
 }
+
+#ifdef TCL_TEST
+#   undef TCL_STORAGE_CLASS
+#   define TCL_STORAGE_CLASS DLLEXPORT
+EXTERN const char *Tcltest_Foo() {
+    return "I'm in tclAppInit.c";
+}
+#endif /* TCL_TEST */
 
 /*
  * Local Variables:
-- 
cgit v0.12


From 9d0b3f045b6c187e33ae5e704d5d78b4041102cd Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 8 Apr 2011 06:31:54 +0000
Subject: fix for [Bug 3280043]: win2k: unresolved DLL imports

---
 ChangeLog        |  6 ++++++
 win/configure    | 66 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 win/configure.in | 15 +++++++++++++
 win/tclWinPort.h |  3 +++
 4 files changed, 90 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 6c5a31c..a44ee50 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-04-08  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* win/tclWinPort.h: fix for [Bug 3280043]: win2k: unresolved DLL imports
+	* win/configure.in
+	* win/configure
+
 2011-04-06  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclExecute.c (TclCompileObj): earlier return if Tip280
diff --git a/win/configure b/win/configure
index d1d50e2..c3969fa 100755
--- a/win/configure
+++ b/win/configure
@@ -3700,6 +3700,72 @@ _ACEOF
 
 fi
 
+# See if the <wspiapi.h> header file is present
+
+echo "$as_me:$LINENO: checking for wspiapi.h" >&5
+echo $ECHO_N "checking for wspiapi.h... $ECHO_C" >&6
+if test "${tcl_have_wspiapi_h+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+#include <wspiapi.h>
+
+int
+main ()
+{
+
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  tcl_have_wspiapi_h=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+tcl_have_wspiapi_h=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_have_wspiapi_h" >&5
+echo "${ECHO_T}$tcl_have_wspiapi_h" >&6
+if test "tcl_have_wspiapi_h" = "yes"; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_WSPIAPI_H 1
+_ACEOF
+
+fi
+
 #--------------------------------------------------------------------
 # Determines the correct binary file extension (.o, .obj, .exe etc.)
 #--------------------------------------------------------------------
diff --git a/win/configure.in b/win/configure.in
index 4e9f2db..b286537 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -291,6 +291,21 @@ if test "$tcl_cv_intrinsics" = "yes"; then
             [Defined when the compilers supports intrinsics])
 fi
 
+# See if the <wspiapi.h> header file is present    
+
+AC_CACHE_CHECK(for wspiapi.h,
+    tcl_have_wspiapi_h,
+AC_TRY_COMPILE([
+#include <wspiapi.h>
+], [],
+        tcl_have_wspiapi_h=yes,
+        tcl_have_wspiapi_h=no)
+)
+if test "tcl_have_wspiapi_h" = "yes"; then
+    AC_DEFINE(HAVE_WSPIAPI_H, 1,
+            [Defined when wspiapi.h exists])
+fi
+
 #--------------------------------------------------------------------
 # Determines the correct binary file extension (.o, .obj, .exe etc.)
 #--------------------------------------------------------------------
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index e60ff2c..f7e16a2 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -37,6 +37,9 @@
 #define INCL_WINSOCK_API_TYPEDEFS   1
 #include <winsock2.h>
 #include <ws2tcpip.h>
+#ifdef HAVE_WSPIAPI_H
+#   include <wspiapi.h>
+#endif
 
 #ifdef CHECK_UNICODE_CALLS
 #   define _UNICODE
-- 
cgit v0.12


From 00b1448021754a9cd1539fbf2e362a7bd0828a50 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Sat, 9 Apr 2011 08:03:11 +0000
Subject: typo, (and accidently checked in changes to tclOO.decls, reverted in
 the next commit [d550d19c7c]

---
 generic/tclOO.decls     |  2 +-
 generic/tclOODecls.h    | 75 +++++++++++++++++++++++--------------------------
 generic/tclOOIntDecls.h | 49 +++++++++++++++-----------------
 win/configure           |  2 +-
 win/configure.in        |  2 +-
 5 files changed, 60 insertions(+), 70 deletions(-)

diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index 027dcd0..31d1113 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -6,7 +6,7 @@ library tclOO
 
 interface tclOO
 hooks tclOOInt
-scspec EXTERN
+scspec TCLOOAPI
 
 declare 0 {
     Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 80a10bb..5e48b0b 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -5,14 +5,13 @@
 #ifndef _TCLOODECLS
 #define _TCLOODECLS
 
-#undef TCL_STORAGE_CLASS
-#ifdef BUILD_tcl
-#   define TCL_STORAGE_CLASS DLLEXPORT
-#else
-#   ifdef USE_TCL_STUBS
-#      define TCL_STORAGE_CLASS
+#ifndef TCLOOAPI
+#   ifdef BUILD_tcl
+#	define TCLOOAPI MODULE_SCOPE
 #   else
-#      define TCL_STORAGE_CLASS DLLIMPORT
+#	define TCLOOAPI extern
+#	undef USE_TCLOO_STUBS
+#	define USE_TCLOO_STUBS 1
 #   endif
 #endif
 
@@ -37,92 +36,92 @@ extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version);
  */
 
 /* 0 */
-EXTERN Tcl_Object	Tcl_CopyObjectInstance(Tcl_Interp *interp,
+TCLOOAPI Tcl_Object	Tcl_CopyObjectInstance(Tcl_Interp *interp,
 				Tcl_Object sourceObject,
 				const char *targetName,
 				const char *targetNamespaceName);
 /* 1 */
-EXTERN Tcl_Object	Tcl_GetClassAsObject(Tcl_Class clazz);
+TCLOOAPI Tcl_Object	Tcl_GetClassAsObject(Tcl_Class clazz);
 /* 2 */
-EXTERN Tcl_Class	Tcl_GetObjectAsClass(Tcl_Object object);
+TCLOOAPI Tcl_Class	Tcl_GetObjectAsClass(Tcl_Object object);
 /* 3 */
-EXTERN Tcl_Command	Tcl_GetObjectCommand(Tcl_Object object);
+TCLOOAPI Tcl_Command	Tcl_GetObjectCommand(Tcl_Object object);
 /* 4 */
-EXTERN Tcl_Object	Tcl_GetObjectFromObj(Tcl_Interp *interp,
+TCLOOAPI Tcl_Object	Tcl_GetObjectFromObj(Tcl_Interp *interp,
 				Tcl_Obj *objPtr);
 /* 5 */
-EXTERN Tcl_Namespace *	Tcl_GetObjectNamespace(Tcl_Object object);
+TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object);
 /* 6 */
-EXTERN Tcl_Class	Tcl_MethodDeclarerClass(Tcl_Method method);
+TCLOOAPI Tcl_Class	Tcl_MethodDeclarerClass(Tcl_Method method);
 /* 7 */
-EXTERN Tcl_Object	Tcl_MethodDeclarerObject(Tcl_Method method);
+TCLOOAPI Tcl_Object	Tcl_MethodDeclarerObject(Tcl_Method method);
 /* 8 */
-EXTERN int		Tcl_MethodIsPublic(Tcl_Method method);
+TCLOOAPI int		Tcl_MethodIsPublic(Tcl_Method method);
 /* 9 */
-EXTERN int		Tcl_MethodIsType(Tcl_Method method,
+TCLOOAPI int		Tcl_MethodIsType(Tcl_Method method,
 				const Tcl_MethodType *typePtr,
 				ClientData *clientDataPtr);
 /* 10 */
-EXTERN Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
+TCLOOAPI Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
 /* 11 */
-EXTERN Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
 				Tcl_Object object, Tcl_Obj *nameObj,
 				int isPublic, const Tcl_MethodType *typePtr,
 				ClientData clientData);
 /* 12 */
-EXTERN Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
+TCLOOAPI Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
 				Tcl_Obj *nameObj, int isPublic,
 				const Tcl_MethodType *typePtr,
 				ClientData clientData);
 /* 13 */
-EXTERN Tcl_Object	Tcl_NewObjectInstance(Tcl_Interp *interp,
+TCLOOAPI Tcl_Object	Tcl_NewObjectInstance(Tcl_Interp *interp,
 				Tcl_Class cls, const char *nameStr,
 				const char *nsNameStr, int objc,
 				Tcl_Obj *const *objv, int skip);
 /* 14 */
-EXTERN int		Tcl_ObjectDeleted(Tcl_Object object);
+TCLOOAPI int		Tcl_ObjectDeleted(Tcl_Object object);
 /* 15 */
-EXTERN int		Tcl_ObjectContextIsFiltering(
+TCLOOAPI int		Tcl_ObjectContextIsFiltering(
 				Tcl_ObjectContext context);
 /* 16 */
-EXTERN Tcl_Method	Tcl_ObjectContextMethod(Tcl_ObjectContext context);
+TCLOOAPI Tcl_Method	Tcl_ObjectContextMethod(Tcl_ObjectContext context);
 /* 17 */
-EXTERN Tcl_Object	Tcl_ObjectContextObject(Tcl_ObjectContext context);
+TCLOOAPI Tcl_Object	Tcl_ObjectContextObject(Tcl_ObjectContext context);
 /* 18 */
-EXTERN int		Tcl_ObjectContextSkippedArgs(
+TCLOOAPI int		Tcl_ObjectContextSkippedArgs(
 				Tcl_ObjectContext context);
 /* 19 */
-EXTERN ClientData	Tcl_ClassGetMetadata(Tcl_Class clazz,
+TCLOOAPI ClientData	Tcl_ClassGetMetadata(Tcl_Class clazz,
 				const Tcl_ObjectMetadataType *typePtr);
 /* 20 */
-EXTERN void		Tcl_ClassSetMetadata(Tcl_Class clazz,
+TCLOOAPI void		Tcl_ClassSetMetadata(Tcl_Class clazz,
 				const Tcl_ObjectMetadataType *typePtr,
 				ClientData metadata);
 /* 21 */
-EXTERN ClientData	Tcl_ObjectGetMetadata(Tcl_Object object,
+TCLOOAPI ClientData	Tcl_ObjectGetMetadata(Tcl_Object object,
 				const Tcl_ObjectMetadataType *typePtr);
 /* 22 */
-EXTERN void		Tcl_ObjectSetMetadata(Tcl_Object object,
+TCLOOAPI void		Tcl_ObjectSetMetadata(Tcl_Object object,
 				const Tcl_ObjectMetadataType *typePtr,
 				ClientData metadata);
 /* 23 */
-EXTERN int		Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
+TCLOOAPI int		Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
 				Tcl_ObjectContext context, int objc,
 				Tcl_Obj *const *objv, int skip);
 /* 24 */
-EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
+TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
 				Tcl_Object object);
 /* 25 */
-EXTERN void		Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
+TCLOOAPI void		Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
 				Tcl_ObjectMapMethodNameProc *mapMethodNameProc);
 /* 26 */
-EXTERN void		Tcl_ClassSetConstructor(Tcl_Interp *interp,
+TCLOOAPI void		Tcl_ClassSetConstructor(Tcl_Interp *interp,
 				Tcl_Class clazz, Tcl_Method method);
 /* 27 */
-EXTERN void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
+TCLOOAPI void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
 				Tcl_Class clazz, Tcl_Method method);
 /* 28 */
-EXTERN Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
+TCLOOAPI Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
 				Tcl_Object object);
 
 typedef struct TclOOStubHooks {
@@ -240,8 +239,4 @@ extern const TclOOStubs *tclOOStubsPtr;
 #endif /* defined(USE_TCLOO_STUBS) */
 
 /* !END!: Do not edit above this line. */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
-
 #endif /* _TCLOODECLS */
diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h
index b9600f2..49a43aa 100644
--- a/generic/tclOOIntDecls.h
+++ b/generic/tclOOIntDecls.h
@@ -5,14 +5,13 @@
 #ifndef _TCLOOINTDECLS
 #define _TCLOOINTDECLS
 
-#undef TCL_STORAGE_CLASS
-#ifdef BUILD_tcl
-#   define TCL_STORAGE_CLASS DLLEXPORT
-#else
-#   ifdef USE_TCL_STUBS
-#      define TCL_STORAGE_CLASS
+#ifndef TCLOOAPI
+#   ifdef BUILD_tcl
+#	define TCLOOAPI MODULE_SCOPE
 #   else
-#      define TCL_STORAGE_CLASS DLLIMPORT
+#	define TCLOOAPI extern
+#	undef USE_TCLOO_STUBS
+#	define USE_TCLOO_STUBS 1
 #   endif
 #endif
 
@@ -29,46 +28,46 @@
  */
 
 /* 0 */
-EXTERN Tcl_Object	TclOOGetDefineCmdContext(Tcl_Interp *interp);
+TCLOOAPI Tcl_Object	TclOOGetDefineCmdContext(Tcl_Interp *interp);
 /* 1 */
-EXTERN Tcl_Method	TclOOMakeProcInstanceMethod(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	TclOOMakeProcInstanceMethod(Tcl_Interp *interp,
 				Object *oPtr, int flags, Tcl_Obj *nameObj,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				const Tcl_MethodType *typePtr,
 				ClientData clientData, Proc **procPtrPtr);
 /* 2 */
-EXTERN Tcl_Method	TclOOMakeProcMethod(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	TclOOMakeProcMethod(Tcl_Interp *interp,
 				Class *clsPtr, int flags, Tcl_Obj *nameObj,
 				const char *namePtr, Tcl_Obj *argsObj,
 				Tcl_Obj *bodyObj,
 				const Tcl_MethodType *typePtr,
 				ClientData clientData, Proc **procPtrPtr);
 /* 3 */
-EXTERN Method *		TclOONewProcInstanceMethod(Tcl_Interp *interp,
+TCLOOAPI Method *	TclOONewProcInstanceMethod(Tcl_Interp *interp,
 				Object *oPtr, int flags, Tcl_Obj *nameObj,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				ProcedureMethod **pmPtrPtr);
 /* 4 */
-EXTERN Method *		TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
+TCLOOAPI Method *	TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
 				int flags, Tcl_Obj *nameObj,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				ProcedureMethod **pmPtrPtr);
 /* 5 */
-EXTERN int		TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
+TCLOOAPI int		TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
 				int objc, Tcl_Obj *const *objv,
 				int publicOnly, Class *startCls);
 /* 6 */
-EXTERN int		TclOOIsReachable(Class *targetPtr, Class *startPtr);
+TCLOOAPI int		TclOOIsReachable(Class *targetPtr, Class *startPtr);
 /* 7 */
-EXTERN Method *		TclOONewForwardMethod(Tcl_Interp *interp,
+TCLOOAPI Method *	TclOONewForwardMethod(Tcl_Interp *interp,
 				Class *clsPtr, int isPublic,
 				Tcl_Obj *nameObj, Tcl_Obj *prefixObj);
 /* 8 */
-EXTERN Method *		TclOONewForwardInstanceMethod(Tcl_Interp *interp,
+TCLOOAPI Method *	TclOONewForwardInstanceMethod(Tcl_Interp *interp,
 				Object *oPtr, int isPublic, Tcl_Obj *nameObj,
 				Tcl_Obj *prefixObj);
 /* 9 */
-EXTERN Tcl_Method	TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
 				Tcl_Object oPtr,
 				TclOO_PreCallProc *preCallPtr,
 				TclOO_PostCallProc *postCallPtr,
@@ -77,7 +76,7 @@ EXTERN Tcl_Method	TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				int flags, void **internalTokenPtr);
 /* 10 */
-EXTERN Tcl_Method	TclOONewProcMethodEx(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	TclOONewProcMethodEx(Tcl_Interp *interp,
 				Tcl_Class clsPtr,
 				TclOO_PreCallProc *preCallPtr,
 				TclOO_PostCallProc *postCallPtr,
@@ -86,22 +85,22 @@ EXTERN Tcl_Method	TclOONewProcMethodEx(Tcl_Interp *interp,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				int flags, void **internalTokenPtr);
 /* 11 */
-EXTERN int		TclOOInvokeObject(Tcl_Interp *interp,
+TCLOOAPI int		TclOOInvokeObject(Tcl_Interp *interp,
 				Tcl_Object object, Tcl_Class startCls,
 				int publicPrivate, int objc,
 				Tcl_Obj *const *objv);
 /* 12 */
-EXTERN void		TclOOObjectSetFilters(Object *oPtr, int numFilters,
+TCLOOAPI void		TclOOObjectSetFilters(Object *oPtr, int numFilters,
 				Tcl_Obj *const *filters);
 /* 13 */
-EXTERN void		TclOOClassSetFilters(Tcl_Interp *interp,
+TCLOOAPI void		TclOOClassSetFilters(Tcl_Interp *interp,
 				Class *classPtr, int numFilters,
 				Tcl_Obj *const *filters);
 /* 14 */
-EXTERN void		TclOOObjectSetMixins(Object *oPtr, int numMixins,
+TCLOOAPI void		TclOOObjectSetMixins(Object *oPtr, int numMixins,
 				Class *const *mixins);
 /* 15 */
-EXTERN void		TclOOClassSetMixins(Tcl_Interp *interp,
+TCLOOAPI void		TclOOClassSetMixins(Tcl_Interp *interp,
 				Class *classPtr, int numMixins,
 				Class *const *mixins);
 
@@ -177,8 +176,4 @@ extern const TclOOIntStubs *tclOOIntStubsPtr;
 #endif /* defined(USE_TCLOO_STUBS) */
 
 /* !END!: Do not edit above this line. */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
-
 #endif /* _TCLOOINTDECLS */
diff --git a/win/configure b/win/configure
index c3969fa..ecfd2ec 100755
--- a/win/configure
+++ b/win/configure
@@ -3758,7 +3758,7 @@ rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
 fi
 echo "$as_me:$LINENO: result: $tcl_have_wspiapi_h" >&5
 echo "${ECHO_T}$tcl_have_wspiapi_h" >&6
-if test "tcl_have_wspiapi_h" = "yes"; then
+if test "$tcl_have_wspiapi_h" = "yes"; then
 
 cat >>confdefs.h <<\_ACEOF
 #define HAVE_WSPIAPI_H 1
diff --git a/win/configure.in b/win/configure.in
index b286537..54727f8 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -301,7 +301,7 @@ AC_TRY_COMPILE([
         tcl_have_wspiapi_h=yes,
         tcl_have_wspiapi_h=no)
 )
-if test "tcl_have_wspiapi_h" = "yes"; then
+if test "$tcl_have_wspiapi_h" = "yes"; then
     AC_DEFINE(HAVE_WSPIAPI_H, 1,
             [Defined when wspiapi.h exists])
 fi
-- 
cgit v0.12


From ef309fcd9588574626469b6b0d0e169dbf0e097c Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 11 Apr 2011 07:31:18 +0000
Subject: fix for [Bug 3281728]: Tcl sources from 2011-04-06 do not build on
 GCC9 (RH9)

---
 ChangeLog      | 5 +++++
 generic/tcl.h  | 2 +-
 unix/configure | 5 ++++-
 unix/tcl.m4    | 7 +++++--
 4 files changed, 15 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index a44ee50..951a993 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-04-11  Jan Nijtmans  <nijtmans@users.sf.net>
+	* generic/tcl.h:    fix for [Bug 3281728]: Tcl sources from 2011-04-06 do
+	* unix/tcl.m4:      not build on GCC9 (RH9)
+	* unix/configure:
+
 2011-04-08  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* win/tclWinPort.h: fix for [Bug 3280043]: win2k: unresolved DLL imports
diff --git a/generic/tcl.h b/generic/tcl.h
index 3285c3c..ed63f8f 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -193,7 +193,7 @@ extern "C" {
 #   endif
 #else
 #   define DLLIMPORT
-#   if defined(__GNUC__) && !defined(NO_VIZ) && !defined(STATIC_BUILD)
+#   if defined(__GNUC__) && __GNUC__ > 3
 #       define DLLEXPORT __attribute__ ((visibility("default")))
 #   else
 #       define DLLEXPORT
diff --git a/unix/configure b/unix/configure
index 4fdddd4..2483e4a 100755
--- a/unix/configure
+++ b/unix/configure
@@ -6479,7 +6479,7 @@ if test "${tcl_cv_cc_visibility_hidden+set}" = set; then
   echo $ECHO_N "(cached) $ECHO_C" >&6
 else
 
-	    if test "$GCC" = yes -a "$SHARED_BUILD" = 1; then
+	    if test "$SHARED_BUILD" = 1; then
 
 		hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror"
 		cat >conftest.$ac_ext <<_ACEOF
@@ -6492,6 +6492,9 @@ cat >>conftest.$ac_ext <<_ACEOF
 int
 main ()
 {
+#if !defined(__GNUC__) || __GNUC__ < 4
+#error visibility hidden is not supported for this compiler
+#endif
 
   ;
   return 0;
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 9a02e4c..5f4012d 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1044,9 +1044,12 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 
     AC_CACHE_CHECK([if compiler supports visibility "hidden"],
 	tcl_cv_cc_visibility_hidden, [
-	    AS_IF([test "$GCC" = yes -a "$SHARED_BUILD" = 1], [
+	    AS_IF([test "$SHARED_BUILD" = 1], [
 		hold_cflags=$CFLAGS; CFLAGS="$CFLAGS -fvisibility=hidden -Werror"
-		AC_TRY_COMPILE(,, tcl_cv_cc_visibility_hidden=yes,
+		AC_TRY_COMPILE(,[#if !defined(__GNUC__) || __GNUC__ < 4
+#error visibility hidden is not supported for this compiler
+#endif
+		], tcl_cv_cc_visibility_hidden=yes,
 		    tcl_cv_cc_visibility_hidden=no)
 		CFLAGS=$hold_cflags
 	    ], [
-- 
cgit v0.12


From 084e0e3592fe3bef1db12395401090e9d317c590 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 11 Apr 2011 10:37:39 +0000
Subject: insure that 'coroutine eval' runs the initial command in the proper
 context, [Bug 3282869]

---
 ChangeLog            |  6 ++++++
 generic/tclBasic.c   | 11 +++++++++--
 tests/coroutine.test | 24 ++++++++++++++++++++++++
 3 files changed, 39 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 951a993..2b7012f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-04-11  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclBasic.c:
+	* tests/coroutine.test: insure that 'coroutine eval' runs the initial
+	command in the proper context, [Bug 3282869]
+	
 2011-04-11  Jan Nijtmans  <nijtmans@users.sf.net>
 	* generic/tcl.h:    fix for [Bug 3281728]: Tcl sources from 2011-04-06 do
 	* unix/tcl.m4:      not build on GCC9 (RH9)
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index f00864f..5019c86 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -8866,6 +8866,7 @@ TclNRCoroutineObjCmd(
     const char *fullName, *procName;
     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
     Tcl_DString ds;
+    Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
     
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
@@ -8952,7 +8953,7 @@ TclNRCoroutineObjCmd(
     }
 
     /*
-     * Save the base context.
+     * Create the base context.
      */
 
     corPtr->running.framePtr = iPtr->rootFramePtr;
@@ -8972,13 +8973,19 @@ TclNRCoroutineObjCmd(
     corPtr->callerEEPtr = iPtr->execEnvPtr;
     corPtr->eePtr->corPtr = corPtr;
     
+    SAVE_CONTEXT(corPtr->caller);
+    corPtr->callerEEPtr = iPtr->execEnvPtr;
+    RESTORE_CONTEXT(corPtr->running);
     iPtr->execEnvPtr = corPtr->eePtr;
 
     TclNRAddCallback(interp, NRCoroutineExitCallback, corPtr,
 	    NULL, NULL, NULL);
 
-    iPtr->lookupNsPtr = iPtr->varFramePtr->nsPtr;
+    iPtr->lookupNsPtr = lookupNsPtr;
     Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);
+
+    SAVE_CONTEXT(corPtr->running);
+    RESTORE_CONTEXT(corPtr->caller);
     iPtr->execEnvPtr = corPtr->callerEEPtr;
     
     /*
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 4d7e3de..bc72017 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -435,6 +435,30 @@ test coroutine-4.5 {bug #2724403} -constraints {memory} \
     unset i ns start end
 } -result 0
 
+test coroutine-4.6 {compile context, bug #3282869} -setup {
+    unset ::x
+    proc f x {
+	coroutine D eval {yield X$x;yield Y}
+    }
+} -body {
+    f 12
+} -cleanup {
+    rename f {}
+} -returnCodes error -match glob -result {can't read *}
+
+test coroutine-4.7 {compile context, bug #3282869} -setup {
+    proc f x {
+	coroutine D eval {yield X$x;yield Y$x}
+    }
+} -body {
+    set ::x 15
+    set ::x [f 12]
+    D
+} -cleanup {
+    unset ::x
+    rename f {}
+} -result YX15
+
 test coroutine-5.1 {right numLevels on coro return} -constraints {testnrelevels} \
 -setup {
     proc nestedYield {{val {}}} {
-- 
cgit v0.12


From 190867f044d99cc38e5383c153da12d862db858c Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Tue, 12 Apr 2011 17:34:29 +0000
Subject: * generic/tclBasic.c: fix for [Bug 2440625], kbk's patch

---
 ChangeLog          |  4 ++++
 generic/tclBasic.c | 30 ++++++------------------------
 2 files changed, 10 insertions(+), 24 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 2b7012f..c768503 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-04-12  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclBasic.c: fix for [Bug 2440625], kbk's patch
+
 2011-04-11  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclBasic.c:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 5019c86..4c826f3 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -4265,27 +4265,13 @@ TclNREvalObjv(
      * a callback to do the actual running.
      */
 
-#if 0
-    {
-        Tcl_ObjCmdProc *objProc = cmdPtr->nreProc;
-        
-        if (!objProc) {
-            objProc = cmdPtr->objProc;
-        }
-        
-        TclNRAddCallback(interp, NRRunObjProc, objProc, cmdPtr->objClientData,
-                INT2PTR(objc), (ClientData) objv);
-    }
-    return TCL_OK;
-#else
     if (cmdPtr->nreProc) {
-        TclNRAddCallback(interp, NRRunObjProc, cmdPtr->nreProc,
-                cmdPtr->objClientData, INT2PTR(objc), (ClientData) objv);
+        TclNRAddCallback(interp, NRRunObjProc, cmdPtr,
+                INT2PTR(objc), (ClientData) objv, NULL);
         return TCL_OK;
     } else {
 	return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
     }        
-#endif
 }
 
 void
@@ -4373,15 +4359,11 @@ NRRunObjProc(
 {
     /* OPT: do not call? */
 
-    Tcl_ObjCmdProc *objProc = (Tcl_ObjCmdProc *)data[0];
-    ClientData objClientData = data[1];
-    int objc = PTR2INT(data[2]);
-    Tcl_Obj **objv = data[3];
+    Command* cmdPtr = data[0];
+    int objc = PTR2INT(data[1]);
+    Tcl_Obj **objv = data[2];
 
-    if (result == TCL_OK) {
-	return objProc(objClientData, interp, objc, objv);
-    }
-    return result;
+    return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv);
 }
 
 
-- 
cgit v0.12


From 4884764d1d8d9cf7bd61e25622b0173c43e46114 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 13 Apr 2011 11:03:30 +0000
Subject: [3285375]: Make the crash less mysterious through the judicious use
 of a panic.

---
 ChangeLog         | 27 +++++++++++++++++----------
 generic/tclUtil.c |  5 +++++
 2 files changed, 22 insertions(+), 10 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index cc68aaa..7bf374c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-04-13  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclUtil.c (Tcl_ConcatObj): [Bug 3285375]: Make the crash
+	less mysterious through the judicious use of a panic. Not yet properly
+	fixed, but at least now clearer what the failure mode is.
+
 2011-04-12  Don Porter  <dgp@users.sourceforge.net>
 
 	* tests/string.test:	Test for [Bug 3285472]. Not buggy in trunk.
@@ -8,31 +14,32 @@
 
 2011-04-12  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclBasic.c: fix for [Bug 2440625], kbk's patch
+	* generic/tclBasic.c: Fix for [Bug 2440625], kbk's patch
 
 2011-04-11  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclBasic.c:
-	* tests/coroutine.test: insure that 'coroutine eval' runs the initial
-	command in the proper context, [Bug 3282869]
-	
+	* tests/coroutine.test: [Bug 3282869]: Ensure that 'coroutine eval'
+	runs the initial command in the proper context.
+
 2011-04-11  Jan Nijtmans  <nijtmans@users.sf.net>
-	* generic/tcl.h:    fix for [Bug 3281728]: Tcl sources from 2011-04-06 do
-	* unix/tcl.m4:      not build on GCC9 (RH9)
+
+	* generic/tcl.h:    Fix for [Bug 3281728]: Tcl sources from 2011-04-06
+	* unix/tcl.m4:      do not build on GCC9 (RH9)
 	* unix/configure:
 
 2011-04-08  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinPort.h: fix for [Bug 3280043]: win2k: unresolved DLL imports
-	* win/configure.in
+	* win/tclWinPort.h: Fix for [Bug 3280043]: win2k: unresolved DLL
+	* win/configure.in: imports.
 	* win/configure
 
 2011-04-06  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclExecute.c (TclCompileObj): earlier return if Tip280
+	* generic/tclExecute.c (TclCompileObj): Earlier return if Tip280
 	gymnastics not needed.
 
-	* generic/tclExecute.c: fix for [Bug 3274728], making *catchTop an
+	* generic/tclExecute.c: Fix for [Bug 3274728]: making *catchTop an
 	unsigned long.
 
 2011-04-06  Jan Nijtmans  <nijtmans@users.sf.net>
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 64aa824..46ddf85 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1110,10 +1110,15 @@ Tcl_ConcatObj(
 
     allocSize = 0;
     for (i = 0;  i < objc;  i++) {
+	int oldAllocSize = allocSize;
+
 	objPtr = objv[i];
 	element = TclGetStringFromObj(objPtr, &length);
 	if ((element != NULL) && (length > 0)) {
 	    allocSize += (length + 1);
+	    if (allocSize < oldAllocSize) {
+		Tcl_Panic("too much memory required");
+	    }
 	}
     }
     if (allocSize == 0) {
-- 
cgit v0.12


From f1724b7ab36f74c7fc8f9f4c58e79be1864f14d5 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 16 Apr 2011 11:51:35 +0000
Subject: Added comments to try to tame the file attributes guts, while trying
 to simplify things enough that I can puzzle out AK's TclVFS problems. I
 suspect this is not a real fix though; just an attempt to make the problem
 tractable.

---
 ChangeLog         | 18 ++++++++++++------
 generic/tclFCmd.c | 36 ++++++++++++++++++++++--------------
 2 files changed, 34 insertions(+), 20 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index d04c05e..13aa14a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,9 +1,15 @@
+2011-04-16  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclFCmd.c (TclFileAttrsCmd): Add comments to make this code
+	easier to understand. Added a panic to handle the case where the VFS
+	layer does something odd.
+
 2011-04-13  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclUtil.c:	Rewrite of Tcl_Concat*() routines to 
-	prevent segfaults on buffer overflow.  Build them out of existing
-	primitives already coded to handle overflow properly.  Uses the
-	new TclTrim*() routines. [Bug 3285375]
+	* generic/tclUtil.c:	[Bug 3285375]: Rewrite of Tcl_Concat*()
+	routines to prevent segfaults on buffer overflow.  Build them out of
+	existing primitives already coded to handle overflow properly.  Uses
+	the new TclTrim*() routines.
 
 	* generic/tclCmdMZ.c:	New internal utility routines TclTrimLeft()
 	* generic/tclInt.h:	and TclTrimRight().  Refactor the
@@ -11,8 +17,8 @@
 
 2011-04-13  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclVar.c: fix for [Bug 2662380], crash caused by
-	appending to a variable with a write trace that unsets it.
+	* generic/tclVar.c: [Bug 2662380]: Fix crash caused by appending to a
+	variable with a write trace that unsets it.
 
 2011-04-13  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index e9176ca..048fa57 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -966,6 +966,10 @@ TclFileAttrsCmd(
     result = TCL_ERROR;
     Tcl_SetErrno(0);
 
+    /*
+     * Get the set of attribute names from the filesystem.
+     */
+
     attributeStrings = Tcl_FSFileAttrStrings(filePtr, &objStrings);
     if (attributeStrings == NULL) {
 	int index;
@@ -980,9 +984,8 @@ TclFileAttrsCmd(
 		Tcl_AppendResult(interp, "could not read \"",
 			TclGetString(filePtr), "\": ", Tcl_PosixError(interp),
 			NULL);
-		return TCL_ERROR;
 	    }
-	    goto end;
+	    return TCL_ERROR;
 	}
 
 	/*
@@ -1006,7 +1009,16 @@ TclFileAttrsCmd(
 	}
 	attributeStringsAllocated[index] = NULL;
 	attributeStrings = attributeStringsAllocated;
+    } else if (objStrings != NULL) {
+	Tcl_Panic("must not update objPtrRef's variable and return non-NULL");
     }
+
+    /*
+     * Process the attributes to produce a list of all of them, the value of a
+     * particular attribute, or to set one or more attributes (depending on
+     * the number of arguments).
+     */
+
     if (objc == 0) {
 	/*
 	 * Get all attributes.
@@ -1114,21 +1126,17 @@ TclFileAttrsCmd(
     }
     result = TCL_OK;
 
+    /*
+     * Free up the array we allocated and drop our reference to any list of
+     * attribute names issued by the filesystem.
+     */
+
   end:
     if (attributeStringsAllocated != NULL) {
-	/*
-	 * Free up the array we allocated.
-	 */
-
 	TclStackFree(interp, (void *) attributeStringsAllocated);
-
-	/*
-	 * We don't need this object that was passed to us any more.
-	 */
-
-	if (objStrings != NULL) {
-	    Tcl_DecrRefCount(objStrings);
-	}
+    }
+    if (objStrings != NULL) {
+	Tcl_DecrRefCount(objStrings);
     }
     return result;
 }
-- 
cgit v0.12


From 76259f2d58dc67f1a0095a1891696b69167c3902 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 18 Apr 2011 10:19:13 +0000
Subject: [Bug 3288696]: Command summary was confusingly wrong when it came to
 [dict filter] with a 'value' filter.

---
 ChangeLog  | 8 ++++++--
 doc/dict.n | 2 +-
 2 files changed, 7 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 670038a..ca5e989 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,11 @@
+2011-04-18  Donal K. Fellows  <dkf@users.sf.net>
+
+	* doc/dict.n: [Bug 3288696]: Command summary was confusingly wrong
+	when it came to [dict filter] with a 'value' filter.
+
 2011-04-18  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tcl.h: fix for [Bug 3288345]: Wrong Tcl_StatBuf
-	used on MinGW.
+	* generic/tcl.h: [Bug 3288345]: Fix wrong Tcl_StatBuf used on MinGW.
 
 2011-04-16  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/doc/dict.n b/doc/dict.n
index c14a06f..561d418 100644
--- a/doc/dict.n
+++ b/doc/dict.n
@@ -67,7 +67,7 @@ dictionary, and a condition of \fBTCL_CONTINUE\fR is equivalent to a false
 result. The key/value pairs are tested in the order in which the keys
 were inserted into the dictionary.
 .TP
-\fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern\fR
+\fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern ...\fR
 .VS 8.6
 The value rule only matches those key/value pairs whose values match any
 of the given patterns (in the style of \fBstring match\fR.)
-- 
cgit v0.12


From 1ba0761f8a75067fc5f6f597b7a80bd8ab395587 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 19 Apr 2011 08:04:22 +0000
Subject: This time, I'll try to get it right!

---
 doc/dict.n | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/doc/dict.n b/doc/dict.n
index 561d418..b8386f2 100644
--- a/doc/dict.n
+++ b/doc/dict.n
@@ -67,7 +67,7 @@ dictionary, and a condition of \fBTCL_CONTINUE\fR is equivalent to a false
 result. The key/value pairs are tested in the order in which the keys
 were inserted into the dictionary.
 .TP
-\fBdict filter \fIdictionaryValue \fBvalue \fIglobPattern ...\fR
+\fBdict filter \fIdictionaryValue \fBvalue \fR?\fIglobPattern ...\fR?
 .VS 8.6
 The value rule only matches those key/value pairs whose values match any
 of the given patterns (in the style of \fBstring match\fR.)
-- 
cgit v0.12


From 70f37765e1508c03a7994ed0ba2ead67fff67bba Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 25 Apr 2011 12:49:53 +0000
Subject: Revise last fix.

---
 generic/tclListObj.c | 8 ++++----
 1 file changed, 4 insertions(+), 4 deletions(-)

diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 46e846d..7955e19 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -99,8 +99,8 @@ NewListIntRep(
     listRepPtr = attemptckalloc(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj*)));
     if (listRepPtr == NULL) {
 	if (p) {
-	    Tcl_Panic("list creation failed: unable to alloc %lu bytes",
-		    (unsigned long) (sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))));
+	    Tcl_Panic("list creation failed: unable to alloc %u bytes",
+		    (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *))));
 	}
 	return NULL;
     }
@@ -162,8 +162,8 @@ AttemptNewList(
 		    LIST_MAX));
 	} else {
 	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
-		    "list creation failed: unable to alloc %lu bytes",
-		    (unsigned long) (sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))));
+		    "list creation failed: unable to alloc %u bytes",
+		    (unsigned)(sizeof(List) + ((objc-1) * sizeof(Tcl_Obj *)))));
 	}
 	Tcl_SetErrorCode(interp, "TCL", "MEMORY", NULL);
     }
-- 
cgit v0.12


From db89fa13d55a8702757ce698cd695db454d4690b Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 25 Apr 2011 17:51:14 +0000
Subject: TclFreeIntRep() related cleanup.

---
 generic/tclPathObj.c | 4 ----
 generic/tclProc.c    | 5 ++---
 generic/tclTestObj.c | 3 +--
 3 files changed, 3 insertions(+), 9 deletions(-)

diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 01a297b..d9e3973 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -1156,7 +1156,6 @@ Tcl_FSConvertToPathType(
 	    UpdateStringOfFsPath(pathPtr);
 	}
 	FreeFsPathInternalRep(pathPtr);
-	pathPtr->typePtr = NULL;
     }
 
     return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
@@ -1175,7 +1174,6 @@ Tcl_FSConvertToPathType(
      *             UpdateStringOfFsPath(pathPtr);
      *         }
      *         FreeFsPathInternalRep(pathPtr);
-     *         pathPtr->typePtr = NULL;
      *         return Tcl_ConvertToType(interp, pathPtr, &tclFsPathType);
      *     }
      * }
@@ -1903,7 +1901,6 @@ Tcl_FSGetNormalizedPath(
 		UpdateStringOfFsPath(pathPtr);
 	    }
 	    FreeFsPathInternalRep(pathPtr);
-	    pathPtr->typePtr = NULL;
 	    if (Tcl_ConvertToType(interp, pathPtr, &tclFsPathType) != TCL_OK) {
 		return NULL;
 	    }
@@ -2214,7 +2211,6 @@ TclFSEnsureEpochOk(
 	    UpdateStringOfFsPath(pathPtr);
 	}
 	FreeFsPathInternalRep(pathPtr);
-	pathPtr->typePtr = NULL;
 	if (SetFsPathFromAny(NULL, pathPtr) != TCL_OK) {
 	    return TCL_ERROR;
 	}
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 1260f4f..a2de765 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -2006,8 +2006,7 @@ TclProcCompileProc(
 	    codePtr->compileEpoch = iPtr->compileEpoch;
 	    codePtr->nsPtr = nsPtr;
 	} else {
-	    bodyPtr->typePtr->freeIntRepProc(bodyPtr);
-	    bodyPtr->typePtr = NULL;
+	    TclFreeIntRep(bodyPtr);
 	}
     }
 
@@ -2635,7 +2634,7 @@ SetLambdaFromAny(
      * conversion to lambdaType.
      */
 
-    objPtr->typePtr->freeIntRepProc(objPtr);
+    TclFreeIntRep(objPtr);
 
     objPtr->internalRep.twoPtrValue.ptr1 = procPtr;
     objPtr->internalRep.twoPtrValue.ptr2 = nsObjPtr;
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 1ef1dc3..92c278f 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -562,8 +562,7 @@ TestindexobjCmd(
 	    && !strcmp("index", objv[3]->typePtr->name)) {
 	indexRep = objv[3]->internalRep.otherValuePtr;
 	if (indexRep->tablePtr == (void *) argv) {
-	    objv[3]->typePtr->freeIntRepProc(objv[3]);
-	    objv[3]->typePtr = NULL;
+	    TclFreeIntRep(objv[3]);
 	}
     }
 
-- 
cgit v0.12


From 534bec807cc2cb0a81899bdc9fe9e39a486c0ea5 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 27 Apr 2011 18:49:22 +0000
Subject: TclFreeIntRep() cleanup.

---
 ChangeLog              | 9 +++++++++
 generic/tclCmdMZ.c     | 2 --
 generic/tclExecute.c   | 1 -
 generic/tclIndexObj.c  | 1 -
 generic/tclListObj.c   | 1 -
 generic/tclNamesp.c    | 1 -
 generic/tclResult.c    | 1 -
 generic/tclStringObj.c | 1 -
 generic/tclVar.c       | 2 --
 9 files changed, 9 insertions(+), 10 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f058413..ca8952f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,14 @@
 2011-04-27  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclCmdMZ.c:	TclFreeIntRep() cleanup.
+	* generic/tclExecute.c:
+	* generic/tclIndexObj.c:
+	* generic/tclListObj.c:
+	* generic/tclNamesp.c:
+	* generic/tclResult.c:
+	* generic/tclStringObj.c:
+	* generic/tclVar.c:
+
 	* generic/tclListObj.c:	FreeListInternalRep() cleanup.
 
 2011-04-21  Don Porter  <dgp@users.sourceforge.net>
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index a4b7d1e..e4a58ed 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1560,7 +1560,6 @@ StringIsCmd(
 	    if (stop < end) {
 		result = 0;
 		TclFreeIntRep(objPtr);
-		objPtr->typePtr = NULL;
 	    }
 	}
 	break;
@@ -1617,7 +1616,6 @@ StringIsCmd(
 
 		failat = stop - string1;
 		TclFreeIntRep(objPtr);
-		objPtr->typePtr = NULL;
 	    }
 	} else {
 	    /*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index ab50256..4fe65d7 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -2549,7 +2549,6 @@ TEBCresume(
 #if !TCL_COMPILE_DEBUG
 	    if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
 		TclFreeIntRep(objResultPtr);
-		objResultPtr->typePtr = NULL;
 		objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
 		objResultPtr->length = length + appendLen;
 		p = TclGetString(objResultPtr) + length;
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 99bd61f..69608cc 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -217,7 +217,6 @@ GetIndexFromObjList(
      */
 
     TclFreeIntRep(objPtr);
-    objPtr->typePtr = NULL;
     ckfree(tablePtr);
 
     return result;
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 7d0743d..88b3a0b 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -358,7 +358,6 @@ Tcl_SetListObj(
      */
 
     TclFreeIntRep(objPtr);
-    objPtr->typePtr = NULL;
     Tcl_InvalidateStringRep(objPtr);
 
     /*
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 957b525..f3c93e7 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -4739,7 +4739,6 @@ SetNsNameFromAny(
 
 	if (objPtr->typePtr == &nsNameType) {
 	    TclFreeIntRep(objPtr);
-	    objPtr->typePtr = NULL;
 	}
 	return TCL_ERROR;
     }
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 6a71ee2..60bae73 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -989,7 +989,6 @@ ResetObjResult(
 	    objResultPtr->length = 0;
 	}
 	TclFreeIntRep(objResultPtr);
-	objResultPtr->typePtr = NULL;
     }
 }
 
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index fe6d0af..7f31fdf 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -757,7 +757,6 @@ Tcl_SetStringObj(
      */
 
     TclFreeIntRep(objPtr);
-    objPtr->typePtr = NULL;
 
     /*
      * Free any old string rep, then set the string rep to a copy of the
diff --git a/generic/tclVar.c b/generic/tclVar.c
index b735ba3..55c031c 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -703,7 +703,6 @@ TclObjLookupVarEx(
      */
 
     TclFreeIntRep(part1Ptr);
-    part1Ptr->typePtr = NULL;
 
     varPtr = TclLookupSimpleVar(interp, part1Ptr, flags, createPart1,
 	    &errMsg, &index);
@@ -2361,7 +2360,6 @@ TclPtrUnsetVar(
 
     if (part1Ptr->typePtr == &tclNsVarNameType) {
 	TclFreeIntRep(part1Ptr);
-	part1Ptr->typePtr = NULL;
     }
 #endif
 
-- 
cgit v0.12


From 319c5292645aa41b4f56539f615ba5314b27c957 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 28 Apr 2011 13:45:27 +0000
Subject: Improved reaction to out of memory.

---
 ChangeLog              | 4 ++++
 generic/tclStringObj.c | 8 +++++++-
 2 files changed, 11 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 22fadc0..02bcdf6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-04-28  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclStringObj.c:	Improved reaction to out of memory.
+
 2011-04-27  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclCmdMZ.c:	TclFreeIntRep() correction & cleanup.
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 7f31fdf..0f6eff7 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -131,6 +131,8 @@ typedef struct String {
 	Tcl_Panic("max length for a Tcl unicode value (%d chars) exceeded", \
 		STRING_MAXCHARS); \
     }
+#define stringAttemptAlloc(numChars) \
+	(String *) attemptckalloc((unsigned) STRING_SIZE(numChars) )
 #define stringAlloc(numChars) \
 	(String *) ckalloc((unsigned) STRING_SIZE(numChars) )
 #define stringRealloc(ptr, numChars) \
@@ -2856,7 +2858,11 @@ DupStringInternalRep(
 	} else {
 	    copyMaxChars = srcStringPtr->maxChars;
 	}
-	copyStringPtr = stringAlloc(copyMaxChars);
+	copyStringPtr = stringAttemptAlloc(copyMaxChars);
+	if (copyStringPtr == NULL) {
+	    copyMaxChars = srcStringPtr->numChars;
+	    copyStringPtr = stringAlloc(copyMaxChars);
+	}
 	copyStringPtr->maxChars = copyMaxChars;
 	memcpy(copyStringPtr->unicode, srcStringPtr->unicode,
 		srcStringPtr->numChars * sizeof(Tcl_UniChar));
-- 
cgit v0.12


From f24cdf4341465ea638b1d195d2ae99f4fc0eb163 Mon Sep 17 00:00:00 2001
From: Kevin Walzer <kw@codebykevin.com>
Date: Fri, 29 Apr 2011 01:05:37 +0000
Subject: Fix issue with library stripping in install-sh

---
 unix/install-sh | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/unix/install-sh b/unix/install-sh
index 3f83ce9..c68581d 100755
--- a/unix/install-sh
+++ b/unix/install-sh
@@ -1,7 +1,7 @@
 #!/bin/sh
 # install - install a program, script, or datafile
 
-scriptversion=2010-02-06.18; # UTC
+scriptversion=2011-04-20.01; # UTC
 
 # This originates from X11R5 (mit/util/scripts/install.sh), which was
 # later released in X11R6 (xc/config/util/install.sh) with the
@@ -120,6 +120,7 @@ Options:
   -m MODE       $chmodprog installed files to MODE.
   -o USER       $chownprog installed files to USER.
   -s            $stripprog installed files.
+  -S            $stripprog installed files.
   -t DIRECTORY  install into DIRECTORY.
   -T            report an error if DSTFILE is a directory.
 
@@ -155,6 +156,9 @@ while test $# -ne 0; do
 
     -s) stripcmd=$stripprog;;
 
+      -S) stripcmd="$stripprog $2" 
+         shift;; 
+
     -t) dst_arg=$2
 	shift;;
 
-- 
cgit v0.12


From 76f0e86699eb95b37863d57c7915dec2f180aa5b Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 5 May 2011 06:26:50 +0000
Subject: no longer depend on MODULE_SCOPE being defined

---
 unix/tclAppInit.c | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/unix/tclAppInit.c b/unix/tclAppInit.c
index 0d2a6c4..159bbd8 100644
--- a/unix/tclAppInit.c
+++ b/unix/tclAppInit.c
@@ -35,6 +35,9 @@ extern int		Tclxttest_Init(Tcl_Interp *interp);
 #ifndef TCL_LOCAL_APPINIT
 #define TCL_LOCAL_APPINIT Tcl_AppInit
 #endif
+#ifndef MODULE_SCOPE
+#   define MODULE_SCOPE extern
+#endif
 MODULE_SCOPE int TCL_LOCAL_APPINIT(Tcl_Interp *);
 MODULE_SCOPE int main(int, char **);
 
-- 
cgit v0.12


From cfa1a4e5befb266efc87a6521a93b815d2bb6a47 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 5 May 2011 15:32:36 +0000
Subject: Fix typo spotted by Emiliano Gavilan.

---
 doc/Eval.3 | 5 ++++-
 1 file changed, 4 insertions(+), 1 deletion(-)

diff --git a/doc/Eval.3 b/doc/Eval.3
index f232cad..b776e93 100644
--- a/doc/Eval.3
+++ b/doc/Eval.3
@@ -159,10 +159,12 @@ instead of taking a variable number of arguments it takes an argument
 list. Like \fBTcl_VarEval\fR, \fBTcl_VarEvalVA\fR is deprecated.
 
 .SH "FLAG BITS"
+.PP
 Any ORed combination of the following values may be used for the
 \fIflags\fR argument to procedures such as \fBTcl_EvalObjEx\fR:
 .TP 23
 \fBTCL_EVAL_DIRECT\fR
+.
 This flag is only used by \fBTcl_EvalObjEx\fR; it is ignored by
 other procedures.  If this flag bit is set, the script is not
 compiled to bytecodes; instead it is executed directly
@@ -173,10 +175,11 @@ bytecodes will not be reused in a future execution.  In this case,
 it is faster to execute the script directly.
 .TP 23
 \fBTCL_EVAL_GLOBAL\fR
+.
 If this flag is set, the script is processed at global level.  This
 means that it is evaluated in the global namespace and its variable
 context consists of global variables only (it ignores any Tcl
-procedures at are active).
+procedures that are active).
 
 .SH "MISCELLANEOUS DETAILS"
 .PP
-- 
cgit v0.12


From 8a15407fcc66e89fab893e964d8ad44fd98f55b7 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 7 May 2011 23:08:43 +0000
Subject: Convert TclGetLoadedPackages to use Tcl_Obj API for result
 generation.

---
 ChangeLog         |  9 +++++--
 generic/tclLoad.c | 78 ++++++++++++++++++++++++++++---------------------------
 2 files changed, 47 insertions(+), 40 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5e143a3..beb227c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-05-07  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclLoad.c (TclGetLoadedPackages): Convert to use Tcl_Obj API
+	for result generation.
+
 2011-05-07  Miguel Sofer  <msofer@users.sf.net>
 
 	* generic/tclInt.h: fix USE_TCLALLOC so that it can be enabled
@@ -23,7 +28,7 @@
 	* generic/tclListObj.c:	of a boolean var, where the caller can be told
 	* generic/tclParse.c:	whether or not the parsed list element was
 	* generic/tclUtil.c:	enclosed in braces.  In practice, no callers
-	really care about that.  What the callers really want to know is 
+	really care about that.  What the callers really want to know is
 	whether the list element value exists as a literal substring of the
 	string being parsed, or whether a call to TclCopyAndCollpase() is
 	needed to produce the list element value.  Now the final argument
@@ -61,7 +66,7 @@
 	* generic/tclStrToD.c:
 	* generic/tclUtf.c:
 	* unix/tclUnixFile.c:
-	
+
 	* generic/tclStringObj.c:	Improved reaction to out of memory.
 
 2011-04-27  Don Porter  <dgp@users.sourceforge.net>
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 707d6ec..820707e 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -435,36 +435,40 @@ Tcl_LoadObjCmd(
     }
 
     /*
-     * Record the fact that the package has been loaded in the target
-     * interpreter.
+     * Test for whether the initialization failed. If so, transfer the error
+     * from the target interpreter to the originating one.
      */
 
-    if (code == TCL_OK) {
-	/*
-	 * Update the proper reference count.
-	 */
-
-	Tcl_MutexLock(&packageMutex);
-	if (Tcl_IsSafe(target)) {
-	    pkgPtr->safeInterpRefCount++;
-	} else {
-	    pkgPtr->interpRefCount++;
-	}
-	Tcl_MutexUnlock(&packageMutex);
+    if (code != TCL_OK) {
+	Tcl_TransferResult(target, code, interp);
+	goto done;
+    }
 
-	/*
-	 * Refetch ipFirstPtr: loading the package may have introduced
-	 * additional static packages at the head of the linked list!
-	 */
+    /*
+     * Record the fact that the package has been loaded in the target
+     * interpreter.
+     *
+     * Update the proper reference count.
+     */
 
-	ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
-	ipPtr = ckalloc(sizeof(InterpPackage));
-	ipPtr->pkgPtr = pkgPtr;
-	ipPtr->nextPtr = ipFirstPtr;
-	Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
+    Tcl_MutexLock(&packageMutex);
+    if (Tcl_IsSafe(target)) {
+	pkgPtr->safeInterpRefCount++;
     } else {
-	Tcl_TransferResult(target, code, interp);
+	pkgPtr->interpRefCount++;
     }
+    Tcl_MutexUnlock(&packageMutex);
+
+    /*
+     * Refetch ipFirstPtr: loading the package may have introduced additional
+     * static packages at the head of the linked list!
+     */
+
+    ipFirstPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
+    ipPtr = ckalloc(sizeof(InterpPackage));
+    ipPtr->pkgPtr = pkgPtr;
+    ipPtr->nextPtr = ipFirstPtr;
+    Tcl_SetAssocData(target, "tclLoad", LoadCleanupProc, ipPtr);
 
   done:
     Tcl_DStringFree(&pkgName);
@@ -1031,28 +1035,27 @@ TclGetLoadedPackages(
 				 * otherwise, just return info about this
 				 * interpreter. */
 {
-    /* TODO: Use Tcl_Obj APIs to generate this info for cleanliness. */
     Tcl_Interp *target;
     LoadedPackage *pkgPtr;
     InterpPackage *ipPtr;
-    const char *prefix;
+    Tcl_Obj *resultObj, *pkgDesc[2];
 
     if (targetName == NULL) {
 	/*
 	 * Return information about all of the available packages.
 	 */
 
-	prefix = "{";
+	resultObj = Tcl_NewObj();
 	Tcl_MutexLock(&packageMutex);
 	for (pkgPtr = firstPackagePtr; pkgPtr != NULL;
 		pkgPtr = pkgPtr->nextPtr) {
-	    Tcl_AppendResult(interp, prefix, NULL);
-	    Tcl_AppendElement(interp, pkgPtr->fileName);
-	    Tcl_AppendElement(interp, pkgPtr->packageName);
-	    Tcl_AppendResult(interp, "}", NULL);
-	    prefix = " {";
+	    pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
+	    pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);
+	    Tcl_ListObjAppendElement(NULL, resultObj,
+		    Tcl_NewListObj(2, pkgDesc));
 	}
 	Tcl_MutexUnlock(&packageMutex);
+	Tcl_SetObjResult(interp, resultObj);
 	return TCL_OK;
     }
 
@@ -1066,15 +1069,14 @@ TclGetLoadedPackages(
 	return TCL_ERROR;
     }
     ipPtr = Tcl_GetAssocData(target, "tclLoad", NULL);
-    prefix = "{";
+    resultObj = Tcl_NewObj();
     for (; ipPtr != NULL; ipPtr = ipPtr->nextPtr) {
 	pkgPtr = ipPtr->pkgPtr;
-	Tcl_AppendResult(interp, prefix, NULL);
-	Tcl_AppendElement(interp, pkgPtr->fileName);
-	Tcl_AppendElement(interp, pkgPtr->packageName);
-	Tcl_AppendResult(interp, "}", NULL);
-	prefix = " {";
+	pkgDesc[0] = Tcl_NewStringObj(pkgPtr->fileName, -1);
+	pkgDesc[1] = Tcl_NewStringObj(pkgPtr->packageName, -1);
+	Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewListObj(2, pkgDesc));
     }
+    Tcl_SetObjResult(interp, resultObj);
     return TCL_OK;
 }
 
-- 
cgit v0.12


From 2ab84f74c362dd589f01ba696fde1b00d14fe1e5 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 9 May 2011 15:24:06 +0000
Subject: Reduce use of Tcl_AppendElement, which is not (and can't be) a
 Tcl_Obj-aware API.

---
 ChangeLog           |  7 +++++++
 generic/tclNamesp.c | 58 +++++++++++++++++++++++++++++++++++++----------------
 generic/tclPkg.c    | 45 +++++++++++++++++++++++++----------------
 generic/tclTimer.c  |  8 +++++---
 4 files changed, 81 insertions(+), 37 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index d9dcc21..30fad98 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-05-09  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclNamesp.c (NamespacePathCmd): Convert to use Tcl_Obj API
+	* generic/tclPkg.c (Tcl_PackageObjCmd):   for result generation in
+	* generic/tclTimer.c (Tcl_AfterObjCmd):   [after info], [namespace
+	path] and [package versions].
+
 2011-05-09  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclListObj.c:	Revise empty string tests so that we avoid
diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index f3c93e7..9a2152a 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -3959,16 +3959,15 @@ NamespacePathCmd(
      */
 
     if (objc == 1) {
-	/*
-	 * Not a very fast way to compute this, but easy to get right.
-	 */
+        Tcl_Obj *resultObj = Tcl_NewObj();
 
 	for (i=0 ; i<nsPtr->commandPathLength ; i++) {
 	    if (nsPtr->commandPathArray[i].nsPtr != NULL) {
-		Tcl_AppendElement(interp,
-			nsPtr->commandPathArray[i].nsPtr->fullName);
+                Tcl_ListObjAppendElement(NULL, resultObj, Tcl_NewStringObj(
+                        nsPtr->commandPathArray[i].nsPtr->fullName, -1));
 	    }
 	}
+        Tcl_SetObjResult(interp, resultObj);
 	return TCL_OK;
     }
 
@@ -4844,8 +4843,9 @@ TclLogCommandInfo(
 				 * the error. */
     int length,			/* Number of bytes in command (-1 means use
 				 * all bytes up to first null byte). */
-    const unsigned char *pc,    /* current pc of bytecode execution context */
-    Tcl_Obj **tosPtr)           /* current stack of bytecode execution context */
+    const unsigned char *pc,    /* Current pc of bytecode execution context */
+    Tcl_Obj **tosPtr)           /* Current stack of bytecode execution
+                                 * context */
 {
     register const char *p;
     Interp *iPtr = (Interp *) interp;
@@ -4930,32 +4930,46 @@ TclLogCommandInfo(
 
         iPtr->resetErrorStack = 0;
 	Tcl_ListObjLength(interp, iPtr->errorStack, &len);
-        /* reset while keeping the list intrep as much as possible */
+
+        /*
+         * Reset while keeping the list intrep as much as possible.
+         */
+
         Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
         if (pc != NULL) {
             Tcl_Obj *innerContext;
 
             innerContext = TclGetInnerContext(interp, pc, tosPtr);
             if (innerContext != NULL) {
-                Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
+                Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+                        iPtr->innerLiteral);
                 Tcl_ListObjAppendElement(NULL, iPtr->errorStack, innerContext);
             }
         } else if (command != NULL) {
-            Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
-            Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(command, length));
+            Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+                    iPtr->innerLiteral);
+            Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+                    Tcl_NewStringObj(command, length));
         }
     } 
 
     if (!iPtr->framePtr->objc) {
-        /* special frame, nothing to report */
+        /*
+         * Special frame, nothing to report.
+         */
     } else if (iPtr->varFramePtr != iPtr->framePtr) {
-        /* uplevel case, [lappend errorstack UP $relativelevel] */
+        /*
+         * uplevel case, [lappend errorstack UP $relativelevel]
+         */
 
         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->upLiteral);
         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewIntObj(
 		iPtr->framePtr->level - iPtr->varFramePtr->level));
     } else if (iPtr->framePtr != iPtr->rootFramePtr) {
-        /* normal case, [lappend errorstack CALL [info level 0]] */
+        /*
+         * normal case, [lappend errorstack CALL [info level 0]]
+         */
+
         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->callLiteral);
         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewListObj(
 		iPtr->framePtr->objc, iPtr->framePtr->objv));
@@ -4979,7 +4993,12 @@ TclLogCommandInfo(
  *
  *----------------------------------------------------------------------
  */
-void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length)
+
+void
+TclErrorStackResetIf(
+    Tcl_Interp *interp,
+    const char *msg,
+    int length)
 {
     Interp *iPtr = (Interp *) interp;
 
@@ -4996,10 +5015,15 @@ void TclErrorStackResetIf(Tcl_Interp *interp, const char *msg, int length)
 
         iPtr->resetErrorStack = 0;
 	Tcl_ListObjLength(interp, iPtr->errorStack, &len);
-        /* reset while keeping the list intrep as much as possible */
+
+        /*
+         * Reset while keeping the list intrep as much as possible.
+         */
+
         Tcl_ListObjReplace(interp, iPtr->errorStack, 0, len, 0, NULL);
         Tcl_ListObjAppendElement(NULL, iPtr->errorStack, iPtr->innerLiteral);
-        Tcl_ListObjAppendElement(NULL, iPtr->errorStack, Tcl_NewStringObj(msg, length));
+        Tcl_ListObjAppendElement(NULL, iPtr->errorStack,
+                Tcl_NewStringObj(msg, length));
     } 
 }
 
diff --git a/generic/tclPkg.c b/generic/tclPkg.c
index 67503cb..fdaea57 100644
--- a/generic/tclPkg.c
+++ b/generic/tclPkg.c
@@ -882,18 +882,25 @@ Tcl_PackageObjCmd(
 	if (objc != 2) {
 	    Tcl_WrongNumArgs(interp, 2, objv, NULL);
 	    return TCL_ERROR;
-	}
-	tablePtr = &iPtr->packageTable;
-	for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
-		hPtr = Tcl_NextHashEntry(&search)) {
-	    pkgPtr = Tcl_GetHashValue(hPtr);
-	    if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
-		Tcl_AppendElement(interp, Tcl_GetHashKey(tablePtr, hPtr));
+	} else {
+	    Tcl_Obj *resultObj;
+
+	    resultObj = Tcl_NewObj();
+	    tablePtr = &iPtr->packageTable;
+	    for (hPtr = Tcl_FirstHashEntry(tablePtr, &search); hPtr != NULL;
+		    hPtr = Tcl_NextHashEntry(&search)) {
+		pkgPtr = Tcl_GetHashValue(hPtr);
+		if ((pkgPtr->version != NULL) || (pkgPtr->availPtr != NULL)) {
+		    Tcl_ListObjAppendElement(NULL,resultObj, Tcl_NewStringObj(
+			    Tcl_GetHashKey(tablePtr, hPtr), -1));
+		}
 	    }
+	    Tcl_SetObjResult(interp, resultObj);
 	}
 	break;
     case PKG_PRESENT: {
 	const char *name;
+
 	if (objc < 3) {
 	    goto require;
 	}
@@ -1098,23 +1105,27 @@ Tcl_PackageObjCmd(
 	if (objc != 3) {
 	    Tcl_WrongNumArgs(interp, 2, objv, "package");
 	    return TCL_ERROR;
-	}
-	argv2 = TclGetString(objv[2]);
-	hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
-	if (hPtr != NULL) {
-	    pkgPtr = Tcl_GetHashValue(hPtr);
-	    for (availPtr = pkgPtr->availPtr; availPtr != NULL;
-		    availPtr = availPtr->nextPtr) {
-		Tcl_AppendElement(interp, availPtr->version);
+	} else {
+	    Tcl_Obj *resultObj = Tcl_NewObj();
+
+	    argv2 = TclGetString(objv[2]);
+	    hPtr = Tcl_FindHashEntry(&iPtr->packageTable, argv2);
+	    if (hPtr != NULL) {
+		pkgPtr = Tcl_GetHashValue(hPtr);
+		for (availPtr = pkgPtr->availPtr; availPtr != NULL;
+			availPtr = availPtr->nextPtr) {
+		    Tcl_ListObjAppendElement(NULL, resultObj,
+			    Tcl_NewStringObj(availPtr->version, -1));
+		}
 	    }
+	    Tcl_SetObjResult(interp, resultObj);
 	}
 	break;
     case PKG_VSATISFIES: {
 	char *argv2i = NULL;
 
 	if (objc < 4) {
-	    Tcl_WrongNumArgs(interp, 2, objv,
-		    "version ?requirement ...?");
+	    Tcl_WrongNumArgs(interp, 2, objv, "version ?requirement ...?");
 	    return TCL_ERROR;
 	}
 
diff --git a/generic/tclTimer.c b/generic/tclTimer.c
index 6682d21..cf91dca 100644
--- a/generic/tclTimer.c
+++ b/generic/tclTimer.c
@@ -793,7 +793,6 @@ Tcl_AfterObjCmd(
     AfterAssocData *assocPtr;
     int length;
     int index;
-    char buf[16 + TCL_INTEGER_SPACE];
     static const char *const afterSubCmds[] = {
 	"cancel", "idle", "info", NULL
     };
@@ -952,13 +951,16 @@ Tcl_AfterObjCmd(
 	break;
     case AFTER_INFO:
 	if (objc == 2) {
+            Tcl_Obj *resultObj = Tcl_NewObj();
+
 	    for (afterPtr = assocPtr->firstAfterPtr; afterPtr != NULL;
 		    afterPtr = afterPtr->nextPtr) {
 		if (assocPtr->interp == interp) {
-		    sprintf(buf, "after#%d", afterPtr->id);
-		    Tcl_AppendElement(interp, buf);
+                    Tcl_ListObjAppendElement(NULL, resultObj, Tcl_ObjPrintf(
+                            "after#%d", afterPtr->id));
 		}
 	    }
+            Tcl_SetObjResult(interp, resultObj);
 	    return TCL_OK;
 	}
 	if (objc != 3) {
-- 
cgit v0.12


From f457d73c6c66e6b751cd6bc28efd8a88f56daadc Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Wed, 11 May 2011 15:43:06 +0000
Subject:   *  unix/tclUnixSock.c (TcpWatchProc): No need to check for server
 sockets here, as the generic server code already takes care of that.   * 
 tests/socket.test (accept): Add tests to make sure that this remains so.

---
 ChangeLog          |  8 ++++++++
 tests/socket.test  | 18 ++++++++++++++++++
 unix/tclUnixSock.c | 27 +++++++++------------------
 3 files changed, 35 insertions(+), 18 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 47b9a2d..41cf780 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2011-05-11  Reinhard Max  <max@suse.de>
+
+	* unix/tclUnixSock.c (TcpWatchProc): No need to check for server
+	sockets here, as the generic server code already takes care of
+	that.
+	* tests/socket.test (accept): Add tests to make sure that this
+	remains so.
+
 2011-05-10  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclInt.h:     New internal routines TclScanElement() and
diff --git a/tests/socket.test b/tests/socket.test
index 09b34ad..f1acedc 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -800,6 +800,24 @@ test socket_$af-6.1 {accept callback error} -constraints [list socket supported_
     interp bgerror {} $handler
 } -result {divide by zero}
 
+test socket_$af-6.2 {
+    readable fileevent on server socket
+} -setup {
+    set sock [socket -server dummy 0]
+} -body {
+    fileevent $sock readable dummy
+} -cleanup {
+    close $sock
+} -returnCodes 1 -result "channel is not readable"
+
+test socket_$af-6.3 {writable fileevent on server socket} -setup {
+    set sock [socket -server dummy 0]
+} -body {
+    fileevent $sock writable dummy
+} -cleanup {
+    close $sock
+} -returnCodes 1 -result "channel is not writable"
+
 test socket_$af-7.1 {testing socket specific options} -setup {
     file delete $path(script)
     set f [open $path(script) w]
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 35728e1..cb72759 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -785,25 +785,16 @@ TcpWatchProc(
 				 * TCL_EXCEPTION. */
 {
     TcpState *statePtr = (TcpState *) instanceData;
+    TcpFdList *fds;
 
-    /*
-     * Make sure we don't mess with server sockets since they will never be
-     * readable or writable at the Tcl level. This keeps Tcl scripts from
-     * interfering with the -accept behavior.
-     */
-
-    if (!statePtr->acceptProc) {
-	TcpFdList *fds;
-
-	for (fds = statePtr->fds; fds != NULL; fds = fds->next) {
-	    if (mask) {
-		Tcl_CreateFileHandler(fds->fd, mask,
-			(Tcl_FileProc *) Tcl_NotifyChannel,
-			(ClientData) statePtr->channel);
-	    } else {
-		Tcl_DeleteFileHandler(fds->fd);
-	    }
-	}
+    for (fds = statePtr->fds; fds != NULL; fds = fds->next) {
+        if (mask) {
+            Tcl_CreateFileHandler(fds->fd, mask,
+                                  (Tcl_FileProc *) Tcl_NotifyChannel,
+                                  (ClientData) statePtr->channel);
+        } else {
+            Tcl_DeleteFileHandler(fds->fd);
+        }
     }
 }
 
-- 
cgit v0.12


From b13a7c7f7e11cbd428004eef3a32e9f059af3183 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 11 May 2011 20:33:14 +0000
Subject: First draft of bug fix.

---
 generic/tclListObj.c | 38 ++++++++++++++++++++++++++++----------
 generic/tclUtil.c    |  4 ++--
 2 files changed, 30 insertions(+), 12 deletions(-)

diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index 506aa54..b623272 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -13,6 +13,10 @@
 
 #include "tclInt.h"
 
+#ifndef TCL_GROWTH_MIN_ALLOC
+#define TCL_GROWTH_MIN_ALLOC 1024
+#endif
+
 /*
  * Prototypes for functions defined later in this file:
  */
@@ -482,16 +486,13 @@ Tcl_ListObjGetElements(
  *
  * Tcl_ListObjAppendList --
  *
- *	This function appends the objects in the list referenced by
- *	elemListPtr to the list object referenced by listPtr. If listPtr is
- *	not already a list object, an attempt will be made to convert it to
- *	one.
+ *	This function appends the elements in the list value referenced by
+ *	elemListPtr to the list value referenced by listPtr.
  *
  * Results:
  *	The return value is normally TCL_OK. If listPtr or elemListPtr do not
- *	refer to list objects and they can not be converted to one, TCL_ERROR
- *	is returned and an error message is left in the interpreter's result
- *	if interp is not NULL.
+ *	refer to list values, TCL_ERROR is returned and an error message is
+ *	left in the interpreter's result if interp is not NULL.
  *
  * Side effects:
  *	The reference counts of the elements in elemListPtr are incremented
@@ -516,10 +517,12 @@ Tcl_ListObjAppendList(
 	Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
     }
 
+/*
     result = TclListObjLength(interp, listPtr, &listLen);
     if (result != TCL_OK) {
 	return result;
     }
+*/
 
     result = TclListObjGetElements(interp, elemListPtr, &objc, &objv);
     if (result != TCL_OK) {
@@ -531,7 +534,7 @@ Tcl_ListObjAppendList(
      * Delete zero existing elements.
      */
 
-    return Tcl_ListObjReplace(interp, listPtr, listLen, 0, objc, objv);
+    return Tcl_ListObjReplace(interp, listPtr, /*listLen*/LIST_MAX, 0, objc, objv);
 }
 
 /*
@@ -567,6 +570,9 @@ Tcl_ListObjAppendElement(
     Tcl_Obj *listPtr,		/* List object to append objPtr to. */
     Tcl_Obj *objPtr)		/* Object to append to listPtr's list. */
 {
+#if 1
+    return Tcl_ListObjReplace(interp, listPtr, LIST_MAX, 0, 1, &objPtr);
+#else
     register List *listRepPtr;
     register Tcl_Obj **elemPtrs;
     int numElems, numRequired, newMax, newSize, i;
@@ -645,6 +651,7 @@ Tcl_ListObjAppendElement(
 
     Tcl_InvalidateStringRep(listPtr);
     return TCL_OK;
+#endif
 }
 
 /*
@@ -898,9 +905,20 @@ Tcl_ListObjReplace(
 	    newMax = listRepPtr->maxElemCount;
 	}
 
-	listRepPtr = AttemptNewList(interp, newMax, NULL);
+	listRepPtr = AttemptNewList(NULL, newMax, NULL);
 	if (listRepPtr == NULL) {
-	    return TCL_ERROR;
+	    unsigned int limit = LIST_MAX - numRequired;
+	    unsigned int extra = numRequired - listRepPtr->elemCount
+		    + TCL_GROWTH_MIN_ALLOC/sizeof(Tcl_Obj *);
+	    int growth = (int) ((extra > limit) ? limit : extra);
+
+	    listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
+	    if (listRepPtr == NULL) {
+		listRepPtr = AttemptNewList(interp, numRequired, NULL);
+		if (listRepPtr == NULL) {
+		    return TCL_ERROR;
+		}
+	    }
 	}
 
 	listPtr->internalRep.twoPtrValue.ptr1 = listRepPtr;
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index f7f4bf4..3b5b527 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1786,7 +1786,7 @@ Tcl_ConcatObj(
 	    /*
 	     * Tcl_ListObjAppendList could be used here, but this saves us a
 	     * bit of type checking (since we've already done it). Use of
-	     * INT_MAX tells us to always put the new stuff on the end. It
+	     * LIST_MAX tells us to always put the new stuff on the end. It
 	     * will be set right in Tcl_ListObjReplace.
 	     * Note that all objs at this point are either lists or have an
 	     * empty string rep.
@@ -1799,7 +1799,7 @@ Tcl_ConcatObj(
 	    TclListObjGetElements(NULL, objPtr, &listc, &listv);
 	    if (listc) {
 		if (resPtr) {
-		    Tcl_ListObjReplace(NULL, resPtr, INT_MAX, 0, listc, listv);
+		    Tcl_ListObjReplace(NULL, resPtr, LIST_MAX, 0, listc, listv);
 		} else {
 		    resPtr = TclListObjCopy(NULL, objPtr);
 		}
-- 
cgit v0.12


From 3495bd2531b93a17421d6dc087527ef5fa111118 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 11 May 2011 20:42:14 +0000
Subject: Oops!

---
 generic/tclListObj.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index b623272..f1daf19 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -908,7 +908,7 @@ Tcl_ListObjReplace(
 	listRepPtr = AttemptNewList(NULL, newMax, NULL);
 	if (listRepPtr == NULL) {
 	    unsigned int limit = LIST_MAX - numRequired;
-	    unsigned int extra = numRequired - listRepPtr->elemCount
+	    unsigned int extra = numRequired - numElems
 		    + TCL_GROWTH_MIN_ALLOC/sizeof(Tcl_Obj *);
 	    int growth = (int) ((extra > limit) ? limit : extra);
 
-- 
cgit v0.12


From a720a9f6e21c4c9afd7a4b125478dc9800db11c2 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 12 May 2011 15:00:02 +0000
Subject: Set the defaults of all growth algorithm parameters based on one
 master value.

---
 generic/tclInt.h       | 16 +++++++++++++++-
 generic/tclListObj.c   | 11 ++++++-----
 generic/tclStringObj.c | 19 +++++++++----------
 3 files changed, 30 insertions(+), 16 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8f003be..d010284 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4097,8 +4097,22 @@ MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
  *----------------------------------------------------------------
  */
 
+/* General tuning for minimum growth in Tcl growth algorithms */
+#ifndef TCL_MIN_GROWTH
+#  ifdef TCL_GROWTH_MIN_ALLOC
+     /* Support for any legacy tuners */
+#    define TCL_MIN_GROWTH TCL_GROWTH_MIN_ALLOC
+#  else
+#    define TCL_MIN_GROWTH 1024
+#  endif
+#endif
+
+/* Token growth tuning, default to the general value. */
+#ifndef TCL_MIN_TOKEN_GROWTH
+#define TCL_MIN_TOKEN_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Token)
+#endif
+
 #define TCL_MAX_TOKENS (int)(UINT_MAX / sizeof(Tcl_Token))
-#define TCL_MIN_TOKEN_GROWTH 50
 #define TclGrowTokenArray(tokenPtr, used, available, append, staticPtr)	\
     do {								\
 	int needed = (used) + (append);					\
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index f1daf19..e1c415b 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -13,10 +13,6 @@
 
 #include "tclInt.h"
 
-#ifndef TCL_GROWTH_MIN_ALLOC
-#define TCL_GROWTH_MIN_ALLOC 1024
-#endif
-
 /*
  * Prototypes for functions defined later in this file:
  */
@@ -49,6 +45,11 @@ const Tcl_ObjType tclListType = {
     UpdateStringOfList,		/* updateStringProc */
     SetListFromAny		/* setFromAnyProc */
 };
+
+#ifndef TCL_MIN_ELEMENT_GROWTH
+#define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
+#endif
+
 
 /*
  *----------------------------------------------------------------------
@@ -909,7 +910,7 @@ Tcl_ListObjReplace(
 	if (listRepPtr == NULL) {
 	    unsigned int limit = LIST_MAX - numRequired;
 	    unsigned int extra = numRequired - numElems
-		    + TCL_GROWTH_MIN_ALLOC/sizeof(Tcl_Obj *);
+		    + TCL_MIN_ELEMENT_GROWTH;
 	    int growth = (int) ((extra > limit) ? limit : extra);
 
 	    listRepPtr = AttemptNewList(NULL, numRequired + growth, NULL);
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 0f6eff7..ab62359 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -152,8 +152,7 @@ typedef struct String {
  *
  *   Attempt to allocate 2 * (originalLength + appendLength)
  *   On failure:
- *	attempt to allocate originalLength + 2*appendLength +
- *			TCL_GROWTH_MIN_ALLOC
+ *	attempt to allocate originalLength + 2*appendLength + TCL_MIN_GROWTH
  *
  * This algorithm allows very good performance, as it rapidly increases the
  * memory allocated for a given string, which minimizes the number of
@@ -166,20 +165,20 @@ typedef struct String {
  * cover the request, but which hopefully will be less than the total
  * available memory.
  *
- * The addition of TCL_GROWTH_MIN_ALLOC allows for efficient handling of very
+ * The addition of TCL_MIN_GROWTH allows for efficient handling of very
  * small appends. Without this extra slush factor, a sequence of several small
  * appends would cause several memory allocations. As long as
- * TCL_GROWTH_MIN_ALLOC is a reasonable size, we can avoid that behavior.
+ * TCL_MIN_GROWTH is a reasonable size, we can avoid that behavior.
  *
  * The growth algorithm can be tuned by adjusting the following parameters:
  *
- * TCL_GROWTH_MIN_ALLOC		Additional space, in bytes, to allocate when
+ * TCL_MIN_GROWTH		Additional space, in bytes, to allocate when
  *				the double allocation has failed. Default is
- *				1024 (1 kilobyte).
+ *				1024 (1 kilobyte).  See tclInt.h.
  */
 
-#ifndef TCL_GROWTH_MIN_ALLOC
-#define TCL_GROWTH_MIN_ALLOC	1024
+#ifndef TCL_MIN_UNICHAR_GROWTH
+#define TCL_MIN_UNICHAR_GROWTH	TCL_MIN_GROWTH/sizeof(Tcl_UniChar)
 #endif
 
 static void
@@ -214,7 +213,7 @@ GrowStringBuffer(
 	     */
 
 	    unsigned int limit = INT_MAX - needed;
-	    unsigned int extra = needed - objPtr->length + TCL_GROWTH_MIN_ALLOC;
+	    unsigned int extra = needed - objPtr->length + TCL_MIN_GROWTH;
 	    int growth = (int) ((extra > limit) ? limit : extra);
 
 	    attempt = needed + growth;
@@ -265,7 +264,7 @@ GrowUnicodeBuffer(
 
 	    unsigned int limit = STRING_MAXCHARS - needed;
 	    unsigned int extra = needed - stringPtr->numChars
-		    + TCL_GROWTH_MIN_ALLOC/sizeof(Tcl_UniChar);
+		    + TCL_MIN_UNICHAR_GROWTH;
 	    int growth = (int) ((extra > limit) ? limit : extra);
 
 	    attempt = needed + growth;
-- 
cgit v0.12


From 5bd6dd53b688d13a70275daa5ae14814b8c69221 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 24 May 2011 12:23:52 +0000
Subject: Remove some useless code from mcset and mcmset: [dict set] builds
 dictionary levels for us.

---
 ChangeLog                 |  5 +++++
 generic/tclInt.h          |  7 +++++--
 library/msgcat/msgcat.tcl | 14 --------------
 3 files changed, 10 insertions(+), 16 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 6e64b7c..83fa590 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-05-24  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/msgcat/msgcat.tcl (msgcat::mcset, msgcat::mcmset): Remove
+	some useless code; [dict set] builds dictionary levels for us.
+
 2011-05-17  Andreas Kupries  <andreask@activestate.com>
 
 	* generic/tclCompile.c (TclFixupForwardJump): Tracked down and fixed
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8f003be..75f894f 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4227,8 +4227,11 @@ MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
  */
 
 #define TclInvalidateNsCmdLookup(nsPtr) \
-    if ((nsPtr)->numExportPatterns) {	\
-	(nsPtr)->exportLookupEpoch++;	\
+    if ((nsPtr)->numExportPatterns) {		\
+	(nsPtr)->exportLookupEpoch++;		\
+    }						\
+    if ((nsPtr)->commandPathLength) {		\
+	(nsPtr)->cmdRefEpoch++;			\
     }
 
 /*
diff --git a/library/msgcat/msgcat.tcl b/library/msgcat/msgcat.tcl
index a9b4533..b39820a 100644
--- a/library/msgcat/msgcat.tcl
+++ b/library/msgcat/msgcat.tcl
@@ -313,13 +313,6 @@ proc msgcat::mcset {locale src {dest ""}} {
 
     set locale [string tolower $locale]
 
-    # create nested dictionaries if they do not exist
-    if {![dict exists $Msgs $locale]} {
-        dict set Msgs $locale  [dict create]
-    }
-    if {![dict exists $Msgs $locale $ns]} {
-        dict set Msgs $locale $ns [dict create]
-    }
     dict set Msgs $locale $ns $src $dest
     return $dest
 }
@@ -347,13 +340,6 @@ proc msgcat::mcmset {locale pairs } {
     set locale [string tolower $locale]
     set ns [uplevel 1 [list ::namespace current]]
 
-    # create nested dictionaries if they do not exist
-    if {![dict exists $Msgs $locale]} {
-        dict set Msgs $locale  [dict create]
-    }
-    if {![dict exists $Msgs $locale $ns]} {
-        dict set Msgs $locale $ns [dict create]
-    }
     foreach {src dest} $pairs {
         dict set Msgs $locale $ns $src $dest
     }
-- 
cgit v0.12


From 8d3db05308f4171d5df9cc39c19a8914ab6b651d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 24 May 2011 12:36:20 +0000
Subject: Undo mistaken commit

---
 generic/tclInt.h | 7 ++-----
 1 file changed, 2 insertions(+), 5 deletions(-)

diff --git a/generic/tclInt.h b/generic/tclInt.h
index 75f894f..8f003be 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -4227,11 +4227,8 @@ MODULE_SCOPE void	TclDbInitNewObj(Tcl_Obj *objPtr, const char *file,
  */
 
 #define TclInvalidateNsCmdLookup(nsPtr) \
-    if ((nsPtr)->numExportPatterns) {		\
-	(nsPtr)->exportLookupEpoch++;		\
-    }						\
-    if ((nsPtr)->commandPathLength) {		\
-	(nsPtr)->cmdRefEpoch++;			\
+    if ((nsPtr)->numExportPatterns) {	\
+	(nsPtr)->exportLookupEpoch++;	\
     }
 
 /*
-- 
cgit v0.12


From 1d49ca67e112ecdac5812541cf20613f4147a0e9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 25 May 2011 13:35:37 +0000
Subject: Implementation of TIP #381: Call Chain Introspection and Control

---
 ChangeLog            |  10 +
 doc/info.n           |  66 +++++
 doc/next.n           |   8 +
 doc/self.n           |  33 +++
 generic/tclOO.c      |   2 +
 generic/tclOOBasic.c | 120 +++++++-
 generic/tclOOCall.c  | 223 ++++++++++++++-
 generic/tclOOInfo.c  |  90 ++++++
 generic/tclOOInt.h   |   7 +
 tests/oo.test        |   4 +-
 tests/ooNext2.test   | 765 +++++++++++++++++++++++++++++++++++++++++++++++++++
 11 files changed, 1313 insertions(+), 15 deletions(-)
 create mode 100644 tests/ooNext2.test

diff --git a/ChangeLog b/ChangeLog
index af7fab6..3118f82 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2011-05-25  Donal K. Fellows  <dkf@users.sf.net>
+
+	IMPLEMENTATION OF TIP#381.
+
+	* doc/next.n, doc/ooInfo.n, doc/self.n, generic/tclOO.c,
+	* generic/tclOOBasic.c, generic/tclOOCall.c, generic/tclOOInfo.c,
+	* generic/tclOOInt.h, tests/oo.test, tests/ooNext2.test: Added
+	introspection of call chains ([self call], [info object call], [info
+	class call]) and ability to skip ahead in chain ([nextto]).
+
 2011-05-24  Venkat Iyer <venkat@comit.com>
 
 	* library/tzdata/Africa/Cairo: Update to Olson tzdata2011g
diff --git a/doc/info.n b/doc/info.n
index 2126b21..cb5c6e6 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -399,6 +399,29 @@ been set (e.g. a variable declared but not set by \fBvariable\fR).
 The following \fIsubcommand\fR values are supported by \fBinfo class\fR:
 .VE 8.6
 .TP
+\fBinfo class call\fI class method\fR
+.VS
+Returns a description of the method implementations that are used to provide a
+stereotypical instance of \fIclass\fR's implementation of \fImethod\fR
+(stereotypical instances being objects instantiated by a class without having
+any object-specific definitions added). This consists of a list of lists of
+four elements, where each sublist consists of a word that describes the
+general type of method implementation (being one of \fBmethod\fR for an
+ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
+method that is invoked as part of unknown method handling), a word giving the
+name of the particular method invoked (which is always the same as
+\fImethod\fR for the \fBmethod\fR type, and
+.QW \fBunknown\fR
+for the \fBunknown\fR type), a word giving the fully qualified name of the
+class that defined the method, and a word describing the type of method
+implementation (see \fBinfo class methodtype\fR).
+.RS
+.PP
+Note that there is no inspection of whether the method implementations
+actually use \fBnext\fR to transfer control along the call chain.
+.RE
+.VE 8.6
+.TP
 \fBinfo class constructor\fI class\fR
 .VS 8.6
 This subcommand returns a description of the definition of the constructor of
@@ -504,6 +527,28 @@ class's methods, constructor and destructor).
 The following \fIsubcommand\fR values are supported by \fBinfo object\fR:
 .VE 8.6
 .TP
+\fBinfo object call\fI object method\fR
+.VS 8.6
+Returns a description of the method implementations that are used to provide
+\fIobject\fR's implementation of \fImethod\fR.  This consists of a list of
+lists of four elements, where each sublist consists of a word that describes
+the general type of method implementation (being one of \fBmethod\fR for an
+ordinary method, \fBfilter\fR for an applied filter, and \fBunknown\fR for a
+method that is invoked as part of unknown method handling), a word giving the
+name of the particular method invoked (which is always the same as
+\fImethod\fR for the \fBmethod\fR type, and
+.QW \fBunknown\fR
+for the \fBunknown\fR type), a word giving what defined the method (the fully
+qualified name of the class, or the literal string \fBobject\fR if the method
+implementation is on an instance), and a word describing the type of method
+implementation (see \fBinfo object methodtype\fR).
+.RS
+.PP
+Note that there is no inspection of whether the method implementations
+actually use \fBnext\fR to transfer control along the call chain.
+.RE
+.VE 8.6
+.TP
 \fBinfo object class\fI object\fR ?\fIclassName\fR?
 .VS 8.6
 If \fIclassName\fR is unspecified, this subcommand returns class of the
@@ -672,6 +717,27 @@ method and get how it is defined. This procedure illustrates how:
 .PP
 .CS
 proc getDef {obj method} {
+    foreach inf [\fBinfo object call\fR $obj $method] {
+        lassign $inf calltype name locus methodtype
+        # Assume no forwards or filters, and hence no $calltype
+        # or $methodtype checks...
+        if {$locus eq "object"} {
+            return [\fBinfo object definition\fR $obj $name]
+        } else {
+            return [\fBinfo class definition\fR $locus $name]
+        }
+    }
+    error "no definition for $method"
+}
+.CE
+.PP
+This is an alternate way of implementing the definition lookup is by manually
+scanning the list of methods up the inheritance tree. This code assumes that
+only single inheritance is in use, and that there is no complex use of
+mixed-in classes:
+.PP
+.CS
+proc getDef {obj method} {
     if {$method in [\fBinfo object methods\fR $obj]} {
         # Assume no forwards
         return [\fBinfo object definition\fR $obj $method]
diff --git a/doc/next.n b/doc/next.n
index c8b098e..222d8b3 100644
--- a/doc/next.n
+++ b/doc/next.n
@@ -15,6 +15,7 @@ next \- invoke superclass method implementations
 package require TclOO
 
 \fBnext\fR ?\fIarg ...\fR?
+\fBnextto\fI class\fR ?\fIarg ...\fR?
 .fi
 .BE
 
@@ -30,6 +31,13 @@ of the next method in the method chain; if there are no further methods in the
 method chain, the result of \fBnext\fR will be an error. The arguments,
 \fIarg\fR, to \fBnext\fR are the arguments to pass to the next method in the
 chain.
+.PP
+The \fBnextto\fR command is the same as the \fBnext\fR command, except that it
+takes an additional \fIclass\fR argument that identifies a class whose
+implementation of the current method chain (see \fBinfo object call\fR) should
+be used; the method implementation selected will be the one provided by the
+given class, and it must refer to an existing non-filter invocation that lies
+further along the chain than the current implementation.
 .SH "THE METHOD CHAIN"
 .PP
 When a method of an object is invoked, things happen in several stages:
diff --git a/doc/self.n b/doc/self.n
index f01a607..11779ff 100644
--- a/doc/self.n
+++ b/doc/self.n
@@ -25,6 +25,17 @@ takes an argument, \fIsubcommand\fR, that tells it what sort of information is
 actually desired; if omitted the result will be the same as if \fBself
 object\fR was invoked. The supported subcommands are:
 .TP
+\fBself call\fR
+.
+This returns a two-element list describing the method implementations used to
+implement the current call chain. The first element is the same as would be
+reported by \fBinfo object call\fR for the current method (except that this
+also reports useful values from within constructors and destructors, whose
+names are reported as \fB<constructor>\fR and \fB<destructor>\fR
+respectively), and the second element is an index into the first element's
+list that indicates which actual implementation is currently executing (the
+first implementation to execute is always at index 0).
+.TP
 \fBself caller\fR
 .
 When the method was invoked from inside another object method, this subcommand
@@ -109,6 +120,28 @@ c create b
 a foo                \fI\(-> prints "this is the ::a object"\fR
 b foo                \fI\(-> prints "this is the ::b object"\fR
 .CE
+.PP
+This demonstrates what a method call chain looks like, and how traversing
+along it changes the index into it:
+.PP
+.CS
+oo::class create c {
+    method x {} {
+        puts "Cls: [\fBself call\fR]"
+    }
+}
+c create a
+oo::objdefine a {
+    method x {} {
+        puts "Obj: [\fBself call\fR]"
+        next
+        puts "Obj: [\fBself call\fR]"
+    }
+}
+a x     \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR
+        \fI\(-> Cls: {{method x object method} {method x ::c method}} 1\fR
+        \fI\(-> Obj: {{method x object method} {method x ::c method}} 0\fR
+.CE
 .SH "SEE ALSO"
 info(n), next(n)
 .SH KEYWORDS
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 6ae82d1..9df3f53 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -346,6 +346,8 @@ InitFoundation(
 
     Tcl_CreateObjCommand(interp, "::oo::Helpers::next", TclOONextObjCmd, NULL,
 	    NULL);
+    Tcl_CreateObjCommand(interp, "::oo::Helpers::nextto", TclOONextToObjCmd,
+	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "::oo::Helpers::self", TclOOSelfObjCmd, NULL,
 	    NULL);
     Tcl_CreateObjCommand(interp, "::oo::define", TclOODefineObjCmd, NULL,
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index 0d38dcd..b286088 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -680,10 +680,11 @@ TclOO_Object_VarName(
 /*
  * ----------------------------------------------------------------------
  *
- * TclOONextObjCmd --
+ * TclOONextObjCmd, TclOONextToObjCmd --
  *
- *	Implementation of the [next] command. Note that this command is only
- *	ever to be used inside the body of a procedure-like method.
+ *	Implementation of the [next] and [nextto] commands. Note that these
+ *	commands are only ever to be used inside the body of a procedure-like
+ *	method.
  *
  * ----------------------------------------------------------------------
  */
@@ -723,6 +724,97 @@ TclOONextObjCmd(
     return TclNRObjectContextInvokeNext(interp, context, objc, objv, 1);
 }
 
+int
+TclOONextToObjCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *framePtr = iPtr->varFramePtr;
+    Class *classPtr;
+    CallContext *contextPtr;
+    int i;
+    Tcl_Object object;
+
+    /*
+     * Start with sanity checks on the calling context to make sure that we
+     * are invoked from a suitable method context. If so, we can safely
+     * retrieve the handle to the object call context.
+     */
+
+    if (framePtr == NULL || !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+	Tcl_AppendResult(interp, TclGetString(objv[0]),
+		" may only be called from inside a method", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+	return TCL_ERROR;
+    }
+    contextPtr = framePtr->clientData;
+
+    /*
+     * Sanity check the arguments; we need the first one to refer to a class.
+     */
+
+    if (objc < 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "class ?arg...?");
+	return TCL_ERROR;
+    }
+    object = Tcl_GetObjectFromObj(interp, objv[1]);
+    if (object == NULL) {
+	return TCL_ERROR;
+    }
+    classPtr = ((Object *)object)->classPtr;
+    if (classPtr == NULL) {
+	Tcl_AppendResult(interp, "\"", TclGetString(objv[1]),
+		"\" is not a class", NULL);
+	return TCL_ERROR;
+    }
+
+    /*
+     * Search for an implementation of a method associated with the current
+     * call on the call chain past the point where we currently are. Do not
+     * allow jumping backwards!
+     */
+
+    for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+
+	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
+	    /*
+	     * Invoke the (advanced) method call context in the caller
+	     * context. Note that this is like [uplevel 1] and not [eval].
+	     */
+
+	    TclNRAddCallback(interp, RestoreFrame, framePtr, contextPtr,
+		    INT2PTR(contextPtr->index), NULL);
+	    contextPtr->index = i-1;
+	    iPtr->varFramePtr = framePtr->callerVarPtr;
+	    return TclNRObjectContextInvokeNext(interp,
+		    (Tcl_ObjectContext) contextPtr, objc, objv, 2);
+	}
+    }
+
+    /*
+     * Generate an appropriate error message, depending on whether the value
+     * is on the chain but unreachable, or not on the chain at all.
+     */
+
+    for (i=contextPtr->index ; i>=0 ; i--) {
+	struct MInvoke *miPtr = contextPtr->callPtr->chain + i;
+
+	if (!miPtr->isFilter && miPtr->mPtr->declaringClassPtr == classPtr) {
+	    Tcl_AppendResult(interp, "method implementation by \"",
+		    TclGetString(objv[1]), "\" not reachable from here",
+		    NULL);
+	    return TCL_ERROR;
+	}
+    }
+    Tcl_AppendResult(interp, "method has no non-filter implementation by \"",
+	    TclGetString(objv[1]), "\"", NULL);
+    return TCL_ERROR;
+}
+
 static int
 RestoreFrame(
     ClientData data[],
@@ -730,8 +822,12 @@ RestoreFrame(
     int result)
 {
     Interp *iPtr = (Interp *) interp;
+    CallContext *contextPtr = data[1];
 
     iPtr->varFramePtr = data[0];
+    if (contextPtr != NULL) {
+	contextPtr->index = PTR2INT(data[2]);
+    }
     return result;
 }
 
@@ -754,16 +850,17 @@ TclOOSelfObjCmd(
     Tcl_Obj *const *objv)
 {
     static const char *const subcmds[] = {
-	"caller", "class", "filter", "method", "namespace", "next", "object",
-	"target", NULL
+	"call", "caller", "class", "filter", "method", "namespace", "next",
+	"object", "target", NULL
     };
     enum SelfCmds {
-	SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS, SELF_NEXT,
-	SELF_OBJECT, SELF_TARGET
+	SELF_CALL, SELF_CALLER, SELF_CLASS, SELF_FILTER, SELF_METHOD, SELF_NS,
+	SELF_NEXT, SELF_OBJECT, SELF_TARGET
     };
     Interp *iPtr = (Interp *) interp;
     CallFrame *framePtr = iPtr->varFramePtr;
     CallContext *contextPtr;
+    Tcl_Obj *result[3];
     int index;
 
 #define CurrentlyInvoked(contextPtr) \
@@ -834,7 +931,6 @@ TclOOSelfObjCmd(
 	    return TCL_ERROR;
 	} else {
 	    register struct MInvoke *miPtr = &CurrentlyInvoked(contextPtr);
-	    Tcl_Obj *result[3];
 	    Object *oPtr;
 	    const char *type;
 
@@ -862,7 +958,6 @@ TclOOSelfObjCmd(
 	    CallContext *callerPtr = framePtr->callerVarPtr->clientData;
 	    Method *mPtr = callerPtr->callPtr->chain[callerPtr->index].mPtr;
 	    Object *declarerPtr;
-	    Tcl_Obj *result[3];
 
 	    if (mPtr->declaringClassPtr != NULL) {
 		declarerPtr = mPtr->declaringClassPtr->thisPtr;
@@ -894,7 +989,6 @@ TclOOSelfObjCmd(
 	    Method *mPtr =
 		    contextPtr->callPtr->chain[contextPtr->index+1].mPtr;
 	    Object *declarerPtr;
-	    Tcl_Obj *result[2];
 
 	    if (mPtr->declaringClassPtr != NULL) {
 		declarerPtr = mPtr->declaringClassPtr->thisPtr;
@@ -928,7 +1022,6 @@ TclOOSelfObjCmd(
 	} else {
 	    Method *mPtr;
 	    Object *declarerPtr;
-	    Tcl_Obj *result[2];
 	    int i;
 
 	    for (i=contextPtr->index ; i<contextPtr->callPtr->numChain ; i++){
@@ -957,6 +1050,11 @@ TclOOSelfObjCmd(
 	    Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
 	    return TCL_OK;
 	}
+    case SELF_CALL:
+	result[0] = TclOORenderCallChain(interp, contextPtr->callPtr);
+	result[1] = Tcl_NewIntObj(contextPtr->index);
+	Tcl_SetObjResult(interp, Tcl_NewListObj(2, result));
+	return TCL_OK;
     }
     return TCL_ERROR;
 }
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 1e8d1a3..3954a6b 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -104,8 +104,10 @@ TclOODeleteContext(
     register Object *oPtr = contextPtr->oPtr;
 
     TclOODeleteChain(contextPtr->callPtr);
-    TclStackFree(oPtr->fPtr->interp, contextPtr);
-    DelRef(oPtr);
+    if (oPtr != NULL) {
+	TclStackFree(oPtr->fPtr->interp, contextPtr);
+	DelRef(oPtr);
+    }
 }
 
 /*
@@ -1099,6 +1101,137 @@ TclOOGetCallContext(
 /*
  * ----------------------------------------------------------------------
  *
+ * TclOOGetStereotypeCallChain --
+ *
+ *	Construct a call-chain for a method that would be used by a
+ *	stereotypical instance of the given class (i.e., where the object has
+ *	no definitions special to itself).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+CallChain *
+TclOOGetStereotypeCallChain(
+    Class *clsPtr,		/* The object to get the context for. */
+    Tcl_Obj *methodNameObj,	/* The name of the method to get the context
+				 * for. NULL when getting a constructor or
+				 * destructor chain. */
+    int flags)			/* What sort of context are we looking for.
+				 * Only the bits PUBLIC_METHOD, CONSTRUCTOR,
+				 * PRIVATE_METHOD, DESTRUCTOR and
+				 * FILTER_HANDLING are useful. */
+{
+    CallChain *callPtr;
+    struct ChainBuilder cb;
+    int i, count;
+    Foundation *fPtr = clsPtr->thisPtr->fPtr;
+    Tcl_HashEntry *hPtr;
+    Tcl_HashTable doneFilters;
+    Object obj;
+
+    /*
+     * Synthesize a temporary stereotypical object so that we can use existing
+     * machinery to produce the stereotypical call chain.
+     */
+
+    memset(&obj, 0, sizeof(Object));
+    obj.fPtr = fPtr;
+    obj.selfCls = clsPtr;
+    obj.refCount = 1;
+    obj.flags = USE_CLASS_CACHE;
+
+    /*
+     * Check if we can get the chain out of the Tcl_Obj method name or out of
+     * the cache. This is made a bit more complex by the fact that there are
+     * multiple different layers of cache (in the Tcl_Obj, in the object, and
+     * in the class).
+     */
+
+    if (clsPtr->classChainCache != NULL) {
+	hPtr = Tcl_FindHashEntry(clsPtr->classChainCache,
+		(char *) methodNameObj);
+	if (hPtr != NULL && Tcl_GetHashValue(hPtr) != NULL) {
+	    const int reuseMask =
+		    ((flags & PUBLIC_METHOD) ? ~0 : ~PUBLIC_METHOD);
+
+	    callPtr = Tcl_GetHashValue(hPtr);
+	    if (IsStillValid(callPtr, &obj, flags, reuseMask)) {
+		callPtr->refCount++;
+		return callPtr;
+	    }
+	    Tcl_SetHashValue(hPtr, NULL);
+	    TclOODeleteChain(callPtr);
+	}
+    } else {
+	hPtr = NULL;
+    }
+
+    callPtr = (CallChain *) ckalloc(sizeof(CallChain));
+    memset(callPtr, 0, sizeof(CallChain));
+    callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING);
+    callPtr->epoch = fPtr->epoch;
+    callPtr->objectCreationEpoch = fPtr->tsdPtr->nsCount;
+    callPtr->objectEpoch = clsPtr->thisPtr->epoch;
+    callPtr->refCount = 1;
+    callPtr->chain = callPtr->staticChain;
+
+    cb.callChainPtr = callPtr;
+    cb.filterLength = 0;
+    cb.oPtr = &obj;
+
+    /*
+     * Add all defined filters (if any, and if we're going to be processing
+     * them; they're not processed for constructors, destructors or when we're
+     * in the middle of processing a filter).
+     */
+
+    Tcl_InitObjHashTable(&doneFilters);
+    AddClassFiltersToCallContext(&obj, clsPtr, &cb, &doneFilters);
+    Tcl_DeleteHashTable(&doneFilters);
+    count = cb.filterLength = callPtr->numChain;
+
+    /*
+     * Add the actual method implementations.
+     */
+
+    AddSimpleChainToCallContext(&obj, methodNameObj, &cb, NULL, flags, NULL);
+
+    /*
+     * Check to see if the method has no implementation. If so, we probably
+     * need to add in a call to the unknown method. Otherwise, set up the
+     * cacheing of the method implementation (if relevant).
+     */
+
+    if (count == callPtr->numChain) {
+	AddSimpleChainToCallContext(&obj, fPtr->unknownMethodNameObj, &cb,
+		NULL, 0, NULL);
+	callPtr->flags |= OO_UNKNOWN_METHOD;
+	callPtr->epoch = -1;
+	if (count == callPtr->numChain) {
+	    TclOODeleteChain(callPtr);
+	    return NULL;
+	}
+    } else {
+	if (hPtr == NULL) {
+	    if (clsPtr->classChainCache == NULL) {
+		clsPtr->classChainCache = (Tcl_HashTable *)
+			ckalloc(sizeof(Tcl_HashTable));
+
+		Tcl_InitObjHashTable(clsPtr->classChainCache);
+	    }
+	    hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
+		    (char *) methodNameObj, &i);
+	}
+	callPtr->refCount++;
+	Tcl_SetHashValue(hPtr, callPtr);
+	StashCallChain(methodNameObj, callPtr);
+    }
+    return callPtr;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
  * AddClassFiltersToCallContext --
  *
  *	Logic to make extracting all the filters from the class context much
@@ -1256,6 +1389,92 @@ AddSimpleClassChainToCallContext(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOORenderCallChain --
+ *
+ *	Create a description of a call chain. Used in [info object call],
+ *	[info class call], and [self call].
+ *
+ * ----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclOORenderCallChain(
+    Tcl_Interp *interp,
+    CallChain *callPtr)
+{
+    Tcl_Obj *filterLiteral, *methodLiteral, *objectLiteral;
+    Tcl_Obj *resultObj, *descObjs[4], **objv;
+    Foundation *fPtr = TclOOGetFoundation(interp);
+    int i;
+
+    /*
+     * Allocate the literals (potentially) used in our description.
+     */
+
+    filterLiteral = Tcl_NewStringObj("filter", -1);
+    Tcl_IncrRefCount(filterLiteral);
+    methodLiteral = Tcl_NewStringObj("method", -1);
+    Tcl_IncrRefCount(methodLiteral);
+    objectLiteral = Tcl_NewStringObj("object", -1);
+    Tcl_IncrRefCount(objectLiteral);
+
+    /*
+     * Do the actual construction of the descriptions. They consist of a list
+     * of triples that describe the details of how a method is understood. For
+     * each triple, the first word is the type of invokation ("method" is
+     * normal, "unknown" is special because it adds the method name as an
+     * extra argument when handled by some method types, and "filter" is
+     * special because it's a filter method). The second word is the name of
+     * the method in question (which differs for "unknown" and "filter" types)
+     * and the third word is the full name of the class that declares the
+     * method (or "object" if it is declared on the instance).
+     */
+
+    objv = TclStackAlloc(interp, callPtr->numChain * sizeof(Tcl_Obj *));
+    for (i=0 ; i<callPtr->numChain ; i++) {
+	struct MInvoke *miPtr = &callPtr->chain[i];
+
+	descObjs[0] = miPtr->isFilter
+		? filterLiteral
+		: callPtr->flags & OO_UNKNOWN_METHOD
+			? fPtr->unknownMethodNameObj
+			: methodLiteral;
+	descObjs[1] = callPtr->flags & CONSTRUCTOR
+		? fPtr->constructorName
+		: callPtr->flags & DESTRUCTOR
+			? fPtr->destructorName
+			: miPtr->mPtr->namePtr;
+	descObjs[2] = miPtr->mPtr->declaringClassPtr
+		? Tcl_GetObjectName(interp,
+			(Tcl_Object) miPtr->mPtr->declaringClassPtr->thisPtr)
+		: objectLiteral;
+	descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1);
+
+	objv[i] = Tcl_NewListObj(4, descObjs);
+	Tcl_IncrRefCount(objv[i]);
+    }
+
+    /*
+     * Drop the local references to the literals; if they're actually used,
+     * they'll live on the description itself.
+     */
+
+    Tcl_DecrRefCount(filterLiteral);
+    Tcl_DecrRefCount(methodLiteral);
+    Tcl_DecrRefCount(objectLiteral);
+
+    /*
+     * Finish building the description and return it.
+     */
+
+    resultObj = Tcl_NewListObj(callPtr->numChain, objv);
+    TclStackFree(interp, objv);
+    return resultObj;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index 4f25772..ac8ae46 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -17,6 +17,7 @@
 #include "tclOOInt.h"
 
 static inline Class *	GetClassFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr);
+static Tcl_ObjCmdProc InfoObjectCallCmd;
 static Tcl_ObjCmdProc InfoObjectClassCmd;
 static Tcl_ObjCmdProc InfoObjectDefnCmd;
 static Tcl_ObjCmdProc InfoObjectFiltersCmd;
@@ -28,6 +29,7 @@ static Tcl_ObjCmdProc InfoObjectMixinsCmd;
 static Tcl_ObjCmdProc InfoObjectNsCmd;
 static Tcl_ObjCmdProc InfoObjectVarsCmd;
 static Tcl_ObjCmdProc InfoObjectVariablesCmd;
+static Tcl_ObjCmdProc InfoClassCallCmd;
 static Tcl_ObjCmdProc InfoClassConstrCmd;
 static Tcl_ObjCmdProc InfoClassDefnCmd;
 static Tcl_ObjCmdProc InfoClassDestrCmd;
@@ -48,6 +50,7 @@ struct NameProcMap { const char *name; Tcl_ObjCmdProc *proc; };
  */
 
 static const struct NameProcMap infoObjectCmds[] = {
+    {"::oo::InfoObject::call",		InfoObjectCallCmd},
     {"::oo::InfoObject::class",		InfoObjectClassCmd},
     {"::oo::InfoObject::definition",	InfoObjectDefnCmd},
     {"::oo::InfoObject::filters",	InfoObjectFiltersCmd},
@@ -67,6 +70,7 @@ static const struct NameProcMap infoObjectCmds[] = {
  */
 
 static const struct NameProcMap infoClassCmds[] = {
+    {"::oo::InfoClass::call",		InfoClassCallCmd},
     {"::oo::InfoClass::constructor",	InfoClassConstrCmd},
     {"::oo::InfoClass::definition",	InfoClassDefnCmd},
     {"::oo::InfoClass::destructor",	InfoClassDestrCmd},
@@ -1456,6 +1460,92 @@ InfoClassVariablesCmd(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * InfoObjectCallCmd --
+ *
+ *	Implements [info object call $objName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoObjectCallCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Object *oPtr;
+    CallContext *contextPtr;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "objName methodName");
+	return TCL_ERROR;
+    }
+    oPtr = (Object *) Tcl_GetObjectFromObj(interp, objv[1]);
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Get the call context and render its call chain.
+     */
+
+    contextPtr = TclOOGetCallContext(oPtr, objv[2], PUBLIC_METHOD, NULL);
+    if (contextPtr == NULL) {
+	Tcl_AppendResult(interp, "cannot construct any call chain", NULL);
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp,
+	    TclOORenderCallChain(interp, contextPtr->callPtr));
+    TclOODeleteContext(contextPtr);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * InfoClassCallCmd --
+ *
+ *	Implements [info class call $clsName $methodName]
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+InfoClassCallCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    Class *clsPtr;
+    CallChain *callPtr;
+
+    if (objc != 3) {
+	Tcl_WrongNumArgs(interp, 1, objv, "className methodName");
+	return TCL_ERROR;
+    }
+    clsPtr = GetClassFromObj(interp, objv[1]);
+    if (clsPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Get an render the stereotypical call chain.
+     */
+
+    callPtr = TclOOGetStereotypeCallChain(clsPtr, objv[2], PUBLIC_METHOD);
+    if (callPtr == NULL) {
+	Tcl_AppendResult(interp, "cannot construct any call chain", NULL);
+	return TCL_ERROR;
+    }
+    Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index bd32f22..b151183 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -465,6 +465,9 @@ MODULE_SCOPE int	TclOOCopyObjectCmd(ClientData clientData,
 MODULE_SCOPE int	TclOONextObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
+MODULE_SCOPE int	TclOONextToObjCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOOSelfObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
@@ -518,6 +521,8 @@ MODULE_SCOPE void	TclOODelMethodRef(Method *method);
 MODULE_SCOPE CallContext *TclOOGetCallContext(Object *oPtr,
 			    Tcl_Obj *methodNameObj, int flags,
 			    Tcl_Obj *cacheInThisObj);
+MODULE_SCOPE CallChain *TclOOGetStereotypeCallChain(Class *clsPtr,
+			    Tcl_Obj *methodNameObj, int flags);
 MODULE_SCOPE Foundation	*TclOOGetFoundation(Tcl_Interp *interp);
 MODULE_SCOPE Tcl_Obj *	TclOOGetFwdFromMethod(Method *mPtr);
 MODULE_SCOPE Proc *	TclOOGetProcFromMethod(Method *mPtr);
@@ -544,6 +549,8 @@ MODULE_SCOPE void	TclOORemoveFromMixinSubs(Class *subPtr,
 			    Class *mixinPtr);
 MODULE_SCOPE void	TclOORemoveFromSubclasses(Class *subPtr,
 			    Class *superPtr);
+MODULE_SCOPE Tcl_Obj *	TclOORenderCallChain(Tcl_Interp *interp,
+			    CallChain *callPtr);
 MODULE_SCOPE void	TclOOStashContext(Tcl_Obj *objPtr,
 			    CallContext *contextPtr);
 MODULE_SCOPE void	TclOOSetupVariableResolver(Tcl_Namespace *nsPtr);
diff --git a/tests/oo.test b/tests/oo.test
index 60d0077..078d888 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1524,7 +1524,7 @@ test oo-16.2 {OO: object introspection} -body {
 } -returnCodes 1 -result {NOTANOBJECT does not refer to an object}
 test oo-16.3 {OO: object introspection} -body {
     info object gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, class, definition, filters, forward, isa, methods, methodtype, mixins, namespace, variables, or vars}
 test oo-16.4 {OO: object introspection} -setup {
     oo::class create meta { superclass oo::class }
     [meta create instance1] create instance2
@@ -1646,7 +1646,7 @@ test oo-17.3 {OO: class introspection} -setup {
 } -result {"foo" is not a class}
 test oo-17.4 {OO: class introspection} -body {
     info class gorp oo::object
-} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
+} -returnCodes 1 -result {unknown or ambiguous subcommand "gorp": must be call, constructor, definition, destructor, filters, forward, instances, methods, methodtype, mixins, subclasses, superclasses, or variables}
 test oo-17.5 {OO: class introspection} -setup {
     oo::class create testClass
 } -body {
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
new file mode 100644
index 0000000..624a9d9
--- /dev/null
+++ b/tests/ooNext2.test
@@ -0,0 +1,765 @@
+# This file contains a collection of tests for Tcl's built-in object system.
+# Sourcing this file into Tcl runs the tests and generates output for errors.
+# No output means no errors were found.
+#
+# Copyright (c) 2006-2008 Donal K. Fellows
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+#
+# RCS: @(#) $Id: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $
+
+package require -exact TclOO 0.6.2 ;# Must match value in configure.in
+if {[lsearch [namespace children] ::tcltest] == -1} {
+    package require tcltest 2
+    namespace import -force ::tcltest::*
+}
+
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+    proc getbytes {} {
+	set lines [split [memory info] \n]
+	return [lindex $lines 3 3]
+    }
+    proc leaktest {script {iterations 3}} {
+	set end [getbytes]
+	for {set i 0} {$i < $iterations} {incr i} {
+	    uplevel 1 $script
+	    set tmp $end
+	    set end [getbytes]
+	}
+	return [expr {$end - $tmp}]
+    }
+}
+
+test oo-nextto-1.1 {basic nextto functionality} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x args {
+	    lappend ::result ==A== $args
+	}
+    }
+    oo::class create B {
+	superclass A
+	method x args {
+	    lappend ::result ==B== $args
+	    nextto A B -> A {*}$args
+	}
+    }
+    oo::class create C {
+	superclass A
+	method x args {
+	    lappend ::result ==C== $args
+	    nextto A C -> A {*}$args
+	}
+    }
+    oo::class create D {
+	superclass B C
+	method x args {
+	    lappend ::result ==D== $args
+	    next foo
+	    nextto C bar
+	}
+    }
+    set ::result {}
+    [D new] x
+    return $::result
+} -cleanup {
+    root destroy
+} -result {==D== {} ==B== foo ==A== {B -> A foo} ==C== bar ==A== {C -> A bar}}
+test oo-nextto-1.2 {basic nextto functionality} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x args {
+	    lappend ::result ==A== $args
+	}
+    }
+    oo::class create B {
+	superclass A
+	method x args {
+	    lappend ::result ==B== $args
+	    nextto A B -> A {*}$args
+	}
+    }
+    oo::class create C {
+	superclass A
+	method x args {
+	    lappend ::result ==C== $args
+	    nextto A C -> A {*}$args
+	}
+    }
+    oo::class create D {
+	superclass B C
+	method x args {
+	    lappend ::result ==D== $args
+	    nextto B foo {*}$args
+	    nextto C bar {*}$args
+	}
+    }
+    set ::result {}
+    [D new] x 123
+    return $::result
+} -cleanup {
+    root destroy
+} -result {==D== 123 ==B== {foo 123} ==A== {B -> A foo 123} ==C== {bar 123} ==A== {C -> A bar 123}}
+test oo-nextto-1.3 {basic nextto functionality: constructors} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	variable result
+	constructor {a c} {
+	    lappend result ==A== a=$a,c=$c
+	}
+    }
+    oo::class create B {
+	superclass root
+	variable result
+	constructor {b} {
+	    lappend result ==B== b=$b
+	}
+    }
+    oo::class create C {
+	superclass A B
+	variable result
+	constructor {p q r} {
+	    lappend result ==C== p=$p,q=$q,r=$r
+	    # Route arguments to superclasses, in non-trival pattern
+	    nextto B $q
+	    nextto A $p $r
+	}
+	method result {} {return $result}
+    }
+    [C new x y z] result
+} -cleanup {
+    root destroy
+} -result {==C== p=x,q=y,r=z ==B== b=y ==A== a=x,c=z}
+test oo-nextto-1.4 {basic nextto functionality: destructors} -setup {
+    oo::class create root {destructor return}
+} -body {
+    oo::class create A {
+	superclass root
+	destructor {
+	    lappend ::result ==A==
+	    next
+	}
+    }
+    oo::class create B {
+	superclass root
+	destructor {
+	    lappend ::result ==B==
+	    next
+	}
+    }
+    oo::class create C {
+	superclass A B
+	destructor {
+	    lappend ::result ==C==
+	    lappend ::result |
+	    nextto B
+	    lappend ::result |
+	    nextto A
+	    lappend ::result |
+	    next
+	}
+    }
+    set ::result ""
+    [C new] destroy
+    return $::result
+} -cleanup {
+    root destroy
+} -result {==C== | ==B== | ==A== ==B== | ==A== ==B==}
+
+test oo-nextto-2.1 {errors in nextto} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x y {error $y}
+    }
+    oo::class create B {
+	superclass A
+	method x y {nextto A $y}
+    }
+    [B new] x boom
+} -cleanup {
+    root destroy
+} -result boom -returnCodes error
+test oo-nextto-2.2 {errors in nextto} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x y {error $y}
+    }
+    oo::class create B {
+	superclass root
+	method x y {nextto A $y}
+    }
+    [B new] x boom
+} -returnCodes error -cleanup {
+    root destroy
+} -result {method has no non-filter implementation by "A"}
+test oo-nextto-2.3 {errors in nextto} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x y {nextto $y}
+    }
+    oo::class create B {
+	superclass A
+	method x y {nextto A $y}
+    }
+    [B new] x B
+} -returnCodes error -cleanup {
+    root destroy
+} -result {method implementation by "B" not reachable from here}
+test oo-nextto-2.4 {errors in nextto} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x y {nextto $y}
+    }
+    oo::class create B {
+	superclass A
+	method x y {nextto}
+    }
+    [B new] x B
+} -returnCodes error -cleanup {
+    root destroy
+} -result {wrong # args: should be "nextto class ?arg...?"}
+test oo-nextto-2.5 {errors in nextto} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x y {nextto $y}
+    }
+    oo::class create B {
+	superclass A
+	method x y {nextto $y $y $y}
+    }
+    [B new] x A
+} -cleanup {
+    root destroy
+} -result {wrong # args: should be "nextto A y"} -returnCodes error
+test oo-nextto-2.6 {errors in nextto} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x y {nextto $y}
+    }
+    oo::class create B {
+	superclass A
+	method x y {nextto $y $y $y}
+    }
+    [B new] x [root create notAClass]
+} -cleanup {
+    root destroy
+} -result {"::notAClass" is not a class} -returnCodes error
+test oo-nextto-2.7 {errors in nextto} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x y {nextto $y}
+    }
+    oo::class create B {
+	superclass A
+	filter Y
+	method Y args {next {*}$args}
+    }
+    oo::class create C {
+	superclass B
+	method x y {nextto $y $y $y}
+    }
+    [C new] x B
+} -returnCodes error -cleanup {
+    root destroy
+} -result {method has no non-filter implementation by "B"}
+
+test oo-call-1.1 {object call introspection} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    A create y
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{method x ::A method}}
+test oo-call-1.2 {object call introspection} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+    }
+    B create y
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{method x ::B method} {method x ::A method}}
+test oo-call-1.3 {object call introspection} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    A create y
+    oo::objdefine y method x {} {}
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{method x object method} {method x ::A method}}
+test oo-call-1.4 {object object call introspection - unknown} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    A create y
+    info object call y z
+} -cleanup {
+    root destroy
+} -result {{unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-1.5 {object call introspection - filters} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+	method y {} {}
+	filter y
+    }
+    A create y
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{filter y ::A method} {method x ::A method}}
+test oo-call-1.6 {object call introspection - filters} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+	method y {} {}
+	filter y
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+    }
+    B create y
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{filter y ::A method} {method x ::B method} {method x ::A method}}
+test oo-call-1.7 {object call introspection - filters} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+	method y {} {}
+	filter y
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+	method y {} {}
+    }
+    B create y
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
+test oo-call-1.8 {object call introspection - filters} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+	method y {} {}
+	filter y
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+	method y {} {}
+	method z {} {}
+	filter z
+    }
+    B create y
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method x ::B method} {method x ::A method}}
+test oo-call-1.9 {object call introspection - filters} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+	method y {} {}
+	filter y
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+	method y {} {}
+	method z {} {}
+	filter z
+    }
+    B create y
+    info object call y y
+} -cleanup {
+    root destroy
+} -result {{filter z ::B method} {filter y ::B method} {filter y ::A method} {method y ::B method} {method y ::A method}}
+test oo-call-1.10 {object call introspection - filters + unknown} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method y {} {}
+	filter y
+    }
+    oo::class create ::B {
+	superclass A
+	method y {} {}
+	method unknown {} {}
+    }
+    B create y
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{filter y ::B method} {filter y ::A method} {unknown unknown ::B method} {unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-1.11 {object call introspection - filters + unknown} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method y {} {}
+	filter y
+    }
+    A create y
+    oo::objdefine y method unknown {} {}
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-1.12 {object call introspection - filters + unknown} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method y {} {}
+    }
+    A create y
+    oo::objdefine y {
+	method unknown {} {}
+	filter y
+    }
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{filter y ::A method} {unknown unknown object method} {unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-1.13 {object call introspection - filters + unknown} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method y {} {}
+    }
+    A create y
+    oo::objdefine y {
+	method unknown {} {}
+	method x {} {}
+	filter y
+    }
+    info object call y x
+} -cleanup {
+    root destroy
+} -result {{filter y ::A method} {method x object method}}
+test oo-call-1.14 {object call introspection - errors} -body {
+    info object call
+} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
+test oo-call-1.15 {object call introspection - errors} -body {
+    info object call a
+} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
+test oo-call-1.16 {object call introspection - errors} -body {
+    info object call a b c
+} -returnCodes error -result {wrong # args: should be "info object call objName methodName"}
+test oo-call-1.17 {object call introspection - errors} -body {
+    info object call notanobject x
+} -returnCodes error -result {notanobject does not refer to an object}
+test oo-call-1.18 {object call introspection - memory leaks} -body {
+    leaktest {
+	info object call oo::object destroy
+    }
+} -constraints memory -result 0
+
+test oo-call-2.1 {class call introspection} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    info class call A x
+} -cleanup {
+    root destroy
+} -result {{method x ::A method}}
+test oo-call-2.2 {class call introspection} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+    }
+    list [info class call A x] [info class call B x]
+} -cleanup {
+    root destroy
+} -result {{{method x ::A method}} {{method x ::B method} {method x ::A method}}}
+test oo-call-2.3 {class call introspection} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+    }
+    oo::class create ::C {
+	superclass A
+	method x {} {}
+    }
+    oo::class create ::D {
+	superclass C B
+	method x {} {}
+    }
+    info class call D x
+} -cleanup {
+    root destroy
+} -result {{method x ::D method} {method x ::C method} {method x ::B method} {method x ::A method}}
+test oo-call-2.4 {class call introspection - mixin} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+    }
+    oo::class create ::C {
+	superclass A
+	method x {} {}
+    }
+    oo::class create ::D {
+	superclass C
+	mixin B
+	method x {} {}
+    }
+    info class call D x
+} -cleanup {
+    root destroy
+} -result {{method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
+test oo-call-2.5 {class call introspection - mixin + filter} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+	method y {} {}
+	filter y
+    }
+    oo::class create ::C {
+	superclass A
+	method x {} {}
+	method y {} {}
+    }
+    oo::class create ::D {
+	superclass C
+	mixin B
+	method x {} {}
+    }
+    info class call D x
+} -cleanup {
+    root destroy
+} -result {{filter y ::B method} {filter y ::C method} {method x ::B method} {method x ::D method} {method x ::C method} {method x ::A method}}
+test oo-call-2.6 {class call introspection - mixin + filter + unknown} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+	method unknown {} {}
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+	method y {} {}
+	filter y
+    }
+    oo::class create ::C {
+	superclass A
+	method x {} {}
+	method y {} {}
+    }
+    oo::class create ::D {
+	superclass C
+	mixin B
+	method x {} {}
+	method unknown {} {}
+    }
+    info class call D z
+} -cleanup {
+    root destroy
+} -result {{filter y ::B method} {filter y ::C method} {unknown unknown ::D method} {unknown unknown ::A method} {unknown unknown ::oo::object {core method: "unknown"}}}
+test oo-call-2.7 {class call introspection - mixin + filter + unknown} -setup {
+    oo::class create root
+} -body {
+    oo::class create ::A {
+	superclass root
+	method x {} {}
+    }
+    oo::class create ::B {
+	superclass A
+	method x {} {}
+	filter x
+    }
+    info class call B x
+} -cleanup {
+    root destroy
+} -result {{filter x ::B method} {filter x ::A method} {method x ::B method} {method x ::A method}}
+test oo-call-2.8 {class call introspection - errors} -body {
+    info class call
+} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
+test oo-call-2.9 {class call introspection - errors} -body {
+    info class call a
+} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
+test oo-call-2.10 {class call introspection - errors} -body {
+    info class call a b c
+} -returnCodes error -result {wrong # args: should be "info class call className methodName"}
+test oo-call-2.11 {class call introspection - errors} -body {
+    info class call notaclass x
+} -returnCodes error -result {notaclass does not refer to an object}
+test oo-call-2.11 {class call introspection - errors} -setup {
+    oo::class create root
+} -body {
+    root create notaclass
+    info class call notaclass x
+} -returnCodes error -cleanup {
+    root destroy
+} -result {"notaclass" is not a class}
+test oo-call-2.13 {class call introspection - memory leaks} -body {
+    leaktest {
+	info class call oo::class destroy
+    }
+} -constraints memory -result 0
+
+test oo-call-3.1 {current call introspection} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	method x {} {lappend ::result [self call]}
+    }
+    oo::class create B {
+	superclass A
+	method x {} {lappend ::result [self call];next}
+    }
+    B create y
+    oo::objdefine y method x {} {lappend ::result [self call];next}
+    set ::result {}
+    y x
+} -cleanup {
+    root destroy
+} -result {{{{method x object method} {method x ::B method} {method x ::A method}} 0} {{{method x object method} {method x ::B method} {method x ::A method}} 1} {{{method x object method} {method x ::B method} {method x ::A method}} 2}}
+test oo-call-3.2 {current call introspection} -setup {
+    oo::class create root
+} -constraints memory -body {
+    oo::class create A {
+	superclass root
+	method x {} {self call}
+    }
+    oo::class create B {
+	superclass A
+	method x {} {self call;next}
+    }
+    B create y
+    oo::objdefine y method x {} {self call;next}
+    leaktest {
+	y x
+    }
+} -cleanup {
+    root destroy
+} -result 0
+test oo-call-3.3 {current call introspection: in constructors} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	constructor {} {lappend ::result [self call]}
+    }
+    oo::class create B {
+	superclass A
+	constructor {} {lappend ::result [self call]; next}
+    }
+    set ::result {}
+    [B new] destroy
+    return $::result
+} -cleanup {
+    root destroy
+} -result {{{{method <constructor> ::B method} {method <constructor> ::A method}} 0} {{{method <constructor> ::B method} {method <constructor> ::A method}} 1}}
+test oo-call-3.4 {current call introspection: in destructors} -setup {
+    oo::class create root
+} -body {
+    oo::class create A {
+	superclass root
+	destructor {lappend ::result [self call]}
+    }
+    oo::class create B {
+	superclass A
+	destructor {lappend ::result [self call]; next}
+    }
+    set ::result {}
+    [B new] destroy
+    return $::result
+} -cleanup {
+    root destroy
+} -result {{{{method <destructor> ::B method} {method <destructor> ::A method}} 0} {{{method <destructor> ::B method} {method <destructor> ::A method}} 1}}
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# End:
-- 
cgit v0.12


From de8bdfc20fd21d16aa5e73fa0fb0ed8c88a2d18d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 25 May 2011 13:40:44 +0000
Subject: Bump TclOO version.

---
 ChangeLog           | 2 ++
 generic/tclOO.h     | 2 +-
 tests/oo.test       | 2 +-
 tests/ooNext2.test  | 2 +-
 unix/tclooConfig.sh | 2 +-
 win/tclooConfig.sh  | 2 +-
 6 files changed, 7 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 3118f82..6c90987 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,7 @@
 2011-05-25  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclOO.h (TCLOO_VERSION): Bump version.
+
 	IMPLEMENTATION OF TIP#381.
 
 	* doc/next.n, doc/ooInfo.n, doc/self.n, generic/tclOO.c,
diff --git a/generic/tclOO.h b/generic/tclOO.h
index ed70c08..c791930 100644
--- a/generic/tclOO.h
+++ b/generic/tclOO.h
@@ -24,7 +24,7 @@
  * win/tclooConfig.sh
  */
 
-#define TCLOO_VERSION "0.6.2"
+#define TCLOO_VERSION "0.6.3"
 #define TCLOO_PATCHLEVEL TCLOO_VERSION
 
 /*
diff --git a/tests/oo.test b/tests/oo.test
index 078d888..e8f770c 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -7,7 +7,7 @@
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-package require -exact TclOO 0.6.2 ;# Must match value in generic/tclOO.h
+package require -exact TclOO 0.6.3 ;# Must match value in generic/tclOO.h
 package require tcltest 2
 if {"::tcltest" in [namespace children]} {
     namespace import -force ::tcltest::*
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index 624a9d9..fc0423f 100644
--- a/tests/ooNext2.test
+++ b/tests/ooNext2.test
@@ -9,7 +9,7 @@
 #
 # RCS: @(#) $Id: oo.test,v 1.59 2011/01/18 16:10:48 dkf Exp $
 
-package require -exact TclOO 0.6.2 ;# Must match value in configure.in
+package require -exact TclOO 0.6.3 ;# Must match value in configure.in
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
     namespace import -force ::tcltest::*
diff --git a/unix/tclooConfig.sh b/unix/tclooConfig.sh
index 07fb45b..68de106 100644
--- a/unix/tclooConfig.sh
+++ b/unix/tclooConfig.sh
@@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC=""
 TCLOO_INCLUDE_SPEC=""
 TCLOO_PRIVATE_INCLUDE_SPEC=""
 TCLOO_CFLAGS=-DUSE_TCLOO_STUBS
-TCLOO_VERSION=0.6.2
+TCLOO_VERSION=0.6.3
diff --git a/win/tclooConfig.sh b/win/tclooConfig.sh
index 07fb45b..68de106 100644
--- a/win/tclooConfig.sh
+++ b/win/tclooConfig.sh
@@ -16,4 +16,4 @@ TCLOO_STUB_LIB_SPEC=""
 TCLOO_INCLUDE_SPEC=""
 TCLOO_PRIVATE_INCLUDE_SPEC=""
 TCLOO_CFLAGS=-DUSE_TCLOO_STUBS
-TCLOO_VERSION=0.6.2
+TCLOO_VERSION=0.6.3
-- 
cgit v0.12


From ba5939ea3bf47fc00db9172391b3d68e24539921 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Fri, 27 May 2011 17:50:38 +0000
Subject: fix a timing issue in socket-12.3

---
 tests/socket.test | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/tests/socket.test b/tests/socket.test
index f1acedc..83bad09 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1610,7 +1610,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
     # If the socket is still open after 5 seconds, the script1 process must
     # have inherited the accepted socket.
     set failed 0
-    after 5000 set failed 1
+    set after [after 5000 [list set failed 1]]
     proc getdata { file } {
 	# Read handler on the client socket.
 	global x
@@ -1637,6 +1637,7 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
     vwait x
     return $x
 } -cleanup {
+    after cancel $after
     catch {close $p}
 } -result {accepted socket was not inherited}
 
-- 
cgit v0.12


From 19755ae8971d97cfc092add10ceed6ab40f011bd Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Fri, 27 May 2011 18:36:26 +0000
Subject: Fix [socket -async] for DNS names with more than one address

---
 ChangeLog          |   8 ++
 tests/socket.test  |  22 +++++
 unix/tclUnixSock.c | 231 ++++++++++++++++++++++++++++++-----------------------
 3 files changed, 163 insertions(+), 98 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5c4c72a..f7b11cc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2011-05-27  Reinhard Max  <max@suse.de>
+
+	* unix/tclUnixSock.c: Fix [socket -async], so that all addresses
+	returned by getaddrinfo() are tried, not just the first one. This
+	requires the event loop to be running while the async connection
+	is in progress. ***POTENTIAL INCOMPATIBILITY***
+	* tests/socket.test: Add a test for the above.
+
 2011-05-25  Don Porter  <dgp@users.sourceforge.net>
 
 	* library/msgcat/msgcat.tcl:	Bump to msgcat 1.4.4.
diff --git a/tests/socket.test b/tests/socket.test
index 83bad09..1bb9b79 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1699,6 +1699,28 @@ if {$remoteProcChan ne ""} {
 catch {close $commandSocket}
 catch {close $remoteProcChan}
 }
+unset ::tcl::unsupported::socketAF
+test socket-14.0 {async when server only listens on one address family} \
+    -constraints [list socket supported_any] \
+    -setup {
+        proc accept {s a p} {
+            global x
+            puts $s bye
+            close $s
+            set x ok
+        }
+        set server [socket -server accept -myaddr 127.0.0.1 0]
+        set port [lindex [fconfigure $server -sockname] 2]
+    } -body {
+        set client [socket -async localhost $port]
+        # fileevent $client readable [list set x [fconfigure $client -error]]
+        after 1000 {set x [fconfigure $client -error]}
+        vwait x
+        set x
+    } -cleanup {
+        close $server
+        close $client
+    } -result ok
 ::tcltest::cleanupTests
 flush stdout
 return
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index cb72759..f6a1bf2 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -49,9 +49,22 @@ struct TcpState {
     TcpFdList *fds;		/* The file descriptors of the sockets. */
     int flags;			/* ORed combination of the bitfields defined
 				 * below. */
-    Tcl_TcpAcceptProc *acceptProc;
+    union {
+        struct {
+            /* Only needed for server sockets */
+            Tcl_TcpAcceptProc *acceptProc;
 				/* Proc to call on accept. */
-    ClientData acceptProcData;	/* The data for the accept proc. */
+            ClientData acceptProcData;
+				/* The data for the accept proc. */
+        };
+        struct {
+            /* Only needed for client sockets */
+            struct addrinfo *addrlist;
+            struct addrinfo *myaddrlist;
+            struct addrinfo *addr;
+            struct addrinfo *myaddr;
+        };
+    };
 };
 
 /*
@@ -89,9 +102,8 @@ struct TcpState {
  * Static routines for this file:
  */
 
-static TcpState *	CreateClientSocket(Tcl_Interp *interp, int port,
-			    const char *host, const char *myaddr,
-			    int myport, int async);
+static int		CreateClientSocket(Tcl_Interp *interp,
+                                           TcpState *state);
 static void		TcpAccept(ClientData data, int mask);
 static int		TcpBlockModeProc(ClientData data, int mode);
 static int		TcpCloseProc(ClientData instanceData,
@@ -829,17 +841,27 @@ TcpGetHandleProc(
     return TCL_OK;
 }
 
+static void
+TcpAsyncCallback(
+    ClientData clientData,	/* The socket state. */
+    int mask)			/* Events of interest; an OR-ed combination of
+				 * TCL_READABLE, TCL_WRITABLE and
+				 * TCL_EXCEPTION. */
+{
+    CreateClientSocket(NULL, clientData);
+}
+
 /*
  *----------------------------------------------------------------------
  *
- * CreateSocket --
+ * CreateClientSocket --
  *
- *	This function opens a new socket in client or server mode and
- *	initializes the TcpState structure.
+ *	This function opens a new socket in client mode.
  *
  * Results:
- *	Returns a new TcpState, or NULL with an error in the interp's result,
- *	if interp is not NULL.
+ *      TCL_OK, if the socket was successfully connected or an asynchronous
+ *      connection is in progress. If an error occurs, TCL_ERROR is returned
+ *      and an error message is left in interp.
  *
  * Side effects:
  *	Opens a socket.
@@ -847,37 +869,22 @@ TcpGetHandleProc(
  *----------------------------------------------------------------------
  */
 
-static TcpState *
+static int
 CreateClientSocket(
     Tcl_Interp *interp,		/* For error reporting; can be NULL. */
-    int port,			/* Port number to open. */
-    const char *host,		/* Name of host on which to open port. */
-    const char *myaddr,		/* Optional client-side address.
-                                 * NULL implies INADDR_ANY/in6addr_any */
-    int myport,			/* Optional client-side port */
-    int async)			/* If nonzero and creating a client socket,
-				 * attempt to do an async connect. Otherwise
-				 * do a synchronous connect or bind. */
+    TcpState *state)
 {
-    int status = -1, connected = 0, sock = -1;
-    struct addrinfo *addrlist = NULL, *addrPtr;
-                                /* Socket address */
-    struct addrinfo *myaddrlist = NULL, *myaddrPtr;
-                                /* Socket address for client */
-    TcpState *statePtr;
-    const char *errorMsg = NULL;
+    int status = -1, connected = 0;
+    int async = state->flags & TCP_ASYNC_CONNECT;
 
-    if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)) {
-	goto error;
+    if (state->addr != NULL) {
+        goto coro_continue;
     }
-    if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) {
-	goto error;
-    }
-
-    for (addrPtr = addrlist; addrPtr != NULL;
-         addrPtr = addrPtr->ai_next) {
-        for (myaddrPtr = myaddrlist; myaddrPtr != NULL;
-             myaddrPtr = myaddrPtr->ai_next) {
+    
+    for (state->addr = state->addrlist; state->addr != NULL;
+         state->addr = state->addr->ai_next) {
+        for (state->myaddr = state->myaddrlist; state->myaddr != NULL;
+             state->myaddr = state->myaddr->ai_next) {
             int reuseaddr;
             
 	    /*
@@ -885,12 +892,12 @@ CreateClientSocket(
 	     * different families.
 	     */
 
-	    if (myaddrPtr->ai_family != addrPtr->ai_family) {
+	    if (state->myaddr->ai_family != state->addr->ai_family) {
 		continue;
 	    }
 
-	    sock = socket(addrPtr->ai_family, SOCK_STREAM, 0);
-	    if (sock < 0) {
+	    state->fds->fd = socket(state->addr->ai_family, SOCK_STREAM, 0);
+	    if (state->fds->fd < 0) {
 		continue;
 	    }
 
@@ -899,25 +906,26 @@ CreateClientSocket(
 	     * inherited by child processes.
 	     */
 	    
-	    fcntl(sock, F_SETFD, FD_CLOEXEC);
+	    fcntl(state->fds->fd, F_SETFD, FD_CLOEXEC);
 	    
 	    /*
 	     * Set kernel space buffering
 	     */
 	    
-	    TclSockMinimumBuffers(INT2PTR(sock), SOCKET_BUFSIZE);
+	    TclSockMinimumBuffers(INT2PTR(state->fds->fd), SOCKET_BUFSIZE);
     
 	    if (async) {
-		status = TclUnixSetBlockingMode(sock, TCL_MODE_NONBLOCKING);
+		status = TclUnixSetBlockingMode(state->fds->fd, TCL_MODE_NONBLOCKING);
 		if (status < 0) {
 		    goto looperror;
 		}
 	    }
 
             reuseaddr = 1;
-            (void) setsockopt(sock, SOL_SOCKET, SO_REUSEADDR,
+            (void) setsockopt(state->fds->fd, SOL_SOCKET, SO_REUSEADDR,
                     (char *) &reuseaddr, sizeof(reuseaddr));
-            status = bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen);
+            status = bind(state->fds->fd, state->myaddr->ai_addr,
+                          state->myaddr->ai_addrlen);
             if (status < 0) {
                 goto looperror;
             }
@@ -929,27 +937,39 @@ CreateClientSocket(
 	     * in being informed when the connect completes.
 	     */
 	    
-	    status = connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen);
+	    status = connect(state->fds->fd, state->addr->ai_addr,
+                             state->addr->ai_addrlen);
 	    if (status < 0 && errno == EINPROGRESS) {
-		status = 0;
-	    }
+                Tcl_CreateFileHandler(state->fds->fd, TCL_WRITABLE,
+                                      TcpAsyncCallback, state);
+                // fprintf(stderr, "here: %d \n", state->fds->fd);
+                return TCL_OK;
+            coro_continue:
+                do {
+                    socklen_t optlen = sizeof(int);
+                    Tcl_DeleteFileHandler(state->fds->fd);
+                    getsockopt(state->fds->fd, SOL_SOCKET, SO_ERROR,
+                               (char *)&status, &optlen);             
+                    // fprintf(stderr, "there: %d \n", state->fds->fd);
+                } while (0);
+            }
 	    if (status == 0) {
 		connected = 1;
 		break;
 	    }
 	looperror:
-	    if (sock != -1) {
-		close(sock);
-		sock = -1;
+	    if (state->fds->fd != -1) {
+		close(state->fds->fd);
+		state->fds->fd = -1;
 	    }
 	}
 	if (connected) {
 	    break;
 	} 
 	status = -1;
-	if (sock >= 0) {
-	    close(sock);
-	    sock = -1;
+	if (state->fds->fd >= 0) {
+	    close(state->fds->fd);
+	    state->fds->fd = -1;
 	}
     }
     if (async) {
@@ -957,42 +977,25 @@ CreateClientSocket(
 	 * Restore blocking mode.
 	 */
 
-	status = TclUnixSetBlockingMode(sock, TCL_MODE_BLOCKING);
+	status = TclUnixSetBlockingMode(state->fds->fd, TCL_MODE_BLOCKING);
     }
 
-error:
-    if (addrlist) {
-	freeaddrinfo(addrlist);
-    }
-    if (myaddrlist) {
-	freeaddrinfo(myaddrlist);
-    }
-    
-    if (status < 0) {
-	if (interp != NULL) {
+    freeaddrinfo(state->addrlist);
+    freeaddrinfo(state->myaddrlist);
+
+    if (status < 0 && !async) {
+        if (interp != NULL) {
 	    Tcl_AppendResult(interp, "couldn't open socket: ",
-		    Tcl_PosixError(interp), NULL);
-	    if (errorMsg != NULL) {
-		Tcl_AppendResult(interp, " (", errorMsg, ")", NULL);
-	    }
+                             Tcl_PosixError(interp), NULL);
 	}
-	if (sock != -1) {
-	    close(sock);
+	if (state->fds->fd != -1) {
+	    close(state->fds->fd);
 	}
-	return NULL;
+        ckfree(state->fds);
+        ckfree(state);
+	return TCL_ERROR;
     }
-
-    /*
-     * Allocate a new TcpState for this socket.
-     */
-
-    statePtr = ckalloc(sizeof(TcpState));
-    statePtr->flags = async ? TCP_ASYNC_CONNECT : 0;
-    statePtr->fds = ckalloc(sizeof(TcpFdList));
-    memset(statePtr->fds, (int) 0, sizeof(TcpFdList));
-    statePtr->fds->fd = sock;
-
-    return statePtr;
+    return TCL_OK;
 }
 
 /*
@@ -1023,31 +1026,63 @@ Tcl_OpenTcpClient(
 				 * connect. Otherwise we do a blocking
 				 * connect. */
 {
-    TcpState *statePtr;
-    char channelName[16 + TCL_INTEGER_SPACE];
+    TcpState *state;
+    const char *errorMsg = NULL;
+    struct addrinfo *addrlist, *myaddrlist;
+    char channelName[4+16+1];	/* "sock" + up to 16 hex chars + \0 */
+
 
     /*
-     * Create a new client socket and wrap it in a channel.
+     * Do the name lookups for the local and remote addresses.
      */
-
-    statePtr = CreateClientSocket(interp, port, host, myaddr, myport, async);
-    if (statePtr == NULL) {
-	return NULL;
+    if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)) {
+	goto error;
+    }
+    if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
+                                &errorMsg)) {
+        freeaddrinfo(addrlist);
+        goto error;
     }
 
-    statePtr->acceptProc = NULL;
-    statePtr->acceptProcData = NULL;
+    /*
+     * Allocate a new TcpState for this socket.
+     */
+    state = ckalloc(sizeof(TcpState));
+    memset(state, 0, sizeof(TcpState));
+    state->flags = async ? TCP_ASYNC_CONNECT : 0;
+    state->addrlist = addrlist;
+    state->myaddrlist = myaddrlist;
+    state->fds = ckalloc(sizeof(TcpFdList));
+    memset(state->fds, (int) 0, sizeof(TcpFdList));
+    state->fds->fd = -1;
 
-    sprintf(channelName, "sock%d", statePtr->fds->fd);
+    /*
+     * Create a new client socket and wrap it in a channel.
+     */
+    if (CreateClientSocket(interp, state) != TCL_OK) {
+        goto error;
+    }
 
-    statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
-	    statePtr, (TCL_READABLE | TCL_WRITABLE));
-    if (Tcl_SetChannelOption(interp, statePtr->channel, "-translation",
+    sprintf(channelName, "sock%lx", (long)state);
+
+    state->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
+                                       state, (TCL_READABLE | TCL_WRITABLE));
+    if (Tcl_SetChannelOption(interp, state->channel, "-translation",
 	    "auto crlf") == TCL_ERROR) {
-	Tcl_Close(NULL, statePtr->channel);
+	Tcl_Close(NULL, state->channel);
 	return NULL;
     }
-    return statePtr->channel;
+    return state->channel;
+
+error:
+    if (interp != NULL) {
+        Tcl_AppendResult(interp, "couldn't open socket: ",
+                         Tcl_PosixError(interp), NULL);
+        if (errorMsg != NULL) {
+            Tcl_AppendResult(interp, " (", errorMsg, ")", NULL);
+        }
+    }
+    return NULL;
 }
 
 /*
-- 
cgit v0.12


From 2f67cb7c57ed82cb80c4e9a3905850869b9c63c4 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Mon, 30 May 2011 18:04:42 +0000
Subject:   *  Fix setting up of [fileevent] while an async socket is still in
 progress   *  Cache async socket errors for later use by [fconfigure -error] 
  *  Add tests for the above

---
 tests/socket.test  |  39 +++++++++++++++++++--
 unix/tclUnixSock.c | 101 +++++++++++++++++++++++++++++++----------------------
 2 files changed, 96 insertions(+), 44 deletions(-)

diff --git a/tests/socket.test b/tests/socket.test
index 1bb9b79..dd57a3d 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1700,7 +1700,7 @@ catch {close $commandSocket}
 catch {close $remoteProcChan}
 }
 unset ::tcl::unsupported::socketAF
-test socket-14.0 {async when server only listens on one address family} \
+test socket-14.0 {[socket -async] when server only listens on one address family} \
     -constraints [list socket supported_any] \
     -setup {
         proc accept {s a p} {
@@ -1713,7 +1713,6 @@ test socket-14.0 {async when server only listens on one address family} \
         set port [lindex [fconfigure $server -sockname] 2]
     } -body {
         set client [socket -async localhost $port]
-        # fileevent $client readable [list set x [fconfigure $client -error]]
         after 1000 {set x [fconfigure $client -error]}
         vwait x
         set x
@@ -1721,6 +1720,42 @@ test socket-14.0 {async when server only listens on one address family} \
         close $server
         close $client
     } -result ok
+test socket-14.1 {[socket -async] fileevent while still connecting} \
+    -constraints [list socket supported_any] \
+    -setup {
+        proc accept {s a p} {
+            global x
+            puts $s bye
+            close $s
+            set x ok
+        }
+        set server [socket -server accept -myaddr 127.0.0.1 2222]
+        set port [lindex [fconfigure $server -sockname] 2]
+    } -body {
+        set client [socket -async localhost $port]
+        fileevent $client readable {lappend x [fconfigure $client -error]}
+        set after [after 1000 {set x timeout}]
+        vwait x
+        vwait x
+        set x
+    } -cleanup {
+        after cancel $after
+        close $server
+        close $client
+    } -result {ok {}}
+test socket-14.2 {[socket -async] fileevent connection refused} \
+    -constraints [list socket supported_any] \
+    -body {
+        set client [socket -async localhost 0]
+        fileevent $client readable {set x [fconfigure $client -error]}
+        set after [after 1000 {set x timeout}]
+        vwait x
+        set x
+    } -cleanup {
+        after cancel $after
+        close $client
+    } -result "connection refused"
+
 ::tcltest::cleanupTests
 flush stdout
 return
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index f6a1bf2..823942a 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -58,11 +58,16 @@ struct TcpState {
 				/* The data for the accept proc. */
         };
         struct {
-            /* Only needed for client sockets */
-            struct addrinfo *addrlist;
-            struct addrinfo *myaddrlist;
-            struct addrinfo *addr;
-            struct addrinfo *myaddr;
+            /*
+             * Only needed for client sockets
+             */
+            struct addrinfo *addrlist;	/* addresses to connect to        */
+            struct addrinfo *addr;	/* iterator over addrlist         */
+            struct addrinfo *myaddrlist; /* local address                 */
+            struct addrinfo *myaddr;	/* iterator over myaddrlist       */
+            int filehandlers;	/* Caches FileHandlers that get set up while
+                                 * an async socket is not yet connected   */
+            int status;         /* Cache status of async socket */
         };
     };
 };
@@ -644,11 +649,16 @@ TcpGetOptionProc(
 	socklen_t optlen = sizeof(int);
 	int err, ret;
 
-	ret = getsockopt(statePtr->fds->fd, SOL_SOCKET, SO_ERROR,
-		(char *)&err, &optlen);
-	if (ret < 0) {
-	    err = errno;
-	}
+        if (statePtr->status == 0) {
+            ret = getsockopt(statePtr->fds->fd, SOL_SOCKET, SO_ERROR,
+                             (char *)&err, &optlen);
+            if (ret < 0) {
+                err = errno;
+            }
+        } else {
+            err = statePtr->status;
+            statePtr->status = 0;
+        }
 	if (err != 0) {
 	    Tcl_DStringAppend(dsPtr, Tcl_ErrnoMsg(err), -1);
 	}
@@ -797,16 +807,17 @@ TcpWatchProc(
 				 * TCL_EXCEPTION. */
 {
     TcpState *statePtr = (TcpState *) instanceData;
-    TcpFdList *fds;
-
-    for (fds = statePtr->fds; fds != NULL; fds = fds->next) {
-        if (mask) {
-            Tcl_CreateFileHandler(fds->fd, mask,
-                                  (Tcl_FileProc *) Tcl_NotifyChannel,
-                                  (ClientData) statePtr->channel);
-        } else {
-            Tcl_DeleteFileHandler(fds->fd);
-        }
+     
+    if (statePtr->flags & TCP_ASYNC_CONNECT) {
+        /* Async sockets use a FileHandler internally while connecting, so we
+         * need to cache this request until the connection has succeeded. */
+        statePtr->filehandlers = mask;
+    } else if (mask) {
+        Tcl_CreateFileHandler(statePtr->fds->fd, mask,
+                              (Tcl_FileProc *) Tcl_NotifyChannel,
+                              (ClientData) statePtr->channel);
+    } else {
+        Tcl_DeleteFileHandler(statePtr->fds->fd);
     }
 }
 
@@ -874,7 +885,7 @@ CreateClientSocket(
     Tcl_Interp *interp,		/* For error reporting; can be NULL. */
     TcpState *state)
 {
-    int status = -1, connected = 0;
+    int status, connected = 0;
     int async = state->flags & TCP_ASYNC_CONNECT;
 
     if (state->addr != NULL) {
@@ -883,6 +894,9 @@ CreateClientSocket(
     
     for (state->addr = state->addrlist; state->addr != NULL;
          state->addr = state->addr->ai_next) {
+
+	status = -1;
+
         for (state->myaddr = state->myaddrlist; state->myaddr != NULL;
              state->myaddr = state->myaddr->ai_next) {
             int reuseaddr;
@@ -896,6 +910,15 @@ CreateClientSocket(
 		continue;
 	    }
 
+            /*
+             * Close the socket if it is still open from the last unsuccessful
+             * iteration.
+             */
+            if (state->fds->fd >= 0) {
+		close(state->fds->fd);
+		state->fds->fd = -1;
+	    }
+
 	    state->fds->fd = socket(state->addr->ai_family, SOCK_STREAM, 0);
 	    if (state->fds->fd < 0) {
 		continue;
@@ -917,7 +940,7 @@ CreateClientSocket(
 	    if (async) {
 		status = TclUnixSetBlockingMode(state->fds->fd, TCL_MODE_NONBLOCKING);
 		if (status < 0) {
-		    goto looperror;
+                    continue;
 		}
 	    }
 
@@ -927,7 +950,7 @@ CreateClientSocket(
             status = bind(state->fds->fd, state->myaddr->ai_addr,
                           state->myaddr->ai_addrlen);
             if (status < 0) {
-                goto looperror;
+                continue;
             }
 
 	    /*
@@ -942,35 +965,24 @@ CreateClientSocket(
 	    if (status < 0 && errno == EINPROGRESS) {
                 Tcl_CreateFileHandler(state->fds->fd, TCL_WRITABLE,
                                       TcpAsyncCallback, state);
-                // fprintf(stderr, "here: %d \n", state->fds->fd);
                 return TCL_OK;
             coro_continue:
                 do {
                     socklen_t optlen = sizeof(int);
                     Tcl_DeleteFileHandler(state->fds->fd);
                     getsockopt(state->fds->fd, SOL_SOCKET, SO_ERROR,
-                               (char *)&status, &optlen);             
-                    // fprintf(stderr, "there: %d \n", state->fds->fd);
+                               (char *)&status, &optlen);
+                    state->status = status;
                 } while (0);
             }
 	    if (status == 0) {
 		connected = 1;
 		break;
 	    }
-	looperror:
-	    if (state->fds->fd != -1) {
-		close(state->fds->fd);
-		state->fds->fd = -1;
-	    }
 	}
 	if (connected) {
 	    break;
 	} 
-	status = -1;
-	if (state->fds->fd >= 0) {
-	    close(state->fds->fd);
-	    state->fds->fd = -1;
-	}
     }
     if (async) {
 	/*
@@ -983,7 +995,14 @@ CreateClientSocket(
     freeaddrinfo(state->addrlist);
     freeaddrinfo(state->myaddrlist);
 
-    if (status < 0 && !async) {
+    if (async) {
+        CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT);
+        if (state->filehandlers != 0) {
+            TcpWatchProc(state, state->filehandlers);
+        }
+        return TCL_OK;
+    }
+    if (status < 0) {
         if (interp != NULL) {
 	    Tcl_AppendResult(interp, "couldn't open socket: ",
                              Tcl_PosixError(interp), NULL);
@@ -1135,12 +1154,11 @@ TclpMakeTcpClientChannelMode(
     char channelName[16 + TCL_INTEGER_SPACE];
 
     statePtr = ckalloc(sizeof(TcpState));
+    memset(statePtr, 0, sizeof(TcpState));
     statePtr->fds = ckalloc(sizeof(TcpFdList));
     memset(statePtr->fds, (int) 0, sizeof(TcpFdList));
     statePtr->fds->fd = PTR2INT(sock);
     statePtr->flags = 0;
-    statePtr->acceptProc = NULL;
-    statePtr->acceptProcData = NULL;
 
     sprintf(channelName, "sock%d", statePtr->fds->fd);
 
@@ -1273,6 +1291,7 @@ Tcl_OpenTcpServer(
              */
             
             statePtr = ckalloc(sizeof(TcpState));
+            memset(statePtr, 0, sizeof(TcpState));
             statePtr->fds = newfds;
             statePtr->acceptProc = acceptProc;
             statePtr->acceptProcData = acceptProcData;
@@ -1358,13 +1377,11 @@ TcpAccept(
     (void) fcntl(newsock, F_SETFD, FD_CLOEXEC);
 
     newSockState = ckalloc(sizeof(TcpState));
-
+    memset(newSockState, 0, sizeof(TcpState));
     newSockState->flags = 0;
     newSockState->fds = ckalloc(sizeof(TcpFdList));
     memset(newSockState->fds, (int) 0, sizeof(TcpFdList));
     newSockState->fds->fd = newsock;
-    newSockState->acceptProc = NULL;
-    newSockState->acceptProcData = NULL;
 
     sprintf(channelName, "sock%d", newsock);
     newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
-- 
cgit v0.12


From b8ee85e7eb1b906ac79f4fae165c4e8cf0e9faf4 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Wed, 1 Jun 2011 15:30:28 +0000
Subject:   *  Improve socket.test by checking the latency on the loopback
 address and use that for some of the tests instead of fixed "big enough"
 times.   *  Improve correctness of [socket -async] in some error cases.

---
 tests/socket.test  | 37 ++++++++++++++++++++++++------
 unix/tclUnixSock.c | 66 +++++++++++++++++++++++++++---------------------------
 2 files changed, 63 insertions(+), 40 deletions(-)

diff --git a/tests/socket.test b/tests/socket.test
index dd57a3d..b121022 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -71,6 +71,23 @@ testConstraint exec [llength [info commands exec]]
 # from 49152 through 65535.
 proc randport {} { expr {int(rand()*16383+49152)} }
 
+# Test the latency of tcp connections over the loopback interface. Some OSes
+# (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes
+# up to 200ms for a packet sent to localhost to arrive. We're measuring this
+# here, so that OSes that don't have this problem can
+set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0]
+set s2 [socket localhost [lindex [fconfigure $server -sockname] 2]]
+vwait s1; close $server
+fconfigure $s1 -buffering line
+fconfigure $s2 -buffering line
+set t1 [clock milliseconds]
+puts $s2 test1; gets $s1
+puts $s2 test2; gets $s1
+close $s1; close $s2
+set t2 [clock milliseconds]
+set latency [expr {$t2-$t1}]
+unset t1 t2 s1 s2 server
+
 # If remoteServerIP or remoteServerPort are not set, check in the environment
 # variables for externally set values.
 #
@@ -584,7 +601,7 @@ test socket_$af-2.11 {detecting new data} -constraints [list socket supported_$a
     fconfigure $sock -blocking 1
     puts $s2 two
     flush $s2
-    after idle {set x 1}
+    after $latency {set x 1}; # NetBSD fails here if we do [after idle]
     vwait x
     fconfigure $sock -blocking 0
     lappend result c:[gets $sock]
@@ -1713,12 +1730,14 @@ test socket-14.0 {[socket -async] when server only listens on one address family
         set port [lindex [fconfigure $server -sockname] 2]
     } -body {
         set client [socket -async localhost $port]
-        after 1000 {set x [fconfigure $client -error]}
+        set after [after 1000 {set x [fconfigure $client -error]}]
         vwait x
         set x
     } -cleanup {
+        after cancel $after
         close $server
         close $client
+        unset x
     } -result ok
 test socket-14.1 {[socket -async] fileevent while still connecting} \
     -constraints [list socket supported_any] \
@@ -1727,13 +1746,15 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
             global x
             puts $s bye
             close $s
-            set x ok
+	    lappend x ok
         }
-        set server [socket -server accept -myaddr 127.0.0.1 2222]
+        set server [socket -server accept -myaddr 127.0.0.1 0]
         set port [lindex [fconfigure $server -sockname] 2]
     } -body {
         set client [socket -async localhost $port]
-        fileevent $client readable {lappend x [fconfigure $client -error]}
+        fileevent $client writable {
+            lappend x [expr {[fconfigure $client -error] eq ""}]
+        }
         set after [after 1000 {set x timeout}]
         vwait x
         vwait x
@@ -1742,18 +1763,20 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
         after cancel $after
         close $server
         close $client
-    } -result {ok {}}
+        unset x
+    } -result {ok 1}
 test socket-14.2 {[socket -async] fileevent connection refused} \
     -constraints [list socket supported_any] \
     -body {
         set client [socket -async localhost 0]
-        fileevent $client readable {set x [fconfigure $client -error]}
+        fileevent $client writable {set x [fconfigure $client -error]}
         set after [after 1000 {set x timeout}]
         vwait x
         set x
     } -cleanup {
         after cancel $after
         close $client
+        unset x
     } -result "connection refused"
 
 ::tcltest::cleanupTests
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 823942a..981162d 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -885,10 +885,12 @@ CreateClientSocket(
     Tcl_Interp *interp,		/* For error reporting; can be NULL. */
     TcpState *state)
 {
+    socklen_t optlen;
+    int in_coro = (state->addr != NULL);
     int status, connected = 0;
     int async = state->flags & TCP_ASYNC_CONNECT;
 
-    if (state->addr != NULL) {
+    if (in_coro) {
         goto coro_continue;
     }
     
@@ -966,53 +968,51 @@ CreateClientSocket(
                 Tcl_CreateFileHandler(state->fds->fd, TCL_WRITABLE,
                                       TcpAsyncCallback, state);
                 return TCL_OK;
+
             coro_continue:
-                do {
-                    socklen_t optlen = sizeof(int);
-                    Tcl_DeleteFileHandler(state->fds->fd);
-                    getsockopt(state->fds->fd, SOL_SOCKET, SO_ERROR,
-                               (char *)&status, &optlen);
-                    state->status = status;
-                } while (0);
+                Tcl_DeleteFileHandler(state->fds->fd);
+                /*
+                 * Read the error state from the socket, to see if the async
+                 * connection has succeeded or failed and store the status in
+                 * the socket state for later retrieval by [fconfigure -error]
+                 */
+                optlen = sizeof(int);
+                getsockopt(state->fds->fd, SOL_SOCKET, SO_ERROR,
+                           (char *)&status, &optlen);
+                state->status = status;
             }
 	    if (status == 0) {
-		connected = 1;
-		break;
+                goto out;
 	    }
 	}
-	if (connected) {
-	    break;
-	} 
     }
-    if (async) {
-	/*
-	 * Restore blocking mode.
-	 */
 
-	status = TclUnixSetBlockingMode(state->fds->fd, TCL_MODE_BLOCKING);
-    }
+out:
 
     freeaddrinfo(state->addrlist);
     freeaddrinfo(state->myaddrlist);
 
     if (async) {
         CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT);
-        if (state->filehandlers != 0) {
-            TcpWatchProc(state, state->filehandlers);
-        }
-        return TCL_OK;
+        TcpWatchProc(state, state->filehandlers);
+        TclUnixSetBlockingMode(state->fds->fd, TCL_MODE_BLOCKING);
     }
+
     if (status < 0) {
-        if (interp != NULL) {
-	    Tcl_AppendResult(interp, "couldn't open socket: ",
-                             Tcl_PosixError(interp), NULL);
-	}
-	if (state->fds->fd != -1) {
-	    close(state->fds->fd);
-	}
-        ckfree(state->fds);
-        ckfree(state);
-	return TCL_ERROR;
+        if (in_coro) {
+            Tcl_NotifyChannel(state->fds->fd, TCL_WRITABLE);
+        } else {
+            if (interp != NULL) {
+                Tcl_AppendResult(interp, "couldn't open socket: ",
+                                 Tcl_PosixError(interp), NULL);
+            }
+            if (state->fds->fd != -1) {
+                close(state->fds->fd);
+            }
+            ckfree(state->fds);
+            ckfree(state);
+            return TCL_ERROR;
+        }
     }
     return TCL_OK;
 }
-- 
cgit v0.12


From 63b8a6c10fc5f8568a7c9c87c170a564292b5002 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Wed, 1 Jun 2011 22:05:54 +0000
Subject: * generic/tclBasic.c: using the two free data elements in NRCommand
 to store objc and objv - useful for debugging.

---
 ChangeLog          | 5 +++++
 generic/tclBasic.c | 4 ++--
 2 files changed, 7 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 1cea3be..8291a08 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-06-01  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclBasic.c: using the two free data elements in
+	NRCommand to store objc and objv - useful for debugging.
+
 2011-06-01  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclUtil.c:   fix for [Bug 3309871]: Valgrind finds:
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d80731e..bce9684 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -4140,10 +4140,10 @@ TclNREvalObjv(
      */
 
     if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
-	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), NULL, NULL);
+	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), objc, objv);
 	iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
     } else {
-	TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL);
+	TclNRAddCallback(interp, NRCommand, NULL, NULL, objc, objv);
     }
     cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
 
-- 
cgit v0.12


From 0bd52c5044d5dc3e8e67ce0af9e97358e6f5107e Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Wed, 1 Jun 2011 22:09:28 +0000
Subject: missing INT2PTR in last commit

---
 generic/tclBasic.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index bce9684..f4e026f 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -4143,7 +4143,7 @@ TclNREvalObjv(
 	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), objc, objv);
 	iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
     } else {
-	TclNRAddCallback(interp, NRCommand, NULL, NULL, objc, objv);
+	TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);
     }
     cmdPtrPtr = (Command **) &(TOP_CB(interp)->data[0]);
 
-- 
cgit v0.12


From 9dacec2990cb68db16de2ce9045612678277ee79 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 6 Jun 2011 13:48:44 +0000
Subject: Add test constraint, so 6.2 and 6.3 don't fail when the machine does
 not have support for ip6 Follow-up to checkin from 2011-05-11 by rmax

---
 ChangeLog         | 6 ++++++
 tests/socket.test | 4 ++--
 2 files changed, 8 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b8f05ae..b645eb0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-06-06  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* tests/socket.test: Add test constraint, so 6.2 and
+	  6.3 don't fail when the machine does not have support
+	  for ip6. Follow-up to checkin from 2011-05-11 by rmax.
+
 2011-06-02  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclBasic.c:	Removed TclCleanupLiteralTable(), and old
diff --git a/tests/socket.test b/tests/socket.test
index 83bad09..4a9bcb9 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -804,7 +804,7 @@ test socket_$af-6.2 {
     readable fileevent on server socket
 } -setup {
     set sock [socket -server dummy 0]
-} -body {
+} -constraints [list socket supported_$af] -body {
     fileevent $sock readable dummy
 } -cleanup {
     close $sock
@@ -812,7 +812,7 @@ test socket_$af-6.2 {
 
 test socket_$af-6.3 {writable fileevent on server socket} -setup {
     set sock [socket -server dummy 0]
-} -body {
+} -constraints [list socket supported_$af] -body {
     fileevent $sock writable dummy
 } -cleanup {
     close $sock
-- 
cgit v0.12


From a7f1ab1afd109c2c02de573a66aaab15bfbdeab1 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Mon, 6 Jun 2011 15:07:23 +0000
Subject:   *  Don't use port 0 for test 14.2 as it fails in different ways on
 Linux and NetBSD.   *  Unify channel name creation.   *  Prevent error
 messages from appearing twice.   *  Double the measured latency in
 socket.test to be on the safe side.

---
 tests/socket.test  |  4 ++--
 unix/tclUnixSock.c | 59 +++++++++++++++++++++++++++---------------------------
 2 files changed, 31 insertions(+), 32 deletions(-)

diff --git a/tests/socket.test b/tests/socket.test
index b121022..39dc8de 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -85,7 +85,7 @@ puts $s2 test1; gets $s1
 puts $s2 test2; gets $s1
 close $s1; close $s2
 set t2 [clock milliseconds]
-set latency [expr {$t2-$t1}]
+set latency [expr {($t2-$t1)*2}]; # doubled as a safety margin
 unset t1 t2 s1 s2 server
 
 # If remoteServerIP or remoteServerPort are not set, check in the environment
@@ -1768,7 +1768,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
 test socket-14.2 {[socket -async] fileevent connection refused} \
     -constraints [list socket supported_any] \
     -body {
-        set client [socket -async localhost 0]
+        set client [socket -async localhost [randport]]
         fileevent $client writable {set x [fconfigure $client -error]}
         set after [after 1000 {set x timeout}]
         vwait x
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 981162d..0d6b1d0 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -20,6 +20,10 @@
 #define SET_BITS(var, bits)	((var) |= (bits))
 #define CLEAR_BITS(var, bits)	((var) &= ~(bits))
 
+/* "sock" + a pointer in hex + \0 */
+#define SOCK_CHAN_LENGTH 4 + sizeof(void*) * 2 + 1
+#define SOCK_TEMPLATE "sock%lx"
+
 /*
  * This is needed to comply with the strict aliasing rules of GCC, but it also
  * simplifies casting between the different sockaddr types.
@@ -887,7 +891,7 @@ CreateClientSocket(
 {
     socklen_t optlen;
     int in_coro = (state->addr != NULL);
-    int status, connected = 0;
+    int status;
     int async = state->flags & TCP_ASYNC_CONNECT;
 
     if (in_coro) {
@@ -1000,7 +1004,7 @@ out:
 
     if (status < 0) {
         if (in_coro) {
-            Tcl_NotifyChannel(state->fds->fd, TCL_WRITABLE);
+            Tcl_NotifyChannel(state->channel, TCL_WRITABLE);
         } else {
             if (interp != NULL) {
                 Tcl_AppendResult(interp, "couldn't open socket: ",
@@ -1047,20 +1051,25 @@ Tcl_OpenTcpClient(
 {
     TcpState *state;
     const char *errorMsg = NULL;
-    struct addrinfo *addrlist, *myaddrlist;
-    char channelName[4+16+1];	/* "sock" + up to 16 hex chars + \0 */
-
+    struct addrinfo *addrlist = NULL, *myaddrlist = NULL;
+    char channelName[SOCK_CHAN_LENGTH];
 
     /*
      * Do the name lookups for the local and remote addresses.
      */
-    if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg)) {
-	goto error;
-    }
-    if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
-                                &errorMsg)) {
-        freeaddrinfo(addrlist);
-        goto error;
+    if (!TclCreateSocketAddress(interp, &addrlist, host, port, 0, &errorMsg) ||
+        !TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) {
+        if (addrlist != NULL) {
+            freeaddrinfo(addrlist);
+        }
+        if (interp != NULL) {
+            Tcl_AppendResult(interp, "couldn't open socket: ",
+                             Tcl_PosixError(interp), NULL);
+            if (errorMsg != NULL) {
+                Tcl_AppendResult(interp, " (", errorMsg, ")", NULL);
+            }
+        }
+        return NULL;
     }
 
     /*
@@ -1079,10 +1088,10 @@ Tcl_OpenTcpClient(
      * Create a new client socket and wrap it in a channel.
      */
     if (CreateClientSocket(interp, state) != TCL_OK) {
-        goto error;
+        return NULL;
     }
 
-    sprintf(channelName, "sock%lx", (long)state);
+    sprintf(channelName, SOCK_TEMPLATE, (long)state);
 
     state->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
                                        state, (TCL_READABLE | TCL_WRITABLE));
@@ -1092,16 +1101,6 @@ Tcl_OpenTcpClient(
 	return NULL;
     }
     return state->channel;
-
-error:
-    if (interp != NULL) {
-        Tcl_AppendResult(interp, "couldn't open socket: ",
-                         Tcl_PosixError(interp), NULL);
-        if (errorMsg != NULL) {
-            Tcl_AppendResult(interp, " (", errorMsg, ")", NULL);
-        }
-    }
-    return NULL;
 }
 
 /*
@@ -1151,7 +1150,7 @@ TclpMakeTcpClientChannelMode(
 				 * TCL_WRITABLE to indicate file mode. */
 {
     TcpState *statePtr;
-    char channelName[16 + TCL_INTEGER_SPACE];
+    char channelName[SOCK_CHAN_LENGTH];
 
     statePtr = ckalloc(sizeof(TcpState));
     memset(statePtr, 0, sizeof(TcpState));
@@ -1160,7 +1159,7 @@ TclpMakeTcpClientChannelMode(
     statePtr->fds->fd = PTR2INT(sock);
     statePtr->flags = 0;
 
-    sprintf(channelName, "sock%d", statePtr->fds->fd);
+    sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
 
     statePtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
 	    statePtr, mode);
@@ -1202,7 +1201,7 @@ Tcl_OpenTcpServer(
     int status = 0, sock = -1, reuseaddr = 1, chosenport = 0;
     struct addrinfo *addrlist = NULL, *addrPtr;	/* socket address */
     TcpState *statePtr = NULL;
-    char channelName[16 + TCL_INTEGER_SPACE];
+    char channelName[SOCK_CHAN_LENGTH];
     const char *errorMsg = NULL;
     TcpFdList *fds = NULL, *newfds;
 
@@ -1295,7 +1294,7 @@ Tcl_OpenTcpServer(
             statePtr->fds = newfds;
             statePtr->acceptProc = acceptProc;
             statePtr->acceptProcData = acceptProcData;
-            sprintf(channelName, "sock%d", sock);
+            sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
         } else {
             fds->next = newfds;
         }
@@ -1360,7 +1359,7 @@ TcpAccept(
     TcpState *newSockState;	/* State for new socket. */
     address addr;		/* The remote address */
     socklen_t len;		/* For accept interface */
-    char channelName[16 + TCL_INTEGER_SPACE];
+    char channelName[SOCK_CHAN_LENGTH];
     char host[NI_MAXHOST], port[NI_MAXSERV];
     
     len = sizeof(addr);
@@ -1383,7 +1382,7 @@ TcpAccept(
     memset(newSockState->fds, (int) 0, sizeof(TcpFdList));
     newSockState->fds->fd = newsock;
 
-    sprintf(channelName, "sock%d", newsock);
+    sprintf(channelName, SOCK_TEMPLATE, (long)newSockState);
     newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
 	    newSockState, (TCL_READABLE | TCL_WRITABLE));
 
-- 
cgit v0.12


From cd37602cf4924672b4219fdf144d76e2cf773947 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Tue, 7 Jun 2011 12:53:13 +0000
Subject: Fix bug#3164655: getaddrinfo() crash on HP-UX

---
 generic/tclIOSock.c | 7 +++++--
 1 file changed, 5 insertions(+), 2 deletions(-)

diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index ab2b094..aabd67d 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -178,8 +178,11 @@ TclCreateSocketAddress(
     }
 
     hints.ai_socktype = SOCK_STREAM;
-#if defined(AI_ADDRCONFIG) && !defined(_AIX)
-    /* Missing on: OpenBSD, NetBSD.  Causes failure when used on AIX 5.1 */
+#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux)
+    /*
+     * Missing on: OpenBSD, NetBSD.
+     * Causes failure when used on AIX 5.1 and HP-UX
+     */
     hints.ai_flags |= AI_ADDRCONFIG;
 #endif
     if (willBind) {
-- 
cgit v0.12


From 938cb914fee8405b397ae0823e16444bc9eb7c0c Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Tue, 7 Jun 2011 14:31:59 +0000
Subject: Fix bug#3084338, a memleak when a [socket -async] was closed before
 the connection had succeeded or failed.

---
 unix/tclUnixSock.c | 51 ++++++++++++++++++++++-----------------------------
 1 file changed, 22 insertions(+), 29 deletions(-)

diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 0d6b1d0..39fb375 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -53,27 +53,21 @@ struct TcpState {
     TcpFdList *fds;		/* The file descriptors of the sockets. */
     int flags;			/* ORed combination of the bitfields defined
 				 * below. */
-    union {
-        struct {
-            /* Only needed for server sockets */
-            Tcl_TcpAcceptProc *acceptProc;
-				/* Proc to call on accept. */
-            ClientData acceptProcData;
-				/* The data for the accept proc. */
-        };
-        struct {
-            /*
-             * Only needed for client sockets
-             */
-            struct addrinfo *addrlist;	/* addresses to connect to        */
-            struct addrinfo *addr;	/* iterator over addrlist         */
-            struct addrinfo *myaddrlist; /* local address                 */
-            struct addrinfo *myaddr;	/* iterator over myaddrlist       */
-            int filehandlers;	/* Caches FileHandlers that get set up while
-                                 * an async socket is not yet connected   */
-            int status;         /* Cache status of async socket */
-        };
-    };
+    /*
+     * Only needed for server sockets
+     */
+    Tcl_TcpAcceptProc *acceptProc; /* Proc to call on accept. */
+    ClientData acceptProcData;     /* The data for the accept proc. */
+    /*
+     * Only needed for client sockets
+     */
+    struct addrinfo *addrlist;	 /* addresses to connect to        */
+    struct addrinfo *addr;	 /* iterator over addrlist         */
+    struct addrinfo *myaddrlist; /* local address                  */
+    struct addrinfo *myaddr;	 /* iterator over myaddrlist       */
+    int filehandlers;	/* Caches FileHandlers that get set up while
+                         * an async socket is not yet connected   */
+    int status;         /* Cache status of async socket */
 };
 
 /*
@@ -551,6 +545,12 @@ TcpCloseProc(
 	}
 	ckfree(fds);
     }
+    if (statePtr->addrlist != NULL) {
+        freeaddrinfo(statePtr->addrlist);
+    }
+    if (statePtr->myaddrlist != NULL) {
+        freeaddrinfo(statePtr->myaddrlist);
+    }
     ckfree(statePtr);
     return errorCode;
 }
@@ -993,9 +993,6 @@ CreateClientSocket(
 
 out:
 
-    freeaddrinfo(state->addrlist);
-    freeaddrinfo(state->myaddrlist);
-
     if (async) {
         CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT);
         TcpWatchProc(state, state->filehandlers);
@@ -1010,11 +1007,6 @@ out:
                 Tcl_AppendResult(interp, "couldn't open socket: ",
                                  Tcl_PosixError(interp), NULL);
             }
-            if (state->fds->fd != -1) {
-                close(state->fds->fd);
-            }
-            ckfree(state->fds);
-            ckfree(state);
             return TCL_ERROR;
         }
     }
@@ -1088,6 +1080,7 @@ Tcl_OpenTcpClient(
      * Create a new client socket and wrap it in a channel.
      */
     if (CreateClientSocket(interp, state) != TCL_OK) {
+        TcpCloseProc(state, NULL);
         return NULL;
     }
 
-- 
cgit v0.12


From f5123e0b70f74ddc3f0521870aa1c318aff0aef6 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Tue, 7 Jun 2011 14:59:54 +0000
Subject: Simplify file descriptor handling for client sockets and derived
 server sockets by putting an instance of TcpFdList into TcpState instead of
 just a pointer. Now only server sockets that listen on multiple addresses
 need the linked list of file descriptors.

---
 unix/tclUnixSock.c | 80 ++++++++++++++++++++++++++----------------------------
 1 file changed, 38 insertions(+), 42 deletions(-)

diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 39fb375..a883e8c 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -50,7 +50,7 @@ typedef struct TcpFdList {
 
 struct TcpState {
     Tcl_Channel channel;	/* Channel associated with this file. */
-    TcpFdList *fds;		/* The file descriptors of the sockets. */
+    TcpFdList fds;		/* The file descriptors of the sockets. */
     int flags;			/* ORed combination of the bitfields defined
 				 * below. */
     /*
@@ -348,7 +348,7 @@ TcpBlockModeProc(
     } else {
 	SET_BITS(statePtr->flags, TCP_ASYNC_SOCKET);
     }
-    if (TclUnixSetBlockingMode(statePtr->fds->fd, mode) < 0) {
+    if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) {
 	return errno;
     }
     return 0;
@@ -390,7 +390,7 @@ WaitForConnect(
 	    timeOut = -1;
 	}
 	errno = 0;
-	state = TclUnixWaitForFile(statePtr->fds->fd,
+	state = TclUnixWaitForFile(statePtr->fds.fd,
 		TCL_WRITABLE | TCL_EXCEPTION, timeOut);
 	if (state & TCL_EXCEPTION) {
 	    return -1;
@@ -443,7 +443,7 @@ TcpInputProc(
     if (WaitForConnect(statePtr, errorCodePtr) != 0) {
 	return -1;
     }
-    bytesRead = recv(statePtr->fds->fd, buf, (size_t) bufSize, 0);
+    bytesRead = recv(statePtr->fds.fd, buf, (size_t) bufSize, 0);
     if (bytesRead > -1) {
 	return bytesRead;
     }
@@ -493,7 +493,7 @@ TcpOutputProc(
     if (WaitForConnect(statePtr, errorCodePtr) != 0) {
 	return -1;
     }
-    written = send(statePtr->fds->fd, buf, (size_t) toWrite, 0);
+    written = send(statePtr->fds.fd, buf, (size_t) toWrite, 0);
     if (written > -1) {
 	return written;
     }
@@ -537,13 +537,15 @@ TcpCloseProc(
      * that called this function, so we do not have to delete them here.
      */
     
-    for (fds = statePtr->fds; fds != NULL; fds = statePtr->fds) {
-	statePtr->fds = fds->next;
+    for (fds = &statePtr->fds; fds != NULL; fds = fds->next) {
 	Tcl_DeleteFileHandler(fds->fd);
 	if (close(fds->fd) < 0) {
 	    errorCode = errno;
 	}
-	ckfree(fds);
+    
+    }
+    for (fds = statePtr->fds.next; fds != NULL; fds = fds->next) {
+        ckfree(fds);
     }
     if (statePtr->addrlist != NULL) {
         freeaddrinfo(statePtr->addrlist);
@@ -600,7 +602,7 @@ TcpClose2Proc(
         }
         return TCL_ERROR;
     }
-    if (shutdown(statePtr->fds->fd,sd) < 0) {
+    if (shutdown(statePtr->fds.fd,sd) < 0) {
 	errorCode = errno;
     }
 
@@ -654,7 +656,7 @@ TcpGetOptionProc(
 	int err, ret;
 
         if (statePtr->status == 0) {
-            ret = getsockopt(statePtr->fds->fd, SOL_SOCKET, SO_ERROR,
+            ret = getsockopt(statePtr->fds.fd, SOL_SOCKET, SO_ERROR,
                              (char *)&err, &optlen);
             if (ret < 0) {
                 err = errno;
@@ -679,7 +681,7 @@ TcpGetOptionProc(
         address peername;
         socklen_t size = sizeof(peername);
 
-	if (getpeername(statePtr->fds->fd, &peername.sa, &size) >= 0) {
+	if (getpeername(statePtr->fds.fd, &peername.sa, &size) >= 0) {
 	    if (len == 0) {
 		Tcl_DStringAppendElement(dsPtr, "-peername");
 		Tcl_DStringStartSublist(dsPtr);
@@ -726,7 +728,7 @@ TcpGetOptionProc(
 	    Tcl_DStringAppendElement(dsPtr, "-sockname");
 	    Tcl_DStringStartSublist(dsPtr);
 	}
-	for (fds = statePtr->fds; fds != NULL; fds = fds->next) {
+	for (fds = &statePtr->fds; fds != NULL; fds = fds->next) {
 	    size = sizeof(sockname);
 	    if (getsockname(fds->fd, &(sockname.sa), &size) >= 0) {
                 int flags = reverseDNS;
@@ -817,11 +819,11 @@ TcpWatchProc(
          * need to cache this request until the connection has succeeded. */
         statePtr->filehandlers = mask;
     } else if (mask) {
-        Tcl_CreateFileHandler(statePtr->fds->fd, mask,
+        Tcl_CreateFileHandler(statePtr->fds.fd, mask,
                               (Tcl_FileProc *) Tcl_NotifyChannel,
                               (ClientData) statePtr->channel);
     } else {
-        Tcl_DeleteFileHandler(statePtr->fds->fd);
+        Tcl_DeleteFileHandler(statePtr->fds.fd);
     }
 }
 
@@ -852,7 +854,7 @@ TcpGetHandleProc(
 {
     TcpState *statePtr = (TcpState *) instanceData;
 
-    *handlePtr = INT2PTR(statePtr->fds->fd);
+    *handlePtr = INT2PTR(statePtr->fds.fd);
     return TCL_OK;
 }
 
@@ -920,13 +922,13 @@ CreateClientSocket(
              * Close the socket if it is still open from the last unsuccessful
              * iteration.
              */
-            if (state->fds->fd >= 0) {
-		close(state->fds->fd);
-		state->fds->fd = -1;
+            if (state->fds.fd >= 0) {
+		close(state->fds.fd);
+		state->fds.fd = -1;
 	    }
 
-	    state->fds->fd = socket(state->addr->ai_family, SOCK_STREAM, 0);
-	    if (state->fds->fd < 0) {
+	    state->fds.fd = socket(state->addr->ai_family, SOCK_STREAM, 0);
+	    if (state->fds.fd < 0) {
 		continue;
 	    }
 
@@ -935,25 +937,25 @@ CreateClientSocket(
 	     * inherited by child processes.
 	     */
 	    
-	    fcntl(state->fds->fd, F_SETFD, FD_CLOEXEC);
+	    fcntl(state->fds.fd, F_SETFD, FD_CLOEXEC);
 	    
 	    /*
 	     * Set kernel space buffering
 	     */
 	    
-	    TclSockMinimumBuffers(INT2PTR(state->fds->fd), SOCKET_BUFSIZE);
+	    TclSockMinimumBuffers(INT2PTR(state->fds.fd), SOCKET_BUFSIZE);
     
 	    if (async) {
-		status = TclUnixSetBlockingMode(state->fds->fd, TCL_MODE_NONBLOCKING);
+		status = TclUnixSetBlockingMode(state->fds.fd, TCL_MODE_NONBLOCKING);
 		if (status < 0) {
                     continue;
 		}
 	    }
 
             reuseaddr = 1;
-            (void) setsockopt(state->fds->fd, SOL_SOCKET, SO_REUSEADDR,
+            (void) setsockopt(state->fds.fd, SOL_SOCKET, SO_REUSEADDR,
                     (char *) &reuseaddr, sizeof(reuseaddr));
-            status = bind(state->fds->fd, state->myaddr->ai_addr,
+            status = bind(state->fds.fd, state->myaddr->ai_addr,
                           state->myaddr->ai_addrlen);
             if (status < 0) {
                 continue;
@@ -966,22 +968,22 @@ CreateClientSocket(
 	     * in being informed when the connect completes.
 	     */
 	    
-	    status = connect(state->fds->fd, state->addr->ai_addr,
+	    status = connect(state->fds.fd, state->addr->ai_addr,
                              state->addr->ai_addrlen);
 	    if (status < 0 && errno == EINPROGRESS) {
-                Tcl_CreateFileHandler(state->fds->fd, TCL_WRITABLE,
+                Tcl_CreateFileHandler(state->fds.fd, TCL_WRITABLE,
                                       TcpAsyncCallback, state);
                 return TCL_OK;
 
             coro_continue:
-                Tcl_DeleteFileHandler(state->fds->fd);
+                Tcl_DeleteFileHandler(state->fds.fd);
                 /*
                  * Read the error state from the socket, to see if the async
                  * connection has succeeded or failed and store the status in
                  * the socket state for later retrieval by [fconfigure -error]
                  */
                 optlen = sizeof(int);
-                getsockopt(state->fds->fd, SOL_SOCKET, SO_ERROR,
+                getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR,
                            (char *)&status, &optlen);
                 state->status = status;
             }
@@ -996,7 +998,7 @@ out:
     if (async) {
         CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT);
         TcpWatchProc(state, state->filehandlers);
-        TclUnixSetBlockingMode(state->fds->fd, TCL_MODE_BLOCKING);
+        TclUnixSetBlockingMode(state->fds.fd, TCL_MODE_BLOCKING);
     }
 
     if (status < 0) {
@@ -1072,9 +1074,7 @@ Tcl_OpenTcpClient(
     state->flags = async ? TCP_ASYNC_CONNECT : 0;
     state->addrlist = addrlist;
     state->myaddrlist = myaddrlist;
-    state->fds = ckalloc(sizeof(TcpFdList));
-    memset(state->fds, (int) 0, sizeof(TcpFdList));
-    state->fds->fd = -1;
+    state->fds.fd = -1;
 
     /*
      * Create a new client socket and wrap it in a channel.
@@ -1147,9 +1147,7 @@ TclpMakeTcpClientChannelMode(
 
     statePtr = ckalloc(sizeof(TcpState));
     memset(statePtr, 0, sizeof(TcpState));
-    statePtr->fds = ckalloc(sizeof(TcpFdList));
-    memset(statePtr->fds, (int) 0, sizeof(TcpFdList));
-    statePtr->fds->fd = PTR2INT(sock);
+    statePtr->fds.fd = PTR2INT(sock);
     statePtr->flags = 0;
 
     sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
@@ -1275,8 +1273,6 @@ Tcl_OpenTcpServer(
             close(sock);
             continue;
         }
-        newfds = ckalloc(sizeof(TcpFdList));
-        memset(newfds, (int) 0, sizeof(TcpFdList));
         if (statePtr == NULL) {
             /*
              * Allocate a new TcpState for this socket.
@@ -1284,11 +1280,13 @@ Tcl_OpenTcpServer(
             
             statePtr = ckalloc(sizeof(TcpState));
             memset(statePtr, 0, sizeof(TcpState));
-            statePtr->fds = newfds;
             statePtr->acceptProc = acceptProc;
             statePtr->acceptProcData = acceptProcData;
             sprintf(channelName, SOCK_TEMPLATE, (long)statePtr);
+            newfds = &statePtr->fds;
         } else {
+            newfds = ckalloc(sizeof(TcpFdList));
+            memset(newfds, (int) 0, sizeof(TcpFdList));
             fds->next = newfds;
         }
         newfds->fd = sock;
@@ -1371,9 +1369,7 @@ TcpAccept(
     newSockState = ckalloc(sizeof(TcpState));
     memset(newSockState, 0, sizeof(TcpState));
     newSockState->flags = 0;
-    newSockState->fds = ckalloc(sizeof(TcpFdList));
-    memset(newSockState->fds, (int) 0, sizeof(TcpFdList));
-    newSockState->fds->fd = newsock;
+    newSockState->fds.fd = newsock;
 
     sprintf(channelName, SOCK_TEMPLATE, (long)newSockState);
     newSockState->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
-- 
cgit v0.12


From 58ce780c3e7059e66583a33e596969adf9ba7086 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 8 Jun 2011 10:14:50 +0000
Subject: More cleaning up of the code to remove unnecessary [string equal]s in
 tests.

---
 ChangeLog             |  12 +-
 tests/fileSystem.test | 362 +++++++++++++++++---------------------------------
 2 files changed, 130 insertions(+), 244 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b645eb0..f06295f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,14 @@
+2011-06-08  Donal K. Fellows  <dkf@users.sf.net>
+
+	* tests/fileSystem.test: Reduce the amount of use of duplication of
+	complex code to perform common tests, and convert others to do the
+	test result check directly using Tcltest's own primitives.
+
 2011-06-06  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* tests/socket.test: Add test constraint, so 6.2 and
-	  6.3 don't fail when the machine does not have support
-	  for ip6. Follow-up to checkin from 2011-05-11 by rmax.
+	* tests/socket.test: Add test constraint, so 6.2 and 6.3 don't fail
+	when the machine does not have support for ip6. Follow-up to checkin
+	from 2011-05-11 by rmax.
 
 2011-06-02  Don Porter  <dgp@users.sourceforge.net>
 
diff --git a/tests/fileSystem.test b/tests/fileSystem.test
index 6ab554b..4191713 100644
--- a/tests/fileSystem.test
+++ b/tests/fileSystem.test
@@ -31,44 +31,39 @@ makeDirectory [file join dir.dir dirinside.dir]
 makeFile "test file in directory" [file join dir.dir inside.file]
 
 testConstraint unusedDrive 0
-set drive {}
-if {[testConstraint win]} {
-    set vols [string map [list :/ {}] [file volumes]]
-    for {set i 0} {$i < 26} {incr i} {
-	set drive [format %c [expr {$i + 65}]]
-	if {$drive ni $vols} {
-	    testConstraint unusedDrive 1
-	    break
+testConstraint moreThanOneDrive 0
+apply {{} {
+    # The variables 'drive' and 'drives' will be used below.
+    variable drive {} drives {}
+    if {[testConstraint win]} {
+	set vols [string map [list :/ {}] [file volumes]]
+	for {set i 0} {$i < 26} {incr i} {
+	    set drive [format %c [expr {$i + 65}]]
+	    if {$drive ni $vols} {
+		testConstraint unusedDrive 1
+		break
+	    }
 	}
-    }
-    unset i vols
-    # The variable 'drive' will be used below
-}
 
-testConstraint moreThanOneDrive 0
-set drives [list]
-if {[testConstraint win]} {
-    set dir [pwd]
-    foreach vol [file volumes] {
-        if {![catch {cd $vol}]} {
-            lappend drives $vol
-        }
-    }
-    if {[llength $drives] > 1} {
-        testConstraint moreThanOneDrive 1
+	set dir [pwd]
+	try {
+	    foreach vol [file volumes] {
+		if {![catch {cd $vol}]} {
+		    lappend drives $vol
+		}
+	    }
+	    testConstraint moreThanOneDrive [llength $drives]
+	} finally {
+	    cd $dir
+	}
     }
-    # The variable 'drives' will be used below
-    unset vol
-    cd $dir
-    unset dir
-}
+} ::tcl::test::fileSystem}
 
 proc testPathEqual {one two} {
     if {$one eq $two} {
-	return 1
-    } else {
-	return "not equal: $one $two"
+	return "ok"
     }
+    return "not equal: $one $two"
 }
 
 testConstraint hasLinks [expr {![catch {
@@ -100,19 +95,19 @@ test filesystem-1.1 {link normalisation} {hasLinks} {
 test filesystem-1.2 {link normalisation} {hasLinks unix} {
     testPathEqual [file normalize [file join gorp.file foo]] \
 	[file normalize [file join link.file foo]]
-} {1}
+} ok
 test filesystem-1.3 {link normalisation} {hasLinks} {
     testPathEqual [file normalize [file join dir.dir foo]] \
 	[file normalize [file join dir.link foo]]
-} {1}
+} ok
 test filesystem-1.4 {link normalisation} {hasLinks} {
     testPathEqual [file normalize [file join dir.dir inside.file]] \
 	[file normalize [file join dir.link inside.file]]
-} {1}
+} ok
 test filesystem-1.5 {link normalisation} {hasLinks} {
     testPathEqual [file normalize [file join dir.dir linkinside.file]] \
 	[file normalize [file join dir.dir linkinside.file]]
-} {1}
+} ok
 test filesystem-1.6 {link normalisation} {hasLinks} {
     string equal [file normalize [file join dir.dir linkinside.file]] \
 	[file normalize [file join dir.link inside.file]]
@@ -120,28 +115,29 @@ test filesystem-1.6 {link normalisation} {hasLinks} {
 test filesystem-1.7 {link normalisation} {hasLinks unix} {
     testPathEqual [file normalize [file join dir.link linkinside.file foo]] \
 	[file normalize [file join dir.dir inside.file foo]]
-} {1}
+} ok
 test filesystem-1.8 {link normalisation} {hasLinks} {
     string equal [file normalize [file join dir.dir linkinside.filefoo]] \
 	[file normalize [file join dir.link inside.filefoo]]
 } {0}
-test filesystem-1.9 {link normalisation} {unix hasLinks} {
+test filesystem-1.9 {link normalisation} -setup {
     file delete -force dir.link
+} -constraints {unix hasLinks} -body {
     file link dir.link [file nativename dir.dir]
     testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
 	[file normalize [file join dir.link inside.file foo]]
-} {1}
+} -result ok
 test filesystem-1.10 {link normalisation: double link} {unix hasLinks} {
     file link dir2.link dir.link
     testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
 	[file normalize [file join dir2.link inside.file foo]]
-} {1}
+} ok
 makeDirectory dir2.file
 test filesystem-1.11 {link normalisation: double link, back in tree} {unix hasLinks} {
     file link [file join dir2.file dir2.link] [file join .. dir2.link]
     testPathEqual [file normalize [file join dir.dir linkinside.file foo]] \
 	[file normalize [file join dir2.file dir2.link inside.file foo]]
-} {1}
+} ok
 test filesystem-1.12 {file new native path} {} {
     for {set i 0} {$i < 10} {incr i} {
 	foreach f [lsort [glob -nocomplain -type l *]] {
@@ -198,39 +194,35 @@ test filesystem-1.25 {file normalisation} {win unusedDrive} {
 test filesystem-1.25.1 {file normalisation} {win unusedDrive} {
     file normalize ${drive}:/./.././..\\..\\a\\bb
 } "${drive}:/a/bb"
-test filesystem-1.26 {link normalisation: link and ..} {hasLinks} {
+test filesystem-1.26 {link normalisation: link and ..} -setup {
     file delete -force dir2.link
+} -constraints {hasLinks} -body {
     set dir [file join dir2 foo bar]
     file mkdir $dir
     file link dir2.link [file join dir2 foo bar]
-    set res [list [file normalize [file join dir2 foo x]] \
-	    [file normalize [file join dir2.link .. x]]]
-    testPathEqual [lindex $res 0] [lindex $res 1]
-} 1
+    testPathEqual [file normalize [file join dir2 foo x]] \
+	    [file normalize [file join dir2.link .. x]]
+} -result ok
 test filesystem-1.27 {file normalisation: up and down with ..} {
     set dir [file join dir2 foo bar]
     file mkdir $dir
     set dir2 [file join dir2 .. dir2 foo .. foo bar]
-    set res [list [file normalize $dir] [file normalize $dir2]]
-    set res2 [list [file exists $dir] [file exists $dir2]]
-    if {![string equal [lindex $res 0] [lindex $res 1]]} {
-	set res "exists: $res2, $res not equal"
-    } else {
-	set res "ok: $res2"
-    }
-} {ok: 1 1}
-test filesystem-1.28 {link normalisation: link with .. and ..} {hasLinks} {
+    list [testPathEqual [file normalize $dir] [file normalize $dir2]] \
+	[file exists $dir] [file exists $dir2]
+} {ok 1 1}
+test filesystem-1.28 {link normalisation: link with .. and ..} -setup {
     file delete -force dir2.link
+} -constraints {hasLinks} -body {
     set dir [file join dir2 foo bar]
     file mkdir $dir
     set to [file join dir2 .. dir2 foo .. foo bar]
     file link dir2.link $to
-    set res [list [file normalize [file join dir2 foo x]] \
-	    [file normalize [file join dir2.link .. x]]]
-    testPathEqual [lindex $res 0] [lindex $res 1]
-} 1
-test filesystem-1.29 {link normalisation: link with ..} {hasLinks} {
+    testPathEqual [file normalize [file join dir2 foo x]] \
+	    [file normalize [file join dir2.link .. x]]
+} -result ok
+test filesystem-1.29 {link normalisation: link with ..} -setup {
     file delete -force dir2.link
+} -constraints {hasLinks} -body {
     set dir [file join dir2 foo bar]
     file mkdir $dir
     set to [file join dir2 .. dir2 foo .. foo bar]
@@ -240,11 +232,11 @@ test filesystem-1.29 {link normalisation: link with ..} {hasLinks} {
 	return "$res must not contain '..'"
     }
     return "ok"
-} {ok}
+} -result {ok}
 test filesystem-1.29.1 {link normalisation with two consecutive links} {hasLinks} {
     testPathEqual [file normalize [file join dir.link dirinside.link abc]] \
 	[file normalize [file join dir.dir dirinside.dir abc]]
-} {1}
+} ok
 file delete -force dir2.file
 file delete -force dir2.link
 file delete -force link.file dir.link
@@ -277,208 +269,96 @@ test filesystem-1.33 {link normalisation: link near filesystem root} {testsetpla
 if {[testConstraint testsetplatform]} {
     testsetplatform $platform
 }
-test filesystem-1.34 {file normalisation with '/./'} {
-    set res [file normalize /foo/bar/anc/./.tml]
-    if {[string first "/./" $res] != -1} {
-	set res "normalization of /foo/bar/anc/./.tml is: $res"
-    } else {
-	set res "ok"
-    }
-    set res
-} {ok}
-test filesystem-1.35 {file normalisation with '/./'} {
-    set res [file normalize /ffo/bar/anc/./foo/.tml]
-    if {[string first "/./" $res] != -1 || ([regsub -all "foo" $res "" reg] == 2)} {
-	set res "normalization of /ffo/bar/anc/./foo/.tml is: $res"
-    } else {
-	set res "ok"
-    }
-    set res
-} {ok}
-test filesystem-1.36 {file normalisation with '/./'} {
-    set res [file normalize /foo/bar/anc/././asdasd/.tml]
-    if {[string first "/./" $res] != -1 || ([regsub -all "asdasd" $res "" reg] == 2) } {
-	set res "normalization of /foo/bar/anc/././asdasd/.tml is: $res"
-    } else {
-	set res "ok"
-    }
-    set res
-} {ok}
-test filesystem-1.37 {file normalisation with '/./'} {
+test filesystem-1.34 {file normalisation with '/./'} -body {
+    file normalize /foo/bar/anc/./.tml
+} -match regexp -result {^(?:(?!/\./).)*$}
+test filesystem-1.35a {file normalisation with '/./'} -body {
+    file normalize /ffo/bar/anc/./foo/.tml
+} -match regexp -result {^(?:(?!/\./).)*$}
+test filesystem-1.35b {file normalisation with '/./'} {
+    llength [regexp -all foo [file normalize /ffo/bar/anc/./foo/.tml]]
+} 1
+test filesystem-1.36a {file normalisation with '/./'} -body {
+    file normalize /foo/bar/anc/././asdasd/.tml
+} -match regexp -result {^(?:(?!/\./).)*$}
+test filesystem-1.36b {file normalisation with '/./'} {
+    llength [regexp -all asdasd [file normalize /foo/bar/anc/././asdasd/.tml]]
+} 1
+test filesystem-1.37 {file normalisation with '/./'} -body {
     set fname "/abc/./def/./ghi/./asda/.././.././asd/x/../../../../....."
-    set res [file norm $fname]
-    if {[string first "//" $res] != -1} {
-	set res "normalization of $fname is: $res"
-    } else {
-	set res "ok"
-    }
-    set res
-} {ok}
-test filesystem-1.38 {file normalisation with volume relative} \
-  {win moreThanOneDrive} {
-    set path "[string range [lindex $drives 0] 0 1]foo"
+    file norm $fname
+} -match regexp -result {^(?:[^/]|/(?:[^/]|$))+$}
+test filesystem-1.38 {file normalisation with volume relative} -setup {
     set dir [pwd]
+} -constraints {win moreThanOneDrive} -body {
+    set path "[string range [lindex $drives 0] 0 1]foo"
     cd [lindex $drives 1]
-    set res [file norm $path]
+    file norm $path
+} -cleanup {
     cd $dir
-    set res
-} "[lindex $drives 0]foo"
-test filesystem-1.39 {file normalisation with volume relative} {win} {
-    set drv C:/
-    set dir [lindex [glob -type d -dir $drv *] 0]
+} -result "[lindex $drives 0]foo"
+test filesystem-1.39 {file normalisation with volume relative} -setup {
     set old [pwd]
-    cd $dir
-    set res [file norm [string range $drv 0 1]]
+} -constraints {win} -body {
+    set drv C:/
+    cd [lindex [glob -type d -dir $drv *] 0]
+    file norm [string range $drv 0 1]
+} -cleanup {
     cd $old
-    if {[string index $res end] eq "/"} {
-        set res "Bad normalized path: $res"
-    } else {
-        set res "ok"
-    }
-} {ok}
+} -match glob -result {*[^/]}
 test filesystem-1.40 {file normalisation with repeated separators} {
-    set a [file norm foo////bar]
-    set b [file norm foo/bar]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm foo////bar] [file norm foo/bar]
+} ok
 test filesystem-1.41 {file normalisation with repeated separators} {win} {
-    set a [file norm foo\\\\\\bar]
-    set b [file norm foo/bar]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm foo\\\\\\bar] [file norm foo/bar]
+} ok
 test filesystem-1.42 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /xxx/..]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /xxx/..] [file norm /]
+} ok
 test filesystem-1.42.1 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /xxx/../]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /xxx/../] [file norm /]
+} ok
 test filesystem-1.43 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /xxx/foo/../..]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /xxx/foo/../..] [file norm /]
+} ok
 test filesystem-1.43.1 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /xxx/foo/../../]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /xxx/foo/../../] [file norm /]
+} ok
 test filesystem-1.44 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /xxx/foo/../../bar]
-    set b [file norm /bar]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /xxx/foo/../../bar] [file norm /bar]
+} ok
 test filesystem-1.45 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /xxx/../../bar]
-    set b [file norm /bar]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /xxx/../../bar] [file norm /bar]
+} ok
 test filesystem-1.46 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /xxx/../bar]
-    set b [file norm /bar]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /xxx/../bar] [file norm /bar]
+} ok
 test filesystem-1.47 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /..]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /..] [file norm /]
+} ok
 test filesystem-1.48 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /../]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /../] [file norm /]
+} ok
 test filesystem-1.49 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /.]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /.] [file norm /]
+} ok
 test filesystem-1.50 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /./]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /./] [file norm /]
+} ok
 test filesystem-1.51 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /../..]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /../..] [file norm /]
+} ok
 test filesystem-1.51.1 {file normalisation .. beyond root (Bug 1379287)} {
-    set a [file norm /../../]
-    set b [file norm /]
-    if {![string equal $a $b]} {
-        set res "Paths should be equal: $a , $b"
-    } else {
-        set res "ok"
-    }
-} {ok}
+    testPathEqual [file norm /../../] [file norm /]
+} ok
 
 test filesystem-2.0 {new native path} {unix} {
    foreach f [lsort [glob -nocomplain /usr/bin/c*]] {
        catch {file readlink $f}
    }
    # If we reach here we've succeeded. We used to crash above.
-   expr 1
-} {1}
+   return ok
+} ok
 
 # Make sure the testfilesystem hasn't been registered.
 if {[testConstraint testfilesystem]} {
@@ -511,28 +391,28 @@ test filesystem-4.0 {testfilesystem} -constraints testfilesystem -body {
     set filesystemReport {}
     file exists foo
     testfilesystem 0
-    set filesystemReport
+    return $filesystemReport
 } -match glob -result {*{access foo}}
 test filesystem-4.1 {testfilesystem} -constraints testfilesystem -body {
     testfilesystem 1
     set filesystemReport {}
     catch {file stat foo bar}
     testfilesystem 0
-    set filesystemReport
+    return $filesystemReport
 } -match glob -result {*{stat foo}}
 test filesystem-4.2 {testfilesystem} -constraints testfilesystem -body {
     testfilesystem 1
     set filesystemReport {}
     catch {file lstat foo bar}
     testfilesystem 0
-    set filesystemReport
+    return $filesystemReport
 } -match glob -result {*{lstat foo}}
 test filesystem-4.3 {testfilesystem} -constraints testfilesystem -body {
     testfilesystem 1
     set filesystemReport {}
     catch {glob *}
     testfilesystem 0
-    set filesystemReport
+    return $filesystemReport
 } -match glob -result {*{matchindirectory *}*}
 
 test filesystem-5.1 {cache and ~} -constraints testfilesystem -setup {
@@ -1041,7 +921,7 @@ test filesystem-9.9 {path objects and glob and file tail and tilde} -setup {
 # ----------------------------------------------------------------------
 
 cleanupTests
-unset -nocomplain drive
+unset -nocomplain drive drives
 }
 namespace delete ::tcl::test::fileSystem
 return
-- 
cgit v0.12


From 16f7aa77f536ccb3a36ed622f482b0a93a1e0db5 Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Wed, 8 Jun 2011 20:28:57 +0000
Subject: Reverted the fix for [Bug 3274728] committed on 2011-04-06 (rev
 [caf317ab68]) and replaced with one which is 64bit-safe. The existing fix
 crashed tclsh on Windows 64bit.

---
 ChangeLog            | 6 ++++++
 generic/tclExecute.c | 6 +++---
 2 files changed, 9 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f06295f..d7b704d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-06-08  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclExecute.c: Reverted the fix for [Bug 3274728]
+	committed on 2011-04-06 and replaced with one which is
+	64bit-safe. The existing fix crashed tclsh on Windows 64bit.
+
 2011-06-08  Donal K. Fellows  <dkf@users.sf.net>
 
 	* tests/fileSystem.test: Reduce the amount of use of duplication of
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 4fe65d7..84b0b63 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -172,7 +172,7 @@ typedef struct TEBCdata {
     ByteCode *codePtr;		/* Constant until the BC returns */
 				/* -----------------------------------------*/
     const unsigned char *pc;	/* These fields are used on return TO this */
-    unsigned long *catchTop;	/* this level: they record the state when a */
+    ptrdiff_t *catchTop;	/* this level: they record the state when a */
     int cleanup;		/* new codePtr was received for NR */
     Tcl_Obj *auxObjList;	/* execution. */
     int checkInterp;
@@ -1917,7 +1917,7 @@ TclIncrObj(
  *----------------------------------------------------------------------
  */
 #define	bcFramePtr	(&TD->cmdFrame)
-#define	initCatchTop	((unsigned long *) (&TD->stack[-1]))
+#define	initCatchTop	((ptrdiff_t *) (&TD->stack[-1]))
 #define	initTosPtr	((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
 #define esPtr           (iPtr->execEnvPtr->execStackPtr)
 
@@ -6265,7 +6265,7 @@ TEBCresume(
 
 	while (auxObjList) {
 	    if ((catchTop != initCatchTop) &&
-		    (*catchTop>auxObjList->internalRep.ptrAndLongRep.value)) {
+		(*catchTop > ((ptrdiff_t) auxObjList->internalRep.ptrAndLongRep.value))) {
 		break;
 	    }
 	    POP_TAUX_OBJ();
-- 
cgit v0.12


From a2c0c5611d68ee996777ad68e480daae28488ad9 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Thu, 16 Jun 2011 15:21:10 +0000
Subject:   *  doc/socket.n: Document the fact that the event loop is now
 needed for [socket -async]   *  unix/tclUnixSock.c: Set up the file handler
 for async sockets to fire on exceptions in addition to writable state.   * 
 tests/socket.test: Improve error reporting when socket-14.2 times out.

---
 doc/socket.n       | 23 +++++++++++++++++------
 tests/socket.test  |  3 +++
 unix/tclUnixSock.c |  3 ++-
 3 files changed, 22 insertions(+), 7 deletions(-)

diff --git a/doc/socket.n b/doc/socket.n
index 0e427ed..0cb0595 100644
--- a/doc/socket.n
+++ b/doc/socket.n
@@ -71,12 +71,14 @@ port number will be chosen at random by the system software.
 This option will cause the client socket to be connected
 asynchronously. This means that the socket will be created immediately
 but may not yet be connected to the server, when the call to
-\fBsocket\fR returns. When a \fBgets\fR or \fBflush\fR is done on the
-socket before the connection attempt succeeds or fails, if the socket
-is in blocking mode, the operation will wait until the connection is
-completed or fails. If the socket is in nonblocking mode and a
-\fBgets\fR or \fBflush\fR is done on the socket before the connection
-attempt succeeds or fails, the operation returns immediately and
+\fBsocket\fR returns.
+
+When a \fBgets\fR or \fBflush\fR is done on the socket before the
+connection attempt succeeds or fails, if the socket is in blocking
+mode, the operation will wait until the connection is completed or
+fails. If the socket is in nonblocking mode and a \fBgets\fR or
+\fBflush\fR is done on the socket before the connection attempt
+succeeds or fails, the operation returns immediately and
 \fBfblocked\fR on the socket returns 1. Synchronous client sockets may
 be switched (after they have connected) to operating in asynchronous
 mode using:
@@ -87,6 +89,15 @@ mode using:
 .CE
 .PP
 See the \fBchan\fR \fBconfigure\fR command for more details.
+
+The Tcl event loop should be running while an asynchronous connection
+is in progress, because it may have to do several connection attempts
+in the background. Runnig the event loop also allows you to set up a
+writable channel event on the socket to get notified when the
+asyncronous connection has succeeded or failed. See the \fBvwait\fR
+and the \fBchan\fR comands for more details on the event loop and
+channel events.
+
 .RE
 .SH "SERVER SOCKETS"
 .PP
diff --git a/tests/socket.test b/tests/socket.test
index 39dc8de..85d4d6f 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1772,6 +1772,9 @@ test socket-14.2 {[socket -async] fileevent connection refused} \
         fileevent $client writable {set x [fconfigure $client -error]}
         set after [after 1000 {set x timeout}]
         vwait x
+        if {$x eq "timeout"} {
+            append x ": [fconfigure $client -error]"
+        }
         set x
     } -cleanup {
         after cancel $after
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index a883e8c..5ace251 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -971,7 +971,8 @@ CreateClientSocket(
 	    status = connect(state->fds.fd, state->addr->ai_addr,
                              state->addr->ai_addrlen);
 	    if (status < 0 && errno == EINPROGRESS) {
-                Tcl_CreateFileHandler(state->fds.fd, TCL_WRITABLE,
+                Tcl_CreateFileHandler(state->fds.fd,
+                                      TCL_WRITABLE | TCL_EXCEPTION,
                                       TcpAsyncCallback, state);
                 return TCL_OK;
 
-- 
cgit v0.12


From d63052263676891c816f2dbc51362eaa0e3dc048 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Wed, 22 Jun 2011 14:21:28 +0000
Subject: complete a comment in socket.test

---
 tests/socket.test | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/tests/socket.test b/tests/socket.test
index 85d4d6f..e36914f 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -74,7 +74,8 @@ proc randport {} { expr {int(rand()*16383+49152)} }
 # Test the latency of tcp connections over the loopback interface. Some OSes
 # (e.g. NetBSD) seem to use the Nagle algorithm and delayed ACKs, so it takes
 # up to 200ms for a packet sent to localhost to arrive. We're measuring this
-# here, so that OSes that don't have this problem can
+# here, so that OSes that don't have this problem can run the tests at full
+# speed.
 set server [socket -server {apply {{s a p} {set ::s1 $s}}} 0]
 set s2 [socket localhost [lindex [fconfigure $server -sockname] 2]]
 vwait s1; close $server
-- 
cgit v0.12


From 8ea1c68f06abaff251f55c31105d58ccb4639e6a Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Wed, 22 Jun 2011 17:05:27 +0000
Subject: Re-add ".so man.macros", which got removed inadvertently along with
 the RCS Keyword lines.

---
 doc/CrtChnlHdlr.3  | 1 +
 doc/CrtCloseHdlr.3 | 1 +
 2 files changed, 2 insertions(+)

diff --git a/doc/CrtChnlHdlr.3 b/doc/CrtChnlHdlr.3
index fcb1d5f..1451e30 100644
--- a/doc/CrtChnlHdlr.3
+++ b/doc/CrtChnlHdlr.3
@@ -4,6 +4,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\"
+.so man.macros
 .TH Tcl_CreateChannelHandler 3 7.5 Tcl "Tcl Library Procedures"
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
diff --git a/doc/CrtCloseHdlr.3 b/doc/CrtCloseHdlr.3
index 52a7033..a114f9c 100644
--- a/doc/CrtCloseHdlr.3
+++ b/doc/CrtCloseHdlr.3
@@ -4,6 +4,7 @@
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\"
+.so man.macros
 .TH Tcl_CreateCloseHandler 3 7.5 Tcl "Tcl Library Procedures"
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
-- 
cgit v0.12


From 1543959a9b88e49df5b1f1ba37872eeae9eabb1e Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Tue, 28 Jun 2011 11:32:15 +0000
Subject:   *  unix/tclUnixSock.c (CreateClientSocket): Fix and simplify
 posting of the writable fileevent at the end of an asynchronous connection
 attempt. Improve comments for some of the trickery around [socket -async].
 [Bug 3325339]   *  tests/socket.test: Adjust tests to the async code changes.
 Add more tests for corner cases of async sockets.

---
 ChangeLog          | 10 ++++++++
 tests/socket.test  | 67 +++++++++++++++++++++++++++++++++++++++++++-----
 unix/tclUnixSock.c | 75 ++++++++++++++++++++++++++++++++++++++++--------------
 3 files changed, 126 insertions(+), 26 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f6909b1..de04d25 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2011-06-28  Reinhard Max  <max@suse.de>
+
+	* unix/tclUnixSock.c (CreateClientSocket): Fix and simplify
+	posting of the writable fileevent at the end of an asynchronous
+	connection attempt. Improve comments for some of the trickery
+	around [socket -async]. [Bug 3325339]
+	
+	* tests/socket.test: Adjust tests to the async code changes. Add
+	more tests for corner cases of async sockets.
+
 2011-06-22  Andreas Kupries  <andreask@activestate.com>
 
 	* library/platform/pkgIndex.tcl: Updated to platform 1.0.10. Added
diff --git a/tests/socket.test b/tests/socket.test
index 7f5c5c2..363f141 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1751,21 +1751,23 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
         }
         set server [socket -server accept -myaddr 127.0.0.1 0]
         set port [lindex [fconfigure $server -sockname] 2]
+        set x ""
     } -body {
         set client [socket -async localhost $port]
         fileevent $client writable {
-            lappend x [expr {[fconfigure $client -error] eq ""}]
+            lappend x [fconfigure $client -error]
         }
-        set after [after 1000 {set x timeout}]
-        vwait x
-        vwait x
-        set x
+        set after [after 1000 {lappend x timeout}]
+        while {[llength $x] < 2 && "timeout" ni $x} {
+            vwait x
+        }
+        lsort $x; # we only want to see both events, the order doesn't matter
     } -cleanup {
         after cancel $after
         close $server
         close $client
         unset x
-    } -result {ok 1}
+    } -result {{} ok}
 test socket-14.2 {[socket -async] fileevent connection refused} \
     -constraints [list socket supported_any] \
     -body {
@@ -1782,7 +1784,58 @@ test socket-14.2 {[socket -async] fileevent connection refused} \
         close $client
         unset x
     } -result "connection refused"
-
+test socket-14.3 {[socket -async] fileevent host unreachable} \
+    -constraints [list socket supported_any] \
+    -body {
+        # address from rfc5737
+        set client [socket -async 192.0.2.42 [randport]]
+        fileevent $client writable {set x [fconfigure $client -error]}
+        set after [after 5000 {set x timeout}]
+        vwait x
+        if {$x eq "timeout"} {
+            append x ": [fconfigure $client -error]"
+        }
+        set x
+    } -cleanup {
+        after cancel $after
+        close $client
+        unset x
+    } -result "host is unreachable"
+test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
+    -constraints [list socket supported_any] \
+    -setup {
+        proc accept {s a p} {
+            puts $s bye
+            close $s
+        }
+        set server [socket -server accept -myaddr 127.0.0.1 0]
+        set port [lindex [fconfigure $server -sockname] 2]
+        set x ""
+    } -body {
+        set client [socket -async localhost $port]
+        fileevent $client writable {
+            lappend x [fconfigure $client -error]
+            fileevent $client writable {}
+        }
+        fileevent $client readable {lappend x [gets $client]}
+        set after [after 1000 {lappend x timeout}]
+        while {[llength $x] < 2 && "timeout" ni $x} {
+            vwait x
+        }
+        lsort $x
+    } -cleanup {
+        after cancel $after
+        close $client
+        close $server
+    } -result {{} bye}
+test socket-14.5 {[socket -async] which fails before any connect() can be made} \
+    -constraints [list socket supported_any] \
+    -body {
+        # addresses from rfc5737
+        socket -async -myaddr 192.0.2.42 198.51.100.42 [randport]
+    } \
+    -returnCodes 1 \
+    -result {couldn't open socket: cannot assign requested address}
 ::tcltest::cleanupTests
 flush stdout
 return
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 5ace251..52b089c 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -858,6 +858,17 @@ TcpGetHandleProc(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TcpAsyncCallback --
+ *
+ *	Called by the event handler that CreateClientSocket sets up
+ *	internally for [socket -async] to get notified when the
+ *	asyncronous connection attempt has succeeded or failed.
+ *
+ *----------------------------------------------------------------------
+ */
 static void
 TcpAsyncCallback(
     ClientData clientData,	/* The socket state. */
@@ -883,6 +894,18 @@ TcpAsyncCallback(
  * Side effects:
  *	Opens a socket.
  *
+ * Remarks:
+ *	A single host name may resolve to more than one IP address, e.g. for
+ *	an IPv4/IPv6 dual stack host. For handling asyncronously connecting
+ *	sockets in the background for such hosts, this function can act as a
+ *	coroutine. On the first call, it sets up the control variables for the
+ *	two nested loops over the local and remote addresses. Once the first
+ *	connection attempt is in progress, it sets up itself as a writable
+ *	event handler for that socket, and returns. When the callback occurs,
+ *	control is transferred to the "reenter" label, right after the initial
+ *	return and the loops resume as if they had never been interrupted.
+ *	For syncronously connecting sockets, the loops work the usual way.
+ *
  *----------------------------------------------------------------------
  */
 
@@ -892,14 +915,14 @@ CreateClientSocket(
     TcpState *state)
 {
     socklen_t optlen;
-    int in_coro = (state->addr != NULL);
+    int async_callback = (state->addr != NULL);
     int status;
     int async = state->flags & TCP_ASYNC_CONNECT;
 
-    if (in_coro) {
-        goto coro_continue;
+    if (async_callback) {
+        goto reenter;
     }
-    
+
     for (state->addr = state->addrlist; state->addr != NULL;
          state->addr = state->addr->ai_next) {
 
@@ -976,12 +999,13 @@ CreateClientSocket(
                                       TcpAsyncCallback, state);
                 return TCL_OK;
 
-            coro_continue:
+            reenter:
                 Tcl_DeleteFileHandler(state->fds.fd);
                 /*
-                 * Read the error state from the socket, to see if the async
-                 * connection has succeeded or failed and store the status in
-                 * the socket state for later retrieval by [fconfigure -error]
+                 * Read the error state from the socket to see if the async
+                 * connection has succeeded or failed. As this clears the
+                 * error condition, we cache the status in the socket state
+                 * struct for later retrieval by [fconfigure -error].
                  */
                 optlen = sizeof(int);
                 getsockopt(state->fds.fd, SOL_SOCKET, SO_ERROR,
@@ -996,22 +1020,35 @@ CreateClientSocket(
 
 out:
 
-    if (async) {
+    if (async_callback) {
+        /*
+         * An asynchonous connection has finally succeeded or failed.
+         */
         CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT);
         TcpWatchProc(state, state->filehandlers);
         TclUnixSetBlockingMode(state->fds.fd, TCL_MODE_BLOCKING);
-    }
 
-    if (status < 0) {
-        if (in_coro) {
-            Tcl_NotifyChannel(state->channel, TCL_WRITABLE);
-        } else {
-            if (interp != NULL) {
-                Tcl_AppendResult(interp, "couldn't open socket: ",
-                                 Tcl_PosixError(interp), NULL);
-            }
-            return TCL_ERROR;
+        /*
+         * We need to forward the writable event that brought us here, bcasue
+         * upon reading of getsockopt(SO_ERROR), at least some OSes clear the
+         * writable state from the socket, and so a subsequent select() on
+         * behalf of a script level [fileevent] would not fire. It doesn't
+         * hurt that this is also called in the successful case and will save
+         * the event mechanism one roundtrip through select().
+         */
+        Tcl_NotifyChannel(state->channel, TCL_WRITABLE);
+
+    } else if (status != 0) {
+        /*
+         * Failure for either a synchronous connection, or an async one that
+         * failed before it could enter background mode, e.g. because an
+         * invalid -myaddr was given.
+         */
+        if (interp != NULL) {
+            Tcl_AppendResult(interp, "couldn't open socket: ",
+                             Tcl_PosixError(interp), NULL);
         }
+        return TCL_ERROR;
     }
     return TCL_OK;
 }
-- 
cgit v0.12


From aff501ecb18b44cb1c8920d32937ba3e7f404017 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Tue, 28 Jun 2011 14:42:29 +0000
Subject: replace socket-14.3 with a test that is more useful and less likely
 to randomly fail depending on the local network environment.

---
 tests/socket.test | 29 +++++++++++++++++------------
 1 file changed, 17 insertions(+), 12 deletions(-)

diff --git a/tests/socket.test b/tests/socket.test
index 363f141..8efa79e 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1718,7 +1718,7 @@ catch {close $commandSocket}
 catch {close $remoteProcChan}
 }
 unset ::tcl::unsupported::socketAF
-test socket-14.0 {[socket -async] when server only listens on one address family} \
+test socket-14.0 {[socket -async] when server only listens on IPv4} \
     -constraints [list socket supported_any] \
     -setup {
         proc accept {s a p} {
@@ -1784,23 +1784,28 @@ test socket-14.2 {[socket -async] fileevent connection refused} \
         close $client
         unset x
     } -result "connection refused"
-test socket-14.3 {[socket -async] fileevent host unreachable} \
+test socket-14.3 {[socket -async] when server only listens on IPv6} \
     -constraints [list socket supported_any] \
-    -body {
-        # address from rfc5737
-        set client [socket -async 192.0.2.42 [randport]]
-        fileevent $client writable {set x [fconfigure $client -error]}
-        set after [after 5000 {set x timeout}]
-        vwait x
-        if {$x eq "timeout"} {
-            append x ": [fconfigure $client -error]"
+    -setup {
+        proc accept {s a p} {
+            global x
+            puts $s bye
+            close $s
+            set x ok
         }
+        set server [socket -server accept -myaddr ::1 0]
+        set port [lindex [fconfigure $server -sockname] 2]
+    } -body {
+        set client [socket -async localhost $port]
+        set after [after 1000 {set x [fconfigure $client -error]}]
+        vwait x
         set x
     } -cleanup {
         after cancel $after
+        close $server
         close $client
         unset x
-    } -result "host is unreachable"
+    } -result ok
 test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
     -constraints [list socket supported_any] \
     -setup {
@@ -1832,7 +1837,7 @@ test socket-14.5 {[socket -async] which fails before any connect() can be made}
     -constraints [list socket supported_any] \
     -body {
         # addresses from rfc5737
-        socket -async -myaddr 192.0.2.42 198.51.100.42 [randport]
+        socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
     } \
     -returnCodes 1 \
     -result {couldn't open socket: cannot assign requested address}
-- 
cgit v0.12


From dc83b12bd6506975026827fb7329f66a211cd34a Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Tue, 28 Jun 2011 15:43:30 +0000
Subject: Rework constraint detection and add constraints that cater for the
 fact, that both address families might be available, but localhost only
 resolves to one of the loopback addreses.

---
 tests/socket.test | 31 ++++++++++++++++++++++---------
 1 file changed, 22 insertions(+), 9 deletions(-)

diff --git a/tests/socket.test b/tests/socket.test
index 8efa79e..0ea0eb5 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -117,15 +117,28 @@ if 0 {
 }
 
 foreach {af localhost} {
-    any 127.0.0.1
     inet 127.0.0.1
     inet6 ::1
 } {
-    set ::tcl::unsupported::socketAF $af
     # Check if the family is supported and set the constraint accordingly
-    testConstraint supported_$af [expr {![catch {socket -server foo 0} sock]}]
+    testConstraint supported_$af [expr {![catch {socket -server foo -myaddr $localhost 0} sock]}]
     catch {close $sock}
-    
+}
+testConstraint supported_any [expr {[testConstraint supported_inet] || [testConstraint supported_inet6]}]
+
+set sock [socket -server foo -myaddr localhost 0]
+set sockname [fconfigure $sock -sockname]
+close $sock
+testConstraint localhost_v4 [expr {"127.0.0.1" in $sockname}]
+testConstraint localhost_v6 [expr {"::1" in $sockname}]
+
+
+foreach {af localhost} {
+    any 127.0.0.1
+    inet 127.0.0.1
+    inet6 ::1
+} {
+    set ::tcl::unsupported::socketAF $af
 #
 # Check if we're supposed to do tests against the remote server
 #
@@ -1719,7 +1732,7 @@ catch {close $remoteProcChan}
 }
 unset ::tcl::unsupported::socketAF
 test socket-14.0 {[socket -async] when server only listens on IPv4} \
-    -constraints [list socket supported_any] \
+    -constraints [list socket supported_any localhost_v4] \
     -setup {
         proc accept {s a p} {
             global x
@@ -1749,7 +1762,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
             close $s
 	    lappend x ok
         }
-        set server [socket -server accept -myaddr 127.0.0.1 0]
+        set server [socket -server accept -myaddr localhost 0]
         set port [lindex [fconfigure $server -sockname] 2]
         set x ""
     } -body {
@@ -1785,7 +1798,7 @@ test socket-14.2 {[socket -async] fileevent connection refused} \
         unset x
     } -result "connection refused"
 test socket-14.3 {[socket -async] when server only listens on IPv6} \
-    -constraints [list socket supported_any] \
+    -constraints [list socket supported_any localhost_v6] \
     -setup {
         proc accept {s a p} {
             global x
@@ -1813,7 +1826,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
             puts $s bye
             close $s
         }
-        set server [socket -server accept -myaddr 127.0.0.1 0]
+        set server [socket -server accept -myaddr localhost 0]
         set port [lindex [fconfigure $server -sockname] 2]
         set x ""
     } -body {
@@ -1836,7 +1849,7 @@ test socket-14.4 {[socket -async] and both, readdable and writable fileevents} \
 test socket-14.5 {[socket -async] which fails before any connect() can be made} \
     -constraints [list socket supported_any] \
     -body {
-        # addresses from rfc5737
+        # address from rfc5737
         socket -async -myaddr 192.0.2.42 127.0.0.1 [randport]
     } \
     -returnCodes 1 \
-- 
cgit v0.12


From d655e0866270a535855a94980a08d087e0b9f9ab Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 7 Jul 2011 08:47:31 +0000
Subject: minor gcc compiler warning with -Wwrite-strings

---
 win/tclWinPipe.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/win/tclWinPipe.c b/win/tclWinPipe.c
index b9b881c..10b6ab2 100644
--- a/win/tclWinPipe.c
+++ b/win/tclWinPipe.c
@@ -475,7 +475,7 @@ TempFileName(
     TCHAR name[MAX_PATH])	/* Buffer in which name for temporary file
 				 * gets stored. */
 {
-    TCHAR *prefix = TEXT("TCL");
+    const TCHAR *prefix = TEXT("TCL");
     if (GetTempPath(MAX_PATH, name) != 0) {
 	if (GetTempFileName(name, prefix, 0, name) != 0) {
 	    return 1;
@@ -3101,7 +3101,7 @@ TclpOpenTemporaryFile(
 	namePtr += Tcl_DStringLength(&buf);
 	Tcl_DStringFree(&buf);
     } else {
-	TCHAR *baseStr = TEXT("TCL");
+	const TCHAR *baseStr = TEXT("TCL");
 	int length = 3 * sizeof(TCHAR);
 
 	memcpy(namePtr, baseStr, length);
-- 
cgit v0.12


From f3126d6258f2f5d12a84332b79d1f183778e0fc0 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 7 Jul 2011 17:41:00 +0000
Subject: Correct test suite errors revealed by a -singleproc 1 -debug 1 run.

---
 tests/assemble.test  | 4 ++--
 tests/chanio.test    | 2 +-
 tests/coroutine.test | 1 +
 tests/ioTrans.test   | 8 +++++---
 tests/ooNext2.test   | 2 +-
 tests/package.test   | 2 +-
 6 files changed, 11 insertions(+), 8 deletions(-)

diff --git a/tests/assemble.test b/tests/assemble.test
index 761b36b..dae4821 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -767,7 +767,7 @@ test assemble-7.43 {uplus} {
     -returnCodes error
     -result {can't use non-numeric floating-point value as operand of "+"}
 }
-test assemble-7.43 {tryCvtToNumeric} {
+test assemble-7.43.1 {tryCvtToNumeric} {
     -body {
 	assemble {
 	    push NaN; tryCvtToNumeric
@@ -1562,7 +1562,7 @@ test assemble-15.6 {listIndexImm} {
     }
     -result b
 }
-test assemble-15.6 {listIndexImm} {
+test assemble-15.7 {listIndexImm} {
     -body {
 	assemble {push {a b c}; listIndexImm end}
     }
diff --git a/tests/chanio.test b/tests/chanio.test
index 4f44d3f..5569385 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -7720,7 +7720,7 @@ test chan-io-73.1 {channel Tcl_Obj SetChannelFromAny} -body {
 
 # cleanup
 foreach file [list fooBar longfile script output test1 pipe my_script \
-	test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
+	test2 test3 cat kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
     removeFile $file
 }
 cleanupTests
diff --git a/tests/coroutine.test b/tests/coroutine.test
index bc72017..7d5169b 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -455,6 +455,7 @@ test coroutine-4.7 {compile context, bug #3282869} -setup {
     set ::x [f 12]
     D
 } -cleanup {
+    D
     unset ::x
     rename f {}
 } -result YX15
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 8dbad78..3ea017b 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -1790,6 +1790,7 @@ test iortrans.tf-11.0 {origin thread of moved transform gone} -setup {
 } -constraints {testchannel testthread} -match glob -body {
     # Set up channel in thread
     testthread send $tida $helperscript
+    testthread send $tidb $helperscript
     set chan [testthread send $tida {
 	proc foo {args} {
 	    handle.initialize clear drain flush limit? read write
@@ -1816,8 +1817,8 @@ test iortrans.tf-11.0 {origin thread of moved transform gone} -setup {
     # The 'tell' is ok, as it passed through the transform to the base
     # channel without invoking the transform handler.
 } -cleanup {
+    testthread send $tidb tempdone
     tcltest::threadReap
-    tempdone
 } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
 test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup {
     #puts <<$tcltest::mainThread>>main
@@ -1825,7 +1826,8 @@ test iortrans.tf-11.1 {origin thread of moved transform destroyed during access}
     set tidb [testthread create];	#puts <<$tidb>>
 } -constraints {testchannel testthread} -match glob -body {
     # Set up channel in thread
-    set chan [testthread send $tida $helperscript]
+    testthread send $tida $helperscript
+    testthread send $tidb $helperscript
     set chan [testthread send $tida {
 	proc foo {args} {
 	    handle.initialize clear drain flush limit? read write
@@ -1857,8 +1859,8 @@ test iortrans.tf-11.1 {origin thread of moved transform destroyed during access}
     vwait ::res
     return $res
 } -cleanup {
+    testthread send $tidb tempdone
     tcltest::threadReap
-    tempdone
 } -result {Owner lost}
 
 # ### ### ### ######### ######### #########
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index fc0423f..51f02c5 100644
--- a/tests/ooNext2.test
+++ b/tests/ooNext2.test
@@ -671,7 +671,7 @@ test oo-call-2.10 {class call introspection - errors} -body {
 test oo-call-2.11 {class call introspection - errors} -body {
     info class call notaclass x
 } -returnCodes error -result {notaclass does not refer to an object}
-test oo-call-2.11 {class call introspection - errors} -setup {
+test oo-call-2.12 {class call introspection - errors} -setup {
     oo::class create root
 } -body {
     root create notaclass
diff --git a/tests/package.test b/tests/package.test
index bd57e86..da778f1 100644
--- a/tests/package.test
+++ b/tests/package.test
@@ -1039,7 +1039,7 @@ foreach {r p vs vc} {
     incr n
 }
 
-test package-11.0 {package vcompare at 32bit boundary} {
+test package-11.0.0 {package vcompare at 32bit boundary} {
     package vcompare [expr {1<<31}] [expr {(1<<31)-1}]
 } 1
 
-- 
cgit v0.12


From 43690f65e0d3fb04c9e14155f308570808649ee5 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Thu, 7 Jul 2011 18:57:46 +0000
Subject: * generic/tclBasic.c: add missing INT2PTR

---
 ChangeLog          | 4 ++++
 generic/tclBasic.c | 2 +-
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 89766bb..ff9ca31 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-07-07  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclBasic.c: add missing INT2PTR
+	
 2011-07-03  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/FileSystem.3: Corrected statements about ctime field of 'struct
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 6791cbf..c46510c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -4139,7 +4139,7 @@ TclNREvalObjv(
      */
 
     if (iPtr->evalFlags & TCL_EVAL_REDIRECT) {
-	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), objc, objv);
+	TclNRAddCallback(interp, NRCommand, NULL, INT2PTR(1), INT2PTR(objc), objv);
 	iPtr->evalFlags &= ~TCL_EVAL_REDIRECT;
     } else {
 	TclNRAddCallback(interp, NRCommand, NULL, NULL, INT2PTR(objc), objv);
-- 
cgit v0.12


From ff18e6785fda0ce090fefdcb52c03a8be6e3be40 Mon Sep 17 00:00:00 2001
From: Joe Mistachkin <joe@mistachkin.com>
Date: Mon, 11 Jul 2011 20:04:06 +0000
Subject: Correct cast for CURR_DEPTH to silence compiler warning. [Bug
 3339502]

---
 ChangeLog            | 5 +++++
 generic/tclExecute.c | 2 +-
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index bd787b3..d7eb0e4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-07-11  Joe Mistachkin  <joe@mistachkin.com>
+
+	* generic/tclExecute.c: [Bug 3339502]: Correct cast for CURR_DEPTH to
+	silence compiler warning.
+
 2011-07-08  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/http.n: [FRQ 3358415]: State what RFC defines HTTP/1.1.
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 84b0b63..fee096a 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -335,7 +335,7 @@ VarHashCreateVar(
 
 #define OBJ_AT_DEPTH(n)	*(tosPtr-(n))
 
-#define CURR_DEPTH	((unsigned long) (tosPtr - initTosPtr))
+#define CURR_DEPTH	((ptrdiff_t) (tosPtr - initTosPtr))
 
 /*
  * Macros used to trace instruction execution. The macros TRACE,
-- 
cgit v0.12


From a794c019fc0416aa27cb0dde1889e3486725aa4c Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 12 Jul 2011 16:05:43 +0000
Subject: platform portable type matching in debug prints

---
 generic/tclAssembly.c |  4 ++--
 generic/tclCompile.c  |  2 +-
 generic/tclExecute.c  |  2 +-
 generic/tclObj.c      |  8 ++++----
 generic/tclPreserve.c | 12 ++++++------
 5 files changed, 14 insertions(+), 14 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 754941f..1b87886 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -1035,8 +1035,8 @@ TclAssembleCode(
 
 #ifdef TCL_COMPILE_DEBUG
 	    if ((tclTraceCompile >= 2) && (envPtr->procPtr == NULL)) {
-		printf("  %4d Assembling: ",
-			envPtr->codeNext - envPtr->codeStart);
+		printf("  %4ld Assembling: ",
+			(long)(envPtr->codeNext - envPtr->codeStart));
 		TclPrintSource(stdout, parsePtr->commandStart,
 			TclMin(instLen, 55));
 		printf("\n");
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 0eaf834..18679b2 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2468,7 +2468,7 @@ TclInitByteCodeObj(
 #else
     nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
     if (((size_t)(nextPtr - p)) != cmdLocBytes) {
-	Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d", (nextPtr - p), cmdLocBytes);
+	Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %lu != expected size %lu", (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes);
     }
 #endif
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index fee096a..a7d6184 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -8441,7 +8441,7 @@ EvalStatsCmd(
     Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
     Tcl_AppendPrintfToObj(objPtr,
 	    "Compilation and execution statistics for interpreter %#lx\n",
-	    iPtr);
+	    (long int)iPtr);
 
     Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed\t%ld\n",
 	    statsPtr->numExecutions);
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 129d80d..95924c1 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -1330,7 +1330,7 @@ TclFreeObj(
     ObjInitDeletionContext(context);
 
     if (objPtr->refCount < -1) {
-	Tcl_Panic("Reference count for %lx was negative", objPtr);
+	Tcl_Panic("Reference count for %p was negative", objPtr);
     }
 
     /*
@@ -3724,7 +3724,7 @@ Tcl_DbIncrRefCount(
 	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
 	if (!hPtr) {
 	    Tcl_Panic("%s%s",
-		    "Trying to incr ref count of "
+		    "Trying to incr ref count of ",
 		    "Tcl_Obj allocated in another thread");
 	}
     }
@@ -3789,7 +3789,7 @@ Tcl_DbDecrRefCount(
 	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
 	if (!hPtr) {
 	    Tcl_Panic("%s%s",
-		    "Trying to decr ref count of "
+		    "Trying to decr ref count of ",
 		    "Tcl_Obj allocated in another thread");
 	}
 
@@ -3868,7 +3868,7 @@ Tcl_DbIsShared(
 	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
 	if (!hPtr) {
 	    Tcl_Panic("%s%s",
-		    "Trying to check shared status of"
+		    "Trying to check shared status of",
 		    "Tcl_Obj allocated in another thread");
 	}
     }
diff --git a/generic/tclPreserve.c b/generic/tclPreserve.c
index cbd7b63..0bd8f93 100644
--- a/generic/tclPreserve.c
+++ b/generic/tclPreserve.c
@@ -368,10 +368,10 @@ TclHandleFree(
     handlePtr = (HandleStruct *) handle;
 #ifdef TCL_MEM_DEBUG
     if (handlePtr->refCount == 0x61616161) {
-	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
+	Tcl_Panic("using previously disposed TclHandle %p", handlePtr);
     }
     if (handlePtr->ptr2 != handlePtr->ptr) {
-	Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
+	Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
 		handlePtr, handlePtr->ptr2, handlePtr->ptr);
     }
 #endif
@@ -411,10 +411,10 @@ TclHandlePreserve(
     handlePtr = (HandleStruct *) handle;
 #ifdef TCL_MEM_DEBUG
     if (handlePtr->refCount == 0x61616161) {
-	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
+	Tcl_Panic("using previously disposed TclHandle %p", handlePtr);
     }
     if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
-	Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
+	Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
 		handlePtr, handlePtr->ptr2, handlePtr->ptr);
     }
 #endif
@@ -452,10 +452,10 @@ TclHandleRelease(
     handlePtr = (HandleStruct *) handle;
 #ifdef TCL_MEM_DEBUG
     if (handlePtr->refCount == 0x61616161) {
-	Tcl_Panic("using previously disposed TclHandle %x", handlePtr);
+	Tcl_Panic("using previously disposed TclHandle %p", handlePtr);
     }
     if ((handlePtr->ptr != NULL) && (handlePtr->ptr != handlePtr->ptr2)) {
-	Tcl_Panic("someone has changed the block referenced by the handle %x\nfrom %x to %x",
+	Tcl_Panic("someone has changed the block referenced by the handle %p\nfrom %p to %p",
 		handlePtr, handlePtr->ptr2, handlePtr->ptr);
     }
 #endif
-- 
cgit v0.12


From 02ef1632d034f070d79c64264efa65fce9fc5af7 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 12 Jul 2011 19:10:13 +0000
Subject: 3364777 Stop segfault caused by reading from struct after it had been
 freed.

---
 ChangeLog          | 5 +++++
 unix/tclUnixSock.c | 5 ++++-
 2 files changed, 9 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index d7eb0e4..0cfdfef 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-07-12  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclUnixSock.c:  [Bug 3364777] Stop segfault caused by
+	reading from struct after it had been freed. 
+
 2011-07-11  Joe Mistachkin  <joe@mistachkin.com>
 
 	* generic/tclExecute.c: [Bug 3339502]: Correct cast for CURR_DEPTH to
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 52b089c..f302b70 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -544,8 +544,11 @@ TcpCloseProc(
 	}
     
     }
-    for (fds = statePtr->fds.next; fds != NULL; fds = fds->next) {
+    fds = statePtr->fds.next;
+    while (fds != NULL) {
+	TcpFdList *next = fds->next;
         ckfree(fds);
+	fds = next;
     }
     if (statePtr->addrlist != NULL) {
         freeaddrinfo(statePtr->addrlist);
-- 
cgit v0.12


From 8dec52290a9d933a2faa654d1f41a23e49e1a3e6 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 14 Jul 2011 17:57:05 +0000
Subject: Remove stray refcount bump that caused a memory leak.

---
 ChangeLog           | 5 +++++
 generic/tclOOCall.c | 1 -
 2 files changed, 5 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index bd787b3..4821faf 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-07-14  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOCall.c (TclOORenderCallChain): [Bug 3365156]: Remove
+	stray refcount bump that caused a memory leak.
+
 2011-07-08  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/http.n: [FRQ 3358415]: State what RFC defines HTTP/1.1.
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 3954a6b..b5d7c0c 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -1453,7 +1453,6 @@ TclOORenderCallChain(
 	descObjs[3] = Tcl_NewStringObj(miPtr->mPtr->typePtr->name, -1);
 
 	objv[i] = Tcl_NewListObj(4, descObjs);
-	Tcl_IncrRefCount(objv[i]);
     }
 
     /*
-- 
cgit v0.12


From f10d6c78e39de65787b2bb9652689feeca1b0b31 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 15 Jul 2011 14:55:07 +0000
Subject: 3357771 Prevent circular references in values with ByteCode intreps.

---
 ChangeLog            |  6 ++++++
 generic/tclCompile.c | 14 +++++++++++++-
 2 files changed, 19 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 11c28f6..80ca332 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-07-15  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclCompile.c:	[Bug 467523, 3357771] Prevent circular
+	references in values with ByteCode intreps.  They can lead to
+	memory leaks. 
+
 2011-07-14  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclOOCall.c (TclOORenderCallChain): [Bug 3365156]: Remove
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 18679b2..8aedf95 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2443,7 +2443,19 @@ TclInitByteCodeObj(
     p += TCL_ALIGN(codeBytes);		/* align object array */
     codePtr->objArrayPtr = (Tcl_Obj **) p;
     for (i = 0;  i < numLitObjects;  i++) {
-	codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
+	if (objPtr == envPtr->literalArrayPtr[i].objPtr) {
+	    /*
+	     * Prevent circular reference where the bytecode intrep of
+	     * a value contains a literal which is that same value.
+	     * If this is allowed to happen, refcount decrements may not
+	     * reach zero, and memory may leak.  Bugs 467523, 3357771
+	     */
+	    codePtr->objArrayPtr[i] = Tcl_DuplicateObj(objPtr);
+	    Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
+	    Tcl_DecrRefCount(objPtr);
+	} else {
+	    codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
+	}
     }
 
     p += TCL_ALIGN(objArrayBytes);	/* align exception range array */
-- 
cgit v0.12


From 9f51e32c984e0ad2e812d241e588c492c4179cf8 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 17 Jul 2011 15:00:43 +0000
Subject: Documentation improvements (small; some revision to parsing script)
 to improve the quality of HTML doc builds.

---
 doc/after.n                    |   4 +-
 doc/break.n                    |   2 +-
 doc/catch.n                    |   6 +-
 doc/continue.n                 |   4 +-
 doc/coroutine.n                |   2 +-
 doc/error.n                    |  11 +-
 doc/exec.n                     |   2 +-
 doc/expr.n                     |  26 +--
 doc/file.n                     |  10 +-
 doc/fileevent.n                |   4 +-
 doc/filename.n                 |   2 +-
 doc/format.n                   |   3 +-
 doc/glob.n                     |   4 +-
 doc/info.n                     |   4 +-
 doc/interp.n                   |  30 ++--
 doc/lassign.n                  |  10 +-
 doc/lindex.n                   |  10 +-
 doc/lset.n                     |   8 +-
 doc/lsort.n                    |  10 +-
 doc/mathfunc.n                 |  11 +-
 doc/next.n                     |   2 +-
 doc/open.n                     |  43 ++---
 doc/package.n                  |   6 +-
 doc/pkgMkIndex.n               |   5 +-
 doc/read.n                     |   7 +-
 doc/refchan.n                  |   6 +-
 doc/registry.n                 |   4 +-
 doc/return.n                   |   3 +-
 doc/safe.n                     |   5 +-
 doc/self.n                     |   2 +-
 doc/socket.n                   |   2 +-
 doc/tclvars.n                  |   3 +-
 doc/throw.n                    |   2 +-
 doc/transchan.n                |   4 +-
 tools/tcltk-man2html-utils.tcl | 377 +++++++++++++++++++++++------------------
 tools/tcltk-man2html.tcl       |  21 ++-
 36 files changed, 379 insertions(+), 276 deletions(-)

diff --git a/doc/after.n b/doc/after.n
index 32d3f40..d6181c6 100644
--- a/doc/after.n
+++ b/doc/after.n
@@ -49,7 +49,7 @@ The command will be executed at global level (outside the context
 of any Tcl procedure).
 If an error occurs while executing the delayed command then 
 the background error will be reported by the command
-registered with \fB interp bgerror\fR.
+registered with \fBinterp bgerror\fR.
 The \fBafter\fR command returns an identifier that can be used
 to cancel the delayed command using \fBafter cancel\fR.
 .TP
@@ -82,7 +82,7 @@ The command returns an identifier that can be used
 to cancel the delayed command using \fBafter cancel\fR.
 If an error occurs while executing the script then the
 background error will be reported by the command
-registered with \fB interp bgerror\fR.
+registered with \fBinterp bgerror\fR.
 .TP
 \fBafter info \fR?\fIid\fR?
 .
diff --git a/doc/break.n b/doc/break.n
index 26b9a18..cef37c6 100644
--- a/doc/break.n
+++ b/doc/break.n
@@ -18,7 +18,7 @@ break \- Abort looping command
 .PP
 This command is typically invoked inside the body of a looping command
 such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR.
-It returns a \fBTCL_BREAK\fR code, which causes a break exception
+It returns a 3 (\fBTCL_BREAK\fR) result code, which causes a break exception
 to occur.
 The exception causes the current script to be aborted
 out to the innermost containing loop command, which then
diff --git a/doc/catch.n b/doc/catch.n
index c4960fe..1da163d 100644
--- a/doc/catch.n
+++ b/doc/catch.n
@@ -78,13 +78,13 @@ the corresponding level; or it may be
 in which case the parameter is
 the relative level (as in \fBuplevel\fR) of the previous \fBCALL\fR. The
 salient differences wrt \fB\-errorinfo\fR are that:
-.IP (1)
+.IP [1]
 it is a machine-readable form that is amenable to processing with
 [\fBforeach\fR {tok prm} ...],
-.IP (2)
+.IP [2]
 it contains the true (substituted) values passed to the functions, instead of
 the static text of the calling sites, and
-.IP (3)
+.IP [3]
 it is coarser-grained, with only one element per stack frame (like procs; no
 separate elements for \fBforeach\fR constructs for example).
 .VE 8.6
diff --git a/doc/continue.n b/doc/continue.n
index e92e450..de2f07c 100644
--- a/doc/continue.n
+++ b/doc/continue.n
@@ -18,8 +18,8 @@ continue \- Skip to the next iteration of a loop
 .PP
 This command is typically invoked inside the body of a looping command
 such as \fBfor\fR or \fBforeach\fR or \fBwhile\fR.
-It returns a \fBTCL_CONTINUE\fR code, which causes a continue exception
-to occur.
+It returns a 4 (\fBTCL_CONTINUE\fR) result code, which causes a continue
+exception to occur.
 The exception causes the current script to be aborted
 out to the innermost containing loop command, which then
 continues with the next iteration of the loop.
diff --git a/doc/coroutine.n b/doc/coroutine.n
index 90674f7..f4b5d5b 100644
--- a/doc/coroutine.n
+++ b/doc/coroutine.n
@@ -111,7 +111,7 @@ for {set i 1} {$i <= 20} {incr i} {
 .SS "DETAILED SEMANTICS"
 .PP
 This example demonstrates that coroutines start from the global namespace, and
-that\fIcommand\fR resolution happens before the coroutine stack is created.
+that \fIcommand\fR resolution happens before the coroutine stack is created.
 .PP
 .CS
 proc report {where level} {
diff --git a/doc/error.n b/doc/error.n
index 31af917..d61bd7b 100644
--- a/doc/error.n
+++ b/doc/error.n
@@ -39,19 +39,19 @@ to return a stack trace reflecting the original point of occurrence
 of the error:
 .PP
 .CS
-\fBcatch {...} errMsg
+catch {...} errMsg
 set savedInfo $::errorInfo
 \&...
-error $errMsg $savedInfo\fR
+\fBerror\fR $errMsg $savedInfo
 .CE
 .PP
 When working with Tcl 8.5 or later, the following code
 should be used instead:
 .PP
 .CS
-\fBcatch {...} errMsg options
+catch {...} errMsg options
 \&...
-return -options $options $errMsg\fR
+return -options $options $errMsg
 .CE
 .PP
 If the \fIcode\fR argument is present, then its value is stored
@@ -73,3 +73,6 @@ if {1+2 != 3} {
 catch(n), return(n)
 .SH KEYWORDS
 error, exception
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/doc/exec.n b/doc/exec.n
index 8dd213f..5072d61 100644
--- a/doc/exec.n
+++ b/doc/exec.n
@@ -239,7 +239,7 @@ names must use the short, cryptic, path format (e.g., using
 instead of
 .QW applbakery.default ),
 which can be obtained with the
-.QW "\fBfile attributes \fIfileName \fB\-shortname\fR"
+.QW "\fBfile attributes\fI fileName \fB\-shortname\fR"
 command.
 .PP
 Two or more forward or backward slashes in a row in a path refer to a
diff --git a/doc/expr.n b/doc/expr.n
index 46e6cf3..2ecd501 100644
--- a/doc/expr.n
+++ b/doc/expr.n
@@ -28,7 +28,7 @@ Expressions almost always yield numeric results
 For example, the expression
 .PP
 .CS
-\fBexpr 8.2 + 6\fR
+\fBexpr\fR 8.2 + 6
 .CE
 .PP
 evaluates to 14.2.
@@ -68,7 +68,8 @@ Operands may be specified in any of the following ways:
 .IP [1]
 As a numeric value, either integer or floating-point.
 .IP [2]
-As a boolean value, using any form understood by \fBstring is boolean\fR.
+As a boolean value, using any form understood by \fBstring is\fR
+\fBboolean\fR.
 .IP [3]
 As a Tcl variable, using standard \fB$\fR notation.
 The variable's value will be used as the operand.
@@ -225,7 +226,7 @@ just as in C, which means that operands are not evaluated if they are
 not needed to determine the outcome.  For example, in the command
 .PP
 .CS
-\fBexpr {$v ? [a] : [b]}\fR
+\fBexpr\fR {$v ? [a] : [b]}
 .CE
 .PP
 only one of
@@ -248,19 +249,19 @@ Tcl function in the \fBtcl::mathfunc\fR namespace.  The processing
 of an expression such as:
 .PP
 .CS
-\fBexpr {sin($x+$y)}\fR
+\fBexpr\fR {sin($x+$y)}
 .CE
 .PP
 is the same in every way as the processing of:
 .PP
 .CS
-\fBexpr {[tcl::mathfunc::sin [expr {$x+$y}]]}\fR
+\fBexpr\fR {[tcl::mathfunc::sin [\fBexpr\fR {$x+$y}]]}
 .CE
 .PP
 which in turn is the same as the processing of:
 .PP
 .CS
-\fBtcl::mathfunc::sin [expr {$x+$y}]\fR
+tcl::mathfunc::sin [\fBexpr\fR {$x+$y}]
 .CE
 .PP
 The executor will search for \fBtcl::mathfunc::sin\fR using the usual
@@ -335,8 +336,8 @@ is that produced by the \fB%g\fR format specifier of Tcl's
 \fBformat\fR command.  For example, the commands
 .PP
 .CS
-\fBexpr {"0x03" > "2"}\fR
-\fBexpr {"0y" < "0x12"}\fR
+\fBexpr\fR {"0x03" > "2"}
+\fBexpr\fR {"0y" < "0x12"}
 .CE
 .PP
 both return 1.  The first comparison is done using integer
@@ -358,9 +359,9 @@ once by the Tcl parser and once by the \fBexpr\fR command.
 For example, the commands
 .PP
 .CS
-\fBset a 3\fR
-\fBset b {$a + 2}\fR
-\fBexpr $b*4\fR
+set a 3
+set b {$a + 2}
+\fBexpr\fR $b*4
 .CE
 .PP
 return 11, not a multiple of 4.
@@ -444,3 +445,6 @@ Copyright (c) 1993 The Regents of the University of California.
 Copyright (c) 1994-2000 Sun Microsystems Incorporated.
 Copyright (c) 2005 by Kevin B. Kenny <kennykb@acm.org>. All rights reserved.
 .fi
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/doc/file.n b/doc/file.n
index 7874807..9205d3b 100644
--- a/doc/file.n
+++ b/doc/file.n
@@ -138,7 +138,7 @@ returned.  For example,
 .RS
 .PP
 .CS
-\fBfile dirname c:/\fR
+\fBfile dirname\fR c:/
 .CE
 .PP
 returns \fBc:/\fR. 
@@ -147,13 +147,13 @@ Note that tilde substitution will only be
 performed if it is necessary to complete the command. For example,
 .PP
 .CS
-\fBfile dirname ~/src/foo.c\fR
+\fBfile dirname\fR ~/src/foo.c
 .CE
 .PP
 returns \fB~/src\fR, whereas
 .PP
 .CS
-\fBfile dirname ~\fR
+\fBfile dirname\fR ~
 .CE
 .PP
 returns \fB/home\fR (or something similar).
@@ -193,7 +193,7 @@ proceed from the current argument.  For example,
 .RS
 .PP
 .CS
-\fBfile join a b /foo bar\fR
+\fBfile join\fR a b /foo bar
 .CE
 .PP
 returns \fB/foo/bar\fR.
@@ -380,7 +380,7 @@ For example, under Unix
 .RS
 .PP
 .CS
-file split /foo/~bar/baz
+\fBfile split\fR /foo/~bar/baz
 .CE
 .PP
 returns
diff --git a/doc/fileevent.n b/doc/fileevent.n
index 7a3d2f7..df48d2a 100644
--- a/doc/fileevent.n
+++ b/doc/fileevent.n
@@ -123,7 +123,7 @@ proc GetData {chan} {
 }
 
 fconfigure $chan -blocking 0 -encoding binary
-fileevent $chan readable [list GetData $chan]
+\fBfileevent\fR $chan readable [list GetData $chan]
 .CE
 .PP
 The next example demonstrates use of \fBgets\fR to read line-oriented
@@ -140,7 +140,7 @@ proc GetData {chan} {
 }
 
 fconfigure $chan -blocking 0 -buffering line -translation crlf
-fileevent $chan readable [list GetData $chan]
+\fBfileevent\fR $chan readable [list GetData $chan]
 .CE
 .SH CREDITS
 .PP
diff --git a/doc/filename.n b/doc/filename.n
index 1fe22f0..d481fc9 100644
--- a/doc/filename.n
+++ b/doc/filename.n
@@ -38,7 +38,7 @@ type of a given path.
 .SH "PATH SYNTAX"
 .PP
 The rules for native names depend on the value reported in the Tcl
-array element \fBtcl_platform(platform)\fR:
+\fBplatform\fR element of the \fBtcl_platform\fR array:
 .TP 10
 \fBUnix\fR
 On Unix and Apple MacOS X platforms, Tcl uses path names where the
diff --git a/doc/format.n b/doc/format.n
index 422e389..23dfe60 100644
--- a/doc/format.n
+++ b/doc/format.n
@@ -141,7 +141,8 @@ function of the \fBexpr\fR command (at least a 64-bit range).
 If neither \fBh\fR nor \fBl\fR are present, the integer value is
 truncated to the same range as that produced by the \fBint()\fR
 function of the \fBexpr\fR command (at least a 32-bit range, but
-determined by the value of \fBtcl_platform(wordSize)\fR).
+determined by the value of the \fBwordSize\fR element of the
+\fBtcl_platform\fR array).
 .SS "MANDATORY CONVERSION TYPE"
 .PP
 The last thing in a conversion specifier is an alphabetic character
diff --git a/doc/glob.n b/doc/glob.n
index 2cff41e..7b71189 100644
--- a/doc/glob.n
+++ b/doc/glob.n
@@ -230,9 +230,9 @@ and will not be
 interpreted as a wildcard character. One solution to this problem is
 to use the Unix style forward slash as a path separator. Windows style
 paths can be converted to Unix style paths with the command
-.QW "\fBfile join $path\fR"
+.QW "\fBfile join\fR \fB$path\fR"
 or
-.QW "\fBfile normalize $path\fR" .
+.QW "\fBfile normalize\fR \fB$path\fR" .
 .SH EXAMPLES
 .PP
 Find all the Tcl files in the current directory:
diff --git a/doc/info.n b/doc/info.n
index cb5c6e6..0001ae9 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -507,8 +507,8 @@ class named \fIclass\fR.
 .VS 8.6
 This subcommand returns a list of direct subclasses of class \fIclass\fR. If
 the optional \fIpattern\fR argument is present, it constrains the list of
-returned classes to those that match it according to the rules of \fBstring
-match\fR.
+returned classes to those that match it according to the rules of
+\fBstring match\fR.
 .VE 8.6
 .TP
 \fBinfo class superclasses\fI class\fR
diff --git a/doc/interp.n b/doc/interp.n
index 2cc082b..02421e1 100644
--- a/doc/interp.n
+++ b/doc/interp.n
@@ -61,10 +61,18 @@ on how the alias mechanism works.
 A qualified interpreter name is a proper Tcl lists containing a subset of its
 ancestors in the interpreter hierarchy, terminated by the string naming the
 interpreter in its immediate master. Interpreter names are relative to the
-interpreter in which they are used. For example, if \fBa\fR is a slave of
-the current interpreter and it has a slave \fBa1\fR, which in turn has a
-slave \fBa11\fR, the qualified name of \fBa11\fR in \fBa\fR is the list
-\fBa1 a11\fR.
+interpreter in which they are used. For example, if
+.QW \fBa\fR
+is a slave of the current interpreter and it has a slave
+.QW \fBa1\fR ,
+which in turn has a slave
+.QW \fBa11\fR ,
+the qualified name of
+.QW \fBa11\fR
+in
+.QW \fBa\fR
+is the list
+.QW "\fBa1 a11\fR" .
 .PP
 The \fBinterp\fR command, described below, accepts qualified interpreter
 names as arguments; the interpreter in which the command is being evaluated
@@ -108,10 +116,12 @@ invoking the command.
 interpreter.  For example,
 .QW "\fBa b\fR"
 identifies an interpreter
-\fBb\fR, which is a slave of interpreter \fBa\fR, which is a slave
-of the invoking interpreter.  An empty list specifies the interpreter
-invoking the command.  \fIsrcCmd\fR gives the name of a new
-command, which will be created in the source interpreter.
+.QW \fBb\fR ,
+which is a slave of interpreter
+.QW \fBa\fR ,
+which is a slave of the invoking interpreter.  An empty list specifies
+the interpreter invoking the command.  \fIsrcCmd\fR gives the name of
+a new command, which will be created in the source interpreter.
 \fITargetPath\fR and \fItargetCmd\fR specify a target interpreter
 and command, and the \fIarg\fR arguments, if any, specify additional
 arguments to \fItargetCmd\fR which are prepended to any arguments specified
@@ -194,8 +204,8 @@ and the current setting is returned.
 This only effects the output of \fBinfo frame\fR, in that exact
 frame-level information for command invocation at the bytecode level
 is only captured with this setting on.
-.PP
 .RS
+.PP
 For example, with code like
 .PP
 .CS
@@ -332,7 +342,7 @@ already trusted.
 Returns the maximum allowable nesting depth for the interpreter
 specified by \fIpath\fR.  If \fInewlimit\fR is specified,
 the interpreter recursion limit will be set so that nesting
-of more than \fInewlimit\fR calls to \fBTcl_Eval()\fR
+of more than \fInewlimit\fR calls to \fBTcl_Eval\fR
 and related procedures in that interpreter will return an error.
 The \fInewlimit\fR value is also returned.
 The \fInewlimit\fR value must be a positive integer between 1 and the
diff --git a/doc/lassign.n b/doc/lassign.n
index f09acfc..6f5042b 100644
--- a/doc/lassign.n
+++ b/doc/lassign.n
@@ -28,17 +28,17 @@ An illustration of how multiple assignment works, and what happens
 when there are either too few or too many elements.
 .PP
 .CS
-lassign {a b c} x y z       ;# Empty return
+\fBlassign\fR {a b c} x y z       ;# Empty return
 puts $x                     ;# Prints "a"
 puts $y                     ;# Prints "b"
 puts $z                     ;# Prints "c"
 
-lassign {d e} x y z         ;# Empty return
+\fBlassign\fR {d e} x y z         ;# Empty return
 puts $x                     ;# Prints "d"
 puts $y                     ;# Prints "e"
 puts $z                     ;# Prints ""
 
-lassign {f g h i} x y       ;# Returns "h i"
+\fBlassign\fR {f g h i} x y       ;# Returns "h i"
 puts $x                     ;# Prints "f"
 puts $y                     ;# Prints "g"
 .CE
@@ -49,10 +49,10 @@ the analogue of the
 command in many shell languages like this:
 .PP
 .CS
-set ::argv [lassign $::argv argumentToReadOff]
+set ::argv [\fBlassign\fR $::argv argumentToReadOff]
 .CE
 .SH "SEE ALSO"
-lindex(n), list(n), lset(n), set(n)
+lindex(n), list(n), lrange(n), lset(n), set(n)
 .SH KEYWORDS
 assign, element, list, multiple, set, variable
 '\"Local Variables:
diff --git a/doc/lindex.n b/doc/lindex.n
index 537b09b..bb272a6 100644
--- a/doc/lindex.n
+++ b/doc/lindex.n
@@ -26,13 +26,13 @@ Tcl list and presented as a single argument.
 If no indices are presented, the command takes the form:
 .PP
 .CS
-lindex list
+\fBlindex \fIlist\fR
 .CE
 .PP
 or
 .PP
 .CS
-lindex list {}
+\fBlindex \fIlist\fR {}
 .CE
 .PP
 In this case, the return value of \fBlindex\fR is simply the value of the
@@ -57,19 +57,19 @@ used in turn to select an element from the previous indexing operation,
 allowing the script to select elements from sublists.  The command,
 .PP
 .CS
-lindex $a 1 2 3
+\fBlindex\fR $a 1 2 3
 .CE
 .PP
 or
 .PP
 .CS
-lindex $a {1 2 3}
+\fBlindex\fR $a {1 2 3}
 .CE
 .PP
 is synonymous with
 .PP
 .CS
-lindex [lindex [lindex $a 1] 2] 3
+\fBlindex\fR [\fBlindex\fR [\fBlindex\fR $a 1] 2] 3
 .CE
 .SH EXAMPLES
 .PP
diff --git a/doc/lset.n b/doc/lset.n
index ec84e09..805de16 100755
--- a/doc/lset.n
+++ b/doc/lset.n
@@ -26,13 +26,13 @@ Finally, it accepts a new value for an element of \fIvarName\fR.
 If no indices are presented, the command takes the form:
 .PP
 .CS
-lset varName newValue
+\fBlset\fR varName newValue
 .CE
 .PP
 or
 .PP
 .CS
-lset varName {} newValue
+\fBlset\fR varName {} newValue
 .CE
 .PP
 In this case, \fInewValue\fR replaces the old value of the variable
@@ -68,13 +68,13 @@ allowing the script to alter elements in sublists (or append elements
 to sublists).  The command,
 .PP
 .CS
-lset a 1 2 newValue
+\fBlset\fR a 1 2 newValue
 .CE
 .PP
 or
 .PP
 .CS
-lset a {1 2} newValue
+\fBlset\fR a {1 2} newValue
 .CE
 .PP
 replaces element 2 of sublist 1 with \fInewValue\fR.
diff --git a/doc/lsort.n b/doc/lsort.n
index 10b8162..8e85f5a 100644
--- a/doc/lsort.n
+++ b/doc/lsort.n
@@ -88,7 +88,7 @@ For example,
 .RS
 .PP
 .CS
-lsort -integer -index 1 \e
+\fBlsort\fR -integer -index 1 \e
       {{First 24} {Second 18} {Third 30}}
 .CE
 .PP
@@ -98,7 +98,7 @@ returns \fB{Second 18} {First 24} {Third 30}\fR,
 '\" This example is from the test suite!
 '\"
 .CS
-lsort -index end-1 \e
+\fBlsort\fR -index end-1 \e
         {{a 1 e i} {b 2 3 f g} {c 4 5 6 d h}}
 .CE
 .PP
@@ -106,7 +106,7 @@ returns \fB{c 4 5 6 d h} {a 1 e i} {b 2 3 f g}\fR,
 and
 .PP
 .CS
-lsort -index {0 1} {
+\fBlsort\fR -index {0 1} {
     {{b i g} 12345}
     {{d e m o} 34512}
     {{c o d e} 54321}
@@ -135,7 +135,7 @@ in turn must be at least 2.
 For example,
 .PP
 .CS
-lsort \-stride 2 {carrot 10 apple 50 banana 25}
+\fBlsort\fR \-stride 2 {carrot 10 apple 50 banana 25}
 .CE
 .PP
 returns
@@ -143,7 +143,7 @@ returns
 and
 .PP
 .CS
-lsort \-stride 2 \-index 1 \-integer {carrot 10 apple 50 banana 25}
+\fBlsort\fR \-stride 2 \-index 1 \-integer {carrot 10 apple 50 banana 25}
 .CE
 .PP
 returns
diff --git a/doc/mathfunc.n b/doc/mathfunc.n
index 0977220..3da6d5a 100644
--- a/doc/mathfunc.n
+++ b/doc/mathfunc.n
@@ -195,16 +195,19 @@ Returns the floating-point remainder of the division of \fIx\fR by
 .TP
 \fBhypot \fIx y\fR
 .
-Computes the length of the hypotenuse of a right-angled triangle
-.QW "\fBsqrt\fR [\fBexpr\fR {\fIx\fB*\fIx\fB+\fIy\fB*\fIy\fR}]".
+Computes the length of the hypotenuse of a right-angled triangle,
+approximately
+.QW "\fBsqrt\fR [\fBexpr\fR {\fIx\fB*\fIx\fB+\fIy\fB*\fIy\fR}]"
+except for being more numerically stable when the two arguments have
+substantially different magnitudes.
 .TP
 \fBint \fIarg\fR
 .
 The argument may be any numeric value.  The integer part of \fIarg\fR
 is determined, and then the low order bits of that integer value up
 to the machine word size are returned as an integer value.  For reference,
-the number of bytes in the machine word are stored in
-\fBtcl_platform(wordSize)\fR.
+the number of bytes in the machine word are stored in the \fBwordSize\fR
+element of the \fBtcl_platform\fR array.
 .TP
 \fBisqrt \fIarg\fR
 .
diff --git a/doc/next.n b/doc/next.n
index 222d8b3..8eb2ba6 100644
--- a/doc/next.n
+++ b/doc/next.n
@@ -34,7 +34,7 @@ chain.
 .PP
 The \fBnextto\fR command is the same as the \fBnext\fR command, except that it
 takes an additional \fIclass\fR argument that identifies a class whose
-implementation of the current method chain (see \fBinfo object call\fR) should
+implementation of the current method chain (see \fBinfo object\fR \fBcall\fR) should
 be used; the method implementation selected will be the one provided by the
 given class, and it must refer to an existing non-filter invocation that lies
 further along the chain than the current implementation.
diff --git a/doc/open.n b/doc/open.n
index fd12962..d4842f2 100644
--- a/doc/open.n
+++ b/doc/open.n
@@ -67,8 +67,8 @@ Set the initial access position  to the end of the file.
 .PP
 All of the legal \fIaccess\fR values above may have the character
 \fBb\fR added as the second or third character in the value to
-indicate that the opened channel should be configured with the
-\fB\-translation binary\fR option, making the channel suitable for 
+indicate that the opened channel should be configured as if with the
+\fBfconfigure\fR \fB\-translation binary\fR option, making the channel suitable for 
 reading or writing of binary data.
 .PP
 In the second form, \fIaccess\fR consists of a list of any of the
@@ -131,7 +131,7 @@ conjunction with the process's file mode creation mask.
 .SH "COMMAND PIPELINES"
 .PP
 If the first character of \fIfileName\fR is
-.QW |
+.QW \fB|\fR
 then the
 remaining characters of \fIfileName\fR are treated as a list of arguments
 that describe a command pipeline to invoke, in the same style as the
@@ -139,10 +139,12 @@ arguments for \fBexec\fR.
 In this case, the channel identifier returned by \fBopen\fR may be used
 to write to the command's input pipe or read from its output pipe,
 depending on the value of \fIaccess\fR.
-If write-only access is used (e.g. \fIaccess\fR is \fBw\fR), then
-standard output for the pipeline is directed to the current standard
+If write-only access is used (e.g. \fIaccess\fR is
+.QW \fBw\fR ),
+then standard output for the pipeline is directed to the current standard
 output unless overridden by the command.
-If read-only access is used (e.g. \fIaccess\fR is \fBr\fR),
+If read-only access is used (e.g. \fIaccess\fR is
+.QW \fBr\fR ),
 standard input for the pipeline is taken from the current standard
 input unless overridden by the command.
 The id of the spawned process is accessible through the \fBpid\fR
@@ -271,7 +273,7 @@ in the second form both input and output buffers are defined.
 (Windows only). This option is query only.
 In case of a serial communication error, \fBread\fR or \fBputs\fR
 returns a general Tcl file I/O error.
-\fBfconfigure -lasterror\fR can be called to get a list of error details.
+\fBfconfigure\fR \fB\-lasterror\fR can be called to get a list of error details.
 See below for an explanation of the various error codes.
 .SH "SERIAL PORT SIGNALS"
 .PP
@@ -283,29 +285,29 @@ lines and handshaking. Here we are using the terms \fIworkstation\fR for
 your computer and \fImodem\fR for the external device, because some signal
 names (DCD, RI) come from modems. Of course your external device may use
 these signal lines for other purposes.
-.IP \fBTXD(output)\fR
+.IP \fBTXD\fR(output)
 \fBTransmitted Data:\fR Outgoing serial data.
-.IP \fBRXD(input)\fR
+.IP \fBRXD\fR(input)
 \fBReceived Data:\fRIncoming serial data.
-.IP \fBRTS(output)\fR
+.IP \fBRTS\fR(output)
 \fBRequest To Send:\fR This hardware handshake line informs the modem that
 your workstation is ready to receive data. Your workstation may
 automatically reset this signal to indicate that the input buffer is full.
-.IP \fBCTS(input)\fR
+.IP \fBCTS\fR(input)
 \fBClear To Send:\fR The complement to RTS. Indicates that the modem is
 ready to receive data.
-.IP \fBDTR(output)\fR
+.IP \fBDTR\fR(output)
 \fBData Terminal Ready:\fR This signal tells the modem that the workstation
 is ready to establish a link. DTR is often enabled automatically whenever a
 serial port is opened.
-.IP \fBDSR(input)\fR
+.IP \fBDSR\fR(input)
 \fBData Set Ready:\fR The complement to DTR. Tells the workstation that the
 modem is ready to establish a link.
-.IP \fBDCD(input)\fR
+.IP \fBDCD\fR(input)
 \fBData Carrier Detect:\fR This line becomes active when a modem detects a
 .QW Carrier
 signal.
-.IP \fBRI(input)\fR
+.IP \fBRI\fR(input)
 \fBRing Indicator:\fR Goes active when the modem detects an incoming call.
 .IP \fBBREAK\fR
 A BREAK condition is not a hardware signal line, but a logical zero on the
@@ -321,13 +323,13 @@ event polling in background. The external device may have been switched
 off, the data lines may be noisy, system buffers may overrun or your mode
 settings may be wrong.  That is why a reliable software should always
 \fBcatch\fR serial read operations.  In cases of an error Tcl returns a
-general file I/O error.  Then \fBfconfigure -lasterror\fR may help to
+general file I/O error.  Then \fBfconfigure\fR \fB\-lasterror\fR may help to
 locate the problem.  The following error codes may be returned.
 .TP 10
 \fBRXOVER\fR
 .
 Windows input buffer overrun. The data comes faster than your scripts reads
-it or your system is overloaded. Use \fBfconfigure -sysbuffer\fR to avoid a
+it or your system is overloaded. Use \fBfconfigure\fR \fB\-sysbuffer\fR to avoid a
 temporary bottleneck and/or make your script faster.
 .TP 10
 \fBTXFULL\fR
@@ -345,13 +347,13 @@ and/or setup a lower(1) interrupt threshold value.
 \fBRXPARITY\fR
 .
 A parity error has been detected by your UART.
-Wrong parity settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
+Wrong parity settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line (RXD)
 may cause this error.
 .TP 10
 \fBFRAME\fR
 .
 A stop-bit error has been detected by your UART.
-Wrong mode settings with \fBfconfigure -mode\fR or a noisy data line (RXD)
+Wrong mode settings with \fBfconfigure\fR \fB\-mode\fR or a noisy data line (RXD)
 may cause this error.
 .TP 10
 \fBBREAK\fR
@@ -458,3 +460,6 @@ puts(n), exec(n), pid(n), fopen(3)
 .SH KEYWORDS
 access mode, append, create, file, non-blocking, open, permissions,
 pipeline, process, serial
+'\"Local Variables:
+'\"mode: nroff
+'\"End:
diff --git a/doc/package.n b/doc/package.n
index c59b645..6cf8991 100644
--- a/doc/package.n
+++ b/doc/package.n
@@ -12,7 +12,7 @@
 package \- Facilities for package loading and version control
 .SH SYNOPSIS
 .nf
-\fBpackage forget ?\fIpackage package ...\fR?
+\fBpackage forget\fR ?\fIpackage package ...\fR?
 \fBpackage ifneeded \fIpackage version\fR ?\fIscript\fR?
 \fBpackage names\fR
 \fBpackage present \fIpackage \fR?\fIrequirement...\fR?
@@ -43,7 +43,7 @@ primarily by system scripts that maintain the package database.
 The behavior of the \fBpackage\fR command is determined by its first argument.
 The following forms are permitted:
 .TP
-\fBpackage forget ?\fIpackage package ...\fR?
+\fBpackage forget\fR ?\fIpackage package ...\fR?
 .
 Removes all information about each specified package from this interpreter,
 including information provided by both \fBpackage ifneeded\fR and
@@ -175,7 +175,7 @@ If \fIcommand\fR is specified as an empty string, then the current
 .
 Compares the two version numbers given by \fIversion1\fR and \fIversion2\fR.
 Returns -1 if \fIversion1\fR is an earlier version than \fIversion2\fR,
-0 if they are equal, and 1 if \fIversion1\fR is later than \fBversion2\fR.
+0 if they are equal, and 1 if \fIversion1\fR is later than \fIversion2\fR.
 .TP
 \fBpackage versions \fIpackage\fR
 .
diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n
index 93a5f79..07370ef 100644
--- a/doc/pkgMkIndex.n
+++ b/doc/pkgMkIndex.n
@@ -12,7 +12,7 @@
 pkg_mkIndex \- Build an index for automatic loading of packages
 .SH SYNOPSIS
 .nf
-\fBpkg_mkIndex ?\fIoptions...\fR? \fIdir\fR ?\fIpattern pattern ...\fR?
+\fBpkg_mkIndex\fR ?\fIoptions...\fR? \fIdir\fR ?\fIpattern pattern ...\fR?
 .fi
 .BE
 .SH DESCRIPTION
@@ -228,3 +228,6 @@ the binary file may mask the package defined by the scripts.
 package(n)
 .SH KEYWORDS
 auto-load, index, package, version
+'\"Local Variables:
+'\"mode: nroff
+'\"End:
diff --git a/doc/read.n b/doc/read.n
index a64e079..007c0ac 100644
--- a/doc/read.n
+++ b/doc/read.n
@@ -54,7 +54,7 @@ which \fBfconfigure\fR will alter input.
 '\" Note:  this advice actually applies to many versions of Tcl
 .PP
 For most applications a channel connected to a serial port should be
-configured to be nonblocking: \fBfconfigure \fIchannelId \fB\-blocking
+configured to be nonblocking: \fBfconfigure\fI channelId \fB\-blocking
 \fI0\fR.  Then \fBread\fR behaves much like described above.  Care
 must be taken when using \fBread\fR on blocking serial ports:
 .TP
@@ -66,7 +66,7 @@ from the serial port.
 \fBread \fIchannelId\fR 
 .
 In this form \fBread\fR blocks until the reception of the end-of-file
-character, see \fBfconfigure -eofchar\fR. If there no end-of-file
+character, see \fBfconfigure\fR \fB\-eofchar\fR. If there no end-of-file
 character has been configured for the channel, then \fBread\fR will
 block forever.
 .SH "EXAMPLE"
@@ -84,3 +84,6 @@ set lines [split $data \en]
 file(n), eof(n), fblocked(n), fconfigure(n), Tcl_StandardChannels(3)
 .SH KEYWORDS
 blocking, channel, end of line, end of file, nonblocking, read, translation, encoding
+'\"Local Variables:
+'\"mode: nroff
+'\"End:
diff --git a/doc/refchan.n b/doc/refchan.n
index c4066b6..a51c3d7 100644
--- a/doc/refchan.n
+++ b/doc/refchan.n
@@ -17,10 +17,10 @@ refchan \- command handler API of reflected channels
 .PP
 The Tcl-level handler for a reflected channel has to be a command with
 subcommands (termed an \fIensemble\fR, as it is a command such as that
-created by \fBnamespace ensemble create\fR, though the implementation
+created by \fBnamespace ensemble\fR \fBcreate\fR, though the implementation
 of handlers for reflected channel \fIis not\fR tied to \fBnamespace
-ensemble\fRs in any way; see \fBEXAMPLE\fR below for how to build a
-\fBclass\fR that supports the API). Note that \fIcmdPrefix\fR is whatever was
+ensemble\fRs in any way; see \fBEXAMPLE\fR below for how to build an
+\fBoo::class\fR that supports the API). Note that \fIcmdPrefix\fR is whatever was
 specified in the call to \fBchan create\fR, and may consist of
 multiple arguments; this will be expanded to multiple words in place
 of the prefix.
diff --git a/doc/registry.n b/doc/registry.n
index b9b36d1..2e69b1e 100644
--- a/doc/registry.n
+++ b/doc/registry.n
@@ -103,7 +103,7 @@ data, see \fBSUPPORTED TYPES\fR, below.
 If \fIpattern\fR is not specified, returns a list of names of all the
 subkeys of \fIkeyName\fR.  If \fIpattern\fR is specified, only those
 names matching \fIpattern\fR are returned.  Matching is determined
-using the same rules as for \fBstring\fR \fBmatch\fR.  If the
+using the same rules as for \fBstring match\fR.  If the
 specified \fIkeyName\fR does not exist, then an error is generated.
 .TP
 \fBregistry set \fIkeyName\fR ?\fIvalueName data \fR?\fItype\fR??
@@ -127,7 +127,7 @@ Returns the type of the value \fIvalueName\fR in the key
 If \fIpattern\fR is not specified, returns a list of names of all the
 values of \fIkeyName\fR.  If \fIpattern\fR is specified, only those
 names matching \fIpattern\fR are returned.  Matching is determined
-using the same rules as for \fBstring\fR \fBmatch\fR.
+using the same rules as for \fBstring match\fR.
 .SH "SUPPORTED TYPES"
 Each value under a key in the registry contains some data of a
 particular type in a type-specific representation.  The \fBregistry\fR
diff --git a/doc/return.n b/doc/return.n
index 6bfa346..b59a93d 100644
--- a/doc/return.n
+++ b/doc/return.n
@@ -317,7 +317,8 @@ proc myReturn {args} {
 }
 .CE
 .SH "SEE ALSO"
-break(n), catch(n), continue(n), dict(n), error(n), proc(n), source(n), tclvars(n)
+break(n), catch(n), continue(n), dict(n), error(n), proc(n),
+source(n), tclvars(n), throw(n), try(n)
 .SH KEYWORDS
 break, catch, continue, error, exception, procedure, result, return
 .\" Local Variables:
diff --git a/doc/safe.n b/doc/safe.n
index 843eaf5..a5acb02 100644
--- a/doc/safe.n
+++ b/doc/safe.n
@@ -76,7 +76,7 @@ If the \fIslave\fR argument is omitted, a name will be generated.
 \fB::safe::interpInit\fR \fIslave\fR ?\fIoptions...\fR?
 This command is similar to \fBinterpCreate\fR except it that does not
 create the safe interpreter. \fIslave\fR must have been created by some
-other means, like \fBinterp create \-safe\fR.
+other means, like \fBinterp create\fR \fB\-safe\fR.
 .TP
 \fB::safe::interpConfigure\fR \fIslave\fR ?\fIoptions...\fR?
 If no \fIoptions\fR are given, returns the settings for all options for the
@@ -354,3 +354,6 @@ interp(n), library(n), load(n), package(n), source(n), unknown(n)
 .SH KEYWORDS
 alias, auto\-loading, auto_mkindex, load, master interpreter, safe
 interpreter, slave interpreter, source
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
diff --git a/doc/self.n b/doc/self.n
index 11779ff..348c38f 100644
--- a/doc/self.n
+++ b/doc/self.n
@@ -29,7 +29,7 @@ object\fR was invoked. The supported subcommands are:
 .
 This returns a two-element list describing the method implementations used to
 implement the current call chain. The first element is the same as would be
-reported by \fBinfo object call\fR for the current method (except that this
+reported by \fBinfo object\fR \fBcall\fR for the current method (except that this
 also reports useful values from within constructors and destructors, whose
 names are reported as \fB<constructor>\fR and \fB<destructor>\fR
 respectively), and the second element is an index into the first element's
diff --git a/doc/socket.n b/doc/socket.n
index 0cb0595..9c9366d 100644
--- a/doc/socket.n
+++ b/doc/socket.n
@@ -88,7 +88,7 @@ mode using:
 \fBchan configure \fIchan \fB\-blocking 0\fR
 .CE
 .PP
-See the \fBchan\fR \fBconfigure\fR command for more details.
+See the \fBchan configure\fR command for more details.
 
 The Tcl event loop should be running while an asynchronous connection
 is in progress, because it may have to do several connection attempts
diff --git a/doc/tclvars.n b/doc/tclvars.n
index 27f9cc2..b126b7f 100644
--- a/doc/tclvars.n
+++ b/doc/tclvars.n
@@ -102,7 +102,8 @@ This variable is only used when initializing the \fBauto_path\fR variable.
 .TP
 \fBenv(TCL_INTERP_DEBUG_FRAME)\fR
 .
-If existing, it has the same effect as running \fBinterp debug {} -frame 1\fR
+If existing, it has the same effect as running \fBinterp debug\fR
+\fB{} -frame 1\fR
 as the very first command of each new Tcl interpreter.
 .RE
 .TP
diff --git a/doc/throw.n b/doc/throw.n
index a76609b..d49fb24 100644
--- a/doc/throw.n
+++ b/doc/throw.n
@@ -40,7 +40,7 @@ The following produces an error that is identical to that produced by
 \fBthrow\fR {ARITH DIVZERO {divide by zero}} {divide by zero}
 .CE
 .SH "SEE ALSO"
-catch(n), error(n), return(n), try(n)
+catch(n), error(n), return(n), tclvars(n), try(n)
 .SH "KEYWORDS"
 error, exception
 '\" Local Variables:
diff --git a/doc/transchan.n b/doc/transchan.n
index 9de9a87..e308e13 100644
--- a/doc/transchan.n
+++ b/doc/transchan.n
@@ -54,7 +54,7 @@ if the interpreter is deleted.
 This mandatory subcommand is called first, and then never again (for the given
 \fIhandle\fR). Its responsibility is to initialize all parts of the
 transformation at the Tcl level. The \fImode\fR is a list containing any of
-\fBread\fR and \fBwrite\fR.
+\fBread \fRand \fBwrite\fR.
 .RS
 .TP
 \fBwrite\fR
@@ -73,7 +73,7 @@ as error thrown by \fBchan push\fR.
 .SS "READ-RELATED SUBCOMMANDS"
 .PP
 These subcommands are used for handling transformations applied to readable
-channels; though strictly \fBread\fR is optional, it must be supported if any
+channels; though strictly \fBread \fRis optional, it must be supported if any
 of the others is or the channel will be made non-readable.
 .TP
 \fIcmdPrefix \fBdrain \fIhandle\fR
diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index e1a91a9..16e9a93 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -489,6 +489,16 @@ proc output-IP-list {context code rest} {
 	    man-puts <P>
 	}
 	set dl "<DL class=\"[string tolower $manual(section)]\">"
+	set enddl "</DL>"
+	if {$code eq ".IP"} {
+	    if {[regexp {^\[[\da-f]+\]$} $rest]} {
+		set dl "<OL class=\"[string tolower $manual(section)]\">"
+		set enddl "</OL>"
+	    } elseif {"&#8226;" eq $rest} {
+		set dl "<UL class=\"[string tolower $manual(section)]\">"
+		set enddl "</UL>"
+	    }
+	}
 	man-puts $dl
 	lappend manual(section-toc) $dl
 	backup-text 1
@@ -504,11 +514,12 @@ proc output-IP-list {context code rest} {
 			    output-IP-list .IP $code $rest
 			    continue
 			}
-			if {$manual(section) eq "ARGUMENTS" || \
-				[regexp {^\[\d+\]$} $rest]} {
+			if {$manual(section) eq "ARGUMENTS"} {
 			    man-puts "$para<DT>$rest<DD>"
+			} elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} {
+			    man-puts "$para<LI value=\"$value\">"
 			} elseif {"&#8226;" eq $rest} {
-			    man-puts "$para<DT><DD>$rest&nbsp;"
+			    man-puts "$para<LI>"
 			} else {
 			    man-puts "$para<DT>[long-toc $rest]<DD>"
 			}
@@ -542,14 +553,13 @@ proc output-IP-list {context code rest} {
 			} elseif {[match-text @rest .RE]} {
 			    # gad, this is getting ridiculous
 			    if {!$accept_RE} {
-				man-puts "</DL><P>$rest<DL>"
+				man-puts "$enddl<P>$rest$dl"
 				backup-text 1
 				set para {}
 				break
-			    } else {
-				man-puts "<P>$rest"
-				incr accept_RE -1
 			    }
+			    man-puts "<P>$rest"
+			    incr accept_RE -1
 			} elseif {$accept_RE} {
 			    output-directive $line
 			} else {
@@ -574,8 +584,8 @@ proc output-IP-list {context code rest} {
 	    }
 	    set para <P>
 	}
-	man-puts "$para</DL>"
-	lappend manual(section-toc) </DL>
+	man-puts "$para$enddl"
+	lappend manual(section-toc) $enddl
 	if {$accept_RE} {
 	    manerror "missing .RE in output-IP-list"
 	}
@@ -611,31 +621,44 @@ proc output-name {line} {
 proc cross-reference {ref} {
     global manual remap_link_target
     global ensemble_commands exclude_refs_map exclude_when_followed_by_map
-    set lref [string tolower $ref]
+    set manname $manual(name)
+    set mantail $manual(tail)
     if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref]} {
 	set lref $ref
+	##
+	## apply a link remapping if available
+	##
+	if {[info exists remap_link_target($lref)]} {
+	    set lref $remap_link_target($lref)
+	}
     } elseif {$ref eq "Tcl"} {
 	set lref $ref
     } elseif {
 	[regexp {^[A-Z0-9 ?!]+$} $ref]
-	&& [info exists manual($manual(name)-id-$ref)]
+	&& [info exists manual($manname-id-$ref)]
     } {
-	return "<A HREF=\"#$manual($manual(name)-id-$ref)\">$ref</A>"
-    }
-    ##
-    ## apply a link remapping if available
-    ##
-    if {[info exists remap_link_target($lref)]} {
-	set lref $remap_link_target($lref)
+	return "<A HREF=\"#$manual($manname-id-$ref)\">$ref</A>"
+    } else {
+	set lref [string tolower $ref]
+	##
+	## apply a link remapping if available
+	##
+	if {[info exists remap_link_target($lref)]} {
+	    set lref $remap_link_target($lref)
+	}
     }
     ##
     ## nothing to reference
     ##
     if {![info exists manual(name-$lref)]} {
 	foreach name $ensemble_commands {
-	    if {[regexp "^$name \[a-z0-9]*\$" $lref] && \
-		    [info exists manual(name-$name)] && \
-		    $manual(tail) ne "$name.n"} {
+	    if {
+		[regexp "^$name \[a-z0-9]*\$" $lref] &&
+		[info exists manual(name-$name)] &&
+		$mantail ne "$name.n" &&
+		(![info exists exclude_refs_map($mantail)] ||
+		$manual(name-$name) ni $exclude_refs_map($mantail))
+	    } {
 		return "<A HREF=\"../$manual(name-$name).htm\">$ref</A>"
 	    }
 	}
@@ -644,43 +667,45 @@ proc cross-reference {ref} {
 	}
 	return $ref
     }
+    set manref $manual(name-$lref)
     ##
     ## would be a self reference
     ##
-    foreach name $manual(name-$lref) {
-	if {"$manual(wing-file)/$manual(name)" in $name} {
+    foreach name $manref {
+	if {"$manual(wing-file)/$manname" in $name} {
 	    return $ref
 	}
     }
     ##
     ## multiple choices for reference
     ##
-    if {[llength $manual(name-$lref)] > 1} {
-	set tcl_i [lsearch -glob $manual(name-$lref) *TclCmd*]
-	set tcl_ref [lindex $manual(name-$lref) $tcl_i]
-	set tk_i [lsearch -glob $manual(name-$lref) *TkCmd*]
-	set tk_ref [lindex $manual(name-$lref) $tk_i]
+    if {[llength $manref] > 1} {
+	set tcl_i [lsearch -glob $manref *TclCmd*]
 	if {$tcl_i >= 0 && $manual(wing-file) eq "TclCmd"
 		|| $manual(wing-file) eq "TclLib"} {
+	    set tcl_ref [lindex $manref $tcl_i]
 	    return "<A HREF=\"../$tcl_ref.htm\">$ref</A>"
 	}
+	set tk_i [lsearch -glob $manref *TkCmd*]
 	if {$tk_i >= 0 && $manual(wing-file) eq "TkCmd"
 		|| $manual(wing-file) eq "TkLib"} {
+	    set tk_ref [lindex $manref $tk_i]
 	    return "<A HREF=\"../$tk_ref.htm\">$ref</A>"
 	}
-	if {$lref eq "exit" && $manual(tail) eq "tclsh.1" && $tcl_i >= 0} {
+	if {$lref eq "exit" && $mantail eq "tclsh.1" && $tcl_i >= 0} {
+	    set tcl_ref [lindex $manref $tcl_i]
 	    return "<A HREF=\"../$tcl_ref.htm\">$ref</A>"
 	}
-	puts stderr "multiple cross reference to $ref in $manual(name-$lref) from $manual(wing-file)/$manual(tail)"
+	puts stderr "multiple cross reference to $ref in $manref from $manual(wing-file)/$mantail"
 	return $ref
     }
     ##
     ## exceptions, sigh, to the rule
     ##
-    if {[info exists exclude_when_followed_by_map($manual(tail))]} {
+    if {[info exists exclude_when_followed_by_map($mantail)]} {
 	upvar 1 tail tail
 	set following_word [lindex [regexp -inline {\S+} $tail] 0]
-	foreach {this that} $exclude_when_followed_by_map($manual(tail)) {
+	foreach {this that} $exclude_when_followed_by_map($mantail) {
 	    # only a ref if $this is not followed by $that
 	    if {$lref eq $this && [string match $that* $following_word]} {
 		return $ref
@@ -688,15 +713,15 @@ proc cross-reference {ref} {
 	}
     }
     if {
-	[info exists exclude_refs_map($manual(tail))]
-	&& $lref in $exclude_refs_map($manual(tail))
+	[info exists exclude_refs_map($mantail)]
+	&& $lref in $exclude_refs_map($mantail)
     } {
 	return $ref
     }
     ##
     ## return the cross reference
     ##
-    return "<A HREF=\"../$manual(name-$lref).htm\">$ref</A>"
+    return "<A HREF=\"../$manref.htm\">$ref</A>"
 }
 ##
 ## reference generation errors
@@ -711,148 +736,170 @@ proc reference-error {msg text} {
 ##
 proc insert-cross-references {text} {
     global manual
-    ##
-    ## we identify cross references by:
-    ##     ``quotation''
-    ##    <B>emboldening</B>
-    ##    Tcl_ prefix
-    ##    Tk_ prefix
-    ##	  [a-zA-Z0-9]+ manual entry
-    ## and we avoid messing with already anchored text
-    ##
-    ##
-    ## find where each item lives
-    ##
-    array set offset [list \
-	    anchor [string first {<A } $text] \
-	    end-anchor [string first {</A>} $text] \
-	    quote [string first {``} $text] \
-	    end-quote [string first {''} $text] \
-	    bold [string first {<B>} $text] \
-	    end-bold [string first {</B>} $text] \
-	    tcl [string first {Tcl_} $text] \
-	    tk [string first {Tk_} $text] \
-	    Tcl1 [string first {Tcl manual entry} $text] \
-	    Tcl2 [string first {Tcl overview manual entry} $text] \
-	    ]
-    ##
-    ## accumulate a list
-    ##
-    foreach name [array names offset] {
-	if {$offset($name) >= 0} {
-	    set invert($offset($name)) $name
-	    lappend offsets $offset($name)
-	}
-    }
-    ##
-    ## if nothing, then we're done.
-    ##
-    if {![info exists offsets]} {
-	return $text
-    }
-    ##
-    ## sort the offsets
-    ##
-    set offsets [lsort -integer $offsets]
-    ##
-    ## see which we want to use
-    ##
-    switch -exact -- $invert([lindex $offsets 0]) {
-	anchor {
-	    if {$offset(end-anchor) < 0} {
-		return [reference-error {Missing end anchor} $text]
+    set result ""
+
+    while 1 {
+	##
+	## we identify cross references by:
+	##     ``quotation''
+	##    <B>emboldening</B>
+	##    Tcl_ prefix
+	##    Tk_ prefix
+	##	  [a-zA-Z0-9]+ manual entry
+	## and we avoid messing with already anchored text
+	##
+	##
+	## find where each item lives - EXPENSIVE - and accumulate a list
+	##
+	unset -nocomplain offsets
+	foreach {name pattern} {
+	    anchor     {<A }	end-anchor {</A>}
+	    quote      {``}	end-quote  {''}
+	    bold       {<B>}	end-bold   {</B>}
+	    tcl        {Tcl_}
+	    tk         {Tk_}
+	    Tcl1       {Tcl manual entry}
+	    Tcl2       {Tcl overview manual entry}
+	    url	       {http://}
+	} {
+	    set o [string first $pattern $text]
+	    if {[set offset($name) $o] >= 0} {
+		set invert($o) $name
+		lappend offsets $o
 	    }
-	    set head [string range $text 0 $offset(end-anchor)]
-	    set tail [string range $text [expr {$offset(end-anchor)+1}] end]
-	    return $head[insert-cross-references $tail]
 	}
-	quote {
-	    if {$offset(end-quote) < 0} {
-		return [reference-error "Missing end quote" $text]
-	    }
-	    if {$invert([lindex $offsets 1]) eq "tk"} {
-		set offsets [lreplace $offsets 1 1]
-	    }
-	    if {$invert([lindex $offsets 1]) eq "tcl"} {
-		set offsets [lreplace $offsets 1 1]
+	##
+	## if nothing, then we're done.
+	##
+	if {![info exists offsets]} {
+	    return [append result $text]
+	}
+	##
+	## sort the offsets
+	##
+	set offsets [lsort -integer $offsets]
+	##
+	## see which we want to use
+	##
+	switch -exact -- $invert([lindex $offsets 0]) {
+	    anchor {
+		if {$offset(end-anchor) < 0} {
+		    return [reference-error {Missing end anchor} $text]
+		}
+		append result [string range $text 0 $offset(end-anchor)]
+		set text [string range $text[set text ""] \
+			      [expr {$offset(end-anchor)+1}] end]
+		continue
 	    }
-	    switch -exact -- $invert([lindex $offsets 1]) {
-		end-quote {
-		    set head [string range $text 0 [expr {$offset(quote)-1}]]
-		    set body [string range $text [expr {$offset(quote)+2}] \
-			    [expr {$offset(end-quote)-1}]]
-		    set tail [string range $text \
-			    [expr {$offset(end-quote)+2}] end]
-		    return "$head``[cross-reference $body]''[insert-cross-references $tail]"
+	    quote {
+		if {$offset(end-quote) < 0} {
+		    return [reference-error "Missing end quote" $text]
 		}
-		bold -
-		anchor {
-		    set head [string range $text \
-			    0 [expr {$offset(end-quote)+1}]]
-		    set tail [string range $text \
-			    [expr {$offset(end-quote)+2}] end]
-		    return "$head[insert-cross-references $tail]"
+		if {$invert([lindex $offsets 1]) in {tcl tk}} {
+		    set offsets [lreplace $offsets 1 1]
 		}
+		switch -exact -- $invert([lindex $offsets 1]) {
+		    end-quote {
+			append result [string range $text 0 [expr {$offset(quote)-1}]]
+			set body [string range $text [expr {$offset(quote)+2}] \
+				      [expr {$offset(end-quote)-1}]]
+			set text [string range $text[set text ""] \
+				      [expr {$offset(end-quote)+2}] end]
+			set tail $text
+			append result `` [cross-reference $body] ''
+			continue
+		    }
+		    bold -
+		    anchor {
+			append result [string range $text \
+				      0 [expr {$offset(end-quote)+1}]]
+			set text [string range $text[set text ""] \
+				      [expr {$offset(end-quote)+2}] end]
+			continue
+		    }
+		}
+		return [reference-error "Uncaught quote case" $text]
 	    }
-	    return [reference-error "Uncaught quote case" $text]
-	}
-	bold {
-	    if {$offset(end-bold) < 0} {
-		return $text
-	    }
-	    if {$invert([lindex $offsets 1]) eq "tk"} {
-		set offsets [lreplace $offsets 1 1]
-	    }
-	    if {$invert([lindex $offsets 1]) eq "tcl"} {
-		set offsets [lreplace $offsets 1 1]
+	    bold {
+		if {$offset(end-bold) < 0} {
+		    return [append result $text]
+		}
+		if {$invert([lindex $offsets 1]) in {tcl tk}} {
+		    set offsets [lreplace $offsets 1 1]
+		}
+		switch -exact -- $invert([lindex $offsets 1]) {
+		    url - end-bold {
+			append result \
+			    [string range $text 0 [expr {$offset(bold)-1}]]
+			set body [string range $text [expr {$offset(bold)+3}] \
+				      [expr {$offset(end-bold)-1}]]
+			set text [string range $text[set text ""] \
+				      [expr {$offset(end-bold)+4}] end]
+			set tail $text
+			regsub {http://[\w/.]+} $body {<A HREF="&">&</A>} body
+			append result <B> [cross-reference $body] </B>
+			continue
+		    }
+		    anchor {
+			append result \
+			    [string range $text 0 [expr {$offset(end-bold)+3}]]
+			set text [string range $text[set text ""] \
+				      [expr {$offset(end-bold)+4}] end]
+			continue
+		    }
+		    default {
+			return [reference-error "Uncaught bold case" $text]
+		    }
+		}
 	    }
-	    switch -exact -- $invert([lindex $offsets 1]) {
-		end-bold {
-		    set head [string range $text 0 [expr {$offset(bold)-1}]]
-		    set body [string range $text [expr {$offset(bold)+3}] \
-			    [expr {$offset(end-bold)-1}]]
-		    set tail [string range $text \
-			    [expr {$offset(end-bold)+4}] end]
-		    return "$head<B>[cross-reference $body]</B>[insert-cross-references $tail]"
+	    tk {
+		append result [string range $text 0 [expr {$offset(tk)-1}]]
+		if {![regexp -indices -start $offset(tk) {Tk_\w+} $text range]} {
+		    return [reference-error "Tk regexp failed" $text]
 		}
-		anchor {
-		    set head [string range $text \
-			    0 [expr {$offset(end-bold)+3}]]
-		    set tail [string range $text \
-			    [expr {$offset(end-bold)+4}] end]
-		    return "$head[insert-cross-references $tail]"
+		set body [string range $text {*}$range]
+		set text [string range $text[set text ""] \
+			      [expr {[lindex $range 1]+1}] end]
+		set tail $text
+		append result [cross-reference $body]
+		continue
+	    }
+	    tcl {
+		append result [string range $text 0 [expr {$offset(tcl)-1}]]
+		if {![regexp -indices -start $offset(tcl) {Tcl_\w+} $text range]} {
+		    return [reference-error "Tcl regexp failed" $text]
 		}
+		set body [string range $text {*}$range]
+		set text [string range $text[set text ""] \
+			      [expr {[lindex $range 1]+1}] end]
+		set tail $text
+		append result [cross-reference $body]
+		continue
 	    }
-	    return [reference-error "Uncaught bold case" $text]
-	}
-	tk {
-	    set head [string range $text 0 [expr {$offset(tk)-1}]]
-	    set tail [string range $text $offset(tk) end]
-	    if {![regexp {^(Tk_\w+)(.*)$} $tail all body tail]} {
-		return [reference-error "Tk regexp failed" $text]
+	    Tcl1 -
+	    Tcl2 {
+		set off [lindex $offsets 0]
+		append result [string range $text 0 [expr {$off-1}]]
+		set text [string range $text[set text ""] [expr {$off+3}] end]
+		set tail $text
+		append result [cross-reference Tcl]
+		continue
 	    }
-	    return $head[cross-reference $body][insert-cross-references $tail]
-	}
-	tcl {
-	    set head [string range $text 0 [expr {$offset(tcl)-1}]]
-	    set tail [string range $text $offset(tcl) end]
-	    if {![regexp {^(Tcl_\w+)(.*)$} $tail all body tail]} {
-		return [reference-error {Tcl regexp failed} $text]
+	    url {
+		set off [lindex $offsets 0]
+		append result [string range $text 0 [expr {$off-1}]]
+		regexp -indices -start $off {http://[\w/.]+} $text range
+		set url [string range $text {*}$range]
+		append result "<A HREF=\"$url\">" $url "</A>"
+		set text [string range $text[set text ""] \
+			      [expr {[lindex $range 1]+1}] end]
+		continue
+	    }
+	    end-anchor -
+	    end-bold -
+	    end-quote {
+		return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
 	    }
-	    return $head[cross-reference $body][insert-cross-references $tail]
-	}
-	Tcl1 -
-	Tcl2 {
-	    set off [lindex $offsets 0]
-	    set head [string range $text 0 [expr {$off-1}]]
-	    set body Tcl
-	    set tail [string range $text [expr {$off+3}] end]
-	    return $head[cross-reference $body][insert-cross-references $tail]
-	}
-	end-anchor -
-	end-bold -
-	end-quote {
-	    return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
 	}
     }
 }
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index c528153..33d9ff9 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -810,11 +810,27 @@ array set remap_link_target {
     stdin  Tcl_GetStdChannel
     stdout Tcl_GetStdChannel
     stderr Tcl_GetStdChannel
-    safe   {Safe&nbsp;Base}
     style  ttk::style
     {style map} ttk::style
+    {tk busy}   busy
+    library     auto_execok
+    safe-tcl    safe
+    tclvars     env
+    tcl_break   catch
+    tcl_continue catch
+    tcl_error   catch
+    tcl_ok      catch
+    tcl_return  catch
+    int()       mathfunc
+    wide()      mathfunc
+    packagens   pkg::create
+    pkgMkIndex  pkg_mkIndex
+    pkg_mkIndex pkg_mkIndex
+    Tcl_Obj     Tcl_NewObj
+    Tcl_ObjType Tcl_RegisterObjType
 }
 array set exclude_refs_map {
+    bind.n		{button destroy option}
     clock.n		{next}
     history.n		{exec}
     next.n		{unknown}
@@ -822,13 +838,16 @@ array set exclude_refs_map {
     canvas.n		{bitmap text}
     checkbutton.n	{image}
     clipboard.n		{string}
+    interp.n		{time}
     menu.n		{checkbutton radiobutton}
     options.n		{bitmap image set}
     radiobutton.n	{image}
+    safe.n		{join split}
     scrollbar.n		{set}
     selection.n		{string}
     tcltest.n		{error}
     tkvars.n		{tk}
+    tm.n		{exec}
     ttk_checkbutton.n	{variable}
     ttk_combobox.n	{selection}
     ttk_entry.n		{focus variable}
-- 
cgit v0.12


From 1862ab1259270b5a83e955528dccc4b63c652648 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 18 Jul 2011 15:24:59 +0000
Subject: More small documentation improvements.

---
 doc/binary.n                   |  4 ++--
 doc/clock.n                    |  8 ++++----
 doc/file.n                     |  6 +++---
 doc/http.n                     |  4 ++--
 doc/interp.n                   |  4 ++--
 doc/lsearch.n                  |  2 +-
 doc/lsort.n                    |  4 ++--
 doc/mathop.n                   |  2 +-
 doc/packagens.n                | 10 +++++-----
 doc/pkgMkIndex.n               |  4 ++--
 doc/socket.n                   |  4 ++--
 doc/tcltest.n                  |  4 ++--
 doc/unset.n                    |  6 +++---
 tools/tcltk-man2html-utils.tcl | 19 ++++++++++++++++---
 tools/tcltk-man2html.tcl       | 14 +++++++++++++-
 15 files changed, 60 insertions(+), 35 deletions(-)

diff --git a/doc/binary.n b/doc/binary.n
index 53d8b5a..8133829 100644
--- a/doc/binary.n
+++ b/doc/binary.n
@@ -13,9 +13,9 @@
 binary \- Insert and extract fields from binary strings
 .SH SYNOPSIS
 .VS 8.6
-\fBbinary decode \fIformat\fR ?\fI-option value ...\fR? \fIdata\fR
+\fBbinary decode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR
 .br
-\fBbinary encode \fIformat\fR ?\fI-option value ...\fR? \fIdata\fR
+\fBbinary encode \fIformat\fR ?\fI\-option value ...\fR? \fIdata\fR
 .br
 .VE 8.6
 \fBbinary format \fIformatString \fR?\fIarg arg ...\fR?
diff --git a/doc/clock.n b/doc/clock.n
index 56a139e..8708029 100644
--- a/doc/clock.n
+++ b/doc/clock.n
@@ -42,12 +42,12 @@ is system-dependent but should be the highest resolution clock available
 on the system such as a CPU cycle counter.  See \fBHIGH RESOLUTION TIMERS\fR for a full description.
 .RS
 .PP
-If the \fI\-option\fR argument is \fI\-milliseconds\fR, then the command
+If the \fI\-option\fR argument is \fB\-milliseconds\fR, then the command
 is synonymous with \fBclock milliseconds\fR (see below).  This
 usage is obsolete, and \fBclock milliseconds\fR is to be
 considered the preferred way of obtaining a count of milliseconds.
 .PP
-If the \fI\-option\fR argument is \fI\-microseconds\fR, then the command
+If the \fI\-option\fR argument is \fB\-microseconds\fR, then the command
 is synonymous with \fBclock microseconds\fR (see below).  This
 usage is obsolete, and \fBclock microseconds\fR is to be
 considered the preferred way of obtaining a count of microseconds.
@@ -116,7 +116,7 @@ On \fBclock format\fR, the default format is
 %a %b %d %H:%M:%S %z %Y
 .CE
 .PP
-On \fBclock scan\fR, the lack of a \fI\-format\fR option indicates that a
+On \fBclock scan\fR, the lack of a \fB\-format\fR option indicates that a
 .QW "free format scan"
 is requested; see \fBFREE FORM SCAN\fR for a description of what happens.
 .RE
@@ -904,7 +904,7 @@ or
 Note that only these three formats are accepted.
 The command does \fInot\fR accept the full range of point-in-time
 specifications specified in ISO8601.  Other formats can be recognized by
-giving an explicit \fI\-format\fR option to the \fBclock scan\fR command.
+giving an explicit \fB\-format\fR option to the \fBclock scan\fR command.
 .TP
 \fIrelative time\fR
 A specification relative to the current time.  The format is \fBnumber
diff --git a/doc/file.n b/doc/file.n
index 9205d3b..eef4647 100644
--- a/doc/file.n
+++ b/doc/file.n
@@ -104,7 +104,7 @@ within a single filesystem, \fIfile copy\fR will copy soft links (i.e.
 the links themselves are copied, not the things they point to).  Trying
 to overwrite a non-empty directory, overwrite a directory with a file,
 or overwrite a file with a directory will all result in errors even if
-\fI\-force\fR was specified.  Arguments are processed in the order
+\fB\-force\fR was specified.  Arguments are processed in the order
 specified, halting at the first error, if any.  A \fB\-\|\-\fR marks
 the end of switches; the argument following the \fB\-\|\-\fR will be
 treated as a \fIsource\fR even if it starts with a \fB\-\fR.
@@ -227,9 +227,9 @@ If the user wishes to make a link of a specific type only, (and signal an
 error if for some reason that is not possible), then the optional
 \fI\-linktype\fR argument should be given.  Accepted values for
 \fI\-linktype\fR are
-.QW \-symbolic
+.QW \fB\-symbolic\fR
 and
-.QW \-hard .
+.QW \fB\-hard\fR .
 .PP
 On Unix, symbolic links can be made to relative paths, and those paths
 must be relative to the actual \fIlinkName\fR's location (not to the
diff --git a/doc/http.n b/doc/http.n
index b05588e..631a141 100644
--- a/doc/http.n
+++ b/doc/http.n
@@ -16,9 +16,9 @@ http \- Client-side implementation of the HTTP/1.1 protocol
 \fBpackage require http ?2.7?\fR
 .\" See Also -useragent option documentation in body!
 .sp
-\fB::http::config ?\fI-option value\fR ...?
+\fB::http::config ?\fI\-option value\fR ...?
 .sp
-\fB::http::geturl \fIurl\fR ?\fI-option value\fR ...?
+\fB::http::geturl \fIurl\fR ?\fI\-option value\fR ...?
 .sp
 \fB::http::formatQuery\fR \fIkey value\fR ?\fIkey value\fR ...?
 .sp
diff --git a/doc/interp.n b/doc/interp.n
index 02421e1..b261779 100644
--- a/doc/interp.n
+++ b/doc/interp.n
@@ -194,11 +194,11 @@ given name already exists in this master.
 The initial recursion limit of the slave interpreter is set to the
 current recursion limit of its parent interpreter.
 .TP
-\fBinterp\fR \fBdebug \fIpath\fR ?\fI\-frame\fR ?\fIbool\fR??
+\fBinterp\fR \fBdebug \fIpath\fR ?\fB\-frame\fR ?\fIbool\fR??
 .
 Controls whether frame-level stack information is captured in the
 slave interpreter identified by \fIpath\fR.  If no arguments are
-given, option and current setting are returned.  If \fI\-frame\fR
+given, option and current setting are returned.  If \fB\-frame\fR
 is given, the debug setting is set to the given boolean if provided
 and the current setting is returned.
 This only effects the output of \fBinfo frame\fR, in that exact
diff --git a/doc/lsearch.n b/doc/lsearch.n
index a049b53..7835352 100644
--- a/doc/lsearch.n
+++ b/doc/lsearch.n
@@ -161,7 +161,7 @@ If this option is given, the index result from this command (or every
 index result when \fB\-all\fR is also specified) will be a complete
 path (suitable for use with \fBlindex\fR or \fBlset\fR) within the
 overall list to the term found.  This option has no effect unless the
-\fI\-index\fR is also specified, and is just a convenience short-cut.
+\fB\-index\fR is also specified, and is just a convenience short-cut.
 .SH EXAMPLES
 .PP
 Basic searching:
diff --git a/doc/lsort.n b/doc/lsort.n
index 8e85f5a..312048e 100644
--- a/doc/lsort.n
+++ b/doc/lsort.n
@@ -79,7 +79,7 @@ the values themselves.
 \fB\-index\0\fIindexList\fR
 .
 If this option is specified, each of the elements of \fIlist\fR must
-itself be a proper Tcl sublist (unless \fB-stride\fR is used).
+itself be a proper Tcl sublist (unless \fB\-stride\fR is used).
 Instead of sorting based on whole sublists, \fBlsort\fR will extract
 the \fIindexList\fR'th element from each sublist (as if the overall
 element and the \fIindexList\fR were passed to \fBlindex\fR) and sort
@@ -161,7 +161,7 @@ effect if combined with the \fB\-dictionary\fR, \fB\-integer\fR, or
 If this option is specified, then only the last set of duplicate
 elements found in the list will be retained.  Note that duplicates are
 determined relative to the comparison used in the sort.  Thus if 
-\fI\-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be
+\fB\-index 0\fR is used, \fB{1 a}\fR and \fB{1 b}\fR would be
 considered duplicates and only the second element, \fB{1 b}\fR, would
 be retained.
 .SH "NOTES"
diff --git a/doc/mathop.n b/doc/mathop.n
index 282b636..e359276 100644
--- a/doc/mathop.n
+++ b/doc/mathop.n
@@ -133,7 +133,7 @@ holds true:
 .RS
 .PP
 .CS
-(\fIx \fB/ \fIy\fR) \fB* \fIy \fB== \fIx \fB-\fR (\fIx \fB% \fIy\fR)
+(\fIx \fB/ \fIy\fR) \fB* \fIy \fB== \fIx \fB\-\fR (\fIx \fB% \fIy\fR)
 .CE
 .RE
 .TP
diff --git a/doc/packagens.n b/doc/packagens.n
index 1220b20..30617a3 100644
--- a/doc/packagens.n
+++ b/doc/packagens.n
@@ -9,7 +9,7 @@
 .SH NAME
 pkg::create \- Construct an appropriate 'package ifneeded' command for a given package specification
 .SH SYNOPSIS
-\fB::pkg::create \fI\-name packageName\fR \fI\-version packageVersion\fR ?\fI\-load filespec\fR? ... ?\fI\-source filespec\fR? ...
+\fB::pkg::create\fR \fB\-name \fIpackageName \fB\-version \fIpackageVersion\fR ?\fB\-load \fIfilespec\fR? ... ?\fB\-source \fIfilespec\fR? ...
 .BE
 
 .SH DESCRIPTION
@@ -22,13 +22,13 @@ command for a given package specification.  It can be used to construct a
 .SH OPTIONS
 The parameters supported are:
 .TP
-\fB\-name\fR\0\fIpackageName\fR
+\fB\-name \fIpackageName\fR
 This parameter specifies the name of the package.  It is required.
 .TP
-\fB\-version\fR\0\fIpackageVersion\fR
+\fB\-version \fIpackageVersion\fR
 This parameter specifies the version of the package.  It is required.
 .TP
-\fB\-load\fR\0\fIfilespec\fR
+\fB\-load \fIfilespec\fR
 This parameter specifies a binary library that must be loaded with the
 \fBload\fR command.  \fIfilespec\fR is a list with two elements.  The
 first element is the name of the file to load.  The second, optional
@@ -37,7 +37,7 @@ list of procedures is empty or omitted, \fB::pkg::create\fR will
 set up the library for direct loading (see \fBpkg_mkIndex\fR).  Any
 number of \fB\-load\fR parameters may be specified.
 .TP
-\fB\-source\fR\0\fIfilespec\fR
+\fB\-source \fIfilespec\fR
 This parameter is similar to the \fB\-load\fR parameter, except that it
 specifies a Tcl library that must be loaded with the
 \fBsource\fR command.  Any number of \fB\-source\fR parameters may be
diff --git a/doc/pkgMkIndex.n b/doc/pkgMkIndex.n
index 07370ef..2753208 100644
--- a/doc/pkgMkIndex.n
+++ b/doc/pkgMkIndex.n
@@ -153,7 +153,7 @@ commands for each version of each available package;  these commands
 invoke \fBpackage provide\fR commands to announce the
 availability of the package, and they setup auto-loader
 information to load the files of the package.
-If the \fI\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR
+If the \fB\-lazy\fR flag was provided when the \fBpkgIndex.tcl\fR
 was generated,
 a given file of a given version of a given package is not
 actually loaded until the first time one of its commands
@@ -168,7 +168,7 @@ commands or those which require special initialization, might select
 that their package files be loaded immediately upon \fBpackage require\fR
 instead of delaying the actual loading to the first use of one of the
 package's command. This is the default mode when generating the package
-index.  It can be overridden by specifying the \fI\-lazy\fR argument.
+index.  It can be overridden by specifying the \fB\-lazy\fR argument.
 .SH "COMPLEX CASES"
 Most complex cases of dependencies among scripts
 and binary files, and packages being split among scripts and
diff --git a/doc/socket.n b/doc/socket.n
index 9c9366d..e2c4759 100644
--- a/doc/socket.n
+++ b/doc/socket.n
@@ -169,8 +169,8 @@ identical to the address, the first element of the list.
 For server sockets this option returns a list of a multiple of three
 elements each group of which have the same meaning as described
 above. The list contains more than one group when the server socket
-was created without \fB-myaddr\fR or with the argument to
-\fB-myaddr\fR being a domain name that resolves multiple IP addresses
+was created without \fB\-myaddr\fR or with the argument to
+\fB\-myaddr\fR being a domain name that resolves multiple IP addresses
 that are local to the invoking host.
 
 .TP
diff --git a/doc/tcltest.n b/doc/tcltest.n
index 5977013..731bed7 100644
--- a/doc/tcltest.n
+++ b/doc/tcltest.n
@@ -32,7 +32,7 @@ tcltest \- Test harness support code and utilities
 
 \fBtcltest::configure\fR
 \fBtcltest::configure \fI\-option\fR
-\fBtcltest::configure \fI\-option value\fR ?\fI-option value ...\fR?
+\fBtcltest::configure \fI\-option value\fR ?\fI\-option value ...\fR?
 \fBtcltest::customMatch \fImode command\fR
 \fBtcltest::testConstraint \fIconstraint\fR ?\fIvalue\fR?
 \fBtcltest::outputChannel \fR?\fIchannelID\fR?
@@ -90,7 +90,7 @@ of how to use the commands of \fBtcltest\fR to produce test suites
 for your Tcl-enabled code.
 .SH COMMANDS
 .TP
-\fBtest\fR \fIname description\fR ?\fI-option value ...\fR?
+\fBtest\fR \fIname description\fR ?\fI\-option value ...\fR?
 .
 Defines and possibly runs a test with the name \fIname\fR and
 description \fIdescription\fR.  The name and description of a test
diff --git a/doc/unset.n b/doc/unset.n
index b86407a..64b334d 100644
--- a/doc/unset.n
+++ b/doc/unset.n
@@ -13,7 +13,7 @@
 .SH NAME
 unset \- Delete variables
 .SH SYNOPSIS
-\fBunset \fR?\fI\-nocomplain\fR? ?\fI\-\-\fR? ?\fIname name name ...\fR?
+\fBunset \fR?\fB\-nocomplain\fR? ?\fB\-\-\fR? ?\fIname name name ...\fR?
 .BE
 .SH DESCRIPTION
 .PP
@@ -25,9 +25,9 @@ element is removed without affecting the rest of the array.
 If a \fIname\fR consists of an array name with no parenthesized
 index, then the entire array is deleted.
 The \fBunset\fR command returns an empty string as result.
-If \fI\-nocomplain\fR is specified as the first argument, any possible
+If \fB\-nocomplain\fR is specified as the first argument, any possible
 errors are suppressed.  The option may not be abbreviated, in order to
-disambiguate it from possible variable names.  The option \fI\-\-\fR
+disambiguate it from possible variable names.  The option \fB\-\-\fR
 indicates the end of the options, and should be used if you wish to
 remove a variable with the same name as any of the options.
 If an error occurs during variable deletion, any variables after the named one
diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index 16e9a93..a7270a1 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -623,7 +623,7 @@ proc cross-reference {ref} {
     global ensemble_commands exclude_refs_map exclude_when_followed_by_map
     set manname $manual(name)
     set mantail $manual(tail)
-    if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref]} {
+    if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref]} {
 	set lref $ref
 	##
 	## apply a link remapping if available
@@ -758,6 +758,7 @@ proc insert-cross-references {text} {
 	    bold       {<B>}	end-bold   {</B>}
 	    tcl        {Tcl_}
 	    tk         {Tk_}
+	    ttk	       {Ttk_}
 	    Tcl1       {Tcl manual entry}
 	    Tcl2       {Tcl overview manual entry}
 	    url	       {http://}
@@ -795,7 +796,7 @@ proc insert-cross-references {text} {
 		if {$offset(end-quote) < 0} {
 		    return [reference-error "Missing end quote" $text]
 		}
-		if {$invert([lindex $offsets 1]) in {tcl tk}} {
+		if {$invert([lindex $offsets 1]) in {tcl tk ttk}} {
 		    set offsets [lreplace $offsets 1 1]
 		}
 		switch -exact -- $invert([lindex $offsets 1]) {
@@ -824,7 +825,7 @@ proc insert-cross-references {text} {
 		if {$offset(end-bold) < 0} {
 		    return [append result $text]
 		}
-		if {$invert([lindex $offsets 1]) in {tcl tk}} {
+		if {$invert([lindex $offsets 1]) in {tcl tk ttk}} {
 		    set offsets [lreplace $offsets 1 1]
 		}
 		switch -exact -- $invert([lindex $offsets 1]) {
@@ -864,6 +865,18 @@ proc insert-cross-references {text} {
 		append result [cross-reference $body]
 		continue
 	    }
+	    ttk {
+		append result [string range $text 0 [expr {$offset(ttk)-1}]]
+		if {![regexp -indices -start $offset(ttk) {Ttk_\w+} $text range]} {
+		    return [reference-error "Ttk regexp failed" $text]
+		}
+		set body [string range $text {*}$range]
+		set text [string range $text[set text ""] \
+			      [expr {[lindex $range 1]+1}] end]
+		set tail $text
+		append result [cross-reference $body]
+		continue
+	    }
 	    tcl {
 		append result [string range $text 0 [expr {$offset(tcl)-1}]]
 		if {![regexp -indices -start $offset(tcl) {Tcl_\w+} $text range]} {
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index 33d9ff9..cd8b0e5 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -836,22 +836,31 @@ array set exclude_refs_map {
     next.n		{unknown}
     zlib.n		{binary close filename text}
     canvas.n		{bitmap text}
+    console.n		{eval}
     checkbutton.n	{image}
     clipboard.n		{string}
+    entry.n		{string}
+    event.n		{return}
+    font.n		{menu}
+    getOpenFile.n	{file open text}
+    grab.n		{global}
     interp.n		{time}
     menu.n		{checkbutton radiobutton}
+    messageBox.n	{error info}
     options.n		{bitmap image set}
     radiobutton.n	{image}
     safe.n		{join split}
+    scale.n		{label variable}
     scrollbar.n		{set}
     selection.n		{string}
     tcltest.n		{error}
     tkvars.n		{tk}
+    tkwait.n		{variable}
     tm.n		{exec}
     ttk_checkbutton.n	{variable}
     ttk_combobox.n	{selection}
     ttk_entry.n		{focus variable}
-    ttk_intro.n		{focus}
+    ttk_intro.n		{focus text}
     ttk_label.n		{font text}
     ttk_labelframe.n	{text}
     ttk_menubutton.n	{flush}
@@ -880,6 +889,9 @@ array set exclude_when_followed_by_map {
     ttk_image.n {
 	image imageSpec
     }
+    fontchooser.n {
+	tk fontchooser
+    }
 }
 
 try {
-- 
cgit v0.12


From 44695da5cf0b2b661205e9509841420f6485e3c9 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 18 Jul 2011 20:01:39 +0000
Subject: Bump version number to 8.6b2.

---
 ChangeLog         | 13 +++++++++++++
 README            |  2 +-
 generic/tcl.h     |  4 ++--
 library/init.tcl  |  2 +-
 tools/tcl.wse.in  |  2 +-
 unix/configure    |  2 +-
 unix/configure.in |  2 +-
 unix/tcl.spec     |  2 +-
 win/configure     |  2 +-
 win/configure.in  |  2 +-
 10 files changed, 23 insertions(+), 10 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f9dbc26..70132ea 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2011-07-18  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tcl.h:	Bump version number to 8.6b2.
+	* library/init.tcl:
+	* unix/configure.in:
+	* win/configure.in:
+	* unix/tcl.spec:
+	* tools/tcl.wse.in:
+	* README:
+
+	* unix/configure:	autoconf-2.59
+	* win/configure:
+
 2011-07-15  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats()
diff --git a/README b/README
index 949847a..0442a0e 100644
--- a/README
+++ b/README
@@ -1,5 +1,5 @@
 README:  Tcl
-    This is the Tcl 8.6b1 source distribution.
+    This is the Tcl 8.6b2 source distribution.
 	http://tcl.sourceforge.net/
     You can get any source release of Tcl from the file distributions
     link at the above URL.
diff --git a/generic/tcl.h b/generic/tcl.h
index 7644e63..54bfedc 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -58,10 +58,10 @@ extern "C" {
 #define TCL_MAJOR_VERSION   8
 #define TCL_MINOR_VERSION   6
 #define TCL_RELEASE_LEVEL   TCL_BETA_RELEASE
-#define TCL_RELEASE_SERIAL  1
+#define TCL_RELEASE_SERIAL  2
 
 #define TCL_VERSION	    "8.6"
-#define TCL_PATCH_LEVEL	    "8.6b1.2"
+#define TCL_PATCH_LEVEL	    "8.6b2"
 
 /*
  *----------------------------------------------------------------------------
diff --git a/library/init.tcl b/library/init.tcl
index f1d6a64..685fc7b 100644
--- a/library/init.tcl
+++ b/library/init.tcl
@@ -15,7 +15,7 @@
 if {[info commands package] == ""} {
     error "version mismatch: library\nscripts expect Tcl version 7.5b1 or later but the loaded version is\nonly [info patchlevel]"
 }
-package require -exact Tcl 8.6b1.2
+package require -exact Tcl 8.6b2
 
 # Compute the auto path to use in this interpreter.
 # The values on the path come from several locations:
diff --git a/tools/tcl.wse.in b/tools/tcl.wse.in
index e2a636d..653b1e1 100644
--- a/tools/tcl.wse.in
+++ b/tools/tcl.wse.in
@@ -12,7 +12,7 @@ item: Global
   Log Pathname=%MAINDIR%\INSTALL.LOG
   Message Font=MS Sans Serif
   Font Size=8
-  Disk Label=tcl8.6b1
+  Disk Label=tcl8.6b2
   Disk Filename=setup
   Patch Flags=0000000000000001
   Patch Threshold=85
diff --git a/unix/configure b/unix/configure
index 2483e4a..ab251a6 100755
--- a/unix/configure
+++ b/unix/configure
@@ -1335,7 +1335,7 @@ ac_compiler_gnu=$ac_cv_c_compiler_gnu
 TCL_VERSION=8.6
 TCL_MAJOR_VERSION=8
 TCL_MINOR_VERSION=6
-TCL_PATCH_LEVEL="b1.2"
+TCL_PATCH_LEVEL="b2"
 VERSION=${TCL_VERSION}
 
 #------------------------------------------------------------------------
diff --git a/unix/configure.in b/unix/configure.in
index 34908a7..35eb3e5 100644
--- a/unix/configure.in
+++ b/unix/configure.in
@@ -25,7 +25,7 @@ m4_ifdef([SC_USE_CONFIG_HEADERS], [
 TCL_VERSION=8.6
 TCL_MAJOR_VERSION=8
 TCL_MINOR_VERSION=6
-TCL_PATCH_LEVEL="b1.2"
+TCL_PATCH_LEVEL="b2"
 VERSION=${TCL_VERSION}
 
 #------------------------------------------------------------------------
diff --git a/unix/tcl.spec b/unix/tcl.spec
index 3331b14..b35e220 100644
--- a/unix/tcl.spec
+++ b/unix/tcl.spec
@@ -4,7 +4,7 @@
 
 Name:          tcl
 Summary:       Tcl scripting language development environment
-Version:       8.6b1
+Version:       8.6b2
 Release:       2
 License:       BSD
 Group:         Development/Languages
diff --git a/win/configure b/win/configure
index 180901c..3a40da1 100755
--- a/win/configure
+++ b/win/configure
@@ -1311,7 +1311,7 @@ SHELL=/bin/sh
 TCL_VERSION=8.6
 TCL_MAJOR_VERSION=8
 TCL_MINOR_VERSION=6
-TCL_PATCH_LEVEL="b1.2"
+TCL_PATCH_LEVEL="b2"
 VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
 
 TCL_DDE_VERSION=1.3
diff --git a/win/configure.in b/win/configure.in
index 7d43a38..cb958f2 100644
--- a/win/configure.in
+++ b/win/configure.in
@@ -14,7 +14,7 @@ SHELL=/bin/sh
 TCL_VERSION=8.6
 TCL_MAJOR_VERSION=8
 TCL_MINOR_VERSION=6
-TCL_PATCH_LEVEL="b1.2"
+TCL_PATCH_LEVEL="b2"
 VER=$TCL_MAJOR_VERSION$TCL_MINOR_VERSION
 
 TCL_DDE_VERSION=1.3
-- 
cgit v0.12


From 28155c8eab47a927fe919db3b537dde2ef01366b Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Mon, 18 Jul 2011 22:41:10 +0000
Subject: Undocument long gone limitation of [upvar].

---
 ChangeLog   | 4 ++++
 doc/upvar.n | 3 +--
 2 files changed, 5 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f9dbc26..0d6b8f0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-07-19 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* doc/upvar.n: Undocument long gone limitation of [upvar].
+
 2011-07-15  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats()
diff --git a/doc/upvar.n b/doc/upvar.n
index 8985d24..60e5324 100644
--- a/doc/upvar.n
+++ b/doc/upvar.n
@@ -21,8 +21,7 @@ This command arranges for one or more local variables in the current
 procedure to refer to variables in an enclosing procedure call or
 to global variables.
 \fILevel\fR may have any of the forms permitted for the \fBuplevel\fR
-command, and may be omitted if the first letter of the first \fIotherVar\fR
-is not \fB#\fR or a digit (it defaults to \fB1\fR).
+command, and may be omitted (it defaults to \fB1\fR).
 For each \fIotherVar\fR argument, \fBupvar\fR makes the variable
 by that name in the procedure frame given by \fIlevel\fR (or at
 global level, if \fIlevel\fR is \fB#0\fR) accessible
-- 
cgit v0.12


From 72d34422eacbba7943133639ab202f4cb9869a06 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 18 Jul 2011 23:45:15 +0000
Subject: The final parts of my doc improvement project

---
 ChangeLog                      | 15 +++++++++++++--
 doc/Class.3                    |  2 +-
 doc/CrtInterp.3                |  2 +-
 doc/Ensemble.3                 |  2 +-
 doc/FileSystem.3               |  6 +++---
 doc/Method.3                   |  2 +-
 doc/NRE.3                      |  2 +-
 doc/Namespace.3                |  2 +-
 doc/Notifier.3                 |  2 +-
 doc/SplitList.3                |  4 ++--
 doc/Translate.3                | 11 ++++-------
 tools/tcltk-man2html-utils.tcl |  8 +++++---
 tools/tcltk-man2html.tcl       | 27 +++++++++++++++++++++++++++
 13 files changed, 61 insertions(+), 24 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 0d6b8f0..e97bb11 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2011-07-19  Donal K. Fellows  <dkf@users.sf.net>
+
+	* doc/*.3, doc/*.n: Many small fixes to documentation as part of
+	project to improve quality of generated HTML docs.
+
+	* tools/tcltk-man2html.tcl (remap_link_target): More complete set of
+	definitions of link targets, especially for major C API types.
+	* tools/tcltk-man2html-utils.tcl (output-IP-list, cross-reference):
+	Update to generation to produce proper HTML bulleted and enumerated
+	lists.
+
 2011-07-19 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	* doc/upvar.n: Undocument long gone limitation of [upvar].
@@ -7,9 +18,9 @@
 	* generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats()
 	is called in a deleted interp.
 
-	* generic/tclCompile.c:	[Bug 467523, 3357771] Prevent circular
+	* generic/tclCompile.c:	[Bug 467523, 3357771]: Prevent circular
 	references in values with ByteCode intreps.  They can lead to
-	memory leaks. 
+	memory leaks.
 
 2011-07-14  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/doc/Class.3 b/doc/Class.3
index e9bb21c..dbb5b99 100644
--- a/doc/Class.3
+++ b/doc/Class.3
@@ -9,7 +9,7 @@
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
-Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_CopyObjectInstance, Tcl_GetClassAsObject, Tcl_GetObjectAsClass, Tcl_GetObjectCommand, Tcl_GetObjectNamespace, Tcl_NewObjectInstance, Tcl_ObjectDeleted, Tcl_ObjectGetMetadata, Tcl_ObjectGetMethodNameMapper, Tcl_ObjectSetMetadata, Tcl_ObjectSetMethodNameMapper \- manipulate objects and classes
+Tcl_ClassGetMetadata, Tcl_ClassSetMetadata, Tcl_CopyObjectInstance, Tcl_GetClassAsObject, Tcl_GetObjectAsClass, Tcl_GetObjectCommand, Tcl_GetObjectFromObj, Tcl_GetObjectName, Tcl_GetObjectNamespace, Tcl_NewObjectInstance, Tcl_ObjectDeleted, Tcl_ObjectGetMetadata, Tcl_ObjectGetMethodNameMapper, Tcl_ObjectSetMetadata, Tcl_ObjectSetMethodNameMapper \- manipulate objects and classes
 .SH SYNOPSIS
 .nf
 \fB#include <tclOO.h>\fR
diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3
index d1a030a..a248cf4 100644
--- a/doc/CrtInterp.3
+++ b/doc/CrtInterp.3
@@ -9,7 +9,7 @@
 .TH Tcl_CreateInterp 3 7.5 Tcl "Tcl Library Procedures"
 .BS
 .SH NAME
-Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpDeleted \- create and delete Tcl command interpreters
+Tcl_CreateInterp, Tcl_DeleteInterp, Tcl_InterpActive, Tcl_InterpDeleted \- create and delete Tcl command interpreters
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
diff --git a/doc/Ensemble.3 b/doc/Ensemble.3
index 2153840..19c6099 100644
--- a/doc/Ensemble.3
+++ b/doc/Ensemble.3
@@ -10,7 +10,7 @@
 .TH Tcl_Ensemble 3 8.5 Tcl "Tcl Library Procedures"
 .BS
 .SH NAME
-Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsembleSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands
+Tcl_CreateEnsemble, Tcl_FindEnsemble, Tcl_GetEnsembleFlags, Tcl_GetEnsembleMappingDict, Tcl_GetEnsembleNamespace, Tcl_GetEnsembleParameterList, Tcl_GetEnsembleUnknownHandler, Tcl_GetEnsembleSubcommandList, Tcl_IsEnsemble, Tcl_SetEnsembleFlags, Tcl_SetEnsembleMappingDict, Tcl_SetEnsembleParameterList, Tcl_SetEnsembleSubcommandList, Tcl_SetEnsembleUnknownHandler \- manipulate ensemble commands
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
diff --git a/doc/FileSystem.3 b/doc/FileSystem.3
index 7816099..e3870c3 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -718,14 +718,14 @@ sequences (these have been expanded to their current
 representation in the filesystem). The object returned is owned by the
 caller, which must store it or call Tcl_DecrRefCount to ensure memory is
 freed. This function is of little practical use, and
-\fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually
+\fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually
 better functions to use for most purposes.
 .PP
 \fBTcl_FSGetTranslatedStringPath\fR does the same as
 \fBTcl_FSGetTranslatedPath\fR, but returns a character string or NULL.
 The string returned is dynamically allocated and owned by the caller,
 which must store it or call \fBckfree\fR to ensure it is freed. Again,
-\fBTcl_FSGetNormalizedPath\fR or \fBTcl_GetNativePath\fR are usually
+\fBTcl_FSGetNormalizedPath\fR or \fBTcl_FSGetNativePath\fR are usually
 better functions to use for most purposes.
 .PP
 \fBTcl_FSNewNativePath\fR performs something like the reverse of the
@@ -792,7 +792,7 @@ It returns one of \fBTCL_PATH_ABSOLUTE\fR, \fBTCL_PATH_RELATIVE\fR, or
 .PP
 \fBTcl_AllocStatBuf\fR allocates a \fITcl_StatBuf\fR on the system heap (which
 may be deallocated by being passed to \fBckfree\fR). This allows extensions to
-invoke \fBTcl_FSStat\fR and \fBTcl_FSLStat\fR without being dependent on the
+invoke \fBTcl_FSStat\fR and \fBTcl_FSLstat\fR without being dependent on the
 size of the buffer. That in turn depends on the flags used to build Tcl.
 .PP
 .VS 8.6
diff --git a/doc/Method.3 b/doc/Method.3
index 11e2d5b..43b3609 100644
--- a/doc/Method.3
+++ b/doc/Method.3
@@ -9,7 +9,7 @@
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
-Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
+Tcl_ClassSetConstructor, Tcl_ClassSetDestructor, Tcl_MethodDeclarerClass, Tcl_MethodDeclarerObject, Tcl_MethodIsPublic, Tcl_MethodIsType, Tcl_MethodName, Tcl_NewInstanceMethod, Tcl_NewMethod, Tcl_ObjectContextInvokeNext, Tcl_ObjectContextIsFiltering, Tcl_ObjectContextMethod, Tcl_ObjectContextObject, Tcl_ObjectContextSkippedArgs \- manipulate methods and method-call contexts
 .SH SYNOPSIS
 .nf
 \fB#include <tclOO.h>\fR
diff --git a/doc/NRE.3 b/doc/NRE.3
index dfa6064..5c27491 100644
--- a/doc/NRE.3
+++ b/doc/NRE.3
@@ -141,7 +141,7 @@ trampoline.
 .PP
 \fBTcl_NRCmdSwap\fR allows for trampoline evaluation of a command whose
 resolution is already known.  The \fIcmd\fR parameter gives a
-\fBTcl_Command\fR object (returned from \fBTcl_CreateObjCmd\fR or
+\fBTcl_Command\fR object (returned from \fBTcl_CreateObjCommand\fR or
 \fBTcl_GetCommandFromObj\fR) identifying the command to be invoked in
 the trampoline; this command must match the word in \fIobjv[0]\fR.
 The remaining arguments are as for \fBTcl_NREvalObj\fR.
diff --git a/doc/Namespace.3 b/doc/Namespace.3
index c42e36e..50cc559 100644
--- a/doc/Namespace.3
+++ b/doc/Namespace.3
@@ -160,6 +160,6 @@ for the namespace, or NULL if none is set.
 the namespace. If \fIhandlerPtr\fR is NULL, then the handler is reset to
 its default.
 .SH "SEE ALSO"
-Tcl_CreateCommand(3), Tcl_ListObjAppendElements(3), Tcl_SetVar(3)
+Tcl_CreateCommand(3), Tcl_ListObjAppendList(3), Tcl_SetVar(3)
 .SH KEYWORDS
 namespace, command
diff --git a/doc/Notifier.3 b/doc/Notifier.3
index ddd4ae1..435f779 100644
--- a/doc/Notifier.3
+++ b/doc/Notifier.3
@@ -411,7 +411,7 @@ an event to the current thread's queue.
 To add an event to another thread's queue, use \fBTcl_ThreadQueueEvent\fR.
 \fBTcl_ThreadQueueEvent\fR accepts as an argument a Tcl_ThreadId argument,
 which uniquely identifies a thread in a Tcl application.  To obtain the
-Tcl_ThreadID for the current thread, use the \fBTcl_GetCurrentThread\fR
+Tcl_ThreadId for the current thread, use the \fBTcl_GetCurrentThread\fR
 procedure.  (A thread would then need to pass this identifier to other
 threads for those threads to be able to add events to its queue.)
 After adding an event to another thread's queue, you then typically
diff --git a/doc/SplitList.3 b/doc/SplitList.3
index b7d1969..219dfc7 100644
--- a/doc/SplitList.3
+++ b/doc/SplitList.3
@@ -182,7 +182,7 @@ with \fBTCL_DONT_QUOTE_HASH\fR.
 the same as \fBTcl_ScanElement\fR and \fBTcl_ConvertElement\fR, except
 the length of string \fIsrc\fR is specified by the \fIlength\fR
 argument, and the string may contain embedded nulls.
+.SH "SEE ALSO"
+Tcl_ListObjGetElements(3)
 .SH KEYWORDS
 backslash, convert, element, list, merge, split, strings
-.SH "SEE ALSO"
-Tcl_GetListFromObj(3)
diff --git a/doc/Translate.3 b/doc/Translate.3
index d434cda..55233c3 100644
--- a/doc/Translate.3
+++ b/doc/Translate.3
@@ -29,7 +29,6 @@ At the time of the call it should be uninitialized or free.  The
 caller must eventually call \fBTcl_DStringFree\fR to free up
 anything stored here.
 .BE
-
 .SH DESCRIPTION
 .PP
 This utility procedure translates a file name to a platform-specific form
@@ -38,11 +37,11 @@ passing to the local operating system.  In particular, it converts
 network names into native form and does tilde substitution.  
 .PP
 However, with the advent of the newer \fBTcl_FSGetNormalizedPath\fR and
-\fBTcl_GetNativePath\fR, there is no longer any need to use this
-procedure.  In particular, \fBTcl_GetNativePath\fR performs all the
+\fBTcl_FSGetNativePath\fR, there is no longer any need to use this
+procedure.  In particular, \fBTcl_FSGetNativePath\fR performs all the
 necessary translation and encoding conversion, is virtual-filesystem
 aware, and caches the native result for faster repeated calls.
-Finally \fBTcl_GetNativePath\fR does not require you to free anything
+Finally \fBTcl_FSGetNativePath\fR does not require you to free anything
 afterwards.
 .PP
 If
@@ -66,9 +65,7 @@ frees the dynamic string itself so that the caller need not call
 .PP
 The caller is responsible for making sure that the interpreter's result
 has its default empty value when \fBTcl_TranslateFileName\fR is invoked.
-
 .SH "SEE ALSO"
-filename
-
+filename(n)
 .SH KEYWORDS
 file name, home directory, tilde, translate, user
diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index a7270a1..af2faa3 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -4,7 +4,7 @@
 ## by Tcl and Tk; they do not cope with arbitrary nroff markup.
 ##
 ## Copyright (c) 1995-1997 Roger E. Critchlow Jr
-## Copyright (c) 2004-2010 Donal K. Fellows
+## Copyright (c) 2004-2011 Donal K. Fellows
 
 set ::manual(report-level) 1
 
@@ -491,7 +491,7 @@ proc output-IP-list {context code rest} {
 	set dl "<DL class=\"[string tolower $manual(section)]\">"
 	set enddl "</DL>"
 	if {$code eq ".IP"} {
-	    if {[regexp {^\[[\da-f]+\]$} $rest]} {
+	    if {[regexp {^\[[\da-f]+\]|\(?[\da-f]+\)$} $rest]} {
 		set dl "<OL class=\"[string tolower $manual(section)]\">"
 		set enddl "</OL>"
 	    } elseif {"&#8226;" eq $rest} {
@@ -518,6 +518,8 @@ proc output-IP-list {context code rest} {
 			    man-puts "$para<DT>$rest<DD>"
 			} elseif {[regexp {^\[([\da-f]+)\]$} $rest -> value]} {
 			    man-puts "$para<LI value=\"$value\">"
+			} elseif {[regexp {^\(?([\da-f]+)\)$} $rest -> value]} {
+			    man-puts "$para<LI value=\"$value\">"
 			} elseif {"&#8226;" eq $rest} {
 			    man-puts "$para<LI>"
 			} else {
@@ -624,7 +626,7 @@ proc cross-reference {ref} {
     set manname $manual(name)
     set mantail $manual(tail)
     if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref]} {
-	set lref $ref
+	regexp {^\w+} $ref lref
 	##
 	## apply a link remapping if available
 	##
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index cd8b0e5..f928d4a 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -828,6 +828,33 @@ array set remap_link_target {
     pkg_mkIndex pkg_mkIndex
     Tcl_Obj     Tcl_NewObj
     Tcl_ObjType Tcl_RegisterObjType
+    Tcl_OpenFileChannelProc Tcl_FSOpenFileChannel
+    errorinfo 	env
+    errorcode 	env
+    tcl_pkgpath env
+    Tcl_Command Tcl_CreateObjCommand
+    Tcl_CmdProc Tcl_CreateObjCommand
+    Tcl_Channel Tcl_OpenFileChannel
+    Tcl_WideInt Tcl_NewIntObj
+    Tcl_ChannelType Tcl_CreateChannel
+    Tcl_DString Tcl_DStringInit
+    Tcl_Namespace Tcl_AppendExportList
+    Tcl_Object  Tcl_NewObjectInstance
+    Tcl_Class   Tcl_GetObjectAsClass
+    Tcl_Event   Tcl_QueueEvent
+    Tcl_Time	Tcl_GetTime
+    Tcl_ThreadId Tcl_CreateThread
+    Tk_Window	Tk_WindowId
+    Tk_3DBorder Tk_Get3DBorder
+    Tk_Anchor	Tk_GetAnchor
+    Tk_Cursor	Tk_GetCursor
+    Tk_Dash	Tk_GetDash
+    Tk_Font	Tk_GetFont
+    Tk_Image	Tk_GetImage
+    Tk_ImageMaster Tk_GetImage
+    Tk_ItemType Tk_CreateItemType
+    Tk_Justify	Tk_GetJustify
+    Ttk_Theme	Ttk_GetTheme
 }
 array set exclude_refs_map {
     bind.n		{button destroy option}
-- 
cgit v0.12


From 6dc6abffa7924bc7ef004be95916702634242133 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Tue, 19 Jul 2011 18:13:53 +0000
Subject: Fix [bug 3371644] -- crash on Tcl_ConvertElement with leading pound.

---
 ChangeLog         | 4 ++++
 generic/tclUtil.c | 4 +++-
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index e97bb11..1a0e4dc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-07-19 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* generic/tclUtil.c: Fix [bug 3371644] -- crash on Tcl_ConvertElement with leading pound.
+
 2011-07-19  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/*.3, doc/*.n: Many small fixes to documentation as part of
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 6f36dad..55103e3 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -1261,7 +1261,9 @@ int TclConvertElement(
 	    p[1] = '#';
 	    p += 2;
 	    src++;
-	    length--;
+	    if (length > 0) {
+		length--;
+	    }
 	} else {
 	    conversion = CONVERT_BRACE;
 	}
-- 
cgit v0.12


From d7019b7df70dfd4375c7952850fe26f1bec79520 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 26 Jul 2011 20:00:23 +0000
Subject: Ensure that TclOO is properly found by all the various package
 mechanisms (by adding a dummy ifneeded script) and not just some of them.

---
 ChangeLog       | 10 ++++++++--
 generic/tclOO.c |  1 +
 tests/oo.test   | 19 ++++++-------------
 3 files changed, 15 insertions(+), 15 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index aad6742..bf320fc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,16 @@
+2011-07-26  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOO.c (initScript): Ensure that TclOO is properly found by
+	all the various package mechanisms (by adding a dummy ifneeded script)
+	and not just some of them.
+
 2011-07-21  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinPort.h: [Bug 3372130] Fix hypot math function with MSVC10
+	* win/tclWinPort.h: [Bug 3372130]: Fix hypot math function with MSVC10
 
 2011-07-19  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclUtil.c:	[Bug 3371644] Repair failure to properly handle 
+	* generic/tclUtil.c:	[Bug 3371644]: Repair failure to properly handle
 	* tests/util.test: (length == -1) scanning in TclConvertElement().
 	Thanks to Thomas Sader and Alexandre Ferrieux.
 
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 9df3f53..8b76eeb 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -130,6 +130,7 @@ static const DeclaredClassMethod objMethods[] = {
 };
 
 static char initScript[] =
+    "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
     "namespace eval ::oo { variable version " TCLOO_VERSION " };"
     "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
 /*     "tcl_findLibrary tcloo $oo::version $oo::version" */
diff --git a/tests/oo.test b/tests/oo.test
index e8f770c..b12cb42 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2,7 +2,7 @@
 # Sourcing this file into Tcl runs the tests and generates output for errors.
 # No output means no errors were found.
 #
-# Copyright (c) 2006-2008 Donal K. Fellows
+# Copyright (c) 2006-2011 Donal K. Fellows
 #
 # See the file "license.terms" for information on usage and redistribution of
 # this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -29,15 +29,9 @@ if {[testConstraint memory]} {
 	return [expr {$end - $tmp}]
     }
 }
-
-proc initInterpreter name {
-    $name eval [list package ifneeded TclOO [package provide TclOO] \
-		    [package ifneeded TclOO [package provide TclOO]]]
-}
 
 test oo-0.1 {basic test of OO's ability to clean up its initial state} {
     interp create t
-    initInterpreter t
     t eval {
 	package require TclOO
     }
@@ -45,11 +39,11 @@ test oo-0.1 {basic test of OO's ability to clean up its initial state} {
 } {}
 test oo-0.2 {basic test of OO's ability to clean up its initial state} {
     set i [interp create]
-    initInterpreter $i
     interp eval $i {
 	package require TclOO
 	namespace delete ::
     }
+    interp delete $i
 } {}
 test oo-0.3 {basic test of OO's ability to clean up its initial state} -body {
     leaktest {
@@ -72,7 +66,6 @@ test oo-0.5 {testing literal leak on interp delete} memory {
 } 0
 test oo-0.6 {cleaning the core class pair; way #1} -setup {
     interp create t
-    initInterpreter t
 } -body {
     t eval {
 	package require TclOO
@@ -84,7 +77,6 @@ test oo-0.6 {cleaning the core class pair; way #1} -setup {
 } -result {0 {} 1 {invalid command name "object"}}
 test oo-0.7 {cleaning the core class pair; way #2} -setup {
     interp create t
-    initInterpreter t
 } -body {
     t eval {
 	package require TclOO
@@ -106,6 +98,10 @@ test oo-0.8 {leak in variable management} -setup {
 } -cleanup {
     foo destroy
 } -result 0
+test oo-0.9 {various types of presence of the TclOO package} {
+    list [lsearch -nocase -all -inline [package names] tcloo] \
+	[package present TclOO] [package versions TclOO]
+} [list TclOO $::oo::version $::oo::version]
 
 test oo-1.1 {basic test of OO functionality: no classes} {
     set result {}
@@ -272,7 +268,6 @@ test oo-2.1 {basic test of OO functionality: constructor} -setup {
     # This is a bit complex because it needs to run in a sub-interp as
     # we're modifying the root object class's constructor
     interp create subinterp
-    initInterpreter subinterp
     subinterp eval {
 	package require TclOO
     }
@@ -340,7 +335,6 @@ test oo-3.1 {basic test of OO functionality: destructor} -setup {
     # This is a bit complex because it needs to run in a sub-interp as we're
     # modifying the root object class's constructor
     interp create subinterp
-    initInterpreter subinterp
     subinterp eval {
 	package require TclOO
     }
@@ -361,7 +355,6 @@ test oo-3.2 {basic test of OO functionality: destructor} -setup {
     # This is a bit complex because it needs to run in a sub-interp as
     # we're modifying the root object class's constructor
     interp create subinterp
-    initInterpreter subinterp
     subinterp eval {
 	package require TclOO
     }
-- 
cgit v0.12


From 81e8e3f1134a59fb0ebd8ffccc332db1bd516ca0 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Thu, 28 Jul 2011 15:51:40 +0000
Subject: Fix AC_DEFINE invocation for NEED_FAKE_RFC2553.

---
 ChangeLog   | 5 +++++
 unix/tcl.m4 | 3 ++-
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index b205b74..99f6408 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-07-28  Reinhard Max  <max@suse.de>
+
+	* unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for
+	NEED_FAKE_RFC2553.
+
 2011-07-28  Don Porter  <dgp@users.sourceforge.net>
 
 	* changes:	Updates for 8.6b2 release.
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 229e0b8..2f7cb16 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -3261,7 +3261,8 @@ AC_DEFUN([SC_TCL_IPV6],[
 #include <netdb.h>
 ]])
 if test "x$NEED_FAKE_RFC2553" = "x1"; then
-   AC_DEFINE(NEED_FAKE_RFC2553)
+   AC_DEFINE([NEED_FAKE_RFC2553], 1,
+        [Use compat implementation of getaddrinfo() and friends])
    AC_LIBOBJ([fake-rfc2553])
    AC_CHECK_FUNC(strlcpy)
 fi
-- 
cgit v0.12


From d9f455ab2c498da430f6831eae0793db2af05333 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 28 Jul 2011 15:56:27 +0000
Subject: autoconf

---
 ChangeLog      | 1 +
 unix/configure | 3 ++-
 2 files changed, 3 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 99f6408..722ddf1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,7 @@
 
 	* unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for
 	NEED_FAKE_RFC2553.
+	* unix/configure:	autoconf-2.59
 
 2011-07-28  Don Porter  <dgp@users.sourceforge.net>
 
diff --git a/unix/configure b/unix/configure
index 2483e4a..53f44ac 100755
--- a/unix/configure
+++ b/unix/configure
@@ -11381,7 +11381,8 @@ else
 fi
 
 if test "x$NEED_FAKE_RFC2553" = "x1"; then
-   cat >>confdefs.h <<\_ACEOF
+
+cat >>confdefs.h <<\_ACEOF
 #define NEED_FAKE_RFC2553 1
 _ACEOF
 
-- 
cgit v0.12


From 2d6a72ad106ef3b905a031ecb92a2734a6a2cc0d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 29 Jul 2011 20:20:35 +0000
Subject: Small enhancements to improve cross-linking with contributed
 packages.

---
 ChangeLog                      |  7 +++++
 tools/tcltk-man2html-utils.tcl | 61 +++++++++++-------------------------------
 tools/tcltk-man2html.tcl       |  4 ++-
 3 files changed, 25 insertions(+), 47 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 722ddf1..50ddec3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-07-29  Donal K. Fellows  <dkf@users.sf.net>
+
+	* tools/tcltk-man2html.tcl (ensemble_commands, remap_link_target):
+	Small enhancements to improve cross-linking with contributed packages.
+	* tools/tcltk-man2html-utils.tcl (insert-cross-references): Enhance to
+	cope with contributed packages' C API.
+
 2011-07-28  Reinhard Max  <max@suse.de>
 
 	* unix/tcl.m4 (SC_TCL_IPV6): Fix AC_DEFINE invocation for
diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index af2faa3..e5a478c 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -625,7 +625,7 @@ proc cross-reference {ref} {
     global ensemble_commands exclude_refs_map exclude_when_followed_by_map
     set manname $manual(name)
     set mantail $manual(tail)
-    if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref]} {
+    if {[string match "Tcl_*" $ref] || [string match "Tk_*" $ref] || [string match "Ttk_*" $ref] || [string match "Itcl_*" $ref] || [string match "Tdbc_*" $ref]} {
 	regexp {^\w+} $ref lref
 	##
 	## apply a link remapping if available
@@ -705,7 +705,7 @@ proc cross-reference {ref} {
     ## exceptions, sigh, to the rule
     ##
     if {[info exists exclude_when_followed_by_map($mantail)]} {
-	upvar 1 tail tail
+	upvar 1 text tail
 	set following_word [lindex [regexp -inline {\S+} $tail] 0]
 	foreach {this that} $exclude_when_followed_by_map($mantail) {
 	    # only a ref if $this is not followed by $that
@@ -758,9 +758,11 @@ proc insert-cross-references {text} {
 	    anchor     {<A }	end-anchor {</A>}
 	    quote      {``}	end-quote  {''}
 	    bold       {<B>}	end-bold   {</B>}
-	    tcl        {Tcl_}
-	    tk         {Tk_}
-	    ttk	       {Ttk_}
+	    c.tcl      {Tcl_}
+	    c.tk       {Tk_}
+	    c.ttk      {Ttk_}
+	    c.tdbc     {Tdbc_}
+	    c.itcl     {Itcl_}
 	    Tcl1       {Tcl manual entry}
 	    Tcl2       {Tcl overview manual entry}
 	    url	       {http://}
@@ -808,12 +810,10 @@ proc insert-cross-references {text} {
 				      [expr {$offset(end-quote)-1}]]
 			set text [string range $text[set text ""] \
 				      [expr {$offset(end-quote)+2}] end]
-			set tail $text
 			append result `` [cross-reference $body] ''
 			continue
 		    }
-		    bold -
-		    anchor {
+		    bold - anchor {
 			append result [string range $text \
 				      0 [expr {$offset(end-quote)+1}]]
 			set text [string range $text[set text ""] \
@@ -838,7 +838,6 @@ proc insert-cross-references {text} {
 				      [expr {$offset(end-bold)-1}]]
 			set text [string range $text[set text ""] \
 				      [expr {$offset(end-bold)+4}] end]
-			set tail $text
 			regsub {http://[\w/.]+} $body {<A HREF="&">&</A>} body
 			append result <B> [cross-reference $body] </B>
 			continue
@@ -855,48 +854,20 @@ proc insert-cross-references {text} {
 		    }
 		}
 	    }
-	    tk {
-		append result [string range $text 0 [expr {$offset(tk)-1}]]
-		if {![regexp -indices -start $offset(tk) {Tk_\w+} $text range]} {
-		    return [reference-error "Tk regexp failed" $text]
-		}
-		set body [string range $text {*}$range]
-		set text [string range $text[set text ""] \
-			      [expr {[lindex $range 1]+1}] end]
-		set tail $text
-		append result [cross-reference $body]
-		continue
-	    }
-	    ttk {
-		append result [string range $text 0 [expr {$offset(ttk)-1}]]
-		if {![regexp -indices -start $offset(ttk) {Ttk_\w+} $text range]} {
-		    return [reference-error "Ttk regexp failed" $text]
-		}
-		set body [string range $text {*}$range]
-		set text [string range $text[set text ""] \
-			      [expr {[lindex $range 1]+1}] end]
-		set tail $text
-		append result [cross-reference $body]
-		continue
-	    }
-	    tcl {
-		append result [string range $text 0 [expr {$offset(tcl)-1}]]
-		if {![regexp -indices -start $offset(tcl) {Tcl_\w+} $text range]} {
-		    return [reference-error "Tcl regexp failed" $text]
-		}
+	    c.tk - c.ttk - c.tcl - c.tdbc - c.itcl {
+		append result [string range $text 0 \
+				   [expr {[lindex $offsets 0]-1}]]
+		regexp -indices -start [lindex $offsets 0] {\w+} $text range
 		set body [string range $text {*}$range]
 		set text [string range $text[set text ""] \
 			      [expr {[lindex $range 1]+1}] end]
-		set tail $text
-		append result [cross-reference $body]
+		lappend result [cross-reference $body]
 		continue
 	    }
-	    Tcl1 -
-	    Tcl2 {
+	    Tcl1 - Tcl2 {
 		set off [lindex $offsets 0]
 		append result [string range $text 0 [expr {$off-1}]]
 		set text [string range $text[set text ""] [expr {$off+3}] end]
-		set tail $text
 		append result [cross-reference Tcl]
 		continue
 	    }
@@ -910,9 +881,7 @@ proc insert-cross-references {text} {
 			      [expr {[lindex $range 1]+1}] end]
 		continue
 	    }
-	    end-anchor -
-	    end-bold -
-	    end-quote {
+	    end-anchor - end-bold - end-quote {
 		return [reference-error "Out of place $invert([lindex $offsets 0])" $text]
 	    }
 	}
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index f928d4a..2bde714 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -804,7 +804,7 @@ set ensemble_commands {
     after array binary chan clock dde dict encoding file history info interp
     memory namespace package registry self string trace update zlib
     clipboard console font grab grid image option pack place selection tk
-    tkwait ttk::style winfo wm
+    tkwait ttk::style winfo wm itcl::delete itcl::find itcl::is
 }
 array set remap_link_target {
     stdin  Tcl_GetStdChannel
@@ -834,6 +834,8 @@ array set remap_link_target {
     tcl_pkgpath env
     Tcl_Command Tcl_CreateObjCommand
     Tcl_CmdProc Tcl_CreateObjCommand
+    Tcl_CmdDeleteProc Tcl_CreateObjCommand
+    Tcl_ObjCmdProc Tcl_CreateObjCommand
     Tcl_Channel Tcl_OpenFileChannel
     Tcl_WideInt Tcl_NewIntObj
     Tcl_ChannelType Tcl_CreateChannel
-- 
cgit v0.12


From 03ad3d0610ac27a99cd817cdf14f0506de1f59ed Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 29 Jul 2011 20:46:10 +0000
Subject: Small errors plague us all...

---
 tools/tcltk-man2html-utils.tcl | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index e5a478c..938a1af 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -827,7 +827,7 @@ proc insert-cross-references {text} {
 		if {$offset(end-bold) < 0} {
 		    return [append result $text]
 		}
-		if {$invert([lindex $offsets 1]) in {tcl tk ttk}} {
+		if {[string match "c.*" $invert([lindex $offsets 1])]} {
 		    set offsets [lreplace $offsets 1 1]
 		}
 		switch -exact -- $invert([lindex $offsets 1]) {
@@ -861,7 +861,7 @@ proc insert-cross-references {text} {
 		set body [string range $text {*}$range]
 		set text [string range $text[set text ""] \
 			      [expr {[lindex $range 1]+1}] end]
-		lappend result [cross-reference $body]
+		append result [cross-reference $body]
 		continue
 	    }
 	    Tcl1 - Tcl2 {
-- 
cgit v0.12


From 84631930502efd5f508061e9c4ae81d8413f3ecf Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 1 Aug 2011 09:15:11 +0000
Subject: [Bug 3382474]: Added code to determine the version number of
 contributed packages from their directory names so that HTML documentation
 builds are less confusing.

---
 ChangeLog                |  6 ++++++
 tools/tcltk-man2html.tcl | 16 ++++++++++++----
 2 files changed, 18 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 50ddec3..abaf7b5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-08-01  Donal K. Fellows  <dkf@users.sf.net>
+
+	* tools/tcltk-man2html.tcl (plus-pkgs): [Bug 3382474]: Added code to
+	determine the version number of contributed packages from their
+	directory names so that HTML documentation builds are less confusing.
+
 2011-07-29  Donal K. Fellows  <dkf@users.sf.net>
 
 	* tools/tcltk-man2html.tcl (ensemble_commands, remap_link_target):
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index 2bde714..eaadc51 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -766,23 +766,31 @@ proc plus-pkgs {type args} {
     if {!$build_tcl} return
     set result {}
     foreach {dir name} $args {
-	set globpat $tcltkdir/$tcldir/pkgs/$dir/doc/*.$type
+	set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/*.$type
 	if {![llength [glob -nocomplain $globpat]]} {
 	    # Fallback for manpages generated using doctools
-	    set globpat $tcltkdir/$tcldir/pkgs/$dir/doc/man/*.$type
+	    set globpat $tcltkdir/$tcldir/pkgs/$dir*/doc/man/*.$type
 	    if {![llength [glob -nocomplain $globpat]]} {
 		continue
 	    }
 	}
+	regexp "pkgs/$dir(.*)/doc$" [glob $tcltkdir/$tcldir/pkgs/$dir*/doc] \
+	    -> version
 	switch $type {
 	    n {
 		set title "$name Package Commands"
+		if {$version ne ""} {
+		    append title ", version $version"
+		}
 		set dir [string totitle $dir]Cmd
 		set desc \
 		    "The additional commands provided by the $name package."
 	    }
 	    3 {
 		set title "$name Package Library"
+		if {$version ne ""} {
+		    append title ", version $version"
+		}
 		set dir [string totitle $dir]Lib
 		set desc \
 		    "The additional C functions provided by the $name package."
@@ -945,8 +953,8 @@ try {
 	append appdir "$tkdir"
     }
 
-    # Get the list of packages to try, and what their human-readable
-    # names are.
+    # Get the list of packages to try, and what their human-readable names
+    # are. Note that the package directory list should be version-less.
     try {
 	set packageDirNameMap {}
 	if {$build_tcl} {
-- 
cgit v0.12


From a51e3eead5f69832eaa7002d41e40b3b6ae4f646 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 1 Aug 2011 09:34:08 +0000
Subject: Added some examples of how some of the standard global variables can
 be used, following prompting by a request by Robert Hicks.

---
 ChangeLog     |  4 ++++
 doc/tclvars.n | 37 +++++++++++++++++++++++++++++++++++++
 2 files changed, 41 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index abaf7b5..7794884 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2011-08-01  Donal K. Fellows  <dkf@users.sf.net>
 
+	* doc/tclvars.n (EXAMPLES): Added some examples of how some of the
+	standard global variables can be used, following prompting by a
+	request by Robert Hicks.
+
 	* tools/tcltk-man2html.tcl (plus-pkgs): [Bug 3382474]: Added code to
 	determine the version number of contributed packages from their
 	directory names so that HTML documentation builds are less confusing.
diff --git a/doc/tclvars.n b/doc/tclvars.n
index b126b7f..3bd18e8 100644
--- a/doc/tclvars.n
+++ b/doc/tclvars.n
@@ -485,6 +485,7 @@ bug fixes that retain backward compatibility.
 The value of this variable is returned by the \fBinfo tclversion\fR
 command.
 .SH "OTHER GLOBAL VARIABLES"
+.PP
 The following variables are only guaranteed to exist in \fBtclsh\fR
 and \fBwish\fR executables; the Tcl library does not define them
 itself but many Tcl environments do.
@@ -508,6 +509,42 @@ was invoked.
 Contains 1 if \fBtclsh\fR or \fBwish\fR is running interactively (no
 script was specified and standard input is a terminal-like device), 0
 otherwise.
+.SH EXAMPLES
+.PP
+To add a directory to the collection of locations searched by
+\fBpackage require\fR, e.g., because of some application-specific
+packages that are used, the \fBauto_path\fR variable needs to be
+updated:
+.PP
+.CS
+lappend ::\fBauto_path\fR [file join [pwd] "theLibDir"]
+.CE
+.PP
+A simple though not very robust way to handle command line arguments
+of the form
+.QW "\-foo 1 \-bar 2"
+is to load them into an array having first loaded in the default settings:
+.CS
+array set arguments {-foo 0 -bar 0 -grill 0}
+array set arguments $::\fBargv\fR
+puts "foo is $arguments(-foo)"
+puts "bar is $arguments(-bar)"
+puts "grill is $arguments(-grill)"
+.CE
+.PP
+The \fBargv0\fR global variable can be used (in conjunction with the
+\fBinfo script\fR command) to determine whether the current script is
+being executed as the main script or loaded as a library.  This is
+useful because it allows a single script to be used as both a library
+and a demonstration of that library:
+.PP
+.CS
+if {$::\fBargv0\fR eq [info script]} {
+    # running as: tclsh example.tcl
+} else {
+    package provide Example 1.0
+}
+.CE
 .SH "SEE ALSO"
 eval(n), library(n), tclsh(1), tkvars(n), wish(1)
 .SH KEYWORDS
-- 
cgit v0.12


From 666118190e342c616ccffff20d1f7d0f14abe242 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 1 Aug 2011 10:07:23 +0000
Subject: General cleanup of tests to promote intelligibility and to try to
 ensure that what is tested is just that which was the subject of the test.

---
 tests/encoding.test | 187 ++++++++++++++++++++++++++--------------------------
 1 file changed, 93 insertions(+), 94 deletions(-)

diff --git a/tests/encoding.test b/tests/encoding.test
index 1738413..a4f8449 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -1,12 +1,12 @@
 # This file contains a collection of tests for tclEncoding.c
-# 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.
 
 package require tcltest 2
 
@@ -25,32 +25,34 @@ proc fromutf {args} {
 }
 
 proc runtests {} {
-
     variable x
 
 # Some tests require the testencoding command
 testConstraint testencoding [llength [info commands testencoding]]
 testConstraint exec [llength [info commands exec]]
-
+testConstraint testgetdefenc [llength [info commands testgetdefenc]]
+
 # TclInitEncodingSubsystem is tested by the rest of this file
 # TclFinalizeEncodingSubsystem is not currently tested
 
-test encoding-1.1 {Tcl_GetEncoding: system encoding} {testencoding} {
-    testencoding create foo [namespace origin toutf] [namespace origin fromutf]
+test encoding-1.1 {Tcl_GetEncoding: system encoding} -setup {
     set old [encoding system]
+} -constraints {testencoding} -body {
+    testencoding create foo [namespace origin toutf] [namespace origin fromutf]
     encoding system foo
     set x {}
     encoding convertto abcd
+    return $x
+} -cleanup {
     encoding system $old
     testencoding delete foo
-    set x
-} {{fromutf }}
+} -result {{fromutf }}
 test encoding-1.2 {Tcl_GetEncoding: existing encoding} {testencoding} {
     testencoding create foo [namespace origin toutf] [namespace origin fromutf]
     set x {}
     encoding convertto foo abcd
     testencoding delete foo
-    set x
+    return $x
 } {{fromutf }}
 test encoding-1.3 {Tcl_GetEncoding: load encoding} {
     list [encoding convertto jis0208 \u4e4e] \
@@ -60,71 +62,77 @@ test encoding-1.3 {Tcl_GetEncoding: load encoding} {
 test encoding-2.1 {Tcl_FreeEncoding: refcount == 0} {
     encoding convertto jis0208 \u4e4e
 } {8C}
-test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} {testencoding} {
+test encoding-2.2 {Tcl_FreeEncoding: refcount != 0} -setup {
     set system [encoding system]
     set path [encoding dirs]
+} -constraints {testencoding} -body {
     encoding system shiftjis		;# incr ref count
     encoding dirs [list [pwd]]
     set x [encoding convertto shiftjis \u4e4e]	;# old one found   
     encoding system identity
     llength shiftjis		;# Shimmer away any cache of Tcl_Encoding
     lappend x [catch {encoding convertto shiftjis \u4e4e} msg] $msg
+} -cleanup {
     encoding system identity
     encoding dirs $path
     encoding system $system
-    set x
-} "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"
+} -result "\u008c\u00c1 1 {unknown encoding \"shiftjis\"}"
 
-test encoding-3.1 {Tcl_GetEncodingName, NULL} {
+test encoding-3.1 {Tcl_GetEncodingName, NULL} -setup {
     set old [encoding system]
+} -body {
     encoding system shiftjis
-    set x [encoding system]
+    encoding system
+} -cleanup {
     encoding system $old
-    set x
-} {shiftjis}
-test encoding-3.2 {Tcl_GetEncodingName, non-null} {
+} -result {shiftjis}
+test encoding-3.2 {Tcl_GetEncodingName, non-null} -setup {
     set old [fconfigure stdout -encoding]
+} -body {
     fconfigure stdout -encoding jis0208
-    set x [fconfigure stdout -encoding]
+    fconfigure stdout -encoding
+} -cleanup {
     fconfigure stdout -encoding $old
-    set x
-} {jis0208}
+} -result {jis0208}
 
-test encoding-4.1 {Tcl_GetEncodingNames} {testencoding} {
+test encoding-4.1 {Tcl_GetEncodingNames} -constraints {testencoding} -setup {
     cd [makeDirectory tmp]
     makeDirectory [file join tmp encoding]
-    makeFile {} [file join tmp encoding junk.enc]
-    makeFile {} [file join tmp encoding junk2.enc]
     set path [encoding dirs]
     encoding dirs {}
     catch {unset encodings}
     catch {unset x}
+} -body {
     foreach encoding [encoding names] {
 	set encodings($encoding) 1
     }
+    makeFile {} [file join tmp encoding junk.enc]
+    makeFile {} [file join tmp encoding junk2.enc]
     encoding dirs [list [file join [pwd] encoding]]
     foreach encoding [encoding names] {
 	if {![info exists encodings($encoding)]} {
 	    lappend x $encoding
 	}
     }
+    lsort $x
+} -cleanup {
     encoding dirs $path
     cd [workingDirectory]
     removeFile [file join tmp encoding junk2.enc]
     removeFile [file join tmp encoding junk.enc]
     removeDirectory [file join tmp encoding]
     removeDirectory tmp
-    lsort $x
-} {junk junk2}
+} -result {junk junk2}
 
-test encoding-5.1 {Tcl_SetSystemEncoding} {
+test encoding-5.1 {Tcl_SetSystemEncoding} -setup {
     set old [encoding system]
+} -body {
     encoding system jis0208
-    set x [encoding convertto \u4e4e]
+    encoding convertto \u4e4e
+} -cleanup {
     encoding system identity
     encoding system $old
-    set x
-} {8C}
+} -result {8C}
 test encoding-5.2 {Tcl_SetSystemEncoding: test ref count} {
     set old [encoding system]
     encoding system $old
@@ -138,7 +146,7 @@ test encoding-6.1 {Tcl_CreateEncoding: new} {testencoding} {
     encoding convertfrom foo abcd
     encoding convertto foo abcd
     testencoding delete foo
-    set x
+    return $x
 } {{toutf 1} {fromutf 2}}
 test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
     testencoding create foo [namespace code {toutf a}] \
@@ -147,7 +155,7 @@ test encoding-6.2 {Tcl_CreateEncoding: replace encoding} {testencoding} {
     encoding convertfrom foo abcd
     encoding convertto foo abcd
     testencoding delete foo
-    set x
+    return $x
 } {{toutf a} {fromutf b}}
 
 test encoding-7.1 {Tcl_ExternalToUtfDString: small buffer} {
@@ -173,7 +181,7 @@ test encoding-8.1 {Tcl_ExternalToUtf} {
     set x [read $f]
     close $f
     file delete [file join [temporaryDirectory] dummy]
-    set x
+    return $x
 } "ab\u4e4eg"
 
 test encoding-9.1 {Tcl_UtfToExternalDString: small buffer} {
@@ -201,7 +209,7 @@ test encoding-10.1 {Tcl_UtfToExternal} {
     set x [read $f]
     close $f
     file delete [file join [temporaryDirectory] dummy]
-    set x
+    return $x
 } "ab\x8c\xc1g"
 
 proc viewable {str} {
@@ -242,10 +250,11 @@ test encoding-11.5 {LoadEncodingFile: escape file} {
 test encoding-11.5.1 {LoadEncodingFile: escape file} {
     viewable [encoding convertto iso2022-jp \u4e4e]
 } [viewable "\x1b\$B8C\x1b(B"]
-test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
+test encoding-11.6 {LoadEncodingFile: invalid file} -constraints {testencoding} -setup {
     set system [encoding system]
     set path [encoding dirs]
     encoding system identity
+} -body {
     cd [temporaryDirectory]
     encoding dirs [file join tmp encoding]
     makeDirectory tmp
@@ -254,15 +263,15 @@ test encoding-11.6 {LoadEncodingFile: invalid file} {testencoding} {
     fconfigure $f -translation binary 
     puts $f "abcdefghijklmnop"
     close $f
-    set x [list [catch {encoding convertto splat \u4e4e} msg] $msg]
+    encoding convertto splat \u4e4e
+} -returnCodes error -cleanup {
     file delete [file join [temporaryDirectory] tmp encoding splat.enc]
     removeDirectory [file join tmp encoding]
     removeDirectory tmp
     cd [workingDirectory]
     encoding dirs $path
     encoding system $system
-    set x
-} {1 {invalid encoding file "splat"}}
+} -result {invalid encoding file "splat"}
 
 # OpenEncodingFile is fully tested by the rest of the tests in this file.
 
@@ -300,7 +309,6 @@ test encoding-14.1 {BinaryProc} {
 test encoding-15.1 {UtfToUtfProc} {
     encoding convertto utf-8 \xa3
 } "\xc2\xa3"
-
 test encoding-15.2 {UtfToUtfProc null character output} {
     set x \u0000
     set y [encoding convertto utf-8 \u0000]
@@ -308,7 +316,6 @@ test encoding-15.2 {UtfToUtfProc null character output} {
     binary scan $y H* z
     list [string bytelength $x] [string bytelength $y] $z
 } {2 1 00}
-
 test encoding-15.3 {UtfToUtfProc null character input} {
     set x [encoding convertfrom identity \x00]
     set y [encoding convertfrom utf-8 $x]
@@ -388,44 +395,40 @@ test encoding-23.3 {iso2022-jp escape encoding test} {
     fconfigure $fid -encoding iso2022-jp
     set data [read $fid 50]
     close $fid
-    set data
+    return $data
 } [string range $iso2022uniData 0 49] ; # 0 .. 49 inclusive == 50
 cd [workingDirectory]
 
-test encoding-24.1 {EscapeFreeProc on open channels} -constraints {
-	exec
-} -setup {
-    # Bug #524674 input
-    set file [makeFile {
+# Code to make the next few tests more intelligible; the code being tested
+# should be in the body of the test!
+proc runInSubprocess {contents {filename iso2022.tcl}} {
+    set theFile [makeFile $contents $filename]
+    try {
+	exec [interpreter] $theFile
+    } finally {
+	removeFile $theFile
+    }
+}
+
+test encoding-24.1 {EscapeFreeProc on open channels} exec {
+    runInSubprocess {
 	set f [open [file join [file dirname [info script]] iso2022.txt]]
 	fconfigure $f -encoding iso2022-jp
 	gets $f
-    } iso2022.tcl]
-} -body {
-    exec [interpreter] $file
-} -cleanup {
-    removeFile iso2022.tcl
-} -result {}
-
-test encoding-24.2 {EscapeFreeProc on open channels} -constraints {
-	exec
-} -setup {
+    }
+} {}
+test encoding-24.2 {EscapeFreeProc on open channels} exec {
     # Bug #524674 output
-    set file [makeFile {
+    viewable [runInSubprocess {
 	encoding system cp1252;	# Bug #2891556 crash revelator
 	fconfigure stdout -encoding iso2022-jp
 	puts ab\u4e4e\u68d9g
 	testfinexit
-    } iso2022.tcl]
-} -body {
-    viewable [exec [interpreter] $file]
-} -cleanup {
-    removeFile iso2022.tcl
-} -result "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
-
+    }]
+} "ab\x1b\$B8C\x1b\$(DD%\x1b(Bg (ab\\u001b\$B8C\\u001b\$(DD%\\u001b(Bg)"
 test encoding-24.3 {EscapeFreeProc on open channels} {stdio} {
-    # Bug #219314 - if we don't free escape encodings correctly on
-    # channel closure, we go boom
+    # Bug #219314 - if we don't free escape encodings correctly on channel
+    # closure, we go boom
     set file [makeFile {
 	encoding system iso2022-jp
 	set a "\u4e4e\u4e5e\u4e5f"; # 3 Japanese Kanji letters
@@ -469,18 +472,14 @@ proc foreach-jisx0208 {varName command} {
     } {
 	if {[llength $range] == 2} {
 	    # for adhoc range. simple {first last}. inclusive.
-	    set first [scan [lindex $range 0] %x]
-	    set last [scan [lindex $range 1] %x]
+	    scan $range %x%x first last
 	    for {set i $first} {$i <= $last} {incr i} {
 		set code $i
 		uplevel 1 $command
 	    }
 	} elseif {[llength $range] == 4} {
 	    # for uniform range.
-	    set h0 [scan [lindex $range 0] %x]
-	    set l0 [scan [lindex $range 1] %x]
-	    set hend [scan [lindex $range 2] %x]
-	    set lend [scan [lindex $range 3] %x]
+	    scan $range %x%x%x%x h0 l0 hend lend
 	    for {set hi $h0} {$hi <= $hend} {incr hi} {
 		for {set lo $l0} {$lo <= $lend} {incr lo} {
 		    set code [expr {$hi << 8 | ($lo & 0xff)}]
@@ -524,7 +523,7 @@ proc channel-diff {fa fb} {
 	binary scan [lindex $lb 1] H* got
 	lappend diff [list $code $expected $got]
     }
-    set diff
+    return $diff
 }
 
 # Create char tables.
@@ -543,8 +542,9 @@ file copy -force cp932.chars shiftjis.chars
 set NUM 0
 foreach from {cp932 shiftjis euc-jp iso2022-jp} {
     foreach to {cp932 shiftjis euc-jp iso2022-jp} {
-	test encoding-25.[incr NUM] "jisx0208 $from => $to" {
+	test encoding-25.[incr NUM] "jisx0208 $from => $to" -setup {
 	    cd [temporaryDirectory]
+	} -body {
 	    set f [open $from.chars]
 	    fconfigure $f -encoding $from
 	    set out [open $from.$to.tcltestout w]
@@ -552,40 +552,35 @@ foreach from {cp932 shiftjis euc-jp iso2022-jp} {
 	    puts -nonewline $out [read $f]
 	    close $out
 	    close $f
-	    
 	    # then compare $to.chars <=> $from.to.tcltestout as binary.
-	    set fa [open $to.chars]
-	    fconfigure $fa -encoding binary
-	    set fb [open $from.$to.tcltestout]
-	    fconfigure $fb -encoding binary
-	    set diff [channel-diff $fa $fb]
+	    set fa [open $to.chars rb]
+	    set fb [open $from.$to.tcltestout rb]
+	    channel-diff $fa $fb
+	    # Difference should be empty.
+	} -cleanup {
 	    close $fa
 	    close $fb
-	    
-	    # Difference should be empty.
-	    set diff
-	} {}
+	} -result {}
     }
 }
 
-testConstraint testgetdefenc [llength [info commands testgetdefenc]]
-
 test encoding-26.0 {Tcl_GetDefaultEncodingDir} -constraints {
-    testgetdefenc 
+    testgetdefenc
 } -setup {
-     set origDir [testgetdefenc]
-     testsetdefenc slappy
+    set origDir [testgetdefenc]
+    testsetdefenc slappy
 } -body {
-     testgetdefenc
+    testgetdefenc
 } -cleanup {
-     testsetdefenc $origDir
+    testsetdefenc $origDir
 } -result slappy
 
 file delete {*}[glob -directory [temporaryDirectory] *.chars *.tcltestout]
 # ===> Cut here <===
 
-# EscapeFreeProc, GetTableEncoding, unilen
-# are fully tested by the rest of this file
+# EscapeFreeProc, GetTableEncoding, unilen are fully tested by the rest of
+# this file.
+
 }
 runtests
 
@@ -595,3 +590,7 @@ runtests
 namespace delete ::tcl::test::encoding
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End:
-- 
cgit v0.12


From 7cafb9729cb8db722600b80cd3b1c9536ca46519 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 1 Aug 2011 17:15:19 +0000
Subject: * generic/tclProc.c (TclProcCompileProc): fix for leak of resolveInfo
 when recompiling procs, [Bug 3383616]. Thx go to Gustaf Neumann for detecting
 the bug and providing the fix.

---
 ChangeLog         | 6 ++++++
 generic/tclProc.c | 7 +++++++
 2 files changed, 13 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 7794884..b4d5502 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-08-01  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclProc.c (TclProcCompileProc): fix for leak of
+	resolveInfo when recompiling procs, [Bug 3383616]. Thx go to
+	Gustaf Neumann for detecting the bug and providing the fix.
+
 2011-08-01  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/tclvars.n (EXAMPLES): Added some examples of how some of the
diff --git a/generic/tclProc.c b/generic/tclProc.c
index a2de765..48f472f 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -2063,6 +2063,13 @@ TclProcCompileProc(
 		CompiledLocal *toFree = clPtr;
 
 		clPtr = clPtr->nextPtr;
+		if (toFree->resolveInfo) {
+		    if (toFree->resolveInfo->deleteProc) {
+			toFree->resolveInfo->deleteProc(toFree->resolveInfo);
+		    } else {
+			ckfree(toFree->resolveInfo);
+		    }
+		}
 		ckfree(toFree);
 	    }
 	    procPtr->numCompiledLocals = procPtr->numArgs;
-- 
cgit v0.12


From 48549658629032dd38411079fd36f81ca3ff56e6 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 2 Aug 2011 09:07:29 +0000
Subject: [Bug 3384007]: Fix some panic messages.

---
 ChangeLog        | 12 +++++++++---
 generic/tclObj.c | 46 +++++++++++++++++++++-------------------------
 2 files changed, 30 insertions(+), 28 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b4d5502..b9a37ed 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,14 @@
+2011-08-02  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclObj.c (Tcl_DbIncrRefCount, Tcl_DbDecrRefCount)
+	(Tcl_DbIsShared): [Bug 3384007]: Fix the panic messages so they share
+	what should be shared and have the right number of spaces.
+
 2011-08-01  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclProc.c (TclProcCompileProc): fix for leak of
-	resolveInfo when recompiling procs, [Bug 3383616]. Thx go to
-	Gustaf Neumann for detecting the bug and providing the fix.
+	* generic/tclProc.c (TclProcCompileProc): [Bug 3383616]: Fix for leak
+	of resolveInfo when recompiling procs. Thanks go to Gustaf Neumann for
+	detecting the bug and providing the fix.
 
 2011-08-01  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclObj.c b/generic/tclObj.c
index 95924c1..a1316d9 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -3713,23 +3713,21 @@ Tcl_DbIncrRefCount(
      */
 
     if (!TclInExit()) {
-	Tcl_HashTable *tablePtr;
-	Tcl_HashEntry *hPtr;
 	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+	Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
+	Tcl_HashEntry *hPtr;
 
-	tablePtr = tsdPtr->objThreadMap;
 	if (!tablePtr) {
 	    Tcl_Panic("object table not initialized");
 	}
 	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
 	if (!hPtr) {
-	    Tcl_Panic("%s%s",
-		    "Trying to incr ref count of ",
-		    "Tcl_Obj allocated in another thread");
+	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
+                    "incr ref count");
 	}
     }
-# endif
-#endif
+# endif /* TCL_THREADS */
+#endif /* TCL_MEM_DEBUG */
     ++(objPtr)->refCount;
 }
 
@@ -3778,19 +3776,17 @@ Tcl_DbDecrRefCount(
      */
 
     if (!TclInExit()) {
-	Tcl_HashTable *tablePtr;
-	Tcl_HashEntry *hPtr;
 	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+	Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
+	Tcl_HashEntry *hPtr;
 
-	tablePtr = tsdPtr->objThreadMap;
 	if (!tablePtr) {
 	    Tcl_Panic("object table not initialized");
 	}
 	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
 	if (!hPtr) {
-	    Tcl_Panic("%s%s",
-		    "Trying to decr ref count of ",
-		    "Tcl_Obj allocated in another thread");
+	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
+                    "decr ref count");
 	}
 
 	/*
@@ -3807,8 +3803,9 @@ Tcl_DbDecrRefCount(
 	    Tcl_DeleteHashEntry(hPtr);
 	}
     }
-# endif
-#endif
+# endif /* TCL_THREADS */
+#endif /* TCL_MEM_DEBUG */
+
     if (--(objPtr)->refCount <= 0) {
 	TclFreeObj(objPtr);
     }
@@ -3858,22 +3855,21 @@ Tcl_DbIsShared(
      */
 
     if (!TclInExit()) {
-	Tcl_HashTable *tablePtr;
-	Tcl_HashEntry *hPtr;
 	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-	tablePtr = tsdPtr->objThreadMap;
+	Tcl_HashTable *tablePtr = tsdPtr->objThreadMap;
+	Tcl_HashEntry *hPtr;
+
 	if (!tablePtr) {
 	    Tcl_Panic("object table not initialized");
 	}
 	hPtr = Tcl_FindHashEntry(tablePtr, objPtr);
 	if (!hPtr) {
-	    Tcl_Panic("%s%s",
-		    "Trying to check shared status of",
-		    "Tcl_Obj allocated in another thread");
+	    Tcl_Panic("Trying to %s of Tcl_Obj allocated in another thread",
+                    "check shared status");
 	}
     }
-# endif
-#endif
+# endif /* TCL_THREADS */
+#endif /* TCL_MEM_DEBUG */
 
 #ifdef TCL_COMPILE_STATS
     Tcl_MutexLock(&tclObjMutex);
@@ -3885,7 +3881,7 @@ Tcl_DbIsShared(
 	tclObjsShared[0]++;
     }
     Tcl_MutexUnlock(&tclObjMutex);
-#endif
+#endif /* TCL_COMPILE_STATS */
 
     return ((objPtr)->refCount > 1);
 }
-- 
cgit v0.12


From e6bcda9b1f02804a103d402c12abf8b22b743084 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 2 Aug 2011 14:04:30 +0000
Subject: Updates for 8.6b2 release.

---
 ChangeLog | 4 ++++
 changes   | 4 +++-
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index b9a37ed..4293b16 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-08-02  Don Porter  <dgp@users.sourceforge.net>
+
+	* changes:	Updates for 8.6b2 release.
+
 2011-08-02  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclObj.c (Tcl_DbIncrRefCount, Tcl_DbDecrRefCount)
diff --git a/changes b/changes
index 75fcda3..76ed3e8 100644
--- a/changes
+++ b/changes
@@ -7949,6 +7949,8 @@ memory with buffer backup (ferrieux)
 
 2011-07-28 tzdata updated to Olson's tzdata2011h (porter)
 
+2011-08-01 (bug fix)[3383616] memleak exposed by XOTcl (neumann,sofer)
+
 Many more Tcl built-in command errors now set an -errorcode.
 
---- Released 8.6b2, August 3, 2011 --- See ChangeLog for details ---
+--- Released 8.6b2, August 5, 2011 --- See ChangeLog for details ---
-- 
cgit v0.12


From ff2d7ecb2916f4732bc397c7b640acc2d2100a24 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 2 Aug 2011 14:45:30 +0000
Subject: Variable substitution botch.

---
 ChangeLog                | 1 +
 tools/tcltk-man2html.tcl | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 4293b16..3e3bbec 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,7 @@
 2011-08-02  Don Porter  <dgp@users.sourceforge.net>
 
 	* changes:	Updates for 8.6b2 release.
+	* tools/tcltk-man2html.tcl: Variable substitution botch.
 
 2011-08-02  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index eaadc51..552095e 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -774,7 +774,7 @@ proc plus-pkgs {type args} {
 		continue
 	    }
 	}
-	regexp "pkgs/$dir(.*)/doc$" [glob $tcltkdir/$tcldir/pkgs/$dir*/doc] \
+	regexp "pkgs/${dir}(.*)/doc$" [glob $tcltkdir/$tcldir/pkgs/$dir*/doc] \
 	    -> version
 	switch $type {
 	    n {
-- 
cgit v0.12


From af556848dde348585c87d0115a8de6c77356b3c1 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 2 Aug 2011 15:11:51 +0000
Subject: Use the actual case used by Thread to name the directory its
 distributions unpack into.

---
 tools/tcltk-man2html.tcl | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index 552095e..b347abf 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -973,7 +973,7 @@ try {
 	set packageDirNameMap {
 	    itcl {[incr Tcl]}
 	    tdbc {TDBC}
-	    Thread Thread
+	    thread Thread
 	}
     }
 
-- 
cgit v0.12


From 92c2318f0bcf65d962079a1dc6cec0326921a2b5 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 3 Aug 2011 18:12:14 +0000
Subject: Fix build on systems where ECANCELED == ELIBMAX

---
 generic/tclPosixStr.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclPosixStr.c b/generic/tclPosixStr.c
index b722336..d0002ec 100644
--- a/generic/tclPosixStr.c
+++ b/generic/tclPosixStr.c
@@ -203,7 +203,7 @@ Tcl_ErrnoId(void)
 #ifdef ELIBEXEC
     case ELIBEXEC: return "ELIBEXEC";
 #endif
-#ifdef ELIBMAX
+#if defined(ELIBMAX) && (!defined(ECANCELED) || (ELIBMAX != ECANCELED))
     case ELIBMAX: return "ELIBMAX";
 #endif
 #ifdef ELIBSCN
@@ -662,7 +662,7 @@ Tcl_ErrnoMsg(
 #ifdef ELIBEXEC
     case ELIBEXEC: return "cannot exec a shared library directly";
 #endif
-#ifdef ELIBMAX
+#if defined(ELIBMAX) && (!defined(ECANCELED) || (ELIBMAX != ECANCELED))
     case ELIBMAX: return
 	    "attempting to link in more shared libraries than system limit";
 #endif
-- 
cgit v0.12


From d82fd277a100d2f7d8297003c6aeae4cef56a6fa Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 3 Aug 2011 19:42:57 +0000
Subject: Update file generated by `make dist`

---
 unix/tclConfig.h.in | 31 +++++++++++++++++++++++++++++--
 1 file changed, 29 insertions(+), 2 deletions(-)

diff --git a/unix/tclConfig.h.in b/unix/tclConfig.h.in
index debbd53..42abf34 100644
--- a/unix/tclConfig.h.in
+++ b/unix/tclConfig.h.in
@@ -28,10 +28,16 @@
 /* Do we have access to Darwin CoreFoundation.framework? */
 #undef HAVE_COREFOUNDATION
 
+/* Define to 1 if you have the `freeaddrinfo' function. */
+#undef HAVE_FREEADDRINFO
+
 /* Do we have fts functions? */
 #undef HAVE_FTS
 
-/* Define to 1 if getaddrinfo is available. */
+/* Define to 1 if you have the `gai_strerror' function. */
+#undef HAVE_GAI_STRERROR
+
+/* Define to 1 if you have the `getaddrinfo' function. */
 #undef HAVE_GETADDRINFO
 
 /* Define to 1 if you have the `getattrlist' function. */
@@ -79,6 +85,9 @@
 /* Define to 1 if gethostbyname_r takes 6 args. */
 #undef HAVE_GETHOSTBYNAME_R_6
 
+/* Define to 1 if you have the `getnameinfo' function. */
+#undef HAVE_GETNAMEINFO
+
 /* Define to 1 if getpwnam_r is available. */
 #undef HAVE_GETPWNAM_R
 
@@ -178,9 +187,21 @@
 /* Define to 1 if you have the `strtol' function. */
 #undef HAVE_STRTOL
 
+/* Define to 1 if the system has the type `struct addrinfo'. */
+#undef HAVE_STRUCT_ADDRINFO
+
 /* Is 'struct dirent64' in <sys/types.h>? */
 #undef HAVE_STRUCT_DIRENT64
 
+/* Define to 1 if the system has the type `struct in6_addr'. */
+#undef HAVE_STRUCT_IN6_ADDR
+
+/* Define to 1 if the system has the type `struct sockaddr_in6'. */
+#undef HAVE_STRUCT_SOCKADDR_IN6
+
+/* Define to 1 if the system has the type `struct sockaddr_storage'. */
+#undef HAVE_STRUCT_SOCKADDR_STORAGE
+
 /* Is 'struct stat64' in <sys/stat.h>? */
 #undef HAVE_STRUCT_STAT64
 
@@ -244,12 +265,15 @@
 /* Is this a Mac I see before me? */
 #undef MAC_OSX_TCL
 
-/* Compiler support for module scope symbols */
+/* No Compiler support for module scope symbols */
 #undef MODULE_SCOPE
 
 /* Default libtommath precision. */
 #undef MP_PREC
 
+/* Use compat implementation of getaddrinfo() and friends */
+#undef NEED_FAKE_RFC2553
+
 /* Is Darwin CoreFoundation unavailable for 64-bit? */
 #undef NO_COREFOUNDATION_64
 
@@ -307,6 +331,9 @@
 /* Do we have <values.h>? */
 #undef NO_VALUES_H
 
+/* No visibility attribute */
+#undef NO_VIZ
+
 /* Do we have wait3() */
 #undef NO_WAIT3
 
-- 
cgit v0.12


From 277d2c7075ce7dee345ae755f48675378a04edc2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 4 Aug 2011 13:16:22 +0000
Subject: [Bug 3384840]: Fix memory leaks in the assembler due to Tcl_Obj
 reference ownership error.

---
 ChangeLog             | 10 +++++++
 generic/tclAssembly.c | 22 +++-----------
 tests/assemble.test   | 82 +++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 96 insertions(+), 18 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 3e3bbec..e6bf629 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2011-08-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand)
+	(GetIntegerOperand, GetListIndexOperand, FindLocalVar): [Bug 3384840]:
+	A Tcl_Obj is allocated by GetNextOperand, so callers of it must not
+	hold a reference to one in the 'out' parameter when calling it. This
+	was causing a great many memory leaks.
+	* tests/assemble.test (assemble-51.*): Added group of memory leak
+	tests.
+
 2011-08-02  Don Porter  <dgp@users.sourceforge.net>
 
 	* changes:	Updates for 8.6b2 release.
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 1b87886..e12d0f8 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -1244,8 +1244,6 @@ AssembleOneLine(
      */
 
     tokenPtr = parsePtr->tokenPtr;
-    instNameObj = Tcl_NewObj();
-    Tcl_IncrRefCount(instNameObj);
     if (GetNextOperand(assemEnvPtr, &tokenPtr, &instNameObj) != TCL_OK) {
 	return TCL_ERROR;
     }
@@ -2087,17 +2085,14 @@ GetBooleanOperand(
     Tcl_Token* tokenPtr = *tokenPtrPtr;
 				/* INOUT: Pointer to the next token in the
 				 * source code */
-    Tcl_Obj* intObj = Tcl_NewObj();
-				/* Integer from the source code */
+    Tcl_Obj* intObj;		/* Integer from the source code */
     int status;			/* Tcl status return */
 
     /*
      * Extract the next token as a string.
      */
 
-    Tcl_IncrRefCount(intObj);
     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
-	Tcl_DecrRefCount(intObj);
 	return TCL_ERROR;
     }
 
@@ -2143,17 +2138,14 @@ GetIntegerOperand(
     Tcl_Token* tokenPtr = *tokenPtrPtr;
 				/* INOUT: Pointer to the next token in the
 				 * source code */
-    Tcl_Obj* intObj = Tcl_NewObj();
-				/* Integer from the source code */
+    Tcl_Obj* intObj;		/* Integer from the source code */
     int status;			/* Tcl status return */
 
     /*
      * Extract the next token as a string.
      */
 
-    Tcl_IncrRefCount(intObj);
     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
-	Tcl_DecrRefCount(intObj);
 	return TCL_ERROR;
     }
 
@@ -2199,17 +2191,14 @@ GetListIndexOperand(
     Tcl_Token* tokenPtr = *tokenPtrPtr;
 				/* INOUT: Pointer to the next token in the
 				 * source code */
-    Tcl_Obj* intObj = Tcl_NewObj();
-				/* Integer from the source code */
+    Tcl_Obj* intObj;		/* Integer from the source code */
     int status;			/* Tcl status return */
 
     /*
      * Extract the next token as a string.
      */
 
-    Tcl_IncrRefCount(intObj);
     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &intObj) != TCL_OK) {
-	Tcl_DecrRefCount(intObj);
 	return TCL_ERROR;
     }
 
@@ -2256,15 +2245,12 @@ FindLocalVar(
     Tcl_Token* tokenPtr = *tokenPtrPtr;
 				/* INOUT: Pointer to the next token
 				 * in the source code */
-    Tcl_Obj* varNameObj = Tcl_NewObj();
-				/* Name of the variable */
+    Tcl_Obj* varNameObj;	/* Name of the variable */
     const char* varNameStr;
     int varNameLen;
     int localVar;		/* Index of the variable in the LVT */
 
-    Tcl_IncrRefCount(varNameObj);
     if (GetNextOperand(assemEnvPtr, tokenPtrPtr, &varNameObj) != TCL_OK) {
-	Tcl_DecrRefCount(varNameObj);
 	return -1;
     }
     varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
diff --git a/tests/assemble.test b/tests/assemble.test
index dae4821..7d4e5d1 100644
--- a/tests/assemble.test
+++ b/tests/assemble.test
@@ -30,6 +30,23 @@ proc fillTables {} {
     }
     return $s
 }
+
+testConstraint memory [llength [info commands memory]]
+if {[testConstraint memory]} {
+    proc getbytes {} {
+	set lines [split [memory info] \n]
+	return [lindex $lines 3 3]
+    }
+    proc leaktest {script {iterations 3}} {
+	set end [getbytes]
+	for {set i 0} {$i < $iterations} {incr i} {
+	    uplevel 1 $script
+	    set tmp $end
+	    set end [getbytes]
+	}
+	return [expr {$end - $tmp}]
+    }
+}
 
 # assemble-1 - TclNRAssembleObjCmd
 
@@ -3198,6 +3215,71 @@ test assemble-50.1 {Ulam's 3n+1 problem, TAL implementation} {
     }
     -result {1 2 16 4 16 16 52 8 52 16 52 16 40 52 160 16 52 52 88 20 64 52 160 24 88 40 9232 52 88}
 }
+
+test assemble-51.1 {memory leak testing} memory {
+    leaktest {
+	apply {{} {assemble {push hello}}}
+    }
+} 0
+test assemble-51.2 {memory leak testing} memory {
+    leaktest {
+	apply {{{x 0}} {assemble {incrImm x 1}}}
+    }
+} 0
+test assemble-51.3 {memory leak testing} memory {
+    leaktest {
+	apply {{n} {
+	    assemble {
+		load n;		# max
+		dup;		# max n
+		jump start;     # max n
+	    
+		label loop;	# max n
+		over 1;         # max n max
+		over 1;		# max in max n
+		ge;             # man n max>=n
+		jumpTrue skip;  # max n
+
+		reverse 2;      # n max
+		pop;            # n
+		dup;            # n n
+	    
+		label skip;	# max n
+		dup;            # max n n
+		push 2;         # max n n 2
+		mod;            # max n n%2
+		jumpTrue odd;   # max n
+	    
+		push 2;         # max n 2
+		div;            # max n/2 -> max n
+		jump start;     # max n
+	     
+		label odd;	# max n
+		push 3;         # max n 3
+		mult;           # max 3*n
+		push 1;         # max 3*n 1
+		add;            # max 3*n+1
+	    
+		label start;	# max n
+		dup;		# max n n
+		push 1;		# max n n 1
+		neq;		# max n n>1
+		jumpTrue loop;	# max n
+	    
+		pop;		# max
+	    }
+	}} 1
+    }
+} 0
+test assemble-51.4 {memory leak testing} memory {
+    leaktest {
+	catch {
+	    apply {{} {
+		assemble {reverse polish notation}
+	    }}
+	}
+    }
+} 0
 
 rename fillTables {}
 rename assemble {}
-- 
cgit v0.12


From 2d023b4b58bc316adcf9e9721273392145c60fc2 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Thu, 4 Aug 2011 14:03:59 +0000
Subject: Don't use AI_ADDRCONFIG for now. It seems to do more harm than good.

---
 ChangeLog           | 12 ++++++++++++
 generic/tclIOSock.c |  9 +++++++++
 2 files changed, 21 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index e6bf629..7d4e098 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+<<<<<<< BEGIN MERGE CONFLICT: local copy shown first <<<<<<<<<<<<<<<
+2011-08-04  Reinhard Max  <max@suse.de>
+
+	* generic/tclIOSock.c (TclCreateSocketAddress): Don't bother using
+	AI_ADDRCONFIG for now, as it was causing problems in various
+	situations.
+	
+2011-08-02  Don Porter  <dgp@users.sourceforge.net>
+======= COMMON ANCESTOR content follows ============================
+2011-08-02  Don Porter  <dgp@users.sourceforge.net>
+======= MERGED IN content follows ==================================
 2011-08-04  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand)
@@ -9,6 +20,7 @@
 	tests.
 
 2011-08-02  Don Porter  <dgp@users.sourceforge.net>
+>>>>>>> END MERGE CONFLICT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 
 	* changes:	Updates for 8.6b2 release.
 	* tools/tcltk-man2html.tcl: Variable substitution botch.
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index aabd67d..768428f 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -178,6 +178,14 @@ TclCreateSocketAddress(
     }
 
     hints.ai_socktype = SOCK_STREAM;
+#if 0
+    /*
+     * We found some problems when using AI_ADDRCONFIG, e.g. on systems that
+     * have no networking besides the loopback interface and want to resolve
+     * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of
+     * using AI_ADDRCONFIG in situations where it works, is probably low,
+     * we'll leave it out for now. After all, it is just an optimisation.
+     */
 #if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux)
     /*
      * Missing on: OpenBSD, NetBSD.
@@ -185,6 +193,7 @@ TclCreateSocketAddress(
      */
     hints.ai_flags |= AI_ADDRCONFIG;
 #endif
+#endif
     if (willBind) {
 	hints.ai_flags |= AI_PASSIVE;
     } 
-- 
cgit v0.12


From a789207beed7bac51e02a7710720d6c550e7014d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 4 Aug 2011 14:13:33 +0000
Subject: More memleak plugging.

---
 ChangeLog             | 14 +++++++-------
 generic/tclAssembly.c | 17 ++---------------
 2 files changed, 9 insertions(+), 22 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 7d4e098..38914cf 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,14 +1,15 @@
-<<<<<<< BEGIN MERGE CONFLICT: local copy shown first <<<<<<<<<<<<<<<
+2011-08-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclAssembly.c (FreeAssemblyEnv): [Bug 3384840]: Plug another
+	possible memory leak due to over-complex code for freeing the table of
+	labels.
+
 2011-08-04  Reinhard Max  <max@suse.de>
 
 	* generic/tclIOSock.c (TclCreateSocketAddress): Don't bother using
 	AI_ADDRCONFIG for now, as it was causing problems in various
 	situations.
-	
-2011-08-02  Don Porter  <dgp@users.sourceforge.net>
-======= COMMON ANCESTOR content follows ============================
-2011-08-02  Don Porter  <dgp@users.sourceforge.net>
-======= MERGED IN content follows ==================================
+
 2011-08-04  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclAssembly.c (AssembleOneLine, GetBooleanOperand)
@@ -20,7 +21,6 @@
 	tests.
 
 2011-08-02  Don Porter  <dgp@users.sourceforge.net>
->>>>>>> END MERGE CONFLICT >>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>>
 
 	* changes:	Updates for 8.6b2 release.
 	* tools/tcltk-man2html.tcl: Variable substitution botch.
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index e12d0f8..7868882 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -1173,24 +1173,10 @@ FreeAssemblyEnv(
     }
 
     /*
-     * Free the label hash.
-     */
-
-    while (1) {
-	Tcl_HashEntry* hashEntry;
-	Tcl_HashSearch hashSearch;
-
-	hashEntry = Tcl_FirstHashEntry(&assemEnvPtr->labelHash, &hashSearch);
-	if (hashEntry == NULL) {
-	    break;
-	}
-	Tcl_DeleteHashEntry(hashEntry);
-    }
-
-    /*
      * Dispose what's left.
      */
 
+    Tcl_DeleteHashTable(&assemEnvPtr->labelHash);
     TclStackFree(interp, assemEnvPtr->parsePtr);
     TclStackFree(interp, assemEnvPtr);
 }
@@ -2255,6 +2241,7 @@ FindLocalVar(
     }
     varNameStr = Tcl_GetStringFromObj(varNameObj, &varNameLen);
     if (CheckNamespaceQualifiers(interp, varNameStr, varNameLen)) {
+	Tcl_DecrRefCount(varNameObj);
 	return -1;
     }
     localVar = TclFindCompiledLocal(varNameStr, varNameLen, 1, envPtr);
-- 
cgit v0.12


From 3859a76809d6666ff194afbb5c4883f3c4e7fae6 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 4 Aug 2011 14:38:09 +0000
Subject: missing TIP id in changes

---
 changes | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/changes b/changes
index 76ed3e8..f364e1c 100644
--- a/changes
+++ b/changes
@@ -7563,7 +7563,7 @@ avoid otherwise very tricky multi-thread finalization bugs. (staplin,ferrieux)
 
 2009-07-16 (bug fix)[2819200] underflow settings on MIPS systems (porter)
 
-2009-07-19 (interface) new public routine Tcl_GetObjectName() (fellows)
+2009-07-19 (interface)[TIP 354] new routine Tcl_GetObjectName() (fellows)
 
 2009-07-20 (performance) favor [string is] success cases over empty (fellows)
 
@@ -7726,7 +7726,7 @@ memory with buffer backup (ferrieux)
 
 2010-03-20 (enhancement) permit [fcopy] of > 2**31 bytes (fellows)
 
-2010-03-24 (new feature) [info object methodtype] (fellows)
+2010-03-24 (new feature)[TIP 354] [info object methodtype] (fellows)
 
 2010-03-24 (bug fix)[2383005] [return -errorcode] reject non-list (porter)
 
-- 
cgit v0.12


From a919f9d8847122e540b39459604823b06bffd0eb Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 4 Aug 2011 16:35:52 +0000
Subject: More changes tidying.

---
 changes | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/changes b/changes
index f364e1c..434750c 100644
--- a/changes
+++ b/changes
@@ -7532,7 +7532,7 @@ evaluation in extensions (sofer,kenny)
 
 2009-05-08 (bug fix)[2414858] tailcall in oo constructor (fellows)
 
-2009-05-14 (new subcommand) [info object namespace] (fellows)
+2009-05-14 (new subcommand)[TIP 354] [info object namespace] (fellows)
 
 2009-05-29 (platform support) account for ia64_32 (kupries)
 => platform 1.0.5
@@ -7726,7 +7726,7 @@ memory with buffer backup (ferrieux)
 
 2010-03-20 (enhancement) permit [fcopy] of > 2**31 bytes (fellows)
 
-2010-03-24 (new feature)[TIP 354] [info object methodtype] (fellows)
+2010-03-24 (new feature) [info object methodtype] (fellows)
 
 2010-03-24 (bug fix)[2383005] [return -errorcode] reject non-list (porter)
 
-- 
cgit v0.12


From 1e205f662a0808f3bf55bf56fff31bbf425a1f99 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Thu, 4 Aug 2011 18:40:05 +0000
Subject: * generic/tclVar.c (TclPtrSetVar): fix valgrind-detected error when
 newValuePtr is the interp's result obj.

---
 ChangeLog        | 5 +++++
 generic/tclVar.c | 3 ++-
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 38914cf..13f8a69 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-04  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclVar.c (TclPtrSetVar): fix valgrind-detected error
+	when newValuePtr is the interp's result obj.
+	
 2011-08-04  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclAssembly.c (FreeAssemblyEnv): [Bug 3384840]: Plug another
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 55c031c..62bf1c4 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -1826,6 +1826,7 @@ TclPtrSetVar(
     Tcl_Obj *oldValuePtr;
     Tcl_Obj *resultPtr = NULL;
     int result;
+    int cleanupOnEarlyError = (newValuePtr->refCount == 0);
 
     /*
      * If the variable is in a hashtable and its hPtr field is NULL, then we
@@ -1997,7 +1998,7 @@ TclPtrSetVar(
     return resultPtr;
 
   earlyError:
-    if (newValuePtr->refCount == 0) {
+    if (cleanupOnEarlyError) {
 	Tcl_DecrRefCount(newValuePtr);
     }
     goto cleanup;
-- 
cgit v0.12


From ac6a1491aaf30ac441a0c7bbd5963c3188b722e6 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 4 Aug 2011 23:12:30 +0000
Subject: [Bug 3386197]: Plug memory leak in unstacking of zlib transforms.

---
 ChangeLog         | 13 +++++++++----
 generic/tclZlib.c | 14 ++++++++++++++
 2 files changed, 23 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 13f8a69..61825c0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,13 @@
+2011-08-05  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclZlib.c (ZlibTransformClose): [Bug 3386197]: Plug a memory
+	leak found by Miguel with valgrind.
+
 2011-08-04  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclVar.c (TclPtrSetVar): fix valgrind-detected error
-	when newValuePtr is the interp's result obj.
-	
+	* generic/tclVar.c (TclPtrSetVar): Fix valgrind-detected error when
+	newValuePtr is the interp's result obj.
+
 2011-08-04  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclAssembly.c (FreeAssemblyEnv): [Bug 3384840]: Plug another
@@ -149,7 +154,7 @@
 
 2011-07-07  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclBasic.c: add missing INT2PTR
+	* generic/tclBasic.c: Add missing INT2PTR
 
 2011-07-03  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 3ddc3fb..80431a3 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -2253,7 +2253,16 @@ ZlibTransformClose(
     ZlibChannelData *cd = instanceData;
     int e, result = TCL_OK;
 
+    /*
+     * Delete the support timer.
+     */
+
     ZlibTransformTimerKill(cd);
+
+    /*
+     * Flush any data waiting to be compressed.
+     */
+
     if (cd->mode == TCL_ZLIB_STREAM_DEFLATE) {
 	cd->outStream.avail_in = 0;
 	do {
@@ -2291,6 +2300,10 @@ ZlibTransformClose(
 	e = inflateEnd(&cd->outStream);
     }
 
+    /*
+     * Release all memory.
+     */
+
     if (cd->inBuffer) {
 	ckfree(cd->inBuffer);
 	cd->inBuffer = NULL;
@@ -2299,6 +2312,7 @@ ZlibTransformClose(
 	ckfree(cd->outBuffer);
 	cd->outBuffer = NULL;
     }
+    ckfree(cd);
     return result;
 }
 
-- 
cgit v0.12


From c6ae1163ac5b975510aad910b2693c58accdac96 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 5 Aug 2011 00:00:15 +0000
Subject: [Bug 3386197]: Fix buffer direction botch. Damn you, confusing
 terminology!

---
 ChangeLog         | 3 ++-
 generic/tclZlib.c | 4 ++--
 2 files changed, 4 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 61825c0..9d2b16d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,8 @@
 2011-08-05  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclZlib.c (ZlibTransformClose): [Bug 3386197]: Plug a memory
-	leak found by Miguel with valgrind.
+	leak found by Miguel with valgrind, and ensure that the correct
+	direction's buffers are released.
 
 2011-08-04  Miguel Sofer  <msofer@users.sf.net>
 
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 80431a3..922ec18 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -2295,9 +2295,9 @@ ZlibTransformClose(
 		}
 	    }
 	} while (e != Z_STREAM_END);
-	e = deflateEnd(&cd->inStream);
+	e = deflateEnd(&cd->outStream);
     } else {
-	e = inflateEnd(&cd->outStream);
+	e = inflateEnd(&cd->inStream);
     }
 
     /*
-- 
cgit v0.12


From 6c25700250fe041510e2332ba954737b21f3146d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 5 Aug 2011 09:36:48 +0000
Subject: Ensure that memory isn't leaked when an unknown instruction is
 encountered.

---
 ChangeLog             |   4 +
 generic/tclAssembly.c | 219 +++++++++++++++++++++++++-------------------------
 2 files changed, 115 insertions(+), 108 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 9d2b16d..c233e6d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2011-08-05  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclAssembly.c (AssembleOneLine): Ensure that memory isn't
+	leaked when an unknown instruction is encountered. Also simplify code
+	through use of Tcl_ObjPrintf in error message generation.
+
 	* generic/tclZlib.c (ZlibTransformClose): [Bug 3386197]: Plug a memory
 	leak found by Miguel with valgrind, and ensure that the correct
 	direction's buffers are released.
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 7868882..eca934f 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -1,5 +1,5 @@
 /*
- * tclAssembly,c --
+ * tclAssembly.c --
  *
  *	Assembler for Tcl bytecodes.
  *
@@ -84,7 +84,7 @@ typedef struct BasicBlock {
 				 * unresolved */
     int initialStackDepth;	/* Absolute stack depth on entry */
     int minStackDepth;		/* Low-water relative stack depth */
-    int maxStackDepth; 		/* High-water relative stack depth */
+    int maxStackDepth;		/* High-water relative stack depth */
     int finalStackDepth;	/* Relative stack depth on exit */
     enum BasicBlockCatchState catchState;
 				/* State of the block for 'catch' analysis */
@@ -193,7 +193,7 @@ typedef enum TalInstType {
 
 typedef struct TalInstDesc {
     const char *name;		/* Name of instruction. */
-    TalInstType instType; 	/* The type of instruction */
+    TalInstType instType;	/* The type of instruction */
     int tclInstCode;		/* Instruction code. For instructions having
 				 * 1- and 4-byte variables, tclInstCode is
 				 * ((1byte)<<8) || (4byte) */
@@ -831,16 +831,20 @@ CompileAssembleObj(
     if (objPtr->typePtr == &assembleCodeType) {
 	namespacePtr = iPtr->varFramePtr->nsPtr;
 	codePtr = objPtr->internalRep.otherValuePtr;
-	if (((Interp *) *codePtr->interpHandle != iPtr)
-		|| (codePtr->compileEpoch != iPtr->compileEpoch)
-		|| (codePtr->nsPtr != namespacePtr)
-		|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)
-		|| (codePtr->localCachePtr
-			!= iPtr->varFramePtr->localCachePtr)) {
-	    FreeAssembleCodeInternalRep(objPtr);
-	} else {
+	if (((Interp *) *codePtr->interpHandle == iPtr)
+		&& (codePtr->compileEpoch == iPtr->compileEpoch)
+		&& (codePtr->nsPtr == namespacePtr)
+		&& (codePtr->nsEpoch == namespacePtr->resolverEpoch)
+		&& (codePtr->localCachePtr
+			== iPtr->varFramePtr->localCachePtr)) {
 	    return codePtr;
 	}
+
+	/*
+	 * Not valid, so free it and regenerate.
+	 */
+
+	FreeAssembleCodeInternalRep(objPtr);
     }
 
     /*
@@ -967,7 +971,7 @@ TclCompileAssembleCmd(
 
 static int
 TclAssembleCode(
-    CompileEnv *envPtr, 	/* Compilation environment that is to receive
+    CompileEnv *envPtr,		/* Compilation environment that is to receive
 				 * the generated bytecode */
     const char* codePtr,	/* Assembly-language code to be processed */
     int codeLen,		/* Length of the code */
@@ -1208,13 +1212,12 @@ AssembleOneLine(
     Tcl_Parse* parsePtr = assemEnvPtr->parsePtr;
 				/* Parse of the line of code */
     Tcl_Token* tokenPtr;	/* Current token within the line of code */
-    Tcl_Obj* instNameObj = NULL;
-				/* Name of the instruction */
+    Tcl_Obj* instNameObj;	/* Name of the instruction */
     int tblIdx;			/* Index in TalInstructionTable of the
 				 * instruction */
     enum TalInstType instType;	/* Type of the instruction */
     Tcl_Obj* operand1Obj = NULL;
-    				/* First operand to the instruction */
+				/* First operand to the instruction */
     const char* operand1;	/* String rep of the operand */
     int operand1Len;		/* String length of the operand */
     int opnd;			/* Integer representation of an operand */
@@ -1241,7 +1244,7 @@ AssembleOneLine(
     if (Tcl_GetIndexFromObjStruct(interp, instNameObj,
 	    &TalInstructionTable[0].name, sizeof(TalInstDesc), "instruction",
 	    TCL_EXACT, &tblIdx) != TCL_OK) {
-	return TCL_ERROR;
+	goto cleanup;
     }
 
     /*
@@ -1310,8 +1313,11 @@ AssembleOneLine(
 	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "boolean varName");
 	    goto cleanup;
 	}
-	if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
-		|| (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
+	if (GetBooleanOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+	    goto cleanup;
+	}
+	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
+	if (localVar < 0) {
 	    goto cleanup;
 	}
 	BBEmitInstInt1(assemEnvPtr, tblIdx, opnd, 0);
@@ -1349,8 +1355,11 @@ AssembleOneLine(
 	    goto cleanup;
 	}
 	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
-		|| CheckStrictlyPositive(interp, opnd) != TCL_OK
-		|| (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
+		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
+	    goto cleanup;
+	}
+	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
+	if (localVar < 0) {
 	    goto cleanup;
 	}
 	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd+1);
@@ -1363,8 +1372,11 @@ AssembleOneLine(
 	    goto cleanup;
 	}
 	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
-		|| CheckStrictlyPositive(interp, opnd) != TCL_OK
-		|| (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
+		|| CheckStrictlyPositive(interp, opnd) != TCL_OK) {
+	    goto cleanup;
+	}
+	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
+	if (localVar < 0) {
 	    goto cleanup;
 	}
 	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, opnd);
@@ -1558,7 +1570,8 @@ AssembleOneLine(
 	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
 	    goto cleanup;
 	}
-	if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
+	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
+	if (localVar < 0) {
 	    goto cleanup;
 	}
 	BBEmitInst1or4(assemEnvPtr, tblIdx, localVar, 0);
@@ -1569,8 +1582,8 @@ AssembleOneLine(
 	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
 	    goto cleanup;
 	}
-	if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0
-		|| CheckOneByte(interp, localVar)) {
+	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
+	if (localVar < 0 || CheckOneByte(interp, localVar)) {
 	    goto cleanup;
 	}
 	BBEmitInstInt1(assemEnvPtr, tblIdx, localVar, 0);
@@ -1581,8 +1594,8 @@ AssembleOneLine(
 	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varName imm8");
 	    goto cleanup;
 	}
-	if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0
-		|| CheckOneByte(interp, localVar)
+	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
+	if (localVar < 0 || CheckOneByte(interp, localVar)
 		|| GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
 		|| CheckSignedOneByte(interp, opnd)) {
 	    goto cleanup;
@@ -1596,7 +1609,8 @@ AssembleOneLine(
 	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "varname");
 	    goto cleanup;
 	}
-	if ((localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) < 0) {
+	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
+	if (localVar < 0) {
 	    goto cleanup;
 	}
 	BBEmitInstInt4(assemEnvPtr, tblIdx, localVar, 0);
@@ -1658,8 +1672,11 @@ AssembleOneLine(
 	    Tcl_WrongNumArgs(interp, 1, &instNameObj, "count varName");
 	    goto cleanup;
 	}
-	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK
-		|| (localVar = FindLocalVar(assemEnvPtr, &tokenPtr)) == -1) {
+	if (GetIntegerOperand(assemEnvPtr, &tokenPtr, &opnd) != TCL_OK) {
+	    goto cleanup;
+	}
+	localVar = FindLocalVar(assemEnvPtr, &tokenPtr);
+	if (localVar < 0) {
 	    goto cleanup;
 	}
 	BBEmitInstInt4(assemEnvPtr, tblIdx, opnd, 0);
@@ -1673,9 +1690,7 @@ AssembleOneLine(
 
     status = TCL_OK;
  cleanup:
-    if (instNameObj) {
-	Tcl_DecrRefCount(instNameObj);
-    }
+    Tcl_DecrRefCount(instNameObj);
     if (operand1Obj) {
 	Tcl_DecrRefCount(operand1Obj);
     }
@@ -1857,7 +1872,7 @@ MoveExceptionRangesToBasicBlock(
 	    curr_bb, exceptionCount, savedExceptArrayNext);
     curr_bb->foreignExceptionBase = savedExceptArrayNext;
     curr_bb->foreignExceptionCount = exceptionCount;
-    curr_bb->foreignExceptions = 
+    curr_bb->foreignExceptions =
 	    ckalloc(exceptionCount * sizeof(ExceptionRange));
     memcpy(curr_bb->foreignExceptions,
 	    envPtr->exceptArrayPtr + savedExceptArrayNext,
@@ -1904,7 +1919,6 @@ CreateMirrorJumpTable(
     Tcl_HashEntry* hashEntry;	/* Entry for a key in the hashtable */
     int isNew;			/* Flag==1 if the key is not yet in the
 				 * table. */
-    Tcl_Obj* result;		/* Error message */
     int i;
 
     if (Tcl_ListObjGetElements(interp, jumps, &objc, &objv) != TCL_OK) {
@@ -1940,17 +1954,15 @@ CreateMirrorJumpTable(
 		&isNew);
 	if (!isNew) {
 	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
-		result = Tcl_NewStringObj(
-			"duplicate entry in jump table for \"", -1);
-		Tcl_AppendObjToObj(result, objv[i]);
-		Tcl_AppendToObj(result, "\"", -1);
-		Tcl_SetObjResult(interp, result);
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"duplicate entry in jump table for \"%s\"",
+			Tcl_GetString(objv[i])));
 		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPJUMPTABLEENTRY");
 		DeleteMirrorJumpTable(jtPtr);
 		return TCL_ERROR;
 	    }
 	}
-	Tcl_SetHashValue(hashEntry, (ClientData) objv[i+1]);
+	Tcl_SetHashValue(hashEntry, objv[i+1]);
 	Tcl_IncrRefCount(objv[i+1]);
     }
     DEBUG_PRINT("}\n");
@@ -2229,8 +2241,8 @@ FindLocalVar(
     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
 				/* Tcl interpreter */
     Tcl_Token* tokenPtr = *tokenPtrPtr;
-				/* INOUT: Pointer to the next token
-				 * in the source code */
+				/* INOUT: Pointer to the next token in the
+				 * source code. */
     Tcl_Obj* varNameObj;	/* Name of the variable */
     const char* varNameStr;
     int varNameLen;
@@ -2282,6 +2294,7 @@ CheckNamespaceQualifiers(
 {
     Tcl_Obj* result;		/* Error message */
     const char* p;
+
     for (p = name; p+2 < name+nameLen;  p++) {
 	if ((*p == ':') && (p[1] == ':')) {
 	    result = Tcl_NewStringObj("variable \"", -1);
@@ -2458,7 +2471,6 @@ DefineLabel(
     Tcl_HashEntry* entry;	/* Label's entry in the symbol table */
     int isNew;			/* Flag == 1 iff the label was previously
 				 * undefined */
-    Tcl_Obj* result;		/* Error message */
 
     /* TODO - This can now be simplified! */
 
@@ -2474,14 +2486,11 @@ DefineLabel(
 	 * This is a duplicate label.
 	 */
 
-	if (assemEnvPtr-> flags & (TCL_EVAL_DIRECT)) {
-	    result = Tcl_NewStringObj(
-		    "duplicate definition of label \"", -1);
-	    Tcl_AppendToObj(result, labelName, -1);
-	    Tcl_AppendToObj(result, "\"", -1);
-	    Tcl_SetObjResult(interp, result);
-	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL",
-		    labelName, NULL);
+	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "duplicate definition of label \"%s\"", labelName));
+	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "DUPLABEL", labelName,
+		    NULL);
 	}
 	return TCL_ERROR;
     }
@@ -2518,7 +2527,7 @@ StartBasicBlock(
 {
     CompileEnv* envPtr = assemEnvPtr->envPtr;
 				/* Compilation environment */
-    BasicBlock* newBB;	 	/* BasicBlock structure for the new block */
+    BasicBlock* newBB;		/* BasicBlock structure for the new block */
     BasicBlock* currBB = assemEnvPtr->curr_bb;
 
     /*
@@ -2680,8 +2689,10 @@ FinishAssembly(
 	return TCL_ERROR;
     }
 
-    /* TODO - Check for unreachable code */
-    /* Maybe not - unreachable code is Mostly Harmless. */
+    /*
+     * TODO - Check for unreachable code. Or maybe not; unreachable code is
+     * Mostly Harmless.
+     */
 
     return TCL_OK;
 }
@@ -2739,7 +2750,7 @@ CalculateJumpRelocations(
 	motion = 0;
 	for (bbPtr = assemEnvPtr->head_bb;
 		bbPtr != NULL;
-		bbPtr=bbPtr->successor1) {
+		bbPtr = bbPtr->successor1) {
 	    /*
 	     * Advance the basic block start offset by however many bytes we
 	     * have inserted in the code up to this point
@@ -2839,8 +2850,7 @@ CheckJumpTableLabels(
 		Tcl_GetString(symbolObj));
 	DEBUG_PRINT("  %s -> %s (%d)\n",
 		(char*) Tcl_GetHashKey(symHash, symEntryPtr),
-		Tcl_GetString(symbolObj),
-		(valEntryPtr != NULL));
+		Tcl_GetString(symbolObj), (valEntryPtr != NULL));
 	if (valEntryPtr == NULL) {
 	    ReportUndefinedLabel(assemEnvPtr, bbPtr, symbolObj);
 	    return TCL_ERROR;
@@ -2863,6 +2873,7 @@ CheckJumpTableLabels(
  *
  *-----------------------------------------------------------------------------
  */
+
 static void
 ReportUndefinedLabel(
     AssemblyEnv* assemEnvPtr,	/* Assembly environment */
@@ -2874,13 +2885,10 @@ ReportUndefinedLabel(
 				/* Compilation environment */
     Tcl_Interp* interp = (Tcl_Interp*) envPtr->iPtr;
 				/* Tcl interpreter */
-    Tcl_Obj* result;		/* Error message */
 
     if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
-	result = Tcl_NewStringObj("undefined label \"", -1);
-	Tcl_AppendObjToObj(result, jumpTarget);
-	Tcl_AppendToObj(result, "\"", -1);
-	Tcl_SetObjResult(interp, result);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"undefined label \"%s\"", Tcl_GetString(jumpTarget)));
 	Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NOLABEL",
 		Tcl_GetString(jumpTarget), NULL);
 	Tcl_SetErrorLine(interp, bbPtr->jumpLine);
@@ -3025,8 +3033,7 @@ ResolveJumpTableTargets(
     auxDataIndex = TclGetInt4AtPtr(envPtr->codeStart + bbPtr->jumpOffset + 1);
     DEBUG_PRINT("bbPtr = %p jumpOffset = %d auxDataIndex = %d\n",
 	    bbPtr, bbPtr->jumpOffset, auxDataIndex);
-    realJumpTablePtr = (JumptableInfo*)
-	    envPtr->auxDataArrayPtr[auxDataIndex].clientData;
+    realJumpTablePtr = envPtr->auxDataArrayPtr[auxDataIndex].clientData;
     realJumpHashPtr = &realJumpTablePtr->hashTable;
 
     /*
@@ -3134,7 +3141,6 @@ CheckNonThrowingBlock(
     int bound;			/* Bytecode offset following the last
 				 * instruction of the block. */
     unsigned char opcode;	/* Current bytecode instruction */
-    Tcl_Obj* retval;		/* Error message */
 
     /*
      * Determine where in the code array the basic block ends.
@@ -3164,13 +3170,12 @@ CheckNonThrowingBlock(
 	     */
 
 	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
-		retval = Tcl_NewStringObj("\"", -1);
-		Tcl_AppendToObj(retval, tclInstructionTable[opcode].name, -1);
-		Tcl_AppendToObj(retval, "\" instruction may not appear in "
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"\"%s\" instruction may not appear in "
 			"a context where an exception has been "
-			"caught and not disposed of.", -1);
+			"caught and not disposed of.",
+			tclInstructionTable[opcode].name));
 		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADTHROW", NULL);
-		Tcl_SetObjResult(interp, retval);
 		AddBasicBlockRangeToErrorInfo(assemEnvPtr, blockPtr);
 	    }
 	    return TCL_ERROR;
@@ -3203,7 +3208,7 @@ BytecodeMightThrow(
      */
 
     int min = 0;
-    int max = sizeof(NonThrowingByteCodes)-1;
+    int max = sizeof(NonThrowingByteCodes) - 1;
     int mid;
     unsigned char c;
 
@@ -3344,7 +3349,11 @@ StackCheckBasicBlock(
 	if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
 	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
 		    "inconsistent stack depths on two execution paths", -1));
-	    /* TODO - add execution trace of both paths */
+
+	    /*
+	     * TODO - add execution trace of both paths
+	     */
+
 	    Tcl_SetErrorLine(interp, blockPtr->startLine);
 	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
 	}
@@ -3477,8 +3486,6 @@ StackCheckExit(
     int depth;			/* Net stack effect */
     int litIndex;		/* Index in the literal pool of the empty
 				 * string */
-    Tcl_Obj* depthObj;		/* Net stack effect for an error message */
-    Tcl_Obj* resultObj;		/* Error message from this procedure */
     BasicBlock* curr_bb = assemEnvPtr->curr_bb;
 				/* Final basic block in the assembly */
 
@@ -3489,51 +3496,45 @@ StackCheckExit(
      */
 
     if (curr_bb->flags & BB_VISITED) {
-    	/*
+	/*
 	 * Exit with no operands; push an empty one.
 	 */
 
-    	depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth;
-    	if (depth == 0) {
-    	    /*
+	depth = curr_bb->finalStackDepth + curr_bb->initialStackDepth;
+	if (depth == 0) {
+	    /*
 	     * Emit a 'push' of the empty literal.
 	     */
 
-    	    litIndex = TclRegisterNewLiteral(envPtr, "", 0);
+	    litIndex = TclRegisterNewLiteral(envPtr, "", 0);
 
-    	    /*
+	    /*
 	     * Assumes that 'push' is at slot 0 in TalInstructionTable.
 	     */
 
-    	    BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
-    	    ++depth;
-    	}
+	    BBEmitInst1or4(assemEnvPtr, 0, litIndex, 0);
+	    ++depth;
+	}
 
-    	/*
+	/*
 	 * Exit with unbalanced stack.
 	 */
 
-    	if (depth != 1) {
-    	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
-    		depthObj = Tcl_NewIntObj(depth);
-    		Tcl_IncrRefCount(depthObj);
-    		resultObj = Tcl_NewStringObj(
-			"stack is unbalanced on exit from the code (depth=",
-			-1);
-    		Tcl_AppendObjToObj(resultObj, depthObj);
-    		Tcl_DecrRefCount(depthObj);
-    		Tcl_AppendToObj(resultObj, ")", -1);
-    		Tcl_SetObjResult(interp, resultObj);
-    		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
-    	    }
-    	    return TCL_ERROR;
-    	}
-
-    	/*
+	if (depth != 1) {
+	    if (assemEnvPtr->flags & TCL_EVAL_DIRECT) {
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"stack is unbalanced on exit from the code (depth=%d)",
+			depth));
+		Tcl_SetErrorCode(interp, "TCL", "ASSEM", "BADSTACK", NULL);
+	    }
+	    return TCL_ERROR;
+	}
+
+	/*
 	 * Record stack usage.
 	 */
 
-    	envPtr->currStackDepth += depth;
+	envPtr->currStackDepth += depth;
     }
 
     return TCL_OK;
@@ -3698,8 +3699,10 @@ ProcessCatchesInBasicBlock(
     jumpEnclosing = enclosing;
     jumpState = state;
 
-    /* TODO: Make sure that the test cases include validating
-     *       that a natural loop can't include 'beginCatch' or 'endCatch' */
+    /*
+     * TODO: Make sure that the test cases include validating that a natural
+     * loop can't include 'beginCatch' or 'endCatch'
+     */
 
     if (bbPtr->flags & BB_BEGINCATCH) {
 	/*
@@ -3843,8 +3846,8 @@ BuildExceptionRanges(
     int catchDepth = 0;		/* Current catch depth */
     int maxCatchDepth = 0;	/* Maximum catch depth in the program */
     BasicBlock** catches;	/* Stack of catches in progress */
-    int* catchIndices;		/* Indices of the exception ranges
-				 * of catches in progress */
+    int* catchIndices;		/* Indices of the exception ranges of catches
+				 * in progress */
     int i;
 
     /*
@@ -4093,7 +4096,7 @@ RestoreEmbeddedExceptionRanges(
 				 * range as reinstalled */
     ExceptionRange* range;	/* Current foreign exception range */
     unsigned char opcode;	/* Current instruction's opcode */
-    int catchIndex;	/* Index of the exception range to which the
+    int catchIndex;		/* Index of the exception range to which the
 				 * current instruction refers */
     int i;
 
-- 
cgit v0.12


From 86876436a44b247ec6423fbead92b7c3ce8a2032 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 5 Aug 2011 15:23:55 +0000
Subject: Use Tcl_PrintfObj to generate more (complex) error messages.

---
 generic/tclAssembly.c |  7 ++-----
 generic/tclBasic.c    |  8 ++------
 generic/tclFileName.c | 14 +++++++-------
 generic/tclIO.c       |  9 +++------
 generic/tclIORChan.c  | 43 ++++++++++++++++++-------------------------
 generic/tclIORTrans.c | 36 +++++++++++++++---------------------
 generic/tclObj.c      | 27 +++++++++------------------
 generic/tclProc.c     |  9 ++++-----
 generic/tclStrToD.c   |  6 ++----
 tests/ioTrans.test    |  2 +-
 10 files changed, 63 insertions(+), 98 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index eca934f..f45ae07 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -2292,15 +2292,12 @@ CheckNamespaceQualifiers(
     const char* name,		/* Variable name to check */
     int nameLen)		/* Length of the variable */
 {
-    Tcl_Obj* result;		/* Error message */
     const char* p;
 
     for (p = name; p+2 < name+nameLen;  p++) {
 	if ((*p == ':') && (p[1] == ':')) {
-	    result = Tcl_NewStringObj("variable \"", -1);
-	    Tcl_AppendToObj(result, name, -1);
-	    Tcl_AppendToObj(result, "\" is not local", -1);
-	    Tcl_SetObjResult(interp, result);
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "variable \"%s\" is not local", name));
 	    Tcl_SetErrorCode(interp, "TCL", "ASSEM", "NONLOCAL", name, NULL);
 	    return TCL_ERROR;
 	}
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index c46510c..a44d736 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -3645,12 +3645,8 @@ Tcl_GetMathFuncInfo(
      */
 
     if (cmdPtr == NULL) {
-	Tcl_Obj *message;
-
-	TclNewLiteralStringObj(message, "unknown math function \"");
-	Tcl_AppendToObj(message, name, -1);
-	Tcl_AppendToObj(message, "\"", 1);
-	Tcl_SetObjResult(interp, message);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "unknown math function \"%s\"", name));
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "MATHFUNC", name, NULL);
 	*numArgsPtr = -1;
 	*argTypesPtr = NULL;
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 05ecb04..8ed6f96 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -1210,7 +1210,7 @@ Tcl_GlobObjCmd(
     int index, i, globFlags, length, join, dir, result;
     char *string;
     const char *separators;
-    Tcl_Obj *typePtr, *resultPtr, *look;
+    Tcl_Obj *typePtr, *look;
     Tcl_Obj *pathOrDir = NULL;
     Tcl_DString prefix;
     static const char *const options[] = {
@@ -1497,8 +1497,8 @@ Tcl_GlobObjCmd(
 	    } else {
 		Tcl_Obj *item;
 
-		if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK) &&
-			(len == 3)) {
+		if ((Tcl_ListObjLength(NULL, look, &len) == TCL_OK)
+			&& (len == 3)) {
 		    Tcl_ListObjIndex(interp, look, 0, &item);
 		    if (!strcmp("macintosh", Tcl_GetString(item))) {
 			Tcl_ListObjIndex(interp, look, 1, &item);
@@ -1528,10 +1528,9 @@ Tcl_GlobObjCmd(
 		 */
 
 	    badTypesArg:
-		TclNewObj(resultPtr);
-		Tcl_AppendToObj(resultPtr, "bad argument to \"-types\": ", -1);
-		Tcl_AppendObjToObj(resultPtr, look);
-		Tcl_SetObjResult(interp, resultPtr);
+		Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+			"bad argument to \"-types\": %s",
+			Tcl_GetString(look)));
 		Tcl_SetErrorCode(interp, "TCL", "ARGUMENT", "BAD", NULL);
 		result = TCL_ERROR;
 		join = 0;
@@ -1624,6 +1623,7 @@ Tcl_GlobObjCmd(
 		Tcl_AppendResult(interp, Tcl_DStringValue(&prefix), NULL);
 	    } else {
 		const char *sep = "";
+
 		for (i = 0; i < objc; i++) {
 		    string = Tcl_GetString(objv[i]);
 		    Tcl_AppendResult(interp, sep, string, NULL);
diff --git a/generic/tclIO.c b/generic/tclIO.c
index c7fab6c..78c1dc0 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -2095,12 +2095,9 @@ Tcl_GetChannelHandle(
 
     chanPtr = ((Channel *) chan)->state->bottomChanPtr;
     if (!chanPtr->typePtr->getHandleProc) {
-	Tcl_Obj *err;
-
-	TclNewLiteralStringObj(err, "channel \"");
-	Tcl_AppendToObj(err, Tcl_GetChannelName(chan), -1);
-	Tcl_AppendToObj(err, "\" does not support OS handles", -1);
-	Tcl_SetChannelError(chan, err);
+        Tcl_SetChannelError(chan, Tcl_ObjPrintf(
+                "channel \"%s\" does not support OS handles",
+                Tcl_GetChannelName(chan)));
 	return TCL_ERROR;
     }
     result = chanPtr->typePtr->getHandleProc(chanPtr->instanceData, direction,
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 683e2e4..9ba42ef 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -605,11 +605,9 @@ TclChanCreateObjCmd(
      */
 
     if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1);
-	Tcl_AppendObjToObj(err, resObj);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s initialize\" returned non-list: %s",
+                Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
 	Tcl_DecrRefCount(resObj);
 	goto error;
     }
@@ -633,42 +631,37 @@ TclChanCreateObjCmd(
     Tcl_DecrRefCount(resObj);
 
     if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" does not support all required methods", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" does not support all required methods",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
     if ((mode & TCL_READABLE) && !HAS(methods, METH_READ)) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" lacks a \"read\" method", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" lacks a \"read\" method",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
     if ((mode & TCL_WRITABLE) && !HAS(methods, METH_WRITE)) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" lacks a \"write\" method", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" lacks a \"write\" method",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
     if (!IMPLIES(HAS(methods, METH_CGET), HAS(methods, METH_CGETALL))) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" supports \"cget\" but not \"cgetall\"", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" supports \"cget\" but not \"cgetall\"",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
     if (!IMPLIES(HAS(methods, METH_CGETALL), HAS(methods, METH_CGET))) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" supports \"cgetall\" but not \"cget\"", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" supports \"cgetall\" but not \"cget\"",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 5bd77b7..272306b 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -601,11 +601,9 @@ TclChanPushObjCmd(
      */
 
     if (Tcl_ListObjGetElements(NULL, resObj, &listc, &listv) != TCL_OK) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, " initialize\" returned non-list: ", -1);
-	Tcl_AppendObjToObj(err, resObj);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s initialize\" returned non-list: %s",
+                Tcl_GetString(cmdObj), Tcl_GetString(resObj)));
 	Tcl_DecrRefCount(resObj);
 	goto error;
     }
@@ -629,10 +627,9 @@ TclChanPushObjCmd(
     Tcl_DecrRefCount(resObj);
 
     if ((REQUIRED_METHODS & methods) != REQUIRED_METHODS) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" does not support all required methods", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" does not support all required methods",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
@@ -652,10 +649,9 @@ TclChanPushObjCmd(
     }
 
     if (!mode) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" makes the channel inacessible", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" makes the channel inaccessible",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
@@ -664,18 +660,16 @@ TclChanPushObjCmd(
      */
 
     if (!IMPLIES(HAS(methods, METH_DRAIN), HAS(methods, METH_READ))) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" supports \"drain\" but not \"read\"", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" supports \"drain\" but not \"read\"",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
     if (!IMPLIES(HAS(methods, METH_FLUSH), HAS(methods, METH_WRITE))) {
-	TclNewLiteralStringObj(err, "chan handler \"");
-	Tcl_AppendObjToObj(err, cmdObj);
-	Tcl_AppendToObj(err, "\" supports \"flush\" but not \"write\"", -1);
-	Tcl_SetObjResult(interp, err);
+        Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                "chan handler \"%s\" supports \"flush\" but not \"write\"",
+                Tcl_GetString(cmdObj)));
 	goto error;
     }
 
diff --git a/generic/tclObj.c b/generic/tclObj.c
index a1316d9..099b67d 100644
--- a/generic/tclObj.c
+++ b/generic/tclObj.c
@@ -2763,12 +2763,9 @@ Tcl_GetLongFromObj(
 #endif
 	if (objPtr->typePtr == &tclDoubleType) {
 	    if (interp != NULL) {
-		Tcl_Obj *msg;
-
-		TclNewLiteralStringObj(msg, "expected integer but got \"");
-		Tcl_AppendObjToObj(msg, objPtr);
-		Tcl_AppendToObj(msg, "\"", -1);
-		Tcl_SetObjResult(interp, msg);
+                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                        "expected integer but got \"%s\"",
+                        Tcl_GetString(objPtr)));
 		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
 	    }
 	    return TCL_ERROR;
@@ -3067,12 +3064,9 @@ Tcl_GetWideIntFromObj(
 	}
 	if (objPtr->typePtr == &tclDoubleType) {
 	    if (interp != NULL) {
-		Tcl_Obj *msg;
-
-		TclNewLiteralStringObj(msg, "expected integer but got \"");
-		Tcl_AppendObjToObj(msg, objPtr);
-		Tcl_AppendToObj(msg, "\"", -1);
-		Tcl_SetObjResult(interp, msg);
+                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                        "expected integer but got \"%s\"",
+                        Tcl_GetString(objPtr)));
 		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
 	    }
 	    return TCL_ERROR;
@@ -3401,12 +3395,9 @@ GetBignumFromObj(
 #endif
 	if (objPtr->typePtr == &tclDoubleType) {
 	    if (interp != NULL) {
-		Tcl_Obj *msg;
-
-		TclNewLiteralStringObj(msg, "expected integer but got \"");
-		Tcl_AppendObjToObj(msg, objPtr);
-		Tcl_AppendToObj(msg, "\"", -1);
-		Tcl_SetObjResult(interp, msg);
+                Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+                        "expected integer but got \"%s\"",
+                        Tcl_GetString(objPtr)));
 		Tcl_SetErrorCode(interp, "TCL", "VALUE", "INTEGER", NULL);
 	    }
 	    return TCL_ERROR;
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 48f472f..50cf0f7 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -2480,7 +2480,7 @@ SetLambdaFromAny(
 {
     Interp *iPtr = (Interp *) interp;
     const char *name;
-    Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv, *errPtr;
+    Tcl_Obj *argsPtr, *bodyPtr, *nsObjPtr, **objv;
     int objc, result;
     Proc *procPtr;
 
@@ -2495,10 +2495,9 @@ SetLambdaFromAny(
 
     result = TclListObjGetElements(NULL, objPtr, &objc, &objv);
     if ((result != TCL_OK) || ((objc != 2) && (objc != 3))) {
-	TclNewLiteralStringObj(errPtr, "can't interpret \"");
-	Tcl_AppendObjToObj(errPtr, objPtr);
-	Tcl_AppendToObj(errPtr, "\" as a lambda expression", -1);
-	Tcl_SetObjResult(interp, errPtr);
+	Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		"can't interpret \"%s\" as a lambda expression",
+		Tcl_GetString(objPtr)));
 	Tcl_SetErrorCode(interp, "TCL", "VALUE", "LAMBDA", NULL);
 	return TCL_ERROR;
     }
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index 15bff3e..8a961ff 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -1384,11 +1384,9 @@ TclParseNumber(
 
     if (status != TCL_OK) {
 	if (interp != NULL) {
-	    Tcl_Obj *msg;
+	    Tcl_Obj *msg = Tcl_ObjPrintf("expected %s but got \"",
+		    expected);
 
-	    TclNewLiteralStringObj(msg, "expected ");
-	    Tcl_AppendToObj(msg, expected, -1);
-	    Tcl_AppendToObj(msg, " but got \"", -1);
 	    Tcl_AppendLimitedToObj(msg, bytes, numBytes, 50, "");
 	    Tcl_AppendToObj(msg, "\"", -1);
 	    if (state == BAD_OCTAL) {
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index 3ea017b..d8defcc 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -207,7 +207,7 @@ test iortrans-2.14 {chan push, initialize failed, bad result, mode/handler misma
 } -returnCodes error -cleanup {
     tempdone
     rename foo {}
-} -match glob -result {*makes the channel inacessible}
+} -match glob -result {*makes the channel inaccessible}
 # iortrans-2.15 event/watch methods elimimated, removed these tests.
 # iortrans-2.16
 test iortrans-2.17 {chan push, initialize failed, bad result, drain/read mismatch} -body {
-- 
cgit v0.12


From c29c6011291530fa0d9f267921fbc93c5e3e0cb6 Mon Sep 17 00:00:00 2001
From: Kevin B Kenny <kennykb@acm.org>
Date: Sat, 6 Aug 2011 16:27:00 +0000
Subject: Plug another memory leak. [Bug 3384840]

---
 ChangeLog             | 4 ++++
 generic/tclAssembly.c | 7 +++++++
 2 files changed, 11 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 1523872..30568c7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-08-06  Kevin B, Kenny  <kennykb@acm.org>
+
+	* generic/tclAssemnbly.c: Plug another memory leak. [Bug 3384840]
+
 2011-08-05  Kevin B. Kenny  <kennykb@acm.org>
 
 	* generic/tclStrToD.c: Plugged a memory leak in double->string
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index f45ae07..3c23358 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -3893,11 +3893,18 @@ BuildExceptionRanges(
 	prevPtr = bbPtr;
     }
 
+    /* Make sure that all catches are closed */
+
     if (catchDepth != 0) {
 	Tcl_Panic("unclosed catch at end of code in "
 		"tclAssembly.c:BuildExceptionRanges, can't happen");
     }
 
+    /* Free temp storage */
+
+    ckfree(catchIndices);
+    ckfree(catches);
+
     return TCL_OK;
 }
 
-- 
cgit v0.12


From 45f4a7ec08a29687ec671b5ff71549f7dc1d659f Mon Sep 17 00:00:00 2001
From: Kevin B Kenny <kennykb@acm.org>
Date: Sat, 6 Aug 2011 19:56:41 +0000
Subject: Plug another memory leak. [Bug 3384840]

---
 generic/tclAssembly.c | 21 +++++++++++++++------
 1 file changed, 15 insertions(+), 6 deletions(-)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 3c23358..22bcdcc 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -783,11 +783,6 @@ TclNRAssembleObjCmd(
      * Use NRE to evaluate the bytecode from the trampoline.
      */
 
-#if 0
-    Tcl_NRAddCallback(interp, NRCallTEBC, INT2PTR(TCL_NR_BC_TYPE), codePtr,
-	    NULL, NULL);
-    return TCL_OK;
-#endif
     return TclNRExecuteByteCode(interp, codePtr);
 }
 
@@ -817,11 +812,17 @@ CompileAssembleObj(
     CompileEnv compEnv;		/* Compilation environment structure */
     register ByteCode *codePtr = NULL;
 				/* Bytecode resulting from the assembly */
+    register const AuxData * auxDataPtr;
+				/* Pointer to an auxiliary data element
+				 * in a compilation environment being
+				 * destroyed. */
     Namespace* namespacePtr;	/* Namespace in which variable and command
 				 * names in the bytecode resolve */
     int status;			/* Status return from Tcl_AssembleCode */
     const char* source;		/* String representation of the source code */
     int sourceLen;		/* Length of the source code in bytes */
+    int i;
+
 
     /*
      * Get the expression ByteCode from the object. If it exists, make sure it
@@ -858,7 +859,15 @@ CompileAssembleObj(
 	/*
 	 * Assembly failed. Clean up and report the error.
 	 */
-
+	for (i = 0; i < compEnv.literalArrayNext; i++) {
+	    TclReleaseLiteral(interp, compEnv.literalArrayPtr[i].objPtr);
+	}
+	for (i = 0; i < compEnv.auxDataArrayNext; i++) {
+	    auxDataPtr = compEnv.auxDataArrayPtr + i;
+	    if (auxDataPtr->type->freeProc != NULL) {
+		(auxDataPtr->type->freeProc)(auxDataPtr->clientData);
+	    }
+	}
 	TclFreeCompileEnv(&compEnv);
 	return NULL;
     }
-- 
cgit v0.12


From d90ed9c0f07bbb5cf66140e89fcebc0da3f08285 Mon Sep 17 00:00:00 2001
From: Kevin B Kenny <kennykb@acm.org>
Date: Sat, 6 Aug 2011 20:49:35 +0000
Subject: * generic/tclAssemnbly.c: Plug another memory leak. [Bug 3384840] *
 generic/tclStrToD.c: Plug another memory leak. [Bug 3386975]

---
 ChangeLog             |  1 +
 generic/tclAssembly.c | 29 +++++++++++++++++++++++++++++
 generic/tclStrToD.c   |  3 +++
 3 files changed, 33 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 30568c7..293490a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,7 @@
 2011-08-06  Kevin B, Kenny  <kennykb@acm.org>
 
 	* generic/tclAssemnbly.c: Plug another memory leak. [Bug 3384840]
+	* generic/tclStrToD.c: Plug another memory leak. [Bug 3386975]
 
 2011-08-05  Kevin B. Kenny  <kennykb@acm.org>
 
diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 22bcdcc..cd6dc38 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -859,15 +859,44 @@ CompileAssembleObj(
 	/*
 	 * Assembly failed. Clean up and report the error.
 	 */
+
+	/*
+	 * Free any literals that were constructed for the assembly.
+	 */
 	for (i = 0; i < compEnv.literalArrayNext; i++) {
 	    TclReleaseLiteral(interp, compEnv.literalArrayPtr[i].objPtr);
 	}
+
+	/*
+	 * Free any auxiliary data that was attached to the bytecode
+	 * under construction.
+	 */
+
 	for (i = 0; i < compEnv.auxDataArrayNext; i++) {
 	    auxDataPtr = compEnv.auxDataArrayPtr + i;
 	    if (auxDataPtr->type->freeProc != NULL) {
 		(auxDataPtr->type->freeProc)(auxDataPtr->clientData);
 	    }
 	}
+
+	/*
+	 * TIP 280. If there is extended command line information,
+	 * we need to clean it up.
+	 */
+
+	if (compEnv.extCmdMapPtr != NULL) {
+	    if (compEnv.extCmdMapPtr->type == TCL_LOCATION_SOURCE) {
+		Tcl_DecrRefCount(compEnv.extCmdMapPtr->path);
+	    }
+	    for (i = 0; i < compEnv.extCmdMapPtr->nuloc; ++i) {
+		ckfree(compEnv.extCmdMapPtr->loc[i].line);
+	    }
+	    if (compEnv.extCmdMapPtr->loc != NULL) {
+		ckfree(compEnv.extCmdMapPtr->loc);
+	    }
+	    Tcl_DeleteHashTable(&(compEnv.extCmdMapPtr->litInfo));
+	}
+
 	TclFreeCompileEnv(&compEnv);
 	return NULL;
     }
diff --git a/generic/tclStrToD.c b/generic/tclStrToD.c
index c2d4ed8..a55ee83 100755
--- a/generic/tclStrToD.c
+++ b/generic/tclStrToD.c
@@ -4479,6 +4479,9 @@ TclFinalizeDoubleConversion(void)
     for (i=0; i<9; ++i) {
 	mp_clear(pow5 + i);
     }
+    for (i=0; i < 5; ++i) {
+	mp_clear(pow5_13 + i);
+    }
 }
 
 /*
-- 
cgit v0.12


From 097bee7c6ba61b29717c1780aed2370468649e4f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 7 Aug 2011 15:46:09 +0000
Subject: [Bug 3387082]: Plug memory leak in call chain introspection.

---
 ChangeLog           | 13 +++++++++----
 generic/tclOOCall.c |  6 ++----
 generic/tclOOInfo.c |  1 +
 tests/ooNext2.test  | 25 +++++++++++++++++++++++++
 4 files changed, 37 insertions(+), 8 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 293490a..1acc1ea 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,12 +1,17 @@
+2011-08-07  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOInfo.c (InfoClassCallCmd): [Bug 3387082]: Plug memory
+	leak in call chain introspection.
+
 2011-08-06  Kevin B, Kenny  <kennykb@acm.org>
 
-	* generic/tclAssemnbly.c: Plug another memory leak. [Bug 3384840]
-	* generic/tclStrToD.c: Plug another memory leak. [Bug 3386975]
+	* generic/tclAssemnbly.c: [Bug 3384840]: Plug another memory leak.
+	* generic/tclStrToD.c: [Bug 3386975]: Plug another memory leak.
 
 2011-08-05  Kevin B. Kenny  <kennykb@acm.org>
 
-	* generic/tclStrToD.c: Plugged a memory leak in double->string
-	conversion. [Bug 3386975]
+	* generic/tclStrToD.c: [Bug 3386975]: Plugged a memory leak in
+	double->string conversion.
 
 2011-08-05  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index b5d7c0c..9c9f3c0 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -1166,7 +1166,7 @@ TclOOGetStereotypeCallChain(
 	hPtr = NULL;
     }
 
-    callPtr = (CallChain *) ckalloc(sizeof(CallChain));
+    callPtr = ckalloc(sizeof(CallChain));
     memset(callPtr, 0, sizeof(CallChain));
     callPtr->flags = flags & (PUBLIC_METHOD|PRIVATE_METHOD|FILTER_HANDLING);
     callPtr->epoch = fPtr->epoch;
@@ -1214,9 +1214,7 @@ TclOOGetStereotypeCallChain(
     } else {
 	if (hPtr == NULL) {
 	    if (clsPtr->classChainCache == NULL) {
-		clsPtr->classChainCache = (Tcl_HashTable *)
-			ckalloc(sizeof(Tcl_HashTable));
-
+		clsPtr->classChainCache = ckalloc(sizeof(Tcl_HashTable));
 		Tcl_InitObjHashTable(clsPtr->classChainCache);
 	    }
 	    hPtr = Tcl_CreateHashEntry(clsPtr->classChainCache,
diff --git a/generic/tclOOInfo.c b/generic/tclOOInfo.c
index ac8ae46..f298320 100644
--- a/generic/tclOOInfo.c
+++ b/generic/tclOOInfo.c
@@ -1542,6 +1542,7 @@ InfoClassCallCmd(
 	return TCL_ERROR;
     }
     Tcl_SetObjResult(interp, TclOORenderCallChain(interp, callPtr));
+    TclOODeleteChain(callPtr);
     return TCL_OK;
 }
 
diff --git a/tests/ooNext2.test b/tests/ooNext2.test
index 51f02c5..eeade11 100644
--- a/tests/ooNext2.test
+++ b/tests/ooNext2.test
@@ -513,6 +513,21 @@ test oo-call-1.18 {object call introspection - memory leaks} -body {
 	info object call oo::object destroy
     }
 } -constraints memory -result 0
+test oo-call-1.19 {object call introspection - memory leaks} -setup {
+    oo::class create leaktester { method foo {} {dummy} }
+} -body {
+    leaktest {
+	set lt [leaktester new]
+	oo::objdefine $lt method foobar {} {dummy}
+	list [info object call $lt destroy] \
+	    [info object call $lt foo] \
+	    [info object call $lt bar] \
+	    [info object call $lt foobar] \
+	    [$lt destroy]
+    }
+} -cleanup {
+    leaktester destroy
+} -constraints memory -result 0
 
 test oo-call-2.1 {class call introspection} -setup {
     oo::class create root
@@ -684,6 +699,16 @@ test oo-call-2.13 {class call introspection - memory leaks} -body {
 	info class call oo::class destroy
     }
 } -constraints memory -result 0
+test oo-call-2.14 {class call introspection - memory leaks} -body {
+    leaktest {
+	oo::class create leaktester { method foo {} {dummy} }
+	[leaktester new] destroy
+	list [info class call leaktester destroy] \
+	    [info class call leaktester foo] \
+	    [info class call leaktester bar] \
+	    [leaktester destroy]
+    }
+} -constraints memory -result 0
 
 test oo-call-3.1 {current call introspection} -setup {
     oo::class create root
-- 
cgit v0.12


From 9d1a20b757fd40ae5b636621c9c7ce303c15043a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 8 Aug 2011 21:41:15 +0000
Subject: Make the -buffersize option to '$zstream add' function correctly
 instead of having its value just be discarded unceremoniously.

---
 ChangeLog         |  7 +++++++
 generic/tclZlib.c | 49 +++++++++++++++++++++++++++++++++++++------------
 2 files changed, 44 insertions(+), 12 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b55989c..bd72245 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-08-08  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclZlib.c (ZlibStreamCmd): Make the -buffersize option to
+	'$zstream add' function correctly instead of having its value just be
+	discarded unceremoniously. Also generate error codes from more of the
+	code, not just the low-level code but also the Tcl infrastructure.
+
 2011-08-07  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclOOInfo.c (InfoClassCallCmd): [Bug 3387082]: Plug memory
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 922ec18..be91365 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -576,6 +576,7 @@ Tcl_ZlibStreamInit(
 		&cmdinfo) == 1) {
 	    Tcl_SetResult(interp,
 		    "BUG: Stream command name already exists", TCL_STATIC);
+	    Tcl_SetErrorCode(interp, "TCL", "BUG", "EXISTING_CMD", NULL);
 	    Tcl_DStringFree(&cmdname);
 	    goto error;
 	}
@@ -898,6 +899,7 @@ Tcl_ZlibStreamPut(
 	if (zshPtr->interp) {
 	    Tcl_SetResult(zshPtr->interp,
 		    "already past compressed stream end", TCL_STATIC);
+	    Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "CLOSED", NULL);
 	}
 	return TCL_ERROR;
     }
@@ -1083,6 +1085,8 @@ Tcl_ZlibStreamGet(
 		    Tcl_SetResult(zshPtr->interp,
 			"Unexpected zlib internal state during decompression",
 			TCL_STATIC);
+		    Tcl_SetErrorCode(zshPtr->interp, "TCL", "ZIP", "STATE",
+			    NULL);
 		}
 		Tcl_SetByteArrayLength(data, existing);
 		return TCL_ERROR;
@@ -1906,12 +1910,14 @@ ZlibCmd(
 	    Tcl_AppendResult(interp,
 		    "compression may only be applied to writable channels",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNWRITABLE", NULL);
 	    return TCL_ERROR;
 	}
 	if (mode == TCL_ZLIB_STREAM_INFLATE && !(chanMode & TCL_READABLE)) {
 	    Tcl_AppendResult(interp,
 		    "decompression may only be applied to readable channels",
 		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "ZIP", "UNREADABLE", NULL);
 	    return TCL_ERROR;
 	}
 
@@ -1930,6 +1936,7 @@ ZlibCmd(
 		if (++i > objc-1) {
 		    Tcl_AppendResult(interp,
 			    "value missing for -header option", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
 		    return TCL_ERROR;
 		}
 		headerObj = objv[i];
@@ -1942,6 +1949,7 @@ ZlibCmd(
 		if (++i > objc-1) {
 		    Tcl_AppendResult(interp,
 			    "value missing for -level option", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
 		    return TCL_ERROR;
 		}
 		if (Tcl_GetIntFromObj(interp, objv[i],
@@ -1958,6 +1966,7 @@ ZlibCmd(
 		if (++i > objc-1) {
 		    Tcl_AppendResult(interp,
 			    "value missing for -limit option", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
 		    return TCL_ERROR;
 		}
 		if (Tcl_GetIntFromObj(interp, objv[i],
@@ -1985,12 +1994,14 @@ ZlibCmd(
 
   badLevel:
     Tcl_AppendResult(interp, "level must be 0 to 9", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "VALUE", "COMPRESSIONLEVEL", NULL);
     if (extraInfoStr) {
 	Tcl_AddErrorInfo(interp, extraInfoStr);
     }
     return TCL_ERROR;
   badBuffer:
     Tcl_AppendResult(interp, "buffer size must be 32 to 65536", NULL);
+    Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE", NULL);
     return TCL_ERROR;
 }
 
@@ -2012,7 +2023,7 @@ ZlibStreamCmd(
     Tcl_Obj *const objv[])
 {
     Tcl_ZlibStream zstream = cd;
-    int command, index, count, code, buffersize, flush = -1, i;
+    int command, index, count, code, buffersize = -1, flush = -1, i;
     Tcl_Obj *obj;
     static const char *const cmds[] = {
 	"add", "checksum", "close", "eof", "finalize", "flush",
@@ -2075,17 +2086,26 @@ ZlibStreamCmd(
 		    Tcl_AppendResult(interp, "\"-buffer\" option must be "
 			    "followed by integer decompression buffersize",
 			    NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "ZIP", "NOVAL", NULL);
 		    return TCL_ERROR;
 		}
 		if (Tcl_GetIntFromObj(interp, objv[i+1],
 			&buffersize) != TCL_OK) {
 		    return TCL_ERROR;
 		}
+		if (buffersize < 1 || buffersize > 65536) {
+		    Tcl_AppendResult(interp,
+			    "buffer size must be 32 to 65536", NULL);
+		    Tcl_SetErrorCode(interp, "TCL", "VALUE", "BUFFERSIZE",
+			    NULL);
+		    return TCL_ERROR;
+		}
 	    }
 
 	    if (flush == -2) {
 		Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and "
 			"\"-finalize\" options are mutually exclusive", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
 		return TCL_ERROR;
 	    }
 	}
@@ -2093,12 +2113,11 @@ ZlibStreamCmd(
 	    flush = 0;
 	}
 
-	if (Tcl_ZlibStreamPut(zstream, objv[objc-1],
-		flush) != TCL_OK) {
+	if (Tcl_ZlibStreamPut(zstream, objv[objc-1], flush) != TCL_OK) {
 	    return TCL_ERROR;
 	}
 	TclNewObj(obj);
-	code = Tcl_ZlibStreamGet(zstream, obj, -1);
+	code = Tcl_ZlibStreamGet(zstream, obj, buffersize);
 	if (code == TCL_OK) {
 	    Tcl_SetObjResult(interp, obj);
 	} else {
@@ -2143,6 +2162,7 @@ ZlibStreamCmd(
 	    if (flush == -2) {
 		Tcl_AppendResult(interp, "\"-flush\", \"-fullflush\" and "
 			"\"-finalize\" options are mutually exclusive", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "ZIP", "EXCLUSIVE", NULL);
 		return TCL_ERROR;
 	    }
 	}
@@ -2461,17 +2481,19 @@ ZlibTransformSetOption(			/* not used */
 
 	if (value[0] == 'f' && strcmp(value, "full") == 0) {
 	    flushType = Z_FULL_FLUSH;
-	    goto doFlush;
-	}
-	if (value[0] == 's' && strcmp(value, "sync") == 0) {
+	} else if (value[0] == 's' && strcmp(value, "sync") == 0) {
 	    flushType = Z_SYNC_FLUSH;
-	    goto doFlush;
+	} else {
+	    Tcl_AppendResult(interp, "unknown -flush type \"", value,
+		    "\": must be full or sync", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "VALUE", "FLUSH", NULL);
+	    return TCL_ERROR;
 	}
-	Tcl_AppendResult(interp, "unknown -flush type \"", value,
-		"\": must be full or sync", NULL);
-	return TCL_ERROR;
 
-    doFlush:
+	/*
+	 * Try to actually do the flush now.
+	 */
+
 	cd->outStream.avail_in = 0;
 	do {
 	    int e;
@@ -2851,6 +2873,7 @@ Tcl_ZlibStreamInit(
     Tcl_ZlibStream *zshandle)
 {
     Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+    Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
     return TCL_ERROR;
 }
 
@@ -2916,6 +2939,7 @@ Tcl_ZlibDeflate(
     Tcl_Obj *gzipHeaderDictObj)
 {
     Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+    Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
     return TCL_ERROR;
 }
 
@@ -2928,6 +2952,7 @@ Tcl_ZlibInflate(
     Tcl_Obj *gzipHeaderDictObj)
 {
     Tcl_SetResult(interp, "unimplemented", TCL_STATIC);
+    Tcl_SetErrorCode(interp, "TCL", "UNIMPLEMENTED", NULL);
     return TCL_ERROR;
 }
 
-- 
cgit v0.12


From bc61e591021b6e5b5e4a49fe1f0111b4a475cc27 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 9 Aug 2011 05:57:48 +0000
Subject: Change the signature of TclParseHex(), such that it can now parse up
 to 8 hex characters

---
 ChangeLog          |  5 +++++
 generic/tclInt.h   |  2 +-
 generic/tclParse.c | 20 +++++++++++---------
 3 files changed, 17 insertions(+), 10 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index bd72245..a443059 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-09  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclInt.h: Change the signature of TclParseHex(), such that
+	* generic/tclParse.c: it can now parse up to 8 hex characters.
+
 2011-08-08  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclZlib.c (ZlibStreamCmd): Make the -buffersize option to
diff --git a/generic/tclInt.h b/generic/tclInt.h
index ebc8bef..e4a7782 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3029,7 +3029,7 @@ MODULE_SCOPE int	TclObjUnsetVar2(Tcl_Interp *interp,
 MODULE_SCOPE int	TclParseBackslash(const char *src,
 			    int numBytes, int *readPtr, char *dst);
 MODULE_SCOPE int	TclParseHex(const char *src, int numBytes,
-			    Tcl_UniChar *resultPtr);
+			    int *resultPtr);
 MODULE_SCOPE int	TclParseNumber(Tcl_Interp *interp, Tcl_Obj *objPtr,
 			    const char *expected, const char *bytes,
 			    int numBytes, const char **endPtrPtr, int flags);
diff --git a/generic/tclParse.c b/generic/tclParse.c
index c33ef5b..2b0dab4 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -744,11 +744,11 @@ int
 TclParseHex(
     const char *src,		/* First character to parse. */
     int numBytes,		/* Max number of byes to scan */
-    Tcl_UniChar *resultPtr)	/* Points to storage provided by caller where
-				 * the Tcl_UniChar resulting from the
+    int *resultPtr)	/* Points to storage provided by caller where
+				 * the character resulting from the
 				 * conversion is to be written. */
 {
-    Tcl_UniChar result = 0;
+    int result = 0;
     register const char *p = src;
 
     while (numBytes--) {
@@ -808,7 +808,8 @@ TclParseBackslash(
 				 * written there. */
 {
     register const char *p = src+1;
-    Tcl_UniChar result;
+    Tcl_UniChar unichar;
+    int result;
     int count;
     char buf[TCL_UTF_MAX];
 
@@ -906,14 +907,14 @@ TclParseBackslash(
 	 */
 
 	if (isdigit(UCHAR(*p)) && (UCHAR(*p) < '8')) {	/* INTL: digit */
-	    result = UCHAR(*p - '0');
+	    result = *p - '0';
 	    p++;
 	    if ((numBytes == 2) || !isdigit(UCHAR(*p))	/* INTL: digit */
 		    || (UCHAR(*p) >= '8')) {
 		break;
 	    }
 	    count = 3;
-	    result = UCHAR((result << 3) + (*p - '0'));
+	    result = (result << 3) + (*p - '0');
 	    p++;
 	    if ((numBytes == 3) || !isdigit(UCHAR(*p))	/* INTL: digit */
 		    || (UCHAR(*p) >= '8')) {
@@ -932,14 +933,15 @@ TclParseBackslash(
 	 */
 
 	if (Tcl_UtfCharComplete(p, numBytes - 1)) {
-	    count = Tcl_UtfToUniChar(p, &result) + 1;	/* +1 for '\' */
+	    count = Tcl_UtfToUniChar(p, &unichar) + 1;	/* +1 for '\' */
 	} else {
 	    char utfBytes[TCL_UTF_MAX];
 
 	    memcpy(utfBytes, p, (size_t) (numBytes - 1));
 	    utfBytes[numBytes - 1] = '\0';
-	    count = Tcl_UtfToUniChar(utfBytes, &result) + 1;
+	    count = Tcl_UtfToUniChar(utfBytes, &unichar) + 1;
 	}
+	result = unichar;
 	break;
     }
 
@@ -947,7 +949,7 @@ TclParseBackslash(
     if (readPtr != NULL) {
 	*readPtr = count;
     }
-    return Tcl_UniCharToUtf((int) result, dst);
+    return Tcl_UniCharToUtf(result, dst);
 }
 
 /*
-- 
cgit v0.12


From 653f52ba6008466571d283d523272ae22c2cf2c4 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Tue, 9 Aug 2011 17:01:16 +0000
Subject: [Bug 3386417] avoid a reference loop between the bytecode and its
 companion errostack when compiling a syntax error.

---
 ChangeLog             |  6 ++++++
 generic/tclCompCmds.c |  2 +-
 generic/tclInt.h      |  1 +
 generic/tclResult.c   | 23 +++++++++++++++++++++++
 4 files changed, 31 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index c2cf484..04d506b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-08-09 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* generic/tclCompCmds.c: [Bug 3386417] avoid a reference loop between
+	* generic/tclInt.h:      the bytecode and its companion errostack
+	* generic/tclResult.c:   when compiling a syntax error.
+
 2011-08-09  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* win/tclWinConsole.c: [Bug 3388350] mingw64 compiler warnings
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 083f530..66c03ab 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3644,7 +3644,7 @@ TclCompileSyntaxError(
     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)));
 }
 
 /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index e4a7782..9f00077 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3016,6 +3016,7 @@ MODULE_SCOPE int	TclMaxListLength(const char *bytes, int numBytes,
 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,
diff --git a/generic/tclResult.c b/generic/tclResult.c
index 60bae73..4443cc1 100644
--- a/generic/tclResult.c
+++ b/generic/tclResult.c
@@ -1599,6 +1599,29 @@ Tcl_GetReturnOptions(
 /*
  *-------------------------------------------------------------------------
  *
+ * 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;
+}
+
+/*
+ *-------------------------------------------------------------------------
+ *
  * Tcl_SetReturnOptions --
  *
  *	Accepts an interp and a dictionary of return options, and sets the
-- 
cgit v0.12


From e83ec9b8978e9e4481a549283c64e11f2a1e4a61 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Tue, 9 Aug 2011 17:19:33 +0000
Subject: [Bug 2919042] Restore "valgrindability" of Tcl that was lost by the
 streamlining of [exit], by conditionally forcing a full Finalize: use
 -DPURIFY or ::env(TCL_FINALIZE_ON_EXIT)

---
 ChangeLog            |  7 +++++
 generic/tclBasic.c   | 13 ++++----
 generic/tclEvent.c   | 49 +++++++++++++++++------------
 generic/tclExecute.c | 12 +++++---
 generic/tclInt.h     |  2 ++
 generic/tclMain.c    | 87 +++++++++++++++++++++++++++++++++++++++++++---------
 6 files changed, 126 insertions(+), 44 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 04d506b..bdf73e9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,12 @@
 2011-08-09 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
+	* generic/tclBasic.c: [Bug 2919042] Restore "valgrindability" of Tcl
+	* generic/tclEvent.c: that was lost by the streamlining of [exit], by
+	* generic/tclExecute.c: conditionally forcing a full Finalize:
+	* generic/tclInt.h:  use -DPURIFY or ::env(TCL_FINALIZE_ON_EXIT)
+
+2011-08-09 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
 	* generic/tclCompCmds.c: [Bug 3386417] avoid a reference loop between
 	* generic/tclInt.h:      the bytecode and its companion errostack
 	* generic/tclResult.c:   when compiling a syntax error.
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index a44d736..124f932 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1355,10 +1355,11 @@ DeleteInterpProc(
     int i;
 
     /*
-     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup.
+     * Punt if there is an error in the Tcl_Release/Tcl_Preserve matchup,
+	 * unless we are exiting.
      */
 
-    if (iPtr->numLevels > 0) {
+    if ((iPtr->numLevels > 0) && !TclInExit()) {
 	Tcl_Panic("DeleteInterpProc called with active evals");
     }
 
@@ -1481,7 +1482,7 @@ DeleteInterpProc(
      * namespace. The order is important [Bug 1658572].
      */
 
-    if (iPtr->framePtr != iPtr->rootFramePtr) {
+    if ((iPtr->framePtr != iPtr->rootFramePtr) && !TclInExit()) {
 	Tcl_Panic("DeleteInterpProc: popping rootCallFrame with other frames on top");
     }
     Tcl_PopCallFrame(interp);
@@ -1602,7 +1603,7 @@ DeleteInterpProc(
      * know which arguments will be used as scripts and which will not.
      */
 
-    if (iPtr->lineLAPtr->numEntries) {
+    if (iPtr->lineLAPtr->numEntries && !TclInExit()) {
 	/*
 	 * When the interp goes away we have nothing on the stack, so there
 	 * are no arguments, so this table has to be empty.
@@ -1612,10 +1613,10 @@ DeleteInterpProc(
     }
 
     Tcl_DeleteHashTable(iPtr->lineLAPtr);
-    ckfree(iPtr->lineLAPtr);
+    ckfree((char *) iPtr->lineLAPtr);
     iPtr->lineLAPtr = NULL;
 
-    if (iPtr->lineLABCPtr->numEntries) {
+    if (iPtr->lineLABCPtr->numEntries && !TclInExit()) {
 	/*
 	 * When the interp goes away we have nothing on the stack, so there
 	 * are no arguments, so this table has to be empty.
diff --git a/generic/tclEvent.c b/generic/tclEvent.c
index 6816487..e65862c 100644
--- a/generic/tclEvent.c
+++ b/generic/tclEvent.c
@@ -953,27 +953,38 @@ Tcl_Exit(
 	currentAppExitPtr(INT2PTR(status));
 	Tcl_Panic("AppExitProc returned unexpectedly");
     } else {
-	/*
-	 * Use default handling.
-	 */
 
-	InvokeExitHandlers();
+	if (TclFullFinalizationRequested()) {
 
-	/*
-	 * Ensure the thread-specific data is initialised as it is used in
-	 * Tcl_FinalizeThread()
-	 */
-	
-	(void) TCL_TSD_INIT(&dataKey);
-	
-	/*
-	 * Now finalize the calling thread only (others are not safely
-	 * reachable).  Among other things, this triggers a flush of the
-	 * Tcl_Channels that may have data enqueued.
-	 */
-	
-	Tcl_FinalizeThread();
-	
+	    /*
+	     * Thorough finalization for Valgrind et al.
+	     */
+
+	    Tcl_Finalize();
+
+	} else {
+
+	    /*
+	     * Fast and deterministic exit (default behavior)
+	     */
+	    
+	    InvokeExitHandlers();
+	    
+	    /*
+	     * Ensure the thread-specific data is initialised as it is used in
+	     * Tcl_FinalizeThread()
+	     */
+	    
+	    (void) TCL_TSD_INIT(&dataKey);
+	    
+	    /*
+	     * Now finalize the calling thread only (others are not safely
+	     * reachable).  Among other things, this triggers a flush of the
+	     * Tcl_Channels that may have data enqueued.
+	     */
+	    
+	    Tcl_FinalizeThread();
+	}
 	TclpExit(status);
 	Tcl_Panic("OS exit failed!");
     }
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index a7d6184..691c8d7 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -53,6 +53,8 @@
 static int execInitialized = 0;
 TCL_DECLARE_MUTEX(execMutex)
 
+static int cachedInExit = 0;
+
 #ifdef TCL_COMPILE_DEBUG
 /*
  * Variable that controls whether execution tracing is enabled and, if so,
@@ -896,7 +898,7 @@ static void
 DeleteExecStack(
     ExecStack *esPtr)
 {
-    if (esPtr->markerPtr) {
+    if (esPtr->markerPtr && !cachedInExit) {
 	Tcl_Panic("freeing an execStack which is still in use");
     }
 
@@ -915,6 +917,8 @@ TclDeleteExecEnv(
 {
     ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
 
+	cachedInExit = TclInExit();
+
     /*
      * Delete all stacks in this exec env.
      */
@@ -930,10 +934,10 @@ TclDeleteExecEnv(
 
     TclDecrRefCount(eePtr->constants[0]);
     TclDecrRefCount(eePtr->constants[1]);
-    if (eePtr->callbackPtr) {
-	Tcl_Panic("Deleting execEnv with pending NRE callbacks!");
+    if (eePtr->callbackPtr && !cachedInExit) {
+	Tcl_Panic("Deleting execEnv with pending TEOV callbacks!");
     }
-    if (eePtr->corPtr) {
+    if (eePtr->corPtr && !cachedInExit) {
 	Tcl_Panic("Deleting execEnv with existing coroutine");
     }
     ckfree(eePtr);
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 9f00077..d65f712 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3787,6 +3787,8 @@ MODULE_SCOPE int	TclCompareObjKeys(void *keyPtr, Tcl_HashEntry *hPtr);
 MODULE_SCOPE void	TclFreeObjEntry(Tcl_HashEntry *hPtr);
 MODULE_SCOPE unsigned	TclHashObjKey(Tcl_HashTable *tablePtr, void *keyPtr);
 
+MODULE_SCOPE int	TclFullFinalizationRequested(void);
+
 /*
  *----------------------------------------------------------------
  * Macros used by the Tcl core to create and release Tcl objects.
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 26383b5..c7166d7 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -125,6 +125,7 @@ typedef struct InteractiveState {
 MODULE_SCOPE Tcl_MainLoopProc *TclGetMainLoop(void);
 static void		Prompt(Tcl_Interp *interp, InteractiveState *isPtr);
 static void		StdinProc(ClientData clientData, int mask);
+static void     FreeMainInterp(ClientData clientData);
 
 #ifndef TCL_ASCII_MAIN
 static Tcl_ThreadDataKey dataKey;
@@ -387,6 +388,13 @@ Tcl_MainEx(
     if (Tcl_LimitExceeded(interp)) {
 	goto done;
     }
+    if (TclFullFinalizationRequested()) {
+	/*
+	 * Arrange for final deletion of the main interp
+	 */
+	// ARGH Munchhausen effect 
+	Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp);
+    }
 
     /*
      * Invoke the script specified on the command line, if any. Must fetch it
@@ -597,31 +605,18 @@ Tcl_MainEx(
     if (!Tcl_InterpDeleted(interp)) {
 	if (!Tcl_LimitExceeded(interp)) {
 	    Tcl_Obj *cmd = Tcl_ObjPrintf("exit %d", exitCode);
-
+	    
 	    Tcl_IncrRefCount(cmd);
 	    Tcl_EvalObjEx(interp, cmd, TCL_EVAL_GLOBAL);
 	    Tcl_DecrRefCount(cmd);
 	}
-
+    }
 	/*
 	 * If Tcl_EvalObjEx returns, trying to eval [exit], something unusual
 	 * is happening. Maybe interp has been deleted; maybe [exit] was
 	 * redefined, maybe we've blown up because of an exceeded limit. We
 	 * still want to cleanup and exit.
 	 */
-
-	if (!Tcl_InterpDeleted(interp)) {
-	    Tcl_DeleteInterp(interp);
-	}
-    }
-    Tcl_SetStartupScript(NULL, NULL);
-
-    /*
-     * If we get here, the master interp has been deleted. Allow its
-     * destruction with the last matching Tcl_Release.
-     */
-
-    Tcl_Release(interp);
     Tcl_Exit(exitCode);
 }
 
@@ -699,6 +694,42 @@ TclGetMainLoop(void)
 /*
  *----------------------------------------------------------------------
  *
+ * TclFullFinalizationRequested --
+ *
+ *	This function returns true when either -DPURIFY is specified, or the
+ *	environment variable TCL_FINALIZE_ON_EXIT is set and not "0". This
+ *	predicate is called at places affecting the exit sequence, so that the
+ *	default behavior is a fast and deadlock-free exit, and the modified
+ *	behavior is a more thorough finalization for debugging purposes (leak
+ *	hunting etc).
+ *
+ * Results:
+ *	A boolean.
+ *
+ *----------------------------------------------------------------------
+ */
+MODULE_SCOPE int
+TclFullFinalizationRequested(void)
+{
+#ifdef PURIFY
+    return 1;
+#else
+    const char *fin;
+    Tcl_DString ds;
+    int finalize = 0;
+    
+    fin = TclGetEnv("TCL_FINALIZE_ON_EXIT", &ds);
+    finalize = ((fin != NULL) && strcmp(fin, "0"));
+    if (fin != NULL) {
+	Tcl_DStringFree(&ds);
+    }
+    return finalize;
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * StdinProc --
  *
  *	This function is invoked by the event dispatcher whenever standard
@@ -881,6 +912,32 @@ Prompt(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * FreeMainInterp --
+ *
+ *	Exit handler used to cleanup the main interpreter and ancillary startup
+ *	script storage at exit.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeMainInterp(
+    ClientData clientData)
+{
+	Tcl_Interp *interp = (Tcl_Interp *) clientData;
+
+	//if (TclInExit()) return;
+
+	if (!Tcl_InterpDeleted(interp)) {
+	    Tcl_DeleteInterp(interp);
+	}
+    Tcl_SetStartupScript(NULL, NULL);
+    Tcl_Release(interp);
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
-- 
cgit v0.12


From 13ec4a7a18514c777a108f3fe0603ea0fa35e488 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 10 Aug 2011 13:44:48 +0000
Subject: compiler error on Windows: there should be only one
 TclFullFinalizationRequested function

---
 generic/tclMain.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclMain.c b/generic/tclMain.c
index c7166d7..652074e 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -689,7 +689,6 @@ TclGetMainLoop(void)
 
     return tsdPtr->mainLoopProc;
 }
-#endif /* !TCL_ASCII_MAIN */
 
 /*
  *----------------------------------------------------------------------
@@ -726,6 +725,7 @@ TclFullFinalizationRequested(void)
     return finalize;
 #endif
 }
+#endif /* !TCL_ASCII_MAIN */
 
 /*
  *----------------------------------------------------------------------
-- 
cgit v0.12


From ba9424ed9813043dd8948d59a0fd5aa83b0cd0ca Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Wed, 10 Aug 2011 18:24:19 +0000
Subject: [Bug 3386721] Allow multiple [load]ing of the Tcltest package

---
 ChangeLog            |   5 ++
 generic/tclTestObj.c | 166 ++++++++++++++++++++++++++++++++-------------------
 2 files changed, 109 insertions(+), 62 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index bdf73e9..127ee0b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-10 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* generic/tclTestObj.c: [Bug 3386721] Allow multiple [load]ing of
+	the Tcltest package
+
 2011-08-09 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	* generic/tclBasic.c: [Bug 2919042] Restore "valgrindability" of Tcl
diff --git a/generic/tclTestObj.c b/generic/tclTestObj.c
index 92c278f..7494beb 100644
--- a/generic/tclTestObj.c
+++ b/generic/tclTestObj.c
@@ -20,23 +20,15 @@
 #include "tclInt.h"
 #include "tommath.h"
 
-/*
- * An array of Tcl_Obj pointers used in the commands that operate on or get
- * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
- * Tcl_Obj *.
- */
-
-#define NUMBER_OF_OBJECT_VARS 20
-static Tcl_Obj *varPtr[NUMBER_OF_OBJECT_VARS];
 
 /*
  * Forward declarations for functions defined later in this file:
  */
 
-static int		CheckIfVarUnset(Tcl_Interp *interp, int varIndex);
+static int		CheckIfVarUnset(Tcl_Interp *interp, Tcl_Obj **varPtr, int varIndex);
 static int		GetVariableIndex(Tcl_Interp *interp,
 			    const char *string, int *indexPtr);
-static void		SetVarToObj(int varIndex, Tcl_Obj *objPtr);
+static void		SetVarToObj(Tcl_Obj **varPtr, int varIndex, Tcl_Obj *objPtr);
 static int		TestbignumobjCmd(ClientData dummy, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 static int		TestbooleanobjCmd(ClientData dummy,
@@ -62,6 +54,27 @@ typedef struct TestString {
     Tcl_UniChar unicode[2];
 } TestString;
 
+#define VARPTR_KEY "TCLOBJTEST_VARPTR"
+#define NUMBER_OF_OBJECT_VARS 20
+
+static void VarPtrDeleteProc(ClientData clientData, Tcl_Interp *interp)
+{
+    register int i;
+    Tcl_Obj **varPtr = (Tcl_Obj **) clientData;
+    for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
+	if (varPtr[i]) Tcl_DecrRefCount(varPtr[i]);
+    }
+    Tcl_DeleteAssocData(interp, VARPTR_KEY);
+    ckfree(varPtr);
+}
+
+static Tcl_Obj **GetVarPtr(Tcl_Interp *interp)
+{
+    Tcl_InterpDeleteProc *proc;
+
+    return (Tcl_Obj **) Tcl_GetAssocData(interp, VARPTR_KEY, &proc);
+}
+
 /*
  *----------------------------------------------------------------------
  *
@@ -85,7 +98,18 @@ TclObjTest_Init(
     Tcl_Interp *interp)
 {
     register int i;
+    /*
+     * An array of Tcl_Obj pointers used in the commands that operate on or get
+     * the values of Tcl object-valued variables. varPtr[i] is the i-th variable's
+     * Tcl_Obj *.
+     */
+    Tcl_Obj **varPtr;
 
+    varPtr = (Tcl_Obj **) ckalloc(NUMBER_OF_OBJECT_VARS *sizeof(varPtr[0]));
+    if (!varPtr) {
+	return TCL_ERROR;
+    }
+    Tcl_SetAssocData(interp, VARPTR_KEY, VarPtrDeleteProc, varPtr);
     for (i = 0;  i < NUMBER_OF_OBJECT_VARS;  i++) {
 	varPtr[i] = NULL;
     }
@@ -142,6 +166,7 @@ TestbignumobjCmd(
     int index, varIndex;
     const char *string;
     mp_int bignumValue, newValue;
+    Tcl_Obj **varPtr;
 
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "option ?arg ...?");
@@ -155,6 +180,7 @@ TestbignumobjCmd(
     if (GetVariableIndex(interp, string, &varIndex) != TCL_OK) {
 	return TCL_ERROR;
     }
+    varPtr = GetVarPtr(interp);
 
     switch (index) {
     case BIGNUM_SET:
@@ -186,7 +212,7 @@ TestbignumobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetBignumObj(varPtr[varIndex], &bignumValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewBignumObj(&bignumValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&bignumValue));
 	}
 	break;
 
@@ -195,7 +221,7 @@ TestbignumobjCmd(
 	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	break;
@@ -205,7 +231,7 @@ TestbignumobjCmd(
 	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
@@ -224,7 +250,7 @@ TestbignumobjCmd(
 	if (!Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetBignumObj(varPtr[varIndex], &newValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue));
 	}
 	break;
 
@@ -233,7 +259,7 @@ TestbignumobjCmd(
 	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetBignumFromObj(interp, varPtr[varIndex],
@@ -252,7 +278,7 @@ TestbignumobjCmd(
 	if (!Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetBignumObj(varPtr[varIndex], &newValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewBignumObj(&newValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewBignumObj(&newValue));
 	}
     }
 
@@ -287,6 +313,7 @@ TestbooleanobjCmd(
 {
     int varIndex, boolValue;
     const char *index, *subCmd;
+    Tcl_Obj **varPtr;
 
     if (objc < 3) {
 	wrongNumArgs:
@@ -299,6 +326,8 @@ TestbooleanobjCmd(
 	return TCL_ERROR;
     }
 
+    varPtr = GetVarPtr(interp);
+
     subCmd = Tcl_GetString(objv[1]);
     if (strcmp(subCmd, "set") == 0) {
 	if (objc != 4) {
@@ -319,14 +348,14 @@ TestbooleanobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetBooleanObj(varPtr[varIndex], boolValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewBooleanObj(boolValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(boolValue));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else if (strcmp(subCmd, "get") == 0) {
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -334,7 +363,7 @@ TestbooleanobjCmd(
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetBooleanFromObj(interp, varPtr[varIndex],
@@ -344,7 +373,7 @@ TestbooleanobjCmd(
 	if (!Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetBooleanObj(varPtr[varIndex], !boolValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewBooleanObj(!boolValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewBooleanObj(!boolValue));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else {
@@ -385,6 +414,7 @@ TestdoubleobjCmd(
     int varIndex;
     double doubleValue;
     const char *index, *subCmd, *string;
+    Tcl_Obj **varPtr;
 
     if (objc < 3) {
 	wrongNumArgs:
@@ -392,6 +422,8 @@ TestdoubleobjCmd(
 	return TCL_ERROR;
     }
 
+    varPtr = GetVarPtr(interp);
+
     index = Tcl_GetString(objv[2]);
     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	return TCL_ERROR;
@@ -418,14 +450,14 @@ TestdoubleobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetDoubleObj(varPtr[varIndex], doubleValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else if (strcmp(subCmd, "get") == 0) {
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -433,7 +465,7 @@ TestdoubleobjCmd(
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
@@ -443,14 +475,14 @@ TestdoubleobjCmd(
 	if (!Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetDoubleObj(varPtr[varIndex], doubleValue * 10.0);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue * 10.0));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue * 10.0));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else if (strcmp(subCmd, "div10") == 0) {
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetDoubleFromObj(interp, varPtr[varIndex],
@@ -460,7 +492,7 @@ TestdoubleobjCmd(
 	if (!Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetDoubleObj(varPtr[varIndex], doubleValue / 10.0);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewDoubleObj(doubleValue / 10.0));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else {
@@ -603,6 +635,7 @@ TestintobjCmd(
     int intValue, varIndex, i;
     long longValue;
     const char *index, *subCmd, *string;
+    Tcl_Obj **varPtr;
 
     if (objc < 3) {
 	wrongNumArgs:
@@ -610,6 +643,7 @@ TestintobjCmd(
 	return TCL_ERROR;
     }
 
+    varPtr = GetVarPtr(interp);
     index = Tcl_GetString(objv[2]);
     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	return TCL_ERROR;
@@ -637,7 +671,7 @@ TestintobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetIntObj(varPtr[varIndex], intValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else if (strcmp(subCmd, "set2") == 0) { /* doesn't set result */
@@ -652,7 +686,7 @@ TestintobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetIntObj(varPtr[varIndex], intValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewIntObj(intValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue));
 	}
     } else if (strcmp(subCmd, "setlong") == 0) {
 	if (objc != 4) {
@@ -666,7 +700,7 @@ TestintobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetLongObj(varPtr[varIndex], intValue);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewLongObj(intValue));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(intValue));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else if (strcmp(subCmd, "setmaxlong") == 0) {
@@ -677,13 +711,13 @@ TestintobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetLongObj(varPtr[varIndex], maxLong);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewLongObj(maxLong));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(maxLong));
 	}
     } else if (strcmp(subCmd, "ismaxlong") == 0) {
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetLongFromObj(interp, varPtr[varIndex], &longValue) != TCL_OK) {
@@ -695,7 +729,7 @@ TestintobjCmd(
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -703,7 +737,7 @@ TestintobjCmd(
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	string = Tcl_GetString(varPtr[varIndex]);
@@ -725,7 +759,7 @@ TestintobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetLongObj(varPtr[varIndex], LONG_MAX);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewLongObj(LONG_MAX));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewLongObj(LONG_MAX));
 	}
 	if (Tcl_GetIntFromObj(interp, varPtr[varIndex], &i) != TCL_OK) {
 	    Tcl_ResetResult(interp);
@@ -738,7 +772,7 @@ TestintobjCmd(
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
@@ -748,14 +782,14 @@ TestintobjCmd(
 	if (!Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetIntObj(varPtr[varIndex], intValue * 10);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewIntObj(intValue * 10));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue * 10));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else if (strcmp(subCmd, "div10") == 0) {
 	if (objc != 3) {
 	    goto wrongNumArgs;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (Tcl_GetIntFromObj(interp, varPtr[varIndex],
@@ -765,7 +799,7 @@ TestintobjCmd(
 	if (!Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetIntObj(varPtr[varIndex], intValue / 10);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewIntObj(intValue / 10));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewIntObj(intValue / 10));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else {
@@ -819,11 +853,13 @@ TestlistobjCmd(
     int cmdIndex;		/* Ordinal number of the subcommand */
     int first;			/* First index in the list */
     int count;			/* Count of elements in a list */
+    Tcl_Obj **varPtr;
 
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "option arg ?arg...?");
 	return TCL_ERROR;
     }
+    varPtr = GetVarPtr(interp);
     index = Tcl_GetString(objv[2]);
     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	return TCL_ERROR;
@@ -837,7 +873,7 @@ TestlistobjCmd(
 	if ((varPtr[varIndex] != NULL) && !Tcl_IsShared(varPtr[varIndex])) {
 	    Tcl_SetListObj(varPtr[varIndex], objc-3, objv+3);
 	} else {
-	    SetVarToObj(varIndex, Tcl_NewListObj(objc-3, objv+3));
+	    SetVarToObj(varPtr, varIndex, Tcl_NewListObj(objc-3, objv+3));
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
 	break;
@@ -847,7 +883,7 @@ TestlistobjCmd(
 	    Tcl_WrongNumArgs(interp, 2, objv, "varIndex");
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -864,7 +900,7 @@ TestlistobjCmd(
 	    return TCL_ERROR;
 	}
 	if (Tcl_IsShared(varPtr[varIndex])) {
-	    SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+	    SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
 	}
 	Tcl_ResetResult(interp);
 	return Tcl_ListObjReplace(interp, varPtr[varIndex], first, count,
@@ -900,6 +936,7 @@ TestobjCmd(
     int varIndex, destIndex, i;
     const char *index, *subCmd, *string;
     const Tcl_ObjType *targetType;
+    Tcl_Obj **varPtr;
 
     if (objc < 2) {
 	wrongNumArgs:
@@ -907,6 +944,7 @@ TestobjCmd(
 	return TCL_ERROR;
     }
 
+    varPtr = GetVarPtr(interp);
     subCmd = Tcl_GetString(objv[1]);
     if (strcmp(subCmd, "assign") == 0) {
 	if (objc != 4) {
@@ -916,14 +954,14 @@ TestobjCmd(
 	if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	string = Tcl_GetString(objv[3]);
 	if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	SetVarToObj(destIndex, varPtr[varIndex]);
+	SetVarToObj(varPtr, destIndex, varPtr[varIndex]);
 	Tcl_SetObjResult(interp, varPtr[destIndex]);
     } else if (strcmp(subCmd, "convert") == 0) {
 	const char *typeName;
@@ -935,7 +973,7 @@ TestobjCmd(
 	if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	typeName = Tcl_GetString(objv[3]);
@@ -957,14 +995,14 @@ TestobjCmd(
 	if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	string = Tcl_GetString(objv[3]);
 	if (GetVariableIndex(interp, string, &destIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	SetVarToObj(destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+	SetVarToObj(varPtr, destIndex, Tcl_DuplicateObj(varPtr[varIndex]));
 	Tcl_SetObjResult(interp, varPtr[destIndex]);
     } else if (strcmp(subCmd, "freeallvars") == 0) {
 	if (objc != 2) {
@@ -984,7 +1022,7 @@ TestobjCmd(
 	if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	Tcl_InvalidateStringRep(varPtr[varIndex]);
@@ -997,7 +1035,7 @@ TestobjCmd(
 	if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	SetVarToObj(varIndex, Tcl_NewObj());
+	SetVarToObj(varPtr, varIndex, Tcl_NewObj());
 	Tcl_SetObjResult(interp, varPtr[varIndex]);
     } else if (strcmp(subCmd, "objtype") == 0) {
 	const char *typeName;
@@ -1024,7 +1062,7 @@ TestobjCmd(
 	if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	Tcl_SetObjResult(interp, Tcl_NewIntObj(varPtr[varIndex]->refCount));
@@ -1036,7 +1074,7 @@ TestobjCmd(
 	if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	    return TCL_ERROR;
 	}
-	if (CheckIfVarUnset(interp, varIndex)) {
+	if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 	    return TCL_ERROR;
 	}
 	if (varPtr[varIndex]->typePtr == NULL) { /* a string! */
@@ -1093,6 +1131,7 @@ TeststringobjCmd(
 #define MAX_STRINGS 11
     const char *index, *string, *strings[MAX_STRINGS+1];
     TestString *strPtr;
+    Tcl_Obj **varPtr;
     static const char *const options[] = {
 	"append", "appendstrings", "get", "get2", "length", "length2",
 	"set", "set2", "setlength", "maxchars", "getunicode",
@@ -1105,6 +1144,7 @@ TeststringobjCmd(
 	return TCL_ERROR;
     }
 
+    varPtr = GetVarPtr(interp);
     index = Tcl_GetString(objv[2]);
     if (GetVariableIndex(interp, index, &varIndex) != TCL_OK) {
 	return TCL_ERROR;
@@ -1123,7 +1163,7 @@ TeststringobjCmd(
 		return TCL_ERROR;
 	    }
 	    if (varPtr[varIndex] == NULL) {
-		SetVarToObj(varIndex, Tcl_NewObj());
+		SetVarToObj(varPtr, varIndex, Tcl_NewObj());
 	    }
 
 	    /*
@@ -1132,7 +1172,7 @@ TeststringobjCmd(
 	     */
 
 	    if (Tcl_IsShared(varPtr[varIndex])) {
-		SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+		SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
 	    }
 	    string = Tcl_GetString(objv[3]);
 	    Tcl_AppendToObj(varPtr[varIndex], string, length);
@@ -1143,7 +1183,7 @@ TeststringobjCmd(
 		goto wrongNumArgs;
 	    }
 	    if (varPtr[varIndex] == NULL) {
-		SetVarToObj(varIndex, Tcl_NewObj());
+		SetVarToObj(varPtr, varIndex, Tcl_NewObj());
 	    }
 
 	    /*
@@ -1152,7 +1192,7 @@ TeststringobjCmd(
 	     */
 
 	    if (Tcl_IsShared(varPtr[varIndex])) {
-		SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+		SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
 	    }
 	    for (i = 3;  i < objc;  i++) {
 		strings[i-3] = Tcl_GetString(objv[i]);
@@ -1170,7 +1210,7 @@ TeststringobjCmd(
 	    if (objc != 3) {
 		goto wrongNumArgs;
 	    }
-	    if (CheckIfVarUnset(interp, varIndex)) {
+	    if (CheckIfVarUnset(interp, varPtr,varIndex)) {
 		return TCL_ERROR;
 	    }
 	    Tcl_SetObjResult(interp, varPtr[varIndex]);
@@ -1179,7 +1219,7 @@ TeststringobjCmd(
 	    if (objc != 3) {
 		goto wrongNumArgs;
 	    }
-	    if (CheckIfVarUnset(interp, varIndex)) {
+	    if (CheckIfVarUnset(interp, varPtr, varIndex)) {
 		return TCL_ERROR;
 	    }
 	    string = Tcl_GetString(varPtr[varIndex]);
@@ -1225,7 +1265,7 @@ TeststringobjCmd(
 		    && !Tcl_IsShared(varPtr[varIndex])) {
 		Tcl_SetStringObj(varPtr[varIndex], string, length);
 	    } else {
-		SetVarToObj(varIndex, Tcl_NewStringObj(string, length));
+		SetVarToObj(varPtr, varIndex, Tcl_NewStringObj(string, length));
 	    }
 	    Tcl_SetObjResult(interp, varPtr[varIndex]);
 	    break;
@@ -1233,7 +1273,7 @@ TeststringobjCmd(
 	    if (objc != 4) {
 		goto wrongNumArgs;
 	    }
-	    SetVarToObj(varIndex, objv[3]);
+	    SetVarToObj(varPtr, varIndex, objv[3]);
 	    break;
 	case 8:				/* setlength */
 	    if (objc != 4) {
@@ -1271,7 +1311,7 @@ TeststringobjCmd(
 		goto wrongNumArgs;
 	    }
 	    if (varPtr[varIndex] == NULL) {
-		SetVarToObj(varIndex, Tcl_NewObj());
+		SetVarToObj(varPtr, varIndex, Tcl_NewObj());
 	    }
 
 	    /*
@@ -1280,7 +1320,7 @@ TeststringobjCmd(
 	     */
 
 	    if (Tcl_IsShared(varPtr[varIndex])) {
-		SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+		SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
 	    }
 
 	    string = Tcl_GetStringFromObj(varPtr[varIndex], &length);
@@ -1302,7 +1342,7 @@ TeststringobjCmd(
 		goto wrongNumArgs;
 	    }
 	    if (varPtr[varIndex] == NULL) {
-		SetVarToObj(varIndex, Tcl_NewObj());
+		SetVarToObj(varPtr, varIndex, Tcl_NewObj());
 	    }
 
 	    /*
@@ -1311,7 +1351,7 @@ TeststringobjCmd(
 	     */
 
 	    if (Tcl_IsShared(varPtr[varIndex])) {
-		SetVarToObj(varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
+		SetVarToObj(varPtr, varIndex, Tcl_DuplicateObj(varPtr[varIndex]));
 	    }
 
 	    unicode = Tcl_GetUnicodeFromObj(varPtr[varIndex], &length);
@@ -1354,6 +1394,7 @@ TeststringobjCmd(
 
 static void
 SetVarToObj(
+    Tcl_Obj **varPtr,
     int varIndex,		/* Designates the assignment variable. */
     Tcl_Obj *objPtr)		/* Points to object to assign to var. */
 {
@@ -1426,6 +1467,7 @@ GetVariableIndex(
 static int
 CheckIfVarUnset(
     Tcl_Interp *interp,		/* Interpreter for error reporting. */
+    Tcl_Obj ** varPtr,
     int varIndex)		/* Index of the test variable to check. */
 {
     if (varPtr[varIndex] == NULL) {
-- 
cgit v0.12


From 860e6b5e43e0ac7e673218dd929d425c5d206014 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 12 Aug 2011 08:02:23 +0000
Subject: TIP 388 implementation

---
 doc/Tcl.n           | 30 ++++++++++++++++++++----------
 doc/re_syntax.n     | 29 ++++++++++++++++-------------
 generic/regc_lex.c  | 35 +++++++++++++++++++++++++----------
 generic/regcomp.c   |  2 +-
 generic/regcustom.h |  2 +-
 generic/tcl.h       | 14 +++++++-------
 generic/tclParse.c  | 15 ++++++++++++---
 tests/reg.test      | 15 ++++++++++++---
 tests/utf.test      | 14 +++++++++++++-
 9 files changed, 107 insertions(+), 49 deletions(-)

diff --git a/doc/Tcl.n b/doc/Tcl.n
index f56c82c..c14c4dc 100644
--- a/doc/Tcl.n
+++ b/doc/Tcl.n
@@ -6,7 +6,7 @@
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\"
 .so man.macros
-.TH Tcl n "8.5" Tcl "Tcl Built-In Commands"
+.TH Tcl n "8.6" Tcl "Tcl Built-In Commands"
 .BS
 .SH NAME
 Tcl \- Tool Command Language
@@ -193,23 +193,33 @@ Backslash
 .TP 7
 \e\fIooo\fR 
 .
-The digits \fIooo\fR (one, two, or three of them) give an eight-bit octal 
-value for the Unicode character that will be inserted.  The upper bits of the
-Unicode character will be 0.
+The digits \fIooo\fR (one, two, or three of them) give a eight-bit octal 
+value for the Unicode character that will be inserted, in the range \fI000\fR
+- \fI377\fR.  The parser will stop just before this range overflows, or when
+the maximum of three digits is reached.  The upper bits of the Unicode
+character will be 0.
 .TP 7
 \e\fBx\fIhh\fR 
 .
-The hexadecimal digits \fIhh\fR give an eight-bit hexadecimal value for the
-Unicode character that will be inserted.  Any number of hexadecimal digits
-may be present; however, all but the last two are ignored (the result is
-always a one-byte quantity).  The upper bits of the Unicode character will
-be 0.
+The hexadecimal digits \fIhh\fR (one or two of them) give an eight-bit
+hexadecimal value for the Unicode character that will be inserted.  The upper
+bits of the Unicode character will be 0.
 .TP 7
 \e\fBu\fIhhhh\fR 
 .
 The hexadecimal digits \fIhhhh\fR (one, two, three, or four of them) give a
 sixteen-bit hexadecimal value for the Unicode character that will be
-inserted.
+inserted.  The upper bits of the Unicode character will be 0.
+.TP 7
+\e\fBU\fIhhhhhhhh\fR 
+.
+The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a
+twentiy-one-bit hexadecimal value for the Unicode character that will be
+inserted, in the range U+0000..U+10FFFF.  The parser will stop just
+before this range overflows, or when the maximum of eight digits
+is reached.  The upper bits of the Unicode character will be 0.
+.PP
+The range U+010000..U+10FFFD is reserved for the future.
 .PP
 Backslash substitution is not performed on words enclosed in braces,
 except for backslash-newline as described above.
diff --git a/doc/re_syntax.n b/doc/re_syntax.n
index 8701641..a53f58b 100644
--- a/doc/re_syntax.n
+++ b/doc/re_syntax.n
@@ -359,39 +359,42 @@ horizontal tab, as in C
 .TP
 \fB\eu\fIwxyz\fR
 .
-(where \fIwxyz\fR is exactly four hexadecimal digits) the Unicode
+(where \fIwxyz\fR is one up to four hexadecimal digits) the Unicode
 character \fBU+\fIwxyz\fR in the local byte ordering
 .TP
 \fB\eU\fIstuvwxyz\fR
 .
-(where \fIstuvwxyz\fR is exactly eight hexadecimal digits) reserved
-for a somewhat-hypothetical Unicode extension to 32 bits
+(where \fIstuvwxyz\fR is one up to eight hexadecimal digits) reserved
+for a Unicode extension up to 21 bits. The digits are parsed until the
+first non-hexadecimal character is encountered, the maximun of eight
+hexadecimal digits are reached, or an overflow would occur in the maximum
+value of \fBU+\fI10ffff\fR.
 .TP
 \fB\ev\fR
 .
 vertical tab, as in C are all available.
 .TP
-\fB\ex\fIhhh\fR
+\fB\ex\fIhh\fR
 .
-(where \fIhhh\fR is any sequence of hexadecimal digits) the character
-whose hexadecimal value is \fB0x\fIhhh\fR (a single character no
-matter how many hexadecimal digits are used).
+(where \fIhh\fR is one or two hexadecimal digits) the character
+whose hexadecimal value is \fB0x\fIhh\fR.
 .TP
 \fB\e0\fR
 .
 the character whose value is \fB0\fR
 .TP
+\fB\e\fIxyz\fR
+.
+(where \fIxyz\fR is exactly three octal digits, and is not a \fIback
+reference\fR (see below)) the character whose octal value is
+\fB0\fIxyz\fR. The first digit must be in the range 0-3, otherwise
+the two-digit form is assumed.
+.TP
 \fB\e\fIxy\fR
 .
 (where \fIxy\fR is exactly two octal digits, and is not a \fIback
 reference\fR (see below)) the character whose octal value is
 \fB0\fIxy\fR
-.TP
-\fB\e\fIxyz\fR
-.
-(where \fIxyz\fR is exactly three octal digits, and is not a back
-reference (see below)) the character whose octal value is
-\fB0\fIxyz\fR
 .RE
 .PP
 Hexadecimal digits are
diff --git a/generic/regc_lex.c b/generic/regc_lex.c
index f3a46da..132e757 100644
--- a/generic/regc_lex.c
+++ b/generic/regc_lex.c
@@ -742,6 +742,7 @@ lexescape(
     struct vars *v)
 {
     chr c;
+    int i;
     static const chr alert[] = {
 	CHR('a'), CHR('l'), CHR('e'), CHR('r'), CHR('t')
     };
@@ -818,18 +819,23 @@ lexescape(
 	RETV(PLAIN, CHR('\t'));
 	break;
     case CHR('u'):
-	c = lexdigits(v, 16, 4, 4);
+	c = (uchr) lexdigits(v, 16, 1, 4);
 	if (ISERR()) {
 	    FAILW(REG_EESCAPE);
 	}
 	RETV(PLAIN, c);
 	break;
     case CHR('U'):
-	c = lexdigits(v, 16, 8, 8);
+	i = lexdigits(v, 16, 1, 8);
 	if (ISERR()) {
 	    FAILW(REG_EESCAPE);
 	}
-	RETV(PLAIN, c);
+	if (i > 0xFFFF) {
+	    /* TODO: output a Surrogate pair
+	     */
+	    i = 0xFFFD;
+	}
+	RETV(PLAIN, (uchr) i);
 	break;
     case CHR('v'):
 	RETV(PLAIN, CHR('\v'));
@@ -844,7 +850,7 @@ lexescape(
 	break;
     case CHR('x'):
 	NOTE(REG_UUNPORT);
-	c = lexdigits(v, 16, 1, 255);	/* REs >255 long outside spec */
+	c = (uchr) lexdigits(v, 16, 1, 2);
 	if (ISERR()) {
 	    FAILW(REG_EESCAPE);
 	}
@@ -866,7 +872,7 @@ lexescape(
     case CHR('9'):
 	save = v->now;
 	v->now--;		/* put first digit back */
-	c = lexdigits(v, 10, 1, 255);	/* REs >255 long outside spec */
+	c = (uchr) lexdigits(v, 10, 1, 255);	/* REs >255 long outside spec */
 	if (ISERR()) {
 	    FAILW(REG_EESCAPE);
 	}
@@ -893,10 +899,15 @@ lexescape(
     case CHR('0'):
 	NOTE(REG_UUNPORT);
 	v->now--;		/* put first digit back */
-	c = lexdigits(v, 8, 1, 3);
+	c = (uchr) lexdigits(v, 8, 1, 3);
 	if (ISERR()) {
 	    FAILW(REG_EESCAPE);
 	}
+	if (c > 0xff) {
+	    /* out of range, so we handled one digit too much */
+	    v->now--;
+	    c >>= 3;
+	}
 	RETV(PLAIN, c);
 	break;
     default:
@@ -909,16 +920,16 @@ lexescape(
 
 /*
  - lexdigits - slurp up digits and return chr value
- ^ static chr lexdigits(struct vars *, int, int, int);
+ ^ static int lexdigits(struct vars *, int, int, int);
  */
-static chr			/* chr value; errors signalled via ERR */
+static int			/* chr value; errors signalled via ERR */
 lexdigits(
     struct vars *v,
     int base,
     int minlen,
     int maxlen)
 {
-    uchr n;			/* unsigned to avoid overflow misbehavior */
+    int n;
     int len;
     chr c;
     int d;
@@ -926,6 +937,10 @@ lexdigits(
 
     n = 0;
     for (len = 0; len < maxlen && !ATEOS(); len++) {
+	if (n > 0x10fff) {
+	    /* Stop when continuing would otherwise overflow */
+	    break;
+	}
 	c = *v->now++;
 	switch (c) {
 	case CHR('0'): case CHR('1'): case CHR('2'): case CHR('3'):
@@ -958,7 +973,7 @@ lexdigits(
 	ERR(REG_EESCAPE);
     }
 
-    return (chr)n;
+    return n;
 }
 
 /*
diff --git a/generic/regcomp.c b/generic/regcomp.c
index d7ae05e..65555aa 100644
--- a/generic/regcomp.c
+++ b/generic/regcomp.c
@@ -79,7 +79,7 @@ static void lexnest(struct vars *, const chr *, const chr *);
 static void lexword(struct vars *);
 static int next(struct vars *);
 static int lexescape(struct vars *);
-static chr lexdigits(struct vars *, int, int, int);
+static int lexdigits(struct vars *, int, int, int);
 static int brenext(struct vars *, pchr);
 static void skip(struct vars *);
 static chr newline(NOPARMS);
diff --git a/generic/regcustom.h b/generic/regcustom.h
index bc8c28c..1c970ea 100644
--- a/generic/regcustom.h
+++ b/generic/regcustom.h
@@ -97,7 +97,7 @@ typedef int celt;		/* Type to hold chr, or NOCELT */
 #define	NOCELT (-1)		/* Celt value which is not valid chr */
 #define	CHR(c) (UCHAR(c))	/* Turn char literal into chr literal */
 #define	DIGITVAL(c) ((c)-'0')	/* Turn chr digit into its value */
-#if TCL_UTF_MAX > 3
+#if TCL_UTF_MAX > 4
 #define	CHRBITS	32		/* Bits in a chr; must not use sizeof */
 #define	CHR_MIN	0x00000000	/* Smallest and largest chr; the value */
 #define	CHR_MAX	0xffffffff	/* CHR_MAX-CHR_MIN+1 should fit in uchr */
diff --git a/generic/tcl.h b/generic/tcl.h
index 54bfedc..7370516 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2153,12 +2153,12 @@ typedef struct Tcl_EncodingType {
 
 /*
  * The maximum number of bytes that are necessary to represent a single
- * Unicode character in UTF-8. The valid values should be 3 or 6 (or perhaps 1
- * if we want to support a non-unicode enabled core). If 3, then Tcl_UniChar
- * must be 2-bytes in size (UCS-2) (the default). If 6, then Tcl_UniChar must
- * be 4-bytes in size (UCS-4). At this time UCS-2 mode is the default and
- * recommended mode. UCS-4 is experimental and not recommended. It works for
- * the core, but most extensions expect UCS-2.
+ * Unicode character in UTF-8. The valid values should be 3, 4 or 6
+ * (or perhaps 1 if we want to support a non-unicode enabled core). If 3 or
+ * 4, then Tcl_UniChar must be 2-bytes in size (UCS-2) (the default). If 6,
+ * then Tcl_UniChar must be 4-bytes in size (UCS-4). At this time UCS-2 mode
+ * is the default and recommended mode. UCS-4 is experimental and not
+ * recommended. It works for the core, but most extensions expect UCS-2.
  */
 
 #ifndef TCL_UTF_MAX
@@ -2170,7 +2170,7 @@ typedef struct Tcl_EncodingType {
  * reflected in regcustom.h.
  */
 
-#if TCL_UTF_MAX > 3
+#if TCL_UTF_MAX > 4
     /*
      * unsigned int isn't 100% accurate as it should be a strict 4-byte value
      * (perhaps wchar_t). 64-bit systems may have troubles. The size of this
diff --git a/generic/tclParse.c b/generic/tclParse.c
index 2b0dab4..3c984bf 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -754,7 +754,7 @@ TclParseHex(
     while (numBytes--) {
 	unsigned char digit = UCHAR(*p);
 
-	if (!isxdigit(digit)) {
+	if (!isxdigit(digit) || (result > 0x10fff)) {
 	    break;
 	}
 
@@ -866,7 +866,7 @@ TclParseBackslash(
 	result = 0xb;
 	break;
     case 'x':
-	count += TclParseHex(p+1, numBytes-2, &result);
+	count += TclParseHex(p+1, (numBytes > 3) ? 2 : numBytes-2, &result);
 	if (count == 2) {
 	    /*
 	     * No hexadigits -> This is just "x".
@@ -889,6 +889,15 @@ TclParseBackslash(
 	    result = 'u';
 	}
 	break;
+    case 'U':
+	count += TclParseHex(p+1, (numBytes > 9) ? 8 : numBytes-2, &result);
+	if (count == 2) {
+	    /*
+	     * No hexadigits -> This is just "U".
+	     */
+	    result = 'U';
+	}
+	break;
     case '\n':
 	count--;
 	do {
@@ -917,7 +926,7 @@ TclParseBackslash(
 	    result = (result << 3) + (*p - '0');
 	    p++;
 	    if ((numBytes == 3) || !isdigit(UCHAR(*p))	/* INTL: digit */
-		    || (UCHAR(*p) >= '8')) {
+		    || (UCHAR(*p) >= '8') || (result >= 0x20)) {
 		break;
 	    }
 	    count = 4;
diff --git a/tests/reg.test b/tests/reg.test
index d92339f..ca6cdd1 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -626,16 +626,24 @@ expectMatch	13.13 P		"a\\nb"		"a\nb"	"a\nb"
 expectMatch	13.14 P		"a\\rb"		"a\rb"	"a\rb"
 expectMatch	13.15 P		"a\\tb"		"a\tb"	"a\tb"
 expectMatch	13.16 P		"a\\u0008x"	"a\bx"	"a\bx"
-expectError	13.17 -		{a\u008x}	EESCAPE
+expectMatch	13.17 P		{a\u008x}	"a\bx"	"a\bx"
 expectMatch	13.18 P		"a\\u00088x"	"a\b8x"	"a\b8x"
 expectMatch	13.19 P		"a\\U00000008x"	"a\bx"	"a\bx"
-expectError	13.20 -		{a\U0000008x}	EESCAPE
+expectMatch	13.20 P		{a\U0000008x}	"a\bx"	"a\bx"
 expectMatch	13.21 P		"a\\vb"		"a\vb"	"a\vb"
 expectMatch	13.22 MP	"a\\x08x"	"a\bx"	"a\bx"
 expectError	13.23 -		{a\xq}		EESCAPE
-expectMatch	13.24 MP	"a\\x0008x"	"a\bx"	"a\bx"
+expectMatch	13.24 MP	"a\\x08x"	"a\bx"	"a\bx"
 expectError	13.25 -		{a\z}		EESCAPE
 expectMatch	13.26 MP	"a\\010b"	"a\bb"	"a\bb"
+expectMatch	13.27 P		"a\\U00001234x"	"a\u1234x"	"a\u1234x"
+expectMatch	13.28 P		{a\U00001234x}	"a\u1234x"	"a\u1234x"
+expectMatch	13.29 P		"a\\U0001234x"	"a\u1234x"	"a\u1234x"
+expectMatch	13.30 P		{a\U0001234x}	"a\u1234x"	"a\u1234x"
+expectMatch	13.31 P		"a\\U000012345x"	"a\u12345x"	"a\u12345x"
+expectMatch	13.32 P		{a\U000012345x}	"a\u12345x"	"a\u12345x"
+expectMatch	13.33 P		"a\\U1000000x"	"a\ufffd0x"	"a\ufffd0x"
+expectMatch	13.34 P		{a\U1000000x}	"a\ufffd0x"	"a\ufffd0x"
 
 
 doing 14 "back references"
@@ -682,6 +690,7 @@ expectError	15.9  -	{a((((((((((b\10))))))))))c}	ESUBREG
 expectMatch	15.10 MP	"a\\12b"	"a\nb"	"a\nb"
 expectError	15.11 b		{a\12b}		ESUBREG
 expectMatch	15.12 eAS	{a\12b}		a12b	a12b
+expectMatch	15.13 MP	{a\701b}	a\u00381b	a\u00381b
 
 
 doing 16 "expanded syntax"
diff --git a/tests/utf.test b/tests/utf.test
index d319f6e..0f1428f 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -168,7 +168,7 @@ bsCheck \x	120
 bsCheck \xa	10
 bsCheck \xA	10
 bsCheck \x41	65
-bsCheck \x541	65
+bsCheck \x541	84
 bsCheck \u	117
 bsCheck \uk	117
 bsCheck \u41	65
@@ -177,6 +177,18 @@ bsCheck \uA	10
 bsCheck \340	224
 bsCheck \ua1	161
 bsCheck \u4e21	20001
+bsCheck \741	60
+bsCheck \U	85
+bsCheck \Uk	85
+bsCheck \U41	65
+bsCheck \Ua	10
+bsCheck \UA	10
+bsCheck \Ua1	161
+bsCheck \U4e21	20001
+bsCheck \U004e21	20001
+bsCheck \U00004e21	20001
+bsCheck \U00110000	65533
+bsCheck \Uffffffff	65533
 
 test utf-11.1 {Tcl_UtfToUpper} {
     string toupper {}
-- 
cgit v0.12


From 799b962aea1e21eb1d360a56a574b4bb57dd2853 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 12 Aug 2011 09:55:32 +0000
Subject: [Bug 3390073]: Return the correct length of written data for a
 compressing transform, ensuring that buffers are written exactly once instead
 of multiple times or not at all (producing an invalid file).

---
 ChangeLog         | 15 ++++++++++-----
 generic/tclZlib.c |  2 +-
 tests/zlib.test   | 32 ++++++++++++++++++++++++++++++++
 3 files changed, 43 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 127ee0b..bb2632e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,24 +1,29 @@
+2011-08-12  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclZlib.c (ZlibTransformOutput): [Bug 3390073]: Return the
+	correct length of written data for a compressing transform.
+
 2011-08-10 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
-	* generic/tclTestObj.c: [Bug 3386721] Allow multiple [load]ing of
-	the Tcltest package
+	* generic/tclTestObj.c: [Bug 3386721]: Allow multiple [load]ing of the
+	Tcltest package.
 
 2011-08-09 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
-	* generic/tclBasic.c: [Bug 2919042] Restore "valgrindability" of Tcl
+	* generic/tclBasic.c: [Bug 2919042]: Restore "valgrindability" of Tcl
 	* generic/tclEvent.c: that was lost by the streamlining of [exit], by
 	* generic/tclExecute.c: conditionally forcing a full Finalize:
 	* generic/tclInt.h:  use -DPURIFY or ::env(TCL_FINALIZE_ON_EXIT)
 
 2011-08-09 Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
-	* generic/tclCompCmds.c: [Bug 3386417] avoid a reference loop between
+	* generic/tclCompCmds.c: [Bug 3386417]: Avoid a reference loop between
 	* generic/tclInt.h:      the bytecode and its companion errostack
 	* generic/tclResult.c:   when compiling a syntax error.
 
 2011-08-09  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinConsole.c: [Bug 3388350] mingw64 compiler warnings
+	* win/tclWinConsole.c: [Bug 3388350]: mingw64 compiler warnings
 	* win/tclWinDde.c
 	* win/tclWinPipe.c
 	* win/tclWinSerial.c
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index be91365..81012dc 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -2460,7 +2460,7 @@ ZlibTransformOutput(
 	return -1;
     }
 
-    return toWrite - cd->outStream.avail_out;
+    return toWrite - cd->outStream.avail_in;
 }
 
 static int
diff --git a/tests/zlib.test b/tests/zlib.test
index 47eeab8..dac11e4 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -156,6 +156,7 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
     close $srv
     removeFile $file
 } -result 81920-->81920
+
 test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
     set sfile [makeFile {} testsrc.gz]
     set file [makeFile {} test.gz]
@@ -569,6 +570,37 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
     rename bgerror {}
     rename zlibRead {}
 } -result {error {invalid block type}}
+
+test zlib-11.1 "Bug #3390073: mis-appled gzip filtering" -setup {
+    set file [makeFile {} test.input]
+} -constraints zlib -body {
+    set f [open $file wb]
+    puts -nonewline [zlib push gzip $f] [string repeat "hello" 1000]
+    close $f
+    set f [open $file rb]
+    set d [read $f]
+    close $f
+    set d [zlib gunzip $d]
+    list [regexp -all "hello" $d] [string length [regsub -all "hello" $d {}]]
+} -cleanup {
+    removeFile $file
+} -result {1000 0}
+test zlib-11.2 "Bug #3390073: mis-appled gzip filtering" -setup {
+    set file [makeFile {} test.input]
+} -constraints zlib -body {
+    set f [open $file wb]
+    puts -nonewline [zlib push gzip $f -header {filename /foo/bar}] \
+	[string repeat "hello" 1000]
+    close $f
+    set f [open $file rb]
+    set d [read $f]
+    close $f
+    set d [zlib gunzip $d -header h]
+    list [regexp -all "hello" $d] [dict get $h filename] \
+	[string length [regsub -all "hello" $d {}]]
+} -cleanup {
+    removeFile $file
+} -result {1000 /foo/bar 0}
 
 ::tcltest::cleanupTests
 return
-- 
cgit v0.12


From 751e6372d8ce07e163ea6bd864ae94bebc0167b7 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 12 Aug 2011 12:53:08 +0000
Subject: Fix tcl8.6b2/win/tclWinPort.h:122:10: error: redefinition of 'struct
 __stati64' on newer mingw versions when compiling tktreectrl

---
 win/tclWinPort.h | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index ca58470..aac3fd3 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -118,7 +118,7 @@
 /*
  * Not all mingw32 versions have this struct.
  */
-#if !defined(__BORLANDC__) && !defined(_MSC_VER) && !defined(_WIN64) && !defined(HAVE_STRUCT_STAT32I64)
+#if !defined(__BORLANDC__) && !defined(_MSC_VER) && !defined(_WIN64) && !defined(HAVE_STRUCT_STAT32I64) && defined(BUILD_tcl)
   struct _stat32i64 {
     dev_t st_dev;
     ino_t st_ino;
-- 
cgit v0.12


From abd37955826e20ddd7de66d3f88b5528c6aa1728 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Sun, 14 Aug 2011 08:23:53 +0000
Subject: [Patch 3124554]: Move WishPanic from Tk to Tcl Added Documentation

---
 ChangeLog      |  5 +++++
 doc/FindExec.3 |  7 +++++++
 doc/Panic.3    | 20 +++++++++-----------
 3 files changed, 21 insertions(+), 11 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 1efa77c..14f2708 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-14  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* doc/FindExec.3: [Patch 3124554]: Move WishPanic from Tk to Tcl
+	* doc/Panic.3     Added Documentation
+
 2011-08-12  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclPathObj.c:	[Bug 3389764] Eliminate possibility that dup
diff --git a/doc/FindExec.3 b/doc/FindExec.3
index 0e225e9..66cc1f1 100644
--- a/doc/FindExec.3
+++ b/doc/FindExec.3
@@ -45,6 +45,13 @@ application's executable, if possible.  If it fails to find
 the binary, then future calls to \fBinfo nameofexecutable\fR
 will return an empty string.
 .PP
+On Windows platforms this procedure is typically invoked as the very
+first thing in the application's main program as well; Its \fIargv[0]\fR
+argument is only used to indicate wheter the executable has a stderr
+channel (any non-null value) or not (the value null). If \fBTcl_SetPanicProc\fR
+is never called and no debugger is running, this determines whether
+the panic message is sent to stderr or to a standard system dialog.
+.PP
 \fBTcl_GetNameOfExecutable\fR simply returns a pointer to the
 internal full path name of the executable file as computed by
 \fBTcl_FindExecutable\fR.  This procedure call is the C API
diff --git a/doc/Panic.3 b/doc/Panic.3
index 44eb102..48aed2b 100644
--- a/doc/Panic.3
+++ b/doc/Panic.3
@@ -49,7 +49,10 @@ same formatting rules are also used by the built-in Tcl command
 In a freshly loaded Tcl library, \fBTcl_Panic\fR prints the formatted
 error message to the standard error file of the process, and then
 calls \fBabort\fR to terminate the process.  \fBTcl_Panic\fR does not
-return.
+return. On Windows, when a debugger is running, the formatted error
+message is sent to the debugger in stead. If the windows executable
+does not have a stderr channel (e.g. \fBwish.exe\fR), then a
+system dialog box is used to display the panic message.
 .PP
 \fBTcl_SetPanicProc\fR may be used to modify the behavior of
 \fBTcl_Panic\fR.  The \fIpanicProc\fR argument should match the
@@ -63,19 +66,14 @@ typedef void \fBTcl_PanicProc\fR(
 .PP
 After \fBTcl_SetPanicProc\fR returns, any future calls to
 \fBTcl_Panic\fR will call \fIpanicProc\fR, passing along the
-\fIformat\fR and \fIarg\fR arguments.  To maintain consistency with the
-callers of \fBTcl_Panic\fR, \fIpanicProc\fR must not return; it must
-call \fBabort\fR.  \fIpanicProc\fR should avoid making calls into the
-Tcl library, or into other libraries that may call the Tcl library,
-since the original call to \fBTcl_Panic\fR indicates the Tcl library is
-not in a state of reliable operation.  
+\fIformat\fR and \fIarg\fR arguments. \fIpanicProc\fR should avoid
+making calls into the Tcl library, or into other libraries that may
+call the Tcl library, since the original call to \fBTcl_Panic\fR
+indicates the Tcl library is not in a state of reliable operation.  
 .PP
 The typical use of \fBTcl_SetPanicProc\fR arranges for the error message
 to be displayed or reported in a manner more suitable for the
-application or the platform.  As an example, the Windows implementation
-of \fBwish\fR calls \fBTcl_SetPanicProc\fR to force all panic messages
-to be displayed in a system dialog box, rather than to be printed to the
-standard error file (usually not visible under Windows).
+application or the platform.
 .PP
 Although the primary callers of \fBTcl_Panic\fR are the procedures of
 the Tcl library, \fBTcl_Panic\fR is a public function and may be called
-- 
cgit v0.12


From 754781a8ca6a7ff2617e2dea8f8fc569c868445e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 16 Aug 2011 13:55:06 +0000
Subject: Small changes to quell gcc warnings and make message generation less
 ugly.

---
 ChangeLog             |  14 +++++--
 generic/tclCmdIL.c    |   9 ++---
 generic/tclIndexObj.c |  44 ++++++++++-----------
 generic/tclListObj.c  | 106 +++++++++++++++++++++++++++++++++-----------------
 generic/tclVar.c      |   7 +---
 5 files changed, 108 insertions(+), 72 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 28c66aa..b8832e6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,18 @@
+2011-08-16  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclListObj.c (TclLindexList, TclLsetFlat): Silence warnings
+	about (unreachable) cases of uninitialized variables.
+	* generic/tclCmdIL.c (SelectObjFromSublist): Improve the generation of
+	* generic/tclIndexObj.c (Tcl_ParseArgsObjv): messages through the use
+	* generic/tclVar.c (ArrayStartSearchCmd):    of Tcl_ObjPrintf.
+
 2011-08-15  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclBasic.c: [Bug 3390272] Leak of [info script] value.
+	* generic/tclBasic.c: [Bug 3390272]: Leak of [info script] value.
 
 2011-08-15  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclPosixStr.c:    [Bug 3388350] mingw64 compiler warnings
+	* generic/tclPosixStr.c:    [Bug 3388350]: mingw64 compiler warnings
 	* win/tclWinPort.h:
 	* win/configure.in
 	* win/configure
@@ -16,7 +24,7 @@
 
 2011-08-12  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclPathObj.c:	[Bug 3389764] Eliminate possibility that dup
+	* generic/tclPathObj.c:	[Bug 3389764]: Eliminate possibility that dup
 	of a "path" value can create reference cycle.
 
 2011-08-12  Donal K. Fellows  <dkf@users.sf.net>
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 64348ad..95532d3 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -4446,12 +4446,9 @@ SelectObjFromSublist(
 	    return NULL;
 	}
 	if (currentObj == NULL) {
-	    char buffer[TCL_INTEGER_SPACE];
-
-	    TclFormatInt(buffer, index);
-	    Tcl_AppendResult(infoPtr->interp, "element ", buffer,
-		    " missing from sublist \"", TclGetString(objPtr), "\"",
-		    NULL);
+            Tcl_SetObjResult(infoPtr->interp, Tcl_ObjPrintf(
+                    "element %d missing from sublist \"%s\"",
+                    index, TclGetString(objPtr)));
             Tcl_SetErrorCode(infoPtr->interp, "TCL", "OPERATION", "LSORT",
                     "INDEXFAILED", NULL);
 	    infoPtr->resultCode = TCL_ERROR;
diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 76c2dea..6f378a4 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -359,7 +359,6 @@ Tcl_GetIndexFromObjStruct(
 	int count;
 
 	TclNewObj(resultPtr);
-	Tcl_SetObjResult(interp, resultPtr);
 	Tcl_AppendStringsToObj(resultPtr,
 		(numAbbrev>1 && !(flags & TCL_EXACT) ? "ambiguous " : "bad "),
 		msg, " \"", key, NULL);
@@ -379,6 +378,7 @@ Tcl_GetIndexFromObjStruct(
 		}
 	    }
 	}
+	Tcl_SetObjResult(interp, resultPtr);
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "INDEX", msg, key, NULL);
     }
     return TCL_ERROR;
@@ -410,7 +410,7 @@ SetIndexFromAny(
     register Tcl_Obj *objPtr)	/* The object to convert. */
 {
     if (interp) {
-    Tcl_SetObjResult(interp, Tcl_NewStringObj(
+	Tcl_SetObjResult(interp, Tcl_NewStringObj(
 	    "can't convert value to index except via Tcl_GetIndexFromObj API",
 	    -1));
     }
@@ -593,14 +593,16 @@ PrefixMatchObjCmd(
 	case PRFMATCH_MESSAGE:
 	    if (i > (objc - 4)) {
 		Tcl_AppendResult(interp, "missing message", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
 		return TCL_ERROR;
 	    }
 	    i++;
 	    message = Tcl_GetString(objv[i]);
 	    break;
 	case PRFMATCH_ERROR:
-	    if (i > (objc - 4)) {
+	    if (i > objc-4) {
 		Tcl_AppendResult(interp, "missing error options", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "NOARG", NULL);
 		return TCL_ERROR;
 	    }
 	    i++;
@@ -611,6 +613,7 @@ PrefixMatchObjCmd(
 	    if ((errorLength % 2) != 0) {
 		Tcl_AppendResult(interp, "error options must have an even"
 			" number of elements", NULL);
+		Tcl_SetErrorCode(interp, "TCL", "VALUE", "DICTIONARY", NULL);
 		return TCL_ERROR;
 	    }
 	    errorPtr = objv[i];
@@ -1093,7 +1096,7 @@ Tcl_ParseArgsObjv(
 				/* Pointer to the current entry in the table
 				 * of argument descriptions. */
     const Tcl_ArgvInfo *matchPtr;
-				/* Descriptor that matches current argument. */
+				/* Descriptor that matches current argument */
     Tcl_Obj *curArg;		/* Current argument */
     const char *str = NULL;
     register char c;		/* Second character of current arg (used for
@@ -1106,7 +1109,7 @@ Tcl_ParseArgsObjv(
 				 * being processed, primarily for error
 				 * reporting. */
     int objc;			/* # arguments in objv still to process. */
-    int length;			/* Number of characters in current argument. */
+    int length;			/* Number of characters in current argument */
 
     if (remObjv != NULL) {
 	/*
@@ -1147,8 +1150,7 @@ Tcl_ParseArgsObjv(
 
 	matchPtr = NULL;
 	infoPtr = argTable;
-	for (; (infoPtr != NULL) && (infoPtr->type != TCL_ARGV_END);
-		infoPtr++) {
+	for (; infoPtr != NULL && infoPtr->type != TCL_ARGV_END ; infoPtr++) {
 	    if (infoPtr->keyStr == NULL) {
 		continue;
 	    }
@@ -1242,7 +1244,8 @@ Tcl_ParseArgsObjv(
 	    objc--;
 	    break;
 	case TCL_ARGV_FUNC: {
-	    Tcl_ArgvFuncProc *handlerProc;
+	    Tcl_ArgvFuncProc *handlerProc = (Tcl_ArgvFuncProc *)
+		    infoPtr->srcPtr;
 	    Tcl_Obj *argObj;
 
 	    if (objc == 0) {
@@ -1250,7 +1253,6 @@ Tcl_ParseArgsObjv(
 	    } else {
 		argObj = objv[srcIndex];
 	    }
-	    handlerProc = (Tcl_ArgvFuncProc *) infoPtr->srcPtr;
 	    if (handlerProc(infoPtr->clientData, argObj, infoPtr->dstPtr)) {
 		srcIndex++;
 		objc--;
@@ -1258,9 +1260,9 @@ Tcl_ParseArgsObjv(
 	    break;
 	}
 	case TCL_ARGV_GENFUNC: {
-	    Tcl_ArgvGenFuncProc *handlerProc;
+	    Tcl_ArgvGenFuncProc *handlerProc = (Tcl_ArgvGenFuncProc *)
+		    infoPtr->srcPtr;
 
-	    handlerProc = (Tcl_ArgvGenFuncProc *) infoPtr->srcPtr;
 	    objc = handlerProc(infoPtr->clientData, interp, objc,
 		    &objv[srcIndex], infoPtr->dstPtr);
 	    if (objc < 0) {
@@ -1271,15 +1273,11 @@ Tcl_ParseArgsObjv(
 	case TCL_ARGV_HELP:
 	    PrintUsage(interp, argTable);
 	    goto error;
-	default: {
-	    char buf[64 + TCL_INTEGER_SPACE];
-
-	    sprintf(buf, "bad argument type %d in Tcl_ArgvInfo",
-		    infoPtr->type);
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj(buf, -1));
+	default:
+	    Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+		    "bad argument type %d in Tcl_ArgvInfo", infoPtr->type));
 	    goto error;
 	}
-	}
     }
 
     /*
@@ -1444,18 +1442,18 @@ int
 TclGetCompletionCodeFromObj(
     Tcl_Interp *interp,		/* Current interpreter. */
     Tcl_Obj *value,
-    int *code)	/* Argument objects. */
+    int *code)			/* Argument objects. */
 {
     static const char *const returnCodes[] = {
-	    "ok", "error", "return", "break", "continue", NULL
+	"ok", "error", "return", "break", "continue", NULL
     };
 
     if ((value->typePtr != &indexType)
 	    && (TCL_OK == TclGetIntFromObj(NULL, value, code))) {
 	return TCL_OK;
     }
-    if (TCL_OK == Tcl_GetIndexFromObj(
-	    NULL, value, returnCodes, NULL, TCL_EXACT, code)) {
+    if (TCL_OK == Tcl_GetIndexFromObj(NULL, value, returnCodes, NULL,
+		TCL_EXACT, code)) {
 	return TCL_OK;
     }
     /*
@@ -1472,7 +1470,7 @@ TclGetCompletionCodeFromObj(
     }
     return TCL_ERROR;
 }
-
+
 /*
  * Local Variables:
  * mode: c
diff --git a/generic/tclListObj.c b/generic/tclListObj.c
index ac87628..3668b45 100644
--- a/generic/tclListObj.c
+++ b/generic/tclListObj.c
@@ -49,7 +49,6 @@ const Tcl_ObjType tclListType = {
 #ifndef TCL_MIN_ELEMENT_GROWTH
 #define TCL_MIN_ELEMENT_GROWTH TCL_MIN_GROWTH/sizeof(Tcl_Obj *)
 #endif
-
 
 /*
  *----------------------------------------------------------------------
@@ -518,7 +517,10 @@ Tcl_ListObjAppendList(
 	Tcl_Panic("%s called with shared object", "Tcl_ListObjAppendList");
     }
 
-    /* Pull the elements to append from elemListPtr */
+    /*
+     * Pull the elements to append from elemListPtr.
+     */
+
     if (TCL_OK != TclListObjGetElements(interp, elemListPtr, &objc, &objv)) {
 	return TCL_ERROR;
     }
@@ -600,7 +602,10 @@ Tcl_ListObjAppendElement(
     }
 
     if (needGrow && !isShared) {
-	/* Need to grow + unshared intrep => try to realloc */
+	/*
+	 * Need to grow + unshared intrep => try to realloc
+	 */
+
 	attempt = 2 * numRequired;
 	if (attempt <= LIST_MAX) {
 	    newPtr = attemptckrealloc(listRepPtr, LIST_SIZE(attempt));
@@ -626,10 +631,10 @@ Tcl_ListObjAppendElement(
 	Tcl_Obj **dst, **src = &listRepPtr->elements;
 
 	/*
-	 * Either we have a shared intrep and we must copy to write,
-	 * or we need to grow and realloc attempts failed.
-	 * Attempt intrep copy.
+	 * Either we have a shared intrep and we must copy to write, or we
+	 * need to grow and realloc attempts failed.  Attempt intrep copy.
 	 */
+
 	attempt = 2 * numRequired;
 	newPtr = AttemptNewList(NULL, attempt, NULL);
 	if (newPtr == NULL) {
@@ -644,7 +649,10 @@ Tcl_ListObjAppendElement(
 	    newPtr = AttemptNewList(interp, attempt, NULL);
 	}
 	if (newPtr == NULL) {
-	    /* All growth attempts failed; throw the error */
+	    /*
+	     * All growth attempts failed; throw the error.
+	     */
+
 	    return TCL_ERROR;
 	}
 
@@ -655,8 +663,8 @@ Tcl_ListObjAppendElement(
 
 	if (isShared) {
 	    /*
-	     * The original intrep must remain undisturbed.
-	     * Copy into the new one and bump refcounts
+	     * The original intrep must remain undisturbed.  Copy into the new
+	     * one and bump refcounts
 	     */
 	    while (numElems--) {
 		*dst = *src++;
@@ -664,9 +672,11 @@ Tcl_ListObjAppendElement(
 	    }
 	    listRepPtr->refCount--;
 	} else {
-	    /* Old intrep to be freed, re-use refCounts */
-	    memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
+	    /*
+	     * Old intrep to be freed, re-use refCounts.
+	     */
 
+	    memcpy(dst, src, (size_t) numElems * sizeof(Tcl_Obj *));
 	    ckfree(listRepPtr);
 	}
 	listRepPtr = newPtr;
@@ -854,11 +864,10 @@ Tcl_ListObjReplace(
     }
     if (listPtr->typePtr != &tclListType) {
 	if (listPtr->bytes == tclEmptyStringRep) {
-	    if (objc) {
-		Tcl_SetListObj(listPtr, objc, NULL);
-	    } else {
+	    if (!objc) {
 		return TCL_OK;
 	    }
+	    Tcl_SetListObj(listPtr, objc, NULL);
 	} else {
 	    int result = SetListFromAny(interp, listPtr);
 
@@ -891,8 +900,9 @@ Tcl_ListObjReplace(
     } else if (numElems < first+count || first+count < 0) {
 	/*
 	 * The 'first+count < 0' condition here guards agains integer
-	 * overflow in determining 'first+count'
+	 * overflow in determining 'first+count'.
 	 */
+
 	count = numElems - first;
     }
 
@@ -1075,8 +1085,6 @@ TclLindexList(
 {
 
     int index;			/* Index into the list. */
-    Tcl_Obj **indices;		/* Array of list indices. */
-    int indexCount;		/* Size of the array of list indices. */
     Tcl_Obj *indexListCopy;
 
     /*
@@ -1116,8 +1124,19 @@ TclLindexList(
 	return TclLindexFlat(interp, listPtr, 1, &argPtr);
     }
 
-    TclListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
-    listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
+    if (indexListCopy->typePtr == &tclListType) {
+	List *listRepPtr = ListRepPtr(indexListCopy);
+
+	listPtr = TclLindexFlat(interp, listPtr, listRepPtr->elemCount,
+		&listRepPtr->elements);
+    } else {
+	int indexCount = -1;	/* Size of the array of list indices. */
+	Tcl_Obj **indices = NULL;
+				/* Array of list indices. */
+
+	Tcl_ListObjGetElements(NULL, indexListCopy, &indexCount, &indices);
+	listPtr = TclLindexFlat(interp, listPtr, indexCount, indices);
+    }
     Tcl_DecrRefCount(indexListCopy);
     return listPtr;
 }
@@ -1375,6 +1394,7 @@ TclLsetFlat(
 
     retValuePtr = subListPtr;
     chainPtr = NULL;
+    result = TCL_OK;
 
     /*
      * Loop through all the index arguments, and for each one dive into the
@@ -1385,11 +1405,14 @@ TclLsetFlat(
 	int elemCount;
 	Tcl_Obj *parentList, **elemPtrs;
 
-	/* Check for the possible error conditions... */
-	result = TCL_ERROR;
+	/*
+	 * Check for the possible error conditions...
+	 */
+
 	if (TclListObjGetElements(interp, subListPtr, &elemCount, &elemPtrs)
 		!= TCL_OK) {
 	    /* ...the sublist we're indexing into isn't a list at all. */
+	    result = TCL_ERROR;
 	    break;
 	}
 
@@ -1401,6 +1424,7 @@ TclLsetFlat(
 	if (TclGetIntForIndexM(interp, *indexArray, elemCount - 1, &index)
 		!= TCL_OK)  {
 	    /* ...the index we're trying to use isn't an index at all. */
+	    result = TCL_ERROR;
 	    indexArray++;
 	    break;
 	}
@@ -1411,9 +1435,10 @@ TclLsetFlat(
 	    if (interp != NULL) {
 		Tcl_SetObjResult(interp,
 			Tcl_NewStringObj("list index out of range", -1));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
+			"BADINDEX", NULL);
 	    }
-	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
-		    NULL);
+	    result = TCL_ERROR;
 	    break;
 	}
 
@@ -1424,7 +1449,6 @@ TclLsetFlat(
 	 * modify it.
 	 */
 
-	result = TCL_OK;
 	if (--indexCount) {
 	    parentList = subListPtr;
 	    if (index == elemCount) {
@@ -1514,10 +1538,13 @@ TclLsetFlat(
     }
 
     /*
-     * Store valuePtr in proper sublist and return.
+     * Store valuePtr in proper sublist and return. The -1 is to avoid a
+     * compiler warning (not a problem because we checked that we have a
+     * proper list - or something convertible to one - above).
      */
 
-    Tcl_ListObjLength(NULL, subListPtr, &len);
+    len = -1;
+    TclListObjLength(NULL, subListPtr, &len);
     if (index == len) {
 	Tcl_ListObjAppendElement(NULL, subListPtr, valuePtr);
     } else {
@@ -1586,9 +1613,9 @@ TclListObjSetElement(
 	    if (interp != NULL) {
 		Tcl_SetObjResult(interp,
 			Tcl_NewStringObj("list index out of range", -1));
+		Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET",
+			"BADINDEX", NULL);
 	    }
-	    Tcl_SetErrorCode(interp, "TCL", "OPERATION", "LSET", "BADINDEX",
-		    NULL);
 	    return TCL_ERROR;
 	}
 	result = SetListFromAny(interp, listPtr);
@@ -1811,19 +1838,23 @@ SetListFromAny(
 	 */
 
 	estCount = TclMaxListLength(nextElem, length, &limit);
-	estCount += (estCount == 0); /* Smallest List struct holds 1 element. */
+	estCount += (estCount == 0);	/* Smallest list struct holds 1
+					 * element. */
 	listRepPtr = AttemptNewList(interp, estCount, NULL);
 	if (listRepPtr == NULL) {
 	    return TCL_ERROR;
 	}
 	elemPtrs = &listRepPtr->elements;
 
-	/* Each iteration, parse and store a list element */
+	/*
+	 * Each iteration, parse and store a list element.
+	 */
+
 	while (nextElem < limit) {
 	    const char *elemStart;
 	    int elemSize, literal;
 
-	    if (TCL_OK != TclFindElement(interp, nextElem, (limit - nextElem),
+	    if (TCL_OK != TclFindElement(interp, nextElem, limit - nextElem,
 		    &elemStart, &nextElem, &elemSize, &literal)) {
 		while (--elemPtrs >= &listRepPtr->elements) {
 		    Tcl_DecrRefCount(*elemPtrs);
@@ -1904,7 +1935,9 @@ UpdateStringOfList(
 
     listRepPtr->canonicalFlag = 1;
 
-    /* Handle empty list case first, so rest of the routine is simpler */
+    /*
+     * Handle empty list case first, so rest of the routine is simpler.
+     */
 
     if (numElems == 0) {
 	listPtr->bytes = tclEmptyStringRep;
@@ -1919,12 +1952,15 @@ UpdateStringOfList(
     if (numElems <= LOCAL_SIZE) {
 	flagPtr = localFlags;
     } else {
-	/* We know numElems <= LIST_MAX, so this is safe. */
+	/*
+	 * We know numElems <= LIST_MAX, so this is safe.
+	 */
+
 	flagPtr = ckalloc(numElems * sizeof(int));
     }
     elemPtrs = &listRepPtr->elements;
     for (i = 0; i < numElems; i++) {
-	flagPtr[i] = ( i ? TCL_DONT_QUOTE_HASH : 0 );
+	flagPtr[i] = (i ? TCL_DONT_QUOTE_HASH : 0);
 	elem = TclGetStringFromObj(elemPtrs[i], &length);
 	bytesNeeded += TclScanElement(elem, length, flagPtr+i);
 	if (bytesNeeded < 0) {
@@ -1944,7 +1980,7 @@ UpdateStringOfList(
     listPtr->bytes = ckalloc(bytesNeeded);
     dst = listPtr->bytes;
     for (i = 0; i < numElems; i++) {
-	flagPtr[i] |= ( i ? TCL_DONT_QUOTE_HASH : 0 );
+	flagPtr[i] |= (i ? TCL_DONT_QUOTE_HASH : 0);
 	elem = TclGetStringFromObj(elemPtrs[i], &length);
 	dst += TclConvertElement(elem, length, dst, flagPtr[i]);
 	*dst++ = ' ';
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 62bf1c4..4df5d43 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -3077,21 +3077,18 @@ ArrayStartSearchCmd(
     hPtr = Tcl_CreateHashEntry(&iPtr->varSearches, varPtr, &isNew);
     if (isNew) {
 	searchPtr->id = 1;
-	Tcl_AppendResult(interp, "s-1-", varName, NULL);
 	varPtr->flags |= VAR_SEARCH_ACTIVE;
 	searchPtr->nextPtr = NULL;
     } else {
-	char string[TCL_INTEGER_SPACE];
-
 	searchPtr->id = ((ArraySearch *) Tcl_GetHashValue(hPtr))->id + 1;
-	TclFormatInt(string, searchPtr->id);
-	Tcl_AppendResult(interp, "s-", string, "-", varName, NULL);
 	searchPtr->nextPtr = Tcl_GetHashValue(hPtr);
     }
     searchPtr->varPtr = varPtr;
     searchPtr->nextEntry = VarHashFirstEntry(varPtr->value.tablePtr,
 	    &searchPtr->search);
     Tcl_SetHashValue(hPtr, searchPtr);
+    Tcl_SetObjResult(interp,
+	    Tcl_ObjPrintf("s-%d-%s", searchPtr->id, varName));
     return TCL_OK;
 }
 
-- 
cgit v0.12


From 3323723916d6dd4a6fa97bec7fb95f9299cadf22 Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Tue, 16 Aug 2011 16:04:28 +0000
Subject: Fixed the C99/C++ comments introduced by [8d3f0fb215] which break
 strict C89 compilers (AIX, cough, cough)

---
 generic/tclMain.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclMain.c b/generic/tclMain.c
index 652074e..114d2c3 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -392,7 +392,7 @@ Tcl_MainEx(
 	/*
 	 * Arrange for final deletion of the main interp
 	 */
-	// ARGH Munchhausen effect 
+	/* ARGH Munchhausen effect  */
 	Tcl_CreateExitHandler(FreeMainInterp, (ClientData)interp);
     }
 
@@ -928,7 +928,7 @@ FreeMainInterp(
 {
 	Tcl_Interp *interp = (Tcl_Interp *) clientData;
 
-	//if (TclInExit()) return;
+	/*if (TclInExit()) return;*/
 
 	if (!Tcl_InterpDeleted(interp)) {
 	    Tcl_DeleteInterp(interp);
-- 
cgit v0.12


From 07e716801399c0843c58d8c3c6b43f183f1fd378 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 16 Aug 2011 19:49:57 +0000
Subject: 3392070 More complete prevention of Tcl_Obj reference cycles when
 producing an intrep of ByteCode.

---
 ChangeLog            |  5 +++++
 generic/tclCompile.c | 10 +++++++++-
 2 files changed, 14 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index b8832e6..567bfd2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-16  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclCompile.c: [Bug 3392070] More complete prevention of
+	Tcl_Obj reference cycles when producing an intrep of ByteCode.
+
 2011-08-16  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclListObj.c (TclLindexList, TclLsetFlat): Silence warnings
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index ae633ea..026503b 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -2449,8 +2449,16 @@ TclInitByteCodeObj(
 	     * a value contains a literal which is that same value.
 	     * If this is allowed to happen, refcount decrements may not
 	     * reach zero, and memory may leak.  Bugs 467523, 3357771
+	     *
+	     * NOTE:  [Bugs 3392070, 3389764] We make a copy based completely
+	     * on the string value, and do not call Tcl_DuplicateObj() so we
+             * can be sure we do not have any lingering cycles hiding in
+	     * the intrep.
 	     */
-	    codePtr->objArrayPtr[i] = Tcl_DuplicateObj(objPtr);
+	    int numBytes;
+	    const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes);
+
+	    codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes);
 	    Tcl_IncrRefCount(codePtr->objArrayPtr[i]);
 	    Tcl_DecrRefCount(objPtr);
 	} else {
-- 
cgit v0.12


From 5f6458590d2630066c197d4c91986c175c8820e3 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 17 Aug 2011 06:37:02 +0000
Subject: separate test for overflowed and negative Tcl_UniChar

---
 tests/utf.test | 9 ++++++---
 1 file changed, 6 insertions(+), 3 deletions(-)

diff --git a/tests/utf.test b/tests/utf.test
index d319f6e..92b3a48 100644
--- a/tests/utf.test
+++ b/tests/utf.test
@@ -27,9 +27,12 @@ test utf-1.3 {Tcl_UniCharToUtf: 2 byte sequences} {
 test utf-1.4 {Tcl_UniCharToUtf: 3 byte sequences} {
     set x "\u4e4e"
 } [bytestring "\xe4\xb9\x8e"]
-test utf-1.5 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
-    string length [format %c -1]
-} 1
+test utf-1.5 {Tcl_UniCharToUtf: overflowed Tcl_UniChar} {
+    format %c 0x110000
+} [bytestring "\xef\xbf\xbd"]
+test utf-1.6 {Tcl_UniCharToUtf: negative Tcl_UniChar} {
+    format %c -1
+} [bytestring "\xef\xbf\xbd"]
 
 test utf-2.1 {Tcl_UtfToUniChar: low ascii} {
     string length "abc"
-- 
cgit v0.12


From 703f1a10e054dc8c26566bc3ad5fa463a5289be9 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Wed, 17 Aug 2011 18:33:35 +0000
Subject: Document TIP 378's one-way-ness.

---
 ChangeLog    | 4 ++++
 doc/interp.n | 4 ++++
 2 files changed, 8 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 2d9b7ec..4126cee 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-08-17  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* doc/interp.n: Document TIP 378's one-way-ness.
+	
 2011-08-17  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclGet.c: [Bug 3393150] Overlooked free of intreps.
diff --git a/doc/interp.n b/doc/interp.n
index b261779..6ce10ee 100644
--- a/doc/interp.n
+++ b/doc/interp.n
@@ -230,6 +230,10 @@ extends so far that the system will be able to determine the file and
 absolute line number of this command, and return a frame of type
 \fBsource\fR. This more exact information is paid for with slower
 execution of all commands.
+.PP
+Note that once it is on, this flag cannot be switched back off: such
+attempts are silently ignored. This is needed to maintain the
+consistency of the underlying interpreter's state.
 .RE
 .TP
 \fBinterp\fR \fBdelete \fR?\fIpath ...?\fR
-- 
cgit v0.12


From 1d11a7f1fd50b863d05886dbe18ca3ed326e5df8 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Wed, 17 Aug 2011 20:35:19 +0000
Subject: [Bug 2946474] Consistently resume backgrounded flushes+closes when
 exiting.

---
 ChangeLog        |  5 +++++
 generic/tclIO.c  |  5 +++--
 tests/ioCmd.test | 31 +++++++++++++++++++++++++++++++
 3 files changed, 39 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 4126cee..6ebfce0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
 2011-08-17  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
+	* generic/tclIO.c:  [Bug 2946474] Consistently resume backgrounded
+	* tests/ioCmd.test: flushes+closes when exiting.
+
+2011-08-17  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
 	* doc/interp.n: Document TIP 378's one-way-ness.
 	
 2011-08-17  Don Porter  <dgp@users.sourceforge.net>
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 78c1dc0..a19fde8 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -414,8 +414,8 @@ TclFinalizeIOSubsystem(void)
 		statePtr != NULL;
 		statePtr = statePtr->nextCSPtr) {
 	    chanPtr = statePtr->topChanPtr;
-	    if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED |
-		    CHANNEL_DEAD)) {
+            if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED | CHANNEL_DEAD)
+                || GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
 		active = 1;
 		break;
 	    }
@@ -458,6 +458,7 @@ TclFinalizeIOSubsystem(void)
 		 * The refcount is greater than zero, so flush the channel.
 		 */
 
+                ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
 		Tcl_Flush((Tcl_Channel) chanPtr);
 
 		/*
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 82f83db..6536072 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -2592,9 +2592,40 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi
 } -cleanup {
     rename foo {}
     unset res
+    update
 } -result {{write rc* ABC} {watch rc* write} {}} \
     -constraints {testchannel testthread}
 
+test iocmd.tf-24.16 {chan write, note the background flush setup by close due to the EAGAIN leaving data in buffers.} -match glob -setup {
+    set res {}
+    proc foo {args} {
+	oninit; onfinal; track
+	# Note: The EAGAIN signals that the channel cannot accept
+	# write requests right now, this in turn causes the IO core to
+	# request the generation of writable events (see expected
+	# result below, and compare to case 24.14 above).
+	error EAGAIN
+    }
+    set c [chan create {r w} foo]
+} -body {
+    notes [inthread $c {
+	note [puts -nonewline $c ABC ; flush $c]
+	close $c
+	notes
+    } c]
+    # Replace handler with all-tracking one which doesn't error.
+    # This will tell us if a write-due-flush is there.
+    proc foo {args} { note BG ; track }
+    # Flush (sic!) the event-queue to capture the write from a
+    # BG-flush.
+    update
+    set res
+} -cleanup {
+    rename foo {}
+    unset res
+} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \
+    -constraints {testchannel testthread}
+
 # --- === *** ###########################
 # method cgetall
 
-- 
cgit v0.12


From 377e7c77456825d7dc9d44f44c937ff57e1bfce3 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Thu, 18 Aug 2011 15:06:58 +0000
Subject: [Bug 3096275] Sync fcopy buffers input.

---
 ChangeLog       |  4 ++++
 generic/tclIO.c | 15 ++++++++++-----
 2 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 64a25dd..e294229 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-08-18  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* generic/tclIO.c [Bug 3096275] Sync fcopy buffers input.
+
 2011-08-18  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclUniData.c: [Bug 3393714] overflow in toupper delta
diff --git a/generic/tclIO.c b/generic/tclIO.c
index a19fde8..95afd63 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -79,7 +79,7 @@ static int		DetachChannel(Tcl_Interp *interp, Tcl_Channel chan);
 static void		DiscardInputQueued(ChannelState *statePtr,
 			    int discardSavedBuffers);
 static void		DiscardOutputQueued(ChannelState *chanPtr);
-static int		DoRead(Channel *chanPtr, char *srcPtr, int slen);
+static int		DoRead(Channel *chanPtr, char *srcPtr, int slen, int allowShortReads);
 static int		DoWrite(Channel *chanPtr, const char *src, int srcLen);
 static int		DoReadChars(Channel *chan, Tcl_Obj *objPtr, int toRead,
 			    int appendFlag);
@@ -5444,7 +5444,7 @@ Tcl_Read(
 	return -1;
     }
 
-    return DoRead(chanPtr, dst, bytesToRead);
+    return DoRead(chanPtr, dst, bytesToRead, 0);
 }
 
 /*
@@ -9169,7 +9169,8 @@ CopyData(
 	    }
 
 	    if (inBinary || sameEncoding) {
-		size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb);
+		size = DoRead(inStatePtr->topChanPtr, csPtr->buffer, sizeb,
+                              !GotFlag(inStatePtr, CHANNEL_NONBLOCKING));
 	    } else {
 		size = DoReadChars(inStatePtr->topChanPtr, bufObj, sizeb,
 			0 /* No append */);
@@ -9408,7 +9409,8 @@ static int
 DoRead(
     Channel *chanPtr,		/* The channel from which to read. */
     char *bufPtr,		/* Where to store input read. */
-    int toRead)			/* Maximum number of bytes to read. */
+    int toRead,			/* Maximum number of bytes to read. */
+    int allowShortReads)	/* Allow half-blocking (pipes,sockets) */
 {
     ChannelState *statePtr = chanPtr->state;
 				/* State info for channel */
@@ -9449,7 +9451,10 @@ DoRead(
 		}
 		goto done;
 	    }
-	}
+	} else if (allowShortReads) {
+            copied += copiedNow;
+            break;
+        }
     }
 
     ResetFlag(statePtr, CHANNEL_BLOCKED);
-- 
cgit v0.12


From 72fa03ae4fe97ce840005caa68f3467a1489260a Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Fri, 19 Aug 2011 13:59:57 +0000
Subject: [Bug 2981154] async-4.3 segfault.

---
 ChangeLog         |  8 ++++++--
 generic/tclTest.c | 52 +++++++++++++++++++++++++++++++++++++++++++---------
 2 files changed, 49 insertions(+), 11 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index e294229..d8cf76e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,10 @@
+2011-08-19  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* generic/tclTest.c: [Bug 2981154] async-4.3 segfault.
+
 2011-08-18  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
-	* generic/tclIO.c [Bug 3096275] Sync fcopy buffers input.
+	* generic/tclIO.c: [Bug 3096275] Sync fcopy buffers input.
 
 2011-08-18  Jan Nijtmans  <nijtmans@users.sf.net>
 
@@ -16,7 +20,7 @@
 2011-08-17  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	* doc/interp.n: Document TIP 378's one-way-ness.
-	
+
 2011-08-17  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclGet.c: [Bug 3393150] Overlooked free of intreps.
diff --git a/generic/tclTest.c b/generic/tclTest.c
index bac0c7f..3e3bc09 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -75,6 +75,8 @@ typedef struct TestAsyncHandler {
 				/* Next is list of handlers. */
 } TestAsyncHandler;
 
+TCL_DECLARE_MUTEX(asyncTestMutex);
+
 static TestAsyncHandler *firstHandler = NULL;
 
 /*
@@ -791,17 +793,20 @@ TestasyncCmd(
 	    goto wrongNumArgs;
 	}
 	asyncPtr = ckalloc(sizeof(TestAsyncHandler));
+	asyncPtr->command = ckalloc(strlen(argv[2]) + 1);
+	strcpy(asyncPtr->command, argv[2]);
+        Tcl_MutexLock(&asyncTestMutex);
 	asyncPtr->id = nextId;
 	nextId++;
 	asyncPtr->handler = Tcl_AsyncCreate(AsyncHandlerProc,
-		(ClientData) asyncPtr);
-	asyncPtr->command = ckalloc(strlen(argv[2]) + 1);
-	strcpy(asyncPtr->command, argv[2]);
+                                            (ClientData) asyncPtr->id);
 	asyncPtr->nextPtr = firstHandler;
 	firstHandler = asyncPtr;
+        Tcl_MutexUnlock(&asyncTestMutex);
 	Tcl_SetObjResult(interp, Tcl_NewIntObj(asyncPtr->id));
     } else if (strcmp(argv[1], "delete") == 0) {
 	if (argc == 2) {
+            Tcl_MutexLock(&asyncTestMutex);
 	    while (firstHandler != NULL) {
 		asyncPtr = firstHandler;
 		firstHandler = asyncPtr->nextPtr;
@@ -809,6 +814,7 @@ TestasyncCmd(
 		ckfree(asyncPtr->command);
 		ckfree(asyncPtr);
 	    }
+            Tcl_MutexUnlock(&asyncTestMutex);
 	    return TCL_OK;
 	}
 	if (argc != 3) {
@@ -817,6 +823,7 @@ TestasyncCmd(
 	if (Tcl_GetInt(interp, argv[2], &id) != TCL_OK) {
 	    return TCL_ERROR;
 	}
+        Tcl_MutexLock(&asyncTestMutex);
 	for (prevPtr = NULL, asyncPtr = firstHandler; asyncPtr != NULL;
 		prevPtr = asyncPtr, asyncPtr = asyncPtr->nextPtr) {
 	    if (asyncPtr->id != id) {
@@ -832,6 +839,7 @@ TestasyncCmd(
 	    ckfree(asyncPtr);
 	    break;
 	}
+        Tcl_MutexUnlock(&asyncTestMutex);
     } else if (strcmp(argv[1], "mark") == 0) {
 	if (argc != 5) {
 	    goto wrongNumArgs;
@@ -862,7 +870,7 @@ TestasyncCmd(
 	    if (asyncPtr->id == id) {
 		Tcl_ThreadId threadID;
 		if (Tcl_CreateThread(&threadID, AsyncThreadProc,
-			(ClientData) asyncPtr, TCL_THREAD_STACK_DEFAULT,
+			(ClientData) id, TCL_THREAD_STACK_DEFAULT,
 			TCL_THREAD_NOFLAGS) != TCL_OK) {
 		    Tcl_SetResult(interp, "can't create thread", TCL_STATIC);
 		    return TCL_ERROR;
@@ -886,15 +894,29 @@ TestasyncCmd(
 
 static int
 AsyncHandlerProc(
-    ClientData clientData,	/* Pointer to TestAsyncHandler structure. */
+    ClientData clientData,	/* If of TestAsyncHandler structure. 
+                                 * in global list. */
     Tcl_Interp *interp,		/* Interpreter in which command was
 				 * executed, or NULL. */
     int code)			/* Current return code from command. */
 {
-    TestAsyncHandler *asyncPtr = (TestAsyncHandler *) clientData;
+    TestAsyncHandler *asyncPtr;
+    int id = (int) clientData;
     const char *listArgv[4], *cmd;
     char string[TCL_INTEGER_SPACE];
 
+    Tcl_MutexLock(&asyncTestMutex);
+    for (asyncPtr = firstHandler; asyncPtr != NULL;
+         asyncPtr = asyncPtr->nextPtr) {
+        if (asyncPtr->id == id) break;
+    }
+    Tcl_MutexUnlock(&asyncTestMutex);
+
+    if (!asyncPtr) {
+        /* Woops - this one was deleted between the AsyncMark and now */
+        return TCL_OK;
+    }
+
     TclFormatInt(string, code);
     listArgv[0] = asyncPtr->command;
     listArgv[1] = Tcl_GetString(Tcl_GetObjResult(interp));
@@ -932,12 +954,22 @@ AsyncHandlerProc(
 #ifdef TCL_THREADS
 static Tcl_ThreadCreateType
 AsyncThreadProc(
-    ClientData clientData)	/* Parameter is a pointer to a
+    ClientData clientData)	/* Parameter is the id of a
 				 * TestAsyncHandler, defined above. */
 {
-    TestAsyncHandler *asyncPtr = clientData;
+    TestAsyncHandler *asyncPtr;
+    int id = (int) clientData;
+
     Tcl_Sleep(1);
-    Tcl_AsyncMark(asyncPtr->handler);
+    Tcl_MutexLock(&asyncTestMutex);
+    for (asyncPtr = firstHandler; asyncPtr != NULL;
+         asyncPtr = asyncPtr->nextPtr) {
+        if (asyncPtr->id == id) {
+            Tcl_AsyncMark(asyncPtr->handler);
+            break;
+        }
+    }
+    Tcl_MutexUnlock(&asyncTestMutex);
     Tcl_ExitThread(TCL_OK);
     TCL_THREAD_CREATE_RETURN;
 }
@@ -7054,5 +7086,7 @@ TestconcatobjCmd(
  * mode: c
  * c-basic-offset: 4
  * fill-column: 78
+ * tab-width: 8
+ * indent-tabs-mode: nil
  * End:
  */
-- 
cgit v0.12


From a6827503fbf6b31c4d417b8842f67144cd792778 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Fri, 19 Aug 2011 14:23:19 +0000
Subject: [Bug 1774689] async-4.3 sometimes fails.

---
 ChangeLog        | 1 +
 tests/async.test | 2 +-
 2 files changed, 2 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index d8cf76e..c998c27 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,7 @@
 2011-08-19  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	* generic/tclTest.c: [Bug 2981154] async-4.3 segfault.
+	* tests/async.test:  [Bug 1774689] async-4.3 sometimes fails.
 
 2011-08-18  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
diff --git a/tests/async.test b/tests/async.test
index db21333..7834ed5 100644
--- a/tests/async.test
+++ b/tests/async.test
@@ -196,7 +196,7 @@ test async-4.3 {async interrupting loop-less bytecode sequence} -constraints {
 	set aresult {Async event not delivered}
 	testasync marklater $handle
 	set i 0
-    } [string repeat {;incr i;} 1500000] {
+    } "[string repeat {;incr i;} 1500000]after 10;" {
 	return $aresult
     }]] $hm
 } -result {test pattern} -cleanup {
-- 
cgit v0.12


From c7308459febcf0a9d4fd00a1522a33b0fe6fa74b Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 19 Aug 2011 16:05:46 +0000
Subject: Preserve the chanPtr during FlushChannel so that channel drivers
 don't yank it away before we're done with it.

---
 ChangeLog       |  5 +++++
 generic/tclIO.c | 15 +++++++++++----
 2 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index c998c27..8cbc045 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-19  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclIO.c: Preserve the chanPtr during FlushChannel so that
+	channel drivers don't yank it away before we're done with it.
+
 2011-08-19  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	* generic/tclTest.c: [Bug 2981154] async-4.3 segfault.
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 95afd63..946b53a 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -2356,6 +2356,7 @@ FlushChannel(
      * of the queued output to the channel.
      */
 
+    Tcl_Preserve(chanPtr);
     while (1) {
 	/*
 	 * If the queue is empty and there is a ready current buffer, OR if
@@ -2385,7 +2386,8 @@ FlushChannel(
 	 */
 
 	if (!calledFromAsyncFlush && GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
-	    return 0;
+	    errorCode = 0;
+	    goto done;
 	}
 
 	/*
@@ -2532,7 +2534,7 @@ FlushChannel(
 
     if (GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
 	if (wroteSome) {
-	    return errorCode;
+	    goto done;
 	} else if (statePtr->outQueueHead == NULL) {
 	    ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
 	    ChanWatch(chanPtr, statePtr->interestMask);
@@ -2549,7 +2551,8 @@ FlushChannel(
 	    (statePtr->outQueueHead == NULL) &&
 	    ((statePtr->curOutPtr == NULL) ||
 	    IsBufferEmpty(statePtr->curOutPtr))) {
-	return CloseChannel(interp, chanPtr, errorCode);
+	errorCode = CloseChannel(interp, chanPtr, errorCode);
+	goto done;
     }
 
     /*
@@ -2562,8 +2565,12 @@ FlushChannel(
 	    (statePtr->outQueueHead == NULL) &&
 	    ((statePtr->curOutPtr == NULL) ||
 	    IsBufferEmpty(statePtr->curOutPtr))) {
-	return CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE);
+	errorCode = CloseChannelPart(interp, chanPtr, errorCode, TCL_CLOSE_WRITE);
+	goto done;
     }
+
+  done:
+    Tcl_Release(chanPtr);
     return errorCode;
 }
 
-- 
cgit v0.12


From b4307ec076f504b43a12901bb34c646ea5267391 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 19 Aug 2011 19:07:17 +0000
Subject: 3394654, 3393276 Revise FlushChannel() to account for the possibility
 that the ChanWrite() call might recycle the buffer out from under us.

---
 ChangeLog       | 4 ++++
 generic/tclIO.c | 4 +++-
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 8cbc045..db4bf84 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2011-08-19  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclIO.c: [Bugs 3394654, 3393276] Revise FlushChannel() to
+	account for the possibility that the ChanWrite() call might recycle
+	the buffer out from under us.
+
 	* generic/tclIO.c: Preserve the chanPtr during FlushChannel so that
 	channel drivers don't yank it away before we're done with it.
 
diff --git a/generic/tclIO.c b/generic/tclIO.c
index 946b53a..ae1b89a 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -2510,7 +2510,9 @@ FlushChannel(
 	    wroteSome = 1;
 	}
 
-	bufPtr->nextRemoved += written;
+	if (!IsBufferEmpty(bufPtr)) {
+	    bufPtr->nextRemoved += written;
+	}
 
 	/*
 	 * If this buffer is now empty, recycle it.
-- 
cgit v0.12


From 6b86c2f514ad7c263691443055ad1d0a94a9f4f9 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 19 Aug 2011 20:27:48 +0000
Subject: 3393279, 3393280 ReflectClose(.) is missing Tcl_EventuallyFree()
 calls at some of its exits.

---
 ChangeLog             | 3 +++
 generic/tclIORTrans.c | 2 ++
 2 files changed, 5 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index db4bf84..5e7821a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
 2011-08-19  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclIORTrans.c: [Bugs 3393279, 3393280] ReflectClose(.) is
+	missing Tcl_EventuallyFree() calls at some of its exits.
+
 	* generic/tclIO.c: [Bugs 3394654, 3393276] Revise FlushChannel() to
 	account for the possibility that the ChanWrite() call might recycle
 	the buffer out from under us.
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 272306b..4806690 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -940,6 +940,7 @@ ReflectClose(
 	int errorCode;
 
 	if (!TransformDrain(rtPtr, &errorCode)) {
+	    Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
 	    return errorCode;
 	}
     }
@@ -948,6 +949,7 @@ ReflectClose(
 	int errorCode;
 
 	if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
+	    Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
 	    return errorCode;
 	}
     }
-- 
cgit v0.12


From b001a09fa9bea8a30e18638849438a54fc58c5f2 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 23 Aug 2011 07:08:34 +0000
Subject: [FRQ 3396731] inline string reverse

---
 ChangeLog              |   4 ++
 generic/tclStringObj.c | 160 ++++++++++++++++++++++++-------------------------
 2 files changed, 84 insertions(+), 80 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5e7821a..36cf7f1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-08-23  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclStringObj.c: [FRQ 3396731] inline string reverse
+
 2011-08-19  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclIORTrans.c: [Bugs 3393279, 3393280] ReflectClose(.) is
diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index ab62359..993a694 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2657,96 +2657,96 @@ Tcl_Obj *
 TclStringObjReverse(
     Tcl_Obj *objPtr)
 {
-    String *stringPtr;
-    char *src = NULL, *dest = NULL;
-    Tcl_UniChar *usrc = NULL, *udest = NULL;
-    Tcl_Obj *resultPtr = NULL;
+    char *src, *dest;
+    Tcl_Obj *resultPtr = objPtr;
+    char c;
 
-    SetStringFromAny(NULL, objPtr);
-    stringPtr = GET_STRING(objPtr);
+    src = TclGetString(objPtr);
+    if (Tcl_IsShared(objPtr)) {
+	resultPtr = Tcl_NewObj();
+	Tcl_SetObjLength(resultPtr, objPtr->length);
+	dest = TclGetString(resultPtr);
+	memcpy(dest, src, objPtr->length);
+    } else {
+	TclFreeIntRep(objPtr);
+	dest = src;
+    }
 
-    if (stringPtr->hasUnicode == 0) {
-	if (stringPtr->numChars == -1) {
-	    TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
-	}
-	if (stringPtr->numChars <= 1) {
-	    return objPtr;
-	}
-	if (stringPtr->numChars == objPtr->length) {
-	    /*
-	     * All one-byte chars. Reverse in objPtr->bytes.
-	     */
+    src = dest + objPtr->length;
 
-	    if (Tcl_IsShared(objPtr)) {
-		resultPtr = Tcl_NewObj();
-		Tcl_SetObjLength(resultPtr, objPtr->length);
-		dest = TclGetString(resultPtr);
-		src = objPtr->bytes + objPtr->length - 1;
-		while (src >= objPtr->bytes) {
-		    *dest++ = *src--;
-		}
-		return resultPtr;
+    /* Pass 1: reverse individual bytes of UTF-8 representation. */
+    while (dest < src) {
+	Tcl_UniChar ch = 0;
+	switch (Tcl_UtfToUniChar(dest, &ch)) {
+	case 1: {
+		++dest;
+		break;
 	    }
-
-	    /*
-	     * Unshared. Reverse objPtr->bytes in place.
-	     */
-
-	    dest = objPtr->bytes;
-	    src = dest + objPtr->length - 1;
-	    while (dest < src) {
-		char tmp = *src;
-
-		*src-- = *dest;
-		*dest++ = tmp;
+	case 2: {
+		c = dest[0];
+		dest[0] = dest[1];
+		dest[1] = c;
+		dest += 2;
+		break;
+	    }
+	case 3: {
+		c = dest[0];
+		dest[0] = dest[2];
+		dest[2] = c;
+		dest += 3;
+		break;
+	    }
+#if TCL_UTF_MAX > 4
+	case 5: {
+		c = dest[0];
+		dest[0] = dest[4];
+		dest[4] = c;
+		c = dest[1];
+		dest[1] = dest[3];
+		dest[3] = c;
+		dest += 5;
+		break;
+	    }
+#endif
+#if TCL_UTF_MAX > 5
+	case 6: {
+		c = dest[0];
+		dest[0] = dest[5];
+		dest[5] = c;
+		c = dest[1];
+		dest[1] = dest[4];
+		dest[4] = c;
+		c = dest[0];
+		dest[2] = dest[3];
+		dest[3] = c;
+		dest += 6;
+		break;
+	    }
+#endif
+	default: {
+#if TCL_UTF_MAX > 3
+		c = dest[0];
+		dest[0] = dest[3];
+		dest[3] = c;
+		c = dest[1];
+		dest[1] = dest[2];
+		dest[2] = c;
+		dest += 4;
+#endif
+		break;
 	    }
-	    return objPtr;
 	}
-	FillUnicodeRep(objPtr);
-	stringPtr = GET_STRING(objPtr);
-    }
-    if (stringPtr->numChars <= 1) {
-	return objPtr;
     }
 
-    /*
-     * Reverse the Unicode rep.
-     */
-
-    if (Tcl_IsShared(objPtr)) {
-	Tcl_UniChar ch = 0;
-
-	/*
-	 * Create a non-empty, pure unicode value, so we can coax
-	 * Tcl_SetObjLength into growing the unicode rep buffer.
-	 */
+	/* Pass 2: Reverse byte string. */
+	dest = TclGetString(resultPtr);
 
-	resultPtr = Tcl_NewUnicodeObj(&ch, 1);
-	Tcl_SetObjLength(resultPtr, stringPtr->numChars);
-	udest = Tcl_GetUnicode(resultPtr);
-	usrc = stringPtr->unicode + stringPtr->numChars - 1;
-	while (usrc >= stringPtr->unicode) {
-	    *udest++ = *usrc--;
+	while (dest < --src) {
+		c = *src;
+		*src = *dest;
+		*dest++ = c;
 	}
-	return resultPtr;
-    }
-
-    /*
-     * Unshared. Reverse objPtr->bytes in place.
-     */
-
-    udest = stringPtr->unicode;
-    usrc = udest + stringPtr->numChars - 1;
-    while (udest < usrc) {
-	Tcl_UniChar tmp = *usrc;
-
-	*usrc-- = *udest;
-	*udest++ = tmp;
-    }
-
-    TclInvalidateStringRep(objPtr);
-    stringPtr->allocated = 0;
-    return objPtr;
+    return resultPtr;
 }
 
 /*
-- 
cgit v0.12


From 7b6e23a91afe6e1644253d45327605fb2016677f Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 23 Aug 2011 16:31:11 +0000
Subject: 3396948 Leak of ReflectedChannelMap.

---
 ChangeLog            | 4 ++++
 generic/tclIORChan.c | 7 +++----
 2 files changed, 7 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 36cf7f1..f1c9053 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-08-19  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclIORChan.c:	[Bug 3396948] Leak of ReflectedChannelMap.
+
 2011-08-23  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclStringObj.c: [FRQ 3396731] inline string reverse
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 9ba42ef..846618c 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -2516,6 +2516,7 @@ DeleteReflectedChannelMap(
 
 	Tcl_ConditionNotify(&resultPtr->done);
     }
+    Tcl_MutexUnlock(&rcForwardMutex);
 
     /*
      * Get the map of all channels handled by the current thread. This is a
@@ -2541,8 +2542,6 @@ DeleteReflectedChannelMap(
 
 	Tcl_DeleteHashEntry(hPtr);
     }
-
-    Tcl_MutexUnlock(&rcForwardMutex);
 #endif
 }
 
@@ -2650,6 +2649,7 @@ DeleteThreadReflectedChannelMap(
 
 	Tcl_ConditionNotify(&resultPtr->done);
     }
+    Tcl_MutexUnlock(&rcForwardMutex);
 
     /*
      * Get the map of all channels handled by the current thread. This is a
@@ -2667,8 +2667,7 @@ DeleteThreadReflectedChannelMap(
 	rcPtr->interp = NULL;
 	Tcl_DeleteHashEntry(hPtr);
     }
-
-    Tcl_MutexUnlock(&rcForwardMutex);
+    ckfree(rcmPtr);
 }
 
 static void
-- 
cgit v0.12


From fe0b615064efb673ddf7e8d4f1d934aaabda0cd1 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 23 Aug 2011 16:58:55 +0000
Subject: typo

---
 ChangeLog | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index f1c9053..bc323fa 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,4 @@
-2011-08-19  Don Porter  <dgp@users.sourceforge.net>
+2011-08-23  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclIORChan.c:	[Bug 3396948] Leak of ReflectedChannelMap.
 
-- 
cgit v0.12


From 545f0cffe802c26b1779eb2f9ca6c4ade8c8c654 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 25 Aug 2011 12:00:14 +0000
Subject: [Enh 3396731] Follow-up: special case for Pure-unicode representation

---
 generic/tclStringObj.c | 25 +++++++++++++++++++++++++
 tests/string.test      |  3 +++
 2 files changed, 28 insertions(+)

diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 993a694..9cb973e 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2661,6 +2661,31 @@ TclStringObjReverse(
     Tcl_Obj *resultPtr = objPtr;
     char c;
 
+    /* Special case: Pure Unicode array */
+    if ((objPtr->typePtr == &tclStringType) && !objPtr->bytes) {
+	String *strPtr = GET_STRING(objPtr);
+	if (strPtr->hasUnicode) {
+		String *dstStrPtr = stringAlloc(strPtr->numChars);
+	    Tcl_UniChar *chars = strPtr->unicode;
+	    Tcl_UniChar *dstChars = dstStrPtr->unicode + strPtr->numChars;
+
+	    resultPtr = Tcl_NewObj();
+	    resultPtr->bytes = NULL;
+	    SET_STRING(resultPtr, dstStrPtr);
+	    resultPtr->typePtr = &tclStringType;
+	    dstStrPtr->maxChars = strPtr->numChars;
+	    dstStrPtr->unicode[strPtr->numChars] = 0;
+	    dstStrPtr->numChars = strPtr->numChars;
+	    dstStrPtr->hasUnicode = 1;
+	    dstStrPtr->allocated = 0;
+
+	    while (--dstChars >= dstStrPtr->unicode) {
+		*dstChars = *chars++;
+	    }
+	    return resultPtr;
+	}
+    }
+
     src = TclGetString(objPtr);
     if (Tcl_IsShared(objPtr)) {
 	resultPtr = Tcl_NewObj();
diff --git a/tests/string.test b/tests/string.test
index 1a62a66..92f544e 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -1623,6 +1623,9 @@ test string-24.12 {string reverse command - corner case} {
     set y \udead
     string is ascii [string reverse $x$y]
 } 0
+test string-24.13 {string reverse command - pure Unicode string} {
+    string reverse [string range \ubeef\udead\ubeef\udead\ubeef\udead 1 5]
+} \udead\ubeef\udead\ubeef\udead
 
 test string-25.1 {string is list} {
     string is list {a b c}
-- 
cgit v0.12


From f04c7d313f1392d0e474bbb3c40af1d69791f770 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 25 Aug 2011 16:26:37 +0000
Subject: 3396731 Another rewrite of TclStringObjReverse() to make it adopt the
 nijtmans approach for reversing the objPtr->bytes rep without losing
 performance.

---
 generic/tclStringObj.c | 176 +++++++++++++++++++++++++++++--------------------
 tests/string.test      |   8 +++
 2 files changed, 114 insertions(+), 70 deletions(-)

diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index ab62359..27480c5 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2653,99 +2653,135 @@ Tcl_ObjPrintf(
  *---------------------------------------------------------------------------
  */
 
+void
+ReverseBytes(
+    unsigned char *to,		/* Copy bytes into here... */
+    unsigned char *from,	/* ...from here... */
+    int count)		/* Until this many are copied, */
+				/* reversing as you go. */
+{
+    if (to == from) {
+	/* Reversing in place */
+	from += count - 1;
+	while (to < from) {
+	    unsigned char c = *from;
+	    *from-- = *to;
+	    *to++ = c;
+	}
+    }  else {
+	from += count - 1;
+	while (count--) {
+	    *to++ = *from--;
+	}
+    }
+}
+
+void
+ReverseUniChars(
+    Tcl_UniChar *to,		/* Copy Tcl_UniChars into here... */
+    Tcl_UniChar *from,		/* ...from here... */
+    unsigned int count)		/* Until this many are copied, */
+				/* reversing as you go. */
+{
+    if (to == from) {
+	/* Reversing in place */
+	from += count - 1;
+	while (to < from) {
+	    Tcl_UniChar c = *from;
+	    *from-- = *to;
+	    *to++ = c;
+	}
+    }  else {
+	from += count - 1;
+	while (count--) {
+	    *to++ = *from--;
+	}
+    }
+}
+
 Tcl_Obj *
 TclStringObjReverse(
     Tcl_Obj *objPtr)
 {
     String *stringPtr;
-    char *src = NULL, *dest = NULL;
-    Tcl_UniChar *usrc = NULL, *udest = NULL;
-    Tcl_Obj *resultPtr = NULL;
 
-    SetStringFromAny(NULL, objPtr);
-    stringPtr = GET_STRING(objPtr);
+    if (TclIsPureByteArray(objPtr)) {
+	int numBytes;
+	unsigned char *from = Tcl_GetByteArrayFromObj(objPtr, &numBytes);
 
-    if (stringPtr->hasUnicode == 0) {
-	if (stringPtr->numChars == -1) {
-	    TclNumUtfChars(stringPtr->numChars, objPtr->bytes, objPtr->length);
-	}
-	if (stringPtr->numChars <= 1) {
-	    return objPtr;
+	if (Tcl_IsShared(objPtr)) {
+	    objPtr = Tcl_NewByteArrayObj(NULL, numBytes);
 	}
-	if (stringPtr->numChars == objPtr->length) {
-	    /*
-	     * All one-byte chars. Reverse in objPtr->bytes.
-	     */
+	ReverseBytes(Tcl_GetByteArrayFromObj(objPtr, NULL), from, numBytes);
+	return objPtr;
+    }
 
-	    if (Tcl_IsShared(objPtr)) {
-		resultPtr = Tcl_NewObj();
-		Tcl_SetObjLength(resultPtr, objPtr->length);
-		dest = TclGetString(resultPtr);
-		src = objPtr->bytes + objPtr->length - 1;
-		while (src >= objPtr->bytes) {
-		    *dest++ = *src--;
-		}
-		return resultPtr;
-	    }
+    SetStringFromAny(NULL, objPtr);
+    stringPtr = GET_STRING(objPtr);
+
+    if (stringPtr->hasUnicode) {
+	Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
 
+	if (Tcl_IsShared(objPtr)) {
 	    /*
-	     * Unshared. Reverse objPtr->bytes in place.
+	     * Create a non-empty, pure unicode value, so we can coax
+	     * Tcl_SetObjLength into growing the unicode rep buffer.
 	     */
 
-	    dest = objPtr->bytes;
-	    src = dest + objPtr->length - 1;
-	    while (dest < src) {
-		char tmp = *src;
-
-		*src-- = *dest;
-		*dest++ = tmp;
-	    }
-	    return objPtr;
+	    Tcl_UniChar ch = 0;
+	    objPtr = Tcl_NewUnicodeObj(&ch, 1);
+	    Tcl_SetObjLength(objPtr, stringPtr->numChars);
 	}
-	FillUnicodeRep(objPtr);
-	stringPtr = GET_STRING(objPtr);
-    }
-    if (stringPtr->numChars <= 1) {
-	return objPtr;
+	ReverseUniChars(Tcl_GetUnicode(objPtr), from, stringPtr->numChars);
     }
 
-    /*
-     * Reverse the Unicode rep.
-     */
-
-    if (Tcl_IsShared(objPtr)) {
-	Tcl_UniChar ch = 0;
-
-	/*
-	 * Create a non-empty, pure unicode value, so we can coax
-	 * Tcl_SetObjLength into growing the unicode rep buffer.
-	 */
+    if (objPtr->bytes) {
+	int numChars = stringPtr->numChars;
+	int numBytes = objPtr->length;
+	char *to, *from = objPtr->bytes;
 
-	resultPtr = Tcl_NewUnicodeObj(&ch, 1);
-	Tcl_SetObjLength(resultPtr, stringPtr->numChars);
-	udest = Tcl_GetUnicode(resultPtr);
-	usrc = stringPtr->unicode + stringPtr->numChars - 1;
-	while (usrc >= stringPtr->unicode) {
-	    *udest++ = *usrc--;
+	if (Tcl_IsShared(objPtr)) {
+	    objPtr = Tcl_NewObj();
+	    Tcl_SetObjLength(objPtr, numBytes);
 	}
-	return resultPtr;
-    }
+	to = objPtr->bytes;
 
-    /*
-     * Unshared. Reverse objPtr->bytes in place.
-     */
+	if (numChars < numBytes) {
+	    /*
+	     * Either numChars == -1 and we don't know how many chars are
+	     * represented by objPtr->bytes and we need Pass 1 just in case,
+	     * or numChars >= 0 and we know we have fewer chars than bytes,
+	     * so we know there's a multibyte character needing Pass 1.
+	     *
+	     * Pass 1. Reverse the bytes of each multi-byte character.
+	     */
+	    int charCount = 0;
+	    int bytesLeft = numBytes;
 
-    udest = stringPtr->unicode;
-    usrc = udest + stringPtr->numChars - 1;
-    while (udest < usrc) {
-	Tcl_UniChar tmp = *usrc;
+	    while (bytesLeft) {
+		/*
+		 * NOTE: We know that the from buffer is NUL-terminated.
+		 * It's part of the contract for objPtr->bytes values.
+		 * Thus, we can skip calling Tcl_UtfCharComplete() here.
+		 */
+		Tcl_UniChar ch = 0;
+		int bytesInChar = Tcl_UtfToUniChar(from, &ch);
+
+		ReverseBytes((unsigned char *)to, (unsigned char *)from,
+			bytesInChar);
+		to += bytesInChar;
+		from += bytesInChar;
+		bytesLeft -= bytesInChar;
+		charCount++;
+	    }
 
-	*usrc-- = *udest;
-	*udest++ = tmp;
+	    from = to = objPtr->bytes;
+	    stringPtr->numChars = charCount;
+	}
+	/* Pass 2. Reverse all the bytes. */
+	ReverseBytes((unsigned char *)to, (unsigned char *)from, numBytes);
     }
 
-    TclInvalidateStringRep(objPtr);
-    stringPtr->allocated = 0;
     return objPtr;
 }
 
diff --git a/tests/string.test b/tests/string.test
index 1a62a66..e53504f 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -1623,6 +1623,14 @@ test string-24.12 {string reverse command - corner case} {
     set y \udead
     string is ascii [string reverse $x$y]
 } 0
+test string-24.13 {string reverse command - pure bytearray} {
+    binary scan [string reverse [binary format H* 010203]] H* x
+    set x
+} 030201
+test string-24.14 {string reverse command - pure bytearray} {
+    binary scan [tcl::string::reverse [binary format H* 010203]] H* x
+    set x
+} 030201
 
 test string-25.1 {string is list} {
     string is list {a b c}
-- 
cgit v0.12


From 65fc2758670c06dcb89d1bd829f990290c74e8c3 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Sat, 27 Aug 2011 02:28:47 +0000
Subject: Repaired the lost performance in the copy loop hotspots.  Now meets
 or beats the former trunk (and current trunk by magnitudes) in tclbench.

---
 generic/tclStringObj.c | 25 ++++++++++++-------------
 1 file changed, 12 insertions(+), 13 deletions(-)

diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index 27480c5..bccd28a 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2660,18 +2660,17 @@ ReverseBytes(
     int count)		/* Until this many are copied, */
 				/* reversing as you go. */
 {
+    unsigned char *src = from + count - 1;
     if (to == from) {
 	/* Reversing in place */
-	from += count - 1;
-	while (to < from) {
-	    unsigned char c = *from;
-	    *from-- = *to;
+	while (to < src) {
+	    unsigned char c = *src;
+	    *src-- = *to;
 	    *to++ = c;
 	}
     }  else {
-	from += count - 1;
-	while (count--) {
-	    *to++ = *from--;
+	while (src >= from) {
+	    *to++ = *src--;
 	}
     }
 }
@@ -2683,18 +2682,18 @@ ReverseUniChars(
     unsigned int count)		/* Until this many are copied, */
 				/* reversing as you go. */
 {
+    Tcl_UniChar *src = from + count - 1;
     if (to == from) {
 	/* Reversing in place */
 	from += count - 1;
-	while (to < from) {
-	    Tcl_UniChar c = *from;
-	    *from-- = *to;
+	while (to < src) {
+	    Tcl_UniChar c = *src;
+	    *src-- = *to;
 	    *to++ = c;
 	}
     }  else {
-	from += count - 1;
-	while (count--) {
-	    *to++ = *from--;
+	while (src >= from) {
+	    *to++ = *src--;
 	}
     }
 }
-- 
cgit v0.12


From 7fa60e4fb188f417e4b968ef37085cc9c1c171e2 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 29 Aug 2011 07:25:27 +0000
Subject: [3396731] inline string reverse: minor further improvements

---
 generic/tclStringObj.c | 54 ++++++++++++++++++++------------------------------
 1 file changed, 22 insertions(+), 32 deletions(-)

diff --git a/generic/tclStringObj.c b/generic/tclStringObj.c
index bccd28a..d721c47 100644
--- a/generic/tclStringObj.c
+++ b/generic/tclStringObj.c
@@ -2653,47 +2653,24 @@ Tcl_ObjPrintf(
  *---------------------------------------------------------------------------
  */
 
-void
+static void
 ReverseBytes(
     unsigned char *to,		/* Copy bytes into here... */
     unsigned char *from,	/* ...from here... */
     int count)		/* Until this many are copied, */
 				/* reversing as you go. */
 {
-    unsigned char *src = from + count - 1;
+    unsigned char *src = from + count;
     if (to == from) {
 	/* Reversing in place */
-	while (to < src) {
+	while (--src > to) {
 	    unsigned char c = *src;
-	    *src-- = *to;
-	    *to++ = c;
-	}
-    }  else {
-	while (src >= from) {
-	    *to++ = *src--;
-	}
-    }
-}
-
-void
-ReverseUniChars(
-    Tcl_UniChar *to,		/* Copy Tcl_UniChars into here... */
-    Tcl_UniChar *from,		/* ...from here... */
-    unsigned int count)		/* Until this many are copied, */
-				/* reversing as you go. */
-{
-    Tcl_UniChar *src = from + count - 1;
-    if (to == from) {
-	/* Reversing in place */
-	from += count - 1;
-	while (to < src) {
-	    Tcl_UniChar c = *src;
-	    *src-- = *to;
+	    *src = *to;
 	    *to++ = c;
 	}
     }  else {
-	while (src >= from) {
-	    *to++ = *src--;
+	while (--src >= from) {
+	    *to++ = *src;
 	}
     }
 }
@@ -2703,6 +2680,7 @@ TclStringObjReverse(
     Tcl_Obj *objPtr)
 {
     String *stringPtr;
+    Tcl_UniChar ch;
 
     if (TclIsPureByteArray(objPtr)) {
 	int numBytes;
@@ -2720,18 +2698,31 @@ TclStringObjReverse(
 
     if (stringPtr->hasUnicode) {
 	Tcl_UniChar *from = Tcl_GetUnicode(objPtr);
+	Tcl_UniChar *src = from + stringPtr->numChars;
 
 	if (Tcl_IsShared(objPtr)) {
+	    Tcl_UniChar *to;
+
 	    /*
 	     * Create a non-empty, pure unicode value, so we can coax
 	     * Tcl_SetObjLength into growing the unicode rep buffer.
 	     */
 
-	    Tcl_UniChar ch = 0;
+	    ch = 0;
 	    objPtr = Tcl_NewUnicodeObj(&ch, 1);
 	    Tcl_SetObjLength(objPtr, stringPtr->numChars);
+	    to = Tcl_GetUnicode(objPtr);
+	    while (--src >= from) {
+		*to++ = *src;
+	    }
+	} else {
+	    /* Reversing in place */
+	    while (--src > from) {
+		ch = *src;
+		*src = *from;
+		*from++ = ch;
+	    }
 	}
-	ReverseUniChars(Tcl_GetUnicode(objPtr), from, stringPtr->numChars);
     }
 
     if (objPtr->bytes) {
@@ -2763,7 +2754,6 @@ TclStringObjReverse(
 		 * It's part of the contract for objPtr->bytes values.
 		 * Thus, we can skip calling Tcl_UtfCharComplete() here.
 		 */
-		Tcl_UniChar ch = 0;
 		int bytesInChar = Tcl_UtfToUniChar(from, &ch);
 
 		ReverseBytes((unsigned char *)to, (unsigned char *)from,
-- 
cgit v0.12


From cb7ed495368dc8bb18338cc748f6e408abf13b1e Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 29 Aug 2011 10:43:14 +0000
Subject: Fix eval's faulty objProc, it was actually an nreProc [3399564|Bug
 3399564]. Thanks to Joe Mistachkin for detection and analysis.

---
 generic/tclBasic.c |  2 +-
 generic/tclCmdAH.c | 10 ++++++++++
 generic/tclInt.h   |  3 ++-
 3 files changed, 13 insertions(+), 2 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index f0f0c0f..9758449 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -215,7 +215,7 @@ static const CmdInfo builtInCmds[] = {
     {"continue",	Tcl_ContinueObjCmd,	TclCompileContinueCmd,	NULL,	1},
     {"coroutine",	NULL,			NULL,			TclNRCoroutineObjCmd,	1},
     {"error",		Tcl_ErrorObjCmd,	TclCompileErrorCmd,	NULL,	1},
-    {"eval",		Tcl_EvalObjCmd,		NULL,			NULL,	1},
+    {"eval",		Tcl_EvalObjCmd,		NULL,			TclNREvalObjCmd,	1},
     {"expr",		Tcl_ExprObjCmd,		TclCompileExprCmd,	TclNRExprObjCmd,	1},
     {"for",		Tcl_ForObjCmd,		TclCompileForCmd,	TclNRForObjCmd,	1},
     {"foreach",		Tcl_ForeachObjCmd,	TclCompileForeachCmd,	TclNRForeachCmd,	1},
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 765c9dc..fc9d39d 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -737,6 +737,16 @@ Tcl_EvalObjCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
+    return Tcl_NRCallObjProc(interp, TclNREvalObjCmd, dummy, objc, objv);    
+}
+
+int
+TclNREvalObjCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Argument objects. */
+{
     register Tcl_Obj *objPtr;
     Interp *iPtr = (Interp *) interp;
     CmdFrame *invoker = NULL;
diff --git a/generic/tclInt.h b/generic/tclInt.h
index d65f712..f30e83e 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2768,7 +2768,7 @@ MODULE_SCOPE char	tclEmptyString;
  */
 
 MODULE_SCOPE Tcl_ObjCmdProc TclNRApplyObjCmd;
-MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNREvalObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRCatchObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRExprObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRForObjCmd;
@@ -2778,6 +2778,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRSourceObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSubstObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRSwitchObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRTryObjCmd;
+MODULE_SCOPE Tcl_ObjCmdProc TclNRUplevelObjCmd;
 MODULE_SCOPE Tcl_ObjCmdProc TclNRWhileObjCmd;
 
 MODULE_SCOPE Tcl_NRPostProc TclNRForIterCallback;
-- 
cgit v0.12


From d65bb6e67d734ac2958cf3ff427488bb8cf04ab8 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 29 Aug 2011 14:16:07 +0000
Subject: Leak of ReflectedTransformMap.

---
 ChangeLog             | 4 ++++
 generic/tclIORTrans.c | 7 +++----
 2 files changed, 7 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 67572ce..23ee0bf 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2011-08-29  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclIORTrans.c: Leak of ReflectedTransformMap.
+
 2011-08-27  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclStringObj.c:  [RFE 3396731] Revise the [string reverse]
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 4806690..fa973c7 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -2191,6 +2191,7 @@ DeleteReflectedTransformMap(
 
 	Tcl_ConditionNotify(&resultPtr->done);
     }
+    Tcl_MutexUnlock(&rtForwardMutex);
 
     /*
      * Get the map of all channels handled by the current thread. This is a
@@ -2215,8 +2216,6 @@ DeleteReflectedTransformMap(
 
 	Tcl_DeleteHashEntry(hPtr);
     }
-
-    Tcl_MutexUnlock(&rtForwardMutex);
 #endif
 }
 
@@ -2323,6 +2322,7 @@ DeleteThreadReflectedTransformMap(
 
 	Tcl_ConditionNotify(&resultPtr->done);
     }
+    Tcl_MutexUnlock(&rtForwardMutex);
 
     /*
      * Get the map of all channels handled by the current thread. This is a
@@ -2339,8 +2339,7 @@ DeleteThreadReflectedTransformMap(
 	rtPtr->interp = NULL;
 	Tcl_DeleteHashEntry(hPtr);
     }
-
-    Tcl_MutexUnlock(&rtForwardMutex);
+    ckfree(rtmPtr);
 }
 
 static void
-- 
cgit v0.12


From 962035b9e88c81c37b472d73da55dbba9534756a Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Mon, 29 Aug 2011 23:24:36 +0000
Subject: Put back the check for server sockets (bug #3394732).

---
 ChangeLog          | 5 +++++
 unix/tclUnixSock.c | 9 +++++++++
 2 files changed, 14 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 23ee0bf..05f864a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-08-30  Reinhard Max  <max@suse.de>
+
+	* unix/tclUnixSock.c (TcpWatchProc): Put back the check for server
+	sockets (bug #3394732).
+
 2011-08-29  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclIORTrans.c: Leak of ReflectedTransformMap.
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index f302b70..35c00c5 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -816,6 +816,15 @@ TcpWatchProc(
 				 * TCL_EXCEPTION. */
 {
     TcpState *statePtr = (TcpState *) instanceData;
+
+    if (statePtr->acceptProc != NULL) {
+        /*
+         * Make sure we don't mess with server sockets since they will never
+         * be readable or writable at the Tcl level. This keeps Tcl scripts
+         * from interfering with the -accept behavior (bug #3394732).
+         */
+    	return;
+    }
      
     if (statePtr->flags & TCP_ASYNC_CONNECT) {
         /* Async sockets use a FileHandler internally while connecting, so we
-- 
cgit v0.12


From c14c0cb9b1f94390b3e110a359a5506c892cda44 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 30 Aug 2011 06:33:29 +0000
Subject: Tcl_MainEx() (like Tk_MainEx())

---
 generic/tcl.h      | 6 ++++--
 generic/tclDecls.h | 2 --
 generic/tclMain.c  | 3 ++-
 3 files changed, 6 insertions(+), 5 deletions(-)

diff --git a/generic/tcl.h b/generic/tcl.h
index 54bfedc..177126a 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -2373,8 +2373,10 @@ const char *		TclTomMathInitializeStubs(Tcl_Interp *interp,
  * Tcl_GetMemoryInfo is needed for AOLserver. [Bug 1868171]
  */
 
-EXTERN void		Tcl_Main(int argc, char **argv,
-			    Tcl_AppInitProc *appInitProc);
+#define Tcl_Main(argc, argv, proc) Tcl_MainEx(argc, argv, proc, \
+	    (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
+EXTERN void		Tcl_MainEx(int argc, char **argv,
+			    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
 EXTERN const char *	Tcl_PkgInitStubsCheck(Tcl_Interp *interp,
 			    const char *version, int exact);
 #if defined(TCL_THREADS) && defined(USE_THREAD_ALLOC)
diff --git a/generic/tclDecls.h b/generic/tclDecls.h
index 1df7e14..1f7dfe6 100644
--- a/generic/tclDecls.h
+++ b/generic/tclDecls.h
@@ -3791,8 +3791,6 @@ extern const TclStubs *tclStubsPtr;
 #   define Tcl_MainEx Tcl_MainExW
     EXTERN void Tcl_MainExW(int argc, wchar_t **argv,
 	    Tcl_AppInitProc *appInitProc, Tcl_Interp *interp);
-#   define Tcl_Main(argc, argv, proc) Tcl_MainExW(argc, argv, proc, \
-	    (Tcl_FindExecutable(argv[0]), (Tcl_CreateInterp)()))
 #endif
 
 #undef TCL_STORAGE_CLASS
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 114d2c3..58ad377 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -621,7 +621,8 @@ Tcl_MainEx(
 }
 
 #ifndef UNICODE
-void
+#undef Tcl_Main
+extern DLLEXPORT void
 Tcl_Main(
     int argc,			/* Number of arguments. */
     TCHAR **argv,		/* Array of argument strings. */
-- 
cgit v0.12


From 9d11f87f176b6d4318a556e83316e338759a426a Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Thu, 1 Sep 2011 21:03:12 +0000
Subject: [Bug 3401422] Cache script-level changes to the nonblocking flag of
 an async client socket in progress, and commit them on completion.

---
 ChangeLog          | 6 ++++++
 unix/tclUnixSock.c | 8 +++++++-
 2 files changed, 13 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 06ece36..a5bac84 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-09-01  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* unix/tclUnixSock.c: [Bug 3401422] Cache script-level changes to
+	the nonblocking flag of an async client socket in progress, and
+	commit them on completion.
+
 2011-09-01  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclStrToD.c:	[Bug 3402540] Corrections to TclParseNumber()
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 35c00c5..7b5c9e0 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -68,6 +68,7 @@ struct TcpState {
     int filehandlers;	/* Caches FileHandlers that get set up while
                          * an async socket is not yet connected   */
     int status;         /* Cache status of async socket */
+    int cachedBlocking; /* Cache blocking mode of async socket */
 };
 
 /*
@@ -348,6 +349,10 @@ TcpBlockModeProc(
     } else {
 	SET_BITS(statePtr->flags, TCP_ASYNC_SOCKET);
     }
+    if (statePtr->flags & TCP_ASYNC_CONNECT) {
+        statePtr->cachedBlocking = mode;
+        return 0;
+    }
     if (TclUnixSetBlockingMode(statePtr->fds.fd, mode) < 0) {
 	return errno;
     }
@@ -1038,7 +1043,7 @@ out:
          */
         CLEAR_BITS(state->flags, TCP_ASYNC_CONNECT);
         TcpWatchProc(state, state->filehandlers);
-        TclUnixSetBlockingMode(state->fds.fd, TCL_MODE_BLOCKING);
+        TclUnixSetBlockingMode(state->fds.fd, state->cachedBlocking);
 
         /*
          * We need to forward the writable event that brought us here, bcasue
@@ -1122,6 +1127,7 @@ Tcl_OpenTcpClient(
     state = ckalloc(sizeof(TcpState));
     memset(state, 0, sizeof(TcpState));
     state->flags = async ? TCP_ASYNC_CONNECT : 0;
+    state->cachedBlocking = TCL_MODE_BLOCKING;
     state->addrlist = addrlist;
     state->myaddrlist = myaddrlist;
     state->fds.fd = -1;
-- 
cgit v0.12


From 68317f28895f8fcb2972916e1190498550d662af Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 2 Sep 2011 16:33:50 +0000
Subject: Convert [testthread] use to Thread package use in http.test.
 Eliminates memory leak seen in `make valgrind`.

---
 ChangeLog       |  5 +++++
 tests/http.test | 19 ++++++++-----------
 2 files changed, 13 insertions(+), 11 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index a5bac84..9b78a78 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-09-02  Don Porter  <dgp@users.sourceforge.net>
+
+	* tests/http.test:	Convert [testthread] use to Thread package use.
+	Eliminates memory leak seen in `make valgrind`.
+
 2011-09-01  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	* unix/tclUnixSock.c: [Bug 3401422] Cache script-level changes to
diff --git a/tests/http.test b/tests/http.test
index 1f4d8b4..e6e7649 100644
--- a/tests/http.test
+++ b/tests/http.test
@@ -51,14 +51,13 @@ if {![file exists $httpdFile]} {
     set removeHttpd 1
 }
 
-if {[info commands testthread] == "testthread" && [file exists $httpdFile]} {
-    set httpthread [testthread create "
-	source [list $httpdFile]
-	testthread wait
-    "]
-    testthread send $httpthread [list set port $port]
-    testthread send $httpthread [list set bindata $bindata]
-    testthread send $httpthread {httpd_init $port}
+catch {package require Thread 2.6}
+if {[catch {package present Thread}] == 0 && [file exists $httpdFile]} {
+    set httpthread [thread::create -preserved]
+    thread::send $httpthread [list source $httpdFile]
+    thread::send $httpthread [list set port $port]
+    thread::send $httpthread [list set bindata $bindata]
+    thread::send $httpthread {httpd_init $port}
     puts "Running httpd in thread $httpthread"
 } else {
     if {![file exists $httpdFile]} {
@@ -590,9 +589,7 @@ catch {unset badurl}
 catch {unset port}
 catch {unset data}
 if {[info exists httpthread]} {
-    testthread send -async $httpthread {
-	testthread exit
-    }
+    thread::release $httpthread
 } else {
     close $listen
 }
-- 
cgit v0.12


From 2ef078fcde8663a017bc1af6eb823f97ea9dda6a Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 9 Sep 2011 14:40:04 +0000
Subject: 3389733 Convert [testthread] use to Thread package use in
 chan-io-70.1. Eliminates a memory leak in `make valgrind TESTFLAGS="-file
 chanio.test"`.

---
 ChangeLog         |  6 ++++++
 tests/chanio.test | 28 ++++++++--------------------
 2 files changed, 14 insertions(+), 20 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5fd2d9d..e83458b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-09-09  Don Porter  <dgp@users.sourceforge.net>
+
+	* tests/chanio.test:	[Bug 3389733] Convert [testthread] use to
+	Thread package use in chan-io-70.1.  Eliminates a memory leak in
+	`make valgrind TESTFLAGS="-file chanio.test"`.
+
 2011-09-07  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclCompExpr.c: [Bug 3401704] Allow function names like
diff --git a/tests/chanio.test b/tests/chanio.test
index 5569385..6a8524c 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -37,7 +37,7 @@ namespace eval ::tcl::test::io {
     testConstraint testfevent       [llength [info commands testfevent]]
     testConstraint testchannelevent [llength [info commands testchannelevent]]
     testConstraint testmainthread   [llength [info commands testmainthread]]
-    testConstraint testthread       [llength [info commands testthread]]
+    testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 
     # You need a *very* special environment to do some tests.  In particular,
     # many file systems do not support large-files...
@@ -7413,7 +7413,6 @@ test chan-io-59.1 {Thread reference of channels} {testmainthread testchannel} {
     # More complicated tests (like that the reference changes as a channel is
     # moved from thread to thread) can be done only in the extension which
     # fully implements the moving of channels between threads, i.e. 'Threads'.
-    # Or we have to extend [testthread] as well.
     set f [open $path(longfile) r]
     set result [testchannel mthread $f]
     chan close $f
@@ -7494,37 +7493,26 @@ test chan-io-70.0 {Cutting & Splicing channels} -setup {
     chan close $c
     removeFile cutsplice
 } -result {0 1 0}
-# Duplicate of code in "thread.test". Find a better way of doing this without
-# duplication. Maybe placement into a proc which transforms to nop after the
-# first call, and placement of its defintion in a central location.
-if {[testConstraint testthread]} {
-    testthread errorproc ThreadError
-    proc ThreadError {id info} {
-	global threadError
-	set threadError $info
-    }
-    proc ThreadNullError {id info} {
-	# ignore
-    }
-}
+
 test chan-io-70.1 {Transfer channel} -setup {
     set f [makeFile {... dummy ...} cutsplice]
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     set c [open $f r]
     lappend res [catch {chan seek $c 0 start}]
     testchannel cut $c
     lappend res [catch {chan seek $c 0 start}]
-    set tid [testthread create]
-    testthread send $tid [list set c $c]
-    lappend res [testthread send $tid {
+    set tid [thread::create -preserved]
+    thread::send $tid [list set c $c]
+    thread::send $tid {load {} Tcltest}
+    lappend res [thread::send $tid {
 	testchannel splice $c
 	set res [catch {chan seek $c 0 start}]
 	chan close $c
 	set res
     }]
 } -cleanup {
-    tcltest::threadReap
+    thread::release
     removeFile cutsplice
 } -result {0 1 0}
 
-- 
cgit v0.12


From 4c4d1e2d836ca5b3c4f6c0f0b3df7514667a372e Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 9 Sep 2011 15:08:19 +0000
Subject: Release the right thread!  D'oh!

---
 tests/chanio.test | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/chanio.test b/tests/chanio.test
index 6a8524c..fbc9854 100644
--- a/tests/chanio.test
+++ b/tests/chanio.test
@@ -7512,7 +7512,7 @@ test chan-io-70.1 {Transfer channel} -setup {
 	set res
     }]
 } -cleanup {
-    thread::release
+    thread::release $tid
     removeFile cutsplice
 } -result {0 1 0}
 
-- 
cgit v0.12


From eb6fb56fa20feb22f2ee6c09b058ece6fcb981cc Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 9 Sep 2011 15:37:38 +0000
Subject: 3389733 Convert [testthread] use to Thread package use in *io-70.1.
 Eliminates a memory leak in `make valgrind`.

---
 ChangeLog     |  4 ++--
 tests/io.test | 33 ++++++++-------------------------
 2 files changed, 10 insertions(+), 27 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index e83458b..69acbec 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,8 @@
 2011-09-09  Don Porter  <dgp@users.sourceforge.net>
 
 	* tests/chanio.test:	[Bug 3389733] Convert [testthread] use to
-	Thread package use in chan-io-70.1.  Eliminates a memory leak in
-	`make valgrind TESTFLAGS="-file chanio.test"`.
+	* tests/io.test:	Thread package use in *io-70.1.  Eliminates a
+	memory leak in `make valgrind`.
 
 2011-09-07  Don Porter  <dgp@users.sourceforge.net>
 
diff --git a/tests/io.test b/tests/io.test
index e28948f..8a7cc51 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -37,7 +37,7 @@ testConstraint fcopy            [llength [info commands fcopy]]
 testConstraint testfevent       [llength [info commands testfevent]]
 testConstraint testchannelevent [llength [info commands testchannelevent]]
 testConstraint testmainthread   [llength [info commands testmainthread]]
-testConstraint testthread       [llength [info commands testthread]]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 
 # You need a *very* special environment to do some tests.  In
 # particular, many file systems do not support large-files...
@@ -7435,7 +7435,7 @@ test io-59.1 {Thread reference of channels} {testmainthread testchannel} {
     # More complicated tests (like that the reference changes as a
     # channel is moved from thread to thread) can be done only in the
     # extension which fully implements the moving of channels between
-    # threads, i.e. 'Threads'. Or we have to extend [testthread] as well.
+    # threads, i.e. 'Threads'.
 
     set f [open $path(longfile) r]
     set result [testchannel mthread $f]
@@ -7527,25 +7527,7 @@ test io-70.0 {Cutting & Splicing channels} {testchannel} {
 } {0 1 0}
 
 
-# Duplicate of code in "thread.test". Find a better way of doing this
-# without duplication. Maybe placement into a proc which transforms to
-# nop after the first call, and placement of its defintion in a
-# central location.
-
-if {[testConstraint testthread]} {
-    testthread errorproc ThreadError
-
-    proc ThreadError {id info} {
-	global threadError
-	set threadError $info
-    }
-
-    proc ThreadNullError {id info} {
-	# ignore
-    }
-}
-
-test io-70.1 {Transfer channel} {testchannel testthread} {
+test io-70.1 {Transfer channel} {testchannel thread} {
     set f [makeFile {... dummy ...} cutsplice]
     set c [open $f r]
 
@@ -7554,16 +7536,17 @@ test io-70.1 {Transfer channel} {testchannel testthread} {
     testchannel cut $c
     lappend res [catch {seek $c 0 start}]
 
-    set tid [testthread create]
-    testthread send $tid [list set c $c]
-    lappend res [testthread send $tid {
+    set tid [thread::create -preserved]
+    thread::send $tid [list set c $c]
+    thread::send $tid {load {} Tcltest}
+    lappend res [thread::send $tid {
 	testchannel splice $c
 	set res [catch {seek $c 0 start}]
 	close $c
 	set res
     }]
 
-    tcltest::threadReap
+    thread::release $tid
     removeFile cutsplice
 
     set res
-- 
cgit v0.12


From ef7088a8bad44f5db8e7985a9bf9072e63f7506e Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 9 Sep 2011 19:26:59 +0000
Subject: Convert uses of the [testthread] command to uses of the Thread
 package. This takes as many leaks as possible out of the testing harness, so
 the leaks remaining are the fault of the tested code. Committed to a branch
 because the conversion creates new test failures that need review.

---
 tests/ioCmd.test | 292 +++++++++++++++++++++++++++----------------------------
 1 file changed, 144 insertions(+), 148 deletions(-)

diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 6536072..43ac712 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -21,7 +21,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 # Custom constraints used in this file
 testConstraint fcopy		[llength [info commands fcopy]]
 testConstraint testchannel	[llength [info commands testchannel]]
-testConstraint testthread	[llength [info commands testthread]]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 
 #----------------------------------------------------------------------
 
@@ -1991,7 +1991,6 @@ test iocmd-32.1 {origin interpreter of moved channel destroyed during access} -m
     # response.
 
     interp eval $idb [list set chan $chan]
-    interp eval $idb [list set mid $tcltest::mainThread]
     set res [interp eval $idb {
 	# wait a bit, give the main thread the time to start its event
 	# loop to wait for the response from B
@@ -2028,23 +2027,6 @@ test iocmd-32.2 {delete interp of reflected chan} {
 ## forwarding, and gaps due to tests not applicable to forwarding are
 ## left to keep this asociation.
 
-# Duplicate of code in "thread.test". Find a better way of doing this
-# without duplication. Maybe placement into a proc which transforms to
-# nop after the first call, and placement of its defintion in a
-# central location.
-
-if {[testConstraint testthread]} {
-    testthread errorproc ThreadError
-
-    proc ThreadError {id info} {
-	global threadError
-	set threadError $info
-    }
-    proc ThreadNullError {id info} {
-	# ignore
-    }
-}
-
 # ### ### ### ######### ######### #########
 ## Helper command. Runs a script in a separate thread and returns the
 ## result. A channel is transfered into the thread as well, and list of
@@ -2053,7 +2035,8 @@ if {[testConstraint testthread]} {
 proc inthread {chan script args} {
     # Test thread.
 
-    set tid [testthread create]
+    set tid [thread::create -preserved]
+    thread::send $tid {load {} Tcltest}
 
     # Init thread configuration.
     # - Listed variables
@@ -2062,22 +2045,23 @@ proc inthread {chan script args} {
 
     foreach v $args {
 	upvar 1 $v x
-	testthread send $tid [list set $v $x]
+	thread::send $tid [list set $v $x]
+
     }
-    testthread send $tid [list set mid $tcltest::mainThread]
-    testthread send $tid {
+    thread::send $tid [list set mid [thread::id]]
+    thread::send $tid {
 	proc note {item} {global notes; lappend notes $item}
 	proc notes {} {global notes; return $notes}
 	proc noteOpts opts {global notes; lappend notes [dict merge {
 	    -code !?! -level !?! -errorcode !?! -errorline !?! -errorinfo !?!
 	} $opts]}
     }
-    testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*)
+    thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*)
 
     # Transfer channel (cut/splice aka detach/attach)
 
     testchannel cut $chan
-    testthread send $tid [list testchannel splice $chan]
+    thread::send $tid [list testchannel splice $chan]
 
     # Run test script, also run local event loop!
     # The local event loop waits for the result to come back.
@@ -2085,15 +2069,15 @@ proc inthread {chan script args} {
     # operations.
 
     set ::tres ""
-    testthread send -async $tid {
+    thread::send -async $tid {
 	after 500
 	catch {s} res; # This runs the script, 's' was defined at (*)
-	testthread send -async $mid [list set ::tres $res]
+	thread::send -async $mid [list set ::tres $res]
     }
     vwait ::tres
     # Remove test thread, and return the captured result.
 
-    tcltest::threadReap
+    thread::release $tid
     return $::tres
 }
 
@@ -2114,7 +2098,7 @@ test iocmd.tf-22.2 {chan finalize, for close} -match glob -body {
     note [info command foo]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo}
+} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} {} foo}
 test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -body {
     set res {}
     proc foo {args} {track; oninit; return -code error 5}
@@ -2127,7 +2111,7 @@ test iocmd.tf-22.3 {chan finalize, for close, error, close error} -match glob -b
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}}
+} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 5 {}}
 test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -body {
     set res {}
     proc foo {args} {track; oninit; error FOO}
@@ -2138,7 +2122,7 @@ test iocmd.tf-22.4 {chan finalize, for close, error, close errror} -match glob -
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO}
+} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 1 FOO}
 test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -body {
     set res {}
     proc foo {args} {track; oninit; return SOMETHING}
@@ -2149,7 +2133,7 @@ test iocmd.tf-22.5 {chan finalize, for close, arbitrary result} -match glob -bod
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}}
+} -constraints {testchannel thread} -result {{initialize rc* {read write}} rc* {finalize rc*} 0 {}}
 test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -body {
     set res {}
     proc foo {args} {track; oninit; return -code 3}
@@ -2161,7 +2145,7 @@ test iocmd.tf-22.6 {chan finalize, for close, break, close error} -match glob -b
     rename foo {}
     set res
 } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob -body {
     set res {}
     proc foo {args} {track; oninit; return -code 4}
@@ -2173,7 +2157,7 @@ test iocmd.tf-22.7 {chan finalize, for close, continue, close error} -match glob
     rename foo {}
     set res
 } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match glob -body {
     set res {}
     proc foo {args} {track; oninit; return -code 777 BANG}
@@ -2185,7 +2169,7 @@ test iocmd.tf-22.8 {chan finalize, for close, custom code, close error} -match g
     rename foo {}
     set res
 } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match glob -body {
     set res {}
     proc foo {args} {track; oninit; return -level 5 -code 777 BANG}
@@ -2197,7 +2181,7 @@ test iocmd.tf-22.9 {chan finalize, for close, ignore level, close error} -match
     rename foo {}
     set res
 } -result {{initialize rc* {read write}} rc* {finalize rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "finalize"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 
 # --- === *** ###########################
 # method read
@@ -2216,7 +2200,7 @@ test iocmd.tf-23.1 {chan read, regular data return} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
+} -constraints {testchannel thread} -result {{read rc* 4096} {read rc* 4096} snarfsnarf}
 test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2231,7 +2215,7 @@ test iocmd.tf-23.2 {chan read, bad data return, to much} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{read rc* 4096} 1 {read delivered more than requested}}
+} -constraints {testchannel thread} -result {{read rc* 4096} 1 {read delivered more than requested}}
 test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2245,7 +2229,7 @@ test iocmd.tf-23.3 {chan read, for non-readable channel} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for reading}}
+} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for reading}}
 test iocmd.tf-23.4 {chan read, error return} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2261,7 +2245,7 @@ test iocmd.tf-23.4 {chan read, error return} -match glob -body {
     rename foo {}
     set res
 } -result {{read rc* 4096} 1 BOOM!} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-23.5 {chan read, break return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2277,7 +2261,7 @@ test iocmd.tf-23.5 {chan read, break return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{read rc* 4096} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2293,7 +2277,7 @@ test iocmd.tf-23.6 {chan read, continue return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{read rc* 4096} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2309,7 +2293,7 @@ test iocmd.tf-23.7 {chan read, custom return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{read rc* 4096} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2325,7 +2309,7 @@ test iocmd.tf-23.8 {chan read, level is squashed} -match glob -body {
     rename foo {}
     set res
 } -result {{read rc* 4096} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "read"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup {
     set res {}
     proc foo {args} {
@@ -2345,7 +2329,7 @@ test iocmd.tf-23.9 {chan read, no data means eof} -match glob -setup {
     rename foo {}
     unset res
 } -result {{read rc* 4096} {} 1} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match glob -setup {
     set res {}
     proc foo {args} {
@@ -2365,7 +2349,7 @@ test iocmd.tf-23.10 {chan read, EAGAIN means no data, yet no eof either} -match
     rename foo {}
     unset res
 } -result {{read rc* 4096} {} 0} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 
 # --- === *** ###########################
 # method write
@@ -2385,7 +2369,7 @@ test iocmd.tf-24.1 {chan write, regular write} -match glob -body {
     } c
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{write rc* snarf} 5}
+} -constraints {testchannel thread} -result {{write rc* snarf} 5}
 test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2402,7 +2386,7 @@ test iocmd.tf-24.2 {chan write, ack partial writes} -match glob -body {
     } c
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8}
+} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} 7 {write rc* arfsnarf} 8}
 test iocmd.tf-24.3 {chan write, failed write} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; note -1; return -1}
@@ -2413,7 +2397,7 @@ test iocmd.tf-24.3 {chan write, failed write} -match glob -body {
     } c
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{write rc* snarfsnarfsnarf} -1}
+} -constraints {testchannel thread} -result {{write rc* snarfsnarfsnarf} -1}
 test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
@@ -2426,7 +2410,7 @@ test iocmd.tf-24.4 {chan write, non-writable channel} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {1 {channel "rc*" wasn't opened for writing}}
+} -constraints {testchannel thread} -result {1 {channel "rc*" wasn't opened for writing}}
 test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return 10000}
@@ -2439,7 +2423,7 @@ test iocmd.tf-24.5 {chan write, bad result, more written than data} -match glob
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}}
+} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}}
 test iocmd.tf-24.6 {chan write, zero writes} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return 0}
@@ -2452,7 +2436,7 @@ test iocmd.tf-24.6 {chan write, zero writes} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{write rc* snarf} 1 {write wrote more than requested}}
+} -constraints {testchannel thread} -result {{write rc* snarf} 1 {write wrote more than requested}}
 test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return -code error BOOM!}
@@ -2466,7 +2450,7 @@ test iocmd.tf-24.7 {chan write, failed write, error return} -match glob -body {
     rename foo {}
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; error BOOM!}
@@ -2480,7 +2464,7 @@ test iocmd.tf-24.8 {chan write, failed write, error return} -match glob -body {
     rename foo {}
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 BOOM!} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return -code break BOOM!}
@@ -2494,7 +2478,7 @@ test iocmd.tf-24.9 {chan write, failed write, break return is error} -match glob
     rename foo {}
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return -code continue BOOM!}
@@ -2508,7 +2492,7 @@ test iocmd.tf-24.10 {chan write, failed write, continue return is error} -match
     rename foo {}
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return -code 777 BOOM!}
@@ -2522,8 +2506,9 @@ test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match gl
     rename foo {}
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body {
+#LEAKS!
     set res {}
     proc foo {args} {oninit; onfinal; track; return BANG}
     set c [chan create {r w} foo]
@@ -2536,7 +2521,7 @@ test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -mat
     rename foo {}
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 {expected integer but got "BANG"}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return -level 55 -code 777 BOOM!}
@@ -2551,7 +2536,7 @@ test iocmd.tf-24.13 {chan write, failed write, level is ignored} -match glob -bo
     rename foo {}
     set res
 } -result {{write rc* snarfsnarfsnarf} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "write"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this time, bug 2936225} -match glob -setup {
     set res {}
     proc foo {args} {
@@ -2570,7 +2555,7 @@ test iocmd.tf-24.14 {chan write, no EAGAIN means that writing is allowed at this
     rename foo {}
     unset res
 } -result {{write rc* ABC} {}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at this time, bug 2936225} -match glob -setup {
     set res {}
     proc foo {args} {
@@ -2594,9 +2579,10 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi
     unset res
     update
 } -result {{write rc* ABC} {watch rc* write} {}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 
 test iocmd.tf-24.16 {chan write, note the background flush setup by close due to the EAGAIN leaving data in buffers.} -match glob -setup {
+#LEAKS!
     set res {}
     proc foo {args} {
 	oninit; onfinal; track
@@ -2624,7 +2610,7 @@ test iocmd.tf-24.16 {chan write, note the background flush setup by close due to
     rename foo {}
     unset res
 } -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 
 # --- === *** ###########################
 # method cgetall
@@ -2640,7 +2626,7 @@ test iocmd.tf-25.1 {chan configure, cgetall, standard options} -match glob -body
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
     -result {{-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
 test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
     set res {}
@@ -2653,7 +2639,7 @@ test iocmd.tf-25.2 {chan configure, cgetall, no options} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
     -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *}}}
 test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
     set res {}
@@ -2669,7 +2655,7 @@ test iocmd.tf-25.3 {chan configure, cgetall, regular result} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
     -result {{cgetall rc*} {-blocking 1 -buffering full -buffersize 4096 -encoding * -eofchar {{} {}} -translation {auto *} -bar foo -snarf x}}
 test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length} -match glob -body {
     set res {}
@@ -2686,8 +2672,9 @@ test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length}
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}
+} -constraints {testchannel thread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}
 test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body {
+#LEAKS!
     set res {}
     proc foo {args} {
 	oninit cget cgetall; onfinal; track
@@ -2702,7 +2689,7 @@ test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{cgetall rc*} 1 {unmatched open brace in list}}
+} -constraints {testchannel thread} -result {{cgetall rc*} 1 {unmatched open brace in list}}
 test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2718,7 +2705,7 @@ test iocmd.tf-25.6 {chan configure, cgetall, error return} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{cgetall rc*} 1 BOOM!}
+} -constraints {testchannel thread} -result {{cgetall rc*} 1 BOOM!}
 test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2735,7 +2722,7 @@ test iocmd.tf-25.7 {chan configure, cgetall, break return is error} -match glob
     rename foo {}
     set res
 } -result {{cgetall rc*} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2752,7 +2739,7 @@ test iocmd.tf-25.8 {chan configure, cgetall, continue return is error} -match gl
     rename foo {}
     set res
 } -result {{cgetall rc*} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2769,7 +2756,7 @@ test iocmd.tf-25.9 {chan configure, cgetall, custom return is error} -match glob
     rename foo {}
     set res
 } -result {{cgetall rc*} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2787,7 +2774,7 @@ test iocmd.tf-25.10 {chan configure, cgetall, level is ignored} -match glob -bod
     rename foo {}
     set res
 } -result {{cgetall rc*} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cgetall"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 
 # --- === *** ###########################
 # method configure
@@ -2805,7 +2792,7 @@ test iocmd.tf-26.1 {chan configure, set standard option} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{}}
+} -constraints {testchannel thread} -result {{}}
 test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2821,7 +2808,7 @@ test iocmd.tf-26.2 {chan configure, set option, error return} -match glob -body
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} 1 BOOM!}
+} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} 1 BOOM!}
 test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body {
     set res {}
     proc foo {args} {oninit configure; onfinal; track; return}
@@ -2833,7 +2820,7 @@ test iocmd.tf-26.3 {chan configure, set option, ok return} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{configure rc* -rc-foo bar} {}}
+} -constraints {testchannel thread} -result {{configure rc* -rc-foo bar} {}}
 test iocmd.tf-26.4 {chan configure, set option, break return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2850,7 +2837,7 @@ test iocmd.tf-26.4 {chan configure, set option, break return is error} -match gl
     rename foo {}
     set res
 } -result {{configure rc* -rc-foo bar} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2867,7 +2854,7 @@ test iocmd.tf-26.5 {chan configure, set option, continue return is error} -match
     rename foo {}
     set res
 } -result {{configure rc* -rc-foo bar} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2884,7 +2871,7 @@ test iocmd.tf-26.6 {chan configure, set option, custom return is error} -match g
     rename foo {}
     set res
 } -result {{configure rc* -rc-foo bar} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2902,7 +2889,7 @@ test iocmd.tf-26.7 {chan configure, set option, level is ignored} -match glob -b
     rename foo {}
     set res
 } -result {{configure rc* -rc-foo bar} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "configure"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 
 # --- === *** ###########################
 # method cget
@@ -2918,7 +2905,7 @@ test iocmd.tf-27.1 {chan configure, get option, ok return} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} foo}
+} -constraints {testchannel thread} -result {{cget rc* -rc-foo} foo}
 test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2934,7 +2921,7 @@ test iocmd.tf-27.2 {chan configure, get option, error return} -match glob -body
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{cget rc* -rc-foo} 1 BOOM!}
+} -constraints {testchannel thread} -result {{cget rc* -rc-foo} 1 BOOM!}
 test iocmd.tf-27.3 {chan configure, get option, break return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2951,7 +2938,7 @@ test iocmd.tf-27.3 {chan configure, get option, break return is error} -match gl
     rename foo {}
     set res
 } -result {{cget rc* -rc-foo} 1 BOOM!} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2968,7 +2955,7 @@ test iocmd.tf-27.4 {chan configure, get option, continue return is error} -match
     rename foo {}
     set res
 } -result {{cget rc* -rc-foo} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match glob -body {
     set res {}
     proc foo {args} {
@@ -2985,7 +2972,7 @@ test iocmd.tf-27.5 {chan configure, get option, custom return is error} -match g
     rename foo {}
     set res
 } -result {{cget rc* -rc-foo} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -body {
     set res {}
     proc foo {args} {
@@ -3003,7 +2990,7 @@ test iocmd.tf-27.6 {chan configure, get option, level is ignored} -match glob -b
     rename foo {}
     set res
 } -result {{cget rc* -rc-foo} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "cget"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 
 # --- === *** ###########################
 # method seek
@@ -3020,7 +3007,7 @@ test iocmd.tf-28.1 {chan tell, not supported by handler} -match glob -body {
     rename foo {}
     set res
 } -result {-1} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.2 {chan tell, error return} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!}
@@ -3034,7 +3021,7 @@ test iocmd.tf-28.2 {chan tell, error return} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} 1 BOOM!} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!}
@@ -3048,7 +3035,7 @@ test iocmd.tf-28.3 {chan tell, break return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!}
@@ -3062,7 +3049,7 @@ test iocmd.tf-28.4 {chan tell, continue return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -code 222 BOOM!}
@@ -3076,7 +3063,7 @@ test iocmd.tf-28.5 {chan tell, custom return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -level 11 -code 222 BANG}
@@ -3091,7 +3078,7 @@ test iocmd.tf-28.6 {chan tell, level is ignored} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.7 {chan tell, regular return} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return 88}
@@ -3104,7 +3091,7 @@ test iocmd.tf-28.7 {chan tell, regular return} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} 88} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.8 {chan tell, negative return} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -1}
@@ -3118,8 +3105,9 @@ test iocmd.tf-28.8 {chan tell, negative return} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.9 {chan tell, string return} -match glob -body {
+#LEAKS!
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return BOGUS}
     set c [chan create {r w} foo]
@@ -3132,7 +3120,7 @@ test iocmd.tf-28.9 {chan tell, string return} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} 1 {expected integer but got "BOGUS"}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
@@ -3146,7 +3134,7 @@ test iocmd.tf-28.10 {chan seek, not supported by handler} -match glob -body {
     rename foo {}
     set res
 } -result {1 {error during seek on "rc*": invalid argument}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.11 {chan seek, error return} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -code error BOOM!}
@@ -3160,7 +3148,7 @@ test iocmd.tf-28.11 {chan seek, error return} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 start} 1 BOOM!} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -code break BOOM!}
@@ -3174,7 +3162,7 @@ test iocmd.tf-28.12 {chan seek, break return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 start} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -code continue BOOM!}
@@ -3188,7 +3176,7 @@ test iocmd.tf-28.13 {chan seek, continue return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 start} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -code 99 BOOM!}
@@ -3202,7 +3190,7 @@ test iocmd.tf-28.14 {chan seek, custom return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 start} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -level 33 -code 99 BANG}
@@ -3217,7 +3205,7 @@ test iocmd.tf-28.15 {chan seek, level is ignored} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 start} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "seek"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return -45}
@@ -3231,8 +3219,9 @@ test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -bo
     rename foo {}
     set res
 } -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body {
+#LEAKS!
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return BOGUS}
     set c [chan create {r w} foo]
@@ -3245,7 +3234,7 @@ test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 start} 1 {expected integer but got "BOGUS"}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-28.18 {chan seek, ok result} -match glob -body {
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return 23}
@@ -3258,7 +3247,7 @@ test iocmd.tf-28.18 {chan seek, ok result} -match glob -body {
     rename foo {}
     set res
 } -result {{seek rc* 0 current} {}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 foreach {testname code} {
     iocmd.tf-28.19.0 start
     iocmd.tf-28.19.1 current
@@ -3276,7 +3265,7 @@ foreach {testname code} {
 	rename foo {}
 	set res
     } -result [list [list seek rc* 0 $code] {}] \
-	-constraints {testchannel testthread}
+	-constraints {testchannel thread}
 }
 
 # --- === *** ###########################
@@ -3294,7 +3283,7 @@ test iocmd.tf-29.1 {chan blocking, no handler support} -match glob -body {
     rename foo {}
     set res
 } -result {1} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; note MUST_NOT_HAPPEN; return}
@@ -3308,7 +3297,7 @@ test iocmd.tf-29.2 {chan blocking, no handler support} -match glob -body {
     rename foo {}
     set res
 } -result {{} 0} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; note MUST_NOT_HAPPEN; return}
@@ -3321,7 +3310,7 @@ test iocmd.tf-29.3 {chan blocking, retrieval, handler support} -match glob -body
     rename foo {}
     set res
 } -result {1} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; return}
@@ -3335,7 +3324,7 @@ test iocmd.tf-29.4 {chan blocking, resetting, handler support} -match glob -body
     rename foo {}
     set res
 } -result {{blocking rc* 0} {} 0} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; return}
@@ -3349,7 +3338,7 @@ test iocmd.tf-29.5 {chan blocking, setting, handler support} -match glob -body {
     rename foo {}
     set res
 } -result {{blocking rc* 1} {} 1} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.6 {chan blocking, error return} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; error BOOM!}
@@ -3364,7 +3353,7 @@ test iocmd.tf-29.6 {chan blocking, error return} -match glob -body {
     rename foo {}
     set res
 } -result {{blocking rc* 0} 1 BOOM!} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; return -code break BOOM!}
@@ -3378,7 +3367,7 @@ test iocmd.tf-29.7 {chan blocking, break return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{blocking rc* 0} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; return -code continue BOOM!}
@@ -3392,7 +3381,7 @@ test iocmd.tf-29.8 {chan blocking, continue return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{blocking rc* 0} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; return -code 44 BOOM!}
@@ -3406,7 +3395,7 @@ test iocmd.tf-29.9 {chan blocking, custom return is error} -match glob -body {
     rename foo {}
     set res
 } -result {{blocking rc* 0} 1 *bad code*} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; return -level 99 -code 44 BANG}
@@ -3421,7 +3410,7 @@ test iocmd.tf-29.10 {chan blocking, level is ignored} -match glob -body {
     rename foo {}
     set res
 } -result {{blocking rc* 0} 1 *bad code* {-code 1 -level 0 -errorcode NONE -errorline 1 -errorinfo *bad code*subcommand "blocking"*}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glob -body {
     set res {}
     proc foo {args} {oninit blocking; onfinal; track; return BOGUS}
@@ -3435,7 +3424,7 @@ test iocmd.tf-29.11 {chan blocking, regular return ok, value ignored} -match glo
     rename foo {}
     set res
 } -result {{blocking rc* 0} 0 {}} \
-    -constraints {testchannel testthread}
+    -constraints {testchannel thread}
 
 # --- === *** ###########################
 # method watch
@@ -3451,7 +3440,7 @@ test iocmd.tf-30.1 {chan watch, read interest, some return} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{watch rc* read} {watch rc* {}} {}}
+} -constraints {testchannel thread} -result {{watch rc* read} {watch rc* {}} {}}
 test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return -code error BOOM!_IGNORED}
@@ -3464,7 +3453,7 @@ test iocmd.tf-30.2 {chan watch, write interest, error return} -match glob -body
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} -result {{watch rc* write} {watch rc* {}} {} {}}
+} -constraints {testchannel thread} -result {{watch rc* write} {watch rc* {}} {} {}}
 test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body {
     set res {}
     proc foo {args} {oninit; onfinal; track; return}
@@ -3479,7 +3468,7 @@ test iocmd.tf-30.3 {chan watch, accumulated interests} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
     -result {{watch rc* write} {watch rc* {read write}} {watch rc* read} {watch rc* {}} {} {} {} {}}
 test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -body {
     set res {}
@@ -3494,7 +3483,7 @@ test iocmd.tf-30.4 {chan watch, unchanged interest not forwarded} -match glob -b
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
     -result {{watch rc* write} {watch rc* {read write}} {watch rc* write} {watch rc* {}} {} {} {}}
 
 # --- === *** ###########################
@@ -3514,7 +3503,7 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body {
     } c]
     rename foo {}
     set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
     -result {{can not find reflected channel named "rc*"}}
 
 # --- === *** ###########################
@@ -3523,14 +3512,18 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body {
 # B. Must not crash, must return proper errors.
 
 test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
+#LEAKS!
 
     #puts <<$tcltest::mainThread>>main
-    set tida [testthread create];#puts <<$tida>>
-    set tidb [testthread create];#puts <<$tidb>>
+    set tida [thread::create -preserved];#puts <<$tida>>
+    thread::send $tida {load {} Tcltest}
+
+    set tidb [thread::create -preserved];#puts <<$tidb>>
+    thread::send $tidb {load {} Tcltest}
 
     # Set up channel in thread
-    testthread send $tida $helperscript
-    set chan [testthread send $tida {
+    thread::send $tida $helperscript
+    set chan [thread::send $tida {
 	proc foo {args} {oninit seek; onfinal; track; return}
 	set chan [chan create {r w} foo]
 	fconfigure $chan -buffering none
@@ -3538,39 +3531,41 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
     }]
 
     # Move channel to 2nd thread.
-    testthread send $tida [list testchannel cut    $chan]
-    testthread send $tidb [list testchannel splice $chan]
+    thread::send $tida [list testchannel cut $chan]
+    thread::send $tidb [list testchannel splice $chan]
 
     # Kill origin thread, then access channel from 2nd thread.
-    testthread send -async $tida {testthread exit}
-    after 100
+    thread::release $tida
 
     set     res {}
-    lappend res [catch {testthread send $tidb [list puts  $chan shoo]} msg] $msg
+    lappend res [catch {thread::send $tidb [list puts  $chan shoo]} msg] $msg
 
-    lappend res [catch {testthread send $tidb [list tell  $chan]}      msg] $msg
-    lappend res [catch {testthread send $tidb [list seek  $chan 1]}    msg] $msg
-    lappend res [catch {testthread send $tidb [list gets  $chan]}      msg] $msg
-    lappend res [catch {testthread send $tidb [list close $chan]}      msg] $msg
-    tcltest::threadReap
+    lappend res [catch {thread::send $tidb [list tell  $chan]}      msg] $msg
+    lappend res [catch {thread::send $tidb [list seek  $chan 1]}    msg] $msg
+    lappend res [catch {thread::send $tidb [list gets  $chan]}      msg] $msg
+    lappend res [catch {thread::send $tidb [list close $chan]}      msg] $msg
+    thread::release $tidb
     set res
 
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
     -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
 
 test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body {
+#LEAKS!
 
     #puts <<$tcltest::mainThread>>main
-    set tida [testthread create];#puts <<$tida>>
-    set tidb [testthread create];#puts <<$tidb>>
+    set tida [thread::create -preserved];#puts <<$tida>>
+    thread::send $tida {load {} Tcltest}
+    set tidb [thread::create -preserved];#puts <<$tidb>>
+    thread::send $tidb {load {} Tcltest}
 
     # Set up channel in thread
-    set chan [testthread send $tida $helperscript]
-    set chan [testthread send $tida {
+    thread::send $tida $helperscript
+    set chan [thread::send $tida {
 	proc foo {args} {
 	    oninit; onfinal; track;
 	    # destroy thread during channel access
-	    testthread exit
+	    thread::exit
 	    return}
 	set chan [chan create {r w} foo]
 	fconfigure $chan -buffering none
@@ -3578,27 +3573,28 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat
     }]
 
     # Move channel to 2nd thread.
-    testthread send $tida [list testchannel cut    $chan]
-    testthread send $tidb [list testchannel splice $chan]
+    thread::send $tida [list testchannel cut    $chan]
+    thread::send $tidb [list testchannel splice $chan]
 
     # Run access from thread B, wait for response from A (A is not
     # using event loop at this point, so the event pile up in the
     # queue.
 
-    testthread send $tidb [list set chan $chan]
-    testthread send $tidb [list set mid $tcltest::mainThread]
-    testthread send -async $tidb {
+    thread::send $tidb [list set chan $chan]
+    thread::send $tidb [list set mid [thread::id]]
+    thread::send -async $tidb {
 	# wait a bit, give the main thread the time to start its event
 	# loop to wait for the response from B
 	after 2000
 	catch { puts $chan shoo } res
-	testthread send -async $mid [list set ::res $res]
+	thread::send -async $mid [list set ::res $res]
     }
     vwait ::res
 
-    tcltest::threadReap
+    catch {thread::release $tida}
+    thread::release $tidb
     set res
-} -constraints {testchannel testthread} \
+} -constraints {testchannel thread} \
     -result {Owner lost}
 
 # ### ### ### ######### ######### #########
-- 
cgit v0.12


From 27a3957c2e65717360160b65c14cd53ec494538a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 10 Sep 2011 17:57:03 +0000
Subject: [Bug 3400658]: Correction to forwarded method magic so that
 Tcl_WrongNumArgs produces the right sort of message.

---
 ChangeLog             |   6 +++
 generic/tclOOMethod.c |   2 +-
 tests/oo.test         | 132 ++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 139 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 69acbec..4d7c763 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-09-10  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOOMethod.c (InitEnsembleRewrite): [Bug 3400658]: Set the
+	ensemble-like rewriting up correctly for forwarded methods so that
+	computed error messages are correct.
+
 2011-09-09  Don Porter  <dgp@users.sourceforge.net>
 
 	* tests/chanio.test:	[Bug 3389733] Convert [testthread] use to
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 4e7edb8..708295a 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1595,7 +1595,7 @@ InitEnsembleRewrite(
     if (isRootEnsemble) {
 	iPtr->ensembleRewrite.sourceObjs = objv;
 	iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
-	iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
+	iPtr->ensembleRewrite.numInsertedObjs = rewriteLength - 1;
     } else {
 	int numIns = iPtr->ensembleRewrite.numInsertedObjs;
 
diff --git a/tests/oo.test b/tests/oo.test
index b12cb42..5ec5d2f 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -748,6 +748,138 @@ test oo-6.7 {OO: forward resolution scope is per-object} -setup {
 } -cleanup {
     fooClass destroy
 } -result 1
+test oo-6.8 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+    oo::class create fooClass
+} -body {
+    oo::define fooClass {
+	forward test my handler
+	method handler {a b c} {}
+    }
+    fooClass create ::foo
+    foo test
+} -returnCodes error -cleanup {
+    fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.9 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+    oo::class create fooClass
+} -body {
+    oo::define fooClass {
+	forward test my handler
+	method handler {a b c} {list $a,$b,$c}
+    }
+    fooClass create ::foo
+    foo test 1 2 3
+} -cleanup {
+    fooClass destroy
+} -result 1,2,3
+test oo-6.10 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+    oo::class create fooClass
+} -body {
+    oo::define fooClass {
+	forward test my handler
+	method handler {a b c} {list $a,$b,$c}
+    }
+    fooClass create ::foo
+    foo test 1 2
+} -returnCodes error -cleanup {
+    fooClass destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.11 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+    oo::object create foo
+} -body {
+    oo::objdefine foo {
+	forward test my handler
+	method handler {a b c} {}
+    }
+    foo test
+} -returnCodes error -cleanup {
+    foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.12 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+    oo::object create foo
+} -body {
+    oo::objdefine foo {
+	forward test my handler
+	method handler {a b c} {list $a,$b,$c}
+    }
+    foo test 1 2 3
+} -cleanup {
+    foo destroy
+} -result 1,2,3
+test oo-6.13 {Bug 3400658: forwarding and wrongargs rewriting} -setup {
+    oo::object create foo
+} -body {
+    oo::objdefine foo {
+	forward test my handler
+	method handler {a b c} {list $a,$b,$c}
+    }
+    foo test 1 2
+} -returnCodes error -cleanup {
+    foo destroy
+} -result {wrong # args: should be "foo test a b c"}
+test oo-6.14 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+    oo::class create fooClass
+} -body {
+    oo::define fooClass {
+	forward test my handler1 p
+	forward handler1 my handler q
+	method handler {a b c} {}
+    }
+    fooClass create ::foo
+    foo test
+} -returnCodes error -cleanup {
+    fooClass destroy
+} -result {wrong # args: should be "foo test c"}
+test oo-6.15 {Bug 3400658: forwarding and wrongargs rewriting - multistep} -setup {
+    oo::class create fooClass
+} -body {
+    oo::define fooClass {
+	forward test my handler1 p
+	forward handler1 my handler q
+	method handler {a b c} {list $a,$b,$c}
+    }
+    fooClass create ::foo
+    foo test 1
+} -cleanup {
+    fooClass destroy
+} -result q,p,1
+test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setup {
+    oo::class create fooClass
+} -body {
+    oo::define fooClass {
+	forward test handler1 foo bar
+	forward handler2 my handler x
+	method handler {a b c d} {list $a,$b,$c,$d}
+	export eval
+    }
+    fooClass create ::foo
+    foo eval {
+	interp alias {} [namespace current]::handler1 \
+	    {} [namespace current]::my handler2
+    }
+    foo test 1 2 3
+} -returnCodes error -cleanup {
+    fooClass destroy
+} -result {wrong # args: should be "foo test d"}
+test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -setup {
+    oo::class create fooClass
+} -constraints knownBug -body {
+    oo::define fooClass {
+	forward test handler1 foo bar boo
+	forward handler2 my handler
+	method handler {a b c d} {list $a,$b,$c,$d}
+	export eval
+    }
+    fooClass create ::foo
+    foo eval {
+	namespace ensemble create \
+	    -command [namespace current]::handler1 -parameters {p q} \
+	    -map [list boo [list [namespace current]::my handler2]]
+    }
+    foo test 1 2 3
+} -returnCodes error -cleanup {
+    fooClass destroy
+} -result {wrong # args: should be "foo test c d"}
 
 test oo-7.1 {OO: inheritance 101} -setup {
     oo::class create superClass
-- 
cgit v0.12


From cc91390bcaad5838a55714ae8994b24be476efca Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 10 Sep 2011 17:58:39 +0000
Subject: Minor formatting fixes.

---
 ChangeLog | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 4d7c763..5be7831 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -6,16 +6,16 @@
 
 2011-09-09  Don Porter  <dgp@users.sourceforge.net>
 
-	* tests/chanio.test:	[Bug 3389733] Convert [testthread] use to
+	* tests/chanio.test:	[Bug 3389733]: Convert [testthread] use to
 	* tests/io.test:	Thread package use in *io-70.1.  Eliminates a
 	memory leak in `make valgrind`.
 
 2011-09-07  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCompExpr.c: [Bug 3401704] Allow function names like
-	* tests/parseExpr.test:	 influence(), nanobot(), and 99bottles()
-	that have been parsed as missing operator syntax errors before
-	with the form NUMBER + FUNCTION.
+	* generic/tclCompExpr.c: [Bug 3401704]: Allow function names like
+	* tests/parseExpr.test:	 influence(), nanobot(), and 99bottles() that
+	have been parsed as missing operator syntax errors before with the
+	form NUMBER + FUNCTION.
 	***POTENTIAL INCOMPATIBILITY***
 
 2011-09-06  Venkat Iyer <venkat@comit.com>
@@ -42,13 +42,13 @@
 
 2011-09-01  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
-	* unix/tclUnixSock.c: [Bug 3401422] Cache script-level changes to
-	the nonblocking flag of an async client socket in progress, and
-	commit them on completion.
+	* unix/tclUnixSock.c: [Bug 3401422]: Cache script-level changes to the
+	nonblocking flag of an async client socket in progress, and commit
+	them on completion.
 
 2011-09-01  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclStrToD.c:	[Bug 3402540] Corrections to TclParseNumber()
+	* generic/tclStrToD.c:	[Bug 3402540]: Corrections to TclParseNumber()
 	* tests/binary.test:	to make it reject invalid Nan(Hex) strings.
 
 	* tests/scan.test:	[scan Inf %g] is portable; remove constraint.
-- 
cgit v0.12


From 0316c6eff20ff2d18f2b47d72f9d83fa497d5731 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Sun, 11 Sep 2011 20:02:33 +0000
Subject: 3390699 Convert [testthread] use to Thread package use in
 socket_*-13.1. Eliminates a memory leak in `make valgrind`.

---
 ChangeLog         |  6 ++++++
 tests/socket.test | 29 ++++++++++-------------------
 2 files changed, 16 insertions(+), 19 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5be7831..6ddc913 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-09-11  Don Porter  <dgp@users.sourceforge.net>
+
+	* tests/socket.test:	[Bug 3390699]: Convert [testthread] use to
+	Thread package use in socket_*-13.1.  Eliminates a memory leak in
+	`make valgrind`.
+
 2011-09-10  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclOOMethod.c (InitEnsembleRewrite): [Bug 3400658]: Set the
diff --git a/tests/socket.test b/tests/socket.test
index 0ea0eb5..58eb3ee 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -63,8 +63,8 @@
 package require tcltest 2
 namespace import -force ::tcltest::*
 
-# Some tests require the testthread and exec commands
-testConstraint testthread [llength [info commands testthread]]
+# Some tests require the Thread package or exec command
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 testConstraint exec [llength [info commands exec]]
 
 # Produce a random port number in the Dynamic/Private range
@@ -1672,9 +1672,9 @@ test socket_$af-12.3 {testing inheritance of accepted sockets} -setup {
     catch {close $p}
 } -result {accepted socket was not inherited}
 
-test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
-    threadReap
-    set path(script) [makeFile [string map [list @localhost@ $localhost] {
+test socket_$af-13.1 {Testing use of shared socket between two threads} -body {
+    # create a thread
+    set serverthread [thread::create -preserved [string map [list @localhost@ $localhost] {
         set f [socket -server accept -myaddr @localhost@ 0]
         set listen [lindex [fconfigure $f -sockname] 2]
         proc accept {s a p} {
@@ -1696,15 +1696,8 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
         set i 0
         vwait x
         close $f
-        # thread cleans itself up.
-        testthread exit
-    }] script]
-} -constraints [list socket supported_$af testthread] -body {
-    # create a thread
-    set serverthread [testthread create [list source $path(script) ] ]
-    update
-    set port [testthread send $serverthread {set listen}]
-    update
+    }]]
+    set port [thread::send $serverthread {set listen}]
     set s [socket $localhost $port]
     fconfigure $s -buffering line
     catch {
@@ -1712,11 +1705,9 @@ test socket_$af-13.1 {Testing use of shared socket between two threads} -setup {
         gets $s result
     }
     close $s
-    update
-    append result " " [threadReap]
-} -cleanup {
-    removeFile script
-} -result {hello 1}
+    thread::release $serverthread
+    append result " " [llength [thread::names]]
+} -result {hello 1} -constraints [list socket supported_$af thread] 
 
 # ----------------------------------------------------------------------
 
-- 
cgit v0.12


From a0baa7a37e79abe06322069bef4fa706950a4b18 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Sep 2011 00:41:44 +0000
Subject: Convert [testthread] use to Thread package use in thread-6.1.
 Eliminates a memory leak in `make valgrind`.

---
 ChangeLog         |  3 +++
 tests/thread.test | 15 ++++++---------
 2 files changed, 9 insertions(+), 9 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 6ddc913..ea86aec 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
 2011-09-11  Don Porter  <dgp@users.sourceforge.net>
 
+	* tests/thread.test:	Convert [testthread] use to Thread package
+	use in thread-6.1.  Eliminates a memory leak in `make valgrind`.
+
 	* tests/socket.test:	[Bug 3390699]: Convert [testthread] use to
 	Thread package use in socket_*-13.1.  Eliminates a memory leak in
 	`make valgrind`.
diff --git a/tests/thread.test b/tests/thread.test
index a6961ed..db28dc9 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -19,6 +19,7 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 # Some tests require the testthread command
 
 testConstraint testthread [expr {[info commands testthread] != {}}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 
 if {[testConstraint testthread]} {
     testthread errorproc ThreadError
@@ -239,22 +240,18 @@ test thread-5.2 {Try to join a detached thread} {testthread} {
     lrange $msg 0 2
 } {cannot join thread}
 
-test thread-6.1 {freeing very large object trees in a thread} testthread {
+test thread-6.1 {freeing very large object trees in a thread} thread {
     # conceptual duplicate of obj-32.1
-    threadReap
-    set serverthread [testthread create -joinable]
-    testthread send -async $serverthread {
+    set serverthread [thread::create -preserved]
+    thread::send -async $serverthread {
 	set x {}
 	for {set i 0} {$i<100000} {incr i} {
 	    set x [list $x {}]
 	}
 	unset x
-	testthread exit
     }
-    catch {set res [testthread join $serverthread]} msg
-    threadReap
-    set res
-} {0}
+    thread::release -wait $serverthread
+} 0
 
 # TIP #285: Script cancellation support
 test thread-7.1 {cancel: args} {testthread} {
-- 
cgit v0.12


From 87e56352ebf369aa9192b48501e2ca76f2e42afb Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Sep 2011 01:01:44 +0000
Subject: Convert [testthread] to Thread

---
 tests/unixNotfy.test | 15 ++++++++-------
 1 file changed, 8 insertions(+), 7 deletions(-)

diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index 8af8a21..9684bfe 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -20,7 +20,8 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 }
 
 # When run in a Tk shell, these tests hang.
-testConstraint noTk       [expr {![info exists tk_version]}]
+testConstraint noTk [expr {0 != [catch {package present Tk}]}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 testConstraint testthread [expr {[info commands testthread] != {}}]
 # Darwin always uses a threaded notifier
 testConstraint unthreaded [expr {
@@ -61,16 +62,16 @@ test unixNotfy-1.2 {Tcl_DeleteFileHandler} -constraints {noTk unix unthreaded} -
 }
 
 test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
-    -constraints {noTk unix testthread} \
+    -constraints {noTk unix thread} \
     -body {
 	update
 	set f [open [makeFile "" foo] w]
 	fileevent $f writable {set x 1}
 	vwait x
 	close $f
-   	testthread create "testthread send [testthread id] {set x ok}"
+   	set t [thread::create -preserved "thread::send [thread::id] {set x ok}"]
 	vwait x
-	threadReap
+	thread::release $t
 	set x
     } \
     -result {ok} \
@@ -79,7 +80,7 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
 	catch { removeFile foo }
     }
 test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
-    -constraints {noTk unix testthread} \
+    -constraints {noTk unix thread} \
     -body {
 	update
 	set f1 [open [makeFile "" foo] w]
@@ -90,9 +91,9 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
 	close $f1
 	vwait y
 	close $f2
-   	testthread create "testthread send [testthread id] {set x ok}"
+   	set t [thread::create -preserved "thread::send [thread::id] {set x ok}"]
 	vwait x
-	threadReap
+	thread::release $t
 	set x
     } \
     -result {ok} \
-- 
cgit v0.12


From f17890321842cedc4b3d1ee105278a56b75d2704 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Sep 2011 04:50:56 +0000
Subject: Work in progress taking leaks out of thread.test.

---
 tests/thread.test | 136 ++++++++++++++++++++++++------------------------------
 1 file changed, 61 insertions(+), 75 deletions(-)

diff --git a/tests/thread.test b/tests/thread.test
index db28dc9..7bc7394 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -42,40 +42,34 @@ test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
 test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
     list [catch {testthread foo} msg] $msg
 } {1 {bad option "foo": must be cancel, create, event, exit, id, join, names, send, wait, or errorproc}}
-test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {testthread} {
-    list [threadReap] [llength [testthread names]]
-} {1 1}
-test thread-1.4 {Tcl_ThreadObjCmd: thread create } {testthread} {
-    threadReap
-    set serverthread [testthread create]
-    update
-    set numthreads [llength [testthread names]]
-    threadReap
+test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
+    llength [thread::names]
+} 1
+test thread-1.4 {Tcl_ThreadObjCmd: thread create } {thread} {
+    set serverthread [thread::create -preserved]
+    set numthreads [llength [thread::names]]
+    thread::release $serverthread
     set numthreads
 } {2}
-test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {testthread} {
-    threadReap
-    testthread create {set x 5}
+test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} {
+    thread::create {set x 5}
     foreach try {0 1 2 4 5 6} {
 	# Try various ways to yield
 	update
 	after 10
-	set l [llength [testthread names]]
+	set l [llength [thread::names]]
 	if {$l == 1} {
 	    break
 	}
     }
-    threadReap
     set l
 } {1}
-test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {testthread} {
+test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
     threadReap
-    testthread create {testthread exit}
+    thread::create {{*}{}}
     update
     after 10
-    set result [llength [testthread names]]
-    threadReap
-    set result
+    llength [thread::names]
 } {1}
 test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
     set x [catch {testthread id x} msg]
@@ -99,11 +93,10 @@ test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} {
     set x [catch {testthread send abc command} msg]
     list $x $msg
 } {1 {expected integer but got "abc"}}
-test thread-1.13 {Tcl_ThreadObjCmd: send args} {testthread} {
-    threadReap
-    set serverthread [testthread create]
-    set five [testthread send $serverthread {set x 5}]
-    threadReap
+test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} {
+    set serverthread [thread::create -preserved]
+    set five [thread::send $serverthread {set x 5}]
+    thread::release $serverthread
     set five
 } 5
 test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
@@ -111,11 +104,10 @@ test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
     set x [catch {testthread send $tid {set x 5}} msg]
     list $x $msg
 } {1 {invalid thread id}}
-test thread-1.15 {Tcl_ThreadObjCmd: wait} {testthread} {
-    threadReap
-    set serverthread [testthread create {set z 5 ; testthread wait}]
-    set five [testthread send $serverthread {set z}]
-    threadReap
+test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} {
+    set serverthread [thread::create -preserved {set z 5 ; thread::wait}]
+    set five [thread::send $serverthread {set z}]
+    thread::release $serverthread
     set five
 } 5
 test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} {
@@ -132,84 +124,78 @@ test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} {
 # NewThread, safe and regular
 # ThreadErrorProc, except for printing to standard error
 
-test thread-2.1 {ListUpdateInner and ListRemove} {testthread} {
-    threadReap
+test thread-2.1 {ListUpdateInner and ListRemove} {thread} {
     catch {unset tid}
     foreach t {0 1 2} {
 	upvar #0 t$t tid
-	set tid [testthread create]
+	set tid [thread::create -preserved]
     }
-    threadReap
+    foreach t {0 1 2} {
+	upvar #0 t$t tid
+	thread::release $tid
+    }
+    llength [thread::names]
 } 1
 
-test thread-3.1 {TclThreadList} {testthread} {
-    threadReap
+test thread-3.1 {TclThreadList} {thread} {
     catch {unset tid}
-    set len [llength [testthread names]]
+    set len [llength [thread::names]]
     set l1  {}
     foreach t {0 1 2} {
-	lappend l1 [testthread create]
+	lappend l1 [thread::create -preserved]
+    }
+    set l2 [thread::names]
+    set c [string compare [lsort [concat [thread::id] $l1]] [lsort $l2]]
+    foreach t $l1 {
+	thread::release $t
     }
-    set l2 [testthread names]
-    list $l1 $l2
-    set c [string compare \
-	    [lsort -integer [concat $::tcltest::mainThread $l1]] \
-	    [lsort -integer $l2]]
-    threadReap
     list $len $c
 } {1 0}
 
-test thread-4.1 {TclThreadSend to self} {testthread} {
+test thread-4.1 {TclThreadSend to self} {thread} {
     catch {unset x}
-    testthread send [testthread id] {
+    thread::send [thread::id] {
 	set x 4
     }
     set x
 } {4}
-test thread-4.2 {TclThreadSend -async} {testthread} {
-    threadReap
-    set len [llength [testthread names]]
-    set serverthread [testthread create]
-    testthread send -async $serverthread {
-	after 1000
-	testthread exit
+test thread-4.2 {TclThreadSend -async} {thread} {
+    set len [llength [thread::names]]
+    set serverthread [thread::create -preserved]
+    thread::send -async $serverthread {
+	after 1 {thread::release}
     }
-    set two [llength [testthread names]]
-    after 1500 {set done 1}
+    set two [llength [thread::names]]
+    after 100 {set done 1}
     vwait done
-    threadReap
-    list $len [llength [testthread names]] $two
+    list $len [llength [thread::names]] $two
 } {1 1 2}
-test thread-4.3 {TclThreadSend preserve errorInfo} {testthread} {
-    threadReap
-    set len [llength [testthread names]]
-    set serverthread [testthread create]
-    set x [catch {testthread send $serverthread {set undef}} msg]
+test thread-4.3 {TclThreadSend preserve errorInfo} {thread} {
+    set len [llength [thread::names]]
+    set serverthread [thread::create -preserved]
+    set x [catch {thread::send $serverthread {set undef}} msg]
     set savedErrorInfo $::errorInfo
-    threadReap
+    thread::release $serverthread
     list $len $x $msg $savedErrorInfo
 } {1 1 {can't read "undef": no such variable} {can't read "undef": no such variable
     while executing
 "set undef"
     invoked from within
-"testthread send $serverthread {set undef}"}}
-test thread-4.4 {TclThreadSend preserve code} {testthread} {
-    threadReap
-    set len [llength [testthread names]]
-    set serverthread [testthread create]
+"thread::send $serverthread {set undef}"}}
+test thread-4.4 {TclThreadSend preserve code} {thread} {
+    set len [llength [thread::names]]
+    set serverthread [thread::create -preserved]
     set ::errorInfo {}
-    set x [catch {testthread send $serverthread {set ::errorInfo {}; break}} msg]
+    set x [catch {thread::send $serverthread {set ::errorInfo {}; break}} msg]
     set savedErrorInfo $::errorInfo
-    threadReap
+    thread::release $serverthread
     list $len $x $msg $savedErrorInfo
 } {1 3 {} {}}
-test thread-4.5 {TclThreadSend preserve errorCode} {testthread} {
-    threadReap
-    set ::tcltest::mainThread [testthread names]
-    set serverthread [testthread create]
-    set x [catch {testthread send $serverthread {error ERR INFO CODE}} msg]
+test thread-4.5 {TclThreadSend preserve errorCode} {thread} {
+    set serverthread [thread::create]
+    set x [catch {thread::send $serverthread {error ERR INFO CODE}} msg]
     set savedErrorCode $::errorCode
-    threadReap
+    thread::release $serverthread
     list $x $msg $savedErrorCode
 } {1 ERR CODE}
 
-- 
cgit v0.12


From 021b7b35eb1380f04f55ca09121e9a392a1bd1ee Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Sep 2011 05:06:11 +0000
Subject: more conversion work

---
 tests/thread.test | 35 +++++++++++++++--------------------
 1 file changed, 15 insertions(+), 20 deletions(-)

diff --git a/tests/thread.test b/tests/thread.test
index 7bc7394..6cd4b5d 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -200,29 +200,24 @@ test thread-4.5 {TclThreadSend preserve errorCode} {thread} {
 } {1 ERR CODE}
 
 
-test thread-5.0 {Joining threads} {testthread} {
-    threadReap
-    set serverthread [testthread create -joinable]
-    testthread send -async $serverthread {after 1000 ; testthread exit}
-    set res [testthread join $serverthread]
-    threadReap
-    set res
+test thread-5.0 {Joining threads} {thread} {
+    set serverthread [thread::create -joinable -preserved]
+    thread::send -async $serverthread {after 1000 ; thread::release}
+    thread::join $serverthread
 } {0}
-test thread-5.1 {Joining threads after the fact} {testthread} {
-    threadReap
-    set serverthread [testthread create -joinable]
-    testthread send -async $serverthread {testthread exit}
+test thread-5.1 {Joining threads after the fact} {thread} {
+    set serverthread [thread::create -joinable -preserved]
+    thread::send -async $serverthread {thread::release}
     after 2000
-    set res [testthread join $serverthread]
-    threadReap
-    set res
+    thread::join $serverthread
 } {0}
-test thread-5.2 {Try to join a detached thread} {testthread} {
-    threadReap
-    set serverthread [testthread create]
-    testthread send -async $serverthread {after 1000 ; testthread exit}
-    catch {set res [testthread join $serverthread]} msg
-    threadReap
+test thread-5.2 {Try to join a detached thread} {thread} {
+    set serverthread [thread::create -preserved]
+    thread::send -async $serverthread {after 1000 ; thread::release}
+    catch {set res [thread::join $serverthread]} msg
+    while {[llength [thread::names]] > 1} {
+	after 20
+    }
     lrange $msg 0 2
 } {cannot join thread}
 
-- 
cgit v0.12


From 7b78279bacaab05c7ae42e7e5b487e290a02292a Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Sep 2011 16:19:07 +0000
Subject: Attempt to convert test thread-7.26

---
 tests/thread.test | 18 +++++++++---------
 1 file changed, 9 insertions(+), 9 deletions(-)

diff --git a/tests/thread.test b/tests/thread.test
index 6cd4b5d..62cdb24 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -938,28 +938,28 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {testthr
 	      [expr {[info exists ::threadError] ? \
 		  [lindex [split $::threadError \n] 0] : "" }]
 } {{} 1 0 {}}
-test thread-7.26 {cancel: send async cancel bad interp path} {testthread} {
-    threadReap
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
+    unset -nocomplain ::threadIdStarted
+    set serverthread [thread::create -preserved \
+	[string map [list MAIN [thread::id]] {
 	proc foobar {} {
 	    while {1} {
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send MAIN \
+			    [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		update
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    catch {testthread send $serverthread {interp cancel -- bad}} msg
-    threadReap
+    catch {thread::send $serverthread {interp cancel -- bad}} msg
+    thread::release -wait $serverthread
     list [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 		  $msg
-- 
cgit v0.12


From 71ccb108c1bc10efa33e1318cf6079986176e0fd Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Sep 2011 17:52:19 +0000
Subject: stop segfault

---
 tests/thread.test | 6 +++++-
 1 file changed, 5 insertions(+), 1 deletion(-)

diff --git a/tests/thread.test b/tests/thread.test
index 62cdb24..865c7c6 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -23,6 +23,10 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 
 if {[testConstraint testthread]} {
     testthread errorproc ThreadError
+}
+if {[testConstraint thread]} {
+    thread::errorproc ThreadError
+}
 
     proc ThreadError {id info} {
 	global threadId threadError
@@ -33,7 +37,6 @@ if {[testConstraint testthread]} {
     proc ThreadNullError {id info} {
 	# ignore
     }
-}
 
 
 test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
@@ -959,6 +962,7 @@ test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     catch {thread::send $serverthread {interp cancel -- bad}} msg
+    thread::send -async $serverthread {interp cancel -unwind}
     thread::release -wait $serverthread
     list [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
-- 
cgit v0.12


From 4e6d7ac04b768be3cca7788d3d97483d809918a0 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 12 Sep 2011 18:37:09 +0000
Subject: revise iocmd.tf-24.16 result to deal with Thread conversion

---
 tests/ioCmd.test | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 43ac712..f749b46 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -2609,7 +2609,7 @@ test iocmd.tf-24.16 {chan write, note the background flush setup by close due to
 } -cleanup {
     rename foo {}
     unset res
-} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \
+} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC} BG {finalize rc*}} \
     -constraints {testchannel thread}
 
 # --- === *** ###########################
-- 
cgit v0.12


From ef09f86d39a751b46143aa33f2ee808b31a6a984 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 15 Sep 2011 16:27:42 +0000
Subject: 3408408 Partial improvement by sharing as literals the computed
 values of constant subexpressions when we can do so without incurring the
 cost of string rep generation.

---
 ChangeLog             |  7 +++++++
 generic/tclCompExpr.c | 26 ++++++++++++++++++++++++--
 2 files changed, 31 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 42b0884..26f0093 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-09-15  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclCompExpr.c: [Bug 3408408] Partial improvement by 
+	sharing as literals the computed values of constant subexpressions
+	when we can do so without incurring the cost of string rep
+	generation.
+
 2011-09-13  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclUtil.c:	[Bug 3390638] Workaround broken solaris
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index 80f21e4..d96670c 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -2471,8 +2471,30 @@ CompileExprTree(
 
 		if (ExecConstantExprTree(interp, nodes, next, litObjvPtr)
 			== TCL_OK) {
-		    TclEmitPush(TclAddLiteralObj(envPtr,
-			    Tcl_GetObjResult(interp), NULL), envPtr);
+		    int index;
+		    Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
+
+		    /*
+		     * Don't generate a string rep, but if we have one
+		     * already, then use it to share via the literal table.
+		     */
+		    if (objPtr->bytes) {
+			Tcl_Obj *tableValue;
+
+			index = TclRegisterNewLiteral(envPtr, objPtr->bytes,
+				objPtr->length);
+			tableValue = envPtr->literalArrayPtr[index].objPtr;
+			if ((tableValue->typePtr == NULL) &&
+				(objPtr->typePtr != NULL)) {
+			    /* Same intrep surgery as for OT_LITERAL */
+			    tableValue->typePtr = objPtr->typePtr;
+			    tableValue->internalRep = objPtr->internalRep;
+			    objPtr->typePtr = NULL;
+			}
+		    } else {
+			index = TclAddLiteralObj(envPtr, objPtr, NULL);
+		    }
+		    TclEmitPush(index, envPtr);
 		} else {
 		    TclCompileSyntaxError(interp, envPtr);
 		}
-- 
cgit v0.12


From 616ed3e2c84e9d0ece967a597357eb509fffccbd Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 16 Sep 2011 08:55:26 +0000
Subject: Minor change: formatting

---
 ChangeLog | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index efd3449..4bb5097 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -7,22 +7,21 @@
 
 2011-09-15  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCompExpr.c: [Bug 3408408] Partial improvement by 
-	sharing as literals the computed values of constant subexpressions
-	when we can do so without incurring the cost of string rep
-	generation.
+	* generic/tclCompExpr.c: [Bug 3408408]: Partial improvement by sharing
+	as literals the computed values of constant subexpressions when we can
+	do so without incurring the cost of string rep generation.
 
 2011-09-13  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclUtil.c:	[Bug 3390638] Workaround broken solaris
+	* generic/tclUtil.c:	[Bug 3390638]: Workaround broken solaris
 	studio cc optimizer.  Thanks to Wolfgang S. Kechel.
 
-	* generic/tclDTrace.d:	[Bug 3405652] Portability workaround for
+	* generic/tclDTrace.d:	[Bug 3405652]: Portability workaround for
 	broken system DTrace support.  Thanks to Dagobert Michelson.
 
 2011-09-12  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinPort.h: [Bug 3407070] tclPosixStr.c won't build with
+	* win/tclWinPort.h: [Bug 3407070]: tclPosixStr.c won't build with
 	EOVERFLOW==E2BIG
 
 2011-09-11  Don Porter  <dgp@users.sourceforge.net>
-- 
cgit v0.12


From 8dad1b8281811bab0d71588b3c59a7fa1d163642 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 16 Sep 2011 13:13:11 +0000
Subject: [Bug 3408830]: Use the _right_ fix for [Bug 3400658]!

---
 ChangeLog             | 10 ++++------
 generic/tclOOMethod.c |  2 +-
 generic/tclProc.c     |  2 ++
 tests/oo.test         | 10 ++++++++++
 4 files changed, 17 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 4bb5097..99b891b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2011-09-16  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclProc.c (ProcWrongNumArgs): [Bugs 3400658,3408830]:
+	Ensemble-like rewriting of error messages is complex, and TclOO (in
+	combination with iTcl) hits the most tricky cases.
+
 	* library/http/http.tcl (http::geturl): [Bug 3391977]: Ensure that the
 	-headers option overrides the -type option (important because -type
 	has a default that is not always appropriate, and the header must not
@@ -33,12 +37,6 @@
 	Thread package use in socket_*-13.1.  Eliminates a memory leak in
 	`make valgrind`.
 
-2011-09-10  Donal K. Fellows  <dkf@users.sf.net>
-
-	* generic/tclOOMethod.c (InitEnsembleRewrite): [Bug 3400658]: Set the
-	ensemble-like rewriting up correctly for forwarded methods so that
-	computed error messages are correct.
-
 2011-09-09  Don Porter  <dgp@users.sourceforge.net>
 
 	* tests/chanio.test:	[Bug 3389733]: Convert [testthread] use to
diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c
index 708295a..4e7edb8 100644
--- a/generic/tclOOMethod.c
+++ b/generic/tclOOMethod.c
@@ -1595,7 +1595,7 @@ InitEnsembleRewrite(
     if (isRootEnsemble) {
 	iPtr->ensembleRewrite.sourceObjs = objv;
 	iPtr->ensembleRewrite.numRemovedObjs = toRewrite;
-	iPtr->ensembleRewrite.numInsertedObjs = rewriteLength - 1;
+	iPtr->ensembleRewrite.numInsertedObjs = rewriteLength;
     } else {
 	int numIns = iPtr->ensembleRewrite.numInsertedObjs;
 
diff --git a/generic/tclProc.c b/generic/tclProc.c
index 50cf0f7..d008217 100644
--- a/generic/tclProc.c
+++ b/generic/tclProc.c
@@ -1120,6 +1120,8 @@ ProcWrongNumArgs(
     if (framePtr->isProcCallFrame & FRAME_IS_LAMBDA) {
 	desiredObjs[0] = Tcl_NewStringObj("lambdaExpr", -1);
     } else {
+	((Interp *) interp)->ensembleRewrite.numInsertedObjs -= skip - 1;
+
 #ifdef AVOID_HACKS_FOR_ITCL
 	desiredObjs[0] = framePtr->objv[skip-1];
 #else
diff --git a/tests/oo.test b/tests/oo.test
index 5ec5d2f..171ccc7 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -880,6 +880,16 @@ test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -s
 } -returnCodes error -cleanup {
     fooClass destroy
 } -result {wrong # args: should be "foo test c d"}
+test oo-6.18 {Bug 3408830: more forwarding cases} -setup {
+    oo::class create fooClass
+} -body {
+    oo::define fooClass {
+	forward len  string length
+    }
+    [fooClass create foo] len a b
+} -returnCodes error -cleanup {
+    fooClass destroy
+} -result {wrong # args: should be "::foo len string"}
 
 test oo-7.1 {OO: inheritance 101} -setup {
     oo::class create superClass
-- 
cgit v0.12


From 81286b9a064f7a8293258770d12d65a99b34063f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 16 Sep 2011 13:19:19 +0000
Subject: Noticed that a test now works.

---
 tests/oo.test | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/oo.test b/tests/oo.test
index 171ccc7..e5a17f1 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -863,7 +863,7 @@ test oo-6.16 {Bug 3400658: forwarding and wrongargs rewriting - via alias} -setu
 } -result {wrong # args: should be "foo test d"}
 test oo-6.17 {Bug 3400658: forwarding and wrongargs rewriting - via ensemble} -setup {
     oo::class create fooClass
-} -constraints knownBug -body {
+} -body {
     oo::define fooClass {
 	forward test handler1 foo bar boo
 	forward handler2 my handler
-- 
cgit v0.12


From a46ead9692a9b2e6ddedba10dc6e11d3cb6bfdda Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 16 Sep 2011 17:12:25 +0000
Subject: Made test socket-14.1 more robust to stop failure on OS X (Snow
 Leopard)

---
 tests/socket.test | 1 +
 1 file changed, 1 insertion(+)

diff --git a/tests/socket.test b/tests/socket.test
index 58eb3ee..f63f5ca 100644
--- a/tests/socket.test
+++ b/tests/socket.test
@@ -1760,6 +1760,7 @@ test socket-14.1 {[socket -async] fileevent while still connecting} \
         set client [socket -async localhost $port]
         fileevent $client writable {
             lappend x [fconfigure $client -error]
+	    fileevent $client writable {}
         }
         set after [after 1000 {lappend x timeout}]
         while {[llength $x] < 2 && "timeout" ni $x} {
-- 
cgit v0.12


From a33ebfc70324c59441cbf1437559dc205bfec0fa Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 16 Sep 2011 18:18:58 +0000
Subject: Revise tests.  You can't robustly thread::release a thread that's not
 thread::wait-ing

---
 tests/unixNotfy.test | 6 ++----
 1 file changed, 2 insertions(+), 4 deletions(-)

diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index 9684bfe..2a17098 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -69,9 +69,8 @@ test unixNotfy-2.1 {Tcl_DeleteFileHandler} \
 	fileevent $f writable {set x 1}
 	vwait x
 	close $f
-   	set t [thread::create -preserved "thread::send [thread::id] {set x ok}"]
+   	thread::create "thread::send [thread::id] {set x ok}"
 	vwait x
-	thread::release $t
 	set x
     } \
     -result {ok} \
@@ -91,9 +90,8 @@ test unixNotfy-2.2 {Tcl_DeleteFileHandler} \
 	close $f1
 	vwait y
 	close $f2
-   	set t [thread::create -preserved "thread::send [thread::id] {set x ok}"]
+   	thread::create "thread::send [thread::id] {set x ok}"
 	vwait x
-	thread::release $t
 	set x
     } \
     -result {ok} \
-- 
cgit v0.12


From 18492c312190b67e04959f7245dd3821b3222702 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Sun, 18 Sep 2011 19:10:11 +0000
Subject: Revise the tests that confront background flush on close across
 threads. Need cleanup code to bring an end to the otherwise endless loop of
 thread finalization that continually tries to flush before closing, and is
 continually thwarted by a driver raising EAGAIN.  If this dance isn't cleanly
 terminated, it continues and corrupts any subsequent tests that define a
 [foo] command.

---
 tests/ioCmd.test | 11 +++++++----
 1 file changed, 7 insertions(+), 4 deletions(-)

diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index f749b46..c46dc26 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -2575,9 +2575,10 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi
     } c]
     set res
 } -cleanup {
+    proc foo {args} {onfinal; set ::done-24.15 1; return 3}
+    vwait done-24.15
     rename foo {}
     unset res
-    update
 } -result {{write rc* ABC} {watch rc* write} {}} \
     -constraints {testchannel thread}
 
@@ -2601,15 +2602,17 @@ test iocmd.tf-24.16 {chan write, note the background flush setup by close due to
     } c]
     # Replace handler with all-tracking one which doesn't error.
     # This will tell us if a write-due-flush is there.
-    proc foo {args} { note BG ; track }
+    proc foo {args} { onfinal; note BG ; track ; set ::endbody-24.16 1}
     # Flush (sic!) the event-queue to capture the write from a
     # BG-flush.
-    update
+    vwait endbody-24.16
     set res
 } -cleanup {
+    proc foo {args} {onfinal; set ::done-24.16 1; return 3}
+    vwait done-24.16
     rename foo {}
     unset res
-} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC} BG {finalize rc*}} \
+} -result {{write rc* ABC} {watch rc* write} {} BG {write rc* ABC}} \
     -constraints {testchannel thread}
 
 # --- === *** ###########################
-- 
cgit v0.12


From 4e8954188850061d06183ad502d35b9b38db1f50 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 19 Sep 2011 10:57:40 +0000
Subject: Plug a number of MarshallError memleaks.

---
 generic/tclIORChan.c | 12 +++++++++---
 tests/ioCmd.test     |  5 -----
 2 files changed, 9 insertions(+), 8 deletions(-)

diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 846618c..acf7365 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -2927,7 +2927,9 @@ ForwardProc(
 	    int written;
 
 	    if (Tcl_GetIntFromObj(interp, resObj, &written) != TCL_OK) {
-		ForwardSetObjError(paramPtr, MarshallError(interp));
+		Tcl_DecrRefCount(resObj);
+		resObj = MarshallError(interp);
+		ForwardSetObjError(paramPtr, resObj);
 		paramPtr->output.toWrite = -1;
 	    } else if (written==0 || paramPtr->output.toWrite<written) {
 		ForwardSetStaticError(paramPtr, msg_write_toomuch);
@@ -2970,7 +2972,9 @@ ForwardProc(
 		    paramPtr->seek.offset = newLoc;
 		}
 	    } else {
-		ForwardSetObjError(paramPtr, MarshallError(interp));
+		Tcl_DecrRefCount(resObj);
+		resObj = MarshallError(interp);
+		ForwardSetObjError(paramPtr, resObj);
 		paramPtr->seek.offset = -1;
 	    }
 	}
@@ -3061,7 +3065,9 @@ ForwardProc(
 
 	    if (Tcl_ListObjGetElements(interp, resObj, &listc,
                                        &listv) != TCL_OK) {
-		ForwardSetObjError(paramPtr, MarshallError(interp));
+		Tcl_DecrRefCount(resObj);
+		resObj = MarshallError(interp);
+		ForwardSetObjError(paramPtr, resObj);
 	    } else if ((listc % 2) == 1) {
 		/*
 		 * Odd number of elements is wrong. [x].
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index c46dc26..d45f7aa 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -2508,7 +2508,6 @@ test iocmd.tf-24.11 {chan write, failed write, custom return is error} -match gl
 } -result {{write rc* snarfsnarfsnarf} 1 *bad code*} \
     -constraints {testchannel thread}
 test iocmd.tf-24.12 {chan write, failed write, non-numeric return is error} -match glob -body {
-#LEAKS!
     set res {}
     proc foo {args} {oninit; onfinal; track; return BANG}
     set c [chan create {r w} foo]
@@ -2583,7 +2582,6 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi
     -constraints {testchannel thread}
 
 test iocmd.tf-24.16 {chan write, note the background flush setup by close due to the EAGAIN leaving data in buffers.} -match glob -setup {
-#LEAKS!
     set res {}
     proc foo {args} {
 	oninit; onfinal; track
@@ -2677,7 +2675,6 @@ test iocmd.tf-25.4 {chan configure, cgetall, bad result, list of uneven length}
     set res
 } -constraints {testchannel thread} -result {{cgetall rc*} 1 {Expected list with even number of elements, got 1 element instead}}
 test iocmd.tf-25.5 {chan configure, cgetall, bad result, not a list} -match glob -body {
-#LEAKS!
     set res {}
     proc foo {args} {
 	oninit cget cgetall; onfinal; track
@@ -3110,7 +3107,6 @@ test iocmd.tf-28.8 {chan tell, negative return} -match glob -body {
 } -result {{seek rc* 0 current} 1 {Tried to seek before origin}} \
     -constraints {testchannel thread}
 test iocmd.tf-28.9 {chan tell, string return} -match glob -body {
-#LEAKS!
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return BOGUS}
     set c [chan create {r w} foo]
@@ -3224,7 +3220,6 @@ test iocmd.tf-28.16 {chan seek, bogus return, negative location} -match glob -bo
 } -result {{seek rc* 0 start} 1 {Tried to seek before origin}} \
     -constraints {testchannel thread}
 test iocmd.tf-28.17 {chan seek, bogus return, string return} -match glob -body {
-#LEAKS!
     set res {}
     proc foo {args} {oninit seek; onfinal; track; return BOGUS}
     set c [chan create {r w} foo]
-- 
cgit v0.12


From bd3d162f011f2a5728eaffba2ad513bf15d6d3e6 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 19 Sep 2011 14:41:22 +0000
Subject: Plug leak of a ReflectedChannel in test iocmd.tf-32.0

---
 generic/tclIORChan.c | 58 ++++++++++++++++++++++++++++++++--------------------
 1 file changed, 36 insertions(+), 22 deletions(-)

diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index acf7365..da6f642 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -1066,15 +1066,9 @@ ReflectClose(
 	    ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p);
 	    result = p.base.code;
 
-	    /*
-	     * FreeReflectedChannel is done in the forwarded operation!, in
-	     * the other thread. rcPtr here is gone!
-	     */
-
 	    if (result != TCL_OK) {
 		FreeReceivedError(&p);
 	    }
-	    return EOK;
 	}
 #endif
 
@@ -1105,10 +1099,7 @@ ReflectClose(
 	ForwardOpToOwnerThread(rcPtr, ForwardedClose, &p);
 	result = p.base.code;
 
-	/*
-	 * FreeReflectedChannel is done in the forwarded operation!, in the
-	 * other thread. rcPtr here is gone!
-	 */
+        Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
 
 	if (result != TCL_OK) {
 	    PassReceivedErrorInterp(interp, &p);
@@ -2130,21 +2121,14 @@ NextHandle(void)
 }
 
 static void
-FreeReflectedChannel(
+FreeReflectedChannelArgs(
     ReflectedChannel *rcPtr)
 {
-    Channel *chanPtr = (Channel *) rcPtr->chan;
-    int i, n;
-
-    if (chanPtr->typePtr != &tclRChannelType) {
-	/*
-	 * Delete a cloned ChannelType structure.
-	 */
+    int i, n = rcPtr->argc - 2;
 
-	ckfree(chanPtr->typePtr);
+    if (n < 0) {
+	return;
     }
-
-    n = rcPtr->argc - 2;
     for (i=0; i<n; i++) {
 	Tcl_DecrRefCount(rcPtr->argv[i]);
     }
@@ -2155,6 +2139,25 @@ FreeReflectedChannel(
 
     Tcl_DecrRefCount(rcPtr->argv[n+1]);
 
+    rcPtr->argc = 1;
+}
+
+static void
+FreeReflectedChannel(
+    ReflectedChannel *rcPtr)
+{
+    Channel *chanPtr = (Channel *) rcPtr->chan;
+
+    if (chanPtr->typePtr != &tclRChannelType) {
+	/*
+	 * Delete a cloned ChannelType structure.
+	 */
+
+	ckfree(chanPtr->typePtr);
+    }
+
+    FreeReflectedChannelArgs(rcPtr);
+
     ckfree(rcPtr->argv);
     ckfree(rcPtr);
 }
@@ -2506,6 +2509,11 @@ DeleteReflectedChannelMap(
 	 */
 
 	evPtr = resultPtr->evPtr;
+
+	/* Basic crash safety until this routine can get revised [3411310] */
+	if (evPtr == NULL) {
+	    continue;
+	}
 	paramPtr = evPtr->param;
 
 	evPtr->resultPtr = NULL;
@@ -2639,6 +2647,11 @@ DeleteThreadReflectedChannelMap(
 	 */
 
 	evPtr = resultPtr->evPtr;
+
+	/* Basic crash safety until this routine can get revised [3411310] */
+	if (evPtr == NULL ) {
+	    continue;
+	}
 	paramPtr = evPtr->param;
 
 	evPtr->resultPtr = NULL;
@@ -2665,6 +2678,7 @@ DeleteThreadReflectedChannelMap(
 	ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);
 
 	rcPtr->interp = NULL;
+	FreeReflectedChannelArgs(rcPtr);
 	Tcl_DeleteHashEntry(hPtr);
     }
     ckfree(rcmPtr);
@@ -2862,7 +2876,7 @@ ForwardProc(
                                  Tcl_GetChannelName(rcPtr->chan));
 	Tcl_DeleteHashEntry(hPtr);
 
-        Tcl_EventuallyFree (rcPtr, (Tcl_FreeProc *) FreeReflectedChannel);
+	FreeReflectedChannelArgs(rcPtr);
 	break;
 
     case ForwardedInput: {
-- 
cgit v0.12


From 12b5a6914cc9a4c32cdcd7090cc77ddff8788e66 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 19 Sep 2011 15:26:24 +0000
Subject: Constrain test iocmd.tf-32.1 to be skipped during valgrinding.  It
 contains a memory leak that cannot be plugged while testing what the test
 aims to test.

---
 tests/ioCmd.test | 19 +++++++++++++++----
 unix/Makefile.in |  2 +-
 2 files changed, 16 insertions(+), 5 deletions(-)

diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index d45f7aa..4c08229 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -3510,7 +3510,6 @@ test iocmd.tf-31.8 {chan postevent, bad input} -match glob -body {
 # B. Must not crash, must return proper errors.
 
 test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
-#LEAKS!
 
     #puts <<$tcltest::mainThread>>main
     set tida [thread::create -preserved];#puts <<$tida>>
@@ -3548,8 +3547,20 @@ test iocmd.tf-32.0 {origin thread of moved channel gone} -match glob -body {
 } -constraints {testchannel thread} \
     -result {1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
 
+
+# The test iocmd.tf-32.1 unavoidably exhibits a memory leak.  We are testing
+# the ability of the reflected channel system to react to the situation where
+# the thread in which the driver routines runs exits during driver operations.
+# In this case, thread exit handlers signal back to the owner thread so that the 
+# channel operation does not hang.  There's no way to test this without actually
+# exiting a thread in mid-operation, and that action is unavoidably leaky (which
+# is why [thread::exit] is advised against).
+#
+# Use constraints to skip this test while valgrinding so this expected leak
+# doesn't prevent a finding of "leak-free".
+#
+testConstraint notValgrind [expr {![testConstraint valgrind]}]
 test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -match glob -body {
-#LEAKS!
 
     #puts <<$tcltest::mainThread>>main
     set tida [thread::create -preserved];#puts <<$tida>>
@@ -3564,7 +3575,7 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat
 	    oninit; onfinal; track;
 	    # destroy thread during channel access
 	    thread::exit
-	    return}
+	    }
 	set chan [chan create {r w} foo]
 	fconfigure $chan -buffering none
 	set chan
@@ -3592,7 +3603,7 @@ test iocmd.tf-32.1 {origin thread of moved channel destroyed during access} -mat
     catch {thread::release $tida}
     thread::release $tidb
     set res
-} -constraints {testchannel thread} \
+} -constraints {testchannel thread notValgrind} \
     -result {Owner lost}
 
 # ### ### ### ######### ######### #########
diff --git a/unix/Makefile.in b/unix/Makefile.in
index b3507ba..5014ccb 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -738,7 +738,7 @@ gdb: ${TCL_EXE}
 	$(SHELL_ENV) $(GDB) ./${TCL_EXE}
 
 valgrind: ${TCL_EXE} ${TCLTEST_EXE}
-	$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl -singleproc 1 $(TESTFLAGS)
+	$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCLTEST_EXE} $(TOP_DIR)/tests/all.tcl -singleproc 1 -constraints valgrind $(TESTFLAGS)
 
 valgrindshell: ${TCL_EXE}
 	$(SHELL_ENV) $(VALGRIND) $(VALGRINDARGS) ./${TCL_EXE} $(SCRIPT)
-- 
cgit v0.12


From e2635d6143eba18faa11cd18025a53f5ebd7620a Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 19 Sep 2011 20:30:56 +0000
Subject: Conversion from [testthread] to Thread package stops most memory
 leaks.

---
 ChangeLog            |   3 +
 generic/tclIORChan.c |   1 +
 tests/ioTrans.test   | 183 +++++++++++++++++++++++++--------------------------
 3 files changed, 93 insertions(+), 94 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 2691e4d..1325f72 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,8 @@
 2011-09-15  Don Porter  <dgp@users.sourceforge.net>
 
+	* tests/ioTrans.test:	Conversion from [testthread] to Thread package
+	stops most memory leaks.  
+
 	* tests/thread.test:	Plug most memory leaks in thread.test  Constrain
 	the rest to be skipped during `make valgrind`.  Tests using the
 	[testthread cancel] testing command are leaky.  Corrections wait for
diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index da6f642..61c8475 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -439,6 +439,7 @@ static ReflectedChannel * NewReflectedChannel(Tcl_Interp *interp,
 			    Tcl_Obj *cmdpfxObj, int mode, Tcl_Obj *handleObj);
 static Tcl_Obj *	NextHandle(void);
 static void		FreeReflectedChannel(ReflectedChannel *rcPtr);
+static void		FreeReflectedChannelArgs(ReflectedChannel *rcPtr);
 static int		InvokeTclMethod(ReflectedChannel *rcPtr,
 			    const char *method, Tcl_Obj *argOneObj,
 			    Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
diff --git a/tests/ioTrans.test b/tests/ioTrans.test
index d8defcc..7da4329 100644
--- a/tests/ioTrans.test
+++ b/tests/ioTrans.test
@@ -18,10 +18,10 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 
 # Custom constraints used in this file
 testConstraint testchannel [llength [info commands testchannel]]
-testConstraint testthread  [llength [info commands testthread]]
+testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 
 # testchannel cut|splice  Both needed to test the reflection in threads.
-# testthread  send 
+# thread::send
 
 #----------------------------------------------------------------------
 
@@ -1046,22 +1046,6 @@ test iortrans-11.2 {delete interp of reflected transform} -setup {
 ## gaps due to tests not applicable to forwarding are left to keep this
 ## association.
 
-# Duplicate of code in "thread.test", and "ioCmd.test". Find a better way of
-# doing this without duplication. Maybe placement into a proc which transforms
-# to nop after the first call, and placement of its defintion in a central
-# location.
-
-if {[testConstraint testthread]} {
-    testthread errorproc ThreadError
-    proc ThreadError {id info} {
-	global threadError
-	set threadError $info
-    }
-    proc ThreadNullError {id info} {
-	# ignore
-    }
-}
-
 # ### ### ### ######### ######### #########
 ## Helper command. Runs a script in a separate thread and returns the result.
 ## A channel is transfered into the thread as well, and a list of configuation
@@ -1069,7 +1053,8 @@ if {[testConstraint testthread]} {
 
 proc inthread {chan script args} {
     # Test thread.
-    set tid [testthread create]
+    set tid [thread::create -preserved]
+    thread::send $tid {load {} Tcltest}
 
     # Init thread configuration.
     # - Listed variables
@@ -1078,10 +1063,10 @@ proc inthread {chan script args} {
 
     foreach v $args {
 	upvar 1 $v x
-	testthread send $tid [list set $v $x]
+	thread::send $tid [list set $v $x]
     }
-    testthread send $tid [list set mid $tcltest::mainThread]
-    testthread send $tid {
+    thread::send $tid [list set mid [thread::id]]
+    thread::send $tid {
 	proc notes {} {
 	    return $::notes
 	}
@@ -1092,27 +1077,27 @@ proc inthread {chan script args} {
 	    } $opts]
 	}
     }
-    testthread send $tid [list proc s {} [list uplevel 1 $script]]; # (*)
+    thread::send $tid [list proc s {} [list uplevel 1 $script]]; # (*)
 
     # Transfer channel (cut/splice aka detach/attach)
 
     testchannel cut $chan
-    testthread send $tid [list testchannel splice $chan]
+    thread::send $tid [list testchannel splice $chan]
 
     # Run test script, also run local event loop!  The local event loop waits
     # for the result to come back.  It is also necessary for the execution of
     # forwarded channel operations.
 
     set ::tres ""
-    testthread send -async $tid {
+    thread::send -async $tid {	
 	after 50
 	catch {s} res;	# This runs the script, 's' was defined at (*)
-	testthread send -async $mid [list set ::tres $res]
+	thread::send -async $mid [list set ::tres $res]
     }
     vwait ::tres
     # Remove test thread, and return the captured result.
 
-    tcltest::threadReap
+    thread::release $tid
     return $::tres
 }
 
@@ -1120,7 +1105,7 @@ proc inthread {chan script args} {
 
 test iortrans.tf-3.2 {chan finalize, for close} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	lappend ::res $args
 	handle.initialize
@@ -1139,7 +1124,7 @@ test iortrans.tf-3.2 {chan finalize, for close} -setup {
 } -result {{initialize rt* {read write}} file* {finalize rt*} {} foo}
 test iortrans.tf-3.3 {chan finalize, for close, error, close error} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	lappend ::res $args
 	handle.initialize
@@ -1157,7 +1142,7 @@ test iortrans.tf-3.3 {chan finalize, for close, error, close error} -setup {
 } -result {{initialize rt* {read write}} file* {finalize rt*} 1 5 {}}
 test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	lappend ::res $args
 	handle.initialize
@@ -1173,7 +1158,7 @@ test iortrans.tf-3.4 {chan finalize, for close, error, close errror} -setup {
 } -result {{initialize rt* {read write}} file* {finalize rt*} 1 FOO}
 test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	lappend ::res $args
 	handle.initialize
@@ -1189,7 +1174,7 @@ test iortrans.tf-3.5 {chan finalize, for close, arbitrary result} -setup {
 } -result {{initialize rt* {read write}} file* {finalize rt*} 0 {}}
 test iortrans.tf-3.6 {chan finalize, for close, break, close error} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	lappend ::res $args
 	handle.initialize
@@ -1205,7 +1190,7 @@ test iortrans.tf-3.6 {chan finalize, for close, break, close error} -setup {
 } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
 test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	lappend ::res $args
 	handle.initialize
@@ -1221,7 +1206,7 @@ test iortrans.tf-3.7 {chan finalize, for close, continue, close error} -setup {
 } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
 test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	lappend ::res $args
 	handle.initialize
@@ -1237,7 +1222,7 @@ test iortrans.tf-3.8 {chan finalize, for close, custom code, close error} -setup
 } -result {{initialize rt* {read write}} file* {finalize rt*} 1 *bad code*}
 test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	lappend ::res $args
 	handle.initialize
@@ -1258,7 +1243,7 @@ test iortrans.tf-3.9 {chan finalize, for close, ignore level, close error} -setu
 
 test iortrans.tf-4.1 {chan read, transform call and return} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1278,7 +1263,7 @@ test iortrans.tf-4.1 {chan read, transform call and return} -setup {
 }} snarf}
 test iortrans.tf-4.2 {chan read, for non-readable channel} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1296,7 +1281,7 @@ test iortrans.tf-4.2 {chan read, for non-readable channel} -setup {
 } -match glob -result {1 {channel "file*" wasn't opened for reading}}
 test iortrans.tf-4.3 {chan read, error return} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1316,7 +1301,7 @@ test iortrans.tf-4.3 {chan read, error return} -setup {
 }} 1 BOOM!}
 test iortrans.tf-4.4 {chan read, break return is error} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1336,7 +1321,7 @@ test iortrans.tf-4.4 {chan read, break return is error} -setup {
 }} 1 *bad code*}
 test iortrans.tf-4.5 {chan read, continue return is error} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1356,7 +1341,7 @@ test iortrans.tf-4.5 {chan read, continue return is error} -setup {
 }} 1 *bad code*}
 test iortrans.tf-4.6 {chan read, custom return is error} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1376,7 +1361,7 @@ test iortrans.tf-4.6 {chan read, custom return is error} -setup {
 }} 1 *bad code*}
 test iortrans.tf-4.7 {chan read, level is squashed} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1401,7 +1386,7 @@ test iortrans.tf-4.7 {chan read, level is squashed} -setup {
 
 test iortrans.tf-5.1 {chan write, regular write} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1421,7 +1406,7 @@ test iortrans.tf-5.1 {chan write, regular write} -setup {
 } -result {{write rt* snarf} transformresult}
 test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1441,7 +1426,7 @@ test iortrans.tf-5.2 {chan write, no write is ok, no change to file} -setup {
 } -result {{write rt* snarfsnarfsnarf} {test data}}
 test iortrans.tf-5.3 {chan write, failed write} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1461,7 +1446,7 @@ test iortrans.tf-5.3 {chan write, failed write} -setup {
 } -result {{write rt* snarfsnarfsnarf} 1 FAIL!}
 test iortrans.tf-5.4 {chan write, non-writable channel} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1483,7 +1468,7 @@ test iortrans.tf-5.4 {chan write, non-writable channel} -setup {
 } -result {1 {channel "file*" wasn't opened for writing}}
 test iortrans.tf-5.5 {chan write, failed write, error return} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1505,7 +1490,7 @@ test iortrans.tf-5.5 {chan write, failed write, error return} -setup {
 } -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
 test iortrans.tf-5.6 {chan write, failed write, error return} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1527,7 +1512,7 @@ test iortrans.tf-5.6 {chan write, failed write, error return} -setup {
 } -result {{write rt* snarfsnarfsnarf} 1 BOOM!}
 test iortrans.tf-5.7 {chan write, failed write, break return is error} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1549,7 +1534,7 @@ test iortrans.tf-5.7 {chan write, failed write, break return is error} -setup {
 } -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
 test iortrans.tf-5.8 {chan write, failed write, continue return is error} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1570,7 +1555,7 @@ test iortrans.tf-5.8 {chan write, failed write, continue return is error} -setup
 } -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
 test iortrans.tf-5.9 {chan write, failed write, custom return is error} -setup {
     set res {}
-} -constraints {testchannel testthread} -body {
+} -constraints {testchannel thread} -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1592,7 +1577,7 @@ test iortrans.tf-5.9 {chan write, failed write, custom return is error} -setup {
 } -match glob -result {{write rt* snarfsnarfsnarf} 1 *bad code*}
 test iortrans.tf-5.10 {chan write, failed write, level is ignored} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize
 	handle.finalize
@@ -1619,7 +1604,7 @@ test iortrans.tf-5.10 {chan write, failed write, level is ignored} -setup {
 
 test iortrans.tf-6.1 {chan read, read limits} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize limit?
 	handle.finalize
@@ -1640,7 +1625,7 @@ test iortrans.tf-6.1 {chan read, read limits} -setup {
 }} {limit? rt*} @@}
 test iortrans.tf-6.2 {chan read, read transform drain on eof} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize drain
 	handle.finalize
@@ -1665,7 +1650,7 @@ test iortrans.tf-6.2 {chan read, read transform drain on eof} -setup {
 
 test iortrans.tf-7.1 {chan write, write clears read buffers} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize clear
 	handle.finalize
@@ -1686,7 +1671,7 @@ test iortrans.tf-7.1 {chan write, write clears read buffers} -setup {
 } -result {{clear rt*} {write rt* snarf}}
 test iortrans.tf-7.2 {seek clears read buffers} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize clear
 	handle.finalize
@@ -1705,7 +1690,7 @@ test iortrans.tf-7.2 {seek clears read buffers} -setup {
 } -result {{clear rt*}}
 test iortrans.tf-7.3 {clear, any result is ignored} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize clear
 	handle.finalize
@@ -1728,7 +1713,7 @@ test iortrans.tf-7.3 {clear, any result is ignored} -setup {
 
 test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize flush
 	handle.finalize
@@ -1755,7 +1740,7 @@ test iortrans.tf-8.1 {seek flushes write buffers, ignores data} -setup {
 } -result {{flush rt*} {flush rt*} | {} | {teXt data}}
 test iortrans.tf-8.2 {close flushes write buffers, writes data} -setup {
     set res {}
-} -constraints {testchannel testthread} -match glob -body {
+} -constraints {testchannel thread} -match glob -body {
     proc foo {args} {
 	handle.initialize flush
 	lappend ::res $args
@@ -1785,13 +1770,15 @@ test iortrans.tf-8.2 {close flushes write buffers, writes data} -setup {
 
 test iortrans.tf-11.0 {origin thread of moved transform gone} -setup {
     #puts <<$tcltest::mainThread>>main
-    set tida [testthread create];	#puts <<$tida>>
-    set tidb [testthread create];	#puts <<$tidb>>
-} -constraints {testchannel testthread} -match glob -body {
+    set tida [thread::create -preserved];	#puts <<$tida>>
+    thread::send $tida {load {} Tcltest}
+    set tidb [thread::create -preserved];	#puts <<$tida>>
+    thread::send $tidb {load {} Tcltest}
+} -constraints {testchannel thread} -match glob -body {
     # Set up channel in thread
-    testthread send $tida $helperscript
-    testthread send $tidb $helperscript
-    set chan [testthread send $tida {
+    thread::send $tida $helperscript
+    thread::send $tidb $helperscript
+    set chan [thread::send $tida {
 	proc foo {args} {
 	    handle.initialize clear drain flush limit? read write
 	    handle.finalize
@@ -1802,65 +1789,73 @@ test iortrans.tf-11.0 {origin thread of moved transform gone} -setup {
 	fconfigure $chan -buffering none
 	set chan
     }]
+
     # Move channel to 2nd thread, transform goes with it.
-    testthread send $tida [list testchannel cut $chan]
-    testthread send $tidb [list testchannel splice $chan]
+    thread::send $tida [list testchannel cut $chan]
+    thread::send $tidb [list testchannel splice $chan]
+
     # Kill origin thread, then access channel from 2nd thread.
-    testthread send -async $tida {testthread exit}
-    after 50
-    set res {}
-    lappend res [catch {testthread send $tidb [list puts $chan shoo]} msg] $msg
-    lappend res [catch {testthread send $tidb [list tell $chan]} msg] $msg
-    lappend res [catch {testthread send $tidb [list seek $chan 1]} msg] $msg
-    lappend res [catch {testthread send $tidb [list gets $chan]} msg] $msg
-    lappend res [catch {testthread send $tidb [list close $chan]} msg] $msg
+    thread::release -wait $tida
+
+    set res {}
+    lappend res [catch {thread::send $tidb [list puts $chan shoo]} msg] $msg
+    lappend res [catch {thread::send $tidb [list tell $chan]} msg] $msg
+    lappend res [catch {thread::send $tidb [list seek $chan 1]} msg] $msg
+    lappend res [catch {thread::send $tidb [list gets $chan]} msg] $msg
+    lappend res [catch {thread::send $tidb [list close $chan]} msg] $msg
     # The 'tell' is ok, as it passed through the transform to the base
     # channel without invoking the transform handler.
 } -cleanup {
-    testthread send $tidb tempdone
-    tcltest::threadReap
+    thread::send $tidb tempdone
+    thread::release $tidb
 } -result {1 {Owner lost} 0 0 1 {Owner lost} 1 {Owner lost} 1 {Owner lost}}
+
+testConstraint notValgrind [expr {![testConstraint valgrind]}]
+
 test iortrans.tf-11.1 {origin thread of moved transform destroyed during access} -setup {
     #puts <<$tcltest::mainThread>>main
-    set tida [testthread create];	#puts <<$tida>>
-    set tidb [testthread create];	#puts <<$tidb>>
-} -constraints {testchannel testthread} -match glob -body {
+    set tida [thread::create -preserved];	#puts <<$tida>>
+    thread::send $tida {load {} Tcltest}
+    set tidb [thread::create -preserved];	#puts <<$tidb>>
+    thread::send $tidb {load {} Tcltest}
+} -constraints {testchannel thread notValgrind} -match glob -body {
     # Set up channel in thread
-    testthread send $tida $helperscript
-    testthread send $tidb $helperscript
-    set chan [testthread send $tida {
+    thread::send $tida $helperscript
+    thread::send $tidb $helperscript
+    set chan [thread::send $tida {
 	proc foo {args} {
 	    handle.initialize clear drain flush limit? read write
 	    handle.finalize
 	    lappend ::res $args
 	    # destroy thread during channel access
-	    testthread exit
-	    return
+	    thread::exit
 	}
 	set chan [chan push [tempchan] foo]
 	fconfigure $chan -buffering none
 	set chan
     }]
+
     # Move channel to 2nd thread, transform goes with it.
-    testthread send $tida [list testchannel cut $chan]
-    testthread send $tidb [list testchannel splice $chan]
+    thread::send $tida [list testchannel cut $chan]
+    thread::send $tidb [list testchannel splice $chan]
+
     # Run access from thread B, wait for response from A (A is not using event
     # loop at this point, so the event pile up in the queue.
-    testthread send $tidb [list set chan $chan]
-    testthread send $tidb [list set mid $tcltest::mainThread]
-    testthread send -async $tidb {
+    thread::send $tidb [list set chan $chan]
+    thread::send $tidb [list set mid [thread::id]]
+    thread::send -async $tidb {
 	# Wait a bit, give the main thread the time to start its event loop to
 	# wait for the response from B
 	after 50
 	catch { puts $chan shoo } res
 	catch { close $chan }
-	testthread send -async $mid [list set ::res $res]
+	thread::send -async $mid [list set ::res $res]
     }
     vwait ::res
-    return $res
+    set res
 } -cleanup {
-    testthread send $tidb tempdone
-    tcltest::threadReap
+    thread::send $tidb tempdone
+    thread::release $tidb
 } -result {Owner lost}
 
 # ### ### ### ######### ######### #########
-- 
cgit v0.12


From 26d9f7564cf5104695a2ed6e6c418d358b436776 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 20 Sep 2011 13:42:27 +0000
Subject: Revised ReflectClose() and FreeReflectedTransform() so that we stop
 leaking ReflectedTransforms, yet free all Tcl_Obj values in the same thread
 that alloced them.

---
 ChangeLog             | 20 +++++++++------
 generic/tclIORTrans.c | 68 ++++++++++++++++++++++++++++++++-------------------
 2 files changed, 56 insertions(+), 32 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 1325f72..77bb046 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,14 +1,20 @@
-2011-09-15  Don Porter  <dgp@users.sourceforge.net>
+2011-09-20  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclIORTrans.c: Revised ReflectClose() and
+	FreeReflectedTransform() so that we stop leaking ReflectedTransforms,
+	yet free all Tcl_Obj values in the same thread that alloced them.
+
+2011-09-19  Don Porter  <dgp@users.sourceforge.net>
 
 	* tests/ioTrans.test:	Conversion from [testthread] to Thread package
 	stops most memory leaks.  
 
-	* tests/thread.test:	Plug most memory leaks in thread.test  Constrain
-	the rest to be skipped during `make valgrind`.  Tests using the
-	[testthread cancel] testing command are leaky.  Corrections wait for
-	either addition of [thread::cancel] to the Thread package, or improvements
-	to the [testthread] testing command to make leak-free versions of these
-	tests possible.
+	* tests/thread.test:	Plug most memory leaks in thread.test.
+	Constrain the rest to be skipped during `make valgrind`.  Tests using
+	the [testthread cancel] testing command are leaky.  Corrections wait
+	for either addition of [thread::cancel] to the Thread package, or
+	improvements to the [testthread] testing command to make leak-free
+	versions of these tests possible.
 
 	* generic/tclIORChan.c:	Plug all memory leaks in ioCmd.test exposed
 	* tests/ioCmd.test:	by `make valgrind`.
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index fa973c7..ef37d5c 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -407,6 +407,7 @@ static ReflectedTransform * NewReflectedTransform(Tcl_Interp *interp,
 			    Tcl_Channel parentChan);
 static Tcl_Obj *	NextHandle(void);
 static void		FreeReflectedTransform(ReflectedTransform *rtPtr);
+static void		FreeReflectedTransformArgs(ReflectedTransform *rtPtr);
 static int		InvokeTclMethod(ReflectedTransform *rtPtr,
 			    const char *method, Tcl_Obj *argOneObj,
 			    Tcl_Obj *argTwoObj, Tcl_Obj **resultObjPtr);
@@ -881,6 +882,7 @@ ReflectClose(
     Tcl_Interp *interp)
 {
     ReflectedTransform *rtPtr = clientData;
+    int errorCode, errorCodeSet = 0;
     int result;			/* Result code for 'close' */
     Tcl_Obj *resObj;		/* Result data for 'close' */
     ReflectedTransformMap *rtmPtr;
@@ -912,15 +914,9 @@ ReflectClose(
 	    ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
 	    result = p.base.code;
 
-	    /*
-	     * FreeReflectedTransform is done in the forwarded operation!, in
-	     * the other thread. rtPtr here is gone!
-	     */
-
 	    if (result != TCL_OK) {
 		FreeReceivedError(&p);
 	    }
-	    return EOK;
 	}
 #endif
 
@@ -937,20 +933,30 @@ ReflectClose(
      */
 
     if (HAS(rtPtr->methods, METH_DRAIN) && !rtPtr->readIsDrained) {
-	int errorCode;
-
 	if (!TransformDrain(rtPtr, &errorCode)) {
-	    Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
-	    return errorCode;
+#ifdef TCL_THREADS
+	    if (rtPtr->thread != Tcl_GetCurrentThread()) {
+		Tcl_EventuallyFree (rtPtr,
+			(Tcl_FreeProc *) FreeReflectedTransform);
+		return errorCode;
+	    } 
+#endif
+	    errorCodeSet = 1;
+	    goto cleanup;
 	}
     }
 
     if (HAS(rtPtr->methods, METH_FLUSH)) {
-	int errorCode;
-
 	if (!TransformFlush(rtPtr, &errorCode, FLUSH_WRITE)) {
-	    Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
-	    return errorCode;
+#ifdef TCL_THREADS
+	    if (rtPtr->thread != Tcl_GetCurrentThread()) {
+		Tcl_EventuallyFree (rtPtr,
+			(Tcl_FreeProc *) FreeReflectedTransform);
+		return errorCode;
+	    } 
+#endif
+	    errorCodeSet = 1;
+	    goto cleanup;
 	}
     }
 
@@ -965,10 +971,7 @@ ReflectClose(
 	ForwardOpToOwnerThread(rtPtr, ForwardedClose, &p);
 	result = p.base.code;
 
-	/*
-	 * FreeReflectedTransform is done in the forwarded operation!, in the
-	 * other thread. rtPtr here is gone!
-	 */
+	Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
 
 	if (result != TCL_OK) {
 	    PassReceivedErrorInterp(interp, &p);
@@ -990,6 +993,8 @@ ReflectClose(
     Tcl_DecrRefCount(resObj);	/* Remove reference we held from the
 				 * invoke. */
 
+  cleanup:
+
     /*
      * Remove the transform from the map before releasing the memory, to
      * prevent future accesses from finding and dereferencing a dangling
@@ -1026,7 +1031,7 @@ ReflectClose(
 #endif
 
     Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
-    return (result == TCL_OK) ? EOK : EINVAL;
+    return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL);
 }
 
 /*
@@ -1866,18 +1871,18 @@ NextHandle(void)
 }
 
 static void
-FreeReflectedTransform(
+FreeReflectedTransformArgs(
     ReflectedTransform *rtPtr)
 {
-    int i, n;
+    int i, n = rtPtr->argc - 2;
 
-    TimerKill(rtPtr);
-    ResultClear(&rtPtr->result);
+    if (n < 0) {
+	return;
+    }
 
     Tcl_DecrRefCount(rtPtr->handle);
     rtPtr->handle = NULL;
 
-    n = rtPtr->argc - 2;
     for (i=0; i<n; i++) {
 	Tcl_DecrRefCount(rtPtr->argv[i]);
     }
@@ -1888,6 +1893,18 @@ FreeReflectedTransform(
      */
     Tcl_DecrRefCount(rtPtr->argv[n+1]);
 
+    rtPtr->argc = 1;
+}
+
+static void
+FreeReflectedTransform(
+    ReflectedTransform *rtPtr)
+{
+    TimerKill(rtPtr);
+    ResultClear(&rtPtr->result);
+
+    FreeReflectedTransformArgs(rtPtr);
+
     ckfree(rtPtr->argv);
     ckfree(rtPtr);
 }
@@ -2337,6 +2354,7 @@ DeleteThreadReflectedTransformMap(
 	ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr);
 
 	rtPtr->interp = NULL;
+	FreeReflectedTransformArgs(rtPtr);
 	Tcl_DeleteHashEntry(hPtr);
     }
     ckfree(rtmPtr);
@@ -2541,7 +2559,7 @@ ForwardProc(
 	hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
 	Tcl_DeleteHashEntry(hPtr);
 
-	Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
+	FreeReflectedTransformArgs(rtPtr);
 	break;
 
     case ForwardedInput: {
-- 
cgit v0.12


From 4e2761163f1ad08f5ef986c9848cacd0be15088c Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 20 Sep 2011 17:33:59 +0000
Subject: Re-using the "interp" field to signal a dead channel (via NULL value)
 interfered with conditional cleanup tasks testing for "the right interp"
 Added a new field "dead" to perform the dead channel signalling task so the
 corrupted logic is avoided.

---
 generic/tclIORChan.c | 19 +++++++++++++------
 1 file changed, 13 insertions(+), 6 deletions(-)

diff --git a/generic/tclIORChan.c b/generic/tclIORChan.c
index 61c8475..49e2930 100644
--- a/generic/tclIORChan.c
+++ b/generic/tclIORChan.c
@@ -121,6 +121,9 @@ typedef struct {
     int interest;		/* Mask of events the channel is interested
 				 * in. */
 
+    int dead;			/* Boolean signal that some operations
+				 * should no longer be attempted. */
+
     /*
      * Note regarding the usage of timers.
      *
@@ -1128,7 +1131,7 @@ ReflectClose(
 	 * the per-interp DeleteReflectedChannelMap exit-handler.
 	 */
 
-	if (rcPtr->interp) {
+	if (!rcPtr->dead) {
 	    rcmPtr = GetReflectedChannelMap(rcPtr->interp);
 	    hPtr = Tcl_FindHashEntry(&rcmPtr->map,
 		    Tcl_GetChannelName(rcPtr->chan));
@@ -2022,6 +2025,7 @@ NewReflectedChannel(
     rcPtr->chan = NULL;
     rcPtr->methods = 0;
     rcPtr->interp = interp;
+    rcPtr->dead = 0;
 #ifdef TCL_THREADS
     rcPtr->thread = Tcl_GetCurrentThread();
 #endif
@@ -2155,6 +2159,7 @@ FreeReflectedChannel(
 	 */
 
 	ckfree(chanPtr->typePtr);
+	chanPtr->typePtr = NULL;
     }
 
     FreeReflectedChannelArgs(rcPtr);
@@ -2201,7 +2206,7 @@ InvokeTclMethod(
     int result;			/* Result code of method invokation */
     Tcl_Obj *resObj = NULL;	/* Result of method invokation. */
 
-    if (!rcPtr->interp) {
+    if (rcPtr->dead) {
 	/*
 	 * The channel is marked as dead. Bail out immediately, with an
 	 * appropriate error.
@@ -2365,7 +2370,7 @@ ErrnoReturn(
     int code;
     Tcl_InterpState sr;		/* State of handler interp */
 
-    if (!rcPtr->interp) {
+    if (rcPtr->dead) {
 	return 0;
     }
 
@@ -2474,7 +2479,7 @@ DeleteReflectedChannelMap(
 	chan = Tcl_GetHashValue(hPtr);
 	rcPtr = Tcl_GetChannelInstanceData(chan);
 
-	rcPtr->interp = NULL;
+	rcPtr->dead = 1;
 	Tcl_DeleteHashEntry(hPtr);
     }
     Tcl_DeleteHashTable(&rcmPtr->map);
@@ -2549,6 +2554,8 @@ DeleteReflectedChannelMap(
 	    continue;
 	}
 
+	rcPtr->dead = 1;
+	FreeReflectedChannelArgs(rcPtr);
 	Tcl_DeleteHashEntry(hPtr);
     }
 #endif
@@ -2678,7 +2685,7 @@ DeleteThreadReflectedChannelMap(
 	Tcl_Channel chan = Tcl_GetHashValue(hPtr);
 	ReflectedChannel *rcPtr = Tcl_GetChannelInstanceData(chan);
 
-	rcPtr->interp = NULL;
+	rcPtr->dead = 1;
 	FreeReflectedChannelArgs(rcPtr);
 	Tcl_DeleteHashEntry(hPtr);
     }
@@ -2702,7 +2709,7 @@ ForwardOpToOwnerThread(
 
     Tcl_MutexLock(&rcForwardMutex);
 
-    if (rcPtr->interp == NULL) {
+    if (rcPtr->dead) {
 	/*
 	 * The channel is marked as dead. Bail out immediately, with an
 	 * appropriate error. Do not forget to unlock the mutex on this path.
-- 
cgit v0.12


From 001194b2f601a85d1bf25104766cca3a02ea9df8 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 20 Sep 2011 17:45:09 +0000
Subject: ChangeLog entry

---
 ChangeLog | 5 +++++
 1 file changed, 5 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 77bb046..360e527 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,10 @@
 2011-09-20  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclIORChan.c: Re-using the "interp" field to signal a dead
+	channel (via NULL value) interfered with conditional cleanup tasks
+	testing for "the right interp". Added a new field "dead" to perform
+	the dead channel signalling task so the corrupted logic is avoided.
+
 	* generic/tclIORTrans.c: Revised ReflectClose() and
 	FreeReflectedTransform() so that we stop leaking ReflectedTransforms,
 	yet free all Tcl_Obj values in the same thread that alloced them.
-- 
cgit v0.12


From f250b157359a2a80012fd92403a0c220aa5806c3 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 21 Sep 2011 08:00:22 +0000
Subject: Remove constraint on test which apparently passes

---
 tests/namespace.test | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/namespace.test b/tests/namespace.test
index f4e50bc..f07d8cf 100644
--- a/tests/namespace.test
+++ b/tests/namespace.test
@@ -2480,7 +2480,7 @@ test namespace-51.16 {Bug 1566526} {
 test namespace-51.17 {resolution epoch handling: Bug 2898722} -setup {
     set result {}
     catch {namespace delete ::a}
-} -constraints knownBug -body {
+} -body {
     namespace eval ::a {
 	proc c {} {lappend ::result A}
 	c
-- 
cgit v0.12


From a0be13178d26ced495715bbc7055f853d2014b4e Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 21 Sep 2011 11:48:16 +0000
Subject: FRQ 3010352 implementation

---
 generic/tclOO.decls     |  2 +-
 generic/tclOODecls.h    | 75 +++++++++++++++++++++++--------------------------
 generic/tclOOIntDecls.h | 49 +++++++++++++++-----------------
 3 files changed, 58 insertions(+), 68 deletions(-)

diff --git a/generic/tclOO.decls b/generic/tclOO.decls
index 027dcd0..31d1113 100644
--- a/generic/tclOO.decls
+++ b/generic/tclOO.decls
@@ -6,7 +6,7 @@ library tclOO
 
 interface tclOO
 hooks tclOOInt
-scspec EXTERN
+scspec TCLOOAPI
 
 declare 0 {
     Tcl_Object Tcl_CopyObjectInstance(Tcl_Interp *interp,
diff --git a/generic/tclOODecls.h b/generic/tclOODecls.h
index 80a10bb..5e48b0b 100644
--- a/generic/tclOODecls.h
+++ b/generic/tclOODecls.h
@@ -5,14 +5,13 @@
 #ifndef _TCLOODECLS
 #define _TCLOODECLS
 
-#undef TCL_STORAGE_CLASS
-#ifdef BUILD_tcl
-#   define TCL_STORAGE_CLASS DLLEXPORT
-#else
-#   ifdef USE_TCL_STUBS
-#      define TCL_STORAGE_CLASS
+#ifndef TCLOOAPI
+#   ifdef BUILD_tcl
+#	define TCLOOAPI MODULE_SCOPE
 #   else
-#      define TCL_STORAGE_CLASS DLLIMPORT
+#	define TCLOOAPI extern
+#	undef USE_TCLOO_STUBS
+#	define USE_TCLOO_STUBS 1
 #   endif
 #endif
 
@@ -37,92 +36,92 @@ extern const char *TclOOInitializeStubs(Tcl_Interp *, const char *version);
  */
 
 /* 0 */
-EXTERN Tcl_Object	Tcl_CopyObjectInstance(Tcl_Interp *interp,
+TCLOOAPI Tcl_Object	Tcl_CopyObjectInstance(Tcl_Interp *interp,
 				Tcl_Object sourceObject,
 				const char *targetName,
 				const char *targetNamespaceName);
 /* 1 */
-EXTERN Tcl_Object	Tcl_GetClassAsObject(Tcl_Class clazz);
+TCLOOAPI Tcl_Object	Tcl_GetClassAsObject(Tcl_Class clazz);
 /* 2 */
-EXTERN Tcl_Class	Tcl_GetObjectAsClass(Tcl_Object object);
+TCLOOAPI Tcl_Class	Tcl_GetObjectAsClass(Tcl_Object object);
 /* 3 */
-EXTERN Tcl_Command	Tcl_GetObjectCommand(Tcl_Object object);
+TCLOOAPI Tcl_Command	Tcl_GetObjectCommand(Tcl_Object object);
 /* 4 */
-EXTERN Tcl_Object	Tcl_GetObjectFromObj(Tcl_Interp *interp,
+TCLOOAPI Tcl_Object	Tcl_GetObjectFromObj(Tcl_Interp *interp,
 				Tcl_Obj *objPtr);
 /* 5 */
-EXTERN Tcl_Namespace *	Tcl_GetObjectNamespace(Tcl_Object object);
+TCLOOAPI Tcl_Namespace * Tcl_GetObjectNamespace(Tcl_Object object);
 /* 6 */
-EXTERN Tcl_Class	Tcl_MethodDeclarerClass(Tcl_Method method);
+TCLOOAPI Tcl_Class	Tcl_MethodDeclarerClass(Tcl_Method method);
 /* 7 */
-EXTERN Tcl_Object	Tcl_MethodDeclarerObject(Tcl_Method method);
+TCLOOAPI Tcl_Object	Tcl_MethodDeclarerObject(Tcl_Method method);
 /* 8 */
-EXTERN int		Tcl_MethodIsPublic(Tcl_Method method);
+TCLOOAPI int		Tcl_MethodIsPublic(Tcl_Method method);
 /* 9 */
-EXTERN int		Tcl_MethodIsType(Tcl_Method method,
+TCLOOAPI int		Tcl_MethodIsType(Tcl_Method method,
 				const Tcl_MethodType *typePtr,
 				ClientData *clientDataPtr);
 /* 10 */
-EXTERN Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
+TCLOOAPI Tcl_Obj *	Tcl_MethodName(Tcl_Method method);
 /* 11 */
-EXTERN Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	Tcl_NewInstanceMethod(Tcl_Interp *interp,
 				Tcl_Object object, Tcl_Obj *nameObj,
 				int isPublic, const Tcl_MethodType *typePtr,
 				ClientData clientData);
 /* 12 */
-EXTERN Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
+TCLOOAPI Tcl_Method	Tcl_NewMethod(Tcl_Interp *interp, Tcl_Class cls,
 				Tcl_Obj *nameObj, int isPublic,
 				const Tcl_MethodType *typePtr,
 				ClientData clientData);
 /* 13 */
-EXTERN Tcl_Object	Tcl_NewObjectInstance(Tcl_Interp *interp,
+TCLOOAPI Tcl_Object	Tcl_NewObjectInstance(Tcl_Interp *interp,
 				Tcl_Class cls, const char *nameStr,
 				const char *nsNameStr, int objc,
 				Tcl_Obj *const *objv, int skip);
 /* 14 */
-EXTERN int		Tcl_ObjectDeleted(Tcl_Object object);
+TCLOOAPI int		Tcl_ObjectDeleted(Tcl_Object object);
 /* 15 */
-EXTERN int		Tcl_ObjectContextIsFiltering(
+TCLOOAPI int		Tcl_ObjectContextIsFiltering(
 				Tcl_ObjectContext context);
 /* 16 */
-EXTERN Tcl_Method	Tcl_ObjectContextMethod(Tcl_ObjectContext context);
+TCLOOAPI Tcl_Method	Tcl_ObjectContextMethod(Tcl_ObjectContext context);
 /* 17 */
-EXTERN Tcl_Object	Tcl_ObjectContextObject(Tcl_ObjectContext context);
+TCLOOAPI Tcl_Object	Tcl_ObjectContextObject(Tcl_ObjectContext context);
 /* 18 */
-EXTERN int		Tcl_ObjectContextSkippedArgs(
+TCLOOAPI int		Tcl_ObjectContextSkippedArgs(
 				Tcl_ObjectContext context);
 /* 19 */
-EXTERN ClientData	Tcl_ClassGetMetadata(Tcl_Class clazz,
+TCLOOAPI ClientData	Tcl_ClassGetMetadata(Tcl_Class clazz,
 				const Tcl_ObjectMetadataType *typePtr);
 /* 20 */
-EXTERN void		Tcl_ClassSetMetadata(Tcl_Class clazz,
+TCLOOAPI void		Tcl_ClassSetMetadata(Tcl_Class clazz,
 				const Tcl_ObjectMetadataType *typePtr,
 				ClientData metadata);
 /* 21 */
-EXTERN ClientData	Tcl_ObjectGetMetadata(Tcl_Object object,
+TCLOOAPI ClientData	Tcl_ObjectGetMetadata(Tcl_Object object,
 				const Tcl_ObjectMetadataType *typePtr);
 /* 22 */
-EXTERN void		Tcl_ObjectSetMetadata(Tcl_Object object,
+TCLOOAPI void		Tcl_ObjectSetMetadata(Tcl_Object object,
 				const Tcl_ObjectMetadataType *typePtr,
 				ClientData metadata);
 /* 23 */
-EXTERN int		Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
+TCLOOAPI int		Tcl_ObjectContextInvokeNext(Tcl_Interp *interp,
 				Tcl_ObjectContext context, int objc,
 				Tcl_Obj *const *objv, int skip);
 /* 24 */
-EXTERN Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
+TCLOOAPI Tcl_ObjectMapMethodNameProc * Tcl_ObjectGetMethodNameMapper(
 				Tcl_Object object);
 /* 25 */
-EXTERN void		Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
+TCLOOAPI void		Tcl_ObjectSetMethodNameMapper(Tcl_Object object,
 				Tcl_ObjectMapMethodNameProc *mapMethodNameProc);
 /* 26 */
-EXTERN void		Tcl_ClassSetConstructor(Tcl_Interp *interp,
+TCLOOAPI void		Tcl_ClassSetConstructor(Tcl_Interp *interp,
 				Tcl_Class clazz, Tcl_Method method);
 /* 27 */
-EXTERN void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
+TCLOOAPI void		Tcl_ClassSetDestructor(Tcl_Interp *interp,
 				Tcl_Class clazz, Tcl_Method method);
 /* 28 */
-EXTERN Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
+TCLOOAPI Tcl_Obj *	Tcl_GetObjectName(Tcl_Interp *interp,
 				Tcl_Object object);
 
 typedef struct TclOOStubHooks {
@@ -240,8 +239,4 @@ extern const TclOOStubs *tclOOStubsPtr;
 #endif /* defined(USE_TCLOO_STUBS) */
 
 /* !END!: Do not edit above this line. */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
-
 #endif /* _TCLOODECLS */
diff --git a/generic/tclOOIntDecls.h b/generic/tclOOIntDecls.h
index b9600f2..49a43aa 100644
--- a/generic/tclOOIntDecls.h
+++ b/generic/tclOOIntDecls.h
@@ -5,14 +5,13 @@
 #ifndef _TCLOOINTDECLS
 #define _TCLOOINTDECLS
 
-#undef TCL_STORAGE_CLASS
-#ifdef BUILD_tcl
-#   define TCL_STORAGE_CLASS DLLEXPORT
-#else
-#   ifdef USE_TCL_STUBS
-#      define TCL_STORAGE_CLASS
+#ifndef TCLOOAPI
+#   ifdef BUILD_tcl
+#	define TCLOOAPI MODULE_SCOPE
 #   else
-#      define TCL_STORAGE_CLASS DLLIMPORT
+#	define TCLOOAPI extern
+#	undef USE_TCLOO_STUBS
+#	define USE_TCLOO_STUBS 1
 #   endif
 #endif
 
@@ -29,46 +28,46 @@
  */
 
 /* 0 */
-EXTERN Tcl_Object	TclOOGetDefineCmdContext(Tcl_Interp *interp);
+TCLOOAPI Tcl_Object	TclOOGetDefineCmdContext(Tcl_Interp *interp);
 /* 1 */
-EXTERN Tcl_Method	TclOOMakeProcInstanceMethod(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	TclOOMakeProcInstanceMethod(Tcl_Interp *interp,
 				Object *oPtr, int flags, Tcl_Obj *nameObj,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				const Tcl_MethodType *typePtr,
 				ClientData clientData, Proc **procPtrPtr);
 /* 2 */
-EXTERN Tcl_Method	TclOOMakeProcMethod(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	TclOOMakeProcMethod(Tcl_Interp *interp,
 				Class *clsPtr, int flags, Tcl_Obj *nameObj,
 				const char *namePtr, Tcl_Obj *argsObj,
 				Tcl_Obj *bodyObj,
 				const Tcl_MethodType *typePtr,
 				ClientData clientData, Proc **procPtrPtr);
 /* 3 */
-EXTERN Method *		TclOONewProcInstanceMethod(Tcl_Interp *interp,
+TCLOOAPI Method *	TclOONewProcInstanceMethod(Tcl_Interp *interp,
 				Object *oPtr, int flags, Tcl_Obj *nameObj,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				ProcedureMethod **pmPtrPtr);
 /* 4 */
-EXTERN Method *		TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
+TCLOOAPI Method *	TclOONewProcMethod(Tcl_Interp *interp, Class *clsPtr,
 				int flags, Tcl_Obj *nameObj,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				ProcedureMethod **pmPtrPtr);
 /* 5 */
-EXTERN int		TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
+TCLOOAPI int		TclOOObjectCmdCore(Object *oPtr, Tcl_Interp *interp,
 				int objc, Tcl_Obj *const *objv,
 				int publicOnly, Class *startCls);
 /* 6 */
-EXTERN int		TclOOIsReachable(Class *targetPtr, Class *startPtr);
+TCLOOAPI int		TclOOIsReachable(Class *targetPtr, Class *startPtr);
 /* 7 */
-EXTERN Method *		TclOONewForwardMethod(Tcl_Interp *interp,
+TCLOOAPI Method *	TclOONewForwardMethod(Tcl_Interp *interp,
 				Class *clsPtr, int isPublic,
 				Tcl_Obj *nameObj, Tcl_Obj *prefixObj);
 /* 8 */
-EXTERN Method *		TclOONewForwardInstanceMethod(Tcl_Interp *interp,
+TCLOOAPI Method *	TclOONewForwardInstanceMethod(Tcl_Interp *interp,
 				Object *oPtr, int isPublic, Tcl_Obj *nameObj,
 				Tcl_Obj *prefixObj);
 /* 9 */
-EXTERN Tcl_Method	TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
 				Tcl_Object oPtr,
 				TclOO_PreCallProc *preCallPtr,
 				TclOO_PostCallProc *postCallPtr,
@@ -77,7 +76,7 @@ EXTERN Tcl_Method	TclOONewProcInstanceMethodEx(Tcl_Interp *interp,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				int flags, void **internalTokenPtr);
 /* 10 */
-EXTERN Tcl_Method	TclOONewProcMethodEx(Tcl_Interp *interp,
+TCLOOAPI Tcl_Method	TclOONewProcMethodEx(Tcl_Interp *interp,
 				Tcl_Class clsPtr,
 				TclOO_PreCallProc *preCallPtr,
 				TclOO_PostCallProc *postCallPtr,
@@ -86,22 +85,22 @@ EXTERN Tcl_Method	TclOONewProcMethodEx(Tcl_Interp *interp,
 				Tcl_Obj *argsObj, Tcl_Obj *bodyObj,
 				int flags, void **internalTokenPtr);
 /* 11 */
-EXTERN int		TclOOInvokeObject(Tcl_Interp *interp,
+TCLOOAPI int		TclOOInvokeObject(Tcl_Interp *interp,
 				Tcl_Object object, Tcl_Class startCls,
 				int publicPrivate, int objc,
 				Tcl_Obj *const *objv);
 /* 12 */
-EXTERN void		TclOOObjectSetFilters(Object *oPtr, int numFilters,
+TCLOOAPI void		TclOOObjectSetFilters(Object *oPtr, int numFilters,
 				Tcl_Obj *const *filters);
 /* 13 */
-EXTERN void		TclOOClassSetFilters(Tcl_Interp *interp,
+TCLOOAPI void		TclOOClassSetFilters(Tcl_Interp *interp,
 				Class *classPtr, int numFilters,
 				Tcl_Obj *const *filters);
 /* 14 */
-EXTERN void		TclOOObjectSetMixins(Object *oPtr, int numMixins,
+TCLOOAPI void		TclOOObjectSetMixins(Object *oPtr, int numMixins,
 				Class *const *mixins);
 /* 15 */
-EXTERN void		TclOOClassSetMixins(Tcl_Interp *interp,
+TCLOOAPI void		TclOOClassSetMixins(Tcl_Interp *interp,
 				Class *classPtr, int numMixins,
 				Class *const *mixins);
 
@@ -177,8 +176,4 @@ extern const TclOOIntStubs *tclOOIntStubsPtr;
 #endif /* defined(USE_TCLOO_STUBS) */
 
 /* !END!: Do not edit above this line. */
-
-#undef TCL_STORAGE_CLASS
-#define TCL_STORAGE_CLASS DLLIMPORT
-
 #endif /* _TCLOOINTDECLS */
-- 
cgit v0.12


From fa18389469985cb82730db620495c814e434e619 Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Wed, 21 Sep 2011 17:13:53 +0000
Subject: * generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the missing
 initialization of the 'dsti' field. Reported by Don Porter, on chat.

---
 ChangeLog             | 6 ++++++
 generic/tclIORTrans.c | 1 +
 2 files changed, 7 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 360e527..25a96be 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-09-21  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the
+	missing initialization of the 'dsti' field. Reported by Don
+	Porter, on chat.
+
 2011-09-20  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclIORChan.c: Re-using the "interp" field to signal a dead
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index ef37d5c..0617df3 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -2403,6 +2403,7 @@ ForwardOpToOwnerThread(
 
     resultPtr->src = Tcl_GetCurrentThread();
     resultPtr->dst = dst;
+    resultPtr->dsti = rtPtr->interp;
     resultPtr->done = NULL;
     resultPtr->result = -1;
     resultPtr->evPtr = evPtr;
-- 
cgit v0.12


From 55d006f52db784e77fdc99b6bcaceeae689da92c Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Wed, 21 Sep 2011 20:54:26 +0000
Subject: [Bug 3412487]: Now short reads are allowed in synchronous fcopy,
 avoid mistaking them as nonblocking ones.

---
 ChangeLog       | 5 +++++
 generic/tclIO.c | 4 ++--
 2 files changed, 7 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 25a96be..836b43f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-09-21  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* unix/tclIO.c: [Bug 3412487]: Now short reads are allowed in
+	synchronous fcopy, avoid mistaking them as nonblocking ones.
+
 2011-09-21  Andreas Kupries  <andreask@activestate.com>
 
 	* generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the
diff --git a/generic/tclIO.c b/generic/tclIO.c
index ae1b89a..082cf70 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -9215,8 +9215,8 @@ CopyData(
 	    if ((size == 0) && Tcl_Eof(inChan) && !(cmdPtr && (mask == 0))) {
 		break;
 	    }
-	    if (((!Tcl_Eof(inChan)) || (cmdPtr && (mask == 0))) &&
-		    !(mask & TCL_READABLE)) {
+	    if (cmdPtr && (!Tcl_Eof(inChan) || (mask == 0)) &&
+                !(mask & TCL_READABLE)) {
 		if (mask & TCL_WRITABLE) {
 		    Tcl_DeleteChannelHandler(outChan, CopyEventProc, csPtr);
 		}
-- 
cgit v0.12


From e82d81e2a36cc9b0e6a0d3024f072ff8c588cc7f Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 21 Sep 2011 21:45:54 +0000
Subject: Revise the thread exit handling of the [testthread] command so that
 it properly maintains the per-process data structures even when the thread
 exits for reasons other than the [testthread exit] command.

---
 ChangeLog               |  7 +++++++
 generic/tclThreadTest.c | 12 +++++++++---
 tests/thread.test       |  1 -
 3 files changed, 16 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 836b43f..85119ca 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-09-21  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclThreadTest.c: Revise the thread exit handling of the
+	[testthread] command so that it properly maintains the per-process
+	data structures even when the thread exits for reasons other than
+	the [testthread exit] command.
+
 2011-09-21  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	* unix/tclIO.c: [Bug 3412487]: Now short reads are allowed in
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 71d5a66..3345081 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -46,7 +46,7 @@ static Tcl_ThreadDataKey dataKey;
  * protected by threadMutex.
  */
 
-static ThreadSpecificData *threadList;
+static ThreadSpecificData *threadList = NULL;
 
 /*
  * The following bit-values are legal for the "flags" field of the
@@ -623,9 +623,9 @@ NewTestThread(
      * Clean up.
      */
 
-    ListRemove(tsdPtr);
-    Tcl_Release(tsdPtr->interp);
     Tcl_DeleteInterp(tsdPtr->interp);
+    Tcl_Release(tsdPtr->interp);
+    ListRemove(tsdPtr);
     Tcl_ExitThread(result);
 
     TCL_THREAD_CREATE_RETURN;
@@ -744,6 +744,7 @@ ListRemove(
 	tsdPtr->nextPtr->prevPtr = tsdPtr->prevPtr;
     }
     tsdPtr->nextPtr = tsdPtr->prevPtr = 0;
+    tsdPtr->interp = NULL;
     Tcl_MutexUnlock(&threadMutex);
 }
 
@@ -1148,6 +1149,11 @@ ThreadExitProc(
     char *threadEvalScript = clientData;
     ThreadEventResult *resultPtr, *nextPtr;
     Tcl_ThreadId self = Tcl_GetCurrentThread();
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+    if (tsdPtr->interp != NULL) {
+	ListRemove(tsdPtr);
+    }
 
     Tcl_MutexLock(&threadMutex);
 
diff --git a/tests/thread.test b/tests/thread.test
index e818388..732f5fd 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -70,7 +70,6 @@ test thread-1.5 {Tcl_ThreadObjCmd: thread create one shot} {thread} {
     set l
 } {1}
 test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
-    threadReap
     thread::create {{*}{}}
     update
     after 10
-- 
cgit v0.12


From 163bd8d39b867eb56b871da18aac105c20e5c0d7 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 22 Sep 2011 12:00:18 +0000
Subject: typo

---
 unix/Makefile.in | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/unix/Makefile.in b/unix/Makefile.in
index 5014ccb..a2ade1d 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -468,7 +468,7 @@ OO_SRCS = \
 STUB_SRCS = \
 	$(GENERIC_DIR)/tclStubLib.c \
 	$(GENERIC_DIR)/tclTomMathStubLib.c \
-	$(GENERIC_DIR)/tclOOStubLib.o
+	$(GENERIC_DIR)/tclOOStubLib.c
 
 TOMMATH_SRCS = \
 	$(TOMMATH_DIR)/bncore.c \
-- 
cgit v0.12


From f1367943a944acec1363cae14f2dd5a6f261f8f9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 22 Sep 2011 14:05:16 +0000
Subject: [Bug 2903743]: Try to do the right thing when presented with
 old-style nroff.

---
 ChangeLog                      |  7 +++++++
 doc/re_syntax.n                |  8 +++++---
 tools/tcltk-man2html-utils.tcl | 33 +++++++--------------------------
 tools/tcltk-man2html.tcl       | 30 ++++++++++++++++--------------
 4 files changed, 35 insertions(+), 43 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 85119ca..5dd2fb8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-09-22  Donal K. Fellows  <dkf@users.sf.net>
+
+	* doc/re_syntax.n: [Bug 2903743]: Add more magic so that we can do at
+	least something sane on Solaris.
+	* tools/tcltk-man2html-utils.tcl (process-text): Teach the HTML
+	generator how to handle this magic.
+
 2011-09-21  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclThreadTest.c: Revise the thread exit handling of the
diff --git a/doc/re_syntax.n b/doc/re_syntax.n
index a53f58b..dacc41f 100644
--- a/doc/re_syntax.n
+++ b/doc/re_syntax.n
@@ -6,6 +6,8 @@
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 '\"
 .so man.macros
+.ie '\w'o''\w'\C'^o''' .ds qo \C'^o'
+.el .ds qo u
 .TH re_syntax n "8.1" Tcl "Tcl Built-In Commands"
 .BS
 .SH NAME
@@ -290,12 +292,12 @@ treatment is as if the enclosing delimiters were
 .QW \fB[.\fR \&
 and
 .QW \fB.]\fR .)
-For example, if \fBo\fR and \fB\N'244'\fR are the members of an
+For example, if \fBo\fR and \fB\*(qo\fR are the members of an
 equivalence class, then
 .QW \fB[[=o=]]\fR ,
-.QW \fB[[=\N'244'=]]\fR ,
+.QW \fB[[=\*(qo=]]\fR ,
 and
-.QW \fB[o\N'244']\fR \&
+.QW \fB[o\*(qo]\fR \&
 are all synonymous. An equivalence class may not be an endpoint of a range.
 .RS
 .PP
diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index 938a1af..ef1f62a 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -110,6 +110,7 @@ proc htmlize-text {text {charmap {}}} {
     # contains some extras for use in nroff->html processing
     # build on the list passed in, if any
     lappend charmap \
+	"&ndash;" "&ndash;" \
 	{&}	{&amp;} \
 	{\\}	"&#92;" \
 	{\e}	"&#92;" \
@@ -143,8 +144,8 @@ proc process-text {text} {
 	    {\fP}	{\fR} \
 	    {\.}	. \
 	    {\(bu}	"&#8226;" \
+	    {\*(qo}	"&ocirc;" \
 	    ]
-    lappend charmap {\o'o^'} {&ocirc;} ; # o-circumflex in re_syntax.n
     lappend charmap {\-\|\-} --        ; # two hyphens
     lappend charmap {\-} -             ; # a hyphen
 
@@ -1063,25 +1064,17 @@ proc output-directive {line} {
 	    output-IP-list .IP .IP $rest
 	    return
 	}
-	.PP {
+	.PP - .sp {
 	    man-puts <P>
 	}
 	.RS {
 	    output-RS-list
 	    return
 	}
-	.RE {
-	    manerror "unexpected .RE"
-	    return
-	}
 	.br {
 	    man-puts <BR>
 	    return
 	}
-	.DE {
-	    manerror "unexpected .DE"
-	    return
-	}
 	.DS {
 	    if {[next-op-is .ta rest]} {
 		# skip the leading .ta directive if it is there
@@ -1109,16 +1102,6 @@ proc output-directive {line} {
 	    }
 	    return
 	}
-	.CE {
-	    manerror "unexpected .CE"
-	    return
-	}
-	.sp {
-	    man-puts <P>
-	}
-	.ta {
-	    manerror "ignoring $line"
-	}
 	.nf {
 	    if {[match-text @more .fi]} {
 		foreach more [split $more \n] {
@@ -1174,13 +1157,11 @@ proc output-directive {line} {
 		manerror "ignoring $line"
 	    }
 	}
-	.fi {
-	    manerror "ignoring $line"
+	.RE - .DE - .CE {
+	    manerror "unexpected $code"
+	    return
 	}
-	.na -
-	.ad -
-	.UL -
-	.ne {
+	.ta - .fi - .na - .ad - .UL - .ie - .el - .ne {
 	    manerror "ignoring $line"
 	}
 	default {
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index b347abf..e4845a6 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -360,7 +360,7 @@ proc make-man-pages {html args} {
 		    continue
 		}
 		switch -exact -- $code {
-		    .if - .nr - .ti - .in -
+		    .if - .nr - .ti - .in - .ie - .el -
 		    .ad - .na - .so - .ne - .AS - .VE - .VS - . {
 			# ignore
 			continue
@@ -379,21 +379,22 @@ proc make-man-pages {html args} {
 			lappend manual(text) "$code [unquote $rest]"
 		    }
 		    .QW {
-			set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest]
-			addbuffer $LQ [unquote [lindex $rest 0]] $RQ \
-			    [unquote [lindex $rest 1]]
+			lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+			    inQuote afterwards
+			addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards]
 		    }
 		    .PQ {
-			set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest]
-			addbuffer ( $LQ [unquote [lindex $rest 0]] $RQ \
-			    [unquote [lindex $rest 1]] ) \
-			    [unquote [lindex $rest 2]]
+			lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+			    inQuote punctuation afterwards
+			addbuffer ( $LQ [unquote $inQuote] $RQ \
+			    [unquote $punctuation] ) \
+			    [unquote $afterwards]
 		    }
 		    .QR {
-			set rest [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest]
-			addbuffer $LQ [unquote [lindex $rest 0]] - \
-			    [unquote [lindex $rest 1]] $RQ \
-			    [unquote [lindex $rest 2]]
+			lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+			    rangeFrom rangeTo afterwards
+			addbuffer $LQ [unquote $rangeFrom] "&ndash;" \
+			    [unquote $rangeTo] $RQ [unquote $afterwards]
 		    }
 		    .MT {
 			addbuffer $LQ$RQ
@@ -404,7 +405,7 @@ proc make-man-pages {html args} {
 		    }
 		    .BS - .BE - .br - .fi - .sp - .nf {
 			flushbuffer
-			if {"$rest" ne {}} {
+			if {$rest ne ""} {
 			    if {!$verbose} {
 				puts stderr ""
 			    }
@@ -435,8 +436,9 @@ proc make-man-pages {html args} {
 		    }
 		    .OP {
 			flushbuffer
+			lassign $rest cmdName dbName dbClass
 			lappend manual(text) [concat .OP [process-text \
-				"\\fB[lindex $rest 0]\\fR \\fB[lindex $rest 1]\\fR \\fB[lindex $rest 2]\\fR"]]
+				"\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]]
 		    }
 		    .PP - .LP {
 			flushbuffer
-- 
cgit v0.12


From 201c3c421c30870cead2b6862a090479cb4ba43e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 22 Sep 2011 14:08:34 +0000
Subject: (minor: tidy up some comments)

---
 ChangeLog | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 5dd2fb8..2096795 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -19,9 +19,8 @@
 
 2011-09-21  Andreas Kupries  <andreask@activestate.com>
 
-	* generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the
-	missing initialization of the 'dsti' field. Reported by Don
-	Porter, on chat.
+	* generic/tclIORTrans.c (ForwardOpToOwnerThread): Fixed the missing
+	initialization of the 'dsti' field. Reported by Don Porter, on chat.
 
 2011-09-20  Don Porter  <dgp@users.sourceforge.net>
 
@@ -37,17 +36,17 @@
 2011-09-19  Don Porter  <dgp@users.sourceforge.net>
 
 	* tests/ioTrans.test:	Conversion from [testthread] to Thread package
-	stops most memory leaks.  
+	stops most memory leaks.
 
 	* tests/thread.test:	Plug most memory leaks in thread.test.
-	Constrain the rest to be skipped during `make valgrind`.  Tests using
+	Constrain the rest to be skipped during `make valgrind'.  Tests using
 	the [testthread cancel] testing command are leaky.  Corrections wait
 	for either addition of [thread::cancel] to the Thread package, or
 	improvements to the [testthread] testing command to make leak-free
 	versions of these tests possible.
 
 	* generic/tclIORChan.c:	Plug all memory leaks in ioCmd.test exposed
-	* tests/ioCmd.test:	by `make valgrind`.
+	* tests/ioCmd.test:	by `make valgrind'.
 	* unix/Makefile.in:
 
 2011-09-16  Jan Nijtmans  <nijtmans@users.sf.net>
@@ -2227,7 +2226,7 @@
 
 	[BRANCH: dogeen-assembler-branch]
 
-	* generic/tclAssembly.c (new file): 
+	* generic/tclAssembly.c (new file):
 	* generic/tclAssembly.h:
 	* generic/tclBasic.c (builtInCmds, Tcl_CreateInterp):
 	* generic/tclInt.h:
-- 
cgit v0.12


From f48bcdecf871a829134b40269947502b13c58c73 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 22 Sep 2011 20:32:06 +0000
Subject: Revise [info frame] so that it stops creating cycles in the
 iPtr->cmdFramePtr stack.

---
 ChangeLog          | 5 +++++
 generic/tclCmdIL.c | 2 +-
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 2096795..e2a5b21 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-09-22  Don Porter  <dgp@users.sourceforge.net>
+
+	* generic/tclCmdIL.c:	Revise [info frame] so that it stops creating
+	cycles in the iPtr->cmdFramePtr stack.
+
 2011-09-22  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/re_syntax.n: [Bug 2903743]: Add more magic so that we can do at
diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index 95532d3..f28e651 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1163,7 +1163,7 @@ InfoFrameCmd(
             lastPtr = runPtr;
             runPtr = runPtr->nextPtr;
         }
-        if (lastPtr && !runPtr) {
+        if (lastPtr && (runPtr != NULL)) {
             lastPtr->nextPtr = corPtr->caller.cmdFramePtr;
         }
     }
-- 
cgit v0.12


From 0fb83403e7b5a32f097dcbb7144943c0c0bca597 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 23 Sep 2011 02:55:30 +0000
Subject: Further corrections to [info frame] in a coroutine.

---
 generic/tclCmdIL.c | 66 +++++++++++++++++++++++++++++++++++++-----------------
 1 file changed, 45 insertions(+), 21 deletions(-)

diff --git a/generic/tclCmdIL.c b/generic/tclCmdIL.c
index f28e651..b312026 100644
--- a/generic/tclCmdIL.c
+++ b/generic/tclCmdIL.c
@@ -1140,32 +1140,40 @@ InfoFrameCmd(
     Tcl_Obj *const objv[])	/* Argument objects. */
 {
     Interp *iPtr = (Interp *) interp;
-    int level, topLevel;
-    CmdFrame *framePtr;
+    int level, topLevel, code = TCL_OK;
+    CmdFrame *runPtr, *framePtr;
+    CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
+    if (objc > 2) {
+	Tcl_WrongNumArgs(interp, 1, objv, "?number?");
+	return TCL_ERROR;
+    }
 
     topLevel = ((iPtr->cmdFramePtr == NULL)
 	    ? 0
 	    : iPtr->cmdFramePtr->level);
 
-
-    if (iPtr->execEnvPtr->corPtr) {
+    if (corPtr) {
 	/*
 	 * A coroutine: must fix the level computations AND the cmdFrame chain,
 	 * which is interrupted at the base.
 	 */
+	CmdFrame *lastPtr = NULL;
 
-        CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
-        CmdFrame *runPtr = iPtr->cmdFramePtr;
-        CmdFrame *lastPtr = NULL;
+        runPtr = iPtr->cmdFramePtr;
 
+	/* TODO - deal with overflow */
         topLevel += corPtr->caller.cmdFramePtr->level;
-        while (runPtr && (runPtr != corPtr->caller.cmdFramePtr)) {
-            lastPtr = runPtr;
-            runPtr = runPtr->nextPtr;
-        }
-        if (lastPtr && (runPtr != NULL)) {
-            lastPtr->nextPtr = corPtr->caller.cmdFramePtr;
-        }
+	while (runPtr) {
+	    runPtr->level += corPtr->caller.cmdFramePtr->level;
+	    lastPtr = runPtr;
+	    runPtr = runPtr->nextPtr;
+	}
+	if (lastPtr) {
+	    lastPtr->nextPtr = corPtr->caller.cmdFramePtr;
+	} else {
+	    iPtr->cmdFramePtr = corPtr->caller.cmdFramePtr;
+	}
     }
 
     if (objc == 1) {
@@ -1174,10 +1182,7 @@ InfoFrameCmd(
 	 */
 
 	Tcl_SetObjResult(interp, Tcl_NewIntObj(topLevel));
-	return TCL_OK;
-    } else if (objc != 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "?number?");
-	return TCL_ERROR;
+	goto done;
     }
 
     /*
@@ -1185,7 +1190,8 @@ InfoFrameCmd(
      */
 
     if (TclGetIntFromObj(interp, objv[1], &level) != TCL_OK) {
-	return TCL_ERROR;
+	code = TCL_ERROR;
+	goto done;
     }
 
     if ((level > topLevel) || (level <= - topLevel)) {
@@ -1194,7 +1200,8 @@ InfoFrameCmd(
 		NULL);
 	Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_FRAME",
 		TclGetString(objv[1]), NULL);
-	return TCL_ERROR;
+	code = TCL_ERROR;
+	goto done;
     }
 
     /*
@@ -1214,7 +1221,24 @@ InfoFrameCmd(
     }
 
     Tcl_SetObjResult(interp, TclInfoFrame(interp, framePtr));
-    return TCL_OK;
+
+  done:
+    if (corPtr) {
+
+	if (iPtr->cmdFramePtr == corPtr->caller.cmdFramePtr) {
+	    iPtr->cmdFramePtr = NULL;
+	} else {
+	    runPtr = iPtr->cmdFramePtr;
+	    while (runPtr->nextPtr != corPtr->caller.cmdFramePtr) {
+	    	runPtr->level -= corPtr->caller.cmdFramePtr->level;
+		runPtr = runPtr->nextPtr;
+	    }
+	    runPtr->level = 1;
+	    runPtr->nextPtr = NULL;
+	}
+
+    }
+    return code;
 }
 
 /*
-- 
cgit v0.12


From b1b7242607411370b9765327872a81c2e8c88513 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 23 Sep 2011 16:00:09 +0000
Subject: Stop using the deprecated thread management commands of the tcltest
 package. The test suite ought to provide these tools for itself.  They do not
 belong in a testing harness.

---
 ChangeLog         |  6 ++++++
 tests/thread.test | 40 +++++++++++++++++++++++++++++-----------
 2 files changed, 35 insertions(+), 11 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index e2a5b21..7df4cc1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-09-23  Don Porter  <dgp@users.sourceforge.net>
+
+	* tests/thread.test:	Stop using the deprecated thread management
+	commands of the tcltest package.  The test suite ought to provide
+	these tools for itself.  They do not belong in a testing harness.
+
 2011-09-22  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclCmdIL.c:	Revise [info frame] so that it stops creating
diff --git a/tests/thread.test b/tests/thread.test
index 732f5fd..74f7043 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -23,23 +23,41 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
 
 testConstraint notValgrind [expr {![testConstraint valgrind]}]
 
-if {[testConstraint testthread]} {
-    testthread errorproc ThreadError
+proc ThreadError {id info} {
+    global threadId threadError
+    set threadId $id
+    set threadError $info
 }
+
 if {[testConstraint thread]} {
     thread::errorproc ThreadError
 }
 
-    proc ThreadError {id info} {
-	global threadId threadError
-	set threadId $id
-	set threadError $info
-    }
+if {[testConstraint testthread]} {
+    testthread errorproc ThreadError
+
+    set mainThread [testthread id]
 
     proc ThreadNullError {id info} {
 	# ignore
     }
 
+    proc threadReap {} {
+	testthread errorproc ThreadNullError
+	while {[llength [testthread names]] > 1} {
+	    foreach tid [testthread names] {
+		if {$tid != [testthread id]} {
+		    catch {
+			testthread send -async $tid {testthread exit}
+		    }
+		}
+	    }
+	    after 1
+	}
+	testthread errorproc ThreadError
+	return [llength [testthread names]]
+    }
+}
 
 test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
     list [catch {testthread} msg] $msg
@@ -80,14 +98,14 @@ test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
     list $x $msg
 } {1 {wrong # args: should be "testthread id"}}
 test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} {
-    string compare [testthread id] $::tcltest::mainThread
+    string compare [testthread id] $mainThread
 } {0}
 test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} {
     set x [catch {testthread names x} msg]
     list $x $msg
 } {1 {wrong # args: should be "testthread names"}}
 test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} {
-    string compare [testthread names] $::tcltest::mainThread
+    string compare [testthread names] $mainThread
 } {0}
 test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} {
     set x [catch {testthread send} msg]
@@ -104,7 +122,7 @@ test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} {
     set five
 } 5
 test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
-    set tid [expr $::tcltest::mainThread + 10]
+    set tid [expr $mainThread + 10]
     set x [catch {testthread send $tid {set x 5}} msg]
     list $x $msg
 } {1 {invalid thread id}}
@@ -248,7 +266,7 @@ test thread-7.2 {cancel: nonint} {testthread} {
     list $x $msg
 } {1 {expected integer but got "abc"}}
 test thread-7.3 {cancel: bad id} {testthread} {
-    set tid [expr $::tcltest::mainThread + 10]
+    set tid [expr $mainThread + 10]
     set x [catch {testthread cancel $tid} msg]
     list $x $msg
 } {1 {invalid thread id}}
-- 
cgit v0.12


From e3352567a2a3af2547b61485e6b91c0efd03533b Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 23 Sep 2011 19:16:23 +0000
Subject: More revisions to get finalization of ReflectedTransforms correct,
 including adopting a "dead" field as was done in tclIORChan.c.

---
 ChangeLog             |   4 ++
 generic/tclIORTrans.c | 119 ++++++++++++++++++++++++++------------------------
 2 files changed, 67 insertions(+), 56 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 7df4cc1..ecac917 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2011-09-23  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclIORTrans.c: More revisions to get finalization of
+	ReflectedTransforms correct, including adopting a "dead" field as
+	was done in tclIORChan.c.
+
 	* tests/thread.test:	Stop using the deprecated thread management
 	commands of the tcltest package.  The test suite ought to provide
 	these tools for itself.  They do not belong in a testing harness.
diff --git a/generic/tclIORTrans.c b/generic/tclIORTrans.c
index 0617df3..b095dcf 100644
--- a/generic/tclIORTrans.c
+++ b/generic/tclIORTrans.c
@@ -161,6 +161,8 @@ typedef struct {
     int mode;			/* Mask of R/W mode */
     int nonblocking;		/* Flag: Channel is blocking or not. */
     int readIsDrained;		/* Flag: Read buffers are flushed. */
+    int dead;			/* Boolean signal that some operations
+				 * should no longer be attempted. */
     ResultBuffer result;
 } ReflectedTransform;
 
@@ -1008,27 +1010,27 @@ ReflectClose(
      * the per-interp DeleteReflectedTransformMap exit-handler.
      */
 
-    if (rtPtr->interp) {
+    if (!rtPtr->dead) {
 	rtmPtr = GetReflectedTransformMap(rtPtr->interp);
 	hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
 	if (hPtr) {
 	    Tcl_DeleteHashEntry(hPtr);
 	}
-    }
 
-    /*
-     * In a threaded interpreter we manage a per-thread map as well, to allow
-     * us to survive if the script level pulls the rug out under a channel by
-     * deleting the owning thread.
-     */
+	/*
+	 * In a threaded interpreter we manage a per-thread map as well,
+	 * to allow us to survive if the script level pulls the rug out
+	 * under a channel by deleting the owning thread.
+	 */
 
 #ifdef TCL_THREADS
-    rtmPtr = GetThreadReflectedTransformMap();
-    hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
-    if (hPtr) {
-	Tcl_DeleteHashEntry(hPtr);
-    }
+	rtmPtr = GetThreadReflectedTransformMap();
+	hPtr = Tcl_FindHashEntry(&rtmPtr->map, Tcl_GetString(rtPtr->handle));
+	if (hPtr) {
+	    Tcl_DeleteHashEntry(hPtr);
+	}
 #endif
+    }
 
     Tcl_EventuallyFree (rtPtr, (Tcl_FreeProc *) FreeReflectedTransform);
     return errorCodeSet ? errorCode : ((result == TCL_OK) ? EOK : EINVAL);
@@ -1771,6 +1773,7 @@ NewReflectedTransform(
     rtPtr->readIsDrained = 0;
     rtPtr->nonblocking =
 	    (((Channel *) parentChan)->state->flags & CHANNEL_NONBLOCKING);
+    rtPtr->dead = 0;
 
     /*
      * Query parent for current blocking mode.
@@ -1950,7 +1953,7 @@ InvokeTclMethod(
     int result;			/* Result code of method invokation */
     Tcl_Obj *resObj = NULL;	/* Result of method invokation. */
 
-    if (!rtPtr->interp) {
+    if (rtPtr->dead) {
 	/*
 	 * The transform is marked as dead. Bail out immediately, with an
 	 * appropriate error.
@@ -2163,7 +2166,8 @@ DeleteReflectedTransformMap(
 	    hPtr != NULL;
 	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
 	rtPtr = Tcl_GetHashValue(hPtr);
-	rtPtr->interp = NULL;
+
+	rtPtr->dead = 1;
 	Tcl_DeleteHashEntry(hPtr);
     }
     Tcl_DeleteHashTable(&rtmPtr->map);
@@ -2175,6 +2179,32 @@ DeleteReflectedTransformMap(
      */
 
     /*
+     * Get the map of all channels handled by the current thread. This is a
+     * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
+     * through the channels and remove all which were handled by this
+     * interpreter. They have already been marked as dead.
+     */
+
+    rtmPtr = GetThreadReflectedTransformMap();
+    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
+	    hPtr != NULL;
+	    hPtr = Tcl_NextHashEntry(&hSearch)) {
+	rtPtr = Tcl_GetHashValue(hPtr);
+
+	if (rtPtr->interp != interp) {
+	    /*
+	     * Ignore entries for other interpreters.
+	     */
+
+	    continue;
+	}
+
+	rtPtr->dead = 1;
+	FreeReflectedTransformArgs(rtPtr);
+	Tcl_DeleteHashEntry(hPtr);
+    }
+
+    /*
      * Go through the list of pending results and cancel all whose events were
      * destined for this interpreter. While this is in progress we block any
      * other access to the list of pending results.
@@ -2210,29 +2240,6 @@ DeleteReflectedTransformMap(
     }
     Tcl_MutexUnlock(&rtForwardMutex);
 
-    /*
-     * Get the map of all channels handled by the current thread. This is a
-     * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
-     * through the channels and remove all which were handled by this
-     * interpreter. They have already been marked as dead.
-     */
-
-    rtmPtr = GetThreadReflectedTransformMap();
-    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
-	    hPtr != NULL;
-	    hPtr = Tcl_NextHashEntry(&hSearch)) {
-	rtPtr = Tcl_GetHashValue(hPtr);
-
-	if (rtPtr->interp != interp) {
-	    /*
-	     * Ignore entries for other interpreters.
-	     */
-
-	    continue;
-	}
-
-	Tcl_DeleteHashEntry(hPtr);
-    }
 #endif
 }
 
@@ -2303,6 +2310,24 @@ DeleteThreadReflectedTransformMap(
      */
 
     /*
+     * Get the map of all channels handled by the current thread. This is a
+     * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
+     * through the channels, remove all, mark them as dead.
+     */
+
+    rtmPtr = GetThreadReflectedTransformMap();
+    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
+	    hPtr != NULL;
+	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
+	ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr);
+
+	rtPtr->dead = 1;
+	FreeReflectedTransformArgs(rtPtr);
+	Tcl_DeleteHashEntry(hPtr);
+    }
+    ckfree(rtmPtr);
+
+    /*
      * Go through the list of pending results and cancel all whose events were
      * destined for this thread. While this is in progress we block any
      * other access to the list of pending results.
@@ -2340,24 +2365,6 @@ DeleteThreadReflectedTransformMap(
 	Tcl_ConditionNotify(&resultPtr->done);
     }
     Tcl_MutexUnlock(&rtForwardMutex);
-
-    /*
-     * Get the map of all channels handled by the current thread. This is a
-     * ReflectedTransformMap, but on a per-thread basis, not per-interp. Go
-     * through the channels, remove all, mark them as dead.
-     */
-
-    rtmPtr = GetThreadReflectedTransformMap();
-    for (hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch);
-	    hPtr != NULL;
-	    hPtr = Tcl_FirstHashEntry(&rtmPtr->map, &hSearch)) {
-	ReflectedTransform *rtPtr = Tcl_GetHashValue(hPtr);
-
-	rtPtr->interp = NULL;
-	FreeReflectedTransformArgs(rtPtr);
-	Tcl_DeleteHashEntry(hPtr);
-    }
-    ckfree(rtmPtr);
 }
 
 static void
@@ -2377,7 +2384,7 @@ ForwardOpToOwnerThread(
 
     Tcl_MutexLock(&rtForwardMutex);
 
-    if (rtPtr->interp == NULL) {
+    if (rtPtr->dead) {
 	/*
 	 * The channel is marked as dead. Bail out immediately, with an
 	 * appropriate error. Do not forget to unlock the mutex on this path.
-- 
cgit v0.12


From 41f3276be0691e2867d69d5b0f47004312f5d72a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 26 Sep 2011 10:09:11 +0000
Subject: Proposed patch to fix [Bug 3413857]...

---
 generic/tclIndexObj.c | 38 ++++++++++++++------------------------
 1 file changed, 14 insertions(+), 24 deletions(-)

diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 6f378a4..4e04f71 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -1113,13 +1113,15 @@ Tcl_ParseArgsObjv(
 
     if (remObjv != NULL) {
 	/*
-	 * Then we should copy the name of the command (0th argument).
+	 * Then we should copy the name of the command (0th argument). The
+	 * upper bound on the number of elements is known, and (undocumented,
+	 * but historically true) there should be a NULL argument after the
+	 * last result. [Bug 3413857]
 	 */
 
 	nrem = 1;
-	leftovers = ckalloc((nrem + 1) * sizeof(Tcl_Obj *));
-	leftovers[nrem-1] = objv[0];
-	leftovers[nrem] = NULL;
+	leftovers = ckalloc((1 + *objcPtr) * sizeof(Tcl_Obj *));
+	leftovers[0] = objv[0];
     } else {
 	nrem = 0;
 	leftovers = NULL;
@@ -1182,14 +1184,7 @@ Tcl_ParseArgsObjv(
 	    }
 
 	    dstIndex++;		/* This argument is now handled */
-	    nrem++;
-
-	    /*
-	     * Allocate nrem (+1 extra for NULL terminator) pointers.
-	     */
-
-	    leftovers = ckrealloc(leftovers, (nrem+1) * sizeof(Tcl_Obj *));
-	    leftovers[nrem-1] = curArg;
+	    leftovers[nrem++] = curArg;
 	    continue;
 	}
 
@@ -1282,7 +1277,9 @@ Tcl_ParseArgsObjv(
 
     /*
      * If we broke out of the loop because of an OPT_REST argument, copy the
-     * remaining arguments down.
+     * remaining arguments down. Note that there is always at least one
+     * argument left over - the command name - so we always have a result if
+     * our caller is willing to receive it. [Bug 3413857]
      */
 
   argsDone:
@@ -1295,19 +1292,12 @@ Tcl_ParseArgsObjv(
     }
 
     if (objc > 0) {
-	leftovers = ckrealloc(leftovers, (nrem+objc+1) * sizeof(Tcl_Obj *));
-	while (objc) {
-	    leftovers[nrem] = objv[srcIndex];
-	    nrem++;
-	    srcIndex++;
-	    objc--;
-	}
-    } else if (leftovers != NULL) {
-	ckfree(leftovers);
+	memcpy(leftovers+nrem, objv+srcIndex, objc*sizeof(Tcl_Obj *));
+	nrem += objc;
     }
     leftovers[nrem] = NULL;
-    *objcPtr = nrem;
-    *remObjv = leftovers;
+    *objcPtr = nrem++;
+    *remObjv = ckrealloc(leftovers, nrem * sizeof(Tcl_Obj *));
     return TCL_OK;
 
     /*
-- 
cgit v0.12


From 643c7a2aa4c7b5cb1412a098ecacd72dc5f09aac Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 26 Sep 2011 10:46:36 +0000
Subject: Make [file] itself be safe, to reduce breakage in existing code. [Bug
 3211758]

---
 ChangeLog          |  7 +++++++
 generic/tclCmdAH.c | 11 +++++++++++
 tests/safe.test    | 16 ++++++++++++++++
 3 files changed, 34 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index ecac917..9673852 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-09-26  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCmdAH.c (TclMakeFileCommandSafe): [Bug 3211758]: Also
+	make the main [file] command hidden by default in safe interpreters,
+	because that's what existing code expects. This will reduce the amount
+	which the code breaks, but not necessarily eliminate it...
+
 2011-09-23  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclIORTrans.c: More revisions to get finalization of
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index fc9d39d..d036bd6 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1063,6 +1063,17 @@ TclMakeFileCommandSafe(
     }
     Tcl_DStringFree(&oldBuf);
     Tcl_DStringFree(&newBuf);
+
+    /*
+     * Ugh. The [file] command is now actually safe, but it is assumed by
+     * scripts that it is not, which messes up security policies. [Bug
+     * 3211758]
+     */
+
+    if (Tcl_HideCommand(interp, "file", "file") != TCL_OK) {
+	Tcl_Panic("problem making 'file' safe: %s",
+		Tcl_GetString(Tcl_GetObjResult(interp)));
+    }
     return TCL_OK;
 }
 
diff --git a/tests/safe.test b/tests/safe.test
index 0f82a6a..4190976 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -541,6 +541,22 @@ test safe-12.7 {glob is restricted} -setup {
 } -cleanup {
     safe::interpDelete $i
 } -match glob -result *
+
+test safe-13.1 {safe file ensemble does not surprise code} -setup {
+    set i [interp create -safe]
+} -body {
+    set result [expr {"file" in [interp hidden $i]}]
+    lappend result [interp eval $i {tcl::file::split a/b/c}]
+    lappend result [catch {interp eval $i {tcl::file::isdirectory .}}]
+    lappend result [interp invokehidden $i file split a/b/c]
+    lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
+    lappend result [catch {interp invokehidden $i file isdirectory .}]
+    interp expose $i file
+    lappend result [catch {interp eval $i {file split a/b/c}} msg] $msg
+    lappend result [catch {interp eval $i {file isdirectory .}} msg] $msg
+} -cleanup {
+    interp delete $i
+} -result {1 {a b c} 1 {a b c} 1 {invalid command name "file"} 1 0 {a b c} 1 {invalid command name "::tcl::file::isdirectory"}}
 
 set ::auto_path $saveAutoPath
 # cleanup
-- 
cgit v0.12


From 0f5c9c8a346e3b691776746c83dfa947b2f41fd6 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 27 Sep 2011 09:44:56 +0000
Subject: Unbreak TCL_ARGV_AUTO_REST macro, found during testing.

---
 generic/tclIndexObj.c | 9 ++++++++-
 1 file changed, 8 insertions(+), 1 deletion(-)

diff --git a/generic/tclIndexObj.c b/generic/tclIndexObj.c
index 4e04f71..8651542 100644
--- a/generic/tclIndexObj.c
+++ b/generic/tclIndexObj.c
@@ -1222,7 +1222,14 @@ Tcl_ParseArgsObjv(
 	    objc--;
 	    break;
 	case TCL_ARGV_REST:
-	    *((int *) infoPtr->dstPtr) = dstIndex;
+	    /*
+	     * Only store the point where we got to if it's not to be written
+	     * to NULL, so that TCL_ARGV_AUTO_REST works.
+	     */
+
+	    if (infoPtr->dstPtr != NULL) {
+		*((int *) infoPtr->dstPtr) = dstIndex;
+	    }
 	    goto argsDone;
 	case TCL_ARGV_FLOAT:
 	    if (objc == 0) {
-- 
cgit v0.12


From a235eed74f319d7860e973935e2064bd1bb30e18 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 27 Sep 2011 09:45:40 +0000
Subject: Test harness for Tcl_ParseArgsObjv

---
 generic/tclTest.c   | 45 +++++++++++++++++++++++++++++++++++++++++++++
 tests/indexObj.test | 38 ++++++++++++++++++++++++++++++++------
 2 files changed, 77 insertions(+), 6 deletions(-)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 96dcb36..5b74663 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -311,6 +311,8 @@ static int		TestpanicCmd(ClientData dummy,
 static int		TestfinexitObjCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+static int              TestparseargsCmd(ClientData dummy, Tcl_Interp *interp,
+                            int objc, Tcl_Obj *const objv[]);
 static int		TestparserObjCmd(ClientData dummy,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -624,6 +626,7 @@ Tcltest_Init(
 	    NULL);
     Tcl_CreateCommand(interp, "testpanic", TestpanicCmd, NULL, NULL);
     Tcl_CreateObjCommand(interp, "testfinexit", TestfinexitObjCmd, NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testparseargs", TestparseargsCmd,NULL,NULL);
     Tcl_CreateObjCommand(interp, "testparser", TestparserObjCmd,
 	    NULL, NULL);
     Tcl_CreateObjCommand(interp, "testparsevar", TestparsevarObjCmd,
@@ -7082,6 +7085,48 @@ TestconcatobjCmd(
 }
 
 /*
+ *----------------------------------------------------------------------
+ *
+ * TestparseargsCmd --
+ *
+ *	This procedure implements the "testparseargs" command. It is used to
+ *	test that Tcl_ParseArgsObjv does indeed return the right number of
+ *	arguments. In other words, that [Bug 3413857] was fixed properly.
+ *
+ * Results:
+ *	A standard Tcl result.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+TestparseargsCmd(
+    ClientData dummy,		/* Not used. */
+    Tcl_Interp *interp,		/* Current interpreter. */
+    int objc,			/* Number of arguments. */
+    Tcl_Obj *const objv[])	/* Arguments. */
+{
+    int count = objc, foo = 0;
+    Tcl_Obj **remObjv, *result[3];
+    Tcl_ArgvInfo argTable[] = {
+        {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
+        TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
+    };
+
+    if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
+        return TCL_ERROR;
+    }
+    result[0] = Tcl_NewIntObj(foo);
+    result[1] = Tcl_NewIntObj(count);
+    result[2] = Tcl_NewListObj(count, remObjv);
+    Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/tests/indexObj.test b/tests/indexObj.test
index 098aec0..479cc3b 100644
--- a/tests/indexObj.test
+++ b/tests/indexObj.test
@@ -1,20 +1,21 @@
 # This file is a Tcl script to test out the the procedures in file
-# tkIndexObj.c, which implement indexed table lookups.  The tests here
-# are organized in the standard fashion for Tcl tests.
+# tkIndexObj.c, which implement indexed table lookups.  The tests here are
+# organized in the standard fashion for Tcl tests.
 #
 # 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.
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
+    package require tcltest 2
     namespace import -force ::tcltest::*
 }
 
 testConstraint testindexobj [llength [info commands testindexobj]]
-
+testConstraint testparseargs [llength [info commands testparseargs]]
+
 test indexObj-1.1 {exact match} testindexobj {
     testindexobj 1 1 xyz abc def xyz alm
 } {2}
@@ -128,6 +129,31 @@ test indexObj-6.4 {Tcl_GetIndexFromObjStruct} testindexobj {
     testgetindexfromobjstruct $x 1
 } "wrong # args: should be \"testgetindexfromobjstruct c 1\""
 
+test indexObj-7.1 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs
+} {0 1 testparseargs}
+test indexObj-7.2 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs -bool
+} {1 1 testparseargs}
+test indexObj-7.3 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs -bool bar
+} {1 2 {testparseargs bar}}
+test indexObj-7.4 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs bar
+} {0 2 {testparseargs bar}}
+test indexObj-7.5 {Tcl_ParseArgsObjv} -constraints testparseargs -body {
+    testparseargs -help
+} -returnCodes error -result {Command-specific options:
+ -bool: booltest
+ --:    Marks the end of the options
+ -help: Print summary of command-line options and abort}
+test indexObj-7.6 {Tcl_ParseArgsObjv} testparseargs {
+    testparseargs -- -bool -help
+} {0 3 {testparseargs -bool -help}}
+test indexObj-7.7 {Tcl_ParseArgsObjv memory management} testparseargs {
+    testparseargs 1 2 3 4 5 6 7 8 9 0 -bool 1 2 3 4 5 6 7 8 9 0
+} {1 21 {testparseargs 1 2 3 4 5 6 7 8 9 0 1 2 3 4 5 6 7 8 9 0}}
+
 # cleanup
 ::tcltest::cleanupTests
 return
-- 
cgit v0.12


From 2b8e3fffb5153cb9fb7c567988338ad6cd163f72 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 27 Sep 2011 09:57:02 +0000
Subject: Release unused memory...

---
 generic/tclTest.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 5b74663..30c95c8 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -7123,6 +7123,7 @@ TestparseargsCmd(
     result[1] = Tcl_NewIntObj(count);
     result[2] = Tcl_NewListObj(count, remObjv);
     Tcl_SetObjResult(interp, Tcl_NewListObj(3, result));
+    ckfree(remObjv);
     return TCL_OK;
 }
 
-- 
cgit v0.12


From 89b3c7f11e1bdf0e7c9b8cfe622f383ec7ca0a4d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 29 Sep 2011 10:56:52 +0000
Subject: [Bug 3414769]: Updated list of default-hidden commands for safe
 interps.

---
 tests/interp.test | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/tests/interp.test b/tests/interp.test
index c146355..ab91f77 100644
--- a/tests/interp.test
+++ b/tests/interp.test
@@ -17,7 +17,7 @@ if {"::tcltest" ni [namespace children]} {
 
 testConstraint testinterpdelete [llength [info commands testinterpdelete]]
 
-set hidden_cmds {cd encoding exec exit fconfigure glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
+set hidden_cmds {cd encoding exec exit fconfigure file glob load open pwd socket source tcl:file:atime tcl:file:attributes tcl:file:copy tcl:file:delete tcl:file:dirname tcl:file:executable tcl:file:exists tcl:file:extension tcl:file:isdirectory tcl:file:isfile tcl:file:link tcl:file:lstat tcl:file:mkdir tcl:file:mtime tcl:file:nativename tcl:file:normalize tcl:file:owned tcl:file:readable tcl:file:readlink tcl:file:rename tcl:file:rootname tcl:file:size tcl:file:stat tcl:file:tail tcl:file:tempfile tcl:file:type tcl:file:volumes tcl:file:writable unload}
 
 foreach i [interp slaves] {
   interp delete $i
-- 
cgit v0.12


From 9f6d7b9f3e4e3b2920f51e94c6444e6e41c8e195 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 29 Sep 2011 14:58:10 +0000
Subject: More polishing of Tcl's HTML doc converter.

---
 ChangeLog                      |   7 +
 tools/tcltk-man2html-utils.tcl | 388 ++++++++++++++++++++++++++++++++++++++++-
 tools/tcltk-man2html.tcl       | 378 +++------------------------------------
 3 files changed, 414 insertions(+), 359 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 117246f..1bcaf49 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-09-29  Donal K. Fellows  <dkf@users.sf.net>
+
+	* tools/tcltk-man2html.tcl, tools/tcltk-man2html-utils.tcl: More
+	refactoring so that more of the utility code is decently out of the
+	way. Adjusted the header-material generator so that version numbers
+	are only included in locations where there is room.
+
 2011-09-28  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclOO.h:      [RFE 3010352]: make all TclOO API functions
diff --git a/tools/tcltk-man2html-utils.tcl b/tools/tcltk-man2html-utils.tcl
index ef1f62a..c0c6a75 100644
--- a/tools/tcltk-man2html-utils.tcl
+++ b/tools/tcltk-man2html-utils.tcl
@@ -35,7 +35,7 @@ proc fatal {msg} {
     uplevel 1 [list manerror $msg]
     exit 1
 }
-
+
 ##
 ## templating
 ##
@@ -46,6 +46,7 @@ proc indexfile {} {
 	return "contents.htm"
     }
 }
+
 proc copyright {copyright {level {}}} {
     # We don't actually generate a separate copyright page anymore
     #set page "${level}copyright.htm"
@@ -54,6 +55,7 @@ proc copyright {copyright {level {}}} {
     set who [string map {@ (at)} [lrange $copyright 2 end]]
     return "Copyright &copy; [htmlize-text $who]"
 }
+
 proc copyout {copyrights {level {}}} {
     set out "<div class=\"copy\">"
     foreach c $copyrights {
@@ -62,12 +64,15 @@ proc copyout {copyrights {level {}}} {
     append out "</div>"
     return $out
 }
+
 proc CSS {{level ""}} {
     return "<link rel=\"stylesheet\" href=\"${level}$::CSSFILE\" type=\"text/css\" media=\"all\">\n"
 }
+
 proc DOCTYPE {} {
     return "<!DOCTYPE HTML PUBLIC \"-//W3C//DTD HTML 4.01 Transitional//EN\">"
 }
+
 proc htmlhead {title header args} {
     set level ""
     if {[lindex $args end] eq "../[indexfile]"} {
@@ -93,7 +98,7 @@ proc htmlhead {title header args} {
     }
     return $out
 }
-
+
 ##
 ## parsing
 ##
@@ -187,6 +192,7 @@ proc process-text {text} {
     }
     return $text
 }
+
 ##
 ## pass 2 text input and matching
 ##
@@ -195,10 +201,12 @@ proc open-text {} {
     set manual(text-length) [llength $manual(text)]
     set manual(text-pointer) 0
 }
+
 proc more-text {} {
     global manual
     return [expr {$manual(text-pointer) < $manual(text-length)}]
 }
+
 proc next-text {} {
     global manual
     if {[more-text]} {
@@ -209,14 +217,17 @@ proc next-text {} {
     manerror "read past end of text"
     error "fatal"
 }
+
 proc is-a-directive {line} {
     return [string match .* $line]
 }
+
 proc split-directive {line opname restname} {
     upvar 1 $opname op $restname rest
     set op [string range $line 0 2]
     set rest [string trim [string range $line 3 end]]
 }
+
 proc next-op-is {op restname} {
     global manual
     upvar 1 $restname rest
@@ -230,12 +241,14 @@ proc next-op-is {op restname} {
     }
     return 0
 }
+
 proc backup-text {n} {
     global manual
     if {$manual(text-pointer)-$n >= 0} {
 	incr manual(text-pointer) -$n
     }
 }
+
 proc match-text args {
     global manual
     set nargs [llength $args]
@@ -275,11 +288,13 @@ proc match-text args {
     }
     return 1
 }
+
 proc expand-next-text {n} {
     global manual
     return [join [lrange $manual(text) $manual(text-pointer) \
 	    [expr {$manual(text-pointer)+$n-1}]] \n\n]
 }
+
 ##
 ## pass 2 output
 ##
@@ -287,7 +302,7 @@ proc man-puts {text} {
     global manual
     lappend manual(output-$manual(wing-file)-$manual(name)) $text
 }
-
+
 ##
 ## build hypertext links to tables of contents
 ##
@@ -300,6 +315,7 @@ proc long-toc {text} {
 	    "<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$text</A>"
     return "<A NAME=\"$here\">$text</A>"
 }
+
 proc option-toc {name class switch} {
     global manual
     # Special case handling, oh we hate it but must do it
@@ -327,6 +343,7 @@ proc option-toc {name class switch} {
 	"<DD><A HREF=\"$manual(name).htm#$here\" NAME=\"$there\">$switch, $name, $class</A>"
     return "<A NAME=\"$here\">$switch</A>"
 }
+
 proc std-option-toc {name page} {
     global manual
     if {[info exists manual(standard-option-$page-$name)]} {
@@ -340,6 +357,7 @@ proc std-option-toc {name page} {
     lappend manual(section-toc) "<DD><A HREF=\"$page.htm#$other\">$name</A>"
     return "<A HREF=\"$page.htm#$other\">$name</A>"
 }
+
 ##
 ## process the widget option section
 ## in widget and options man pages
@@ -411,7 +429,7 @@ proc output-widget-options {rest} {
     man-puts </DL>
     lappend manual(section-toc) </DL>
 }
-
+
 ##
 ## process .RS lists
 ##
@@ -455,7 +473,7 @@ proc output-RS-list {} {
     }
     man-puts </DL>
 }
-
+
 ##
 ## process .IP lists which may be plain indents,
 ## numeric lists, or definition lists
@@ -594,6 +612,7 @@ proc output-IP-list {context code rest} {
 	}
     }
 }
+
 ##
 ## handle the NAME section lines
 ## there's only one line in the NAME section,
@@ -618,6 +637,7 @@ proc output-name {line} {
 	lappend manual(name-$name) $manual(wing-file)/$manual(name)
     }
 }
+
 ##
 ## build a cross-reference link if appropriate
 ##
@@ -726,6 +746,7 @@ proc cross-reference {ref} {
     ##
     return "<A HREF=\"../$manref.htm\">$ref</A>"
 }
+
 ##
 ## reference generation errors
 ##
@@ -734,6 +755,7 @@ proc reference-error {msg text} {
     puts stderr "$manual(tail): $msg: {$text}"
     return $text
 }
+
 ##
 ## insert as many cross references into this text string as are appropriate
 ##
@@ -888,6 +910,7 @@ proc insert-cross-references {text} {
 	}
     }
 }
+
 ##
 ## process formatting directives
 ##
@@ -1169,6 +1192,7 @@ proc output-directive {line} {
 	}
     }
 }
+
 ##
 ## merge copyright listings
 ##
@@ -1206,7 +1230,361 @@ proc merge-copyrights {l1 l2} {
     }
     return [lsort -dictionary $merge]
 }
+
+##
+## foreach of the man pages in the section specified by
+## sectionDescriptor, convert manpages into hypertext in
+## the directory specified by outputDir.
+##
+proc make-manpage-section {outputDir sectionDescriptor} {
+    global manual overall_title tcltkdesc verbose
+    global excluded_pages forced_index_pages process_first_patterns
+
+    set LQ \u201c
+    set RQ \u201d
 
+    lassign $sectionDescriptor \
+	manual(wing-glob) \
+	manual(wing-name) \
+	manual(wing-file) \
+	manual(wing-description)
+    set manual(wing-copyrights) {}
+    makedirhier $outputDir/$manual(wing-file)
+    set manual(wing-toc-fp) [open $outputDir/$manual(wing-file)/[indexfile] w]
+    # whistle
+    puts stderr "scanning section $manual(wing-name)"
+    # put the entry for this section into the short table of contents
+    puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>"
+    # initialize the wing table of contents
+    puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \
+	    $manual(wing-name) $overall_title "../[indexfile]"]
+    # initialize the short table of contents for this section
+    set manual(wing-toc) {}
+    # initialize the man directory for this section
+    makedirhier $outputDir/$manual(wing-file)
+    # initialize the long table of contents for this section
+    set manual(long-toc-n) 1
+    # get the manual pages for this section
+    set manual(pages) [lsort -dictionary [glob -nocomplain $manual(wing-glob)]]
+    # Some pages have to go first so that their links override others
+    foreach pat $process_first_patterns {
+	set n [lsearch -glob $manual(pages) $pat]
+	if {$n >= 0} {
+	    set f [lindex $manual(pages) $n]
+	    puts stderr "shuffling [file tail $f] to front of processing queue"
+	    set manual(pages) \
+		[linsert [lreplace $manual(pages) $n $n] 0 $f]
+	}
+    }
+    # set manual(pages) [lrange $manual(pages) 0 5]
+    foreach manual_page $manual(pages) {
+	set manual(page) [file normalize $manual_page]
+	# whistle
+	if {$verbose} {
+	    puts stderr "scanning page $manual(page)"
+	} else {
+	    puts -nonewline stderr .
+	}
+	set manual(tail) [file tail $manual(page)]
+	set manual(name) [file root $manual(tail)]
+	set manual(section) {}
+	if {$manual(name) in $excluded_pages} {
+	    # obsolete
+	    if {!$verbose} {
+		puts stderr ""
+	    }
+	    manerror "discarding $manual(name)"
+	    continue
+	}
+	set manual(infp) [open $manual(page)]
+	set manual(text) {}
+	set manual(partial-text) {}
+	foreach p {.RS .DS .CS .SO} {
+	    set manual($p) 0
+	}
+	set manual(stack) {}
+	set manual(section) {}
+	set manual(section-toc) {}
+	set manual(section-toc-n) 1
+	set manual(copyrights) {}
+	lappend manual(all-pages) $manual(wing-file)/$manual(tail)
+	lappend manual(all-page-domains) $manual(wing-name)
+	manreport 100 $manual(name)
+	while {[gets $manual(infp) line] >= 0} {
+	    manreport 100 $line
+	    if {[regexp {^[`'][/\\]} $line]} {
+		if {[regexp {Copyright (?:\(c\)|\\\(co).*$} $line copyright]} {
+		    lappend manual(copyrights) $copyright
+		}
+		# comment
+		continue
+	    }
+	    if {"$line" eq {'}} {
+		# comment
+		continue
+	    }
+	    if {![parse-directive $line code rest]} {
+		addbuffer $line
+		continue
+	    }
+	    switch -exact -- $code {
+		.if - .nr - .ti - .in - .ie - .el -
+		.ad - .na - .so - .ne - .AS - .VE - .VS - . {
+		    # ignore
+		    continue
+		}
+	    }
+	    switch -exact -- $code {
+		.SH - .SS {
+		    flushbuffer
+		    if {[llength $rest] == 0} {
+			gets $manual(infp) rest
+		    }
+		    lappend manual(text) "$code [unquote $rest]"
+		}
+		.TH {
+		    flushbuffer
+		    lappend manual(text) "$code [unquote $rest]"
+		}
+		.QW {
+		    lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+			inQuote afterwards
+		    addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards]
+		}
+		.PQ {
+		    lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+			inQuote punctuation afterwards
+		    addbuffer ( $LQ [unquote $inQuote] $RQ \
+			    [unquote $punctuation] ) [unquote $afterwards]
+		}
+		.QR {
+		    lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
+			rangeFrom rangeTo afterwards
+		    addbuffer $LQ [unquote $rangeFrom] "&ndash;" \
+			    [unquote $rangeTo] $RQ [unquote $afterwards]
+		}
+		.MT {
+		    addbuffer $LQ$RQ
+		}
+		.HS - .UL - .ta {
+		    flushbuffer
+		    lappend manual(text) "$code [unquote $rest]"
+		}
+		.BS - .BE - .br - .fi - .sp - .nf {
+		    flushbuffer
+		    if {$rest ne ""} {
+			if {!$verbose} {
+			    puts stderr ""
+			}
+			manerror "unexpected argument: $line"
+		    }
+		    lappend manual(text) $code
+		}
+		.AP {
+		    flushbuffer
+		    lappend manual(text) [concat .IP [process-text \
+			    "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]
+		}
+		.IP {
+		    flushbuffer
+		    regexp {^(.*) +\d+$} $rest all rest
+		    lappend manual(text) ".IP [process-text \
+			    [unquote [string trim $rest]]]"
+		}
+		.TP {
+		    flushbuffer
+		    while {[is-a-directive [set next [gets $manual(infp)]]]} {
+			if {!$verbose} {
+			    puts stderr ""
+			}
+			manerror "ignoring $next after .TP"
+		    }
+		    if {"$next" ne {'}} {
+			lappend manual(text) ".IP [process-text $next]"
+		    }
+		}
+		.OP {
+		    flushbuffer
+		    lassign $rest cmdName dbName dbClass
+		    lappend manual(text) [concat .OP [process-text \
+			    "\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]]
+		}
+		.PP - .LP {
+		    flushbuffer
+		    lappend manual(text) {.PP}
+		}
+		.RS {
+		    flushbuffer
+		    incr manual(.RS)
+		    lappend manual(text) $code
+		}
+		.RE {
+		    flushbuffer
+		    incr manual(.RS) -1
+		    lappend manual(text) $code
+		}
+		.SO {
+		    flushbuffer
+		    incr manual(.SO)
+		    if {[llength $rest] == 0} {
+			lappend manual(text) "$code options"
+		    } else {
+			lappend manual(text) "$code [unquote $rest]"
+		    }
+		}
+		.SE {
+		    flushbuffer
+		    incr manual(.SO) -1
+		    lappend manual(text) $code
+		}
+		.DS {
+		    flushbuffer
+		    incr manual(.DS)
+		    lappend manual(text) $code
+		}
+		.DE {
+		    flushbuffer
+		    incr manual(.DS) -1
+		    lappend manual(text) $code
+		}
+		.CS {
+		    flushbuffer
+		    incr manual(.CS)
+		    lappend manual(text) $code
+		}
+		.CE {
+		    flushbuffer
+		    incr manual(.CS) -1
+		    lappend manual(text) $code
+		}
+		.de {
+		    while {[gets $manual(infp) line] >= 0} {
+			if {[string match "..*" $line]} {
+			    break
+			}
+		    }
+		}
+		.. {
+		    if {!$verbose} {
+			puts stderr ""
+		    }
+		    error "found .. outside of .de"
+		}
+		default {
+		    if {!$verbose} {
+			puts stderr ""
+		    }
+		    flushbuffer
+		    manerror "unrecognized format directive: $line"
+		}
+	    }
+	}
+	flushbuffer
+	close $manual(infp)
+	# fixups
+	if {$manual(.RS) != 0} {
+	    if {!$verbose} {
+		puts stderr ""
+	    }
+	    puts "unbalanced .RS .RE"
+	}
+	if {$manual(.DS) != 0} {
+	    if {!$verbose} {
+		puts stderr ""
+	    }
+	    puts "unbalanced .DS .DE"
+	}
+	if {$manual(.CS) != 0} {
+	    if {!$verbose} {
+		puts stderr ""
+	    }
+	    puts "unbalanced .CS .CE"
+	}
+	if {$manual(.SO) != 0} {
+	    if {!$verbose} {
+		puts stderr ""
+	    }
+	    puts "unbalanced .SO .SE"
+	}
+	# output conversion
+	open-text
+	set haserror 0
+	if {[next-op-is .HS rest]} {
+	    set manual($manual(wing-file)-$manual(name)-title) \
+		"[join [lrange $rest 1 end] { }] [lindex $rest 0] manual page"
+	} elseif {[next-op-is .TH rest]} {
+	    set manual($manual(wing-file)-$manual(name)-title) \
+		"[lindex $rest 0] manual page - [join [lrange $rest 4 end] { }]"
+	} else {
+	    set haserror 1
+	    if {!$verbose} {
+		puts stderr ""
+	    }
+	    manerror "no .HS or .TH record found"
+	}
+	if {!$haserror} {
+	    while {[more-text]} {
+		set line [next-text]
+		if {[is-a-directive $line]} {
+		    output-directive $line
+		} else {
+		    man-puts $line
+		}
+	    }
+	    man-puts [copyout $manual(copyrights) "../"]
+	    set manual(wing-copyrights) [merge-copyrights \
+		    $manual(wing-copyrights) $manual(copyrights)]
+	}
+	#
+	# make the long table of contents for this page
+	#
+	set manual(toc-$manual(wing-file)-$manual(name)) \
+	    [concat <DL> $manual(section-toc) </DL>]
+    }
+    if {!$verbose} {
+	puts stderr ""
+    }
+
+    #
+    # make the wing table of contents for the section
+    #
+    set width 0
+    foreach name $manual(wing-toc) {
+	if {[string length $name] > $width} {
+	    set width [string length $name]
+	}
+    }
+    set perline [expr {118 / $width}]
+    set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}]
+    set n 0
+    catch {unset rows}
+    foreach name [lsort -dictionary $manual(wing-toc)] {
+	set tail $manual(name-$name)
+	if {[llength $tail] > 1} {
+	    manerror "$name is defined in more than one file: $tail"
+	    set tail [lindex $tail [expr {[llength $tail]-1}]]
+	}
+	set tail [file tail $tail]
+	append rows([expr {$n%$nrows}]) \
+	    "<td> <a href=\"$tail.htm\">$name</a> </td>"
+	incr n
+    }
+    puts $manual(wing-toc-fp) <table>
+    foreach row [lsort -integer [array names rows]] {
+	puts $manual(wing-toc-fp) <tr>$rows($row)</tr>
+    }
+    puts $manual(wing-toc-fp) </table>
+
+    #
+    # insert wing copyrights
+    #
+    puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"]
+    puts $manual(wing-toc-fp) "</BODY></HTML>"
+    close $manual(wing-toc-fp)
+    set manual(merge-copyrights) \
+	[merge-copyrights $manual(merge-copyrights) $manual(wing-copyrights)]
+}
+
 proc makedirhier {dir} {
     try {
 	if {![file isdirectory $dir]} {
diff --git a/tools/tcltk-man2html.tcl b/tools/tcltk-man2html.tcl
index e4845a6..585d76a 100755
--- a/tools/tcltk-man2html.tcl
+++ b/tools/tcltk-man2html.tcl
@@ -1,6 +1,4 @@
-#!/bin/sh
-# The next line is executed by /bin/sh, but not tcl \
-exec tclsh "$0" ${1+"$@"}
+#!/usr/bin/env tclsh
 
 package require Tcl 8.6
 
@@ -261,364 +259,36 @@ proc make-man-pages {html args} {
     puts $manual(short-toc-fp) "<DL class=\"keylist\">"
     set manual(merge-copyrights) {}
 
-    set LQ \u201c
-    set RQ \u201d
-
     foreach arg $args {
 	# preprocess to set up subheader for the rest of the files
 	if {![llength $arg]} {
 	    continue
 	}
-	set name [lindex $arg 1]
-	set file [lindex $arg 2]
+	lassign $arg -> name file
+	if {[regexp {(.*)(?: Package)? Commands(?:, version .*)?} $name -> pkg]} {
+	    set name "$pkg Commands"
+	} elseif {[regexp {(.*)(?: Package)? C API(?:, version .*)?} $name -> pkg]} {
+	    set name "$pkg C API"
+	}
 	lappend manual(subheader) $name $file
     }
-    foreach arg $args {
-	if {![llength $arg]} {
-	    continue
-	}
-	set manual(wing-glob) [lindex $arg 0]
-	set manual(wing-name) [lindex $arg 1]
-	set manual(wing-file) [lindex $arg 2]
-	set manual(wing-description) [lindex $arg 3]
-	set manual(wing-copyrights) {}
-	makedirhier $html/$manual(wing-file)
-	set manual(wing-toc-fp) [open $html/$manual(wing-file)/[indexfile] w]
-	# whistle
-	puts stderr "scanning section $manual(wing-name)"
-	# put the entry for this section into the short table of contents
-	puts $manual(short-toc-fp) "<DT><A HREF=\"$manual(wing-file)/[indexfile]\">$manual(wing-name)</A></DT><DD>$manual(wing-description)</DD>"
-	# initialize the wing table of contents
-	puts $manual(wing-toc-fp) [htmlhead $manual(wing-name) \
-		$manual(wing-name) $overall_title "../[indexfile]"]
-	# initialize the short table of contents for this section
-	set manual(wing-toc) {}
-	# initialize the man directory for this section
-	makedirhier $html/$manual(wing-file)
-	# initialize the long table of contents for this section
-	set manual(long-toc-n) 1
-	# get the manual pages for this section
-	set manual(pages) [lsort -dictionary [glob -nocomplain $manual(wing-glob)]]
-	# Some pages have to go first so that their links override others
-	foreach pat $process_first_patterns {
-	    set n [lsearch -glob $manual(pages) $pat]
-	    if {$n >= 0} {
-		set f [lindex $manual(pages) $n]
-		puts stderr "shuffling [file tail $f] to front of processing queue"
-		set manual(pages) \
-		    [linsert [lreplace $manual(pages) $n $n] 0 $f]
-	    }
-	}
-	# set manual(pages) [lrange $manual(pages) 0 5]
-	foreach manual_page $manual(pages) {
-	    set manual(page) [file normalize $manual_page]
-	    # whistle
-	    if {$verbose} {
-		puts stderr "scanning page $manual(page)"
-	    } else {
-		puts -nonewline stderr .
-	    }
-	    set manual(tail) [file tail $manual(page)]
-	    set manual(name) [file root $manual(tail)]
-	    set manual(section) {}
-	    if {$manual(name) in $excluded_pages} {
-		# obsolete
-		if {!$verbose} {
-		    puts stderr ""
-		}
-		manerror "discarding $manual(name)"
-		continue
-	    }
-	    set manual(infp) [open $manual(page)]
-	    set manual(text) {}
-	    set manual(partial-text) {}
-	    foreach p {.RS .DS .CS .SO} {
-		set manual($p) 0
-	    }
-	    set manual(stack) {}
-	    set manual(section) {}
-	    set manual(section-toc) {}
-	    set manual(section-toc-n) 1
-	    set manual(copyrights) {}
-	    lappend manual(all-pages) $manual(wing-file)/$manual(tail)
-	    manreport 100 $manual(name)
-	    while {[gets $manual(infp) line] >= 0} {
-		manreport 100 $line
-		if {[regexp {^[`'][/\\]} $line]} {
-		    if {[regexp {Copyright (?:\(c\)|\\\(co).*$} $line copyright]} {
-			lappend manual(copyrights) $copyright
-		    }
-		    # comment
-		    continue
-		}
-		if {"$line" eq {'}} {
-		    # comment
-		    continue
-		}
-		if {![parse-directive $line code rest]} {
-		    addbuffer $line
-		    continue
-		}
-		switch -exact -- $code {
-		    .if - .nr - .ti - .in - .ie - .el -
-		    .ad - .na - .so - .ne - .AS - .VE - .VS - . {
-			# ignore
-			continue
-		    }
-		}
-		switch -exact -- $code {
-		    .SH - .SS {
-			flushbuffer
-			if {[llength $rest] == 0} {
-			    gets $manual(infp) rest
-			}
-			lappend manual(text) "$code [unquote $rest]"
-		    }
-		    .TH {
-			flushbuffer
-			lappend manual(text) "$code [unquote $rest]"
-		    }
-		    .QW {
-			lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
-			    inQuote afterwards
-			addbuffer $LQ [unquote $inQuote] $RQ [unquote $afterwards]
-		    }
-		    .PQ {
-			lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
-			    inQuote punctuation afterwards
-			addbuffer ( $LQ [unquote $inQuote] $RQ \
-			    [unquote $punctuation] ) \
-			    [unquote $afterwards]
-		    }
-		    .QR {
-			lassign [regexp -all -inline {\"(?:[^""]+)\"|\S+} $rest] \
-			    rangeFrom rangeTo afterwards
-			addbuffer $LQ [unquote $rangeFrom] "&ndash;" \
-			    [unquote $rangeTo] $RQ [unquote $afterwards]
-		    }
-		    .MT {
-			addbuffer $LQ$RQ
-		    }
-		    .HS - .UL - .ta {
-			flushbuffer
-			lappend manual(text) "$code [unquote $rest]"
-		    }
-		    .BS - .BE - .br - .fi - .sp - .nf {
-			flushbuffer
-			if {$rest ne ""} {
-			    if {!$verbose} {
-				puts stderr ""
-			    }
-			    manerror "unexpected argument: $line"
-			}
-			lappend manual(text) $code
-		    }
-		    .AP {
-			flushbuffer
-			lappend manual(text) [concat .IP [process-text "[lindex $rest 0] \\fB[lindex $rest 1]\\fR ([lindex $rest 2])"]]
-		    }
-		    .IP {
-			flushbuffer
-			regexp {^(.*) +\d+$} $rest all rest
-			lappend manual(text) ".IP [process-text [unquote [string trim $rest]]]"
-		    }
-		    .TP {
-			flushbuffer
-			while {[is-a-directive [set next [gets $manual(infp)]]]} {
-			    if {!$verbose} {
-				puts stderr ""
-			    }
-			    manerror "ignoring $next after .TP"
-			}
-			if {"$next" ne {'}} {
-			    lappend manual(text) ".IP [process-text $next]"
-			}
-		    }
-		    .OP {
-			flushbuffer
-			lassign $rest cmdName dbName dbClass
-			lappend manual(text) [concat .OP [process-text \
-				"\\fB$cmdName\\fR \\fB$dbName\\fR \\fB$dbClass\\fR"]]
-		    }
-		    .PP - .LP {
-			flushbuffer
-			lappend manual(text) {.PP}
-		    }
-		    .RS {
-			flushbuffer
-			incr manual(.RS)
-			lappend manual(text) $code
-		    }
-		    .RE {
-			flushbuffer
-			incr manual(.RS) -1
-			lappend manual(text) $code
-		    }
-		    .SO {
-			flushbuffer
-			incr manual(.SO)
-			if {[llength $rest] == 0} {
-			    lappend manual(text) "$code options"
-			} else {
-			    lappend manual(text) "$code [unquote $rest]"
-			}
-		    }
-		    .SE {
-			flushbuffer
-			incr manual(.SO) -1
-			lappend manual(text) $code
-		    }
-		    .DS {
-			flushbuffer
-			incr manual(.DS)
-			lappend manual(text) $code
-		    }
-		    .DE {
-			flushbuffer
-			incr manual(.DS) -1
-			lappend manual(text) $code
-		    }
-		    .CS {
-			flushbuffer
-			incr manual(.CS)
-			lappend manual(text) $code
-		    }
-		    .CE {
-			flushbuffer
-			incr manual(.CS) -1
-			lappend manual(text) $code
-		    }
-		    .de {
-			while {[gets $manual(infp) line] >= 0} {
-			    if {[string match "..*" $line]} {
-				break
-			    }
-			}
-		    }
-		    .. {
-			if {!$verbose} {
-			    puts stderr ""
-			}
-			error "found .. outside of .de"
-		    }
-		    default {
-			if {!$verbose} {
-			    puts stderr ""
-			}
-			flushbuffer
-			manerror "unrecognized format directive: $line"
-		    }
-		}
-	    }
-	    flushbuffer
-	    close $manual(infp)
-	    # fixups
-	    if {$manual(.RS) != 0} {
-		if {!$verbose} {
-		    puts stderr ""
-		}
-		puts "unbalanced .RS .RE"
-	    }
-	    if {$manual(.DS) != 0} {
-		if {!$verbose} {
-		    puts stderr ""
-		}
-		puts "unbalanced .DS .DE"
-	    }
-	    if {$manual(.CS) != 0} {
-		if {!$verbose} {
-		    puts stderr ""
-		}
-		puts "unbalanced .CS .CE"
-	    }
-	    if {$manual(.SO) != 0} {
-		if {!$verbose} {
-		    puts stderr ""
-		}
-		puts "unbalanced .SO .SE"
-	    }
-	    # output conversion
-	    open-text
-	    set haserror 0
-	    if {[next-op-is .HS rest]} {
-		set manual($manual(wing-file)-$manual(name)-title) \
-		    "[join [lrange $rest 1 end] { }] [lindex $rest 0] manual page"
-	    } elseif {[next-op-is .TH rest]} {
-		set manual($manual(wing-file)-$manual(name)-title) \
-		    "[lindex $rest 0] manual page - [join [lrange $rest 4 end] { }]"
-	    } else {
-		set haserror 1
-		if {!$verbose} {
-		    puts stderr ""
-		}
-		manerror "no .HS or .TH record found"
-	    }
-	    if {!$haserror} {
-		while {[more-text]} {
-		    set line [next-text]
-		    if {[is-a-directive $line]} {
-			output-directive $line
-		    } else {
-			man-puts $line
-		    }
-		}
-		man-puts [copyout $manual(copyrights) "../"]
-		set manual(wing-copyrights) [merge-copyrights \
-			$manual(wing-copyrights) $manual(copyrights)]
-	    }
-	    #
-	    # make the long table of contents for this page
-	    #
-	    set manual(toc-$manual(wing-file)-$manual(name)) \
-		    [concat <DL> $manual(section-toc) </DL>]
-	}
-	if {!$verbose} {
-	    puts stderr ""
-	}
 
-	#
-	# make the wing table of contents for the section
-	#
-	set width 0
-	foreach name $manual(wing-toc) {
-	    if {[string length $name] > $width} {
-		set width [string length $name]
-	    }
-	}
-	set perline [expr {118 / $width}]
-	set nrows [expr {([llength $manual(wing-toc)]+$perline)/$perline}]
-	set n 0
-        catch {unset rows}
-	foreach name [lsort -dictionary $manual(wing-toc)] {
-	    set tail $manual(name-$name)
-	    if {[llength $tail] > 1} {
-		manerror "$name is defined in more than one file: $tail"
-		set tail [lindex $tail [expr {[llength $tail]-1}]]
-	    }
-	    set tail [file tail $tail]
-	    append rows([expr {$n%$nrows}]) \
-		    "<td> <a href=\"$tail.htm\">$name</a> </td>"
-	    incr n
-	}
-	puts $manual(wing-toc-fp) <table>
-        foreach row [lsort -integer [array names rows]] {
-	    puts $manual(wing-toc-fp) <tr>$rows($row)</tr>
+    ##
+    ## parse the manpages in a section of the docs (split by
+    ## package) and construct formatted manpages
+    ##
+    foreach arg $args {
+	if {[llength $arg]} {
+	    make-manpage-section $html $arg
 	}
-	puts $manual(wing-toc-fp) </table>
-
-	#
-	# insert wing copyrights
-	#
-	puts $manual(wing-toc-fp) [copyout $manual(wing-copyrights) "../"]
-	puts $manual(wing-toc-fp) "</BODY></HTML>"
-	close $manual(wing-toc-fp)
-	set manual(merge-copyrights) [merge-copyrights \
-		$manual(merge-copyrights) $manual(wing-copyrights)]
     }
 
     ##
     ## build the keyword index.
     ##
+    if {!$verbose} {
+	puts stderr "Assembling index"
+    }
     file delete -force -- $html/Keywords
     makedirhier $html/Keywords
     set keyfp [open $html/Keywords/[indexfile] w]
@@ -688,9 +358,9 @@ proc make-man-pages {html args} {
     ##
     unset manual(section)
     if {!$verbose} {
-	puts stderr "Rescanning [llength $manual(all-pages)] pages to build cross links"
+	puts stderr "Rescanning [llength $manual(all-pages)] pages to build cross links and write out"
     }
-    foreach path $manual(all-pages) {
+    foreach path $manual(all-pages) wing_name $manual(all-page-domains) {
 	set manual(wing-file) [file dirname $path]
 	set manual(tail) [file tail $path]
 	set manual(name) [file root $manual(tail)]
@@ -714,7 +384,7 @@ proc make-man-pages {html args} {
 	    }
 	    set outfd [open $html/$manual(wing-file)/$manual(name).htm w]
 	    puts $outfd [htmlhead "$manual($manual(wing-file)-$manual(name)-title)" \
-		    $manual(name) $manual(wing-file) "[indexfile]" \
+		    $manual(name) $wing_name "[indexfile]" \
 		    $overall_title "../[indexfile]"]
 	    if {($ntext > 60) && ($ntoc > 32)} {
 		foreach item $toc {
@@ -789,7 +459,7 @@ proc plus-pkgs {type args} {
 		    "The additional commands provided by the $name package."
 	    }
 	    3 {
-		set title "$name Package Library"
+		set title "$name Package C API"
 		if {$version ne ""} {
 		    append title ", version $version"
 		}
@@ -990,9 +660,9 @@ try {
 	[plus-base $build_tk $tkdir/doc/*.n {Tk Commands} TkCmd \
 	     "The additional commands which the <B>wish</B> interpreter implements."] \
 	{*}[plus-pkgs n {*}$packageDirNameMap] \
-	[plus-base $build_tcl $tcldir/doc/*.3 {Tcl Library} TclLib \
+	[plus-base $build_tcl $tcldir/doc/*.3 {Tcl C API} TclLib \
 	     "The C functions which a Tcl extended C program may use."] \
-	[plus-base $build_tk $tkdir/doc/*.3 {Tk Library} TkLib \
+	[plus-base $build_tk $tkdir/doc/*.3 {Tk C API} TkLib \
 	     "The additional C functions which a Tk extended C program may use."] \
 	{*}[plus-pkgs 3 {*}$packageDirNameMap]
 } on error {msg opts} {
@@ -1001,7 +671,7 @@ try {
     puts $msg\n[dict get $opts -errorinfo]
     exit 1
 }
-
+
 # Local-Variables:
 # mode: tcl
 # End:
-- 
cgit v0.12


From 28efdc8a7830a383b4c27727ce1a879727756958 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 2 Oct 2011 16:29:42 +0000
Subject: Experimental compilation of the [dict with] subcommand. No tests yet,
 and not yet certain that the added bytecode opcodes are correct; evaluation
 is still needed (but the test suite does pass...)

---
 ChangeLog             |   7 ++
 generic/tclCompCmds.c | 179 ++++++++++++++++++++++++++
 generic/tclCompExpr.c | 340 +++++++++++++++++++++++++++-----------------------
 generic/tclCompile.c  |  10 ++
 generic/tclCompile.h  |   5 +-
 generic/tclDictObj.c  | 213 +++++++++++++++++++++----------
 generic/tclExecute.c  |  45 ++++++-
 generic/tclInt.h      |   8 ++
 8 files changed, 584 insertions(+), 223 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 1bcaf49..c112d2b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-10-02  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclDictObj.c (TclDictWithInit, TclDictWithFinish):
+	* generic/tclCompCmds.c (TclCompileDictWithCmd): Experimental
+	compilation for the [dict with] subcommand, using parts factored out
+	from the interpreted version of the command.
+
 2011-09-29  Donal K. Fellows  <dkf@users.sf.net>
 
 	* tools/tcltk-man2html.tcl, tools/tcltk-man2html-utils.tcl: More
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 66c03ab..172a58d 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -1234,6 +1234,185 @@ TclCompileDictLappendCmd(
     TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
     return TCL_OK;
 }
+
+int
+TclCompileDictWithCmd(
+    Tcl_Interp *interp,		/* Used for looking up stuff. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the command
+				 * created by Tcl_ParseCommand. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds resulting instructions. */
+{
+    DefineLineInformation;	/* TIP #280 */
+    int i, range, varNameTmp, pathTmp, keysTmp, gotPath;
+    Tcl_Token *dictVarTokenPtr, *tokenPtr;
+    int savedStackDepth = envPtr->currStackDepth;
+    JumpFixup jumpFixup;
+
+    /*
+     * There must be at least one argument after the command and we must be in
+     * a procedure so we can have local temporaries.
+     */
+
+    if (envPtr->procPtr == NULL) {
+	return TCL_ERROR;
+    }
+    if (parsePtr->numWords < 3) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Parse the command (trivially). Expect the following:
+     *   dict with <any (varName)> ?<any> ...? <literal>
+     */
+
+    dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
+    tokenPtr = TokenAfter(dictVarTokenPtr);
+    for (i=3 ; i<parsePtr->numWords ; i++) {
+	tokenPtr = TokenAfter(tokenPtr);
+    }
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Allocate local (unnamed, untraced) working variables.
+     */
+
+    gotPath = (parsePtr->numWords > 3);
+    varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    if (gotPath) {
+	pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    } else {
+	pathTmp = -1;
+    }
+    keysTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+
+    /*
+     * Issue instructions. First, the part to expand the dictionary.
+     */
+
+    tokenPtr = dictVarTokenPtr;
+    CompileWord(envPtr, tokenPtr, interp, 0);
+    if (varNameTmp <= 255) {
+	TclEmitInstInt1(	INST_STORE_SCALAR1, varNameTmp,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_STORE_SCALAR4, varNameTmp,	envPtr);
+    }
+    tokenPtr = TokenAfter(tokenPtr);
+    if (gotPath) {
+	for (i=2 ; i<parsePtr->numWords-1 ; i++) {
+	    CompileWord(envPtr, tokenPtr, interp, i-1);
+	    tokenPtr = TokenAfter(tokenPtr);
+	}
+	TclEmitInstInt4(	INST_LIST, parsePtr->numWords-3,envPtr);
+	if (pathTmp <= 255) {
+	    TclEmitInstInt1(	INST_STORE_SCALAR1, pathTmp,	envPtr);
+	} else {
+	    TclEmitInstInt4(	INST_STORE_SCALAR4, pathTmp,	envPtr);
+	}
+	TclEmitOpcode(		INST_POP,			envPtr);
+    }
+    TclEmitOpcode(		INST_LOAD_STK,			envPtr);
+    if (gotPath) {
+	if (pathTmp <= 255) {
+	    TclEmitInstInt1(	INST_LOAD_SCALAR1, pathTmp,	envPtr);
+	} else {
+	    TclEmitInstInt4(	INST_LOAD_SCALAR4, pathTmp,	envPtr);
+	}
+    } else {
+	PushLiteral(envPtr, "", 0);
+    }
+    TclEmitOpcode(		INST_DICT_EXPAND,		envPtr);
+    if (keysTmp <= 255) {
+	TclEmitInstInt1(	INST_STORE_SCALAR1, keysTmp,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_STORE_SCALAR4, keysTmp,	envPtr);
+    }
+    TclEmitOpcode(		INST_POP,			envPtr);
+
+    /*
+     * Now the body of the [dict with].
+     */
+
+    range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
+    TclEmitInstInt4(		INST_BEGIN_CATCH4, range,	envPtr);
+
+    ExceptionRangeStarts(envPtr, range);
+    envPtr->currStackDepth++;
+    SetLineInformation(parsePtr->numWords-1);
+    CompileBody(envPtr, tokenPtr, interp);
+    envPtr->currStackDepth = savedStackDepth;
+    ExceptionRangeEnds(envPtr, range);
+
+    /*
+     * Now fold the results back into the dictionary in the OK case.
+     */
+
+    TclEmitOpcode(		INST_END_CATCH,			envPtr);
+    if (varNameTmp <= 255) {
+	TclEmitInstInt1(	INST_LOAD_SCALAR1, varNameTmp,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_LOAD_SCALAR4, varNameTmp,	envPtr);
+    }
+    if (gotPath) {
+	if (pathTmp <= 255) {
+	    TclEmitInstInt1(	INST_LOAD_SCALAR1, pathTmp,	envPtr);
+	} else {
+	    TclEmitInstInt4(	INST_LOAD_SCALAR4, pathTmp,	envPtr);
+	}
+    } else {
+	PushLiteral(envPtr, "", 0);
+    }
+    if (keysTmp <= 255) {
+	TclEmitInstInt1(	INST_LOAD_SCALAR1, keysTmp,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_LOAD_SCALAR4, keysTmp,	envPtr);
+    }
+    TclEmitOpcode(		INST_DICT_RECOMBINE,		envPtr);
+    TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+
+    /*
+     * Now fold the results back into the dictionary in the exception case.
+     */
+
+    ExceptionRangeTarget(envPtr, range, catchOffset);
+    TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
+    TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
+    TclEmitOpcode(		INST_END_CATCH,			envPtr);
+    if (varNameTmp <= 255) {
+	TclEmitInstInt1(	INST_LOAD_SCALAR1, varNameTmp,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_LOAD_SCALAR4, varNameTmp,	envPtr);
+    }
+    if (parsePtr->numWords > 3) {
+	if (pathTmp <= 255) {
+	    TclEmitInstInt1(	INST_LOAD_SCALAR1, pathTmp,	envPtr);
+	} else {
+	    TclEmitInstInt4(	INST_LOAD_SCALAR4, pathTmp,	envPtr);
+	}
+    } else {
+	PushLiteral(envPtr, "", 0);
+    }
+    if (keysTmp <= 255) {
+	TclEmitInstInt1(	INST_LOAD_SCALAR1, keysTmp,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_LOAD_SCALAR4, keysTmp,	envPtr);
+    }
+    TclEmitOpcode(		INST_DICT_RECOMBINE,		envPtr);
+    TclEmitOpcode(		INST_RETURN_STK,		envPtr);
+
+    /*
+     * Prepare for the start of the next command.
+     */
+
+    if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
+	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
+		(int) (CurrentOffset(envPtr) - jumpFixup.codeOffset));
+    }
+    return TCL_OK;
+}
 
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c
index d96670c..b043fed 100644
--- a/generic/tclCompExpr.c
+++ b/generic/tclCompExpr.c
@@ -167,135 +167,135 @@ enum Marks {
 
 /* Leaf lexemes */
 
-#define NUMBER		( LEAF | 1)	/* For literal numbers */
-#define SCRIPT		( LEAF | 2)	/* Script substitution; [foo] */
-#define BOOLEAN		( LEAF | BAREWORD)	/* For literal booleans */
-#define BRACED		( LEAF | 4)	/* Braced string; {foo bar} */
-#define VARIABLE	( LEAF | 5)	/* Variable substitution; $x */
-#define QUOTED		( LEAF | 6)	/* Quoted string; "foo $bar [soom]" */
-#define EMPTY		( LEAF | 7)	/* Used only for an empty argument
-					 * list to a function. Represents the
-					 * empty string within parens in the
-					 * expression: rand() */
+#define NUMBER		(LEAF | 1)
+				/* For literal numbers */
+#define SCRIPT		(LEAF | 2)
+				/* Script substitution; [foo] */
+#define BOOLEAN		(LEAF | BAREWORD)
+				/* For literal booleans */
+#define BRACED		(LEAF | 4)
+				/* Braced string; {foo bar} */
+#define VARIABLE	(LEAF | 5)
+				/* Variable substitution; $x */
+#define QUOTED		(LEAF | 6)
+				/* Quoted string; "foo $bar [soom]" */
+#define EMPTY		(LEAF | 7)
+				/* Used only for an empty argument list to a
+				 * function. Represents the empty string
+				 * within parens in the expression: rand() */
 
 /* Unary operator lexemes */
 
-#define UNARY_PLUS	( UNARY | PLUS)
-#define UNARY_MINUS	( UNARY | MINUS)
-#define FUNCTION	( UNARY | BAREWORD)	/* This is a bit of "creative
-					 * interpretation" on the part of the
-					 * parser. A function call is parsed
-					 * into the parse tree according to
-					 * the perspective that the function
-					 * name is a unary operator and its
-					 * argument list, enclosed in parens,
-					 * is its operand. The additional
-					 * requirements not implied generally
-					 * by treatment as a unary operator --
-					 * for example, the requirement that
-					 * the operand be enclosed in parens
-					 * -- are hard coded in the relevant
-					 * portions of ParseExpr(). We trade
-					 * off the need to include such
-					 * exceptional handling in the code
-					 * against the need we would otherwise
-					 * have for more lexeme categories. */
-#define START		( UNARY | 4)	/* This lexeme isn't parsed from the
-					 * expression text at all. It
-					 * represents the start of the
-					 * expression and sits at the root of
-					 * the parse tree where it serves as
-					 * the start/end point of
-					 * traversals. */
-#define OPEN_PAREN	( UNARY | 5)	/* Another bit of creative
-					 * interpretation, where we treat "("
-					 * as a unary operator with the
-					 * sub-expression between it and its
-					 * matching ")" as its operand. See
-					 * CLOSE_PAREN below. */
-#define NOT		( UNARY | 6)
-#define BIT_NOT		( UNARY | 7)
+#define UNARY_PLUS	(UNARY | PLUS)
+#define UNARY_MINUS	(UNARY | MINUS)
+#define FUNCTION	(UNARY | BAREWORD)
+				/* This is a bit of "creative interpretation"
+				 * on the part of the parser. A function call
+				 * is parsed into the parse tree according to
+				 * the perspective that the function name is a
+				 * unary operator and its argument list,
+				 * enclosed in parens, is its operand. The
+				 * additional requirements not implied
+				 * generally by treatment as a unary operator
+				 * -- for example, the requirement that the
+				 * operand be enclosed in parens -- are hard
+				 * coded in the relevant portions of
+				 * ParseExpr(). We trade off the need to
+				 * include such exceptional handling in the
+				 * code against the need we would otherwise
+				 * have for more lexeme categories. */
+#define START		(UNARY | 4)
+				/* This lexeme isn't parsed from the
+				 * expression text at all. It represents the
+				 * start of the expression and sits at the
+				 * root of the parse tree where it serves as
+				 * the start/end point of traversals. */
+#define OPEN_PAREN	(UNARY | 5)
+				/* Another bit of creative interpretation,
+				 * where we treat "(" as a unary operator with
+				 * the sub-expression between it and its
+				 * matching ")" as its operand. See
+				 * CLOSE_PAREN below. */
+#define NOT		(UNARY | 6)
+#define BIT_NOT		(UNARY | 7)
 
 /* Binary operator lexemes */
 
-#define BINARY_PLUS	( BINARY |  PLUS)
-#define BINARY_MINUS	( BINARY |  MINUS)
-#define COMMA		( BINARY |  3)	/* The "," operator is a low
-					 * precedence binary operator that
-					 * separates the arguments in a
-					 * function call. The additional
-					 * constraint that this operator can
-					 * only legally appear at the right
-					 * places within a function call
-					 * argument list are hard coded within
-					 * ParseExpr().  */
-#define MULT		( BINARY |  4)
-#define DIVIDE		( BINARY |  5)
-#define MOD		( BINARY |  6)
-#define LESS		( BINARY |  7)
-#define GREATER		( BINARY |  8)
-#define BIT_AND		( BINARY |  9)
-#define BIT_XOR		( BINARY | 10)
-#define BIT_OR		( BINARY | 11)
-#define QUESTION	( BINARY | 12)	/* These two lexemes make up the */
-#define COLON		( BINARY | 13)	/* ternary conditional operator,
-					 * $x ? $y : $z . We treat them as two
-					 * binary operators to avoid another
-					 * lexeme category, and code the
-					 * additional constraints directly in
-					 * ParseExpr(). For instance, the
-					 * right operand of a "?" operator
-					 * must be a ":" operator. */
-#define LEFT_SHIFT	( BINARY | 14)
-#define RIGHT_SHIFT	( BINARY | 15)
-#define LEQ		( BINARY | 16)
-#define GEQ		( BINARY | 17)
-#define EQUAL		( BINARY | 18)
-#define NEQ		( BINARY | 19)
-#define AND		( BINARY | 20)
-#define OR		( BINARY | 21)
-#define STREQ		( BINARY | 22)
-#define STRNEQ		( BINARY | 23)
-#define EXPON		( BINARY | 24)	/* Unlike the other binary operators,
-					 * EXPON is right associative and this
-					 * distinction is coded directly in
-					 * ParseExpr(). */
-#define IN_LIST		( BINARY | 25)
-#define NOT_IN_LIST	( BINARY | 26)
-#define CLOSE_PAREN	( BINARY | 27)	/* By categorizing the CLOSE_PAREN
-					 * lexeme as a BINARY operator, the
-					 * normal parsing rules for binary
-					 * operators assure that a close paren
-					 * will not directly follow another
-					 * operator, and the machinery already
-					 * in place to connect operands to
-					 * operators according to precedence
-					 * performs most of the work of
-					 * matching open and close parens for
-					 * us. In the end though, a close
-					 * paren is not really a binary
-					 * operator, and some special coding
-					 * in ParseExpr() make sure we never
-					 * put an actual CLOSE_PAREN node in
-					 * the parse tree. The sub-expression
-					 * between parens becomes the single
-					 * argument of the matching OPEN_PAREN
-					 * unary operator. */
-#define END		( BINARY | 28)	/* This lexeme represents the end of
-					 * the string being parsed. Treating
-					 * it as a binary operator follows the
-					 * same logic as the CLOSE_PAREN
-					 * lexeme and END pairs with START, in
-					 * the same way that CLOSE_PAREN pairs
-					 * with OPEN_PAREN. */
+#define BINARY_PLUS	(BINARY |  PLUS)
+#define BINARY_MINUS	(BINARY |  MINUS)
+#define COMMA		(BINARY |  3)
+				/* The "," operator is a low precedence binary
+				 * operator that separates the arguments in a
+				 * function call. The additional constraint
+				 * that this operator can only legally appear
+				 * at the right places within a function call
+				 * argument list are hard coded within
+				 * ParseExpr().  */
+#define MULT		(BINARY |  4)
+#define DIVIDE		(BINARY |  5)
+#define MOD		(BINARY |  6)
+#define LESS		(BINARY |  7)
+#define GREATER		(BINARY |  8)
+#define BIT_AND		(BINARY |  9)
+#define BIT_XOR		(BINARY | 10)
+#define BIT_OR		(BINARY | 11)
+#define QUESTION	(BINARY | 12)
+				/* These two lexemes make up the */
+#define COLON		(BINARY | 13)
+				/* ternary conditional operator, $x ? $y : $z.
+				 * We treat them as two binary operators to
+				 * avoid another lexeme category, and code the
+				 * additional constraints directly in
+				 * ParseExpr(). For instance, the right
+				 * operand of a "?" operator must be a ":"
+				 * operator. */
+#define LEFT_SHIFT	(BINARY | 14)
+#define RIGHT_SHIFT	(BINARY | 15)
+#define LEQ		(BINARY | 16)
+#define GEQ		(BINARY | 17)
+#define EQUAL		(BINARY | 18)
+#define NEQ		(BINARY | 19)
+#define AND		(BINARY | 20)
+#define OR		(BINARY | 21)
+#define STREQ		(BINARY | 22)
+#define STRNEQ		(BINARY | 23)
+#define EXPON		(BINARY | 24)
+				/* Unlike the other binary operators, EXPON is
+				 * right associative and this distinction is
+				 * coded directly in ParseExpr(). */
+#define IN_LIST		(BINARY | 25)
+#define NOT_IN_LIST	(BINARY | 26)
+#define CLOSE_PAREN	(BINARY | 27)
+				/* By categorizing the CLOSE_PAREN lexeme as a
+				 * BINARY operator, the normal parsing rules
+				 * for binary operators assure that a close
+				 * paren will not directly follow another
+				 * operator, and the machinery already in
+				 * place to connect operands to operators
+				 * according to precedence performs most of
+				 * the work of matching open and close parens
+				 * for us. In the end though, a close paren is
+				 * not really a binary operator, and some
+				 * special coding in ParseExpr() make sure we
+				 * never put an actual CLOSE_PAREN node in the
+				 * parse tree. The sub-expression between
+				 * parens becomes the single argument of the
+				 * matching OPEN_PAREN unary operator. */
+#define END		(BINARY | 28)
+				/* This lexeme represents the end of the
+				 * string being parsed. Treating it as a
+				 * binary operator follows the same logic as
+				 * the CLOSE_PAREN lexeme and END pairs with
+				 * START, in the same way that CLOSE_PAREN
+				 * pairs with OPEN_PAREN. */
+
 /*
  * When ParseExpr() builds the parse tree it must choose which operands to
  * connect to which operators.  This is done according to operator precedence.
- * The greater an operator's precedence the greater claim it has to link to
- * an available operand.  The Precedence enumeration lists the precedence
- * values used by Tcl expression operators, from lowest to highest claim.
- * Each precedence level is commented with the operators that hold that
- * precedence.
+ * The greater an operator's precedence the greater claim it has to link to an
+ * available operand.  The Precedence enumeration lists the precedence values
+ * used by Tcl expression operators, from lowest to highest claim.  Each
+ * precedence level is commented with the operators that hold that precedence.
  */
 
 enum Precedence {
@@ -320,9 +320,9 @@ enum Precedence {
 };
 
 /*
- * Here the same information contained in the comments above is stored
- * in inverted form, so that given a lexeme, one can quickly look up 
- * its precedence value.
+ * Here the same information contained in the comments above is stored in
+ * inverted form, so that given a lexeme, one can quickly look up its
+ * precedence value.
  */
 
 static const unsigned char prec[] = {
@@ -599,7 +599,10 @@ ParseExpr(
 				 * actual leaf at the time the complete tree
 				 * is needed. */
 
-    /* These variables control generation of the error message. */
+    /*
+     * These variables control generation of the error message.
+     */
+
     Tcl_Obj *msg = NULL;	/* The error message. */
     Tcl_Obj *post = NULL;	/* In a few cases, an additional postscript
 				 * for the error message, supplying more
@@ -801,17 +804,19 @@ ParseExpr(
 	    }
 	}	/* Uncategorized lexemes */
 
-	/* Handle lexeme based on its category. */
-	switch (NODE_TYPE & lexeme) {
-
 	/*
-	 * Each LEAF results in either a literal getting appended to the
-	 * litList, or a sequence of Tcl_Tokens representing a Tcl word
-	 * getting appended to the parsePtr->tokens. No OpNode is filled for
-	 * this lexeme.
+	 * Handle lexeme based on its category.
 	 */
 
+	switch (NODE_TYPE & lexeme) {
 	case LEAF: {
+	    /*
+	     * Each LEAF results in either a literal getting appended to the
+	     * litList, or a sequence of Tcl_Tokens representing a Tcl word
+	     * getting appended to the parsePtr->tokens. No OpNode is filled
+	     * for this lexeme.
+	     */
+
 	    Tcl_Token *tokenPtr;
 	    const char *end = start;
 	    int wordIndex;
@@ -828,7 +833,10 @@ ParseExpr(
 		scanned = 0;
 		insertMark = 1;
 
-		/* Free any literal to avoid a memleak. */
+		/*
+		 * Free any literal to avoid a memleak.
+		 */
+
 		if ((lexeme == NUMBER) || (lexeme == BOOLEAN)) {
 		    Tcl_DecrRefCount(literal);
 		}
@@ -1027,7 +1035,10 @@ ParseExpr(
 		goto error;
 	    }
 
-	    /* Create an OpNode for the unary operator */
+	    /*
+	     * Create an OpNode for the unary operator.
+	     */
+
 	    nodePtr->lexeme = lexeme;
 	    nodePtr->precedence = prec[lexeme];
 	    nodePtr->mark = MARK_RIGHT;
@@ -1498,7 +1509,10 @@ ConvertTreeToTokens(
 
 	case OT_LITERAL:
 
-	    /* Skip any white space that comes before the literal */
+	    /*
+	     * Skip any white space that comes before the literal.
+	     */
+
 	    scanned = TclParseAllWhiteSpace(start, numBytes);
 	    start += scanned;
 	    numBytes -= scanned;
@@ -1581,7 +1595,10 @@ ConvertTreeToTokens(
 
 	default:
 
-	    /* Advance to the child node, which is an operator. */
+	    /*
+	     * Advance to the child node, which is an operator.
+	     */
+
 	    nodePtr = nodes + next;
 
 	    /*
@@ -1662,7 +1679,10 @@ ConvertTreeToTokens(
 	case MARK_RIGHT:
 	    next = nodePtr->right;
 
-	    /* Skip any white space that comes before the operator */
+	    /*
+	     * Skip any white space that comes before the operator.
+	     */
+
 	    scanned = TclParseAllWhiteSpace(start, numBytes);
 	    start += scanned;
 	    numBytes -= scanned;
@@ -1679,7 +1699,10 @@ ConvertTreeToTokens(
 	    case COMMA:
 	    case COLON:
 
-		/* No tokens for these lexemes -> nothing to do. */
+		/*
+		 * No tokens for these lexemes -> nothing to do.
+		 */
+
 		break;
 
 	    default:
@@ -1714,7 +1737,10 @@ ConvertTreeToTokens(
 
 	    case OPEN_PAREN:
 
-		/* Skip past matching close paren. */
+		/*
+		 * Skip past matching close paren.
+		 */
+
 		scanned = TclParseAllWhiteSpace(start, numBytes);
 		start += scanned;
 		numBytes -= scanned;
@@ -1723,7 +1749,7 @@ ConvertTreeToTokens(
 		numBytes -= scanned;
 		break;
 
-	    default: {
+	    default:
 
 		/*
 		 * Before we leave this node/operator/subexpression for the
@@ -1757,7 +1783,6 @@ ConvertTreeToTokens(
 		subExprTokenIdx = parentIdx;
 		break;
 	    }
-	    }
 
 	    /*
 	     * Since we're returning to parent, skip child handling code.
@@ -2009,6 +2034,7 @@ ParseLexeme(
 	     */
 	    if (literal->typePtr == &tclDoubleType) {
 		const char *p = start;
+
 		while (p < end) {
 		    if (!isalnum(UCHAR(*p++))) {
 			/*
@@ -2028,6 +2054,7 @@ ParseLexeme(
 		 */
 		goto number;
 	    }
+
 	    /*
 	     * Otherwise, fall through and parse the whole as a bareword.
 	     */
@@ -2290,22 +2317,22 @@ CompileExprTree(
 		break;
 	    }
 	    case QUESTION:
-		TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump));
+		TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
 		break;
 	    case COLON:
 		CLANG_ASSERT(jumpPtr);
 		TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
-			&(jumpPtr->next->jump));
+			&jumpPtr->next->jump);
 		envPtr->currStackDepth = jumpPtr->depth;
 		jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart);
 		jumpPtr->convert = convert;
 		convert = 1;
 		break;
 	    case AND:
-		TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &(jumpPtr->jump));
+		TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump);
 		break;
 	    case OR:
-		TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &(jumpPtr->jump));
+		TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump);
 		break;
 	    }
 	} else {
@@ -2348,12 +2375,12 @@ CompileExprTree(
 		break;
 	    case COLON:
 		CLANG_ASSERT(jumpPtr);
-		if (TclFixupForwardJump(envPtr, &(jumpPtr->next->jump),
+		if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump,
 			(envPtr->codeNext - envPtr->codeStart)
 			- jumpPtr->next->jump.codeOffset, 127)) {
 		    jumpPtr->offset += 3;
 		}
-		TclFixupForwardJump(envPtr, &(jumpPtr->jump),
+		TclFixupForwardJump(envPtr, &jumpPtr->jump,
 			jumpPtr->offset - jumpPtr->jump.codeOffset, 127);
 		convert |= jumpPtr->convert;
 		envPtr->currStackDepth = jumpPtr->depth + 1;
@@ -2369,18 +2396,18 @@ CompileExprTree(
 		CLANG_ASSERT(jumpPtr);
 		TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND)
 			?  TCL_FALSE_JUMP : TCL_TRUE_JUMP,
-			&(jumpPtr->next->jump));
+			&jumpPtr->next->jump);
 		TclEmitPush(TclRegisterNewLiteral(envPtr,
 			(nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr);
 		TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
-			&(jumpPtr->next->next->jump));
-		TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->jump), 127);
-		if (TclFixupForwardJumpToHere(envPtr, &(jumpPtr->jump), 127)) {
+			&jumpPtr->next->next->jump);
+		TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127);
+		if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) {
 		    jumpPtr->next->next->jump.codeOffset += 3;
 		}
 		TclEmitPush(TclRegisterNewLiteral(envPtr,
 			(nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr);
-		TclFixupForwardJumpToHere(envPtr, &(jumpPtr->next->next->jump),
+		TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump,
 			127);
 		convert = 0;
 		envPtr->currStackDepth = jumpPtr->depth + 1;
@@ -2400,8 +2427,8 @@ CompileExprTree(
 		break;
 	    }
 	    if (nodePtr == rootPtr) {
-
 		/* We're done */
+
 		return;
 	    }
 	    nodePtr = nodes + nodePtr->p.parent;
@@ -2478,6 +2505,7 @@ CompileExprTree(
 		     * Don't generate a string rep, but if we have one
 		     * already, then use it to share via the literal table.
 		     */
+
 		    if (objPtr->bytes) {
 			Tcl_Obj *tableValue;
 
@@ -2486,7 +2514,10 @@ CompileExprTree(
 			tableValue = envPtr->literalArrayPtr[index].objPtr;
 			if ((tableValue->typePtr == NULL) &&
 				(objPtr->typePtr != NULL)) {
-			    /* Same intrep surgery as for OT_LITERAL */
+			    /*
+			     * Same intrep surgery as for OT_LITERAL.
+			     */
+
 			    tableValue->typePtr = objPtr->typePtr;
 			    tableValue->internalRep = objPtr->internalRep;
 			    objPtr->typePtr = NULL;
@@ -2511,6 +2542,7 @@ CompileExprTree(
  *----------------------------------------------------------------------
  *
  * TclSingleOpCmd --
+ *
  *	Implements the commands: ~, !, <<, >>, %, !=, ne, in, ni
  *	in the ::tcl::mathop namespace.  These commands have no
  *	extension to arbitrary arguments; they accept only exactly one
@@ -2537,7 +2569,7 @@ TclSingleOpCmd(
     OpNode nodes[2];
     Tcl_Obj *const *litObjv = objv + 1;
 
-    if (objc != 1+occdPtr->i.numArgs) {
+    if (objc != 1 + occdPtr->i.numArgs) {
 	Tcl_WrongNumArgs(interp, 1, objv, occdPtr->expected);
 	return TCL_ERROR;
     }
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 026503b..4b5d2bb 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -421,6 +421,16 @@ InstructionDesc const tclInstructionTable[] = {
 	/* Make general variable cease to exist; unparsed variable name is
 	 * stktop; op1 is 1 for errors on problems, 0 otherwise */
 
+    {"dictExpand",       1,    -1,        0,    {OPERAND_NONE}},
+        /* Probe into a dict and extract it (or a subdict of it) into
+         * variables with matched names. Produces list of keys bound as
+         * result. Part of [dict with].
+	 * Stack:  ... dict path => ... keyList */
+    {"dictRecombine",    1,    -3,        0,    {OPERAND_NONE}},
+        /* Map variable contents back into a dictionary in a variable. Part of
+         * [dict with].
+	 * Stack:  ... dictVarName path keyList => ... */
+
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 45d50ea..0cd667c 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -676,8 +676,11 @@ typedef struct ByteCode {
 #define INST_UNSET_ARRAY_STK		136
 #define INST_UNSET_STK			137
 
+#define INST_DICT_EXPAND		138
+#define INST_DICT_RECOMBINE		139
+
 /* The last opcode */
-#define LAST_INST_OPCODE		137
+#define LAST_INST_OPCODE		139
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 83fc3a6..5b7ca9b 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -103,7 +103,7 @@ static const EnsembleImplMap implementationMap[] = {
     {"unset",	DictUnsetCmd, NULL, NULL, NULL, 0 },
     {"update",	DictUpdateCmd,	TclCompileDictUpdateCmd, NULL, NULL, 0 },
     {"values",	DictValuesCmd, NULL, NULL, NULL, 0 },
-    {"with",	DictWithCmd, NULL, NULL, NULL, 0 },
+    {"with",	DictWithCmd,	TclCompileDictWithCmd, NULL, NULL, 0 },
     {NULL, NULL, NULL, NULL, NULL, 0}
 };
 
@@ -3110,9 +3110,7 @@ DictWithCmd(
     Tcl_Obj *const *objv)
 {
     Interp *iPtr = (Interp *) interp;
-    Tcl_Obj *dictPtr, *keysPtr, *keyPtr = NULL, *valPtr = NULL, *pathPtr;
-    Tcl_DictSearch s;
-    int done;
+    Tcl_Obj *dictPtr, *keysPtr, *pathPtr;
 
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "dictVar ?key ...? script");
@@ -3127,39 +3125,13 @@ DictWithCmd(
     if (dictPtr == NULL) {
 	return TCL_ERROR;
     }
-    if (objc > 3) {
-	dictPtr = TclTraceDictPath(interp, dictPtr, objc-3, objv+2,
-		DICT_PATH_READ);
-	if (dictPtr == NULL) {
-	    return TCL_ERROR;
-	}
-    }
 
-    /*
-     * Go over the list of keys and write each corresponding value to a
-     * variable in the current context with the same name. Also keep a copy of
-     * the keys so we can write back properly later on even if the dictionary
-     * has been structurally modified.
-     */
-
-    if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr,
-	    &done) != TCL_OK) {
+    keysPtr = TclDictWithInit(interp, dictPtr, objc-3, objv+2);
+    if (keysPtr == NULL) {
 	return TCL_ERROR;
     }
-
-    TclNewObj(keysPtr);
     Tcl_IncrRefCount(keysPtr);
 
-    for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
-	Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
-	if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
-		TCL_LEAVE_ERR_MSG) == NULL) {
-	    TclDecrRefCount(keysPtr);
-	    Tcl_DictObjDone(&s);
-	    return TCL_ERROR;
-	}
-    }
-
     /*
      * Execute the body, while making the invoking context available to the
      * loop body (TIP#280) and postponing the cleanup until later (NRE).
@@ -3183,8 +3155,8 @@ FinalizeDictWith(
     Tcl_Interp *interp,
     int result)
 {
-    Tcl_Obj **keyv, *leafPtr, *dictPtr, *valPtr;
-    int keyc, i, allocdict = 0;
+    Tcl_Obj **pathv;
+    int pathc;
     Tcl_InterpState state;
     Tcl_Obj *varName = data[0];
     Tcl_Obj *keysPtr = data[1];
@@ -3195,43 +3167,163 @@ FinalizeDictWith(
     }
 
     /*
+     * Save the result state; TDWF doesn't guarantee to not modify that on
+     * TCL_OK result.
+     */
+
+    state = Tcl_SaveInterpState(interp, result);
+    if (pathPtr != NULL) {
+	Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv);
+    } else {
+	pathc = 0;
+	pathv = NULL;
+    }
+
+    /*
+     * Pack from local variables back into the dictionary.
+     */
+
+    result = TclDictWithFinish(interp, varName, pathc, pathv, keysPtr);
+
+    /*
+     * Tidy up and return the real result (unless we had an error).
+     */
+
+    TclDecrRefCount(varName);
+    TclDecrRefCount(keysPtr);
+    if (pathPtr != NULL) {
+	TclDecrRefCount(pathPtr);
+    }
+    if (result != TCL_OK) {
+	Tcl_DiscardInterpState(state);
+	return TCL_ERROR;
+    }
+    return Tcl_RestoreInterpState(interp, state);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDictWithInit --
+ *
+ *	Part of the core of [dict with]. Pokes into a dictionary and converts
+ *	the mappings there into assignments to (presumably) local variables.
+ *	Returns a list of all the names that were mapped so that removal of
+ *	either the variable or the dictionary entry won't surprise us when we
+ *	come to stuffing everything back.
+ *
+ * Result:
+ *	List of mapped names, or NULL if there was an error.
+ *
+ * Side effects:
+ *	Assigns to variables, so potentially legion due to traces.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclDictWithInit(
+    Tcl_Interp *interp,
+    Tcl_Obj *dictPtr,
+    int pathc,
+    Tcl_Obj *const pathv[])
+{
+    Tcl_DictSearch s;
+    Tcl_Obj *keyPtr, *valPtr, *keysPtr;
+    int done;
+
+    if (pathc > 0) {
+	dictPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
+		DICT_PATH_READ);
+	if (dictPtr == NULL) {
+	    return NULL;
+	}
+    }
+
+    /*
+     * Go over the list of keys and write each corresponding value to a
+     * variable in the current context with the same name. Also keep a copy of
+     * the keys so we can write back properly later on even if the dictionary
+     * has been structurally modified.
+     */
+
+    if (Tcl_DictObjFirst(interp, dictPtr, &s, &keyPtr, &valPtr,
+	    &done) != TCL_OK) {
+	return NULL;
+    }
+
+    TclNewObj(keysPtr);
+
+    for (; !done ; Tcl_DictObjNext(&s, &keyPtr, &valPtr, &done)) {
+	Tcl_ListObjAppendElement(NULL, keysPtr, keyPtr);
+	if (Tcl_ObjSetVar2(interp, keyPtr, NULL, valPtr,
+		TCL_LEAVE_ERR_MSG) == NULL) {
+	    TclDecrRefCount(keysPtr);
+	    Tcl_DictObjDone(&s);
+	    return NULL;
+	}
+    }
+
+    return keysPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclDictWithFinish --
+ *
+ *	Part of the core of [dict with]. Reassembles the piece of the dict (in
+ *	varName, location given by pathc/pathv) from the variables named in
+ *	the keysPtr argument. NB, does not try to preserve errors or manage
+ *	argument lifetimes.
+ *
+ * Result:
+ *	TCL_OK if we succeeded, or TCL_ERROR if we failed.
+ *
+ * Side effects:
+ *	Assigns to a variable, so potentially legion due to traces. Updates
+ *	the dictionary in the named variable.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclDictWithFinish(
+    Tcl_Interp *interp,
+    Tcl_Obj *varName,
+    int pathc,
+    Tcl_Obj *const pathv[],
+    Tcl_Obj *keysPtr)
+{
+    Tcl_Obj *dictPtr, *leafPtr, *valPtr;
+    int i, allocdict, keyc;
+    Tcl_Obj **keyv;
+
+    /*
      * If the dictionary variable doesn't exist, drop everything silently.
      */
 
     dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0);
     if (dictPtr == NULL) {
-	TclDecrRefCount(varName);
-	TclDecrRefCount(keysPtr);
-	if (pathPtr) {
-	    TclDecrRefCount(pathPtr);
-	}
-	return result;
+	return TCL_OK;
     }
 
     /*
      * Double-check that it is still a dictionary.
      */
 
-    state = Tcl_SaveInterpState(interp, result);
     if (Tcl_DictObjSize(interp, dictPtr, &i) != TCL_OK) {
-	TclDecrRefCount(varName);
-	TclDecrRefCount(keysPtr);
-	if (pathPtr) {
-	    TclDecrRefCount(pathPtr);
-	}
-	Tcl_DiscardInterpState(state);
 	return TCL_ERROR;
     }
 
     if (Tcl_IsShared(dictPtr)) {
 	dictPtr = Tcl_DuplicateObj(dictPtr);
 	allocdict = 1;
+    } else {
+	allocdict = 0;
     }
 
-    if (pathPtr != NULL) {
-	Tcl_Obj **pathv;
-	int pathc;
-
+    if (pathc > 0) {
 	/*
 	 * Want to get to the dictionary which we will update; need to do
 	 * prepare-for-update de-sharing along the path *but* avoid generating
@@ -3241,26 +3333,19 @@ FinalizeDictWith(
 	 * perfectly efficient (but no memory should be leaked).
 	 */
 
-	Tcl_ListObjGetElements(NULL, pathPtr, &pathc, &pathv);
 	leafPtr = TclTraceDictPath(interp, dictPtr, pathc, pathv,
 		DICT_PATH_EXISTS | DICT_PATH_UPDATE);
-	TclDecrRefCount(pathPtr);
 	if (leafPtr == NULL) {
-	    TclDecrRefCount(varName);
-	    TclDecrRefCount(keysPtr);
 	    if (allocdict) {
 		TclDecrRefCount(dictPtr);
 	    }
-	    Tcl_DiscardInterpState(state);
 	    return TCL_ERROR;
 	}
 	if (leafPtr == DICT_PATH_NON_EXISTENT) {
-	    TclDecrRefCount(varName);
-	    TclDecrRefCount(keysPtr);
 	    if (allocdict) {
 		TclDecrRefCount(dictPtr);
 	    }
-	    return Tcl_RestoreInterpState(interp, state);
+	    return TCL_OK;
 	}
     } else {
 	leafPtr = dictPtr;
@@ -3286,14 +3371,13 @@ FinalizeDictWith(
 	    Tcl_DictObjPut(NULL, leafPtr, keyv[i], valPtr);
 	}
     }
-    TclDecrRefCount(keysPtr);
 
     /*
      * Ensure that none of the dictionaries in the chain still have a string
      * rep.
      */
 
-    if (pathPtr != NULL) {
+    if (pathc > 0) {
 	InvalidateDictChain(leafPtr);
     }
 
@@ -3303,11 +3387,12 @@ FinalizeDictWith(
 
     if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr,
 	    TCL_LEAVE_ERR_MSG) == NULL) {
-	Tcl_DiscardInterpState(state);
+	if (allocdict) {
+	    TclDecrRefCount(dictPtr);
+	}
 	return TCL_ERROR;
     }
-    TclDecrRefCount(varName);
-    return Tcl_RestoreInterpState(interp, state);
+    return TCL_OK;
 }
 
 /*
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 691c8d7..e3db83e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1992,9 +1992,8 @@ TclNRExecuteByteCode(
      * Push the callback for bytecode execution
      */
     
-    TclNRAddCallback(interp, TEBCresume, TD,
-	    /*resume*/ INT2PTR(0), NULL, NULL);
-    
+    TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
+	    NULL, NULL);
     return TCL_OK;
 }
 
@@ -5625,7 +5624,7 @@ TEBCresume(
 
     {
 	int opnd2, allocateDict, done, i, allocdict;
-	Tcl_Obj *dictPtr, *statePtr, *keyPtr;
+	Tcl_Obj *dictPtr, *statePtr, *keyPtr, *listPtr, *varNamePtr, *keysPtr;
 	Tcl_Obj *emptyPtr, **keyPtrPtr;
 	Tcl_DictSearch *searchPtr;
 	DictUpdateInfo *duiPtr;
@@ -6105,6 +6104,44 @@ TEBCresume(
 	    }
 	}
 	NEXT_INST_F(9, 1, 0);
+
+    case INST_DICT_EXPAND:
+	dictPtr = OBJ_UNDER_TOS;
+	listPtr = OBJ_AT_TOS;
+	if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+	    TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ",
+		    O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp));
+	    goto gotError;
+	}
+	objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv);
+	if (objResultPtr == NULL) {
+	    TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ",
+		    O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp));
+	    goto gotError;
+	}
+	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+	NEXT_INST_F(1, 2, 1);
+
+    case INST_DICT_RECOMBINE:
+	varNamePtr = OBJ_AT_DEPTH(2);
+	listPtr = OBJ_UNDER_TOS;
+	keysPtr = OBJ_AT_TOS;
+	if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+	    TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ",
+		    O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)),
+		    Tcl_GetObjResult(interp));
+	    goto gotError;
+	}
+	if (TclDictWithFinish(interp, varNamePtr, objc, objv,
+		keysPtr) != TCL_OK) {
+	    TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ",
+		    O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)),
+		    Tcl_GetObjResult(interp));
+	    goto gotError;
+	}
+	TclDecrRefCount(keysPtr);
+	POP_OBJECT();
+	NEXT_INST_F(1, 2, 0);
     }
 
     /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index f30e83e..e7a84ce 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3231,6 +3231,11 @@ MODULE_SCOPE int	TclDefaultBgErrorHandlerObjCmd(
 			    ClientData clientData, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp);
+MODULE_SCOPE int	TclDictWithFinish(Tcl_Interp *interp,
+			    Tcl_Obj *varName, int pathc,
+			    Tcl_Obj *const pathv[], Tcl_Obj *keysPtr);
+MODULE_SCOPE Tcl_Obj *	TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr,
+			    int pathc, Tcl_Obj *const pathv[]);
 MODULE_SCOPE int	Tcl_DisassembleObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
@@ -3495,6 +3500,9 @@ MODULE_SCOPE int	TclCompileDictSetCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileDictUpdateCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileDictWithCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileEnsemble(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From 12b24fa2fb8f381005e95bb52ab317ccfaae110e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 3 Oct 2011 07:51:00 +0000
Subject: Add assembler support for the new INST that I think has a stable
 interface.

---
 generic/tclAssembly.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index cd6dc38..2133ebe 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -370,6 +370,7 @@ TalInstDesc TalInstructionTable[] = {
     {"bitxor",		ASSEM_1BYTE,	INST_BITXOR,		2,	1},
     {"concat",		ASSEM_CONCAT1,	INST_CONCAT1,		INT_MIN,1},
     {"dictAppend",	ASSEM_LVT4,	INST_DICT_APPEND,	2,	1},
+    {"dictExpand",	ASSEM_1BYTE,	INST_DICT_EXPAND,	3,	1},
     {"dictGet",		ASSEM_DICT_GET, INST_DICT_GET,		INT_MIN,1},
     {"dictIncrImm",	ASSEM_SINT4_LVT4,
 					INST_DICT_INCR_IMM,	1,	1},
-- 
cgit v0.12


From f5da66af9b1d20982f24f809029662cdf55fe3b0 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 3 Oct 2011 10:45:35 +0000
Subject: Added support for having the dict var itself referenced by LVT index.

---
 generic/tclCompCmds.c | 69 ++++++++++++++++++++++++++++++++++++++++-----------
 generic/tclCompile.c  |  6 ++++-
 generic/tclCompile.h  |  5 ++--
 generic/tclDictObj.c  | 43 +++++++++++++++++++++++++-------
 generic/tclExecute.c  | 60 ++++++++++++++++++++++++++++++++++----------
 generic/tclInt.h      |  5 ++--
 6 files changed, 147 insertions(+), 41 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 172a58d..0b6b76b 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -1245,7 +1245,7 @@ TclCompileDictWithCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     DefineLineInformation;	/* TIP #280 */
-    int i, range, varNameTmp, pathTmp, keysTmp, gotPath;
+    int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1;
     Tcl_Token *dictVarTokenPtr, *tokenPtr;
     int savedStackDepth = envPtr->currStackDepth;
     JumpFixup jumpFixup;
@@ -1281,7 +1281,32 @@ TclCompileDictWithCmd(
      */
 
     gotPath = (parsePtr->numWords > 3);
-    varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    if (dictVarTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+	const char *ptr = dictVarTokenPtr[1].start;
+	const char *end = ptr + dictVarTokenPtr[1].size;
+	int notArray = 1;
+
+	/*
+	 * A conservative check for if we're working with an array since we
+	 * have a reasonable fallback if things are tricky.
+	 */
+
+	for (; ptr<end ; ptr++) {
+	    if (*ptr == '(' || *ptr == ')') {
+		notArray = 0;
+		break;
+	    }
+	}
+	if (notArray) {
+	    dictVar = TclFindCompiledLocal(dictVarTokenPtr[1].start,
+		    dictVarTokenPtr[1].size, 1, envPtr);
+	}
+    }
+    if (dictVar == -1) {
+	varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
+    } else {
+	varNameTmp = -1;
+    }
     if (gotPath) {
 	pathTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
     } else {
@@ -1294,11 +1319,13 @@ TclCompileDictWithCmd(
      */
 
     tokenPtr = dictVarTokenPtr;
-    CompileWord(envPtr, tokenPtr, interp, 0);
-    if (varNameTmp <= 255) {
-	TclEmitInstInt1(	INST_STORE_SCALAR1, varNameTmp,	envPtr);
-    } else {
-	TclEmitInstInt4(	INST_STORE_SCALAR4, varNameTmp,	envPtr);
+    if (varNameTmp > -1) {
+	CompileWord(envPtr, tokenPtr, interp, 0);
+	if (varNameTmp <= 255) {
+	    TclEmitInstInt1(	INST_STORE_SCALAR1, varNameTmp,	envPtr);
+	} else {
+	    TclEmitInstInt4(	INST_STORE_SCALAR4, varNameTmp,	envPtr);
+	}
     }
     tokenPtr = TokenAfter(tokenPtr);
     if (gotPath) {
@@ -1314,7 +1341,13 @@ TclCompileDictWithCmd(
 	}
 	TclEmitOpcode(		INST_POP,			envPtr);
     }
-    TclEmitOpcode(		INST_LOAD_STK,			envPtr);
+    if (dictVar == -1) {
+	TclEmitOpcode(		INST_LOAD_STK,			envPtr);
+    } else if (dictVar <= 255) {
+	TclEmitInstInt1(	INST_LOAD_SCALAR1, dictVar,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_LOAD_SCALAR4, dictVar,	envPtr);
+    }
     if (gotPath) {
 	if (pathTmp <= 255) {
 	    TclEmitInstInt1(	INST_LOAD_SCALAR1, pathTmp,	envPtr);
@@ -1351,9 +1384,9 @@ TclCompileDictWithCmd(
      */
 
     TclEmitOpcode(		INST_END_CATCH,			envPtr);
-    if (varNameTmp <= 255) {
+    if (varNameTmp > -1 && varNameTmp <= 255) {
 	TclEmitInstInt1(	INST_LOAD_SCALAR1, varNameTmp,	envPtr);
-    } else {
+    } else if (varNameTmp > -1) {
 	TclEmitInstInt4(	INST_LOAD_SCALAR4, varNameTmp,	envPtr);
     }
     if (gotPath) {
@@ -1370,7 +1403,11 @@ TclCompileDictWithCmd(
     } else {
 	TclEmitInstInt4(	INST_LOAD_SCALAR4, keysTmp,	envPtr);
     }
-    TclEmitOpcode(		INST_DICT_RECOMBINE,		envPtr);
+    if (dictVar == -1) {
+	TclEmitOpcode(		INST_DICT_RECOMBINE_STK,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+    }
     TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
 
     /*
@@ -1381,9 +1418,9 @@ TclCompileDictWithCmd(
     TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
     TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
     TclEmitOpcode(		INST_END_CATCH,			envPtr);
-    if (varNameTmp <= 255) {
+    if (varNameTmp > -1 && varNameTmp <= 255) {
 	TclEmitInstInt1(	INST_LOAD_SCALAR1, varNameTmp,	envPtr);
-    } else {
+    } else if (varNameTmp > -1) {
 	TclEmitInstInt4(	INST_LOAD_SCALAR4, varNameTmp,	envPtr);
     }
     if (parsePtr->numWords > 3) {
@@ -1400,7 +1437,11 @@ TclCompileDictWithCmd(
     } else {
 	TclEmitInstInt4(	INST_LOAD_SCALAR4, keysTmp,	envPtr);
     }
-    TclEmitOpcode(		INST_DICT_RECOMBINE,		envPtr);
+    if (dictVar == -1) {
+	TclEmitOpcode(		INST_DICT_RECOMBINE_STK,	envPtr);
+    } else {
+	TclEmitInstInt4(	INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+    }
     TclEmitOpcode(		INST_RETURN_STK,		envPtr);
 
     /*
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 4b5d2bb..97e2a8a 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -426,10 +426,14 @@ InstructionDesc const tclInstructionTable[] = {
          * variables with matched names. Produces list of keys bound as
          * result. Part of [dict with].
 	 * Stack:  ... dict path => ... keyList */
-    {"dictRecombine",    1,    -3,        0,    {OPERAND_NONE}},
+    {"dictRecombineStk", 1,    -3,        0,    {OPERAND_NONE}},
         /* Map variable contents back into a dictionary in a variable. Part of
          * [dict with].
 	 * Stack:  ... dictVarName path keyList => ... */
+    {"dictRecombineImm", 1,    -2,        1,    {OPERAND_LVT4}},
+        /* Map variable contents back into a dictionary in the local variable
+         * indicated by the LVT index. Part of [dict with].
+	 * Stack:  ... path keyList => ... */
 
     {NULL, 0, 0, 0, {OPERAND_NONE}}
 };
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 0cd667c..8e7f0d0 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -677,10 +677,11 @@ typedef struct ByteCode {
 #define INST_UNSET_STK			137
 
 #define INST_DICT_EXPAND		138
-#define INST_DICT_RECOMBINE		139
+#define INST_DICT_RECOMBINE_STK		139
+#define INST_DICT_RECOMBINE_IMM		140
 
 /* The last opcode */
-#define LAST_INST_OPCODE		139
+#define LAST_INST_OPCODE		140
 
 /*
  * Table describing the Tcl bytecode instructions: their name (for displaying
diff --git a/generic/tclDictObj.c b/generic/tclDictObj.c
index 5b7ca9b..d50c0a2 100644
--- a/generic/tclDictObj.c
+++ b/generic/tclDictObj.c
@@ -3161,6 +3161,7 @@ FinalizeDictWith(
     Tcl_Obj *varName = data[0];
     Tcl_Obj *keysPtr = data[1];
     Tcl_Obj *pathPtr = data[2];
+    Var *varPtr, *arrayPtr;
 
     if (result == TCL_ERROR) {
 	Tcl_AddErrorInfo(interp, "\n    (body of \"dict with\")");
@@ -3183,7 +3184,14 @@ FinalizeDictWith(
      * Pack from local variables back into the dictionary.
      */
 
-    result = TclDictWithFinish(interp, varName, pathc, pathv, keysPtr);
+    varPtr = TclObjLookupVarEx(interp, varName, NULL, TCL_LEAVE_ERR_MSG, "set",
+	    /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
+    if (varPtr == NULL) {
+	result = TCL_ERROR;
+    } else {
+	result = TclDictWithFinish(interp, varPtr, arrayPtr, varName, NULL, -1,
+		pathc, pathv, keysPtr);
+    }
 
     /*
      * Tidy up and return the real result (unless we had an error).
@@ -3289,11 +3297,27 @@ TclDictWithInit(
 
 int
 TclDictWithFinish(
-    Tcl_Interp *interp,
-    Tcl_Obj *varName,
-    int pathc,
-    Tcl_Obj *const pathv[],
-    Tcl_Obj *keysPtr)
+    Tcl_Interp *interp,		/* Command interpreter in which variable
+				 * exists. Used for state management, traces
+				 * and error reporting. */
+    Var *varPtr,		/* Reference to the variable holding the
+				 * dictionary. */
+    Var *arrayPtr,		/* Reference to the array containing the
+				 * variable, or NULL if the variable is a
+				 * scalar. */
+    Tcl_Obj *part1Ptr,		/* Name of an array (if part2 is non-NULL) or
+				 * the name of a variable. NULL if the 'index'
+				 * parameter is >= 0 */
+    Tcl_Obj *part2Ptr,		/* If non-NULL, gives the name of an element
+				 * in the array part1. */
+    int index,			/* Index into the local variable table of the
+				 * variable, or -1. Only used when part1Ptr is
+				 * NULL. */
+    int pathc,			/* The number of elements in the path into the
+				 * dictionary. */
+    Tcl_Obj *const pathv[],	/* The elements of the path to the subdict. */
+    Tcl_Obj *keysPtr)		/* List of keys to be synchronized. This is
+				 * the result value from TclDictWithInit. */
 {
     Tcl_Obj *dictPtr, *leafPtr, *valPtr;
     int i, allocdict, keyc;
@@ -3303,7 +3327,8 @@ TclDictWithFinish(
      * If the dictionary variable doesn't exist, drop everything silently.
      */
 
-    dictPtr = Tcl_ObjGetVar2(interp, varName, NULL, 0);
+    dictPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr,
+	    TCL_LEAVE_ERR_MSG, index);
     if (dictPtr == NULL) {
 	return TCL_OK;
     }
@@ -3385,8 +3410,8 @@ TclDictWithFinish(
      * Write back the outermost dictionary to the variable.
      */
 
-    if (Tcl_ObjSetVar2(interp, varName, NULL, dictPtr,
-	    TCL_LEAVE_ERR_MSG) == NULL) {
+    if (TclPtrSetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, dictPtr,
+	    TCL_LEAVE_ERR_MSG, index) == NULL) {
 	if (allocdict) {
 	    TclDecrRefCount(dictPtr);
 	}
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index e3db83e..953c63e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -6122,26 +6122,60 @@ TEBCresume(
 	TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
 	NEXT_INST_F(1, 2, 1);
 
-    case INST_DICT_RECOMBINE:
-	varNamePtr = OBJ_AT_DEPTH(2);
-	listPtr = OBJ_UNDER_TOS;
-	keysPtr = OBJ_AT_TOS;
+    case INST_DICT_RECOMBINE_STK:
+	keysPtr = POP_OBJECT();
+	varNamePtr = OBJ_UNDER_TOS;
+	listPtr = OBJ_AT_TOS;
+	TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
+		O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
 	if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
-	    TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ",
-		    O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)),
-		    Tcl_GetObjResult(interp));
+	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+	    TclDecrRefCount(keysPtr);
 	    goto gotError;
 	}
-	if (TclDictWithFinish(interp, varNamePtr, objc, objv,
-		keysPtr) != TCL_OK) {
-	    TRACE_WITH_OBJ(("%.30s %.30s %.30s => ERROR: ",
-		    O2S(varNamePtr), O2S(listPtr), O2S(keysPtr)),
-		    Tcl_GetObjResult(interp));
+	varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL,
+		TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
+	if (varPtr == NULL) {
+	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+	    TclDecrRefCount(keysPtr);
 	    goto gotError;
 	}
+	DECACHE_STACK_INFO();
+	result = TclDictWithFinish(interp, varPtr,arrayPtr,varNamePtr,NULL,-1,
+		objc, objv, keysPtr);
+	CACHE_STACK_INFO();
 	TclDecrRefCount(keysPtr);
-	POP_OBJECT();
+	if (result != TCL_OK) {
+	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+	    goto gotError;
+	}
+	TRACE_APPEND(("OK\n"));
 	NEXT_INST_F(1, 2, 0);
+
+    case INST_DICT_RECOMBINE_IMM:
+	opnd = TclGetUInt4AtPtr(pc+1);
+	listPtr = OBJ_UNDER_TOS;
+	keysPtr = OBJ_AT_TOS;
+	varPtr = LOCAL(opnd);
+	TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
+		O2S(keysPtr)));
+	if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
+	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+	    goto gotError;
+	}
+	while (TclIsVarLink(varPtr)) {
+	    varPtr = varPtr->value.linkPtr;
+	}
+	DECACHE_STACK_INFO();
+	result = TclDictWithFinish(interp, varPtr, NULL, NULL, NULL, opnd,
+		objc, objv, keysPtr);
+	CACHE_STACK_INFO();
+	if (result != TCL_OK) {
+	    TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+	    goto gotError;
+	}
+	TRACE_APPEND(("OK\n"));
+	NEXT_INST_F(5, 2, 0);
     }
 
     /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index e7a84ce..b375bb9 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3231,8 +3231,9 @@ MODULE_SCOPE int	TclDefaultBgErrorHandlerObjCmd(
 			    ClientData clientData, Tcl_Interp *interp,
 			    int objc, Tcl_Obj *const objv[]);
 MODULE_SCOPE Tcl_Command TclInitDictCmd(Tcl_Interp *interp);
-MODULE_SCOPE int	TclDictWithFinish(Tcl_Interp *interp,
-			    Tcl_Obj *varName, int pathc,
+MODULE_SCOPE int	TclDictWithFinish(Tcl_Interp *interp, Var *varPtr,
+			    Var *arrayPtr, Tcl_Obj *part1Ptr,
+			    Tcl_Obj *part2Ptr, int index, int pathc,
 			    Tcl_Obj *const pathv[], Tcl_Obj *keysPtr);
 MODULE_SCOPE Tcl_Obj *	TclDictWithInit(Tcl_Interp *interp, Tcl_Obj *dictPtr,
 			    int pathc, Tcl_Obj *const pathv[]);
-- 
cgit v0.12


From 7ca256492ade693ddedf767ac5f7711b24ed8be0 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 5 Oct 2011 13:58:56 +0000
Subject: Remove tclWinProcs, as it is no longer being used

---
 ChangeLog         |  6 ++++
 win/tclWin32Dll.c | 80 ---------------------------------------------------
 win/tclWinInt.h   | 86 -------------------------------------------------------
 3 files changed, 6 insertions(+), 166 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 05cfe7a..4e6c57c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,10 @@
+2011-10-05  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclWinInt.h:   Remove tclWinProcs, as it is no longer
+	* generic/tclWin32Dll.c: being used.
+
 2011-10-03  Venkat Iyer <venkat@comit.com>
+
 	* library/tzdata/Africa/Dar_es_Salaam: Update to Olson's tzdata2011k
 	* library/tzdata/Africa/Kampala
 	* library/tzdata/Africa/Nairobi
diff --git a/win/tclWin32Dll.c b/win/tclWin32Dll.c
index 7972862..019d76f 100644
--- a/win/tclWin32Dll.c
+++ b/win/tclWin32Dll.c
@@ -17,20 +17,6 @@
 #endif
 
 /*
- * The following data structures are used when loading the thunking library
- * for execing child processes under Win32s.
- */
-
-typedef DWORD (WINAPI UT32PROC)(LPVOID lpBuff, DWORD dwUserDefined,
-	LPVOID *lpTranslationList);
-
-typedef BOOL (WINAPI UTREGISTER)(HANDLE hModule, LPCSTR SixteenBitDLL,
-	LPCSTR InitName, LPCSTR ProcName, UT32PROC **ThirtyTwoBitThunk,
-	FARPROC UT32Callback, LPVOID Buff);
-
-typedef void (WINAPI UTUNREGISTER)(HANDLE hModule);
-
-/*
  * The following variables keep track of information about this DLL on a
  * per-instance basis. Each time this DLL is loaded, it gets its own new data
  * segment with its own copy of all static and global information.
@@ -67,72 +53,6 @@ typedef struct EXCEPTION_REGISTRATION {
 static Tcl_Encoding winTCharEncoding = NULL;
 
 /*
- * The following function table is used to dispatch to wide-character
- * versions of the operating system calls.
- */
-
-static const TclWinProcs winProcs = {
-    1,
-    (BOOL (WINAPI *)(const TCHAR *, LPDCB)) BuildCommDCB,
-    (TCHAR *(WINAPI *)(TCHAR *)) CharLower,
-    (BOOL (WINAPI *)(const TCHAR *, const TCHAR *, BOOL)) CopyFile,
-    (BOOL (WINAPI *)(const TCHAR *, LPSECURITY_ATTRIBUTES)) CreateDirectory,
-    (HANDLE (WINAPI *)(const TCHAR *, DWORD, DWORD, SECURITY_ATTRIBUTES *,
-	    DWORD, DWORD, HANDLE)) CreateFile,
-    (BOOL (WINAPI *)(const TCHAR *, TCHAR *, LPSECURITY_ATTRIBUTES,
-	    LPSECURITY_ATTRIBUTES, BOOL, DWORD, LPVOID, const TCHAR *,
-	    LPSTARTUPINFO, LPPROCESS_INFORMATION)) CreateProcess,
-    (BOOL (WINAPI *)(const TCHAR *)) DeleteFile,
-    (HANDLE (WINAPI *)(const TCHAR *, WIN32_FIND_DATAT *)) FindFirstFile,
-    (BOOL (WINAPI *)(HANDLE, WIN32_FIND_DATAT *)) FindNextFile,
-    (BOOL (WINAPI *)(TCHAR *, LPDWORD)) GetComputerName,
-    (DWORD (WINAPI *)(DWORD, TCHAR *)) GetCurrentDirectory,
-    (DWORD (WINAPI *)(const TCHAR *)) GetFileAttributes,
-    (DWORD (WINAPI *)(const TCHAR *, DWORD nBufferLength, TCHAR *,
-	    TCHAR **)) GetFullPathName,
-    (DWORD (WINAPI *)(const TCHAR *, TCHAR *, DWORD)) GetShortPathName,
-    (UINT (WINAPI *)(const TCHAR *, const TCHAR *, UINT uUnique,
-	    TCHAR *)) GetTempFileName,
-    (DWORD (WINAPI *)(DWORD, TCHAR *)) GetTempPath,
-    (BOOL (WINAPI *)(const TCHAR *, TCHAR *, DWORD, LPDWORD, LPDWORD, LPDWORD,
-	    TCHAR *, DWORD)) GetVolumeInformation,
-    (HINSTANCE (WINAPI *)(const TCHAR *, HANDLE, DWORD)) LoadLibraryEx,
-    (BOOL (WINAPI *)(const TCHAR *, const TCHAR *)) MoveFile,
-    (BOOL (WINAPI *)(const TCHAR *)) RemoveDirectory,
-    (DWORD (WINAPI *)(const TCHAR *, const TCHAR *, const TCHAR *, DWORD,
-	    TCHAR *, TCHAR **)) SearchPath,
-    (BOOL (WINAPI *)(const TCHAR *)) SetCurrentDirectory,
-    (BOOL (WINAPI *)(const TCHAR *, DWORD)) SetFileAttributes,
-    (BOOL (WINAPI *)(const TCHAR *, GET_FILEEX_INFO_LEVELS,
-	    LPVOID)) GetFileAttributesEx,
-    (BOOL (WINAPI *)(const TCHAR *, const TCHAR*,
-	    LPSECURITY_ATTRIBUTES)) CreateHardLink,
-    (HANDLE (WINAPI *)(const TCHAR*, UINT, LPVOID, UINT,
-	    LPVOID, DWORD)) FindFirstFileEx,
-    (BOOL (WINAPI *)(const TCHAR*, TCHAR*,
-	    DWORD)) GetVolumeNameForVolumeMountPoint,
-    (DWORD (WINAPI *)(const TCHAR*, TCHAR*,
-	    DWORD)) GetLongPathName,
-    /* Security SDK */
-    (BOOL (WINAPI *)(LPCTSTR, SECURITY_INFORMATION,
-	    PSECURITY_DESCRIPTOR, DWORD, LPDWORD)) GetFileSecurity,
-    (BOOL (WINAPI *) (SECURITY_IMPERSONATION_LEVEL)) ImpersonateSelf,
-    (BOOL (WINAPI *) (HANDLE, DWORD, BOOL, PHANDLE)) OpenThreadToken,
-    (BOOL (WINAPI *) (void)) RevertToSelf,
-    (void (WINAPI *) (PDWORD, PGENERIC_MAPPING)) MapGenericMask,
-    (BOOL (WINAPI *)(PSECURITY_DESCRIPTOR, HANDLE, DWORD,
-	    PGENERIC_MAPPING, PPRIVILEGE_SET, LPDWORD, LPDWORD, LPBOOL)) AccessCheck,
-    /* ReadConsole and WriteConsole */
-    (BOOL (WINAPI *)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID)) ReadConsole,
-    (BOOL (WINAPI *)(HANDLE, const void*, DWORD, LPDWORD, LPVOID)) WriteConsole,
-    (BOOL (WINAPI *)(LPTSTR, LPDWORD)) GetUserName,
-    (const TCHAR *(*)(const char *, int, Tcl_DString *)) Tcl_WinUtfToTChar,
-    (const char *(*)(const TCHAR *, int, Tcl_DString *)) Tcl_WinTCharToUtf
-};
-
-const TclWinProcs *const tclWinProcs = &winProcs;
-
-/*
  * The following declaration is for the VC++ DLL entry point.
  */
 
diff --git a/win/tclWinInt.h b/win/tclWinInt.h
index c75084a..882b811 100644
--- a/win/tclWinInt.h
+++ b/win/tclWinInt.h
@@ -34,92 +34,6 @@
 #endif
 
 /*
- * The following structure keeps track of whether we are using the
- * multi-byte or the wide-character interfaces to the operating system.
- * System calls should be made through the following function table.
- */
-
-typedef union {
-    WIN32_FIND_DATAA a;
-    WIN32_FIND_DATAW w;
-} WIN32_FIND_DATAT;
-
-typedef struct TclWinProcs {
-    int useWide;
-    BOOL (WINAPI *buildCommDCBProc)(const TCHAR *, LPDCB);
-    TCHAR * (WINAPI *charLowerProc)(TCHAR *);
-    BOOL (WINAPI *copyFileProc)(const TCHAR *, const TCHAR *, BOOL);
-    BOOL (WINAPI *createDirectoryProc)(const TCHAR *, LPSECURITY_ATTRIBUTES);
-    HANDLE (WINAPI *createFileProc)(const TCHAR *, DWORD, DWORD,
-	    LPSECURITY_ATTRIBUTES, DWORD, DWORD, HANDLE);
-    BOOL (WINAPI *createProcessProc)(const TCHAR *, TCHAR *,
-	    LPSECURITY_ATTRIBUTES, LPSECURITY_ATTRIBUTES, BOOL, DWORD,
-	    LPVOID, const TCHAR *, LPSTARTUPINFO, LPPROCESS_INFORMATION);
-    BOOL (WINAPI *deleteFileProc)(const TCHAR *);
-    HANDLE (WINAPI *findFirstFileProc)(const TCHAR *, WIN32_FIND_DATAT *);
-    BOOL (WINAPI *findNextFileProc)(HANDLE, WIN32_FIND_DATAT *);
-    BOOL (WINAPI *getComputerNameProc)(TCHAR *, LPDWORD);
-    DWORD (WINAPI *getCurrentDirectoryProc)(DWORD, TCHAR *);
-    DWORD (WINAPI *getFileAttributesProc)(const TCHAR *);
-    DWORD (WINAPI *getFullPathNameProc)(const TCHAR *, DWORD, TCHAR *,
-	    TCHAR **);
-    DWORD (WINAPI *getShortPathNameProc)(const TCHAR *, TCHAR *, DWORD);
-    UINT (WINAPI *getTempFileNameProc)(const TCHAR *, const TCHAR *, UINT,
-	    TCHAR *);
-    DWORD (WINAPI *getTempPathProc)(DWORD, TCHAR *);
-    BOOL (WINAPI *getVolumeInformationProc)(const TCHAR *, TCHAR *, DWORD,
-	    LPDWORD, LPDWORD, LPDWORD, TCHAR *, DWORD);
-    HINSTANCE (WINAPI *loadLibraryExProc)(const TCHAR *, HANDLE, DWORD);
-    BOOL (WINAPI *moveFileProc)(const TCHAR *, const TCHAR *);
-    BOOL (WINAPI *removeDirectoryProc)(const TCHAR *);
-    DWORD (WINAPI *searchPathProc)(const TCHAR *, const TCHAR *,
-	    const TCHAR *, DWORD, TCHAR *, TCHAR **);
-    BOOL (WINAPI *setCurrentDirectoryProc)(const TCHAR *);
-    BOOL (WINAPI *setFileAttributesProc)(const TCHAR *, DWORD);
-    /*
-     * These two function pointers will only be set when
-     * Tcl_FindExecutable is called.  If you don't ever call that
-     * function, the application will crash whenever WinTcl tries to call
-     * functions through these null pointers.  That is not a bug in Tcl
-     * -- Tcl_FindExecutable is obligatory in recent Tcl releases.
-     */
-    BOOL (WINAPI *getFileAttributesExProc)(const TCHAR *,
-	    GET_FILEEX_INFO_LEVELS, LPVOID);
-    BOOL (WINAPI *createHardLinkProc)(const TCHAR *, const TCHAR *,
-	    LPSECURITY_ATTRIBUTES);
-
-    /* These two are also NULL at start; see comment above */
-    HANDLE (WINAPI *findFirstFileExProc)(const TCHAR *, UINT,
-	    LPVOID, UINT, LPVOID, DWORD);
-    BOOL (WINAPI *getVolumeNameForVMPProc)(const TCHAR *, TCHAR *, DWORD);
-    DWORD (WINAPI *getLongPathNameProc)(const TCHAR *, TCHAR *, DWORD);
-    /*
-     * These six are for the security sdk to get correct file
-     * permissions on NT, 2000, XP, etc.  On 95,98,ME they are
-     * always null.
-     */
-    BOOL (WINAPI *getFileSecurityProc)(LPCTSTR, SECURITY_INFORMATION,
-	    PSECURITY_DESCRIPTOR, DWORD, LPDWORD);
-    BOOL (WINAPI *impersonateSelfProc) (SECURITY_IMPERSONATION_LEVEL);
-    BOOL (WINAPI *openThreadTokenProc) (HANDLE, DWORD, BOOL, PHANDLE);
-    BOOL (WINAPI *revertToSelfProc) (void);
-    void (WINAPI *mapGenericMaskProc) (PDWORD, PGENERIC_MAPPING);
-    BOOL (WINAPI *accessCheckProc)(PSECURITY_DESCRIPTOR, HANDLE, DWORD,
-		    PGENERIC_MAPPING, PPRIVILEGE_SET, LPDWORD, LPDWORD, LPBOOL);
-    /*
-     * Unicode console support. WriteConsole and ReadConsole
-     */
-    BOOL (WINAPI *readConsoleProc)(HANDLE, LPVOID, DWORD, LPDWORD, LPVOID);
-    BOOL (WINAPI *writeConsoleProc)(HANDLE, const void *, DWORD, LPDWORD,
-	    LPVOID);
-    BOOL (WINAPI *getUserName)(LPTSTR, LPDWORD);
-    const TCHAR *(*utf2tchar)(const char *, int, Tcl_DString *);
-    const char *(*tchar2utf)(const TCHAR *, int, Tcl_DString *);
-} TclWinProcs;
-
-MODULE_SCOPE const TclWinProcs *const tclWinProcs;
-
-/*
  * Declarations of functions that are not accessible by way of the
  * stubs table.
  */
-- 
cgit v0.12


From 1b98fe6855837a8d7d1b446067a4e5a1400ab4ad Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 5 Oct 2011 14:05:28 +0000
Subject: wrong copy/paste in ChangeLog

---
 ChangeLog | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 4e6c57c..7b79f88 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,7 @@
 2011-10-05  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclWinInt.h:   Remove tclWinProcs, as it is no longer
-	* generic/tclWin32Dll.c: being used.
+	* win/tclWinInt.h:   Remove tclWinProcs, as it is no longer
+	* win/tclWin32Dll.c: being used.
 
 2011-10-03  Venkat Iyer <venkat@comit.com>
 
-- 
cgit v0.12


From 58307e4ecd7de78e0ef00884da41cfec0a2a4f2f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 5 Oct 2011 14:19:47 +0000
Subject: Added some tests.

---
 tests/dict.test | 66 +++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 66 insertions(+)

diff --git a/tests/dict.test b/tests/dict.test
index d80a11f..41c21e2 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -1358,6 +1358,72 @@ test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} -body
 } -cleanup {
     unset foo t inner
 } -result OK
+test dict-22.12 {dict with: compiled} {
+    apply {{} {
+	set d {a 1 b 2}
+	list [dict with d {
+	    set a $b
+	    unset b
+	    dict set d c 3
+	    list ok
+	}] $d
+    }}
+} {ok {a 2 c 3}}
+test dict-22.13 {dict with: compiled} {
+    apply {i {
+	set d($i) {a 1 b 2}
+	list [dict with d($i) {
+	    set a $b
+	    unset b
+	    dict set d($i) c 3
+	    list ok
+	}] [array get d]
+    }} e
+} {ok {e {a 2 c 3}}}
+test dict-22.14 {dict with: compiled} {
+    apply {{} {
+	set d {a 1 b 2}
+	foreach x {1 2 3} {
+	    dict with d {
+		incr a $b
+		if {$x == 2} break
+	    }
+	    unset a b
+	}
+	list $a $b $x $d
+    }}
+} {5 2 2 {a 5 b 2}}
+test dict-22.15 {dict with: compiled} {
+    apply {i {
+	set d($i) {a 1 b 2}
+	foreach x {1 2 3} {
+	    dict with d($i) {
+		incr a $b
+		if {$x == 2} break
+	    }
+	    unset a b
+	}
+	list $a $b $x [array get d]
+    }} e
+} {5 2 2 {e {a 5 b 2}}}
+test dict-22.16 {dict with: compiled} {
+    apply {{} {
+	set d {p {q {a 1 b 2}}}
+	dict with d p q {
+	    set a $b.$a
+	}
+	return $d
+    }}
+} {p {q {a 2.1 b 2}}}
+test dict-22.17 {dict with: compiled} {
+    apply {i {
+	set d($i) {p {q {a 1 b 2}}}
+	dict with d($i) p q {
+	    set a $b.$a
+	}
+	array get d
+    }} e
+} {e {p {q {a 2.1 b 2}}}}
 
 # cleanup
 ::tcltest::cleanupTests
-- 
cgit v0.12


From 00dba5b765820b786738f3f44963f26a250accda Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 6 Oct 2011 19:15:25 +0000
Subject: Add the other instructions to the assembler's nous.

---
 generic/tclAssembly.c | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c
index 2133ebe..5b32ab0 100644
--- a/generic/tclAssembly.c
+++ b/generic/tclAssembly.c
@@ -375,6 +375,8 @@ TalInstDesc TalInstructionTable[] = {
     {"dictIncrImm",	ASSEM_SINT4_LVT4,
 					INST_DICT_INCR_IMM,	1,	1},
     {"dictLappend",	ASSEM_LVT4,	INST_DICT_LAPPEND,	2,	1},
+    {"dictRecombineStk",ASSEM_1BYTE,	INST_DICT_RECOMBINE_STK,3,	0},
+    {"dictRecombineImm",ASSEM_LVT4,	INST_DICT_RECOMBINE_IMM,2,	0},
     {"dictSet",		ASSEM_DICT_SET, INST_DICT_SET,		INT_MIN,1},
     {"dictUnset",	ASSEM_DICT_UNSET,
 					INST_DICT_UNSET,	INT_MIN,1},
-- 
cgit v0.12


From 2befc6793de3b9eba7c26d5def4cdfc023a8824b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 9 Oct 2011 14:41:06 +0000
Subject: 	* generic/tclCompCmds.c (TclCompileDictWithCmd): Corrected
 handling of 	qualified names, and added spacial cases for empty bodies
 (used when 	[dict with] is just used for extracting variables).

---
 ChangeLog             |   6 +
 generic/tclCompCmds.c | 615 +++++++++++++++++++++++++-------------------------
 generic/tclCompile.h  |   1 +
 tests/dict.test       |  48 ++++
 4 files changed, 367 insertions(+), 303 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 74aa3a4..d0c4986 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-10-09  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCompCmds.c (TclCompileDictWithCmd): Corrected handling of
+	qualified names, and added spacial cases for empty bodies (used when
+	[dict with] is just used for extracting variables).
+
 2011-10-07  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tcl.h:        Fix gcc warnings (discovered with
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 0b6b76b..69b44ed 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -83,6 +83,18 @@ static int		PushVarName(Tcl_Interp *interp,
 	    mapPtr->loc[eclIndex].next[(word)])
 
 /*
+ * Often want to issue one of two versions of an instruction based on whether
+ * the argument will fit in a single byte or not. This makes it much clearer.
+ */
+
+#define Emit14Inst(nm,idx,envPtr) \
+    if (idx <= 255) {							\
+	TclEmitInstInt1(nm##1,idx,envPtr);				\
+    } else {								\
+	TclEmitInstInt4(nm##4,idx,envPtr);				\
+    }
+
+/*
  * Flags bits used by PushVarName.
  */
 
@@ -186,18 +198,14 @@ TclCompileAppendCmd(
 	if (isScalar) {
 	    if (localIndex < 0) {
 		TclEmitOpcode(INST_APPEND_STK, envPtr);
-	    } else if (localIndex <= 255) {
-		TclEmitInstInt1(INST_APPEND_SCALAR1, localIndex, envPtr);
 	    } else {
-		TclEmitInstInt4(INST_APPEND_SCALAR4, localIndex, envPtr);
+		Emit14Inst(INST_APPEND_SCALAR, localIndex, envPtr);
 	    }
 	} else {
 	    if (localIndex < 0) {
 		TclEmitOpcode(INST_APPEND_ARRAY_STK, envPtr);
-	    } else if (localIndex <= 255) {
-		TclEmitInstInt1(INST_APPEND_ARRAY1, localIndex, envPtr);
 	    } else {
-		TclEmitInstInt4(INST_APPEND_ARRAY4, localIndex, envPtr);
+		Emit14Inst(INST_APPEND_ARRAY, localIndex, envPtr);
 	    }
 	}
     } else {
@@ -366,16 +374,16 @@ TclCompileCatchCmd(
     SetLineInformation(1);
     if (cmdTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
 	savedStackDepth = envPtr->currStackDepth;
-	TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
 	ExceptionRangeStarts(envPtr, range);
 	CompileBody(envPtr, cmdTokenPtr, interp);
     } else {
 	CompileTokens(envPtr, cmdTokenPtr, interp);
 	savedStackDepth = envPtr->currStackDepth;
-	TclEmitInstInt4(INST_BEGIN_CATCH4, range, envPtr);
+	TclEmitInstInt4(	INST_BEGIN_CATCH4, range,	envPtr);
 	ExceptionRangeStarts(envPtr, range);
-	TclEmitOpcode(INST_DUP, envPtr);
-	TclEmitOpcode(INST_EVAL_STK, envPtr);
+	TclEmitOpcode(		INST_DUP,			envPtr);
+	TclEmitOpcode(		INST_EVAL_STK,			envPtr);
     }
     /* Stack at this point:
      *    nonsimple:  script <mark> result
@@ -399,8 +407,8 @@ TclCompileCatchCmd(
     envPtr->currStackDepth = savedStackDepth;
     ExceptionRangeTarget(envPtr, range, catchOffset);
     /* Stack at this point:  ?script? */
-    TclEmitOpcode(INST_PUSH_RESULT, envPtr);
-    TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
+    TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
+    TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);
 
     /*
      * Update the target of the jump after the "no errors" code. 
@@ -415,7 +423,7 @@ TclCompileCatchCmd(
     /* Push the return options if the caller wants them */
 
     if (optsIndex != -1) {
-	TclEmitOpcode(INST_PUSH_RETURN_OPTIONS, envPtr);
+	TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
     }
 
     /*
@@ -423,7 +431,7 @@ TclCompileCatchCmd(
      */
 
     ExceptionRangeEnds(envPtr, range);
-    TclEmitOpcode(INST_END_CATCH, envPtr);
+    TclEmitOpcode(		INST_END_CATCH,			envPtr);
 
     /*
      * At this point, the top of the stack is inconveniently ordered:
@@ -432,9 +440,9 @@ TclCompileCatchCmd(
      */
 
     if (optsIndex != -1) {
-	TclEmitInstInt4(INST_REVERSE, 3, envPtr);
+	TclEmitInstInt4(	INST_REVERSE, 3,		envPtr);
     } else {
-	TclEmitInstInt4(INST_REVERSE, 2, envPtr);
+	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
     }
 
     /*
@@ -442,13 +450,9 @@ TclCompileCatchCmd(
      */
 
     if (resultIndex != -1) {
-	if (resultIndex <= 255) {
-	    TclEmitInstInt1(INST_STORE_SCALAR1, resultIndex, envPtr);
-	} else {
-	    TclEmitInstInt4(INST_STORE_SCALAR4, resultIndex, envPtr);
-	}
+	Emit14Inst(		INST_STORE_SCALAR, resultIndex,	envPtr);
     }
-    TclEmitOpcode(INST_POP, envPtr);
+    TclEmitOpcode(		INST_POP,			envPtr);
 
     /*
      * Stack is now ?script? ?returnOptions? returnCode.
@@ -458,13 +462,9 @@ TclCompileCatchCmd(
      */
 
     if (optsIndex != -1) {
-	TclEmitInstInt4(INST_REVERSE, 2, envPtr);
-	if (optsIndex <= 255) {
-	    TclEmitInstInt1(INST_STORE_SCALAR1, optsIndex, envPtr);
-	} else {
-	    TclEmitInstInt4(INST_STORE_SCALAR4, optsIndex, envPtr);
-	}
-	TclEmitOpcode(INST_POP, envPtr);
+	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
+	Emit14Inst(		INST_STORE_SCALAR, optsIndex,	envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
     }
 
     /* 
@@ -473,8 +473,8 @@ TclCompileCatchCmd(
      */
 
     if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
-	TclEmitInstInt4(INST_REVERSE, 2, envPtr);
-	TclEmitOpcode(INST_POP, envPtr);
+	TclEmitInstInt4(	INST_REVERSE, 2,		envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
     }
 
     /* 
@@ -844,9 +844,9 @@ TclCompileDictForCmd(
      */
 
     CompileWord(envPtr, dictTokenPtr, interp, 3);
-    TclEmitInstInt4( INST_DICT_FIRST, infoIndex,		envPtr);
+    TclEmitInstInt4(	INST_DICT_FIRST, infoIndex,		envPtr);
     emptyTargetOffset = CurrentOffset(envPtr);
-    TclEmitInstInt4( INST_JUMP_TRUE4, 0,			envPtr);
+    TclEmitInstInt4(	INST_JUMP_TRUE4, 0,			envPtr);
 
     /*
      * Now we catch errors from here on so that we can finalize the search
@@ -854,7 +854,7 @@ TclCompileDictForCmd(
      */
 
     catchRange = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
-    TclEmitInstInt4( INST_BEGIN_CATCH4, catchRange,		envPtr);
+    TclEmitInstInt4(	INST_BEGIN_CATCH4, catchRange,		envPtr);
     ExceptionRangeStarts(envPtr, catchRange);
 
     /*
@@ -862,10 +862,10 @@ TclCompileDictForCmd(
      */
 
     bodyTargetOffset = CurrentOffset(envPtr);
-    TclEmitInstInt4( INST_STORE_SCALAR4, keyVarIndex,		envPtr);
-    TclEmitOpcode(   INST_POP,					envPtr);
-    TclEmitInstInt4( INST_STORE_SCALAR4, valueVarIndex,		envPtr);
-    TclEmitOpcode(   INST_POP,					envPtr);
+    Emit14Inst(		INST_STORE_SCALAR, keyVarIndex,		envPtr);
+    TclEmitOpcode(	INST_POP,				envPtr);
+    Emit14Inst(		INST_STORE_SCALAR, valueVarIndex,	envPtr);
+    TclEmitOpcode(	INST_POP,				envPtr);
 
     /*
      * Set up the loop exception targets.
@@ -880,7 +880,7 @@ TclCompileDictForCmd(
 
     SetLineInformation(4);
     CompileBody(envPtr, bodyTokenPtr, interp);
-    TclEmitOpcode(   INST_POP,					envPtr);
+    TclEmitOpcode(	INST_POP,				envPtr);
 
     /*
      * Both exception target ranges (error and loop) end here.
@@ -896,11 +896,11 @@ TclCompileDictForCmd(
      */
 
     ExceptionRangeTarget(envPtr, loopRange, continueOffset);
-    TclEmitInstInt4( INST_DICT_NEXT, infoIndex,			envPtr);
+    TclEmitInstInt4(	INST_DICT_NEXT, infoIndex,		envPtr);
     jumpDisplacement = bodyTargetOffset - CurrentOffset(envPtr);
-    TclEmitInstInt4( INST_JUMP_FALSE4, jumpDisplacement,	envPtr);
-    TclEmitOpcode(   INST_POP,					envPtr);
-    TclEmitOpcode(   INST_POP,					envPtr);
+    TclEmitInstInt4(	INST_JUMP_FALSE4, jumpDisplacement,	envPtr);
+    TclEmitOpcode(	INST_POP,				envPtr);
+    TclEmitOpcode(	INST_POP,				envPtr);
 
     /*
      * Now do the final cleanup for the no-error case (this is where we break
@@ -911,11 +911,11 @@ TclCompileDictForCmd(
      */
 
     ExceptionRangeTarget(envPtr, loopRange, breakOffset);
-    TclEmitInstInt1( INST_UNSET_SCALAR, 0,			envPtr);
-    TclEmitInt4(     infoIndex,					envPtr);
-    TclEmitOpcode(   INST_END_CATCH,				envPtr);
+    TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
+    TclEmitInt4(	infoIndex,				envPtr);
+    TclEmitOpcode(	INST_END_CATCH,				envPtr);
     endTargetOffset = CurrentOffset(envPtr);
-    TclEmitInstInt4( INST_JUMP4, 0,				envPtr);
+    TclEmitInstInt4(	INST_JUMP4, 0,				envPtr);
 
     /*
      * Error handler "finally" clause, which force-terminates the iteration
@@ -923,12 +923,12 @@ TclCompileDictForCmd(
      */
 
     ExceptionRangeTarget(envPtr, catchRange, catchOffset);
-    TclEmitOpcode(   INST_PUSH_RETURN_OPTIONS,			envPtr);
-    TclEmitOpcode(   INST_PUSH_RESULT,				envPtr);
-    TclEmitInstInt1( INST_UNSET_SCALAR, 0,			envPtr);
-    TclEmitInt4(     infoIndex,					envPtr);
-    TclEmitOpcode(   INST_END_CATCH,				envPtr);
-    TclEmitOpcode(   INST_RETURN_STK,				envPtr);
+    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
+    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
+    TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
+    TclEmitInt4(	infoIndex,				envPtr);
+    TclEmitOpcode(	INST_END_CATCH,				envPtr);
+    TclEmitOpcode(	INST_RETURN_STK,			envPtr);
 
     /*
      * Otherwise we're done (the jump after the DICT_FIRST points here) and we
@@ -940,10 +940,10 @@ TclCompileDictForCmd(
     jumpDisplacement = CurrentOffset(envPtr) - emptyTargetOffset;
     TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDisplacement,
 	    envPtr->codeStart + emptyTargetOffset);
-    TclEmitOpcode(   INST_POP,					envPtr);
-    TclEmitOpcode(   INST_POP,					envPtr);
-    TclEmitInstInt1( INST_UNSET_SCALAR, 0,			envPtr);
-    TclEmitInt4(     infoIndex,					envPtr);
+    TclEmitOpcode(	INST_POP,				envPtr);
+    TclEmitOpcode(	INST_POP,				envPtr);
+    TclEmitInstInt1(	INST_UNSET_SCALAR, 0,			envPtr);
+    TclEmitInt4(	infoIndex,				envPtr);
 
     /*
      * Final stage of the command (normal case) is that we push an empty
@@ -1075,12 +1075,12 @@ TclCompileDictUpdateCmd(
     for (i=0 ; i<numVars ; i++) {
 	CompileWord(envPtr, keyTokenPtrs[i], interp, i);
     }
-    TclEmitInstInt4( INST_LIST, numVars,			envPtr);
-    TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex,		envPtr);
-    TclEmitInt4(     infoIndex,					envPtr);
+    TclEmitInstInt4(	INST_LIST, numVars,			envPtr);
+    TclEmitInstInt4(	INST_DICT_UPDATE_START, dictIndex,	envPtr);
+    TclEmitInt4(	infoIndex,				envPtr);
 
     range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
-    TclEmitInstInt4( INST_BEGIN_CATCH4, range,			envPtr);
+    TclEmitInstInt4(	INST_BEGIN_CATCH4, range,		envPtr);
 
     ExceptionRangeStarts(envPtr, range);
     envPtr->currStackDepth++;
@@ -1093,10 +1093,10 @@ TclCompileDictUpdateCmd(
      * the body evaluation: swap them and finish the update code.
      */
 
-    TclEmitOpcode(   INST_END_CATCH,				envPtr);
-    TclEmitInstInt4( INST_REVERSE, 2,				envPtr);
-    TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex,		envPtr);
-    TclEmitInt4(     infoIndex,					envPtr);
+    TclEmitOpcode(	INST_END_CATCH,				envPtr);
+    TclEmitInstInt4(	INST_REVERSE, 2,			envPtr);
+    TclEmitInstInt4(	INST_DICT_UPDATE_END, dictIndex,	envPtr);
+    TclEmitInt4(	infoIndex,				envPtr);
 
     /*
      * Jump around the exceptional termination code.
@@ -1111,14 +1111,14 @@ TclCompileDictUpdateCmd(
      */
 
     ExceptionRangeTarget(envPtr, range, catchOffset);
-    TclEmitOpcode(   INST_PUSH_RESULT,				envPtr);
-    TclEmitOpcode(   INST_PUSH_RETURN_OPTIONS,			envPtr);
-    TclEmitOpcode(   INST_END_CATCH,				envPtr);
-    TclEmitInstInt4( INST_REVERSE, 3,				envPtr);
+    TclEmitOpcode(	INST_PUSH_RESULT,			envPtr);
+    TclEmitOpcode(	INST_PUSH_RETURN_OPTIONS,		envPtr);
+    TclEmitOpcode(	INST_END_CATCH,				envPtr);
+    TclEmitInstInt4(	INST_REVERSE, 3,			envPtr);
 
-    TclEmitInstInt4( INST_DICT_UPDATE_END, dictIndex,		envPtr);
-    TclEmitInt4(     infoIndex,					envPtr);
-    TclEmitOpcode(   INST_RETURN_STK,				envPtr);
+    TclEmitInstInt4(	INST_DICT_UPDATE_END, dictIndex,	envPtr);
+    TclEmitInt4(	infoIndex,				envPtr);
+    TclEmitOpcode(	INST_RETURN_STK,			envPtr);
 
     if (TclFixupForwardJumpToHere(envPtr, &jumpFixup, 127)) {
 	Tcl_Panic("TclCompileDictCmd(update): bad jump distance %d",
@@ -1231,7 +1231,7 @@ TclCompileDictLappendCmd(
     }
     CompileWord(envPtr, keyTokenPtr, interp, 3);
     CompileWord(envPtr, valueTokenPtr, interp, 4);
-    TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr);
+    TclEmitInstInt4(	INST_DICT_LAPPEND, dictVarIndex,	envPtr);
     return TCL_OK;
 }
 
@@ -1246,18 +1246,16 @@ TclCompileDictWithCmd(
 {
     DefineLineInformation;	/* TIP #280 */
     int i, range, varNameTmp, pathTmp, keysTmp, gotPath, dictVar = -1;
-    Tcl_Token *dictVarTokenPtr, *tokenPtr;
+    int bodyIsEmpty = 1;
+    Tcl_Token *varTokenPtr, *tokenPtr;
     int savedStackDepth = envPtr->currStackDepth;
     JumpFixup jumpFixup;
+    const char *ptr, *end;
 
     /*
-     * There must be at least one argument after the command and we must be in
-     * a procedure so we can have local temporaries.
+     * There must be at least one argument after the command.
      */
 
-    if (envPtr->procPtr == NULL) {
-	return TCL_ERROR;
-    }
     if (parsePtr->numWords < 3) {
 	return TCL_ERROR;
     }
@@ -1267,8 +1265,8 @@ TclCompileDictWithCmd(
      *   dict with <any (varName)> ?<any> ...? <literal>
      */
 
-    dictVarTokenPtr = TokenAfter(parsePtr->tokenPtr);
-    tokenPtr = TokenAfter(dictVarTokenPtr);
+    varTokenPtr = TokenAfter(parsePtr->tokenPtr);
+    tokenPtr = TokenAfter(varTokenPtr);
     for (i=3 ; i<parsePtr->numWords ; i++) {
 	tokenPtr = TokenAfter(tokenPtr);
     }
@@ -1277,31 +1275,115 @@ TclCompileDictWithCmd(
     }
 
     /*
-     * Allocate local (unnamed, untraced) working variables.
+     * Test if the last word is an empty script; if so, we can compile it in
+     * all cases, but if it is non-empty we need local variable table entries
+     * to hold the temporary variables (used to keep stack usage simple).
+     */
+
+    for (ptr=tokenPtr[1].start,end=ptr+tokenPtr[1].size ; ptr!=end ; ptr++) {
+	if (*ptr!=' ' && *ptr!='\t' && *ptr!='\n' && *ptr!='\r') {
+	    if (envPtr->procPtr == NULL) {
+		return TCL_ERROR;
+	    }
+	    bodyIsEmpty = 0;
+	    break;
+	}
+    }
+
+    /*
+     * Determine if we're manipulating a dict in a simple local variable.
      */
 
     gotPath = (parsePtr->numWords > 3);
-    if (dictVarTokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
-	const char *ptr = dictVarTokenPtr[1].start;
-	const char *end = ptr + dictVarTokenPtr[1].size;
-	int notArray = 1;
+    if (varTokenPtr->type == TCL_TOKEN_SIMPLE_WORD &&
+	    TclIsLocalScalar(varTokenPtr[1].start, varTokenPtr[1].size)) {
+	dictVar = TclFindCompiledLocal(varTokenPtr[1].start,
+		varTokenPtr[1].size, 1, envPtr);
+    }
 
-	/*
-	 * A conservative check for if we're working with an array since we
-	 * have a reasonable fallback if things are tricky.
-	 */
+    /*
+     * Special case: an empty body means we definitely have no need to issue
+     * try-finally style code or to allocate local variable table entries for
+     * storing temporaries. Still need to do both INST_DICT_EXPAND and
+     * INST_DICT_RECOMBINE_* though, because we can't determine if we're free
+     * of traces.
+     */
 
-	for (; ptr<end ; ptr++) {
-	    if (*ptr == '(' || *ptr == ')') {
-		notArray = 0;
-		break;
+    if (bodyIsEmpty) {
+	if (dictVar >= 0) {
+	    if (gotPath) {
+		/*
+		 * Case: Path into dict in LVT with empty body.
+		 */
+
+		tokenPtr = TokenAfter(varTokenPtr);
+		for (i=2 ; i<parsePtr->numWords-1 ; i++) {
+		    CompileWord(envPtr, tokenPtr, interp, i-1);
+		    tokenPtr = TokenAfter(tokenPtr);
+		}
+		TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
+		Emit14Inst(	INST_LOAD_SCALAR, dictVar,	envPtr);
+		TclEmitInstInt4(INST_OVER, 1,			envPtr);
+		TclEmitOpcode(	INST_DICT_EXPAND,		envPtr);
+		TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+		PushLiteral(envPtr, "", 0);
+	    } else {
+		/*
+		 * Case: Direct dict in LVT with empty body.
+		 */
+
+		PushLiteral(envPtr, "", 0);
+		Emit14Inst(	INST_LOAD_SCALAR, dictVar,	envPtr);
+		PushLiteral(envPtr, "", 0);
+		TclEmitOpcode(	INST_DICT_EXPAND,		envPtr);
+		TclEmitInstInt4(INST_DICT_RECOMBINE_IMM, dictVar, envPtr);
+		PushLiteral(envPtr, "", 0);
+	    }
+	} else {
+	    if (gotPath) {
+		/*
+		 * Case: Path into dict in non-simple var with empty body.
+		 */
+
+		tokenPtr = varTokenPtr;
+		for (i=1 ; i<parsePtr->numWords-1 ; i++) {
+		    CompileWord(envPtr, tokenPtr, interp, i-1);
+		    tokenPtr = TokenAfter(tokenPtr);
+		}
+		TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr);
+		TclEmitInstInt4(INST_OVER, 1,			envPtr);
+		TclEmitOpcode(	INST_LOAD_STK,			envPtr);
+		TclEmitInstInt4(INST_OVER, 1,			envPtr);
+		TclEmitOpcode(	INST_DICT_EXPAND,		envPtr);
+		TclEmitOpcode(	INST_DICT_RECOMBINE_STK,	envPtr);
+		PushLiteral(envPtr, "", 0);
+	    } else {
+		/*
+		 * Case: Direct dict in non-simple var with empty body.
+		 */
+
+		CompileWord(envPtr, varTokenPtr, interp, 0);
+		TclEmitOpcode(	INST_DUP,			envPtr);
+		TclEmitOpcode(	INST_LOAD_STK,			envPtr);
+		PushLiteral(envPtr, "", 0);
+		TclEmitOpcode(	INST_DICT_EXPAND,		envPtr);
+		PushLiteral(envPtr, "", 0);
+		TclEmitInstInt4(INST_REVERSE, 2,		envPtr);
+		TclEmitOpcode(	INST_DICT_RECOMBINE_STK,	envPtr);
+		PushLiteral(envPtr, "", 0);
 	    }
 	}
-	if (notArray) {
-	    dictVar = TclFindCompiledLocal(dictVarTokenPtr[1].start,
-		    dictVarTokenPtr[1].size, 1, envPtr);
-	}
+	return TCL_OK;
     }
+
+    /*
+     * OK, we have a non-trivial body. This means that the focus is on
+     * generating a try-finally structure where the INST_DICT_RECOMBINE_* goes
+     * in the 'finally' clause.
+     *
+     * Start by allocating local (unnamed, untraced) working variables.
+     */
+
     if (dictVar == -1) {
 	varNameTmp = TclFindCompiledLocal(NULL, 0, 1, envPtr);
     } else {
@@ -1318,51 +1400,32 @@ TclCompileDictWithCmd(
      * Issue instructions. First, the part to expand the dictionary.
      */
 
-    tokenPtr = dictVarTokenPtr;
     if (varNameTmp > -1) {
-	CompileWord(envPtr, tokenPtr, interp, 0);
-	if (varNameTmp <= 255) {
-	    TclEmitInstInt1(	INST_STORE_SCALAR1, varNameTmp,	envPtr);
-	} else {
-	    TclEmitInstInt4(	INST_STORE_SCALAR4, varNameTmp,	envPtr);
-	}
+	CompileWord(envPtr, varTokenPtr, interp, 0);
+	Emit14Inst(		INST_STORE_SCALAR, varNameTmp,	envPtr);
     }
-    tokenPtr = TokenAfter(tokenPtr);
+    tokenPtr = TokenAfter(varTokenPtr);
     if (gotPath) {
 	for (i=2 ; i<parsePtr->numWords-1 ; i++) {
 	    CompileWord(envPtr, tokenPtr, interp, i-1);
 	    tokenPtr = TokenAfter(tokenPtr);
 	}
 	TclEmitInstInt4(	INST_LIST, parsePtr->numWords-3,envPtr);
-	if (pathTmp <= 255) {
-	    TclEmitInstInt1(	INST_STORE_SCALAR1, pathTmp,	envPtr);
-	} else {
-	    TclEmitInstInt4(	INST_STORE_SCALAR4, pathTmp,	envPtr);
-	}
+	Emit14Inst(		INST_STORE_SCALAR, pathTmp,	envPtr);
 	TclEmitOpcode(		INST_POP,			envPtr);
     }
     if (dictVar == -1) {
 	TclEmitOpcode(		INST_LOAD_STK,			envPtr);
-    } else if (dictVar <= 255) {
-	TclEmitInstInt1(	INST_LOAD_SCALAR1, dictVar,	envPtr);
     } else {
-	TclEmitInstInt4(	INST_LOAD_SCALAR4, dictVar,	envPtr);
+	Emit14Inst(		INST_LOAD_SCALAR, dictVar,	envPtr);
     }
     if (gotPath) {
-	if (pathTmp <= 255) {
-	    TclEmitInstInt1(	INST_LOAD_SCALAR1, pathTmp,	envPtr);
-	} else {
-	    TclEmitInstInt4(	INST_LOAD_SCALAR4, pathTmp,	envPtr);
-	}
+	Emit14Inst(		INST_LOAD_SCALAR, pathTmp,	envPtr);
     } else {
 	PushLiteral(envPtr, "", 0);
     }
     TclEmitOpcode(		INST_DICT_EXPAND,		envPtr);
-    if (keysTmp <= 255) {
-	TclEmitInstInt1(	INST_STORE_SCALAR1, keysTmp,	envPtr);
-    } else {
-	TclEmitInstInt4(	INST_STORE_SCALAR4, keysTmp,	envPtr);
-    }
+    Emit14Inst(			INST_STORE_SCALAR, keysTmp,	envPtr);
     TclEmitOpcode(		INST_POP,			envPtr);
 
     /*
@@ -1384,25 +1447,15 @@ TclCompileDictWithCmd(
      */
 
     TclEmitOpcode(		INST_END_CATCH,			envPtr);
-    if (varNameTmp > -1 && varNameTmp <= 255) {
-	TclEmitInstInt1(	INST_LOAD_SCALAR1, varNameTmp,	envPtr);
-    } else if (varNameTmp > -1) {
-	TclEmitInstInt4(	INST_LOAD_SCALAR4, varNameTmp,	envPtr);
+    if (varNameTmp > -1) {
+	Emit14Inst(		INST_LOAD_SCALAR, varNameTmp,	envPtr);
     }
     if (gotPath) {
-	if (pathTmp <= 255) {
-	    TclEmitInstInt1(	INST_LOAD_SCALAR1, pathTmp,	envPtr);
-	} else {
-	    TclEmitInstInt4(	INST_LOAD_SCALAR4, pathTmp,	envPtr);
-	}
+	Emit14Inst(		INST_LOAD_SCALAR, pathTmp,	envPtr);
     } else {
 	PushLiteral(envPtr, "", 0);
     }
-    if (keysTmp <= 255) {
-	TclEmitInstInt1(	INST_LOAD_SCALAR1, keysTmp,	envPtr);
-    } else {
-	TclEmitInstInt4(	INST_LOAD_SCALAR4, keysTmp,	envPtr);
-    }
+    Emit14Inst(			INST_LOAD_SCALAR, keysTmp,	envPtr);
     if (dictVar == -1) {
 	TclEmitOpcode(		INST_DICT_RECOMBINE_STK,	envPtr);
     } else {
@@ -1418,25 +1471,15 @@ TclCompileDictWithCmd(
     TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
     TclEmitOpcode(		INST_PUSH_RESULT,		envPtr);
     TclEmitOpcode(		INST_END_CATCH,			envPtr);
-    if (varNameTmp > -1 && varNameTmp <= 255) {
-	TclEmitInstInt1(	INST_LOAD_SCALAR1, varNameTmp,	envPtr);
-    } else if (varNameTmp > -1) {
-	TclEmitInstInt4(	INST_LOAD_SCALAR4, varNameTmp,	envPtr);
+    if (varNameTmp > -1) {
+	Emit14Inst(		INST_LOAD_SCALAR, varNameTmp,	envPtr);
     }
     if (parsePtr->numWords > 3) {
-	if (pathTmp <= 255) {
-	    TclEmitInstInt1(	INST_LOAD_SCALAR1, pathTmp,	envPtr);
-	} else {
-	    TclEmitInstInt4(	INST_LOAD_SCALAR4, pathTmp,	envPtr);
-	}
+	Emit14Inst(		INST_LOAD_SCALAR, pathTmp,	envPtr);
     } else {
 	PushLiteral(envPtr, "", 0);
     }
-    if (keysTmp <= 255) {
-	TclEmitInstInt1(	INST_LOAD_SCALAR1, keysTmp,	envPtr);
-    } else {
-	TclEmitInstInt4(	INST_LOAD_SCALAR4, keysTmp,	envPtr);
-    }
+    Emit14Inst(			INST_LOAD_SCALAR, keysTmp,	envPtr);
     if (dictVar == -1) {
 	TclEmitOpcode(		INST_DICT_RECOMBINE_STK,	envPtr);
     } else {
@@ -1990,12 +2033,8 @@ TclCompileForeachCmd(
 	    SetLineInformation(i);
 	    CompileTokens(envPtr, tokenPtr, interp);
 	    tempVar = (firstValueTemp + loopIndex);
-	    if (tempVar <= 255) {
-		TclEmitInstInt1(INST_STORE_SCALAR1, tempVar, envPtr);
-	    } else {
-		TclEmitInstInt4(INST_STORE_SCALAR4, tempVar, envPtr);
-	    }
-	    TclEmitOpcode(INST_POP, envPtr);
+	    Emit14Inst(		INST_STORE_SCALAR, tempVar,	envPtr);
+	    TclEmitOpcode(	INST_POP,			envPtr);
 	    loopIndex++;
 	}
     }
@@ -2004,7 +2043,7 @@ TclCompileForeachCmd(
      * Initialize the temporary var that holds the count of loop iterations.
      */
 
-    TclEmitInstInt4(INST_FOREACH_START4, infoIndex, envPtr);
+    TclEmitInstInt4(		INST_FOREACH_START4, infoIndex,	envPtr);
 
     /*
      * Top of loop code: assign each loop variable and check whether
@@ -2012,7 +2051,7 @@ TclCompileForeachCmd(
      */
 
     ExceptionRangeTarget(envPtr, range, continueOffset);
-    TclEmitInstInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+    TclEmitInstInt4(		INST_FOREACH_STEP4, infoIndex,	envPtr);
     TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
 
     /*
@@ -2024,7 +2063,7 @@ TclCompileForeachCmd(
     CompileBody(envPtr, bodyTokenPtr, interp);
     ExceptionRangeEnds(envPtr, range);
     envPtr->currStackDepth = savedStackDepth + 1;
-    TclEmitOpcode(INST_POP, envPtr);
+    TclEmitOpcode(		INST_POP,			envPtr);
 
     /*
      * Jump back to the test at the top of the loop. Generate a 4 byte jump if
@@ -2299,14 +2338,14 @@ TclCompileGlobalCmd(
 	}
 
 	CompileWord(envPtr, varTokenPtr, interp, 1);
-	TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
+	TclEmitInstInt4(	INST_NSUPVAR, localIndex,	envPtr);
     }
 
     /*
      * Pop the namespace, and set the result to empty
      */
 
-    TclEmitOpcode(INST_POP, envPtr);
+    TclEmitOpcode(		INST_POP,			envPtr);
     PushLiteral(envPtr, "", 0);
     return TCL_OK;
 }
@@ -2705,43 +2744,41 @@ TclCompileIncrCmd(
      * Emit the instruction to increment the variable.
      */
 
-    if (simpleVarName) {
-	if (isScalar) {
-	    if (localIndex >= 0) {
-		if (haveImmValue) {
-		    TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
-		    TclEmitInt1(immValue, envPtr);
-		} else {
-		    TclEmitInstInt1(INST_INCR_SCALAR1, localIndex, envPtr);
-		}
+    if (!simpleVarName) {
+	if (haveImmValue) {
+	    TclEmitInstInt1(	INST_INCR_STK_IMM, immValue,	envPtr);
+	} else {
+	    TclEmitOpcode(	INST_INCR_STK,			envPtr);
+	}
+    } else if (isScalar) {	/* Simple scalar variable. */
+	if (localIndex >= 0) {
+	    if (haveImmValue) {
+		TclEmitInstInt1(INST_INCR_SCALAR1_IMM, localIndex, envPtr);
+		TclEmitInt1(immValue, envPtr);
 	    } else {
-		if (haveImmValue) {
-		    TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
-		} else {
-		    TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
-		}
+		TclEmitInstInt1(INST_INCR_SCALAR1, localIndex,	envPtr);
 	    }
 	} else {
-	    if (localIndex >= 0) {
-		if (haveImmValue) {
-		    TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
-		    TclEmitInt1(immValue, envPtr);
-		} else {
-		    TclEmitInstInt1(INST_INCR_ARRAY1, localIndex, envPtr);
-		}
+	    if (haveImmValue) {
+		TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immValue, envPtr);
 	    } else {
-		if (haveImmValue) {
-		    TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
-		} else {
-		    TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
-		}
+		TclEmitOpcode(	INST_INCR_SCALAR_STK,		envPtr);
 	    }
 	}
-    } else {			/* Non-simple variable name. */
-	if (haveImmValue) {
-	    TclEmitInstInt1(INST_INCR_STK_IMM, immValue, envPtr);
+    } else {			/* Simple array variable. */
+	if (localIndex >= 0) {
+	    if (haveImmValue) {
+		TclEmitInstInt1(INST_INCR_ARRAY1_IMM, localIndex, envPtr);
+		TclEmitInt1(immValue, envPtr);
+	    } else {
+		TclEmitInstInt1(INST_INCR_ARRAY1, localIndex,	envPtr);
+	    }
 	} else {
-	    TclEmitOpcode(INST_INCR_STK, envPtr);
+	    if (haveImmValue) {
+		TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immValue, envPtr);
+	    } else {
+		TclEmitOpcode(	INST_INCR_ARRAY_STK,		envPtr);
+	    }
 	}
     }
 
@@ -2799,22 +2836,20 @@ TclCompileInfoExistsCmd(
      * Emit instruction to check the variable for existence.
      */
 
-    if (simpleVarName) {
-	if (isScalar) {
-	    if (localIndex < 0) {
-		TclEmitOpcode(INST_EXIST_STK, envPtr);
-	    } else {
-		TclEmitInstInt4(INST_EXIST_SCALAR, localIndex, envPtr);
-	    }
+    if (!simpleVarName) {
+	TclEmitOpcode(		INST_EXIST_STK,			envPtr);
+    } else if (isScalar) {
+	if (localIndex < 0) {
+	    TclEmitOpcode(	INST_EXIST_STK,			envPtr);
 	} else {
-	    if (localIndex < 0) {
-		TclEmitOpcode(INST_EXIST_ARRAY_STK, envPtr);
-	    } else {
-		TclEmitInstInt4(INST_EXIST_ARRAY, localIndex, envPtr);
-	    }
+	    TclEmitInstInt4(	INST_EXIST_SCALAR, localIndex,	envPtr);
 	}
     } else {
-	TclEmitOpcode(INST_EXIST_STK, envPtr);
+	if (localIndex < 0) {
+	    TclEmitOpcode(	INST_EXIST_ARRAY_STK,		envPtr);
+	} else {
+	    TclEmitInstInt4(	INST_EXIST_ARRAY, localIndex,	envPtr);
+	}
     }
 
     return TCL_OK;
@@ -2904,26 +2939,20 @@ TclCompileLappendCmd(
      * LOAD/STORE instructions.
      */
 
-    if (simpleVarName) {
-	if (isScalar) {
-	    if (localIndex < 0) {
-		TclEmitOpcode(INST_LAPPEND_STK, envPtr);
-	    } else if (localIndex <= 255) {
-		TclEmitInstInt1(INST_LAPPEND_SCALAR1, localIndex, envPtr);
-	    } else {
-		TclEmitInstInt4(INST_LAPPEND_SCALAR4, localIndex, envPtr);
-	    }
+    if (!simpleVarName) {
+	TclEmitOpcode(		INST_LAPPEND_STK,		envPtr);
+    } else if (isScalar) {
+	if (localIndex < 0) {
+	    TclEmitOpcode(	INST_LAPPEND_STK,		envPtr);
 	} else {
-	    if (localIndex < 0) {
-		TclEmitOpcode(INST_LAPPEND_ARRAY_STK, envPtr);
-	    } else if (localIndex <= 255) {
-		TclEmitInstInt1(INST_LAPPEND_ARRAY1, localIndex, envPtr);
-	    } else {
-		TclEmitInstInt4(INST_LAPPEND_ARRAY4, localIndex, envPtr);
-	    }
+	    Emit14Inst(		INST_LAPPEND_SCALAR, localIndex, envPtr);
 	}
     } else {
-	TclEmitOpcode(INST_LAPPEND_STK, envPtr);
+	if (localIndex < 0) {
+	    TclEmitOpcode(	INST_LAPPEND_ARRAY_STK,		envPtr);
+	} else {
+	    Emit14Inst(		INST_LAPPEND_ARRAY, localIndex,	envPtr);
+	}
     }
 
     return TCL_OK;
@@ -2996,50 +3025,44 @@ TclCompileLassignCmd(
 	 * the stack and assign it to the variable.
 	 */
 
-	if (simpleVarName) {
-	    if (isScalar) {
-		if (localIndex >= 0) {
-		    TclEmitOpcode(INST_DUP, envPtr);
-		    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
-		    if (localIndex <= 255) {
-			TclEmitInstInt1(INST_STORE_SCALAR1,localIndex,envPtr);
-		    } else {
-			TclEmitInstInt4(INST_STORE_SCALAR4,localIndex,envPtr);
-		    }
-		} else {
-		    TclEmitInstInt4(INST_OVER, 1, envPtr);
-		    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
-		    TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
-		}
+	if (!simpleVarName) {
+	    TclEmitInstInt4(	INST_OVER, 1,			envPtr);
+	    TclEmitInstInt4(	INST_LIST_INDEX_IMM, idx,	envPtr);
+	    TclEmitOpcode(	INST_STORE_STK,			envPtr);
+	    TclEmitOpcode(	INST_POP,			envPtr);
+	} else if (isScalar) {
+	    if (localIndex >= 0) {
+		TclEmitOpcode(	INST_DUP,			envPtr);
+		TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,	envPtr);
+		Emit14Inst(	INST_STORE_SCALAR, localIndex,	envPtr);
+		TclEmitOpcode(	INST_POP,			envPtr);
 	    } else {
-		if (localIndex >= 0) {
-		    TclEmitInstInt4(INST_OVER, 1, envPtr);
-		    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
-		    if (localIndex <= 255) {
-			TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
-		    } else {
-			TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
-		    }
-		} else {
-		    TclEmitInstInt4(INST_OVER, 2, envPtr);
-		    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
-		    TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
-		}
+		TclEmitInstInt4(INST_OVER, 1,			envPtr);
+		TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,	envPtr);
+		TclEmitOpcode(	INST_STORE_SCALAR_STK,		envPtr);
+		TclEmitOpcode(	INST_POP,			envPtr);
 	    }
 	} else {
-	    TclEmitInstInt4(INST_OVER, 1, envPtr);
-	    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
-	    TclEmitOpcode(INST_STORE_STK, envPtr);
+	    if (localIndex >= 0) {
+		TclEmitInstInt4(INST_OVER, 1,			envPtr);
+		TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,	envPtr);
+		Emit14Inst(	INST_STORE_ARRAY, localIndex,	envPtr);
+		TclEmitOpcode(	INST_POP,			envPtr);
+	    } else {
+		TclEmitInstInt4(INST_OVER, 2,			envPtr);
+		TclEmitInstInt4(INST_LIST_INDEX_IMM, idx,	envPtr);
+		TclEmitOpcode(	INST_STORE_ARRAY_STK,		envPtr);
+		TclEmitOpcode(	INST_POP,			envPtr);
+	    }
 	}
-	TclEmitOpcode(INST_POP, envPtr);
     }
 
     /*
      * Generate code to leave the rest of the list on the stack.
      */
 
-    TclEmitInstInt4(INST_LIST_RANGE_IMM, idx, envPtr);
-    TclEmitInt4(-2, envPtr);	/* -2 == "end" */
+    TclEmitInstInt4(		INST_LIST_RANGE_IMM, idx,	envPtr);
+    TclEmitInt4(		-2 /* == "end" */,		envPtr);
 
     return TCL_OK;
 }
@@ -3107,7 +3130,7 @@ TclCompileLindexCmd(
 	     */
 
 	    CompileWord(envPtr, valTokenPtr, interp, 1);
-	    TclEmitInstInt4(INST_LIST_INDEX_IMM, idx, envPtr);
+	    TclEmitInstInt4(	INST_LIST_INDEX_IMM, idx,	envPtr);
 	    return TCL_OK;
 	}
 
@@ -3133,9 +3156,9 @@ TclCompileLindexCmd(
      */
 
     if (numWords == 3) {
-	TclEmitOpcode(INST_LIST_INDEX, envPtr);
+	TclEmitOpcode(		INST_LIST_INDEX,		envPtr);
     } else {
-	TclEmitInstInt4(INST_LIST_INDEX_MULTI, numWords-1, envPtr);
+	TclEmitInstInt4(	INST_LIST_INDEX_MULTI, numWords-1, envPtr);
     }
 
     return TCL_OK;
@@ -3169,6 +3192,8 @@ TclCompileListCmd(
     CompileEnv *envPtr)		/* Holds resulting instructions. */
 {
     DefineLineInformation;	/* TIP #280 */
+    Tcl_Token *valueTokenPtr;
+    int i, numWords;
 
     /*
      * If we're not in a procedure, don't compile.
@@ -3189,17 +3214,13 @@ TclCompileListCmd(
 	 * Push the all values onto the stack.
 	 */
 
-	Tcl_Token *valueTokenPtr;
-	int i, numWords;
-
 	numWords = parsePtr->numWords;
-
 	valueTokenPtr = TokenAfter(parsePtr->tokenPtr);
 	for (i = 1; i < numWords; i++) {
 	    CompileWord(envPtr, valueTokenPtr, interp, i);
 	    valueTokenPtr = TokenAfter(valueTokenPtr);
 	}
-	TclEmitInstInt4(INST_LIST, numWords - 1, envPtr);
+	TclEmitInstInt4(	INST_LIST, numWords - 1,	envPtr);
     }
 
     return TCL_OK;
@@ -3241,7 +3262,7 @@ TclCompileLlengthCmd(
     varTokenPtr = TokenAfter(parsePtr->tokenPtr);
 
     CompileWord(envPtr, varTokenPtr, interp, 1);
-    TclEmitOpcode(INST_LIST_LENGTH, envPtr);
+    TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
     return TCL_OK;
 }
 
@@ -3347,7 +3368,7 @@ TclCompileLsetCmd(
 	} else {
 	    tempDepth = parsePtr->numWords - 1;
 	}
-	TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
+	TclEmitInstInt4(	INST_OVER, tempDepth,		envPtr);
     }
 
     /*
@@ -3360,7 +3381,7 @@ TclCompileLsetCmd(
 	} else {
 	    tempDepth = parsePtr->numWords - 2;
 	}
-	TclEmitInstInt4(INST_OVER, tempDepth, envPtr);
+	TclEmitInstInt4(	INST_OVER, tempDepth,		envPtr);
     }
 
     /*
@@ -3368,22 +3389,18 @@ TclCompileLsetCmd(
      */
 
     if (!simpleVarName) {
-	TclEmitOpcode(INST_LOAD_STK, envPtr);
+	TclEmitOpcode(		INST_LOAD_STK,			envPtr);
     } else if (isScalar) {
 	if (localIndex < 0) {
-	    TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
-	} else if (localIndex < 0x100) {
-	    TclEmitInstInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
+	    TclEmitOpcode(	INST_LOAD_SCALAR_STK,		envPtr);
 	} else {
-	    TclEmitInstInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
+	    Emit14Inst(		INST_LOAD_SCALAR, localIndex,	envPtr);
 	}
     } else {
 	if (localIndex < 0) {
-	    TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
-	} else if (localIndex < 0x100) {
-	    TclEmitInstInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
+	    TclEmitOpcode(	INST_LOAD_ARRAY_STK,		envPtr);
 	} else {
-	    TclEmitInstInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
+	    Emit14Inst(		INST_LOAD_ARRAY, localIndex,	envPtr);
 	}
     }
 
@@ -3392,9 +3409,9 @@ TclCompileLsetCmd(
      */
 
     if (parsePtr->numWords == 4) {
-	TclEmitOpcode(INST_LSET_LIST, envPtr);
+	TclEmitOpcode(		INST_LSET_LIST,			envPtr);
     } else {
-	TclEmitInstInt4(INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
+	TclEmitInstInt4(	INST_LSET_FLAT, parsePtr->numWords-1, envPtr);
     }
 
     /*
@@ -3402,22 +3419,18 @@ TclCompileLsetCmd(
      */
 
     if (!simpleVarName) {
-	TclEmitOpcode(INST_STORE_STK, envPtr);
+	TclEmitOpcode(		INST_STORE_STK,			envPtr);
     } else if (isScalar) {
 	if (localIndex < 0) {
-	    TclEmitOpcode(INST_STORE_SCALAR_STK, envPtr);
-	} else if (localIndex < 0x100) {
-	    TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
+	    TclEmitOpcode(	INST_STORE_SCALAR_STK,		envPtr);
 	} else {
-	    TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+	    Emit14Inst(		INST_STORE_SCALAR, localIndex,	envPtr);
 	}
     } else {
 	if (localIndex < 0) {
-	    TclEmitOpcode(INST_STORE_ARRAY_STK, envPtr);
-	} else if (localIndex < 0x100) {
-	    TclEmitInstInt1(INST_STORE_ARRAY1, localIndex, envPtr);
+	    TclEmitOpcode(	INST_STORE_ARRAY_STK,		envPtr);
 	} else {
-	    TclEmitInstInt4(INST_STORE_ARRAY4, localIndex, envPtr);
+	    Emit14Inst(		INST_STORE_ARRAY, localIndex,	envPtr);
 	}
     }
 
@@ -3495,14 +3508,14 @@ TclCompileNamespaceUpvarCmd(
 	if ((localIndex < 0) || !isScalar) {
 	    return TCL_ERROR;
 	}
-	TclEmitInstInt4(INST_NSUPVAR, localIndex, envPtr);
+	TclEmitInstInt4(	INST_NSUPVAR, localIndex,	envPtr);
     }
 
     /*
      * Pop the namespace, and set the result to empty
      */
 
-    TclEmitOpcode(INST_POP, envPtr);
+    TclEmitOpcode(		INST_POP,			envPtr);
     PushLiteral(envPtr, "", 0);
     return TCL_OK;
 }
@@ -3653,9 +3666,9 @@ TclCompileRegexpCmd(
 
     if (simple) {
 	if (exact && !nocase) {
-	    TclEmitOpcode(INST_STR_EQ, envPtr);
+	    TclEmitOpcode(	INST_STR_EQ,			envPtr);
 	} else {
-	    TclEmitInstInt1(INST_STR_MATCH, nocase, envPtr);
+	    TclEmitInstInt1(	INST_STR_MATCH, nocase,		envPtr);
 	}
     } else {
 	/*
@@ -3666,7 +3679,7 @@ TclCompileRegexpCmd(
 
 	int cflags = TCL_REG_ADVANCED | (nocase ? TCL_REG_NOCASE : 0);
 
-	TclEmitInstInt1(INST_REGEXP, cflags, envPtr);
+	TclEmitInstInt1(	INST_REGEXP, cflags,		envPtr);
     }
 
     return TCL_OK;
@@ -3864,7 +3877,7 @@ TclCompileSyntaxError(
     TclErrorStackResetIf(interp, bytes, numBytes);
     TclEmitPush(TclRegisterNewLiteral(envPtr, bytes, numBytes), envPtr);
     CompileReturnInternal(envPtr, INST_SYNTAX, TCL_ERROR, 0,
-			  TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
+	    TclNoErrorStack(interp, Tcl_GetReturnOptions(interp, TCL_ERROR)));
 }
 
 /*
@@ -3964,14 +3977,14 @@ TclCompileUpvarCmd(
 	if ((localIndex < 0) || !isScalar) {
 	    return TCL_ERROR;
 	}
-	TclEmitInstInt4(INST_UPVAR, localIndex, envPtr);
+	TclEmitInstInt4(	INST_UPVAR, localIndex,		envPtr);
     }
 
     /*
      * Pop the frame index, and set the result to empty
      */
 
-    TclEmitOpcode(INST_POP, envPtr);
+    TclEmitOpcode(		INST_POP,			envPtr);
     PushLiteral(envPtr, "", 0);
     return TCL_OK;
 }
@@ -4036,7 +4049,7 @@ TclCompileVariableCmd(
 	}
 
 	CompileWord(envPtr, varTokenPtr, interp, 1);
-	TclEmitInstInt4(INST_VARIABLE, localIndex, envPtr);
+	TclEmitInstInt4(	INST_VARIABLE, localIndex,	envPtr);
 
 	if (i != numWords) {
 	    /*
@@ -4044,12 +4057,8 @@ TclCompileVariableCmd(
 	     */
 
 	    CompileWord(envPtr, valueTokenPtr, interp, 1);
-	    if (localIndex < 0x100) {
-		TclEmitInstInt1(INST_STORE_SCALAR1, localIndex, envPtr);
-	    } else {
-		TclEmitInstInt4(INST_STORE_SCALAR4, localIndex, envPtr);
-	    }
-	    TclEmitOpcode(INST_POP, envPtr);
+	    Emit14Inst(		INST_STORE_SCALAR, localIndex,	envPtr);
+	    TclEmitOpcode(	INST_POP,			envPtr);
 	}
     }
 
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index 8e7f0d0..e80a710 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -676,6 +676,7 @@ typedef struct ByteCode {
 #define INST_UNSET_ARRAY_STK		136
 #define INST_UNSET_STK			137
 
+/* For [dict with] compilation */
 #define INST_DICT_EXPAND		138
 #define INST_DICT_RECOMBINE_STK		139
 #define INST_DICT_RECOMBINE_IMM		140
diff --git a/tests/dict.test b/tests/dict.test
index 41c21e2..87e5107 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -1424,6 +1424,54 @@ test dict-22.17 {dict with: compiled} {
 	array get d
     }} e
 } {e {p {q {a 2.1 b 2}}}}
+test dict-22.18 {dict with: compiled} {
+    set ::d {a 1 b 2}
+    apply {{} {
+	dict with ::d {
+	    set a $b.$a
+	}
+	return $::d
+    }}
+} {a 2.1 b 2}
+test dict-22.19 {dict with: compiled} {
+    set ::d {p {q {r {a 1 b 2}}}}
+    apply {{} {
+	dict with ::d p q r {
+	    set a $b.$a
+	}
+	return $::d
+    }}
+} {p {q {r {a 2.1 b 2}}}}
+test dict-22.20 {dict with: compiled} {
+    apply {d {
+	dict with d {
+	}
+	return $a,$b
+    }} {a 1 b 2}
+} 1,2
+test dict-22.21 {dict with: compiled} {
+    apply {d {
+	dict with d p q {
+	}
+	return $a,$b
+    }} {p {q {a 1 b 2}}}
+} 1,2
+test dict-22.22 {dict with: compiled} {
+    set ::d {a 1 b 2}
+    apply {{} {
+	dict with ::d {
+	}
+	return $a,$b
+    }}
+} 1,2
+test dict-22.23 {dict with: compiled} {
+    set ::d {p {q {a 1 b 2}}}
+    apply {{} {
+	dict with ::d p q {
+	}
+	return $a,$b
+    }}
+} 1,2
 
 # cleanup
 ::tcltest::cleanupTests
-- 
cgit v0.12


From 6a82abf5e33b58989732a0858f89347235fabb42 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 13 Oct 2011 18:02:27 +0000
Subject: 3423069 silence compiler warnings.

---
 generic/tclTest.c | 5 +++--
 1 file changed, 3 insertions(+), 2 deletions(-)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 30c95c8..03afad9 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -75,7 +75,7 @@ typedef struct TestAsyncHandler {
 				/* Next is list of handlers. */
 } TestAsyncHandler;
 
-TCL_DECLARE_MUTEX(asyncTestMutex);
+TCL_DECLARE_MUTEX(asyncTestMutex)
 
 static TestAsyncHandler *firstHandler = NULL;
 
@@ -7109,7 +7109,8 @@ TestparseargsCmd(
     int objc,			/* Number of arguments. */
     Tcl_Obj *const objv[])	/* Arguments. */
 {
-    int count = objc, foo = 0;
+    static int foo = 0;
+    int count = objc;
     Tcl_Obj **remObjv, *result[3];
     Tcl_ArgvInfo argTable[] = {
         {TCL_ARGV_CONSTANT, "-bool", INT2PTR(1), &foo, "booltest", NULL},
-- 
cgit v0.12


From c0473e256855d4fd008395dd43e4cad66af222d5 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 13 Oct 2011 18:10:20 +0000
Subject: 3423059 silence compiler warning

---
 generic/tclNamesp.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index 9a2152a..73bc644 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -170,7 +170,7 @@ static const EnsembleImplMap defaultNamespaceMap[] = {
     {"export",          NamespaceExportCmd, NULL, NULL, NULL, 0},
     {"forget",          NamespaceForgetCmd, NULL, NULL, NULL, 0},
     {"import",          NamespaceImportCmd, NULL, NULL, NULL, 0},
-    {"inscope",         NamespaceInscopeCmd,    NULL, NULL, NRNamespaceInscopeCmd, 0},
+    {"inscope",         NamespaceInscopeCmd,    NULL, NRNamespaceInscopeCmd, NULL, 0},
     {"origin",          NamespaceOriginCmd, NULL, NULL, NULL, 0},
     {"parent",          NamespaceParentCmd, NULL, NULL, NULL, 0},
     {"path",            NamespacePathCmd, NULL, NULL, NULL, 0},
-- 
cgit v0.12


From 18dff8dc18b2826f2160ce237232b1c73a08be93 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 13 Oct 2011 18:19:26 +0000
Subject: Correct botch.

---
 generic/tclTest.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 03afad9..cbebacd 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -7117,6 +7117,7 @@ TestparseargsCmd(
         TCL_ARGV_AUTO_REST, TCL_ARGV_AUTO_HELP, TCL_ARGV_TABLE_END
     };
 
+    foo = 0;
     if (Tcl_ParseArgsObjv(interp, argTable, &count, objv, &remObjv)!=TCL_OK) {
         return TCL_ERROR;
     }
-- 
cgit v0.12


From 971594ecc4d41c4f217aa38a911f6858e81ca5d0 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 15 Oct 2011 15:57:08 +0000
Subject: Commit of patch relating to interp resolvers

---
 generic/tclBasic.c   |  46 +++++++++++++
 generic/tclCompile.h |   2 +
 generic/tclLiteral.c |  40 +++++++++++
 generic/tclTest.c    | 184 +++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 272 insertions(+)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 9758449..d10e8e6 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -1922,6 +1922,17 @@ Tcl_ExposeCommand(
     }
 
     /*
+     * Command resolvers (per-interp, per-namespace) might have resolved to a
+     * command for the given namespace scope with this command not being
+     * registered with the namespace's command table. During BC compilation,
+     * the so-resolved command turns into a CmdName literal. Without
+     * invalidating a possible CmdName literal here explicitly, such literals
+     * keep being reused while pointing to overhauled commands.
+     */
+
+    TclInvalidateCmdLiteral(interp, cmdName, nsPtr);
+
+    /*
      * The list of command exported from the namespace might have changed.
      * However, we do not need to recompute this just yet; next time we need
      * the info will be soon enough.
@@ -2069,6 +2080,18 @@ Tcl_CreateCommand(
 	}
     } else {
 	/*
+	 * Command resolvers (per-interp, per-namespace) might have resolved
+	 * to a command for the given namespace scope with this command not
+	 * being registered with the namespace's command table. During BC
+	 * compilation, the so-resolved command turns into a CmdName literal.
+	 * Without invalidating a possible CmdName literal here explicitly,
+	 * such literals keep being reused while pointing to overhauled
+	 * commands.
+	 */
+
+	TclInvalidateCmdLiteral(interp, tail, nsPtr);
+
+	/*
 	 * The list of command exported from the namespace might have changed.
 	 * However, we do not need to recompute this just yet; next time we
 	 * need the info will be soon enough.
@@ -2242,6 +2265,18 @@ Tcl_CreateObjCommand(
 	}
     } else {
 	/*
+	 * Command resolvers (per-interp, per-namespace) might have resolved
+	 * to a command for the given namespace scope with this command not
+	 * being registered with the namespace's command table. During BC
+	 * compilation, the so-resolved command turns into a CmdName literal.
+	 * Without invalidating a possible CmdName literal here explicitly,
+	 * such literals keep being reused while pointing to overhauled
+	 * commands.
+	 */
+
+	TclInvalidateCmdLiteral(interp, tail, nsPtr);
+
+	/*
 	 * The list of command exported from the namespace might have changed.
 	 * However, we do not need to recompute this just yet; next time we
 	 * need the info will be soon enough.
@@ -2551,6 +2586,17 @@ TclRenameCommand(
     TclInvalidateNsCmdLookup(cmdPtr->nsPtr);
 
     /*
+     * Command resolvers (per-interp, per-namespace) might have resolved to a
+     * command for the given namespace scope with this command not being
+     * registered with the namespace's command table. During BC compilation,
+     * the so-resolved command turns into a CmdName literal. Without
+     * invalidating a possible CmdName literal here explicitly, such literals
+     * keep being reused while pointing to overhauled commands.
+     */
+
+    TclInvalidateCmdLiteral(interp, newTail, cmdPtr->nsPtr);
+
+    /*
      * Script for rename traces can delete the command "oldName". Therefore
      * increment the reference count for cmdPtr so that it's Command structure
      * is freed only towards the end of this function by calling
diff --git a/generic/tclCompile.h b/generic/tclCompile.h
index e80a710..58663fd 100644
--- a/generic/tclCompile.h
+++ b/generic/tclCompile.h
@@ -960,6 +960,8 @@ MODULE_SCOPE void	TclRegisterAuxDataType(const AuxDataType *typePtr);
 MODULE_SCOPE int	TclRegisterLiteral(CompileEnv *envPtr,
 			    char *bytes, int length, int flags);
 MODULE_SCOPE void	TclReleaseLiteral(Tcl_Interp *interp, Tcl_Obj *objPtr);
+MODULE_SCOPE void	TclInvalidateCmdLiteral(Tcl_Interp *interp, 
+			    const char *name, Namespace *nsPtr);
 MODULE_SCOPE int	TclSingleOpCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
diff --git a/generic/tclLiteral.c b/generic/tclLiteral.c
index 3a9f8e1..441ea91 100644
--- a/generic/tclLiteral.c
+++ b/generic/tclLiteral.c
@@ -936,6 +936,46 @@ RebuildLiteralTable(
     }
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInvalidateCmdLiteral --
+ *
+ *	Invalidate a command literal entry, if present in the literal hash
+ *	tables, by resetting its internal representation. This invalidation
+ *	leaves it in the literal tables and in existing literal arrays. As a
+ *	result, existing references continue to work but we force a fresh
+ *	command look-up upon the next use (see, in particular,
+ *	TclSetCmdNameObj()).
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects: 
+ *	Resets the internal representation of the CmdName Tcl_Obj
+ *	using TclFreeIntRep().
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInvalidateCmdLiteral(
+    Tcl_Interp *interp,		/* Interpreter for which to invalidate a
+				 * command literal. */
+    const char *name,		/* Points to the start of the cmd literal
+				 * name. */
+    Namespace *nsPtr)		/* The namespace for which to lookup and
+				 * invalidate a cmd literal. */
+{
+    Interp *iPtr = (Interp *) interp;
+    Tcl_Obj *literalObjPtr = TclCreateLiteral(iPtr, (char *) name,
+	    strlen(name), -1, NULL, nsPtr, 0, NULL);
+
+    if (literalObjPtr != NULL && literalObjPtr->typePtr == &tclCmdNameType) {
+	TclFreeIntRep(literalObjPtr);
+    }
+}
+
 #ifdef TCL_COMPILE_STATS
 /*
  *----------------------------------------------------------------------
diff --git a/generic/tclTest.c b/generic/tclTest.c
index cbebacd..299ba0e 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -411,6 +411,9 @@ static int		TestHashSystemHashCmd(ClientData clientData,
 static int		TestNRELevels(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
+static int		TestInterpResolversCmd(ClientData clientData,
+			    Tcl_Interp *interp, int objc,
+			    Tcl_Obj *const objv[]);
 
 static const Tcl_Filesystem testReportingFilesystem = {
     "reporting",
@@ -675,6 +678,8 @@ Tcltest_Init(
 
     Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
 	    NULL, NULL);
+    Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolversCmd,
+	    NULL, NULL);
 
     if (TclObjTest_Init(interp) != TCL_OK) {
 	return TCL_ERROR;
@@ -7129,6 +7134,185 @@ TestparseargsCmd(
     return TCL_OK;
 }
 
+static int
+InterpCmdResolver(
+    Tcl_Interp *interp,
+    const char *name,
+    Tcl_Namespace *context,
+    int flags,
+    Tcl_Command *rPtr)
+{
+    Tcl_Command sourceCmdPtr;
+    Interp *iPtr = (Interp *) interp;
+    CallFrame *varFramePtr = iPtr->varFramePtr;
+    Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
+        varFramePtr->procPtr : NULL;
+    Namespace *ns2NsPtr;
+
+    ns2NsPtr = Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+
+    if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
+            || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
+        const char *callingCmdName =
+                Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
+
+        if ((*callingCmdName == 'x') && (*(callingCmdName + 1) == '\0')
+                && (*name == 'z') && (*(name + 1) == '\0')) {
+            sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
+                    TCL_GLOBAL_ONLY);
+            if (sourceCmdPtr != NULL) {
+                *rPtr = sourceCmdPtr;
+                return TCL_OK;
+            }
+        }
+    }
+    return TCL_CONTINUE;
+}
+
+static int
+InterpVarResolver(
+    Tcl_Interp *interp,
+    const char *name,
+    Tcl_Namespace *context,
+    int flags,
+    Tcl_Var *rPtr)
+{
+    return TCL_CONTINUE;
+}
+
+typedef struct MyResolvedVarInfo {
+    Tcl_ResolvedVarInfo vInfo;  /* This must be the first element. */
+    Tcl_Var var;
+    Tcl_Obj *nameObj;
+} MyResolvedVarInfo;
+
+static void
+HashVarFree(
+    Tcl_Var var)
+{
+    if (VarHashRefCount(var) < 2) {
+        ckfree((char *) var);
+    } else {
+        VarHashRefCount(var)--;
+    }
+}
+
+static void
+MyCompiledVarFree(
+    Tcl_ResolvedVarInfo *vInfoPtr)
+{
+    MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vInfoPtr;
+
+    Tcl_DecrRefCount(resVarInfo->nameObj);
+    if (resVarInfo->var) {
+        HashVarFree(resVarInfo->var);
+    }
+    ckfree((char *)vInfoPtr);
+}
+
+#define TclVarHashGetValue(hPtr) \
+    ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
+
+static Tcl_Var
+MyCompiledVarFetch(
+    Tcl_Interp *interp,
+    Tcl_ResolvedVarInfo *vinfoPtr)
+{
+    MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr;
+    Tcl_Var var = resVarInfo->var;
+    Namespace *nsPtr;
+    int isNewVar;
+    Interp *iPtr = (Interp *) interp;
+    Tcl_HashEntry *hPtr;
+
+    if (var && !(((Var *)var)->flags & VAR_DEAD_HASH)) {
+        /*
+         * The cached variable is valid, return it.
+         */
+
+        return var;
+    }
+
+    if (var) {
+        /*
+         * The variable is not valid anymore. Clean it up.
+         */
+
+        HashVarFree(var);
+    }
+
+    nsPtr = iPtr->globalNsPtr;
+    hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &nsPtr->varTable,
+            (char *) resVarInfo->nameObj, &isNewVar);
+    if (hPtr) {
+        var = (Tcl_Var) TclVarHashGetValue(hPtr);
+    } else {
+        var = NULL;
+    }
+    resVarInfo->var = var;
+
+    /*
+     * Increment the reference counter to avoid ckfree() of the variable in
+     * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree();
+     */
+
+    VarHashRefCount(var);
+    return var;
+}
+
+static int
+InterpCompiledVarResolver(
+    Tcl_Interp *interp,
+    const char *name,
+    int length,
+    Tcl_Namespace *context,
+    Tcl_ResolvedVarInfo **rPtr)
+{
+    if (*name == 'T') {
+ 	MyResolvedVarInfo *resVarInfo = ckalloc(sizeof(MyResolvedVarInfo));
+
+ 	resVarInfo->vInfo.fetchProc = MyCompiledVarFetch;
+ 	resVarInfo->vInfo.deleteProc = MyCompiledVarFree;
+ 	resVarInfo->var = NULL;
+ 	resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
+ 	Tcl_IncrRefCount(resVarInfo->nameObj);
+ 	*rPtr = (Tcl_ResolvedVarInfo *) resVarInfo;
+ 	return TCL_OK;
+    }
+    return TCL_CONTINUE;
+}
+
+static int
+TestInterpResolversCmd(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    int objc,
+    Tcl_Obj *const objv[])
+{
+    const char *option;
+
+    if (objc != 2) {
+        Tcl_WrongNumArgs(interp, 1, objv, "up|down");
+ 	return TCL_ERROR;
+    }
+    option = TclGetString(objv[1]);
+    if (*option == 'u' && strcmp(option, "up") == 0) {
+        Tcl_AddInterpResolvers(interp, "interpResolver", InterpCmdResolver,
+                InterpVarResolver, InterpCompiledVarResolver);
+    } else if (*option == 'd' && strcmp(option, "down") == 0) {
+        if (Tcl_RemoveInterpResolvers(interp, "interpResolver") == 0) {
+            Tcl_AppendResult(interp, "could not remove the resolver scheme",
+                    NULL);
+            return TCL_ERROR;
+        }
+    } else {
+ 	Tcl_AppendResult(interp, "bad option \"", option,
+                "\": must be 'up' or 'down'", NULL);
+ 	return TCL_ERROR;
+    }
+    return TCL_OK;
+}
+
 /*
  * Local Variables:
  * mode: c
-- 
cgit v0.12


From c340a3859f1dfc7b1e77c4d0db35a94d3463f60d Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 15 Oct 2011 16:48:16 +0000
Subject: And the failing test file too...

---
 tests/resolver.test | 200 ++++++++++++++++++++++++++++++++++++++++++++++++++++
 1 file changed, 200 insertions(+)
 create mode 100644 tests/resolver.test

diff --git a/tests/resolver.test b/tests/resolver.test
new file mode 100644
index 0000000..bb9f59d
--- /dev/null
+++ b/tests/resolver.test
@@ -0,0 +1,200 @@
+# This test collection covers some unwanted interactions between command
+# literal sharing and the use of command resolvers (per-interp) which cause
+# command literals to be re-used with their command references being invalid
+# in the reusing context.  Sourcing this file into Tcl runs the tests and
+# generates output for errors.  No output means no errors were found.
+#
+# Copyright (c) 2011 Gustaf Neumann <gustaf.neumann@wu.ac.at>
+# Copyright (c) 2011 Stefan Sobernig <stefan.sobernig@wu.ac.at>
+#
+# See the file "license.terms" for information on usage and redistribution of
+# this file, and for a DISCLAIMER OF ALL WARRANTIES.
+
+package require tcltest 2
+if {"::tcltest" in [namespace children]} {
+    namespace import -force ::tcltest::*
+}
+
+testConstraint testinterpresolver [llength [info commands testinterpresolver]]
+
+test resolver-1.1 {cmdNameObj sharing vs. cmd resolver: namespace import} -setup {
+    testinterpresolver up
+    namespace eval ::ns1 {
+	proc z {} { return Z }
+	namespace export z
+    }
+    proc ::y {} { return Y }
+    proc ::x {} {
+	z
+    }
+} -constraints testinterpresolver -body {
+    # 1) Have the proc body compiled: During compilation or, alternatively,
+    # the first evaluation of the compiled body, the InterpCmdResolver (see
+    # tclTest.c) maps the cmd token "z" to "::y"; this mapping is saved in the
+    # resulting CmdName Tcl_Obj with the print string "z". The CmdName Tcl_Obj
+    # is turned into a command literal shared for a given (here: the global)
+    # namespace.
+    set r0 [x];			# --> The result of [x] is "Y"
+    # 2) After having requested cmd resolution above, we can now use the
+    # globally shared CmdName Tcl_Obj "z", now bound to cmd ::y. This is
+    # certainly questionable, but defensible
+    set r1 [z];			# --> The result of [z] is "Y"
+    # 3) We import from the namespace ns1 another z. [namespace import] takes
+    # care "shadowed" cmd references, however, till now cmd literals have not
+    # been touched. This is, however, necessary since the BC compiler (used in
+    # the [namespace eval]) seems to be eager to reuse CmdName Tcl_Objs as cmd
+    # literals for a given NS scope. We expect, that r2 is "Z", the result of
+    # the namespace imported cmd.
+    namespace eval :: {
+	namespace import ::ns1::z
+	set r2 [z]
+    }
+    list $r0 $r1 $::r2
+} -cleanup {
+    testinterpresolver down
+    rename ::x ""
+    rename ::y ""
+    namespace delete ::ns1
+} -result {Y Y Z}
+test resolver-1.2 {cmdNameObj sharing vs. cmd resolver: proc creation} -setup {
+    testinterpresolver up
+    proc ::y {} { return Y }
+    proc ::x {} {
+	z
+    }
+} -constraints testinterpresolver -body {
+    set r0 [x]
+    set r1 [z]
+    proc ::foo {} {
+	proc ::z {} { return Z }
+	return [z]
+    }
+    list $r0 $r1 [::foo]
+} -cleanup {
+    testinterpresolver down
+    rename ::x ""
+    rename ::y ""
+    rename ::foo ""
+    rename ::z ""
+} -result {Y Y Z}
+test resolver-1.3 {cmdNameObj sharing vs. cmd resolver: rename} -setup {
+    testinterpresolver up
+    proc ::Z {} { return Z }
+    proc ::y {} { return Y }
+    proc ::x {} {
+	z
+    }
+} -constraints testinterpresolver -body {
+    set r0 [x]
+    set r1 [z]
+    namespace eval :: {
+	rename ::Z ::z
+	set r2 [z]
+    }
+    list $r0 $r1 $r2
+} -cleanup {
+    testinterpresolver down
+    rename ::x ""
+    rename ::y ""
+    rename ::z ""
+} -result {Y Y Z}
+test resolver-1.4 {cmdNameObj sharing vs. cmd resolver: interp expose} -setup {
+    testinterpresolver up
+    proc ::Z {} { return Z }
+    interp hide {} Z
+    proc ::y {} { return Y }
+    proc ::x {} {
+	z
+    }
+} -constraints testinterpresolver -body {
+    set r0 [x]
+    set r1 [z]
+    interp expose {} Z z
+    namespace eval :: {
+	set r2 [z]
+    }
+    list $r0 $r1 $r2
+} -cleanup {
+    testinterpresolver down
+    rename ::x ""
+    rename ::y ""
+    rename ::z ""
+} -result {Y Y Z}
+test resolver-1.5 {cmdNameObj sharing vs. cmd resolver: other than global NS} -setup {
+    testinterpresolver up
+    namespace eval ::ns1 {
+	proc z {} { return Z }
+	namespace export z
+    }
+    proc ::y {} { return Y }
+    namespace eval ::ns2 {
+	proc x {} {
+	    z
+	}
+    }
+} -constraints testinterpresolver -body {
+    set r0 [namespace eval ::ns2 {x}]
+    set r1 [namespace eval ::ns2 {z}]
+    namespace eval ::ns2 {
+	namespace import ::ns1::z
+	set r2 [z]
+    }
+    list $r0 $r1 $r2
+} -cleanup {
+    testinterpresolver down
+    namespace delete ::ns2
+    namespace delete ::ns1
+} -result {Y Y Z}
+test resolver-1.6 {cmdNameObj sharing vs. cmd resolver: interp alias} -setup {
+    testinterpresolver up
+    proc ::Z {} { return Z }
+    proc ::y {} { return Y }
+    proc ::x {} {
+	z
+    }
+} -constraints testinterpresolver -body {
+    set r0 [x]
+    set r1 [z]
+    namespace eval :: {
+	interp alias {} ::z {} ::Z
+	set r2 [z]
+    }
+    list $r0 $r1 $r2
+} -cleanup {
+    testinterpresolver down
+    rename ::x ""
+    rename ::y ""
+    rename ::Z ""
+} -result {Y Y Z}
+
+test resolver-2.1 {compiled var resolver: Bug #3383616} -setup {
+    testinterpresolver up
+    # The compiled var resolver fetches just variables starting with a capital
+    # "T" and stores some test information in the resolver-specific resolver
+    # var info.
+    proc ::x {} {
+	set T1 100
+	return $T1
+    }
+} -constraints testinterpresolver -body {
+    # Call "x" the first time, causing a byte code compilation of the body.
+    # During the compilation the compiled var resolver, the resolve-specific
+    # var info is allocated, during the execution of the body, the variable is
+    # fetched and cached.
+    x;
+    # During later calls, the cached variable is reused.
+    x
+    # When the proc is freed, the resolver-specific resolver var info is
+    # freed. This did not happen before fix #3383616.
+    rename ::x ""
+} -cleanup {
+    testinterpresolver down
+} -result {}
+
+cleanupTests
+return
+
+# Local Variables:
+# mode: tcl
+# fill-column: 78
+# End:
-- 
cgit v0.12


From ab5335a4c951b478bbedd4f5561b8a314da5b074 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Tue, 18 Oct 2011 13:08:55 +0000
Subject: Don't cache the system timezone when it was derived from TCL_TZ or
 TZ.

---
 ChangeLog         |  7 +++++++
 library/clock.tcl | 27 ++++++++++++++++-----------
 tests/clock.test  | 33 +++++++++++++++++++++++++++++++++
 3 files changed, 56 insertions(+), 11 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index d219048..5cf8570 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-10-18  Reinhard Max  <max@suse.de>
+
+	* library/clock.tcl (::tcl::clock::GetSystemTimeZone): Cache the
+	time zone only if it was detected by one of the expensive
+	methods. Otherwise after unsetting TCL_TZ or TZ the previous value
+	will still be used.
+
 2011-10-15  Venkat Iyer <venkat@comit.com>
 	* library/tzdata/America/Sitka : Update to Olson's tzdata2011l
 	* library/tzdata/Pacific/Fiji
diff --git a/library/clock.tcl b/library/clock.tcl
index b6ff359..2a4c7bd 100644
--- a/library/clock.tcl
+++ b/library/clock.tcl
@@ -3012,18 +3012,23 @@ proc ::tcl::clock::GetSystemTimeZone {} {
 	set timezone $result
     } elseif {[set result [getenv TZ]] ne {}} {
 	set timezone $result
-    } elseif { [info exists CachedSystemTimeZone] } {
-	set timezone $CachedSystemTimeZone
-    } elseif { $::tcl_platform(platform) eq {windows} } {
-	set timezone [GuessWindowsTimeZone]
-    } elseif { [file exists /etc/localtime]
-	       && ![catch {ReadZoneinfoFile \
-			       Tcl/Localtime /etc/localtime}] } {
-	set timezone :Tcl/Localtime
-    } else {
-	set timezone :localtime
     }
-    set CachedSystemTimeZone $timezone
+    if {![info exists timezone]} {
+        # Cache the time zone only if it was detected by one of the
+        # expensive methods.
+        if { [info exists CachedSystemTimeZone] } {
+            set timezone $CachedSystemTimeZone
+        } elseif { $::tcl_platform(platform) eq {windows} } {
+            set timezone [GuessWindowsTimeZone]
+        } elseif { [file exists /etc/localtime]
+                   && ![catch {ReadZoneinfoFile \
+                                   Tcl/Localtime /etc/localtime}] } {
+            set timezone :Tcl/Localtime
+        } else {
+            set timezone :localtime
+        }
+	set CachedSystemTimeZone $timezone
+    }
     if { ![dict exists $TimeZoneBad $timezone] } {
 	dict set TimeZoneBad $timezone [catch {SetupTimeZone $timezone}]
     }
diff --git a/tests/clock.test b/tests/clock.test
index 8c31f83..bda5e76 100644
--- a/tests/clock.test
+++ b/tests/clock.test
@@ -35895,6 +35895,39 @@ test clock-38.1 {regression - convertUTCToLocalViaC - east of Greenwich} \
     } \
     -result {01:00:00}
 
+test clock-38.2 {make sure TZ is not cached after unset} \
+    -setup {
+	if { [info exists env(TZ)] } {
+	    set oldTZ $env(TZ)
+            unset env(TZ)
+	}
+	if { [info exists env(TCL_TZ)] } {
+	    set oldTCLTZ $env(TCL_TZ)
+            unset env(TCL_TZ)
+	}
+    } \
+    -body {
+        set t1 [clock format 0]
+        # a time zone that is unlikely to anywhere
+        set env(TZ) "+04:20"
+        set t2 [clock format 0]
+        unset env(TZ)
+        set t3 [clock format 0]
+        expr {$t1 eq $t3 && $t1 ne $t2}
+    } \
+    -cleanup {
+        if { [info exists oldTZ] } {
+            set env(TZ) $oldTZ
+            unset oldTZ
+        }
+        if { [info exists oldTclTZ] } {
+            set env(TCL_TZ) $oldTclTZ
+            unset oldTclTZ
+        }
+    } \
+    -result 1
+        
+
 test clock-39.1 {regression - synonym timezones} {
     clock format 0 -format {%H:%M:%S} -timezone :US/Eastern
 } {19:00:00}
-- 
cgit v0.12


From af3c0b7aa062161e708224346b62b7e8d6fec876 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 19 Oct 2011 20:21:29 +0000
Subject: Stop warnings and segfault.

---
 generic/tclTest.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index 299ba0e..af467f0 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -7149,7 +7149,7 @@ InterpCmdResolver(
         varFramePtr->procPtr : NULL;
     Namespace *ns2NsPtr;
 
-    ns2NsPtr = Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+    ns2NsPtr = (Namespace *)Tcl_FindNamespace(interp, "::ns2", NULL, 0);
 
     if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
             || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
@@ -7256,7 +7256,7 @@ MyCompiledVarFetch(
      * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree();
      */
 
-    VarHashRefCount(var);
+    VarHashRefCount(var) ++;
     return var;
 }
 
-- 
cgit v0.12


From 87f901722efaedd3a6c7b91b25f0d8f90e078649 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 20 Oct 2011 13:50:43 +0000
Subject: Tidying up.

---
 generic/tclTest.c | 76 +++++++++++++++++++++++++++++++------------------------
 1 file changed, 43 insertions(+), 33 deletions(-)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index af467f0..4027816 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -7134,6 +7134,10 @@ TestparseargsCmd(
     return TCL_OK;
 }
 
+/**
+ * Test harness for command and variable resolvers.
+ */
+
 static int
 InterpCmdResolver(
     Tcl_Interp *interp,
@@ -7142,24 +7146,23 @@ InterpCmdResolver(
     int flags,
     Tcl_Command *rPtr)
 {
-    Tcl_Command sourceCmdPtr;
     Interp *iPtr = (Interp *) interp;
     CallFrame *varFramePtr = iPtr->varFramePtr;
     Proc *procPtr = (varFramePtr->isProcCallFrame & FRAME_IS_PROC) ?
-        varFramePtr->procPtr : NULL;
-    Namespace *ns2NsPtr;
-
-    ns2NsPtr = (Namespace *)Tcl_FindNamespace(interp, "::ns2", NULL, 0);
+            varFramePtr->procPtr : NULL;
+    Namespace *ns2NsPtr = (Namespace *)
+            Tcl_FindNamespace(interp, "::ns2", NULL, 0);
 
     if (procPtr && (procPtr->cmdPtr->nsPtr == iPtr->globalNsPtr
             || (ns2NsPtr && procPtr->cmdPtr->nsPtr == ns2NsPtr))) {
         const char *callingCmdName =
                 Tcl_GetCommandName(interp, (Tcl_Command) procPtr->cmdPtr);
 
-        if ((*callingCmdName == 'x') && (*(callingCmdName + 1) == '\0')
-                && (*name == 'z') && (*(name + 1) == '\0')) {
-            sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
+        if ((callingCmdName[0] == 'x') && (callingCmdName[1] == '\0')
+                && (name[0] == 'z') && (name[1] == '\0')) {
+            Tcl_Command sourceCmdPtr = Tcl_FindCommand(interp, "y", NULL,
                     TCL_GLOBAL_ONLY);
+
             if (sourceCmdPtr != NULL) {
                 *rPtr = sourceCmdPtr;
                 return TCL_OK;
@@ -7177,6 +7180,10 @@ InterpVarResolver(
     int flags,
     Tcl_Var *rPtr)
 {
+    /*
+     * Don't resolve the variable; use standard rules.
+     */
+
     return TCL_CONTINUE;
 }
 
@@ -7186,12 +7193,12 @@ typedef struct MyResolvedVarInfo {
     Tcl_Obj *nameObj;
 } MyResolvedVarInfo;
 
-static void
+static inline void
 HashVarFree(
     Tcl_Var var)
 {
     if (VarHashRefCount(var) < 2) {
-        ckfree((char *) var);
+        ckfree(var);
     } else {
         VarHashRefCount(var)--;
     }
@@ -7207,7 +7214,7 @@ MyCompiledVarFree(
     if (resVarInfo->var) {
         HashVarFree(resVarInfo->var);
     }
-    ckfree((char *)vInfoPtr);
+    ckfree(vInfoPtr);
 }
 
 #define TclVarHashGetValue(hPtr) \
@@ -7220,20 +7227,19 @@ MyCompiledVarFetch(
 {
     MyResolvedVarInfo *resVarInfo = (MyResolvedVarInfo *) vinfoPtr;
     Tcl_Var var = resVarInfo->var;
-    Namespace *nsPtr;
     int isNewVar;
     Interp *iPtr = (Interp *) interp;
     Tcl_HashEntry *hPtr;
 
-    if (var && !(((Var *)var)->flags & VAR_DEAD_HASH)) {
-        /*
-         * The cached variable is valid, return it.
-         */
+    if (var != NULL) {
+        if (!(((Var *) var)->flags & VAR_DEAD_HASH)) {
+            /*
+             * The cached variable is valid, return it.
+             */
 
-        return var;
-    }
+            return var;
+        }
 
-    if (var) {
         /*
          * The variable is not valid anymore. Clean it up.
          */
@@ -7241,8 +7247,7 @@ MyCompiledVarFetch(
         HashVarFree(var);
     }
 
-    nsPtr = iPtr->globalNsPtr;
-    hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &nsPtr->varTable,
+    hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) &iPtr->globalNsPtr->varTable,
             (char *) resVarInfo->nameObj, &isNewVar);
     if (hPtr) {
         var = (Tcl_Var) TclVarHashGetValue(hPtr);
@@ -7256,7 +7261,7 @@ MyCompiledVarFetch(
      * Tcl's FreeVarEntry(); for cleanup, we provide our own HashVarFree();
      */
 
-    VarHashRefCount(var) ++;
+    VarHashRefCount(var)++;
     return var;
 }
 
@@ -7276,7 +7281,7 @@ InterpCompiledVarResolver(
  	resVarInfo->var = NULL;
  	resVarInfo->nameObj = Tcl_NewStringObj(name, -1);
  	Tcl_IncrRefCount(resVarInfo->nameObj);
- 	*rPtr = (Tcl_ResolvedVarInfo *) resVarInfo;
+ 	*rPtr = &resVarInfo->vInfo;
  	return TCL_OK;
     }
     return TCL_CONTINUE;
@@ -7289,26 +7294,31 @@ TestInterpResolversCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    const char *option;
+    static const char *const table[] = {
+        "down", "up", NULL
+    };
+    int idx;
+#define RESOLVER_KEY "testInterpResolver"
 
     if (objc != 2) {
         Tcl_WrongNumArgs(interp, 1, objv, "up|down");
  	return TCL_ERROR;
     }
-    option = TclGetString(objv[1]);
-    if (*option == 'u' && strcmp(option, "up") == 0) {
-        Tcl_AddInterpResolvers(interp, "interpResolver", InterpCmdResolver,
+    if (Tcl_GetIndexFromObj(interp, objv[1], table, "operation", TCL_EXACT,
+            &idx) != TCL_OK) {
+        return TCL_ERROR;
+    }
+    switch (idx) {
+    case 1: /* up */
+        Tcl_AddInterpResolvers(interp, RESOLVER_KEY, InterpCmdResolver,
                 InterpVarResolver, InterpCompiledVarResolver);
-    } else if (*option == 'd' && strcmp(option, "down") == 0) {
-        if (Tcl_RemoveInterpResolvers(interp, "interpResolver") == 0) {
+        break;
+    case 0: /*down*/
+        if (!Tcl_RemoveInterpResolvers(interp, RESOLVER_KEY)) {
             Tcl_AppendResult(interp, "could not remove the resolver scheme",
                     NULL);
             return TCL_ERROR;
         }
-    } else {
- 	Tcl_AppendResult(interp, "bad option \"", option,
-                "\": must be 'up' or 'down'", NULL);
- 	return TCL_ERROR;
     }
     return TCL_OK;
 }
-- 
cgit v0.12


From 37aa42f79dede55e98bf0684b0163c11dfa27f81 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 20 Oct 2011 14:24:53 +0000
Subject: ChangeLog entry.

---
 ChangeLog         | 10 ++++++++++
 generic/tclTest.c |  6 +++---
 2 files changed, 13 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index d219048..a36534d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,13 @@
+2011-10-20  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]:
+	Additional code for handling the invalidation of literals.
+	* generic/tclBasic.c (Tcl_CreateObjCommand, Tcl_CreateCommand)
+	(TclRenameCommand, Tcl_ExposeCommand): The four additional places that
+	need extra care when dealing with literals.
+	* generic/tclTest.c (TestInterpResolverCmd): Additional test machinery
+	for interpreter resolvers.
+
 2011-10-15  Venkat Iyer <venkat@comit.com>
 	* library/tzdata/America/Sitka : Update to Olson's tzdata2011l
 	* library/tzdata/Pacific/Fiji
diff --git a/generic/tclTest.c b/generic/tclTest.c
index 4027816..86941c6 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -411,7 +411,7 @@ static int		TestHashSystemHashCmd(ClientData clientData,
 static int		TestNRELevels(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
-static int		TestInterpResolversCmd(ClientData clientData,
+static int		TestInterpResolverCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const objv[]);
 
@@ -678,7 +678,7 @@ Tcltest_Init(
 
     Tcl_CreateObjCommand(interp, "testnrelevels", TestNRELevels,
 	    NULL, NULL);
-    Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolversCmd,
+    Tcl_CreateObjCommand(interp, "testinterpresolver", TestInterpResolverCmd,
 	    NULL, NULL);
 
     if (TclObjTest_Init(interp) != TCL_OK) {
@@ -7288,7 +7288,7 @@ InterpCompiledVarResolver(
 }
 
 static int
-TestInterpResolversCmd(
+TestInterpResolverCmd(
     ClientData clientData,
     Tcl_Interp *interp,
     int objc,
-- 
cgit v0.12


From 1468085ceb1552c3ff05b0d09c1f81f9b251c33f Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 20 Oct 2011 15:56:52 +0000
Subject: Update changes toward 8.6b3 release. Bump to http 2.8.3.

---
 ChangeLog                 |  9 +++++++++
 changes                   | 35 +++++++++++++++++++++++++++++++++++
 library/http/http.tcl     |  2 +-
 library/http/pkgIndex.tcl |  2 +-
 unix/Makefile.in          |  4 ++--
 win/Makefile.in           |  4 ++--
 6 files changed, 50 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index ccecfcd..6729f15 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2011-10-20  Don Porter  <dgp@users.sourceforge.net>
+
+	* library/http/http.tcl:        Bump to version 2.8.3
+	* library/http/pkgIndex.tcl:
+	* unix/Makefile.in:
+	* win/Makefile.in:
+
+	* changes:	Updates toward 8.6b3 release.
+
 2011-10-20  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclLiteral.c (TclInvalidateCmdLiteral): [Bug 3418547]:
diff --git a/changes b/changes
index 88ea3e6..7a928e0 100644
--- a/changes
+++ b/changes
@@ -7954,3 +7954,38 @@ memory with buffer backup (ferrieux)
 Many more Tcl built-in command errors now set an -errorcode.
 
 --- Released 8.6b2, August 8, 2011 --- See ChangeLog for details ---
+
+2011-07-02 (bug fix)[3349507] correct double(1[string repeat 0 23]) (kenny)
+
+2011-07-19 (bug fix)[3371644] Tcl_ConvertElement() segfault (sader, ferrieux)
+
+2011-07-21 (bug fix)[3372130] hypot(.) segfault (nijtmans)
+
+2011-08-12 (bug fix)[3389764] memleaks due to reference cycles in dup'd paths
+
+2011-08-15 (bug fix)[3390272] leak of [info script] value (porter)
+
+2011-08-17 (bug fix)[3393150] bignum leaks in Tcl_Get*() routines (porter)
+
+2011-08-18 (bug fix)[3393714] [string toupper] overflow (nijtmans)
+
+2011-08-30 (bug fix)[3398794] panic in interp limit setting (gavlian,fellows)
+
+2011-09-08 (bug fix)[3401704] revised expr parser to permit function names
+like "nano()" instead of parsing as "nan o()" with missing op (duquette,porter)
+	*** POTENTIAL INCOMPATIBILITY ***
+
+2011-09-13 (bug fix)[3390638] solaris studio cc workaround (kechel,porter)
+
+2011-09-13 (bug fix)[3405652] DTrace workaround (michelson,porter)
+
+2011-09-16 (bug fix)[3391977] -headers overrides -type (ziegenhagen,fellows)
+=> http 2.7.7
+
+2011-09-16 (bug fix)[3400658] wrong num args msg with TclOO (rsooltan,fellows)
+
+2011-10-11 (bug fix)[2935503] [file stat] returns bad mode (nadkarni,nijtmans)
+
+2011-10-15 tzdata updated to Olson's tzdata2011l (iyer)
+
+--- Released 8.6b3, November 20, 2011 --- See ChangeLog for details ---
diff --git a/library/http/http.tcl b/library/http/http.tcl
index 69817b8..12820af 100644
--- a/library/http/http.tcl
+++ b/library/http/http.tcl
@@ -11,7 +11,7 @@
 package require Tcl 8.6
 # Keep this in sync with pkgIndex.tcl and with the install directories in
 # Makefiles
-package provide http 2.8.2
+package provide http 2.8.3
 
 namespace eval http {
     # Allow resourcing to not clobber existing data
diff --git a/library/http/pkgIndex.tcl b/library/http/pkgIndex.tcl
index 82b2e0b..d89b14b 100644
--- a/library/http/pkgIndex.tcl
+++ b/library/http/pkgIndex.tcl
@@ -1,2 +1,2 @@
 if {![package vsatisfies [package provide Tcl] 8.6]} {return}
-package ifneeded http 2.8.2 [list tclPkgSetup $dir http 2.8.2 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
+package ifneeded http 2.8.3 [list tclPkgSetup $dir http 2.8.3 {{http.tcl source {::http::config ::http::formatQuery ::http::geturl ::http::reset ::http::wait ::http::register ::http::unregister ::http::mapReply}}}]
diff --git a/unix/Makefile.in b/unix/Makefile.in
index a2ade1d..77e87bc 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -829,8 +829,8 @@ install-libraries: libraries
 	    do \
 	    $(INSTALL_DATA) $$i "$(SCRIPT_INSTALL_DIR)"/http1.0; \
 	    done;
-	@echo "Installing package http 2.8.2 as a Tcl Module";
-	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.2.tm;
+	@echo "Installing package http 2.8.3 as a Tcl Module";
+	@$(INSTALL_DATA) $(TOP_DIR)/library/http/http.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.6/http-2.8.3.tm;
 	@echo "Installing package opt0.4 files to $(SCRIPT_INSTALL_DIR)/opt0.4/";
 	@for i in $(TOP_DIR)/library/opt/*.tcl ; \
 	    do \
diff --git a/win/Makefile.in b/win/Makefile.in
index 8a9359b..b2ce7c4 100644
--- a/win/Makefile.in
+++ b/win/Makefile.in
@@ -664,8 +664,8 @@ install-libraries: libraries install-tzdata install-msgs
 	    do \
 	    $(COPY) "$$j" "$(SCRIPT_INSTALL_DIR)/http1.0"; \
 	    done;
-	@echo "Installing package http 2.8.2 as a Tcl Module";
-	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.2.tm;
+	@echo "Installing package http 2.8.3 as a Tcl Module";
+	@$(COPY) $(ROOT_DIR)/library/http/http.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.6/http-2.8.3.tm;
 	@echo "Installing library opt0.4 directory";
 	@for j in $(ROOT_DIR)/library/opt/*.tcl; \
 	    do \
-- 
cgit v0.12


From 7f9fe76ea2ebff9ae991765d371d1886fc7cd88f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 21 Oct 2011 09:39:58 +0000
Subject: MINOR: Add emacs style info to end of C files.

---
 unix/tclUnixTest.c | 19 ++++++++++++++-----
 unix/tclXtTest.c   |  9 +++++++++
 win/tclWinError.c  |  9 +++++++++
 3 files changed, 32 insertions(+), 5 deletions(-)

diff --git a/unix/tclUnixTest.c b/unix/tclUnixTest.c
index 0d79e47..46fc972 100644
--- a/unix/tclUnixTest.c
+++ b/unix/tclUnixTest.c
@@ -6,8 +6,8 @@
  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
  * Copyright (c) 1998 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.
  */
 
 #ifndef USE_TCL_STUBS
@@ -38,8 +38,8 @@
  */
 
 typedef struct Pipe {
-    TclFile readFile;		/* File handle for reading from the pipe.
-				 * NULL means pipe doesn't exist yet. */
+    TclFile readFile;		/* File handle for reading from the pipe. NULL
+				 * means pipe doesn't exist yet. */
     TclFile writeFile;		/* File handle for writing from the pipe. */
     int readCount;		/* Number of times the file handler for this
 				 * file has triggered and the file was
@@ -699,7 +699,7 @@ TestchmodCmd(
     char *rest;
 
     if (argc < 2) {
-	usage:
+    usage:
 	Tcl_AppendResult(interp, "wrong # args: should be \"", argv[0],
 		" mode file ?file ...?", NULL);
 	return TCL_ERROR;
@@ -727,3 +727,12 @@ TestchmodCmd(
     }
     return TCL_OK;
 }
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
diff --git a/unix/tclXtTest.c b/unix/tclXtTest.c
index 93bcc81..fcb0773 100644
--- a/unix/tclXtTest.c
+++ b/unix/tclXtTest.c
@@ -124,3 +124,12 @@ TesteventloopCmd(
     }
     return TCL_OK;
 }
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
diff --git a/win/tclWinError.c b/win/tclWinError.c
index ca1b0e8..4fee02b 100644
--- a/win/tclWinError.c
+++ b/win/tclWinError.c
@@ -387,3 +387,12 @@ TclWinConvertWSAError(
 	Tcl_SetErrno(EINVAL);
     }
 }
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
-- 
cgit v0.12


From 783d7dd4b08ca44c8fe4cce9cdc039e2199709e2 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 1 Nov 2011 18:53:11 +0000
Subject: Work in progress converting tests from [testthread cancel] to
 [thread::cancel]

---
 tests/thread.test    | 613 +++++++++++++++++++++++----------------------------
 tests/unixNotfy.test |   5 -
 2 files changed, 270 insertions(+), 348 deletions(-)

diff --git a/tests/thread.test b/tests/thread.test
index 74f7043..dbfaec3 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -12,14 +12,14 @@
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
 if {[lsearch [namespace children] ::tcltest] == -1} {
-    package require tcltest
+    package require tcltest 2.2
     namespace import -force ::tcltest::*
 }
 
 # Some tests require the testthread command
 
 testConstraint testthread [expr {[info commands testthread] != {}}]
-testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
+testConstraint thread [expr {0 == [catch {package require Thread 2.7}]}]
 
 testConstraint notValgrind [expr {![testConstraint valgrind]}]
 
@@ -59,12 +59,6 @@ if {[testConstraint testthread]} {
     }
 }
 
-test thread-1.1 {Tcl_ThreadObjCmd: no args} {testthread} {
-    list [catch {testthread} msg] $msg
-} {1 {wrong # args: should be "testthread option ?arg ...?"}}
-test thread-1.2 {Tcl_ThreadObjCmd: bad option} {testthread} {
-    list [catch {testthread foo} msg] $msg
-} {1 {bad option "foo": must be cancel, create, event, exit, id, join, names, send, wait, or errorproc}}
 test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
     llength [thread::names]
 } 1
@@ -93,53 +87,18 @@ test thread-1.6 {Tcl_ThreadObjCmd: thread exit} {thread} {
     after 10
     llength [thread::names]
 } {1}
-test thread-1.7 {Tcl_ThreadObjCmd: thread id args} {testthread} {
-    set x [catch {testthread id x} msg]
-    list $x $msg
-} {1 {wrong # args: should be "testthread id"}}
-test thread-1.8 {Tcl_ThreadObjCmd: thread id} {testthread} {
-    string compare [testthread id] $mainThread
-} {0}
-test thread-1.9 {Tcl_ThreadObjCmd: thread names args} {testthread} {
-    set x [catch {testthread names x} msg]
-    list $x $msg
-} {1 {wrong # args: should be "testthread names"}}
-test thread-1.10 {Tcl_ThreadObjCmd: thread id} {testthread} {
-    string compare [testthread names] $mainThread
-} {0}
-test thread-1.11 {Tcl_ThreadObjCmd: send args} {testthread} {
-    set x [catch {testthread send} msg]
-    list $x $msg
-} {1 {wrong # args: should be "testthread send ?-async? id script"}}
-test thread-1.12 {Tcl_ThreadObjCmd: send nonint} {testthread} {
-    set x [catch {testthread send abc command} msg]
-    list $x $msg
-} {1 {expected integer but got "abc"}}
 test thread-1.13 {Tcl_ThreadObjCmd: send args} {thread} {
     set serverthread [thread::create -preserved]
     set five [thread::send $serverthread {set x 5}]
     thread::release $serverthread
     set five
 } 5
-test thread-1.14 {Tcl_ThreadObjCmd: send bad id} {testthread} {
-    set tid [expr $mainThread + 10]
-    set x [catch {testthread send $tid {set x 5}} msg]
-    list $x $msg
-} {1 {invalid thread id}}
 test thread-1.15 {Tcl_ThreadObjCmd: wait} {thread} {
     set serverthread [thread::create -preserved {set z 5 ; thread::wait}]
     set five [thread::send $serverthread {set z}]
     thread::release $serverthread
     set five
 } 5
-test thread-1.16 {Tcl_ThreadObjCmd: errorproc args} {testthread} {
-    set x [catch {testthread errorproc foo bar} msg]
-    list $x $msg
-} {1 {wrong # args: should be "testthread errorproc proc"}}
-test thread-1.17 {Tcl_ThreadObjCmd: errorproc change} {testthread} {
-    testthread errorproc foo
-    testthread errorproc ThreadError
-} {}
 
 # The tests above also cover:
 # TclCreateThread, except when pthread_create fails
@@ -257,29 +216,16 @@ test thread-6.1 {freeing very large object trees in a thread} thread {
 } 0
 
 # TIP #285: Script cancellation support
-test thread-7.1 {cancel: args} {testthread} {
-    set x [catch {testthread cancel} msg]
-    list $x $msg
-} {1 {wrong # args: should be "testthread cancel ?-unwind? id ?result?"}}
-test thread-7.2 {cancel: nonint} {testthread} {
-    set x [catch {testthread cancel abc} msg]
-    list $x $msg
-} {1 {expected integer but got "abc"}}
-test thread-7.3 {cancel: bad id} {testthread} {
-    set tid [expr $mainThread + 10]
-    set x [catch {testthread cancel $tid} msg]
-    list $x $msg
-} {1 {invalid thread id}}
-test thread-7.4 {cancel: pure bytecode loop} {testthread} {
-    threadReap
+test thread-7.4 {cancel: pure bytecode loop} -constraints {thread} -setup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    while {1} {
@@ -287,30 +233,28 @@ test thread-7.4 {cancel: pure bytecode loop} {testthread} {
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval canceled}}
-test thread-7.5 {cancel: pure inside-command loop} {testthread} {
-    threadReap
+    vwait ::threadIdStarted
+    set res [thread::cancel $serverthread]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval canceled}}
+test thread-7.5 {cancel: pure inside-command loop} -constraints {thread} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    set while while
@@ -319,30 +263,28 @@ test thread-7.5 {cancel: pure inside-command loop} {testthread} {
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval canceled}}
-test thread-7.6 {cancel: pure bytecode loop -unwind} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval canceled}}
+test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    while {1} {
@@ -350,30 +292,28 @@ test thread-7.6 {cancel: pure bytecode loop -unwind} {testthread} {
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.7 {cancel: pure inside-command loop -unwind} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
-    	  proc foobar {} {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
+	proc foobar {} {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    set while while
@@ -382,30 +322,28 @@ test thread-7.7 {cancel: pure inside-command loop -unwind} {testthread} {
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.8 {cancel: pure bytecode loop custom result} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.8 {cancel: pure bytecode loop custom result} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    while {1} {
@@ -413,30 +351,30 @@ test thread-7.8 {cancel: pure bytecode loop custom result} {testthread} {
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread "the eval was canceled"]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {the eval was canceled}}
-test thread-7.9 {cancel: pure inside-command loop custom result} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel $serverthread "the eval was canceled"]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
-    	  proc foobar {} {
+} -result {{} 1 1 {the eval was canceled}}
+test thread-7.9 {cancel: pure inside-command loop custom result} -constraints {
+    thread
+} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
+	proc foobar {} {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    set while while
@@ -445,30 +383,30 @@ test thread-7.9 {cancel: pure inside-command loop custom result} {testthread} {
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread "the eval was canceled"]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {the eval was canceled}}
-test thread-7.10 {cancel: pure bytecode loop custom result -unwind} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel $serverthread "the eval was canceled"]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {the eval was canceled}}
+test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints {
+    thread
+} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    while {1} {
@@ -476,30 +414,30 @@ test thread-7.10 {cancel: pure bytecode loop custom result -unwind} {testthread}
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread "the eval was unwound"]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {the eval was unwound}}
-test thread-7.11 {cancel: pure inside-command loop custom result -unwind} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel -unwind $serverthread "the eval was unwound"]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
-    	  proc foobar {} {
+} -result {{} 1 1 {the eval was unwound}}
+test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -constraints {
+    thread
+} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
+	proc foobar {} {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    set while while
@@ -508,196 +446,183 @@ test thread-7.11 {cancel: pure inside-command loop custom result -unwind} {testt
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread "the eval was unwound"]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {the eval was unwound}}
-test thread-7.12 {cancel: after} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel -unwind $serverthread "the eval was unwound"]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {the eval was unwound}}
+test thread-7.12 {cancel: after} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	if {![info exists foo]} then {
 	    # signal the primary thread that we are ready
 	    # to be canceled now (we are running).
-	    testthread send [testthread id -main] \
-		    [list set ::threadIdStarted [testthread id]]
+	    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 	    set foo 1
 	}
 	after 30000
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval canceled}}
-test thread-7.13 {cancel: after -unwind} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval canceled}}
+test thread-7.13 {cancel: after -unwind} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	if {![info exists foo]} then {
 	    # signal the primary thread that we are ready
 	    # to be canceled now (we are running).
-	    testthread send [testthread id -main] \
-		    [list set ::threadIdStarted [testthread id]]
+	    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 	    set foo 1
 	}
 	after 30000
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.14 {cancel: vwait} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.14 {cancel: vwait} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID [thread::id]] {
 	if {![info exists foo]} then {
 	    # signal the primary thread that we are ready
 	    # to be canceled now (we are running).
-	    testthread send [testthread id -main] \
-		    [list set ::threadIdStarted [testthread id]]
+	    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 	    set foo 1
 	}
 	vwait forever
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval canceled}}
-test thread-7.15 {cancel: vwait -unwind} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval canceled}}
+test thread-7.15 {cancel: vwait -unwind} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	if {![info exists foo]} then {
 	    # signal the primary thread that we are ready
 	    # to be canceled now (we are running).
-	    testthread send [testthread id -main] \
-		    [list set ::threadIdStarted [testthread id]]
+	    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 	    set foo 1
 	}
 	vwait forever
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.16 {cancel: expr} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.16 {cancel: expr} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID [thread::id]] {
 	set i [interp create]
-	interp alias $i testthread {} testthread
+	$i eval "package require -exact Thread [package present Thread]"
 	$i eval {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    expr {[while {1} {incr x}]}
 	}
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval canceled}}
-test thread-7.17 {cancel: expr -unwind} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval canceled}}
+test thread-7.17 {cancel: expr -unwind} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	set i [interp create]
-	interp alias $i testthread {} testthread
+	$i eval "package require -exact Thread [package present Thread]"
 	$i eval {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    expr {[while {1} {incr x}]}
 	}
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.18 {cancel: expr bignum} {testthread} {
-    threadReap
+    vwait threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.18 {cancel: expr bignum} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	set i [interp create]
-	interp alias $i testthread {} testthread
+	$i eval "package require -exact Thread [package present Thread]"
 	$i eval {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    #
@@ -706,32 +631,33 @@ test thread-7.18 {cancel: expr bignum} {testthread} {
       #
 	    expr {2**99999}
 	}
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
+    vwait threadIdStarted
+    set res [thread::cancel $serverthread]
+    after 1000 {set ::threadId timeout}
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
 	      [expr {[info exists ::threadError] ? \
 		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 0 {}}
-test thread-7.19 {cancel: expr bignum -unwind} {testthread} {
-    threadReap
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 0 {}}
+test thread-7.19 {cancel: expr bignum -unwind} -constraints thread -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	set i [interp create]
-	interp alias $i testthread {} testthread
+	$i eval "package require -exact Thread [package present Thread]"
 	$i eval {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    #
@@ -740,20 +666,21 @@ test thread-7.19 {cancel: expr bignum -unwind} {testthread} {
       #
 	    expr {2**99999}
 	}
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
+    vwait threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    after 1000 {set ::threadId timeout}
+    vwait threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
 	      [expr {[info exists ::threadError] ? \
 		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 0 {}}
+} -cleanup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -result {{} 1 0 {}}
 test thread-7.20 {cancel: subst} {testthread} {
     threadReap
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
diff --git a/tests/unixNotfy.test b/tests/unixNotfy.test
index 2a17098..067d225 100644
--- a/tests/unixNotfy.test
+++ b/tests/unixNotfy.test
@@ -10,10 +10,6 @@
 # See the file "license.terms" for information on usage and redistribution
 # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
 
-# The tests should not be run if you have a notifier which is unable to
-# detect infinite vwaits, as the tests below will hang. The presence of
-# the "testthread" command indicates that this is the case.
-
 if {[lsearch [namespace children] ::tcltest] == -1} {
     package require tcltest 2
     namespace import -force ::tcltest::*
@@ -22,7 +18,6 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 # When run in a Tk shell, these tests hang.
 testConstraint noTk [expr {0 != [catch {package present Tk}]}]
 testConstraint thread [expr {0 == [catch {package require Thread 2.6}]}]
-testConstraint testthread [expr {[info commands testthread] != {}}]
 # Darwin always uses a threaded notifier
 testConstraint unthreaded [expr {
     (![info exist tcl_platform(threaded)] || !$tcl_platform(threaded))
-- 
cgit v0.12


From c0e38a0f1d5e32323e3654f682d3b339d3e54d54 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 3 Nov 2011 14:37:04 +0000
Subject: 	* unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid,
 TclpGetGrNam) 	(TclpGetGrGid): Use the elaborate memory management scheme
 outlined on 	http://www.opengroup.org/austin/docs/austin_328.txt to handle
 Tcl's 	use of standard reentrant versions of the passwd/group access 
 functions so that everything can work on all BSDs. Problem identified 	by
 Stuart Cassoff.

---
 ChangeLog            |   9 ++
 unix/tclUnixCompat.c | 258 ++++++++++++++++++++++++++++++++++++++++++---------
 2 files changed, 223 insertions(+), 44 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 6729f15..82e2fe0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2011-11-03  Donal K. Fellows  <dkf@users.sf.net>
+
+	* unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid, TclpGetGrNam)
+	(TclpGetGrGid): Use the elaborate memory management scheme outlined on
+	http://www.opengroup.org/austin/docs/austin_328.txt to handle Tcl's
+	use of standard reentrant versions of the passwd/group access
+	functions so that everything can work on all BSDs. Problem identified
+	by Stuart Cassoff.
+
 2011-10-20  Don Porter  <dgp@users.sourceforge.net>
 
 	* library/http/http.tcl:        Bump to version 2.8.3
diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c
index 0ad3822..456a552 100644
--- a/unix/tclUnixCompat.c
+++ b/unix/tclUnixCompat.c
@@ -13,8 +13,10 @@
 #include <errno.h>
 #include <string.h>
 
-/* See also: SC_BLOCKING_STYLE in unix/tcl.m4
+/*
+ * See also: SC_BLOCKING_STYLE in unix/tcl.m4
  */
+
 #ifdef	USE_FIONBIO
 #   ifdef HAVE_SYS_FILIO_H
 #	include	<sys/filio.h>	/* For FIONBIO. */
@@ -23,39 +25,6 @@
 #	include	<sys/ioctl.h>
 #   endif
 #endif	/* USE_FIONBIO */
-
-/*
- *---------------------------------------------------------------------------
- *
- * TclUnixSetBlockingMode --
- *
- *	Set the blocking mode of a file descriptor.
- *
- * Results:
- *
- *	0 on success, -1 (with errno set) on error.
- *
- *---------------------------------------------------------------------------
- */
-int
-TclUnixSetBlockingMode(
-    int fd,		/* File descriptor */
-    int mode)		/* TCL_MODE_BLOCKING or TCL_MODE_NONBLOCKING */
-{
-#ifndef USE_FIONBIO
-    int flags = fcntl(fd, F_GETFL);
-
-    if (mode == TCL_MODE_BLOCKING) {
-	flags &= ~O_NONBLOCK;
-    } else {
-	flags |= O_NONBLOCK;
-    }
-    return fcntl(fd, F_SETFL, flags);
-#else /* USE_FIONBIO */
-    int state = (mode == TCL_MODE_NONBLOCKING);
-    return ioctl(fd, FIONBIO, &state);
-#endif /* !USE_FIONBIO */
-}
 
 /*
  * Used to pad structures at size'd boundaries
@@ -82,10 +51,22 @@ TclUnixSetBlockingMode(
 
 typedef struct ThreadSpecificData {
     struct passwd pwd;
+#if defined(HAVE_GETPWNAM_R_5) || defined(HAVE_GETPWUID_R_5)
+#define NEED_PW_CLEANER 1
+    char *pbuf;
+    int pbuflen;
+#else
     char pbuf[2048];
+#endif
 
     struct group grp;
+#if defined(HAVE_GETGRNAM_R_5) || defined(HAVE_GETGRGID_R_5)
+#define NEED_GR_CLEANER 1
+    char *gbuf;
+    int gbuflen;
+#else
     char gbuf[2048];
+#endif
 
 #if !defined(HAVE_MTSAFE_GETHOSTBYNAME) || !defined(HAVE_MTSAFE_GETHOSTBYADDR)
     struct hostent hent;
@@ -127,11 +108,54 @@ static int		CopyPwd(struct passwd *tgtPtr, char *buf, int buflen);
 static int		CopyString(const char *src, char *buf, int buflen);
 
 #endif
+
+#ifdef NEED_PW_CLEANER
+static void		FreePwBuf(ClientData ignored);
+#endif
+#ifdef NEED_GR_CLEANER
+static void		FreeGrBuf(ClientData ignored);
+#endif
 #endif /* TCL_THREADS */
 
 /*
  *---------------------------------------------------------------------------
  *
+ * TclUnixSetBlockingMode --
+ *
+ *	Set the blocking mode of a file descriptor.
+ *
+ * Results:
+ *
+ *	0 on success, -1 (with errno set) on error.
+ *
+ *---------------------------------------------------------------------------
+ */
+
+int
+TclUnixSetBlockingMode(
+    int fd,			/* File descriptor */
+    int mode)			/* Either TCL_MODE_BLOCKING or
+				 * TCL_MODE_NONBLOCKING. */
+{
+#ifndef USE_FIONBIO
+    int flags = fcntl(fd, F_GETFL);
+
+    if (mode == TCL_MODE_BLOCKING) {
+	flags &= ~O_NONBLOCK;
+    } else {
+	flags |= O_NONBLOCK;
+    }
+    return fcntl(fd, F_SETFL, flags);
+#else /* USE_FIONBIO */
+    int state = (mode == TCL_MODE_NONBLOCKING);
+
+    return ioctl(fd, FIONBIO, &state);
+#endif /* !USE_FIONBIO */
+}
+
+/*
+ *---------------------------------------------------------------------------
+ *
  * TclpGetPwNam --
  *
  *      Thread-safe wrappers for getpwnam(). See "man getpwnam" for more
@@ -158,8 +182,33 @@ TclpGetPwNam(
 #if defined(HAVE_GETPWNAM_R_5)
     struct passwd *pwPtr = NULL;
 
-    return (getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf),
-		       &pwPtr) == 0 && pwPtr != NULL) ? &tsdPtr->pwd : NULL;
+    /*
+     * How to allocate a buffer of the right initial size. If you want the
+     * gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
+     * and weep.
+     */
+
+    if (tsdPtr->pbuf == NULL) {
+	tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
+	if (tsdPtr->pbuflen < 1) {
+	    tsdPtr->pbuflen = 1024;
+	}
+	tsdPtr->pbuf = ckalloc(tsdPtr->pbuflen);
+	Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
+    }
+    while (1) {
+	int e = getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen,
+		&pwPtr);
+
+	if (e == 0) {
+	    break;
+	} else if (e != ERANGE) {
+	    return NULL;
+	}
+	tsdPtr->pbuflen *= 2;
+	tsdPtr->pbuf = ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
+    }
+    return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
 
 #elif defined(HAVE_GETPWNAM_R_4)
     return getpwnam_r(name, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
@@ -214,8 +263,33 @@ TclpGetPwUid(
 #if defined(HAVE_GETPWUID_R_5)
     struct passwd *pwPtr = NULL;
 
-    return (getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf),
-		       &pwPtr) == 0 && pwPtr != NULL) ? &tsdPtr->pwd : NULL;
+    /*
+     * How to allocate a buffer of the right initial size. If you want the
+     * gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
+     * and weep.
+     */
+
+    if (tsdPtr->pbuf == NULL) {
+	tsdPtr->pbuflen = (int) sysconf(_SC_GETPW_R_SIZE_MAX);
+	if (tsdPtr->pbuflen < 1) {
+	    tsdPtr->pbuflen = 1024;
+	}
+	tsdPtr->pbuf = ckalloc(tsdPtr->pbuflen);
+	Tcl_CreateThreadExitHandler(FreePwBuf, NULL);
+    }
+    while (1) {
+	int e = getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, tsdPtr->pbuflen,
+		&pwPtr);
+
+	if (e == 0) {
+	    break;
+	} else if (e != ERANGE) {
+	    return NULL;
+	}
+	tsdPtr->pbuflen *= 2;
+	tsdPtr->pbuf = ckrealloc(tsdPtr->pbuf, tsdPtr->pbuflen);
+    }
+    return (pwPtr != NULL ? &tsdPtr->pwd : NULL);
 
 #elif defined(HAVE_GETPWUID_R_4)
     return getpwuid_r(uid, &tsdPtr->pwd, tsdPtr->pbuf, sizeof(tsdPtr->pbuf));
@@ -244,6 +318,29 @@ TclpGetPwUid(
 /*
  *---------------------------------------------------------------------------
  *
+ * FreePwBuf --
+ *
+ *	Helper that is used to dispose of space allocated and referenced from
+ *	the ThreadSpecificData for user entries. (Darn that baroque POSIX
+ *	reentrant interface.)
+ *
+ *---------------------------------------------------------------------------
+ */
+
+#ifdef NEED_PW_CLEANER
+static void
+FreePwBuf(
+    ClientData ignored)
+{
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+    ckfree(tsdPtr->pbuf);
+}
+#endif /* NEED_PW_CLEANER */
+
+/*
+ *---------------------------------------------------------------------------
+ *
  * TclpGetGrNam --
  *
  *      Thread-safe wrappers for getgrnam(). See "man getgrnam" for more
@@ -267,11 +364,36 @@ TclpGetGrNam(
 #else
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
-#if defined(HAVE_GETGRNAM_R_5)
+#ifdef HAVE_GETGRNAM_R_5
     struct group *grPtr = NULL;
 
-    return (getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf),
-		       &grPtr) == 0 && grPtr != NULL) ? &tsdPtr->grp : NULL;
+    /*
+     * How to allocate a buffer of the right initial size. If you want the
+     * gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
+     * and weep.
+     */
+
+    if (tsdPtr->gbuf == NULL) {
+	tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
+	if (tsdPtr->gbuflen < 1) {
+	    tsdPtr->gbuflen = 1024;
+	}
+	tsdPtr->gbuf = ckalloc(tsdPtr->gbuflen);
+	Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
+    }
+    while (1) {
+	int e = getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen,
+		&grPtr);
+
+	if (e == 0) {
+	    break;
+	} else if (e != ERANGE) {
+	    return NULL;
+	}
+	tsdPtr->gbuflen *= 2;
+	tsdPtr->gbuf = ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
+    }
+    return (grPtr != NULL ? &tsdPtr->grp : NULL);
 
 #elif defined(HAVE_GETGRNAM_R_4)
     return getgrnam_r(name, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
@@ -326,8 +448,33 @@ TclpGetGrGid(
 #if defined(HAVE_GETGRGID_R_5)
     struct group *grPtr = NULL;
 
-    return (getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf),
-		       &grPtr) == 0 && grPtr != NULL) ? &tsdPtr->grp : NULL;
+    /*
+     * How to allocate a buffer of the right initial size. If you want the
+     * gory detail, see http://www.opengroup.org/austin/docs/austin_328.txt
+     * and weep.
+     */
+
+    if (tsdPtr->gbuf == NULL) {
+	tsdPtr->gbuflen = (int) sysconf(_SC_GETGR_R_SIZE_MAX);
+	if (tsdPtr->gbuflen < 1) {
+	    tsdPtr->gbuflen = 1024;
+	}
+	tsdPtr->gbuf = ckalloc(tsdPtr->gbuflen);
+	Tcl_CreateThreadExitHandler(FreeGrBuf, NULL);
+    }
+    while (1) {
+	int e = getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, tsdPtr->gbuflen,
+		&grPtr);
+
+	if (e == 0) {
+	    break;
+	} else if (e != ERANGE) {
+	    return NULL;
+	}
+	tsdPtr->gbuflen *= 2;
+	tsdPtr->gbuf = ckrealloc(tsdPtr->gbuf, tsdPtr->gbuflen);
+    }
+    return (grPtr != NULL ? &tsdPtr->grp : NULL);
 
 #elif defined(HAVE_GETGRGID_R_4)
     return getgrgid_r(gid, &tsdPtr->grp, tsdPtr->gbuf, sizeof(tsdPtr->gbuf));
@@ -356,6 +503,29 @@ TclpGetGrGid(
 /*
  *---------------------------------------------------------------------------
  *
+ * FreeGrBuf --
+ *
+ *	Helper that is used to dispose of space allocated and referenced from
+ *	the ThreadSpecificData for group entries. (Darn that baroque POSIX
+ *	reentrant interface.)
+ *
+ *---------------------------------------------------------------------------
+ */
+
+#ifdef NEED_GR_CLEANER
+static void
+FreeGrBuf(
+    ClientData ignored)
+{
+    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
+    ckfree(tsdPtr->gbuf);
+}
+#endif /* NEED_GR_CLEANER */
+
+/*
+ *---------------------------------------------------------------------------
+ *
  * TclpGetHostByName --
  *
  *      Thread-safe wrappers for gethostbyname(). See "man gethostbyname" for
@@ -769,7 +939,7 @@ CopyArray(
 #ifdef NEED_COPYSTRING
 static int
 CopyString(
-    const char *src,	/* String to copy. */
+    const char *src,		/* String to copy. */
     char *buf,			/* Buffer to copy into. */
     int buflen)			/* Size of buffer. */
 {
-- 
cgit v0.12


From ff1a9f1762b2a15086eb6422ca160377a1a4d783 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 8 Nov 2011 17:20:49 +0000
Subject: missing constraint and too brittle result

---
 tests/encoding.test | 3 ++-
 tests/safe.test     | 2 +-
 2 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/tests/encoding.test b/tests/encoding.test
index a4f8449..51b7aa1 100644
--- a/tests/encoding.test
+++ b/tests/encoding.test
@@ -31,6 +31,7 @@ proc runtests {} {
 testConstraint testencoding [llength [info commands testencoding]]
 testConstraint exec [llength [info commands exec]]
 testConstraint testgetdefenc [llength [info commands testgetdefenc]]
+testConstraint testfinexit [llength [info commands testfinexit]]
 
 # TclInitEncodingSubsystem is tested by the rest of this file
 # TclFinalizeEncodingSubsystem is not currently tested
@@ -417,7 +418,7 @@ test encoding-24.1 {EscapeFreeProc on open channels} exec {
 	gets $f
     }
 } {}
-test encoding-24.2 {EscapeFreeProc on open channels} exec {
+test encoding-24.2 {EscapeFreeProc on open channels} {exec testfinexit} {
     # Bug #524674 output
     viewable [runInSubprocess {
 	encoding system cp1252;	# Bug #2891556 crash revelator
diff --git a/tests/safe.test b/tests/safe.test
index 4190976..2d7f476 100644
--- a/tests/safe.test
+++ b/tests/safe.test
@@ -205,7 +205,7 @@ test safe-7.2 {tests specific path and interpFind/AddToAccessPath} -body {
 	    [catch {interp eval $i {package require http 1}} msg] $msg \
 	    [safe::interpConfigure $i]\
 	    [safe::interpDelete $i]
-} -match glob -result "{\$p(:0:)} {\$p(:[expr 1+[llength [tcl::tm::list]]]:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
+} -match glob -result "{\$p(:0:)} {\$p(:*:)} 1 {can't find package http 1} {-accessPath {[list $tcl_library */dummy/unixlike/test/path]} -statics 0 -nested 1 -deleteHook {}} {}"
 
 # test source control on file name
 test safe-8.1 {safe source control on file} -setup {
-- 
cgit v0.12


From f9b9ca68f809e9a60a4f1c27c8ea43ef0167c26b Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 9 Nov 2011 20:40:46 +0000
Subject: More work in progress converting tests from [testthread] to Thread
 package.

---
 tests/thread.test | 497 ++++++++++++++++++++++++++----------------------------
 1 file changed, 235 insertions(+), 262 deletions(-)

diff --git a/tests/thread.test b/tests/thread.test
index dbfaec3..af4e4b6 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -611,7 +611,75 @@ test thread-7.17 {cancel: expr -unwind} -constraints thread -setup {
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.18 {cancel: expr bignum} -constraints thread -setup {
+test thread-7.18 {cancel: expr bignum} {testthread} {
+    threadReap
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    set serverthread [testthread create -joinable {
+        set i [interp create]
+        interp alias $i testthread {} testthread
+        $i eval {
+            if {![info exists foo]} then {
+                # signal the primary thread that we are ready
+                # to be canceled now (we are running).
+                testthread send [testthread id -main] \
+                        [list set ::threadIdStarted [testthread id]]
+                set foo 1
+            }
+            #
+      # TODO: This will not cancel because libtommath
+      #       does not check Tcl_Canceled.
+      #
+            expr {2**99999}
+        }
+    }]
+    # wait for other thread to signal "ready to cancel"
+    vwait ::threadIdStarted; after 1000
+    set res [testthread cancel $serverthread]
+    testthread join $serverthread
+    while {[testthread event]} {}; # force events to service
+    threadReap
+    list $res [expr {[info exists ::threadIdStarted] ? \
+                  $::threadIdStarted == $serverthread : 0}] \
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError] ? \
+                  [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.19 {cancel: expr bignum -unwind} {testthread} {
+    threadReap
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    set serverthread [testthread create -joinable {
+        set i [interp create]
+        interp alias $i testthread {} testthread
+        $i eval {
+            if {![info exists foo]} then {
+                # signal the primary thread that we are ready
+                # to be canceled now (we are running).
+                testthread send [testthread id -main] \
+                        [list set ::threadIdStarted [testthread id]]
+                set foo 1
+            }
+            #
+      # TODO: This will not cancel because libtommath
+      #       does not check Tcl_Canceled.
+      #
+            expr {2**99999}
+        }
+    }]
+    # wait for other thread to signal "ready to cancel"
+    vwait ::threadIdStarted; after 1000
+    set res [testthread cancel -unwind $serverthread]
+    testthread join $serverthread
+    while {[testthread event]} {}; # force events to service
+    threadReap
+    list $res [expr {[info exists ::threadIdStarted] ? \
+                  $::threadIdStarted == $serverthread : 0}] \
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError] ? \
+                  [lindex [split $::threadError \n] 0] : "" }]
+} {{} 1 0 {}}
+test thread-7.20 {cancel: subst} -constraints {thread} -setup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
@@ -625,28 +693,21 @@ test thread-7.18 {cancel: expr bignum} -constraints thread -setup {
 		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
-	    #
-      # TODO: This will not cancel because libtommath
-      #       does not check Tcl_Canceled.
-      #
-	    expr {2**99999}
+	    subst {[while {1} {incr x}]}
 	}
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel $serverthread]
-    after 1000 {set ::threadId timeout}
-    vwait threadId
+    vwait ::threadId
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-} -result {{} 1 0 {}}
-test thread-7.19 {cancel: expr bignum -unwind} -constraints thread -setup {
+} -result {{} 1 1 {eval canceled}}
+test thread-7.21 {cancel: subst -unwind} -constraints {thread} -setup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
@@ -660,147 +721,76 @@ test thread-7.19 {cancel: expr bignum -unwind} -constraints thread -setup {
 		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
-	    #
-      # TODO: This will not cancel because libtommath
-      #       does not check Tcl_Canceled.
-      #
-	    expr {2**99999}
+	    subst {[while {1} {incr x}]}
 	}
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    after 1000 {set ::threadId timeout}
-    vwait threadId
+    vwait ::threadId
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-} -result {{} 1 0 {}}
-test thread-7.20 {cancel: subst} {testthread} {
-    threadReap
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
-	set i [interp create]
-	interp alias $i testthread {} testthread
-	$i eval {
-	    if {![info exists foo]} then {
-		# signal the primary thread that we are ready
-		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
-		set foo 1
-	    }
-	    subst {[while {1} {incr x}]}
-	}
-    }]
-    # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval canceled}}
-test thread-7.21 {cancel: subst -unwind} {testthread} {
-    threadReap
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
-	set i [interp create]
-	interp alias $i testthread {} testthread
-	$i eval {
-	    if {![info exists foo]} then {
-		# signal the primary thread that we are ready
-		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
-		set foo 1
-	    }
-	    subst {[while {1} {incr x}]}
-	}
-    }]
-    # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.22 {cancel: slave interp} {testthread} {
-    threadReap
+} -result {{} 1 1 {eval unwound}}
+test thread-7.22 {cancel: slave interp} -constraints {thread} -setup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	set i [interp create]
-	interp alias $i testthread {} testthread
+	$i eval "package require -exact Thread [package present Thread]"
 	$i eval {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    while {1} {}
 	}
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval canceled}}
-test thread-7.23 {cancel: slave interp -unwind} {testthread} {
-    threadReap
+    vwait ::threadIdStarted
+    set res [thread::cancel $serverthread]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval canceled}}
+test thread-7.23 {cancel: slave interp -unwind} -constraints {thread} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	set i [interp create]
-	interp alias $i testthread {} testthread
+	$i eval "package require -exact Thread [package present Thread]"
 	$i eval {
 	    if {![info exists foo]} then {
 		# signal the primary thread that we are ready
 		# to be canceled now (we are running).
-		testthread send [testthread id -main] \
-			[list set ::threadIdStarted [testthread id]]
+		thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		set foo 1
 	    }
 	    set while while; $while {1} {}
 	}
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
+    vwait ::threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -result {{} 1 1 {eval unwound}}
 test thread-7.24 {cancel: nested catch inside pure bytecode loop} {notValgrind testthread} {
     threadReap
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -890,14 +880,13 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {notValg
 test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
     unset -nocomplain ::threadIdStarted
     set serverthread [thread::create -preserved \
-	[string map [list MAIN [thread::id]] {
+	[string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    while {1} {
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    thread::send MAIN \
-			    [list set ::threadIdStarted [thread::id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		update
@@ -906,28 +895,26 @@ test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
 	foobar
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
+    vwait ::threadIdStarted
     catch {thread::send $serverthread {interp cancel -- bad}} msg
     thread::send -async $serverthread {interp cancel -unwind}
     thread::release -wait $serverthread
-    list [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-		  $msg
+    list [expr {$::threadIdStarted == $serverthread}] $msg
 } {1 {could not find interpreter "bad"}}
-test thread-7.27 {cancel: send async cancel -- switch} {testthread} {
-    threadReap
+test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread} -setup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
-	interp create -- -unwind
-	interp alias -unwind testthread {} testthread
-	interp eval -unwind {
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
+	set i [interp create -- -unwind]
+	$i eval "package require -exact Thread [package present Thread]"
+	$i eval {
 	    proc foobar {} {
 		while {1} {
 		    if {![info exists foo]} then {
 			# signal the primary thread that we are ready
 			# to be canceled now (we are running).
-			testthread send [testthread id -main] \
-				[list set ::threadIdStarted [testthread id]]
+			thread::send %ID% [list set ::threadIdStarted [thread::id]]
 			set foo 1
 		    }
 		    update
@@ -935,20 +922,18 @@ test thread-7.27 {cancel: send async cancel -- switch} {testthread} {
 	    }
 	    foobar
 	}
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {interp cancel -- -unwind}]
-    after 1000; # wait for ThreadErrorProc to be called.
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval canceled}}
+    vwait ::threadIdStarted
+    set res [thread::send -async $serverthread {interp cancel -- -unwind}]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -result {{} 1 1 {eval canceled}}
 test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {notValgrind testthread} {
     threadReap
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -1121,17 +1106,17 @@ test thread-7.31 {cancel: send async testthread cancel nested catch pure inside-
 	      [expr {[info exists ::threadError] ? \
 		  [lindex [split $::threadError \n] 0] : "" }]
 } {{} 1 0 {}}
-test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} {testthread} {
-    threadReap
+test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    while {1} {
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		catch {
@@ -1146,24 +1131,23 @@ test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} {testt
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} {testthread} {
-    threadReap
+    vwait ::threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    set catch catch
 	    set while while
@@ -1171,8 +1155,7 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind}
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		$catch {
@@ -1187,31 +1170,29 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind}
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} {testthread} {
-    threadReap
+    vwait ::threadIdStarted
+    set res [thread::cancel -unwind $serverthread]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    while {1} {
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		catch {
@@ -1228,24 +1209,23 @@ test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode lo
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {interp cancel -unwind}]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} {testthread} {
-    threadReap
+    vwait ::threadIdStarted
+    set res [thread::send -async $serverthread {interp cancel -unwind}]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    set catch catch
 	    set while while
@@ -1253,8 +1233,7 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		$catch {
@@ -1271,31 +1250,29 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {interp cancel -unwind}]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.36 {cancel: send async testthread cancel nested catch inside pure bytecode loop -unwind} {testthread} {
-    threadReap
+    vwait ::threadIdStarted
+    set res [thread::send -async $serverthread {interp cancel -unwind}]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    while {1} {
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		catch {
@@ -1312,24 +1289,23 @@ test thread-7.36 {cancel: send async testthread cancel nested catch inside pure
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {testthread cancel -unwind [testthread id]}]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
-test thread-7.37 {cancel: send async testthread cancel nested catch inside pure inside-command loop -unwind} {testthread} {
-    threadReap
+    vwait ::threadIdStarted
+    set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+} -result {{} 1 1 {eval unwound}}
+test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -body {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID [thread::id]] {
 	proc foobar {} {
 	    set catch catch
 	    set while while
@@ -1337,8 +1313,7 @@ test thread-7.37 {cancel: send async testthread cancel nested catch inside pure
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		$catch {
@@ -1355,20 +1330,18 @@ test thread-7.37 {cancel: send async testthread cancel nested catch inside pure
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
-    vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {testthread cancel -unwind [testthread id]}]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
-    list $res [expr {[info exists ::threadIdStarted] ? \
-		  $::threadIdStarted == $serverthread : 0}] \
-	      [expr {[info exists ::threadId] ? \
-		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
-} {{} 1 1 {eval unwound}}
+    vwait ::threadIdStarted
+    set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
+    vwait ::threadId
+    thread::join $serverthread
+    list $res [expr {$::threadIdStarted == $serverthread}] \
+	      [expr {$::threadId == $serverthread}] \
+	      [lindex [split $::threadError \n] 0]
+} -cleanup {
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+} -result {{} 1 1 {eval unwound}}
 
 # cleanup
 ::tcltest::cleanupTests
-- 
cgit v0.12


From 3ad283728dbcb52ba80de264ac53c6f9bac43b87 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Fri, 11 Nov 2011 10:34:55 +0000
Subject:  Use nonblocking writes in single-threaded IO tests to avoid
 deadlocks when going beyond OS buffers [Bug 3428756].

---
 ChangeLog       | 5 +++++
 tests/zlib.test | 2 +-
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 82e2fe0..c82dfcc 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-11-11  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* tests/zlib.test: Use nonblocking writes in single-threaded IO
+	tests to avoid deadlocks when going beyond OS buffers [Bug 3428756].
+
 2011-11-03  Donal K. Fellows  <dkf@users.sf.net>
 
 	* unix/tclUnixCompat.c (TclpGetPwNam, TclpGetPwUid, TclpGetGrNam)
diff --git a/tests/zlib.test b/tests/zlib.test
index dac11e4..23f0229 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -197,7 +197,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup {
 test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
         #puts "connection from $a:$p on $c"
-        chan configure $c -encoding binary -translation binary
+        chan configure $c -encoding binary -translation binary -blocking 0
         puts -nonewline $c [string repeat a 81920]
         close $c
     }}} 0]
-- 
cgit v0.12


From a907261ea1119035e5c0c7150e96c62127ec2390 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Fri, 11 Nov 2011 10:58:43 +0000
Subject: Generalize previous fix to all of zlib.test; also, tidy up [chan
 configure] flags across zlib.test.

---
 ChangeLog       |  1 +
 tests/zlib.test | 46 +++++++++++++++++++++++-----------------------
 2 files changed, 24 insertions(+), 23 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index c82dfcc..25d9aba 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,7 @@
 
 	* tests/zlib.test: Use nonblocking writes in single-threaded IO
 	tests to avoid deadlocks when going beyond OS buffers [Bug 3428756].
+	Tidy up [chan configure] flags across zlib.test.
 
 2011-11-03  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/tests/zlib.test b/tests/zlib.test
index 23f0229..236e6b6 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -130,7 +130,7 @@ test zlib-8.2 {zlib transformation} -constraints zlib -setup {
 } -result ok
 test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        fconfigure $c -translation binary
+        fconfigure $c -translation binary -buffering none -blocking 0
         puts -nonewline $c [zlib gzip [string repeat a 81920]]
         close $c
     }}} 0]
@@ -175,7 +175,7 @@ test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
 } -result {copied 81920 size 81920}
 test zlib-9.2 "socket fcopy with push" -constraints zlib -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -encoding binary -translation binary
+        chan configure $c -translation binary -buffering none -blocking 0
         puts -nonewline $c [zlib gzip [string repeat a 81920]]
         close $c
     }}} 0]
@@ -197,7 +197,7 @@ test zlib-9.2 "socket fcopy with push" -constraints zlib -setup {
 test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
         #puts "connection from $a:$p on $c"
-        chan configure $c -encoding binary -translation binary -blocking 0
+        chan configure $c -translation binary -buffering none -blocking 0
         puts -nonewline $c [string repeat a 81920]
         close $c
     }}} 0]
@@ -222,7 +222,7 @@ test zlib-9.3 "socket fcopy bg (identity)" -constraints {tempNotWin zlib} -setup
 } -returnCodes {ok error} -result {read 81920 size 81920}
 test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -encoding binary -translation binary
+        chan configure $c -translation binary -buffering none -blocking 0
         puts -nonewline $c [zlib gzip [string repeat a 81920]]
         close $c
     }}} 0]
@@ -247,7 +247,7 @@ test zlib-9.4 "socket fcopy bg (gzip)" -constraints zlib -setup {
 } -result {read 81920 size 81920}
 test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -encoding binary -translation binary
+        chan configure $c -translation binary -buffering none -blocking 0
         puts -nonewline $c [zlib gzip [string repeat a 81920]]
         close $c
     }}} 0]
@@ -281,7 +281,7 @@ test zlib-9.5 "socket fcopy incremental (gzip)" -constraints zlib -setup {
 } -result {{eof 81920} size 81920}
 test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary -buffering none -blocking 0
         zlib push gzip $c
         puts -nonewline $c [string repeat hello 100]
         close $c
@@ -290,7 +290,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup {
     lassign [chan configure $srv -sockname] addr name port
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
-    chan configure $s -translation binary -buffering none
+    chan configure $s -translation binary
     zlib push gunzip $s
     chan event $s readable [list apply {{s} {
         set d [read $s]
@@ -308,7 +308,7 @@ test zlib-9.6 "bug #2818131 (gzip)" -constraints zlib -setup {
 } -result {eof 500}
 test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary -buffering none -blocking 0
         zlib push compress $c
         puts -nonewline $c [string repeat hello 100]
         close $c
@@ -317,7 +317,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup {
     lassign [chan configure $srv -sockname] addr name port
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
-    chan configure $s -translation binary -buffering none
+    chan configure $s -translation binary
     zlib push decompress $s
     chan event $s readable [list apply {{s} {
         set d [read $s]
@@ -335,7 +335,7 @@ test zlib-9.7 "bug #2818131 (compress)" -constraints zlib -setup {
 } -result {eof 500}
 test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup {
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary -buffering none -blocking 0
         zlib push deflate $c
         puts -nonewline $c [string repeat hello 100]
         close $c
@@ -344,7 +344,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup {
     lassign [chan configure $srv -sockname] addr name port
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
-    chan configure $s -translation binary -buffering none
+    chan configure $s -translation binary
     zlib push inflate $s
     chan event $s readable [list apply {{s} {
         set d [read $s]
@@ -363,7 +363,7 @@ test zlib-9.8 "bug #2818131 (deflate)" -constraints zlib -setup {
 test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
     proc bgerror {s} {set ::total [list error $s]}
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary -buffering none -blocking 0
         zlib push gzip $c
         puts -nonewline $c [string repeat hello 100]
         close $c
@@ -373,7 +373,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
     try {
-        chan configure $s -translation binary -buffering none
+        chan configure $s -translation binary
         zlib push inflate $s
         chan event $s readable [list apply {{s} {
             set d [read $s]
@@ -395,7 +395,7 @@ test zlib-9.9 "bug #2818131 (gzip mismatch)" -constraints zlib -setup {
 test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
     proc bgerror {s} {set ::total [list error $s]}
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary -buffering none -blocking 0
         zlib push compress $c
         puts -nonewline $c [string repeat hello 100]
         close $c
@@ -405,7 +405,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
     try {
-        chan configure $s -translation binary -buffering none
+        chan configure $s -translation binary
         zlib push inflate $s
         chan event $s readable [list apply {{s} {
             set d [read $s]
@@ -427,7 +427,7 @@ test zlib-9.10 "bug #2818131 (compress mismatch)" -constraints zlib -setup {
 test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup {
     proc bgerror {s} {set ::total [list error $s]}
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary -buffering none -blocking 0
         zlib push deflate $c
         puts -nonewline $c [string repeat hello 100]
         close $c
@@ -437,7 +437,7 @@ test zlib-9.11 "bug #2818131 (deflate mismatch)" -constraints zlib -setup {
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
     try {
-        chan configure $s -translation binary -buffering none
+        chan configure $s -translation binary
         zlib push gunzip $s
         chan event $s readable [list apply {{s} {
             set d [read $s]
@@ -462,7 +462,7 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints {
 } -setup {
     proc bgerror {s} {set ::total [list error $s]}
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary
         zlib push inflate $c
         chan event $c readable [list apply {{c} {
             set d [read $c]
@@ -477,7 +477,7 @@ test zlib-10.0 "bug #2818131 (close with null interp)" -constraints {
     lassign [chan configure $srv -sockname] addr name port
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
-    chan configure $s -translation binary -buffering none
+    chan configure $s -translation binary -buffering none -blocking 0
     zlib push gzip $s
     chan event $s xyzzy [list apply {{s} {
         if {[gets $s line] < 0} {
@@ -509,7 +509,7 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
         }
     }
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary
         zlib push inflate $c
         chan event $c readable [list zlibRead $c]
     }}} 0]
@@ -517,7 +517,7 @@ test zlib-10.1 "bug #2818131 (mismatch read)" -constraints {
     lassign [chan configure $srv -sockname] addr name port
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
-    chan configure $s -translation binary -buffering none
+    chan configure $s -translation binary -buffering none -blocking 0
     zlib push gzip $s
     chan event $s readable [list zlibRead $s]
     after idle [list apply {{s} {
@@ -547,7 +547,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
         }
     }
     set srv [socket -myaddr localhost -server {apply {{c a p} {
-        chan configure $c -translation binary -buffering none
+        chan configure $c -translation binary
         zlib push inflate $c
         chan event $c readable [list zlibRead $c]
     }}} 0]
@@ -555,7 +555,7 @@ test zlib-10.2 "bug #2818131 (mismatch gets)" -constraints {
     lassign [chan configure $srv -sockname] addr name port
     after 1000 {set ::total timeout}
     set s [socket $addr $port]
-    chan configure $s -translation binary -buffering none
+    chan configure $s -translation binary -buffering none -blocking 0
     zlib push gzip $s
     chan event $s readable [list zlibRead $s]
     after idle [list apply {{s} {
-- 
cgit v0.12


From 206047c64c05dcec08d93af6860fea9662f667b8 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 11 Nov 2011 13:09:45 +0000
Subject: win/tclWinConsole.c: Refactor common thread handling patterns.

---
 ChangeLog           |  10 +-
 win/tclWinConsole.c | 437 +++++++++++++++++++++++++++-------------------------
 2 files changed, 235 insertions(+), 212 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 25d9aba..83e5703 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,12 @@
+2011-11-11  Donal K. Fellows  <dkf@users.sf.net>
+
+	* win/tclWinConsole.c: Refactor common thread handling patterns.
+
 2011-11-11  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
-	* tests/zlib.test: Use nonblocking writes in single-threaded IO
-	tests to avoid deadlocks when going beyond OS buffers [Bug 3428756].
-	Tidy up [chan configure] flags across zlib.test.
+	* tests/zlib.test: [Bug 3428756]: Use nonblocking writes in
+	single-threaded IO tests to avoid deadlocks when going beyond OS
+	buffers.  Tidy up [chan configure] flags across zlib.test.
 
 2011-11-03  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/win/tclWinConsole.c b/win/tclWinConsole.c
index a6207fe..5aab255 100644
--- a/win/tclWinConsole.c
+++ b/win/tclWinConsole.c
@@ -11,7 +11,6 @@
  */
 
 #include "tclWinInt.h"
-
 #include <sys/stat.h>
 
 /*
@@ -47,6 +46,23 @@ TCL_DECLARE_MUTEX(consoleMutex)
 #define CONSOLE_BUFFER_SIZE (8*1024)
 
 /*
+ * Structure containing handles associated with one of the special console
+ * threads.
+ */
+
+typedef struct ConsoleThreadInfo {
+    HANDLE thread;		/* Handle to reader or writer thread. */
+    HANDLE readyEvent;		/* Manual-reset event to signal _to_ the main
+				 * thread when the worker thread has finished
+				 * waiting for its normal work to happen. */
+    HANDLE startEvent;		/* Auto-reset event used by the main thread to
+				 * signal when the thread should attempt to do
+				 * its normal work. */
+    HANDLE stopEvent;		/* Auto-reset event used by the main thread to
+				 * signal when the thread should exit. */
+} ConsoleThreadInfo;
+
+/*
  * This structure describes per-instance data for a console based channel.
  */
 
@@ -65,24 +81,18 @@ typedef struct ConsoleInfo {
     Tcl_ThreadId threadId;	/* Thread to which events should be reported.
 				 * This value is used by the reader/writer
 				 * threads. */
-    HANDLE writeThread;		/* Handle to writer thread. */
-    HANDLE readThread;		/* Handle to reader thread. */
-    HANDLE writable;		/* Manual-reset event to signal when the
-				 * writer thread has finished waiting for the
-				 * current buffer to be written. */
-    HANDLE readable;		/* Manual-reset event to signal when the
-				 * reader thread has finished waiting for
-				 * input. */
-    HANDLE startWriter;		/* Auto-reset event used by the main thread to
-				 * signal when the writer thread should
-				 * attempt to write to the console. */
-    HANDLE stopWriter;		/* Auto-reset event used by the main thread to
-				 * signal when the writer thread should exit */
-    HANDLE startReader;		/* Auto-reset event used by the main thread to
-				 * signal when the reader thread should
-				 * attempt to read from the console. */
-    HANDLE stopReader;		/* Auto-reset event used by the main thread to
-				 * signal when the reader thread should exit */
+    ConsoleThreadInfo writer;	/* A specialized thread for handling
+				 * asynchronous writes to the console; the
+				 * waiting starts when a start event is sent,
+				 * and a reset event is sent back to the main
+				 * thread when the write is done. A stop event
+				 * is used to terminate the thread. */
+    ConsoleThreadInfo reader;	/* A specialized thread for handling
+				 * asynchronous reads from the console; the
+				 * waiting starts when a start event is sent,
+				 * and a reset event is sent back to the main
+				 * thread when input is available. A stop
+				 * event is used to terminate the thread. */
     DWORD writeError;		/* An error caused by the last background
 				 * write. Set to 0 if no error has been
 				 * detected. This word is shared with the
@@ -97,8 +107,8 @@ typedef struct ConsoleInfo {
     int readFlags;		/* Flags that are shared with the reader
 				 * thread. Access is synchronized with the
 				 * readable object. */
-    int bytesRead;		/* number of bytes in the buffer */
-    int offset;			/* number of bytes read out of the buffer */
+    int bytesRead;		/* Number of bytes in the buffer. */
+    int offset;			/* Number of bytes read out of the buffer. */
     char buffer[CONSOLE_BUFFER_SIZE];
 				/* Data consumed by reader thread. */
 } ConsoleInfo;
@@ -132,7 +142,8 @@ typedef struct ConsoleEvent {
  * Declarations for functions used only in this file.
  */
 
-static int		ConsoleBlockModeProc(ClientData instanceData,int mode);
+static int		ConsoleBlockModeProc(ClientData instanceData,
+			    int mode);
 static void		ConsoleCheckProc(ClientData clientData, int flags);
 static int		ConsoleCloseProc(ClientData instanceData,
 			    Tcl_Interp *interp);
@@ -153,6 +164,15 @@ static void		ProcExitHandler(ClientData clientData);
 static int		WaitForRead(ConsoleInfo *infoPtr, int blocking);
 static void		ConsoleThreadActionProc(ClientData instanceData,
 			    int action);
+static BOOL		ReadConsoleBytes(HANDLE hConsole, LPVOID lpBuffer,
+			    DWORD nbytes, LPDWORD nbytesread);
+static BOOL		WriteConsoleBytes(HANDLE hConsole,
+			    const void *lpBuffer, DWORD nbytes,
+			    LPDWORD nbyteswritten);
+static void		StartChannelThread(ConsoleInfo *infoPtr,
+			    ConsoleThreadInfo *threadInfoPtr,
+			    LPTHREAD_START_ROUTINE threadProc);
+static void		StopChannelThread(ConsoleThreadInfo *threadInfoPtr);
 
 /*
  * This structure describes the channel type structure for command console
@@ -171,23 +191,27 @@ static const Tcl_ChannelType consoleChannelType = {
     ConsoleWatchProc,		/* Set up notifier to watch the channel. */
     ConsoleGetHandleProc,	/* Get an OS handle from channel. */
     NULL,			/* close2proc. */
-    ConsoleBlockModeProc,	/* Set blocking or non-blocking mode.*/
-    NULL,			/* flush proc. */
-    NULL,			/* handler proc. */
-    NULL,			/* wide seek proc */
-    ConsoleThreadActionProc,    /* thread action proc */
-    NULL                       /* truncation */
+    ConsoleBlockModeProc,	/* Set blocking or non-blocking mode. */
+    NULL,			/* Flush proc. */
+    NULL,			/* Handler proc. */
+    NULL,			/* Wide seek proc. */
+    ConsoleThreadActionProc,	/* Thread action proc. */
+    NULL			/* Truncation proc. */
 };
 
 /*
  *----------------------------------------------------------------------
  *
- * readConsoleBytes, writeConsoleBytes --
- * Wrapper for ReadConsole{A,W}, that takes and returns number of bytes
- * instead of number of TCHARS
+ * ReadConsoleBytes, WriteConsoleBytes --
+ *
+ *	Wrapper for ReadConsole{A,W}, that takes and returns number of bytes
+ *	instead of number of TCHARS.
+ *
+ *----------------------------------------------------------------------
  */
+
 static BOOL
-readConsoleBytes(
+ReadConsoleBytes(
     HANDLE hConsole,
     LPVOID lpBuffer,
     DWORD nbytes,
@@ -196,15 +220,17 @@ readConsoleBytes(
     DWORD ntchars;
     BOOL result;
     int tcharsize = sizeof(TCHAR);
-    result = ReadConsole(
-	    hConsole, lpBuffer, nbytes / tcharsize, &ntchars, NULL);
-    if (nbytesread)
-	*nbytesread = (ntchars*tcharsize);
+
+    result = ReadConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars,
+	    NULL);
+    if (nbytesread != NULL) {
+	*nbytesread = ntchars * tcharsize;
+    }
     return result;
 }
 
 static BOOL
-writeConsoleBytes(
+WriteConsoleBytes(
     HANDLE hConsole,
     const void *lpBuffer,
     DWORD nbytes,
@@ -213,10 +239,12 @@ writeConsoleBytes(
     DWORD ntchars;
     BOOL result;
     int tcharsize = sizeof(TCHAR);
-    result = WriteConsole(
-	    hConsole, lpBuffer, nbytes / tcharsize, &ntchars, NULL);
-    if (nbyteswritten)
-	*nbyteswritten = (ntchars*tcharsize);
+
+    result = WriteConsole(hConsole, lpBuffer, nbytes / tcharsize, &ntchars,
+	    NULL);
+    if (nbyteswritten != NULL) {
+	*nbyteswritten = ntchars * tcharsize;
+    }
     return result;
 }
 
@@ -239,8 +267,6 @@ writeConsoleBytes(
 static void
 ConsoleInit(void)
 {
-    ThreadSpecificData *tsdPtr;
-
     /*
      * Check the initialized flag first, then check again in the mutex. This
      * is a speed enhancement.
@@ -255,9 +281,9 @@ ConsoleInit(void)
 	Tcl_MutexUnlock(&consoleMutex);
     }
 
-    tsdPtr = (ThreadSpecificData *)TclThreadDataKeyGet(&dataKey);
-    if (tsdPtr == NULL) {
-	tsdPtr = TCL_TSD_INIT(&dataKey);
+    if (TclThreadDataKeyGet(&dataKey) == NULL) {
+	ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
+
 	tsdPtr->firstConsolePtr = NULL;
 	Tcl_CreateEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
 	Tcl_CreateThreadExitHandler(ConsoleExitHandler, NULL);
@@ -283,7 +309,7 @@ ConsoleInit(void)
 
 static void
 ConsoleExitHandler(
-    ClientData clientData)	/* Old window proc */
+    ClientData clientData)	/* Old window proc. */
 {
     Tcl_DeleteEventSource(ConsoleSetupProc, ConsoleCheckProc, NULL);
 }
@@ -307,7 +333,7 @@ ConsoleExitHandler(
 
 static void
 ProcExitHandler(
-    ClientData clientData)	/* Old window proc */
+    ClientData clientData)	/* Old window proc. */
 {
     Tcl_MutexLock(&consoleMutex);
     initialized = 0;
@@ -352,7 +378,8 @@ ConsoleSetupProc(
     for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
 	    infoPtr = infoPtr->nextPtr) {
 	if (infoPtr->watchMask & TCL_WRITABLE) {
-	    if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+	    if (WaitForSingleObject(infoPtr->writer.readyEvent,
+		    0) != WAIT_TIMEOUT) {
 		block = 0;
 	    }
 	}
@@ -390,7 +417,6 @@ ConsoleCheckProc(
     int flags)			/* Event flags as passed to Tcl_DoOneEvent. */
 {
     ConsoleInfo *infoPtr;
-    ConsoleEvent *evPtr;
     int needEvent;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
@@ -415,7 +441,8 @@ ConsoleCheckProc(
 
 	needEvent = 0;
 	if (infoPtr->watchMask & TCL_WRITABLE) {
-	    if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+	    if (WaitForSingleObject(infoPtr->writer.readyEvent,
+		    0) != WAIT_TIMEOUT) {
 		needEvent = 1;
 	    }
 	}
@@ -427,8 +454,9 @@ ConsoleCheckProc(
 	}
 
 	if (needEvent) {
+	    ConsoleEvent *evPtr = ckalloc(sizeof(ConsoleEvent));
+
 	    infoPtr->flags |= CONSOLE_PENDING;
-	    evPtr = ckalloc(sizeof(ConsoleEvent));
 	    evPtr->header.proc = ConsoleEventProc;
 	    evPtr->infoPtr = infoPtr;
 	    Tcl_QueueEvent((Tcl_Event *) evPtr, TCL_QUEUE_TAIL);
@@ -436,7 +464,6 @@ ConsoleCheckProc(
     }
 }
 
-
 /*
  *----------------------------------------------------------------------
  *
@@ -459,7 +486,7 @@ ConsoleBlockModeProc(
     int mode)			/* TCL_MODE_BLOCKING or
 				 * TCL_MODE_NONBLOCKING. */
 {
-    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+    ConsoleInfo *infoPtr = instanceData;
 
     /*
      * Consoles on Windows can not be switched between blocking and
@@ -472,7 +499,7 @@ ConsoleBlockModeProc(
     if (mode == TCL_MODE_NONBLOCKING) {
 	infoPtr->flags |= CONSOLE_ASYNC;
     } else {
-	infoPtr->flags &= ~(CONSOLE_ASYNC);
+	infoPtr->flags &= ~CONSOLE_ASYNC;
     }
     return 0;
 }
@@ -480,6 +507,84 @@ ConsoleBlockModeProc(
 /*
  *----------------------------------------------------------------------
  *
+ * StartChannelThread, StopChannelThread --
+ *
+ *	Helpers that codify how to ask one of the console service threads to
+ *	start and stop.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+StartChannelThread(
+    ConsoleInfo *infoPtr,
+    ConsoleThreadInfo *threadInfoPtr,
+    LPTHREAD_START_ROUTINE threadProc)
+{
+    DWORD id;
+
+    threadInfoPtr->readyEvent = CreateEvent(NULL, TRUE, TRUE, NULL);
+    threadInfoPtr->startEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+    threadInfoPtr->stopEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+    threadInfoPtr->thread = CreateThread(NULL, 256, threadProc, infoPtr, 0,
+	    &id);
+    SetThreadPriority(threadInfoPtr->thread, THREAD_PRIORITY_HIGHEST);
+}
+
+static void
+StopChannelThread(
+    ConsoleThreadInfo *threadInfoPtr)
+{
+    DWORD exitCode = 0;
+
+    /*
+     * The thread may already have closed on it's own. Check it's exit
+     * code.
+     */
+
+    GetExitCodeThread(threadInfoPtr->thread, &exitCode);
+    if (exitCode == STILL_ACTIVE) {
+	/*
+	 * Set the stop event so that if the reader thread is blocked in
+	 * ConsoleReaderThread on WaitForMultipleEvents, it will exit cleanly.
+	 */
+
+	SetEvent(threadInfoPtr->stopEvent);
+
+	/*
+	 * Wait at most 20 milliseconds for the reader thread to close.
+	 */
+
+	if (WaitForSingleObject(threadInfoPtr->thread, 20) == WAIT_TIMEOUT) {
+	    /*
+	     * Forcibly terminate the background thread as a last resort.
+	     * Note that we need to guard against terminating the thread while
+	     * it is in the middle of Tcl_ThreadAlert because it won't be able
+	     * to release the notifier lock.
+	     */
+
+	    Tcl_MutexLock(&consoleMutex);
+	    /* BUG: this leaks memory. */
+	    TerminateThread(threadInfoPtr->thread, 0);
+	    Tcl_MutexUnlock(&consoleMutex);
+	}
+    }
+
+    /*
+     * Close all the handles associated with the thread, and set the thread
+     * handle field to NULL to mark that the thread has been cleaned up.
+     */
+
+    CloseHandle(threadInfoPtr->thread);
+    CloseHandle(threadInfoPtr->readyEvent);
+    CloseHandle(threadInfoPtr->startEvent);
+    CloseHandle(threadInfoPtr->stopEvent);
+    threadInfoPtr->thread = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * ConsoleCloseProc --
  *
  *	Closes a console based IO channel.
@@ -498,13 +603,10 @@ ConsoleCloseProc(
     ClientData instanceData,	/* Pointer to ConsoleInfo structure. */
     Tcl_Interp *interp)		/* For error reporting. */
 {
-    ConsoleInfo *consolePtr = (ConsoleInfo *) instanceData;
-    int errorCode;
+    ConsoleInfo *consolePtr = instanceData;
+    int errorCode = 0;
     ConsoleInfo *infoPtr, **nextPtrPtr;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-    DWORD exitCode;
-
-    errorCode = 0;
 
     /*
      * Clean up the background thread if necessary. Note that this must be
@@ -512,49 +614,8 @@ ConsoleCloseProc(
      * trying to read from the console.
      */
 
-    if (consolePtr->readThread) {
-	/*
-	 * The thread may already have closed on it's own. Check it's exit
-	 * code.
-	 */
-
-	GetExitCodeThread(consolePtr->readThread, &exitCode);
-
-	if (exitCode == STILL_ACTIVE) {
-	    /*
-	     * Set the stop event so that if the reader thread is blocked in
-	     * ConsoleReaderThread on WaitForMultipleEvents, it will exit
-	     * cleanly.
-	     */
-
-	    SetEvent(consolePtr->stopReader);
-
-	    /*
-	     * Wait at most 20 milliseconds for the reader thread to close.
-	     */
-
-	    if (WaitForSingleObject(consolePtr->readThread, 20)
-		    == WAIT_TIMEOUT) {
-		/*
-		 * Forcibly terminate the background thread as a last resort.
-		 * Note that we need to guard against terminating the thread
-		 * while it is in the middle of Tcl_ThreadAlert because it
-		 * won't be able to release the notifier lock.
-		 */
-
-		Tcl_MutexLock(&consoleMutex);
-
-		/* BUG: this leaks memory. */
-		TerminateThread(consolePtr->readThread, 0);
-		Tcl_MutexUnlock(&consoleMutex);
-	    }
-	}
-
-	CloseHandle(consolePtr->readThread);
-	CloseHandle(consolePtr->readable);
-	CloseHandle(consolePtr->startReader);
-	CloseHandle(consolePtr->stopReader);
-	consolePtr->readThread = NULL;
+    if (consolePtr->reader.thread) {
+	StopChannelThread(&consolePtr->reader);
     }
     consolePtr->validMask &= ~TCL_READABLE;
 
@@ -564,62 +625,20 @@ ConsoleCloseProc(
      * should be no pending write operations.
      */
 
-    if (consolePtr->writeThread) {
+    if (consolePtr->writer.thread) {
 	if (consolePtr->toWrite) {
 	    /*
 	     * We only need to wait if there is something to write. This may
-	     * prevent infinite wait on exit. [python bug 216289]
+	     * prevent infinite wait on exit. [Python Bug 216289]
 	     */
 
-	    WaitForSingleObject(consolePtr->writable, INFINITE);
+	    WaitForSingleObject(consolePtr->writer.readyEvent, INFINITE);
 	}
 
-	/*
-	 * The thread may already have closed on it's own. Check it's exit
-	 * code.
-	 */
-
-	GetExitCodeThread(consolePtr->writeThread, &exitCode);
-
-	if (exitCode == STILL_ACTIVE) {
-	    /*
-	     * Set the stop event so that if the reader thread is blocked in
-	     * ConsoleWriterThread on WaitForMultipleEvents, it will exit
-	     * cleanly.
-	     */
-
-	    SetEvent(consolePtr->stopWriter);
-
-	    /*
-	     * Wait at most 20 milliseconds for the writer thread to close.
-	     */
-
-	    if (WaitForSingleObject(consolePtr->writeThread, 20)
-		    == WAIT_TIMEOUT) {
-		/*
-		 * Forcibly terminate the background thread as a last resort.
-		 * Note that we need to guard against terminating the thread
-		 * while it is in the middle of Tcl_ThreadAlert because it
-		 * won't be able to release the notifier lock.
-		 */
-
-		Tcl_MutexLock(&consoleMutex);
-
-		/* BUG: this leaks memory. */
-		TerminateThread(consolePtr->writeThread, 0);
-		Tcl_MutexUnlock(&consoleMutex);
-	    }
-	}
-
-	CloseHandle(consolePtr->writeThread);
-	CloseHandle(consolePtr->writable);
-	CloseHandle(consolePtr->startWriter);
-	CloseHandle(consolePtr->stopWriter);
-	consolePtr->writeThread = NULL;
+	StopChannelThread(&consolePtr->writer);
     }
     consolePtr->validMask &= ~TCL_WRITABLE;
 
-
     /*
      * Don't close the Win32 handle if the handle is a standard channel during
      * the thread exit process. Otherwise, one thread may kill the stdio of
@@ -645,7 +664,7 @@ ConsoleCloseProc(
     for (nextPtrPtr = &(tsdPtr->firstConsolePtr), infoPtr = *nextPtrPtr;
 	    infoPtr != NULL;
 	    nextPtrPtr = &infoPtr->nextPtr, infoPtr = *nextPtrPtr) {
-	if (infoPtr == (ConsoleInfo *)consolePtr) {
+	if (infoPtr == (ConsoleInfo *) consolePtr) {
 	    *nextPtrPtr = infoPtr->nextPtr;
 	    break;
 	}
@@ -685,7 +704,7 @@ ConsoleInputProc(
 				 * buffer? */
     int *errorCode)		/* Where to store error code. */
 {
-    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+    ConsoleInfo *infoPtr = instanceData;
     DWORD count, bytesRead = 0;
     int result;
 
@@ -720,7 +739,7 @@ ConsoleInputProc(
 	    bytesRead = infoPtr->bytesRead - infoPtr->offset;
 
 	    /*
-	     * Reset the buffer
+	     * Reset the buffer.
 	     */
 
 	    infoPtr->readFlags &= ~CONSOLE_BUFFERED;
@@ -736,8 +755,8 @@ ConsoleInputProc(
      * byte is available or an EOF occurs.
      */
 
-    if (readConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize, &count)
-	    == TRUE) {
+    if (ReadConsoleBytes(infoPtr->handle, (LPVOID) buf, (DWORD) bufSize,
+	    &count) == TRUE) {
 	buf[count] = '\0';
 	return count;
     }
@@ -770,12 +789,13 @@ ConsoleOutputProc(
     int toWrite,		/* How many bytes to write? */
     int *errorCode)		/* Where to store error code. */
 {
-    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+    ConsoleInfo *infoPtr = instanceData;
+    ConsoleThreadInfo *threadInfo = &infoPtr->reader;
     DWORD bytesWritten, timeout;
 
     *errorCode = 0;
     timeout = (infoPtr->flags & CONSOLE_ASYNC) ? 0 : INFINITE;
-    if (WaitForSingleObject(infoPtr->writable, timeout) == WAIT_TIMEOUT) {
+    if (WaitForSingleObject(threadInfo->readyEvent,timeout) == WAIT_TIMEOUT) {
 	/*
 	 * The writer thread is blocked waiting for a write to complete and
 	 * the channel is in non-blocking mode.
@@ -812,10 +832,10 @@ ConsoleOutputProc(
 	    infoPtr->writeBufLen = toWrite;
 	    infoPtr->writeBuf = ckalloc(toWrite);
 	}
-	memcpy(infoPtr->writeBuf, buf, (size_t)toWrite);
+	memcpy(infoPtr->writeBuf, buf, (size_t) toWrite);
 	infoPtr->toWrite = toWrite;
-	ResetEvent(infoPtr->writable);
-	SetEvent(infoPtr->startWriter);
+	ResetEvent(threadInfo->readyEvent);
+	SetEvent(threadInfo->startEvent);
 	bytesWritten = toWrite;
     } else {
 	/*
@@ -823,9 +843,8 @@ ConsoleOutputProc(
 	 * avoids an unnecessary copy.
 	 */
 
-	if (writeConsoleBytes(infoPtr->handle, buf, (DWORD)toWrite,
-			      &bytesWritten)
-		== FALSE) {
+	if (WriteConsoleBytes(infoPtr->handle, buf, (DWORD) toWrite,
+		&bytesWritten) == FALSE) {
 	    TclWinConvertError(GetLastError());
 	    goto error;
 	}
@@ -864,7 +883,7 @@ ConsoleEventProc(
     int flags)			/* Flags that indicate what events to handle,
 				 * such as TCL_FILE_EVENTS. */
 {
-    ConsoleEvent *consoleEvPtr = (ConsoleEvent *)evPtr;
+    ConsoleEvent *consoleEvPtr = (ConsoleEvent *) evPtr;
     ConsoleInfo *infoPtr;
     int mask;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
@@ -883,7 +902,7 @@ ConsoleEventProc(
     for (infoPtr = tsdPtr->firstConsolePtr; infoPtr != NULL;
 	    infoPtr = infoPtr->nextPtr) {
 	if (consoleEvPtr->infoPtr == infoPtr) {
-	    infoPtr->flags &= ~(CONSOLE_PENDING);
+	    infoPtr->flags &= ~CONSOLE_PENDING;
 	    break;
 	}
     }
@@ -904,7 +923,8 @@ ConsoleEventProc(
 
     mask = 0;
     if (infoPtr->watchMask & TCL_WRITABLE) {
-	if (WaitForSingleObject(infoPtr->writable, 0) != WAIT_TIMEOUT) {
+	if (WaitForSingleObject(infoPtr->writer.readyEvent,
+		0) != WAIT_TIMEOUT) {
 	    mask = TCL_WRITABLE;
 	}
     }
@@ -951,7 +971,7 @@ ConsoleWatchProc(
 				 * TCL_EXCEPTION. */
 {
     ConsoleInfo **nextPtrPtr, *ptr;
-    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+    ConsoleInfo *infoPtr = instanceData;
     int oldMask = infoPtr->watchMask;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
 
@@ -963,6 +983,7 @@ ConsoleWatchProc(
     infoPtr->watchMask = mask & infoPtr->validMask;
     if (infoPtr->watchMask) {
 	Tcl_Time blockTime = { 0, 0 };
+
 	if (!oldMask) {
 	    infoPtr->nextPtr = tsdPtr->firstConsolePtr;
 	    tsdPtr->firstConsolePtr = infoPtr;
@@ -1005,12 +1026,12 @@ ConsoleWatchProc(
 static int
 ConsoleGetHandleProc(
     ClientData instanceData,	/* The console state. */
-    int direction,		/* TCL_READABLE or TCL_WRITABLE */
+    int direction,		/* TCL_READABLE or TCL_WRITABLE. */
     ClientData *handlePtr)	/* Where to store the handle. */
 {
-    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+    ConsoleInfo *infoPtr = instanceData;
 
-    *handlePtr = (ClientData) infoPtr->handle;
+    *handlePtr = infoPtr->handle;
     return TCL_OK;
 }
 
@@ -1043,6 +1064,7 @@ WaitForRead(
 {
     DWORD timeout, count;
     HANDLE *handle = infoPtr->handle;
+    ConsoleThreadInfo *threadInfo = &infoPtr->reader;
     INPUT_RECORD input;
 
     while (1) {
@@ -1051,7 +1073,8 @@ WaitForRead(
 	 */
 
 	timeout = blocking ? INFINITE : 0;
-	if (WaitForSingleObject(infoPtr->readable, timeout) == WAIT_TIMEOUT) {
+	if (WaitForSingleObject(threadInfo->readyEvent,
+		timeout) == WAIT_TIMEOUT) {
 	    /*
 	     * The reader thread is blocked waiting for data and the channel
 	     * is in non-blocking mode.
@@ -1110,8 +1133,8 @@ WaitForRead(
 	 * There wasn't any data available, so reset the thread and try again.
 	 */
 
-	ResetEvent(infoPtr->readable);
-	SetEvent(infoPtr->startReader);
+	ResetEvent(threadInfo->readyEvent);
+	SetEvent(threadInfo->startEvent);
     }
 }
 
@@ -1138,14 +1161,18 @@ static DWORD WINAPI
 ConsoleReaderThread(
     LPVOID arg)
 {
-    ConsoleInfo *infoPtr = (ConsoleInfo *)arg;
+    ConsoleInfo *infoPtr = arg;
     HANDLE *handle = infoPtr->handle;
+    ConsoleThreadInfo *threadInfo = &infoPtr->reader;
     DWORD waitResult;
     HANDLE wEvents[2];
 
-    /* The first event takes precedence. */
-    wEvents[0] = infoPtr->stopReader;
-    wEvents[1] = infoPtr->startReader;
+    /*
+     * The first event takes precedence.
+     */
+
+    wEvents[0] = threadInfo->stopEvent;
+    wEvents[1] = threadInfo->startEvent;
 
     for (;;) {
 	/*
@@ -1168,7 +1195,7 @@ ConsoleReaderThread(
 	 * not KEY_EVENTs.
 	 */
 
-	if (readConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
+	if (ReadConsoleBytes(handle, infoPtr->buffer, CONSOLE_BUFFER_SIZE,
 		(LPDWORD) &infoPtr->bytesRead) != FALSE) {
 	    /*
 	     * Data was stored in the buffer.
@@ -1176,10 +1203,9 @@ ConsoleReaderThread(
 
 	    infoPtr->readFlags |= CONSOLE_BUFFERED;
 	} else {
-	    DWORD err;
-	    err = GetLastError();
+	    DWORD err = GetLastError();
 
-	    if (err == (DWORD)EOF) {
+	    if (err == (DWORD) EOF) {
 		infoPtr->readFlags = CONSOLE_EOF;
 	    }
 	}
@@ -1189,7 +1215,7 @@ ConsoleReaderThread(
 	 * waking up the notifier thread.
 	 */
 
-	SetEvent(infoPtr->readable);
+	SetEvent(threadInfo->readyEvent);
 
 	/*
 	 * Alert the foreground thread. Note that we need to treat this like a
@@ -1203,6 +1229,7 @@ ConsoleReaderThread(
 	     * TIP #218. When in flight ignore the event, no one will receive
 	     * it anyway.
 	     */
+
 	    Tcl_ThreadAlert(infoPtr->threadId);
 	}
 	Tcl_MutexUnlock(&consoleMutex);
@@ -1234,16 +1261,19 @@ static DWORD WINAPI
 ConsoleWriterThread(
     LPVOID arg)
 {
-
-    ConsoleInfo *infoPtr = (ConsoleInfo *)arg;
+    ConsoleInfo *infoPtr = arg;
     HANDLE *handle = infoPtr->handle;
+    ConsoleThreadInfo *threadInfo = &infoPtr->writer;
     DWORD count, toWrite, waitResult;
     char *buf;
     HANDLE wEvents[2];
 
-    /* The first event takes precedence. */
-    wEvents[0] = infoPtr->stopWriter;
-    wEvents[1] = infoPtr->startWriter;
+    /*
+     * The first event takes precedence.
+     */
+
+    wEvents[0] = threadInfo->stopEvent;
+    wEvents[1] = threadInfo->startEvent;
 
     for (;;) {
 	/*
@@ -1269,14 +1299,13 @@ ConsoleWriterThread(
 	 */
 
 	while (toWrite > 0) {
-	    if (writeConsoleBytes(handle, buf, (DWORD)toWrite,
-				  &count) == FALSE) {
+	    if (WriteConsoleBytes(handle, buf, (DWORD) toWrite,
+		    &count) == FALSE) {
 		infoPtr->writeError = GetLastError();
 		break;
-	    } else {
-		toWrite -= count;
-		buf += count;
 	    }
+	    toWrite -= count;
+	    buf += count;
 	}
 
 	/*
@@ -1284,7 +1313,7 @@ ConsoleWriterThread(
 	 * waking up the notifier thread.
 	 */
 
-	SetEvent(infoPtr->writable);
+	SetEvent(threadInfo->readyEvent);
 
 	/*
 	 * Alert the foreground thread. Note that we need to treat this like a
@@ -1320,7 +1349,7 @@ ConsoleWriterThread(
  *	Returns the new channel, or NULL.
  *
  * Side effects:
- *	May open the channel
+ *	May open the channel.
  *
  *----------------------------------------------------------------------
  */
@@ -1333,7 +1362,7 @@ TclWinOpenConsoleChannel(
 {
     char encoding[4 + TCL_INTEGER_SPACE];
     ConsoleInfo *infoPtr;
-    DWORD id, modes;
+    DWORD modes;
 
     ConsoleInit();
 
@@ -1374,22 +1403,11 @@ TclWinOpenConsoleChannel(
 	modes &= ~(ENABLE_WINDOW_INPUT | ENABLE_MOUSE_INPUT);
 	modes |= ENABLE_LINE_INPUT;
 	SetConsoleMode(infoPtr->handle, modes);
-
-	infoPtr->readable = CreateEvent(NULL, TRUE, TRUE, NULL);
-	infoPtr->startReader = CreateEvent(NULL, FALSE, FALSE, NULL);
-	infoPtr->stopReader = CreateEvent(NULL, FALSE, FALSE, NULL);
-	infoPtr->readThread = CreateThread(NULL, 256, ConsoleReaderThread,
-		infoPtr, 0, &id);
-	SetThreadPriority(infoPtr->readThread, THREAD_PRIORITY_HIGHEST);
+	StartChannelThread(infoPtr, &infoPtr->reader, ConsoleReaderThread);
     }
 
     if (permissions & TCL_WRITABLE) {
-	infoPtr->writable = CreateEvent(NULL, TRUE, TRUE, NULL);
-	infoPtr->startWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
-	infoPtr->stopWriter = CreateEvent(NULL, FALSE, FALSE, NULL);
-	infoPtr->writeThread = CreateThread(NULL, 256, ConsoleWriterThread,
-		infoPtr, 0, &id);
-	SetThreadPriority(infoPtr->writeThread, THREAD_PRIORITY_HIGHEST);
+	StartChannelThread(infoPtr, &infoPtr->writer, ConsoleWriterThread);
     }
 
     /*
@@ -1428,9 +1446,10 @@ ConsoleThreadActionProc(
     ClientData instanceData,
     int action)
 {
-    ConsoleInfo *infoPtr = (ConsoleInfo *) instanceData;
+    ConsoleInfo *infoPtr = instanceData;
 
-    /* We do not access firstConsolePtr in the thread structures. This is not
+    /*
+     * We do not access firstConsolePtr in the thread structures. This is not
      * for all serials managed by the thread, but only those we are watching.
      * Removal of the filevent handlers before transfer thus takes care of
      * this structure.
-- 
cgit v0.12


From c0089bebf222935ebedd937985ee0c73de5767de Mon Sep 17 00:00:00 2001
From: Joe Mistachkin <joe@mistachkin.com>
Date: Fri, 18 Nov 2011 01:01:37 +0000
Subject: For [testthread cancel], avoid creating a new Tcl_Obj when the
 default script cancellation result is desired.

---
 ChangeLog               | 5 +++++
 generic/tclThreadTest.c | 3 ++-
 2 files changed, 7 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 83e5703..0932130 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-11-17  Joe Mistachkin  <joe@mistachkin.com>
+
+	* generic/tclThreadTest.c: For [testthread cancel], avoid creating a
+	new Tcl_Obj when the default script cancellation result is desired.
+
 2011-11-11  Donal K. Fellows  <dkf@users.sf.net>
 
 	* win/tclWinConsole.c: Refactor common thread handling patterns.
diff --git a/generic/tclThreadTest.c b/generic/tclThreadTest.c
index 3345081..22b5995 100644
--- a/generic/tclThreadTest.c
+++ b/generic/tclThreadTest.c
@@ -988,7 +988,8 @@ ThreadCancel(
 
     Tcl_MutexUnlock(&threadMutex);
     Tcl_ResetResult(interp);
-    return Tcl_CancelEval(tsdPtr->interp, Tcl_NewStringObj(result, -1), 0, flags);
+    return Tcl_CancelEval(tsdPtr->interp,
+    	(result != NULL) ? Tcl_NewStringObj(result, -1) : NULL, 0, flags);
 }
 
 /*
-- 
cgit v0.12


From d385803da8e2091d19290b3bac2c38d8f2287581 Mon Sep 17 00:00:00 2001
From: Joe Mistachkin <joe@mistachkin.com>
Date: Fri, 18 Nov 2011 04:57:05 +0000
Subject: Refactor all the remaining thread-7.x tests that were using
 [testthread].  Note that this test file now requires the very latest version
 of the Thread package to pass all tests.  In addition, the thread-7.18 and
 thread-7.19 tests have been flagged as knownBug because they cannot pass
 without modifications to the [expr] command, persuant to TIP #392.

---
 ChangeLog         |   9 ++++
 tests/thread.test | 155 +++++++++++++++++++++++-------------------------------
 2 files changed, 76 insertions(+), 88 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 0932130..7a0df64 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,14 @@
 2011-11-17  Joe Mistachkin  <joe@mistachkin.com>
 
+	* tests/thread.test: Refactor all the remaining thread-7.x tests that
+	were using [testthread].  Note that this test file now requires the
+	very latest version of the Thread package to pass all tests.  In
+	addition, the thread-7.18 and thread-7.19 tests have been flagged as
+	knownBug because they cannot pass without modifications to the [expr]
+	command, persuant to TIP #392.
+
+2011-11-17  Joe Mistachkin  <joe@mistachkin.com>
+
 	* generic/tclThreadTest.c: For [testthread cancel], avoid creating a
 	new Tcl_Obj when the default script cancellation result is desired.
 
diff --git a/tests/thread.test b/tests/thread.test
index af4e4b6..936f725 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -19,6 +19,9 @@ if {[lsearch [namespace children] ::tcltest] == -1} {
 # Some tests require the testthread command
 
 testConstraint testthread [expr {[info commands testthread] != {}}]
+
+# Some tests require the Thread package
+
 testConstraint thread [expr {0 == [catch {package require Thread 2.7}]}]
 
 testConstraint notValgrind [expr {![testConstraint valgrind]}]
@@ -611,33 +614,30 @@ test thread-7.17 {cancel: expr -unwind} -constraints thread -setup {
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.18 {cancel: expr bignum} {testthread} {
-    threadReap
+test thread-7.18 {cancel: expr bignum} {thread knownBug} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
         set i [interp create]
-        interp alias $i testthread {} testthread
+	$i eval "package require -exact Thread [package present Thread]"
         $i eval {
             if {![info exists foo]} then {
                 # signal the primary thread that we are ready
                 # to be canceled now (we are running).
-                testthread send [testthread id -main] \
-                        [list set ::threadIdStarted [testthread id]]
+                thread::send %ID% [list set ::threadIdStarted [thread::id]]
                 set foo 1
             }
             #
-      # TODO: This will not cancel because libtommath
-      #       does not check Tcl_Canceled.
-      #
+            # BUGBUG: This will not cancel because libtommath
+            #         does not check Tcl_Canceled.
+            #
             expr {2**99999}
         }
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
+    set res [thread::cancel $serverthread]
+    thread::join $serverthread; # WARNING: Never returns due to bug (see above).
     list $res [expr {[info exists ::threadIdStarted] ? \
                   $::threadIdStarted == $serverthread : 0}] \
               [expr {[info exists ::threadId] ? \
@@ -645,33 +645,30 @@ test thread-7.18 {cancel: expr bignum} {testthread} {
               [expr {[info exists ::threadError] ? \
                   [lindex [split $::threadError \n] 0] : "" }]
 } {{} 1 0 {}}
-test thread-7.19 {cancel: expr bignum -unwind} {testthread} {
-    threadReap
+test thread-7.19 {cancel: expr bignum -unwind} {thread knownBug} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
         set i [interp create]
-        interp alias $i testthread {} testthread
+	$i eval "package require -exact Thread [package present Thread]"
         $i eval {
             if {![info exists foo]} then {
                 # signal the primary thread that we are ready
                 # to be canceled now (we are running).
-                testthread send [testthread id -main] \
-                        [list set ::threadIdStarted [testthread id]]
+                thread::send %ID% [list set ::threadIdStarted [thread::id]]
                 set foo 1
             }
             #
-      # TODO: This will not cancel because libtommath
-      #       does not check Tcl_Canceled.
-      #
+            # BUGBUG: This will not cancel because libtommath
+            #         does not check Tcl_Canceled.
+            #
             expr {2**99999}
         }
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    set res [testthread cancel -unwind $serverthread]
-    testthread join $serverthread
-    while {[testthread event]} {}; # force events to service
-    threadReap
+    set res [thread::cancel -unwind $serverthread]
+    thread::join $serverthread; # WARNING: Never returns due to bug (see above).
     list $res [expr {[info exists ::threadIdStarted] ? \
                   $::threadIdStarted == $serverthread : 0}] \
               [expr {[info exists ::threadId] ? \
@@ -791,17 +788,16 @@ test thread-7.23 {cancel: slave interp -unwind} -constraints {thread} -setup {
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.24 {cancel: nested catch inside pure bytecode loop} {notValgrind testthread} {
-    threadReap
+test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    while {1} {
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		catch {
@@ -818,14 +814,12 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {notValgrind t
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
+    set res [thread::cancel $serverthread]
     after 1000; # wait for ThreadErrorProc to be called.
-    while {[testthread event]} {}; # force events to service
-    catch {testthread send $serverthread {testthread exit}}
-    threadReap
+    catch {thread::release $serverthread}
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
@@ -833,10 +827,10 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {notValgrind t
 	      [expr {[info exists ::threadError] ? \
 		  [lindex [split $::threadError \n] 0] : "" }]
 } {{} 1 0 {}}
-test thread-7.25 {cancel: nested catch inside pure inside-command loop} {notValgrind testthread} {
-    threadReap
+test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    set catch catch
 	    set while while
@@ -844,8 +838,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {notValg
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		$catch {
@@ -862,14 +855,12 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {notValg
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    set res [testthread cancel $serverthread]
+    set res [thread::cancel $serverthread]
     after 1000; # wait for ThreadErrorProc to be called.
-    while {[testthread event]} {}; # force events to service
-    catch {testthread send $serverthread {testthread exit}}
-    threadReap
+    catch {thread::release $serverthread}
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
@@ -934,17 +925,16 @@ test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread} -se
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {notValgrind testthread} {
-    threadReap
+test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    while {1} {
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		catch {
@@ -961,14 +951,12 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {interp cancel}]
+    set res [thread::send -async $serverthread {interp cancel}]
     after 1000; # wait for ThreadErrorProc to be called.
-    while {[testthread event]} {}; # force events to service
-    catch {testthread send $serverthread {testthread exit}}
-    threadReap
+    catch {thread::release $serverthread}
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
@@ -976,10 +964,10 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo
 	      [expr {[info exists ::threadError] ? \
 		  [lindex [split $::threadError \n] 0] : "" }]
 } {{} 1 0 {}}
-test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {notValgrind testthread} {
-    threadReap
+test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    set catch catch
 	    set while while
@@ -987,8 +975,7 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		$catch {
@@ -1005,14 +992,12 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {interp cancel}]
+    set res [thread::send -async $serverthread {interp cancel}]
     after 1000; # wait for ThreadErrorProc to be called.
-    while {[testthread event]} {}; # force events to service
-    catch {testthread send $serverthread {testthread exit}}
-    threadReap
+    catch {thread::release $serverthread}
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
@@ -1020,17 +1005,16 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo
 	      [expr {[info exists ::threadError] ? \
 		  [lindex [split $::threadError \n] 0] : "" }]
 } {{} 1 0 {}}
-test thread-7.30 {cancel: send async testthread cancel nested catch inside pure bytecode loop} {notValgrind testthread} {
-    threadReap
+test thread-7.30 {cancel: send async thread cancel nested catch inside pure bytecode loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    while {1} {
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		catch {
@@ -1047,14 +1031,12 @@ test thread-7.30 {cancel: send async testthread cancel nested catch inside pure
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {testthread cancel [testthread id]}]
+    set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
     after 1000; # wait for ThreadErrorProc to be called.
-    while {[testthread event]} {}; # force events to service
-    catch {testthread send $serverthread {testthread exit}}
-    threadReap
+    catch {thread::release $serverthread}
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
@@ -1062,10 +1044,10 @@ test thread-7.30 {cancel: send async testthread cancel nested catch inside pure
 	      [expr {[info exists ::threadError] ? \
 		  [lindex [split $::threadError \n] 0] : "" }]
 } {{} 1 0 {}}
-test thread-7.31 {cancel: send async testthread cancel nested catch pure inside-command loop} {notValgrind testthread} {
-    threadReap
+test thread-7.31 {cancel: send async thread cancel nested catch pure inside-command loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
-    set serverthread [testthread create -joinable {
+    set serverthread [thread::create -joinable \
+	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    set catch catch
 	    set while while
@@ -1073,8 +1055,7 @@ test thread-7.31 {cancel: send async testthread cancel nested catch pure inside-
 		if {![info exists foo]} then {
 		    # signal the primary thread that we are ready
 		    # to be canceled now (we are running).
-		    testthread send [testthread id -main] \
-			    [list set ::threadIdStarted [testthread id]]
+		    thread::send %ID% [list set ::threadIdStarted [thread::id]]
 		    set foo 1
 		}
 		$catch {
@@ -1091,14 +1072,12 @@ test thread-7.31 {cancel: send async testthread cancel nested catch pure inside-
 	    }
 	}
 	foobar
-    }]
+    }]]
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
-    set res [testthread send -async $serverthread {testthread cancel [testthread id]}]
+    set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
     after 1000; # wait for ThreadErrorProc to be called.
-    while {[testthread event]} {}; # force events to service
-    catch {testthread send $serverthread {testthread exit}}
-    threadReap
+    catch {thread::release $serverthread}
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
-- 
cgit v0.12


From b924fb348d9b1220044506e8b77e33b34726c9dd Mon Sep 17 00:00:00 2001
From: Joe Mistachkin <joe@mistachkin.com>
Date: Fri, 18 Nov 2011 12:11:33 +0000
Subject: Remove all use of thread::release from the thread 7.x tests,
 replacing it with a script that can easily cause 'stuck' threads to
 self-destruct for those test cases that require it.  Also, make the error
 message handling far more robust by keeping track of every asynchronous
 error.

---
 ChangeLog         |   8 ++++
 tests/thread.test | 117 +++++++++++++++++++++++++++++++-----------------------
 2 files changed, 75 insertions(+), 50 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 7a0df64..2200e7e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2011-11-18  Joe Mistachkin  <joe@mistachkin.com>
+
+	* tests/thread.test: Remove all use of thread::release from the thread
+	7.x tests, replacing it with a script that can easily cause "stuck"
+	threads to self-destruct for those test cases that require it.  Also,
+	make the error message handling far more robust by keeping track of
+	every asynchronous error.
+
 2011-11-17  Joe Mistachkin  <joe@mistachkin.com>
 
 	* tests/thread.test: Refactor all the remaining thread-7.x tests that
diff --git a/tests/thread.test b/tests/thread.test
index 936f725..3eef85f 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -26,10 +26,21 @@ testConstraint thread [expr {0 == [catch {package require Thread 2.7}]}]
 
 testConstraint notValgrind [expr {![testConstraint valgrind]}]
 
+set threadSuperKillScript {
+    rename catch ""
+    rename while ""
+    rename update ""
+    thread::release
+}
+
+proc getThreadError { info } {
+    return [lindex [split [lindex $info 0] \n] 0]
+}
+
 proc ThreadError {id info} {
     global threadId threadError
     set threadId $id
-    set threadError $info
+    lappend threadError($id) $info
 }
 
 if {[testConstraint thread]} {
@@ -244,7 +255,7 @@ test thread-7.4 {cancel: pure bytecode loop} -constraints {thread} -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
@@ -274,7 +285,7 @@ test thread-7.5 {cancel: pure inside-command loop} -constraints {thread} -setup
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
@@ -303,7 +314,7 @@ test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread} -setu
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -333,7 +344,7 @@ test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints thread -
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -362,7 +373,7 @@ test thread-7.8 {cancel: pure bytecode loop custom result} -constraints thread -
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {the eval was canceled}}
@@ -394,7 +405,7 @@ test thread-7.9 {cancel: pure inside-command loop custom result} -constraints {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {the eval was canceled}}
@@ -425,7 +436,7 @@ test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {the eval was unwound}}
@@ -457,7 +468,7 @@ test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -const
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {the eval was unwound}}
@@ -481,7 +492,7 @@ test thread-7.12 {cancel: after} -constraints thread -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
@@ -505,7 +516,7 @@ test thread-7.13 {cancel: after -unwind} -constraints thread -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -529,7 +540,7 @@ test thread-7.14 {cancel: vwait} -constraints thread -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
@@ -553,7 +564,7 @@ test thread-7.15 {cancel: vwait -unwind} -constraints thread -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -582,7 +593,7 @@ test thread-7.16 {cancel: expr} -constraints thread -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
@@ -610,7 +621,7 @@ test thread-7.17 {cancel: expr -unwind} -constraints thread -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -642,8 +653,8 @@ test thread-7.18 {cancel: expr bignum} {thread knownBug} {
                   $::threadIdStarted == $serverthread : 0}] \
               [expr {[info exists ::threadId] ? \
                   $::threadId == $serverthread : 0}] \
-              [expr {[info exists ::threadError] ? \
-                  [lindex [split $::threadError \n] 0] : "" }]
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.19 {cancel: expr bignum -unwind} {thread knownBug} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -673,8 +684,8 @@ test thread-7.19 {cancel: expr bignum -unwind} {thread knownBug} {
                   $::threadIdStarted == $serverthread : 0}] \
               [expr {[info exists ::threadId] ? \
                   $::threadId == $serverthread : 0}] \
-              [expr {[info exists ::threadError] ? \
-                  [lindex [split $::threadError \n] 0] : "" }]
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.20 {cancel: subst} -constraints {thread} -setup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -700,7 +711,7 @@ test thread-7.20 {cancel: subst} -constraints {thread} -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
@@ -728,7 +739,7 @@ test thread-7.21 {cancel: subst -unwind} -constraints {thread} -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -756,7 +767,7 @@ test thread-7.22 {cancel: slave interp} -constraints {thread} -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
@@ -784,7 +795,7 @@ test thread-7.23 {cancel: slave interp -unwind} -constraints {thread} -setup {
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -819,13 +830,14 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread} {
     vwait ::threadIdStarted; after 1000
     set res [thread::cancel $serverthread]
     after 1000; # wait for ThreadErrorProc to be called.
-    catch {thread::release $serverthread}
+    thread::send $serverthread $::threadSuperKillScript
+    thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
+	      [expr {[info exists ::threadError($serverthread)] ? \
+		  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -860,17 +872,18 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread}
     vwait ::threadIdStarted; after 1000
     set res [thread::cancel $serverthread]
     after 1000; # wait for ThreadErrorProc to be called.
-    catch {thread::release $serverthread}
+    thread::send $serverthread $::threadSuperKillScript
+    thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
+	      [expr {[info exists ::threadError($serverthread)] ? \
+		  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
     unset -nocomplain ::threadIdStarted
-    set serverthread [thread::create -preserved \
+    set serverthread [thread::create -joinable \
 	[string map [list %ID% [thread::id]] {
 	proc foobar {} {
 	    while {1} {
@@ -889,7 +902,7 @@ test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
     vwait ::threadIdStarted
     catch {thread::send $serverthread {interp cancel -- bad}} msg
     thread::send -async $serverthread {interp cancel -unwind}
-    thread::release -wait $serverthread
+    thread::join $serverthread
     list [expr {$::threadIdStarted == $serverthread}] $msg
 } {1 {could not find interpreter "bad"}}
 test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread} -setup {
@@ -921,7 +934,7 @@ test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread} -se
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
@@ -956,13 +969,14 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {interp cancel}]
     after 1000; # wait for ThreadErrorProc to be called.
-    catch {thread::release $serverthread}
+    thread::send $serverthread $::threadSuperKillScript
+    thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
+	      [expr {[info exists ::threadError($serverthread)] ? \
+		  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -997,13 +1011,14 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {interp cancel}]
     after 1000; # wait for ThreadErrorProc to be called.
-    catch {thread::release $serverthread}
+    thread::send $serverthread $::threadSuperKillScript
+    thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
+	      [expr {[info exists ::threadError($serverthread)] ? \
+		  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.30 {cancel: send async thread cancel nested catch inside pure bytecode loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -1036,13 +1051,14 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
     after 1000; # wait for ThreadErrorProc to be called.
-    catch {thread::release $serverthread}
+    thread::send $serverthread $::threadSuperKillScript
+    thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
+	      [expr {[info exists ::threadError($serverthread)] ? \
+		  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.31 {cancel: send async thread cancel nested catch pure inside-command loop} {thread} {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -1077,13 +1093,14 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
     after 1000; # wait for ThreadErrorProc to be called.
-    catch {thread::release $serverthread}
+    thread::send $serverthread $::threadSuperKillScript
+    thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
-	      [expr {[info exists ::threadError] ? \
-		  [lindex [split $::threadError \n] 0] : "" }]
+	      [expr {[info exists ::threadError($serverthread)] ? \
+		  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
@@ -1118,7 +1135,7 @@ test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -const
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -1157,7 +1174,7 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind}
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -1196,7 +1213,7 @@ test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode lo
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -1237,7 +1254,7 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -1276,7 +1293,7 @@ test thread-7.36 {cancel: send async thread cancel nested catch inside pure byte
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
@@ -1317,7 +1334,7 @@ test thread-7.37 {cancel: send async thread cancel nested catch inside pure insi
     thread::join $serverthread
     list $res [expr {$::threadIdStarted == $serverthread}] \
 	      [expr {$::threadId == $serverthread}] \
-	      [lindex [split $::threadError \n] 0]
+	      [getThreadError $::threadError($serverthread)]
 } -cleanup {
     unset -nocomplain ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-- 
cgit v0.12


From 0e4ed9f2c8f843a030690790b240153c0a297928 Mon Sep 17 00:00:00 2001
From: Joe Mistachkin <joe@mistachkin.com>
Date: Mon, 21 Nov 2011 01:26:27 +0000
Subject: Remove unnecessary [after] calls from the thread tests.  Make error
 message matching more robust for tests that may have built-in race
 conditions.  Test thread-7.26 must first unset all thread testing related
 variables.

---
 ChangeLog         |  7 +++++++
 tests/thread.test | 22 ++++++++++++++--------
 2 files changed, 21 insertions(+), 8 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 2200e7e..190984e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2011-11-20  Joe Mistachkin  <joe@mistachkin.com>
+
+	* tests/thread.test: Remove unnecessary [after] calls from the thread
+	tests.  Make error message matching more robust for tests that may
+	have built-in race conditions.  Test thread-7.26 must first unset all
+	thread testing related variables.
+
 2011-11-18  Joe Mistachkin  <joe@mistachkin.com>
 
 	* tests/thread.test: Remove all use of thread::release from the thread
diff --git a/tests/thread.test b/tests/thread.test
index 3eef85f..a09d457 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -29,12 +29,24 @@ testConstraint notValgrind [expr {![testConstraint valgrind]}]
 set threadSuperKillScript {
     rename catch ""
     rename while ""
+    rename unknown ""
     rename update ""
     thread::release
 }
 
 proc getThreadError { info } {
-    return [lindex [split [lindex $info 0] \n] 0]
+    foreach error [lreverse $info] {
+        set list [split $error \n]
+        set idx [lsearch -glob $list "*eval*unwound*"]
+        if {$idx != -1} then {
+          return [lindex $list $idx]
+        }
+        set idx [lsearch -glob $list "*eval*canceled*"]
+        if {$idx != -1} then {
+          return [lindex $list $idx]
+        }
+    }
+    return ""; # some other error we do not care about.
 }
 
 proc ThreadError {id info} {
@@ -829,7 +841,6 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread} {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     set res [thread::cancel $serverthread]
-    after 1000; # wait for ThreadErrorProc to be called.
     thread::send $serverthread $::threadSuperKillScript
     thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
@@ -871,7 +882,6 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread}
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     set res [thread::cancel $serverthread]
-    after 1000; # wait for ThreadErrorProc to be called.
     thread::send $serverthread $::threadSuperKillScript
     thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
@@ -882,7 +892,7 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread}
 		  [getThreadError $::threadError($serverthread)] : "" }]
 } {{} 1 0 {}}
 test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
-    unset -nocomplain ::threadIdStarted
+    unset -nocomplain ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	[string map [list %ID% [thread::id]] {
 	proc foobar {} {
@@ -968,7 +978,6 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {interp cancel}]
-    after 1000; # wait for ThreadErrorProc to be called.
     thread::send $serverthread $::threadSuperKillScript
     thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
@@ -1010,7 +1019,6 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {interp cancel}]
-    after 1000; # wait for ThreadErrorProc to be called.
     thread::send $serverthread $::threadSuperKillScript
     thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
@@ -1050,7 +1058,6 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
-    after 1000; # wait for ThreadErrorProc to be called.
     thread::send $serverthread $::threadSuperKillScript
     thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
@@ -1092,7 +1099,6 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
-    after 1000; # wait for ThreadErrorProc to be called.
     thread::send $serverthread $::threadSuperKillScript
     thread::join $serverthread
     list $res [expr {[info exists ::threadIdStarted] ? \
-- 
cgit v0.12


From 9826002d2164966a047b32a63935ca28020f46b0 Mon Sep 17 00:00:00 2001
From: Joe Mistachkin <joe@mistachkin.com>
Date: Mon, 21 Nov 2011 05:51:26 +0000
Subject: Revise results of the thread-7.28 through thread-7.31 tests to
 account for the fact they are canceled via a script sent to the thread
 asynchronously, which then impacts the error message handling.  Attempt to
 manually drain the event queue for the main thread after joining the test
 thread to make sure no stray events are processed at the wrong time on the
 main thread.  Revise all the synchronization and comparison semantics related
 to the thread id and error message.

---
 ChangeLog         |   9 +-
 tests/thread.test | 558 +++++++++++++++++++++++++++++++-----------------------
 2 files changed, 330 insertions(+), 237 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 190984e..c11a0ee 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -3,7 +3,14 @@
 	* tests/thread.test: Remove unnecessary [after] calls from the thread
 	tests.  Make error message matching more robust for tests that may
 	have built-in race conditions.  Test thread-7.26 must first unset all
-	thread testing related variables.
+	thread testing related variables.  Revise results of the thread-7.28
+	through thread-7.31 tests to account for the fact they are canceled
+	via a script sent to the thread asynchronously, which then impacts the
+	error message handling.  Attempt to manually drain the event queue for
+	the main thread after joining the test thread to make sure no stray
+	events are processed at the wrong time on the main thread.  Revise all
+	the synchronization and comparison semantics related to the thread id
+	and error message.
 
 2011-11-18  Joe Mistachkin  <joe@mistachkin.com>
 
diff --git a/tests/thread.test b/tests/thread.test
index a09d457..44789fa 100644
--- a/tests/thread.test
+++ b/tests/thread.test
@@ -24,6 +24,8 @@ testConstraint testthread [expr {[info commands testthread] != {}}]
 
 testConstraint thread [expr {0 == [catch {package require Thread 2.7}]}]
 
+# Some tests may not work under valgrind
+
 testConstraint notValgrind [expr {![testConstraint valgrind]}]
 
 set threadSuperKillScript {
@@ -34,25 +36,37 @@ set threadSuperKillScript {
     thread::release
 }
 
-proc getThreadError { info } {
+proc getThreadErrorFromInfo { info } {
+    set list [split $info \n]
+    set idx [lsearch -glob $list "*eval*unwound*"]
+    if {$idx != -1} then {
+        return [lindex $list $idx]
+    }
+    set idx [lsearch -glob $list "*eval*canceled*"]
+    if {$idx != -1} then {
+        return [lindex $list $idx]
+    }
+    return ""; # some other error we do not care about.
+}
+
+proc findThreadError { info } {
     foreach error [lreverse $info] {
-        set list [split $error \n]
-        set idx [lsearch -glob $list "*eval*unwound*"]
-        if {$idx != -1} then {
-          return [lindex $list $idx]
-        }
-        set idx [lsearch -glob $list "*eval*canceled*"]
-        if {$idx != -1} then {
-          return [lindex $list $idx]
+        set error [getThreadErrorFromInfo $error]
+        if {[string length $error] > 0} then {
+            return $error
         }
     }
     return ""; # some other error we do not care about.
 }
 
 proc ThreadError {id info} {
-    global threadId threadError
-    set threadId $id
-    lappend threadError($id) $info
+    global threadSawError
+    if {[string length [getThreadErrorFromInfo $info]] > 0} then {
+        global threadId threadError
+        set threadId $id
+        lappend threadError($id) $info
+    }
+    set threadSawError($id) true; # signal main thread to exit [vwait].
 }
 
 if {[testConstraint thread]} {
@@ -60,6 +74,12 @@ if {[testConstraint thread]} {
 }
 
 if {[testConstraint testthread]} {
+    proc drainEventQueue {} {
+	while {[set x [testthread event]]} {
+	    puts "WARNING: drained $x event(s) on main thread"
+	}
+    }
+
     testthread errorproc ThreadError
 
     set mainThread [testthread id]
@@ -85,6 +105,10 @@ if {[testConstraint testthread]} {
     }
 }
 
+# Some tests require manual draining of the event queue
+
+testConstraint drainEventQueue [expr {[info commands drainEventQueue] != {}}]
+
 test thread-1.3 {Tcl_ThreadObjCmd: initial thread list} {thread} {
     llength [thread::names]
 } 1
@@ -242,8 +266,8 @@ test thread-6.1 {freeing very large object trees in a thread} thread {
 } 0
 
 # TIP #285: Script cancellation support
-test thread-7.4 {cancel: pure bytecode loop} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.4 {cancel: pure bytecode loop} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -263,16 +287,18 @@ test thread-7.4 {cancel: pure bytecode loop} -constraints {thread} -setup {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::cancel $serverthread]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.5 {cancel: pure inside-command loop} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.5 {cancel: pure inside-command loop} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -291,18 +317,20 @@ test thread-7.5 {cancel: pure inside-command loop} -constraints {thread} -setup
 	foobar
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -320,18 +348,20 @@ test thread-7.6 {cancel: pure bytecode loop -unwind} -constraints {thread} -setu
 	foobar
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints thread -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -350,18 +380,20 @@ test thread-7.7 {cancel: pure inside-command loop -unwind} -constraints thread -
 	foobar
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.8 {cancel: pure bytecode loop custom result} -constraints thread -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.8 {cancel: pure bytecode loop custom result} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -379,20 +411,23 @@ test thread-7.8 {cancel: pure bytecode loop custom result} -constraints thread -
 	foobar
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel $serverthread "the eval was canceled"]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {the eval was canceled}}
 test thread-7.9 {cancel: pure inside-command loop custom result} -constraints {
     thread
+    drainEventQueue
 } -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -411,20 +446,23 @@ test thread-7.9 {cancel: pure inside-command loop custom result} -constraints {
 	foobar
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel $serverthread "the eval was canceled"]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {the eval was canceled}}
 test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints {
     thread
+    drainEventQueue
 } -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -442,20 +480,23 @@ test thread-7.10 {cancel: pure bytecode loop custom result -unwind} -constraints
 	foobar
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread "the eval was unwound"]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {the eval was unwound}}
 test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -constraints {
     thread
+    drainEventQueue
 } -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -474,18 +515,20 @@ test thread-7.11 {cancel: pure inside-command loop custom result -unwind} -const
 	foobar
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread "the eval was unwound"]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {the eval was unwound}}
-test thread-7.12 {cancel: after} -constraints thread -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.12 {cancel: after} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -498,18 +541,20 @@ test thread-7.12 {cancel: after} -constraints thread -setup {
 	after 30000
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.13 {cancel: after -unwind} -constraints thread -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.13 {cancel: after -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -522,18 +567,20 @@ test thread-7.13 {cancel: after -unwind} -constraints thread -setup {
 	after 30000
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.14 {cancel: vwait} -constraints thread -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.14 {cancel: vwait} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID [thread::id]] {
@@ -546,18 +593,20 @@ test thread-7.14 {cancel: vwait} -constraints thread -setup {
 	vwait forever
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.15 {cancel: vwait -unwind} -constraints thread -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.15 {cancel: vwait -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -570,18 +619,20 @@ test thread-7.15 {cancel: vwait -unwind} -constraints thread -setup {
 	vwait forever
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.16 {cancel: expr} -constraints thread -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.16 {cancel: expr} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID [thread::id]] {
@@ -599,18 +650,20 @@ test thread-7.16 {cancel: expr} -constraints thread -setup {
 	}
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.17 {cancel: expr -unwind} -constraints thread -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.17 {cancel: expr -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -627,18 +680,20 @@ test thread-7.17 {cancel: expr -unwind} -constraints thread -setup {
 	}
     }]]
     # wait for other thread to signal "ready to cancel"
-    vwait threadIdStarted
+    vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.18 {cancel: expr bignum} {thread knownBug} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.18 {cancel: expr bignum} {thread drainEventQueue knownBug} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
         set i [interp create]
@@ -660,16 +715,17 @@ test thread-7.18 {cancel: expr bignum} {thread knownBug} {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     set res [thread::cancel $serverthread]
-    thread::join $serverthread; # WARNING: Never returns due to bug (see above).
+    vwait ::threadSawError($serverthread); # WARNING: Never returns (see above).
+    thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above).
     list $res [expr {[info exists ::threadIdStarted] ? \
                   $::threadIdStarted == $serverthread : 0}] \
               [expr {[info exists ::threadId] ? \
                   $::threadId == $serverthread : 0}] \
               [expr {[info exists ::threadError($serverthread)] ? \
-                  [getThreadError $::threadError($serverthread)] : "" }]
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } {{} 1 0 {}}
-test thread-7.19 {cancel: expr bignum -unwind} {thread knownBug} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.19 {cancel: expr bignum -unwind} {thread drainEventQueue knownBug} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
         set i [interp create]
@@ -691,16 +747,17 @@ test thread-7.19 {cancel: expr bignum -unwind} {thread knownBug} {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted; after 1000
     set res [thread::cancel -unwind $serverthread]
-    thread::join $serverthread; # WARNING: Never returns due to bug (see above).
+    vwait ::threadSawError($serverthread); # WARNING: Never returns (see above).
+    thread::join $serverthread; drainEventQueue; # WARNING: Never returns (see above).
     list $res [expr {[info exists ::threadIdStarted] ? \
                   $::threadIdStarted == $serverthread : 0}] \
               [expr {[info exists ::threadId] ? \
                   $::threadId == $serverthread : 0}] \
               [expr {[info exists ::threadError($serverthread)] ? \
-                  [getThreadError $::threadError($serverthread)] : "" }]
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } {{} 1 0 {}}
-test thread-7.20 {cancel: subst} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.20 {cancel: subst} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -719,16 +776,18 @@ test thread-7.20 {cancel: subst} -constraints {thread} -setup {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::cancel $serverthread]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.21 {cancel: subst -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.21 {cancel: subst -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -747,16 +806,18 @@ test thread-7.21 {cancel: subst -unwind} -constraints {thread} -setup {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.22 {cancel: slave interp} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.22 {cancel: slave interp} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -775,16 +836,18 @@ test thread-7.22 {cancel: slave interp} -constraints {thread} -setup {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::cancel $serverthread]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.23 {cancel: slave interp -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.23 {cancel: slave interp -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -803,16 +866,18 @@ test thread-7.23 {cancel: slave interp -unwind} -constraints {thread} -setup {
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread drainEventQueue} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
@@ -842,16 +907,17 @@ test thread-7.24 {cancel: nested catch inside pure bytecode loop} {thread} {
     vwait ::threadIdStarted; after 1000
     set res [thread::cancel $serverthread]
     thread::send $serverthread $::threadSuperKillScript
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
 	      [expr {[info exists ::threadError($serverthread)] ? \
-		  [getThreadError $::threadError($serverthread)] : "" }]
+		  [findThreadError $::threadError($serverthread)] : ""}]
 } {{} 1 0 {}}
-test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread drainEventQueue} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
@@ -883,16 +949,17 @@ test thread-7.25 {cancel: nested catch inside pure inside-command loop} {thread}
     vwait ::threadIdStarted; after 1000
     set res [thread::cancel $serverthread]
     thread::send $serverthread $::threadSuperKillScript
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
 	      [expr {[info exists ::threadError($serverthread)] ? \
-		  [getThreadError $::threadError($serverthread)] : "" }]
+		  [findThreadError $::threadError($serverthread)] : ""}]
 } {{} 1 0 {}}
-test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.26 {cancel: send async cancel bad interp path} {thread drainEventQueue} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	[string map [list %ID% [thread::id]] {
 	proc foobar {} {
@@ -912,11 +979,12 @@ test thread-7.26 {cancel: send async cancel bad interp path} {thread} {
     vwait ::threadIdStarted
     catch {thread::send $serverthread {interp cancel -- bad}} msg
     thread::send -async $serverthread {interp cancel -unwind}
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list [expr {$::threadIdStarted == $serverthread}] $msg
 } {1 {could not find interpreter "bad"}}
-test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -940,16 +1008,18 @@ test thread-7.27 {cancel: send async cancel -- switch} -constraints {thread} -se
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::send -async $serverthread {interp cancel -- -unwind}]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval canceled}}
-test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {thread} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode loop} {thread drainEventQueue} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
@@ -979,16 +1049,17 @@ test thread-7.28 {cancel: send async cancel nested catch inside pure bytecode lo
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {interp cancel}]
     thread::send $serverthread $::threadSuperKillScript
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
 	      [expr {[info exists ::threadError($serverthread)] ? \
-		  [getThreadError $::threadError($serverthread)] : "" }]
-} {{} 1 0 {}}
-test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {thread} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+		  [findThreadError $::threadError($serverthread)] : ""}]
+} {{} 1 1 {eval canceled}}
+test thread-7.29 {cancel: send async cancel nested catch pure inside-command loop} {thread drainEventQueue} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
@@ -1020,16 +1091,17 @@ test thread-7.29 {cancel: send async cancel nested catch pure inside-command loo
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {interp cancel}]
     thread::send $serverthread $::threadSuperKillScript
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
 	      [expr {[info exists ::threadError($serverthread)] ? \
-		  [getThreadError $::threadError($serverthread)] : "" }]
-} {{} 1 0 {}}
-test thread-7.30 {cancel: send async thread cancel nested catch inside pure bytecode loop} {thread} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+		  [findThreadError $::threadError($serverthread)] : ""}]
+} {{} 1 1 {eval canceled}}
+test thread-7.30 {cancel: send async thread cancel nested catch inside pure bytecode loop} {thread drainEventQueue} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
@@ -1059,16 +1131,17 @@ test thread-7.30 {cancel: send async thread cancel nested catch inside pure byte
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
     thread::send $serverthread $::threadSuperKillScript
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
 	      [expr {[info exists ::threadError($serverthread)] ? \
-		  [getThreadError $::threadError($serverthread)] : "" }]
-} {{} 1 0 {}}
-test thread-7.31 {cancel: send async thread cancel nested catch pure inside-command loop} {thread} {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+		  [findThreadError $::threadError($serverthread)] : ""}]
+} {{} 1 1 {eval canceled}}
+test thread-7.31 {cancel: send async thread cancel nested catch pure inside-command loop} {thread drainEventQueue} {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
 	proc foobar {} {
@@ -1100,16 +1173,17 @@ test thread-7.31 {cancel: send async thread cancel nested catch pure inside-comm
     vwait ::threadIdStarted; after 1000
     set res [thread::send -async $serverthread {thread::cancel [thread::id]}]
     thread::send $serverthread $::threadSuperKillScript
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {[info exists ::threadIdStarted] ? \
 		  $::threadIdStarted == $serverthread : 0}] \
 	      [expr {[info exists ::threadId] ? \
 		  $::threadId == $serverthread : 0}] \
 	      [expr {[info exists ::threadError($serverthread)] ? \
-		  [getThreadError $::threadError($serverthread)] : "" }]
-} {{} 1 0 {}}
-test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+		  [findThreadError $::threadError($serverthread)] : ""}]
+} {{} 1 1 {eval canceled}}
+test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -1137,16 +1211,18 @@ test thread-7.32 {cancel: nested catch inside pure bytecode loop -unwind} -const
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -1176,16 +1252,18 @@ test thread-7.33 {cancel: nested catch inside pure inside-command loop -unwind}
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::cancel -unwind $serverthread]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -1215,16 +1293,18 @@ test thread-7.34 {cancel: send async cancel nested catch inside pure bytecode lo
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::send -async $serverthread {interp cancel -unwind}]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.35 {cancel: send async cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -1256,16 +1336,18 @@ test thread-7.35 {cancel: send async cancel nested catch inside pure inside-comm
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::send -async $serverthread {interp cancel -unwind}]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.36 {cancel: send async thread cancel nested catch inside pure bytecode loop -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID% [thread::id]] {
@@ -1295,16 +1377,18 @@ test thread-7.36 {cancel: send async thread cancel nested catch inside pure byte
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
-test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread} -setup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+test thread-7.37 {cancel: send async thread cancel nested catch inside pure inside-command loop -unwind} -constraints {thread drainEventQueue} -setup {
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -body {
     set serverthread [thread::create -joinable \
 	    [string map [list %ID [thread::id]] {
@@ -1336,13 +1420,15 @@ test thread-7.37 {cancel: send async thread cancel nested catch inside pure insi
     # wait for other thread to signal "ready to cancel"
     vwait ::threadIdStarted
     set res [thread::send -async $serverthread {thread::cancel -unwind [thread::id]}]
-    vwait ::threadId
-    thread::join $serverthread
+    vwait ::threadSawError($serverthread)
+    thread::join $serverthread; drainEventQueue
     list $res [expr {$::threadIdStarted == $serverthread}] \
-	      [expr {$::threadId == $serverthread}] \
-	      [getThreadError $::threadError($serverthread)]
+              [expr {[info exists ::threadId] ? \
+                  $::threadId == $serverthread : 0}] \
+              [expr {[info exists ::threadError($serverthread)] ? \
+                  [findThreadError $::threadError($serverthread)] : ""}]
 } -cleanup {
-    unset -nocomplain ::threadError ::threadId ::threadIdStarted
+    unset -nocomplain ::threadSawError ::threadError ::threadId ::threadIdStarted
 } -result {{} 1 1 {eval unwound}}
 
 # cleanup
-- 
cgit v0.12


From d7d710f3ff4ee669067644f9e32149aabf6629a1 Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Mon, 21 Nov 2011 18:12:15 +0000
Subject: Fixed typo in a comment.

---
 generic/tclBasic.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d10e8e6..0365966 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -5949,7 +5949,7 @@ TclNREvalObjEx(
 
     /*
      * This function consists of three independent blocks for: direct
-     * evaluation of canonical lists, compileation and bytecode execution and
+     * evaluation of canonical lists, compilation and bytecode execution and
      * finally direct evaluation. Precisely one of these blocks will be run.
      */
 
-- 
cgit v0.12


From df6dfc34691563ae25dc7970f47e3b29c66c4dec Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Mon, 21 Nov 2011 18:23:16 +0000
Subject: Fix a bug where global precompiled code (A) called from a precompiled
 procedure causes the core to recompile (A), triggering the trap laid inside,
 i.e. 'error "called a copy of compiled code"'.

<pre>Example
----------------------ex1.tcl
proc init {} {
    source ex2.tcl
}
init
----------------------ex2.tcl
puts a
----------------------</pre>

When run as precompiled code the 'puts a' is not executed, only the trap.

Fixed by enclosing the offending code into a guard which prevents its
execution for precompiled code. The change passes the entire testsuite.
---
 generic/tclExecute.c | 16 +++++++++-------
 1 file changed, 9 insertions(+), 7 deletions(-)

diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 953c63e..b7c576a 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -1652,14 +1652,16 @@ TclCompileObj(
 	    }
 	}
 
-	if (codePtr->procPtr == NULL) {
-	    /*
-	     * Check that any compiled locals do refer to the current proc
-	     * environment! If not, recompile.
-	     */
+	if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
+	    if (codePtr->procPtr == NULL) {
+		/*
+		 * Check that any compiled locals do refer to the current proc
+		 * environment! If not, recompile.
+		 */
 
-	    if (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr) {
-		goto recompileObj;
+		if (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr) {
+		    goto recompileObj;
+		}
 	    }
 	}
 
-- 
cgit v0.12


From c5a1e89cc8d9f34ca57886a2527f484ed21e3902 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 22 Nov 2011 13:07:58 +0000
Subject: Make some of the logic in TclCompileObj less heavily nested, to
 improve clarity.

---
 ChangeLog            |   7 +-
 generic/tclExecute.c | 197 +++++++++++++++++++++++++--------------------------
 2 files changed, 104 insertions(+), 100 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index f439c76..76623c2 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,11 @@
+2011-11-22  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclExecute.c (TclCompileObj): Simplify and de-indent the
+	logic so that it is easier to comprehend.
+
 2011-11-22  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinPort.h:   [Bug 2935503] Windows: file mtime
+	* win/tclWinPort.h:   [Bug 2935503]: Windows: file mtime
 	* win/tclWinFile.c:  sets wrong time (VS2005+ only)
 	* generic/tclTest.c:
 
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index b7c576a..92b6612 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -179,23 +179,25 @@ typedef struct TEBCdata {
     Tcl_Obj *auxObjList;	/* execution. */
     int checkInterp;
     CmdFrame cmdFrame;
-    void * stack[1];            /* Start of the actual combined catch and obj
+    void *stack[1];		/* Start of the actual combined catch and obj
 				 * stacks; the struct will be expanded as
 				 * necessary */
 } TEBCdata;
 
-#define TEBC_YIELD()					\
-    esPtr->tosPtr = tosPtr;				\
-    TD->pc = pc;					\
-    TD->cleanup = cleanup;				\
-    TclNRAddCallback(interp, TEBCresume, TD,	\
-	    INT2PTR(1), NULL, NULL)
-    
+#define TEBC_YIELD() \
+    do {								\
+	esPtr->tosPtr = tosPtr;						\
+	TD->pc = pc;							\
+	TD->cleanup = cleanup;						\
+	TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \
+    } while (0)
+
 #define TEBC_DATA_DIG() \
-    pc = TD->pc;				\
-    cleanup = TD->cleanup;			\
-    tosPtr = esPtr->tosPtr
-    
+    do {					\
+	pc = TD->pc;				\
+	cleanup = TD->cleanup;			\
+	tosPtr = esPtr->tosPtr;			\
+    } while (0)
 
 #define PUSH_TAUX_OBJ(objPtr) \
     do {							\
@@ -347,7 +349,7 @@ VarHashCreateVar(
 
 #ifdef TCL_COMPILE_DEBUG
 #   define TRACE(a) \
-    while (traceInstructions) {				\
+    while (traceInstructions) {					\
 	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels,	\
 		(int) CURR_DEPTH,				\
 		(unsigned) (pc - codePtr->codeStart),		\
@@ -356,12 +358,12 @@ VarHashCreateVar(
 	break;							\
     }
 #   define TRACE_APPEND(a) \
-    while (traceInstructions) {	\
+    while (traceInstructions) {		\
 	printf a;			\
 	break;				\
     }
 #   define TRACE_WITH_OBJ(a, objPtr) \
-    while (traceInstructions) {				\
+    while (traceInstructions) {					\
 	fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels,	\
 		(int) CURR_DEPTH,				\
 		(unsigned) (pc - codePtr->codeStart),		\
@@ -387,13 +389,13 @@ VarHashCreateVar(
 #define TCL_DTRACE_INST_NEXT() \
     do {								\
 	if (TCL_DTRACE_INST_DONE_ENABLED()) {				\
-	    if (curInstName) {					\
-		TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, \
+	    if (curInstName) {						\
+		TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH,	\
 			tosPtr);					\
 	    }								\
 	    curInstName = tclInstructionTable[*pc].name;		\
 	    if (TCL_DTRACE_INST_START_ENABLED()) {			\
-		TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, \
+		TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH,	\
 			tosPtr);					\
 	    }								\
 	} else if (TCL_DTRACE_INST_START_ENABLED()) {			\
@@ -403,7 +405,7 @@ VarHashCreateVar(
     } while (0)
 #define TCL_DTRACE_INST_LAST() \
     do {								\
-	if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {	\
+	if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {		\
 	    TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
 	}								\
     } while (0)
@@ -1257,7 +1259,7 @@ TclStackFree(
 	eePtr->execStackPtr = esPtr->prevPtr;
     } else {
 	eePtr->execStackPtr = esPtr;
-    }	
+    }
 }
 
 void *
@@ -1591,13 +1593,13 @@ FreeExprCodeInternalRep(
  *
  * TclCompileObj --
  *
- *	This procedure compiles the script contained in a Tcl_Obj
+ *	This procedure compiles the script contained in a Tcl_Obj.
  *
  * Results:
  *	A pointer to the corresponding ByteCode, never NULL.
  *
  * Side effects:
- *	The object is shimmered to bytecode type
+ *	The object is shimmered to bytecode type.
  *
  *----------------------------------------------------------------------
  */
@@ -1642,27 +1644,24 @@ TclCompileObj(
 		|| (codePtr->compileEpoch != iPtr->compileEpoch)
 		|| (codePtr->nsPtr != namespacePtr)
 		|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
-	    if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
-		if ((Interp *) *codePtr->interpHandle != iPtr) {
-		    Tcl_Panic("Tcl_EvalObj: compiled script jumped interps");
-		}
-		codePtr->compileEpoch = iPtr->compileEpoch;
-	    } else {
+	    if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
 		goto recompileObj;
 	    }
+	    if ((Interp *) *codePtr->interpHandle != iPtr) {
+		Tcl_Panic("Tcl_EvalObj: compiled script jumped interps");
+	    }
+	    codePtr->compileEpoch = iPtr->compileEpoch;
 	}
 
-	if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
-	    if (codePtr->procPtr == NULL) {
-		/*
-		 * Check that any compiled locals do refer to the current proc
-		 * environment! If not, recompile.
-		 */
+	/*
+	 * Check that any compiled locals do refer to the current proc
+	 * environment! If not, recompile.
+	 */
 
-		if (codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr) {
-		    goto recompileObj;
-		}
-	    }
+	if (!(codePtr->flags & TCL_BYTECODE_PRECOMPILED) &&
+		(codePtr->procPtr == NULL) &&
+		(codePtr->localCachePtr != iPtr->varFramePtr->localCachePtr)){
+	    goto recompileObj;
 	}
 
 	/*
@@ -1694,15 +1693,13 @@ TclCompileObj(
 	 *     information.
 	 */
 
-	if (!invoker) {
+	if (invoker == NULL) {
 	    return codePtr;
-	}
-	
-	{
+	} else {
 	    Tcl_HashEntry *hePtr =
 		    Tcl_FindHashEntry(iPtr->lineBCPtr, codePtr);
 	    ExtCmdLoc *eclPtr;
-	    CmdFrame *ctxPtr;
+	    CmdFrame *ctxCopyPtr;
 	    int redo;
 
 	    if (!hePtr) {
@@ -1711,8 +1708,8 @@ TclCompileObj(
 
 	    eclPtr = Tcl_GetHashValue(hePtr);
 	    redo = 0;
-	    ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame));
-	    *ctxPtr = *invoker;
+	    ctxCopyPtr = TclStackAlloc(interp, sizeof(CmdFrame));
+	    *ctxCopyPtr = *invoker;
 
 	    if (invoker->type == TCL_LOCATION_BC) {
 		/*
@@ -1720,18 +1717,18 @@ TclCompileObj(
 		 *		    ctx.data.tebc.codePtr used instead
 		 */
 
-		TclGetSrcInfoForPc(ctxPtr);
-		if (ctxPtr->type == TCL_LOCATION_SOURCE) {
+		TclGetSrcInfoForPc(ctxCopyPtr);
+		if (ctxCopyPtr->type == TCL_LOCATION_SOURCE) {
 		    /*
 		     * The reference made by 'TclGetSrcInfoForPc' is dead.
 		     */
 
-		    Tcl_DecrRefCount(ctxPtr->data.eval.path);
-		    ctxPtr->data.eval.path = NULL;
+		    Tcl_DecrRefCount(ctxCopyPtr->data.eval.path);
+		    ctxCopyPtr->data.eval.path = NULL;
 		}
 	    }
 
-	    if (word < ctxPtr->nline) {
+	    if (word < ctxCopyPtr->nline) {
 		/*
 		 * Note: We do not care if the line[word] is -1. This is a
 		 * difference and requires a recompile (location changed from
@@ -1744,12 +1741,12 @@ TclCompileObj(
 		 */
 
 		redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
-			    && (eclPtr->start != ctxPtr->line[word]))
+			    && (eclPtr->start != ctxCopyPtr->line[word]))
 			|| ((eclPtr->type == TCL_LOCATION_BC)
-			    && (ctxPtr->type == TCL_LOCATION_SOURCE));
+			    && (ctxCopyPtr->type == TCL_LOCATION_SOURCE));
 	    }
 
-	    TclStackFree(interp, ctxPtr);
+	    TclStackFree(interp, ctxCopyPtr);
 	    if (!redo) {
 		return codePtr;
 	    }
@@ -1768,7 +1765,7 @@ TclCompileObj(
 
     iPtr->invokeCmdFramePtr = invoker;
     iPtr->invokeWord = word;
-    tclByteCodeType.setFromAnyProc(interp, objPtr);
+    TclSetByteCodeFromAny(interp, objPtr, NULL, NULL);
     iPtr->invokeCmdFramePtr = NULL;
     codePtr = objPtr->internalRep.otherValuePtr;
     if (iPtr->varFramePtr->localCachePtr) {
@@ -1925,7 +1922,7 @@ TclIncrObj(
 #define	bcFramePtr	(&TD->cmdFrame)
 #define	initCatchTop	((ptrdiff_t *) (&TD->stack[-1]))
 #define	initTosPtr	((Tcl_Obj **) (initCatchTop+codePtr->maxExceptDepth))
-#define esPtr           (iPtr->execEnvPtr->execStackPtr)
+#define esPtr		(iPtr->execEnvPtr->execStackPtr)
 
 int
 TclNRExecuteByteCode(
@@ -1934,15 +1931,15 @@ TclNRExecuteByteCode(
 {
     Interp *iPtr = (Interp *) interp;
     TEBCdata *TD;
-    int size = sizeof(TEBCdata) -1 + 
+    int size = sizeof(TEBCdata) - 1
 	    + (codePtr->maxStackDepth + codePtr->maxExceptDepth)
-	         *(sizeof(void *));
-    int numWords = (size + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *);
-    
+		* sizeof(void *);
+    int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
+
     if (iPtr->execEnvPtr->rewind) {
 	return TCL_ERROR;
     }
-    
+
     codePtr->refCount++;
 
     /*
@@ -1959,14 +1956,14 @@ TclNRExecuteByteCode(
 
     TD = (TEBCdata *) GrowEvaluationStack(iPtr->execEnvPtr, numWords, 0);
     esPtr->tosPtr = initTosPtr;
-    
+
     TD->codePtr     = codePtr;
-    TD->pc          = codePtr->codeStart;
+    TD->pc	    = codePtr->codeStart;
     TD->catchTop    = initCatchTop;
     TD->cleanup     = 0;
     TD->auxObjList  = NULL;
     TD->checkInterp = 0;
-    
+
     /*
      * TIP #280: Initialize the frame. Do not push it yet: it will be pushed
      * every time that we call out from this TD, popped when we return to it.
@@ -1993,7 +1990,7 @@ TclNRExecuteByteCode(
     /*
      * Push the callback for bytecode execution
      */
-    
+
     TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
 	    NULL, NULL);
     return TCL_OK;
@@ -2035,10 +2032,10 @@ TEBCresume(
     int traceInstructions;	/* Whether we are doing instruction-level
 				 * tracing or not. */
 #endif
-    
+
     Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
     Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];
- 
+
 #define LOCAL(i)	(&compiledLocals[(i)])
 #define TCONST(i)	(constants[(i)])
 
@@ -2050,18 +2047,18 @@ TEBCresume(
     TEBCdata *TD = data[0];
 #define auxObjList	(TD->auxObjList)
 #define catchTop	(TD->catchTop)
-#define codePtr         (TD->codePtr)
+#define codePtr		(TD->codePtr)
 #define checkInterp	(TD->checkInterp)
-                        /* Indicates when a check of interp readyness
-			 * is necessary. Set by CACHE_STACK_INFO() */
+			/* Indicates when a check of interp readyness is
+			 * necessary. Set by CACHE_STACK_INFO() */
 
     /*
      * Globals: variables that store state, must remain valid at all times.
      */
 
-    Tcl_Obj **tosPtr;	      /* Cached pointer to top of evaluation
-			       * stack. */
-    const unsigned char *pc;  /* The current program counter. */
+    Tcl_Obj **tosPtr;		/* Cached pointer to top of evaluation
+				 * stack. */
+    const unsigned char *pc;	/* The current program counter. */
 
     /*
      * Transfer variables - needed only between opcodes, but not while
@@ -2125,12 +2122,12 @@ TEBCresume(
 	     * Push the call's object result and continue execution with the
 	     * next instruction.
 	     */
-	    
+
 	    TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
-			    objc, cmdNameBuf), Tcl_GetObjResult(interp));
-	    
+		    objc, cmdNameBuf), Tcl_GetObjResult(interp));
+
 	    objResultPtr = Tcl_GetObjResult(interp);
-	    
+
 	    /*
 	     * Reset the interp's result to avoid possible duplications of
 	     * large objects [Bug 781585]. We do not call Tcl_ResetResult to
@@ -2141,18 +2138,18 @@ TEBCresume(
 	     * Note that the result object is now in objResultPtr, it keeps
 	     * the refCount it had in its role of iPtr->objResultPtr.
 	     */
-	    
+
 	    TclNewObj(objPtr);
 	    Tcl_IncrRefCount(objPtr);
 	    iPtr->objResultPtr = objPtr;
-	    NEXT_INST_V(0, cleanup, -1);		
+	    NEXT_INST_V(0, cleanup, -1);
 	}
-	
+
 	/*
 	 * Result not TCL_OK: fall through
 	 */
     }
-    
+
     if (iPtr->execEnvPtr->rewind) {
 	result = TCL_ERROR;
 	goto abnormalReturn;
@@ -4023,7 +4020,7 @@ TEBCresume(
 		    (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
 	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, valuePtr);
-	    CACHE_STACK_INFO();	    
+	    CACHE_STACK_INFO();
 	    goto gotError;
 	}
 
@@ -4032,7 +4029,7 @@ TEBCresume(
 		    (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
 	    DECACHE_STACK_INFO();
 	    IllegalExprOperandType(interp, pc, value2Ptr);
-	    CACHE_STACK_INFO();	    
+	    CACHE_STACK_INFO();
 	    goto gotError;
 	}
 
@@ -4424,7 +4421,7 @@ TEBCresume(
 		s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
 		memCmpFn = memcmp;
 	    } else if (((valuePtr->typePtr == &tclStringType)
-			    && (value2Ptr->typePtr == &tclStringType))) {
+		    && (value2Ptr->typePtr == &tclStringType))) {
 		/*
 		 * Do a unicode-specific comparison if both of the args are of
 		 * String type. If the char length == byte length, we can do a
@@ -5219,7 +5216,7 @@ TEBCresume(
 	NEXT_INST_F(1, 1, 1);
     }
 
-   case INST_BITNOT:
+    case INST_BITNOT:
 	valuePtr = OBJ_AT_TOS;
 	if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
 		|| (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) {
@@ -6285,10 +6282,10 @@ TEBCresume(
 	 */
 
     divideByZero:
-	DECACHE_STACK_INFO();	
+	DECACHE_STACK_INFO();
 	Tcl_SetResult(interp, "divide by zero", TCL_STATIC);
 	Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
-	CACHE_STACK_INFO();	
+	CACHE_STACK_INFO();
 	goto gotError;
 
 	/*
@@ -6297,7 +6294,7 @@ TEBCresume(
 	 */
 
     exponOfZero:
-	DECACHE_STACK_INFO();	
+	DECACHE_STACK_INFO();
 	Tcl_SetResult(interp, "exponentiation of zero by negative power",
 		TCL_STATIC);
 	Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
@@ -6341,8 +6338,9 @@ TEBCresume(
 	 */
 
 	while (auxObjList) {
-	    if ((catchTop != initCatchTop) &&
-		(*catchTop > ((ptrdiff_t) auxObjList->internalRep.ptrAndLongRep.value))) {
+	    if ((catchTop != initCatchTop)
+		    && (*catchTop > (ptrdiff_t)
+			auxObjList->internalRep.ptrAndLongRep.value)) {
 		break;
 	    }
 	    POP_TAUX_OBJ();
@@ -8077,7 +8075,7 @@ TclGetSrcInfoForCmd(
     ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
 
     return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
-			   codePtr, lenPtr, NULL);
+	    codePtr, lenPtr, NULL);
 }
 
 void
@@ -8142,8 +8140,8 @@ static const char *
 GetSrcInfoForPc(
     const unsigned char *pc,	/* The program counter value for which to
 				 * return the closest command's source info.
-				 * This points within a bytecode instruction in
-				 * codePtr's code. */
+				 * This points within a bytecode instruction
+				 * in codePtr's code. */
     ByteCode *codePtr,		/* The bytecode sequence in which to look up
 				 * the command source for the pc. */
     int *lengthPtr,		/* If non-NULL, the location where the length
@@ -8233,19 +8231,20 @@ GetSrcInfoForPc(
     }
 
     if (pcBeg != NULL) {
-	const unsigned char *curr,*prev;
+	const unsigned char *curr, *prev;
 
-	/* Walk from beginning of command or BC to pc, by complete
-	 * instructions. Stop when crossing pc; keep previous */
+	/*
+	 * Walk from beginning of command or BC to pc, by complete
+	 * instructions. Stop when crossing pc; keep previous.
+	 */
 
-	curr = prev = ((bestDist == INT_MAX) ?
-		       codePtr->codeStart :
-		       pc - bestDist);
+	curr = ((bestDist == INT_MAX) ? codePtr->codeStart : pc - bestDist);
+	prev = curr;
 	while (curr <= pc) {
 	    prev = curr;
 	    curr += tclInstructionTable[*curr].numBytes;
 	}
-	*pcBeg = prev ; 
+	*pcBeg = prev;
     }
 
     if (bestDist == INT_MAX) {
-- 
cgit v0.12


From 3768c5cbb266c4eb7bcbc8c9f466c546a8e41dff Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 25 Nov 2011 11:55:35 +0000
Subject: 	* library/history.tcl (history): Simplify the dance of
 variable 	management used when chaining to the implementation command.

---
 ChangeLog           | 5 +++++
 library/history.tcl | 2 +-
 2 files changed, 6 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 76623c2..03ff7d9 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2011-11-25  Donal K. Fellows  <dkf@users.sf.net>
+
+	* library/history.tcl (history): Simplify the dance of variable
+	management used when chaining to the implementation command.
+
 2011-11-22  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclExecute.c (TclCompileObj): Simplify and de-indent the
diff --git a/library/history.tcl b/library/history.tcl
index fb722c8..51d2404 100644
--- a/library/history.tcl
+++ b/library/history.tcl
@@ -53,7 +53,7 @@ proc ::history {args} {
     }
 
     # Tricky stuff needed to make stack and errors come out right!
-    tailcall apply {args {tailcall history {*}$args} ::tcl} {*}$args
+    tailcall apply {arglist {tailcall history {*}$arglist} ::tcl} $args
 }
 
 # tcl::HistAdd --
-- 
cgit v0.12


From b774a7b73682ce8dec7ce3a91c495205fbb6adae Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 30 Nov 2011 06:15:13 +0000
Subject: [Bug 2991415]: tclport.h #include'd before limits.h

---
 ChangeLog               | 2 ++
 generic/tclTomMath.h    | 1 -
 generic/tclTomMathInt.h | 1 +
 3 files changed, 3 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index e31ad3e..7d91aba 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2,6 +2,8 @@
 
 	* win/Makefile.in: don't install tommath_(super)?class.h
 	* unix/Makefile.in: don't install directories like 8.2 and 8.3
+	* generic/tclTomMath.h: [Bug 2991415]: move include tclInt.h from
+	* generic/tclTomMathInt.h: tclTomMath.h to tclTomMathInt.h
 
 2011-11-25  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclTomMath.h b/generic/tclTomMath.h
index eca435f..dd9edaf 100644
--- a/generic/tclTomMath.h
+++ b/generic/tclTomMath.h
@@ -15,7 +15,6 @@
 #ifndef BN_H_
 #define BN_H_
 
-#include "tclInt.h"
 #include "tclTomMathDecls.h"
 #ifndef MODULE_SCOPE
 #define MODULE_SCOPE extern
diff --git a/generic/tclTomMathInt.h b/generic/tclTomMathInt.h
index 1b9eb64..831f13f 100644
--- a/generic/tclTomMathInt.h
+++ b/generic/tclTomMathInt.h
@@ -1,2 +1,3 @@
+#include "tclInt.h"
 #include "tclTomMath.h"
 #include "tommath_class.h"
-- 
cgit v0.12


From 9c27c0e59b0afaae14af4b0a18f128744ea594b1 Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Tue, 13 Dec 2011 17:45:39 +0000
Subject: (TclInitAuxDataTypeTable): Extended to register the DictUpdateInfo
 structure as an AuxData type. For use by tbcload, tclcompiler.

---
 ChangeLog            | 6 ++++++
 generic/tclCompile.c | 1 +
 2 files changed, 7 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index 0a753e4..5c7a7b0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2011-12-13  Andreas Kupries  <andreask@activestate.com>
+
+	* generic/tclCompile.c (TclInitAuxDataTypeTable): Extended to
+	register the DictUpdateInfo structure as an AuxData type. For use
+	by tbcload, tclcompiler.
+
 2011-12-11  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/regc_locale.c: [Bug 3457031]: Some Unicode 6.0 chars not
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 97e2a8a..826e49c 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -3572,6 +3572,7 @@ TclInitAuxDataTypeTable(void)
 
     TclRegisterAuxDataType(&tclForeachInfoType);
     TclRegisterAuxDataType(&tclJumptableInfoType);
+    TclRegisterAuxDataType(&tclDictUpdateInfoType);
 }
 
 /*
-- 
cgit v0.12


From 312e3868140b7b11f1b078ab48779769a32b17eb Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 9 Jan 2012 13:50:43 +0000
Subject: Revert mistaken commit.

---
 unix/tclLoadDl.c | 1 -
 1 file changed, 1 deletion(-)

diff --git a/unix/tclLoadDl.c b/unix/tclLoadDl.c
index 9084089..96f0717 100644
--- a/unix/tclLoadDl.c
+++ b/unix/tclLoadDl.c
@@ -210,7 +210,6 @@ UnloadFile(
 {
     void *handle = loadHandle->clientData;
 
-    fprintf(stderr, "dlclose???\n"); fflush(stderr);
     dlclose(handle);
     ckfree(loadHandle);
 }
-- 
cgit v0.12


From 85acf7c41149e429f88a98ea21fbba362def0c72 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 12 Jan 2012 13:23:44 +0000
Subject: [Bug 3466506]: Document more environment variables.

---
 ChangeLog     | 30 +++++++++++++++++-------------
 doc/tclvars.n | 11 +++++++++++
 2 files changed, 28 insertions(+), 13 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index c3159a7..f4f73f3 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,18 +1,22 @@
+2012-01-12  Donal K. Fellows  <dkf@users.sf.net>
+
+	* doc/tclvars.n: [Bug 3466506]: Document more environment variables.
+
 2012-01-09  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclUtf.c:      [Bug 3464428] string is graph \u0120 is wrong
+	* generic/tclUtf.c:      [Bug 3464428]: string is graph \u0120 is wrong
 	* generic/regc_locale.c: Add table for Unicode [:cntrl:] class
 	* tools/uniClass.tcl:    Generate Unicode [:cntrl:] class table
 	* tests/utf.test:
 
 2012-01-08  Kevin B. Kenny  <kennykb@acm.org>
 
-	* library/clock.tcl (ReadZoneinfoFile): Corrected a bug where loading
-	* tests/clock.test (clock-56.4):        zoneinfo would fail if one
-	timezone abbreviation was a proper tail of another, and zic used the
-	same bytes of the file to represent both of them.  Added a test case
-	for the bug, using the same data that caused the observed failure
-	"in the wild." [Bug 3470928]
+	* library/clock.tcl (ReadZoneinfoFile): [Bug 3470928]: Corrected a bug
+	* tests/clock.test (clock-56.4):        where loading zoneinfo would
+	fail if one timezone abbreviation was a proper tail of another, and
+	zic used the same bytes of the file to represent both of them. Added a
+	test case for the bug, using the same data that caused the observed
+	failure "in the wild."
 
 2011-12-30  Venkat Iyer <venkat@comit.com>
 
@@ -26,18 +30,18 @@
 
 2011-12-23  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclUtf.c:     [Bug 3464428] string is graph \u0120 is wrong
+	* generic/tclUtf.c:     [Bug 3464428]: string is graph \u0120 is wrong.
 	* generic/tclUniData.c:
 	* generic/regc_locale.c:
 	* tests/utf.test:
-	* tools/uniParse.tcl:   clean up some unused stuff, and be more robust
+	* tools/uniParse.tcl:   Clean up some unused stuff, and be more robust
 	against changes in UnicodeData.txt syntax
 
 2011-12-13  Andreas Kupries  <andreask@activestate.com>
 
-	* generic/tclCompile.c (TclInitAuxDataTypeTable): Extended to
-	register the DictUpdateInfo structure as an AuxData type. For use
-	by tbcload, tclcompiler.
+	* generic/tclCompile.c (TclInitAuxDataTypeTable): Extended to register
+	the DictUpdateInfo structure as an AuxData type. For use by tbcload,
+	tclcompiler.
 
 2011-12-11  Jan Nijtmans  <nijtmans@users.sf.net>
 
@@ -46,7 +50,7 @@
 
 2011-12-07  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* tools/uniParse.tcl:    [Bug 3444754] string tolower \u01c5 is wrong
+	* tools/uniParse.tcl:    [Bug 3444754]: string tolower \u01c5 is wrong
 	* generic/tclUniData.c:
 	* tests/utf.test:
 
diff --git a/doc/tclvars.n b/doc/tclvars.n
index 3bd18e8..44a8e11 100644
--- a/doc/tclvars.n
+++ b/doc/tclvars.n
@@ -100,6 +100,17 @@ Tcl format, using
 as the path separator, regardless of platform.
 This variable is only used when initializing the \fBauto_path\fR variable.
 .TP
+\fBenv(TCL_TZ)\fR, \fBenv(TZ)\fR
+.
+These specify the default timezone used for parsing and formatting times and
+dates in the \fBclock\fR command. On many platforms, the TZ environment
+variable is set up by the operating system.
+.TP
+\fBenv(LC_ALL)\fR, \fBenv(LC_MESSAGES)\fR, \fBenv(LANG)\fR
+.
+These environment variables are used by the \fBmsgcat\fR package to
+determine what locale to format messages using.
+.TP
 \fBenv(TCL_INTERP_DEBUG_FRAME)\fR
 .
 If existing, it has the same effect as running \fBinterp debug\fR
-- 
cgit v0.12


From 15b74ef01faf9ca538aa987d8e8f6d64952e5b02 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Thu, 12 Jan 2012 20:40:11 +0000
Subject: [Bug 3472316] Document the destructive semantics of [fconfigure
 -error] on sockets.

---
 doc/socket.n | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/doc/socket.n b/doc/socket.n
index e2c4759..e3087c9 100644
--- a/doc/socket.n
+++ b/doc/socket.n
@@ -157,6 +157,9 @@ This option gets the current error status of the given socket.  This
 is useful when you need to determine if an asynchronous connect
 operation succeeded.  If there was an error, the error message is
 returned.  If there was no error, an empty string is returned.
+
+Note that the error status is reset by the read operation; this mimics
+the underlying getsockopt(SO_ERROR) call.
 .TP
 \fB\-sockname\fR
 .
-- 
cgit v0.12


From 68fbac8d0f24ffb16077c6c3ecd6c1a61ab16bb1 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 25 Jan 2012 14:39:55 +0000
Subject: 	* generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]:
 When 	copying an object, make sure that the configuration of the variable 
 resolver is also duplicated.

---
 ChangeLog       |  8 +++++++-
 generic/tclOO.c | 20 +++++++++++++++++++-
 tests/oo.test   | 22 ++++++++++++++++++++++
 3 files changed, 48 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 7753272..3d69427 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,12 @@
+2012-01-25  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: When
+	copying an object, make sure that the configuration of the variable
+	resolver is also duplicated.
+
 2012-01-22  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* tools/uniClass.tcl:    [Frq 3473670]: Various Unicode-related 
+	* tools/uniClass.tcl:    [FRQ 3473670]: Various Unicode-related
 	* tools/uniParse.tcl:    speedups/robustness. Enhanced tools to
 	* generic/tclUniData.c:  be able to handle characters > 0xffff
 	* generic/tclUtf.c:      Done in all branches in order to simplify
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 8b76eeb..8ac2039 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1643,7 +1643,7 @@ Tcl_CopyObjectInstance(
     FOREACH_HASH_DECLS;
     Method *mPtr;
     Class *mixinPtr;
-    Tcl_Obj *keyPtr, *filterObj;
+    Tcl_Obj *keyPtr, *filterObj, *variableObj;
     int i;
 
     /*
@@ -1712,6 +1712,15 @@ Tcl_CopyObjectInstance(
     }
 
     /*
+     * Copy the object's variable resolution list to the new object.
+     */
+
+    DUPLICATE(o2Ptr->variables, oPtr->variables, Tcl_Obj *);
+    FOREACH(variableObj, o2Ptr->variables) {
+	Tcl_IncrRefCount(variableObj);
+    }
+
+    /*
      * Copy the object's flags to the new object, clearing those that must be
      * kept object-local. The duplicate is never deleted at this point, nor is
      * it the root of the object system or in the midst of processing a filter
@@ -1794,6 +1803,15 @@ Tcl_CopyObjectInstance(
 	}
 
 	/*
+	 * Copy the source class's variable resolution list.
+	 */
+
+	DUPLICATE(cls2Ptr->variables, clsPtr->variables, Tcl_Obj *);
+	FOREACH(variableObj, cls2Ptr->variables) {
+	    Tcl_IncrRefCount(variableObj);
+	}
+
+	/*
 	 * Duplicate the source class's mixins (which cannot be circular
 	 * references to the duplicate).
 	 */
diff --git a/tests/oo.test b/tests/oo.test
index e5a17f1..67535c9 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1650,6 +1650,28 @@ test oo-15.3 {OO: class cloning} {
     bar destroy
     return $result
 } {::foo->::baseline ::foo->::baseline ::bar->::tester ::bar->::tester}
+test oo-15.4 {OO: object cloning - Bug 3474460} -setup {
+    oo::class create ArbitraryClass
+} -body {
+    ArbitraryClass create foo
+    oo::objdefine foo variable a b c
+    oo::copy foo bar
+    info object variable bar
+} -cleanup {
+    ArbitraryClass destroy
+} -result {a b c}
+test oo-15.5 {OO: class cloning - Bug 3474460} -setup {
+    oo::class create ArbitraryClass
+} -body {
+    oo::class create Foo {
+	superclass ArbitraryClass
+	variable a b c
+    }
+    oo::copy Foo Bar
+    info class variable Bar
+} -cleanup {
+    ArbitraryClass destroy
+} -result {a b c}
 
 test oo-16.1 {OO: object introspection} -body {
     info object
-- 
cgit v0.12


From 740cd597bdeb4e570412f8fa30a97e39bdf56e99 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 26 Jan 2012 23:26:13 +0000
Subject: alternative TIP 395 implementation: - more efficient, will not
 generate bignum - uses "string is integer" in stead of "string is entier" -
 original "string is integer" renamed to "string is int"

---
 doc/string.n       |   5 ++-
 generic/tclCmdMZ.c |  49 +++++++++++++++++++++++--
 tests/string.test  | 102 ++++++++++++++++++++++++++++++++++++-----------------
 3 files changed, 120 insertions(+), 36 deletions(-)

diff --git a/doc/string.n b/doc/string.n
index d960b71..d1956fd 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -126,10 +126,13 @@ Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
 false.
 .IP \fBgraph\fR 12
 Any Unicode printing character, except space.
-.IP \fBinteger\fR 12
+.IP \fBint\fR 12
 Any of the valid string formats for a 32-bit integer value in Tcl,
 with optional surrounding whitespace.  In case of under/overflow in
 the value, 0 is returned and the \fIvarname\fR will contain \-1.
+.IP \fBinteger\fR 12
+Any of the valid string formats for an integer value in Tcl as allowed by
+\fBTcl_GetBigNnum\fR, with optional surrounding whitespace.
 .IP \fBlist\fR 12
 Any proper list structure, with optional surrounding whitespace. In
 case of improper list structure, 0 is returned and the \fIvarname\fR
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 1ef6fa8..38fb04a 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -1437,7 +1437,7 @@ StringIsCmd(
     static const char *const isClasses[] = {
 	"alnum",	"alpha",	"ascii",	"control",
 	"boolean",	"digit",	"double",	"false",
-	"graph",	"integer",	"list",		"lower",
+	"graph",	"int",	"integer",	"list",		"lower",
 	"print",	"punct",	"space",	"true",
 	"upper",	"wideinteger",	"wordchar",	"xdigit",
 	NULL
@@ -1445,7 +1445,7 @@ StringIsCmd(
     enum isClasses {
 	STR_IS_ALNUM, STR_IS_ALPHA,	STR_IS_ASCII,  STR_IS_CONTROL,
 	STR_IS_BOOL,  STR_IS_DIGIT,	STR_IS_DOUBLE, STR_IS_FALSE,
-	STR_IS_GRAPH, STR_IS_INT,	STR_IS_LIST,   STR_IS_LOWER,
+	STR_IS_GRAPH, STR_IS_INT, STR_IS_INTEGER,	STR_IS_LIST,   STR_IS_LOWER,
 	STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,  STR_IS_TRUE,
 	STR_IS_UPPER, STR_IS_WIDE,	STR_IS_WORD,   STR_IS_XDIGIT
     };
@@ -1575,6 +1575,51 @@ StringIsCmd(
 	    break;
 	}
 	goto failedIntParse;
+    case STR_IS_INTEGER:
+	if ((objPtr->typePtr == &tclIntType) ||
+#ifndef NO_WIDE_TYPE
+		(objPtr->typePtr == &tclWideIntType) ||
+#endif
+		(objPtr->typePtr == &tclBignumType)) {
+	    break;
+	}
+	string1 = TclGetStringFromObj(objPtr, &length1);
+	if (length1 == 0) {
+	    if (strict) {
+		result = 0;
+	    }
+	    goto str_is_done;
+	}
+	end = string1 + length1;
+	if (TclParseNumber(NULL, objPtr, NULL, NULL, -1,
+		(const char **) &stop, TCL_PARSE_INTEGER_ONLY) == TCL_OK) {
+	    if (stop == end) {
+		/*
+		 * Entire string parses as an integer.
+		 */
+
+		break;
+	    } else {
+		/*
+		 * Some prefix parsed as an integer, but not the whole string,
+		 * so return failure index as the point where parsing stopped.
+		 * Clear out the internal rep, since keeping it would leave
+		 * *objPtr in an inconsistent state.
+		 */
+
+		result = 0;
+		failat = stop - string1;
+		TclFreeIntRep(objPtr);
+	    }
+	} else {
+	    /*
+	     * No prefix is a valid integer. Fail at beginning.
+	     */
+
+	    result = 0;
+	    failat = 0;
+	}
+	break;
     case STR_IS_WIDE:
 	if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
 	    break;
diff --git a/tests/string.test b/tests/string.test
index 85a7372..c8bc2d7 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -312,10 +312,10 @@ test string-6.4 {string is, too many args} {
 } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
 test string-6.5 {string is, class check} {
     list [catch {string is bogus str} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, int, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
 test string-6.6 {string is, ambiguous class} {
     list [catch {string is al str} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, int, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
 test string-6.7 {string is alpha, all ok} {
     string is alpha -strict -failindex var abc
 } 1
@@ -448,44 +448,44 @@ test string-6.47 {string is false, false} {
     catch {unset var}
     list [string is false -fail var offensive] $var
 } {0 0}
-test string-6.48 {string is integer, true} {
-    string is integer +1234567890
+test string-6.48 {string is int, true} {
+    string is int +1234567890
 } 1
-test string-6.49 {string is integer, true on type} {
-    string is integer [expr int(50.0)]
+test string-6.49 {string is int, true on type} {
+    string is int [expr int(50.0)]
 } 1
-test string-6.50 {string is integer, true} {
-    string is integer [list -10]
+test string-6.50 {string is int, true} {
+    string is int [list -10]
 } 1
-test string-6.51 {string is integer, true as hex} {
-    string is integer 0xabcdef
+test string-6.51 {string is int, true as hex} {
+    string is int 0xabcdef
 } 1
-test string-6.52 {string is integer, true as octal} {
-    string is integer 012345
+test string-6.52 {string is int, true as octal} {
+    string is int 012345
 } 1
-test string-6.53 {string is integer, true with whitespace} {
-    string is integer "  \n1234\v"
+test string-6.53 {string is int, true with whitespace} {
+    string is int "  \n1234\v"
 } 1
-test string-6.54 {string is integer, false} {
-    list [string is integer -fail var 123abc] $var
+test string-6.54 {string is int, false} {
+    list [string is int -fail var 123abc] $var
 } {0 3}
-test string-6.55 {string is integer, false on overflow} {
-    list [string is integer -fail var +[largest_int]0] $var
+test string-6.55 {string is int, false on overflow} {
+    list [string is int -fail var +[largest_int]0] $var
 } {0 -1}
-test string-6.56 {string is integer, false} {
-    list [string is integer -fail var [expr double(1)]] $var
+test string-6.56 {string is int, false} {
+    list [string is int -fail var [expr double(1)]] $var
 } {0 1}
-test string-6.57 {string is integer, false} {
-    list [string is integer -fail var "    "] $var
+test string-6.57 {string is int, false} {
+    list [string is int -fail var "    "] $var
 } {0 0}
-test string-6.58 {string is integer, false on bad octal} {
+test string-6.58 {string is int, false on bad octal} {
     list [string is integer -fail var 0o36963] $var
 } {0 4}
-test string-6.58.1 {string is integer, false on bad octal} {
-    list [string is integer -fail var 0o36963] $var
+test string-6.58.1 {string is int, false on bad octal} {
+    list [string is int -fail var 0o36963] $var
 } {0 4}
-test string-6.59 {string is integer, false on bad hex} {
-    list [string is integer -fail var 0X345XYZ] $var
+test string-6.59 {string is int, false on bad hex} {
+    list [string is int -fail var 0X345XYZ] $var
 } {0 5}
 test string-6.60 {string is lower, true} {
     string is lower abc
@@ -602,21 +602,21 @@ test string-6.91 {string is double, bad doubles} {
     }
     set result
 } {1 1 0 0 0 1 0 0}
-test string-6.92 {string is integer, 32-bit overflow} {
+test string-6.92 {string is int, 32-bit overflow} {
     # Bug 718878
     set x 0x100000000
-    list [string is integer -failindex var $x] $var
+    list [string is int -failindex var $x] $var
 } {0 -1}
-test string-6.93 {string is integer, 32-bit overflow} {
+test string-6.93 {string is int, 32-bit overflow} {
     # Bug 718878
     set x 0x100000000
     append x ""
-    list [string is integer -failindex var $x] $var
+    list [string is int -failindex var $x] $var
 } {0 -1}
-test string-6.94 {string is integer, 32-bit overflow} {
+test string-6.94 {string is int, 32-bit overflow} {
     # Bug 718878
     set x 0x100000000
-    list [string is integer -failindex var [expr {$x}]] $var
+    list [string is int -failindex var [expr {$x}]] $var
 } {0 -1}
 test string-6.95 {string is wideinteger, true} {
     string is wideinteger +1234567890
@@ -674,6 +674,42 @@ test string-6.108 {string is double, Bug 1382287} {
 test string-6.109 {string is double, Bug 1360532} {
     string is double 1\u00a0
 } 0
+test string-6.110 {string is integer, true} {
+    string is integer +1234567890
+} 1
+test string-6.111 {string is integer, true on type} {
+    string is integer [expr int(50.0)]
+} 1
+test string-6.112 {string is integer, true} {
+    string is integer [list -10]
+} 1
+test string-6.113 {string is integer, true as hex} {
+    string is integer 0xabcdef
+} 1
+test string-6.114 {string is integer, true as octal} {
+    string is integer 012345
+} 1
+test string-6.115 {string is integer, true with whitespace} {
+    string is integer "  \n1234\v"
+} 1
+test string-6.116 {string is integer, false} {
+    list [string is integer -fail var 123abc] $var
+} {0 3}
+test string-6.117 {string is integer, true on integer overflow} {
+    string is integer +[largest_int]0
+} 1
+test string-6.118 {string is integer, false} {
+    list [string is integer -fail var [expr double(1)]] $var
+} {0 1}
+test string-6.119 {string is integer, false} {
+    list [string is integer -fail var "    "] $var
+} {0 0}
+test string-6.120 {string is integer, false on bad octal} {
+    list [string is integer -fail var 0o36963] $var
+} {0 4}
+test string-6.121 {string is integer, false on bad hex} {
+    list [string is integer -fail var 0X345XYZ] $var
+} {0 5}
 
 catch {rename largest_int {}}
 
-- 
cgit v0.12


From 6740ac50e9a65342cacd77245cacb8ad443dda00 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Fri, 27 Jan 2012 21:56:52 +0000
Subject: 3479689  New internal routine TclJoinPath(). Refactor all the
 *Join*Path* routines to give them more useful interfaces that are easier to
 manage getting the refcounts right.

---
 ChangeLog             |  8 +++++++
 generic/tclCmdAH.c    |  2 +-
 generic/tclFCmd.c     |  5 +----
 generic/tclFileName.c | 40 +++++++++++++++------------------
 generic/tclInt.h      |  1 +
 generic/tclPathObj.c  | 61 ++++++++++++++++++++++-----------------------------
 6 files changed, 55 insertions(+), 62 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 896f9a0..e43d7ac 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,13 @@
 2012-01-26  Don Porter  <dgp@users.sourceforge.net>
 
+	* generic/tclCmdAH.c:		New internal routine TclJoinPath().
+	* generic/tclFCmd.c:		Refactor all the *Join*Path* routines
+	* generic/tclFileName.c:	to give them more useful interfaces
+	* generic/tclInt.h:		that are easier to manage getting the
+	* generic/tclPathObj.c:		refcounts right. [Bug 3479689]
+
+2012-01-26  Don Porter  <dgp@users.sourceforge.net>
+
 	* generic/tclPathObj.c:	[Bug 3475569]: Add checks for unshared values
 	before calls demanding them.  [Bug 3479689]: Stop memory corruption
 	when shimmering 0-refCount value to "path" type.
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index d036bd6..2308f33 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -1841,7 +1841,7 @@ PathJoinCmd(
 	Tcl_WrongNumArgs(interp, 1, objv, "name ?name ...?");
 	return TCL_ERROR;
     }
-    Tcl_SetObjResult(interp, Tcl_FSJoinToPath(NULL, objc - 1, objv + 1));
+    Tcl_SetObjResult(interp, TclJoinPath(objc - 1, objv + 1));
     return TCL_OK;
 }
 
diff --git a/generic/tclFCmd.c b/generic/tclFCmd.c
index 0d90094..e95a136 100644
--- a/generic/tclFCmd.c
+++ b/generic/tclFCmd.c
@@ -177,7 +177,6 @@ FileCopyRename(
     for ( ; i<objc-1 ; i++) {
 	Tcl_Obj *jargv[2];
 	Tcl_Obj *source, *newFileName;
-	Tcl_Obj *temp;
 
 	source = FileBasename(interp, objv[i]);
 	if (source == NULL) {
@@ -186,13 +185,11 @@ FileCopyRename(
 	}
 	jargv[0] = objv[objc - 1];
 	jargv[1] = source;
-	temp = Tcl_NewListObj(2, jargv);
-	newFileName = Tcl_FSJoinPath(temp, -1);
+	newFileName = TclJoinPath(2, jargv);
 	Tcl_IncrRefCount(newFileName);
 	result = CopyRenameOneFile(interp, objv[i], newFileName, copyFlag,
 		force);
 	Tcl_DecrRefCount(newFileName);
-	Tcl_DecrRefCount(temp);
 	Tcl_DecrRefCount(source);
 
 	if (result == TCL_ERROR) {
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 8ed6f96..adfa2fd 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -787,32 +787,28 @@ Tcl_FSJoinToPath(
     int objc,			/* Number of array elements to join */
     Tcl_Obj *const objv[])	/* Path elements to join. */
 {
-    int i;
-    Tcl_Obj *lobj, *ret;
-
     if (pathPtr == NULL) {
-	lobj = Tcl_NewListObj(0, NULL);
-    } else {
-	lobj = Tcl_NewListObj(1, &pathPtr);
+	return TclJoinPath(objc, objv);
     }
-
-    for (i = 0; i<objc;i++) {
-	Tcl_ListObjAppendElement(NULL, lobj, objv[i]);
+    if (objc == 0) {
+	return TclJoinPath(1, &pathPtr);
     }
-    ret = Tcl_FSJoinPath(lobj, -1);
-
-    /*
-     * It is possible that 'ret' is just a member of the list and is therefore
-     * going to be freed here. Therefore we must adjust the refCount manually.
-     * (It would be better if we changed the documentation of this function
-     * and Tcl_FSJoinPath so that the returned object already has a refCount
-     * for the caller, hence avoiding these subtleties (and code ugliness)).
-     */
+    if (objc == 1) {
+	Tcl_Obj *pair[2];
 
-    Tcl_IncrRefCount(ret);
-    Tcl_DecrRefCount(lobj);
-    ret->refCount--;
-    return ret;
+	pair[0] = pathPtr;
+	pair[1] = objv[0];
+	return TclJoinPath(2, pair);
+    } else {
+	int elemc = objc + 1;
+	Tcl_Obj *ret, **elemv = ckalloc(elemc*sizeof(Tcl_Obj **));
+
+	elemv[0] = pathPtr;
+	memcpy(elemv+1, objv, objc*sizeof(Tcl_Obj **));
+	ret = TclJoinPath(elemc, elemv);
+	ckfree(elemv);
+	return ret;
+    }
 }
 
 /*
diff --git a/generic/tclInt.h b/generic/tclInt.h
index b375bb9..feede54 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2995,6 +2995,7 @@ MODULE_SCOPE void	TclInitSubsystems(void);
 MODULE_SCOPE int	TclInterpReady(Tcl_Interp *interp);
 MODULE_SCOPE int	TclIsLocalScalar(const char *src, int len);
 MODULE_SCOPE int	TclIsSpaceProc(char byte);
+MODULE_SCOPE Tcl_Obj *	TclJoinPath(int elements, Tcl_Obj * const objv[]);
 MODULE_SCOPE int	TclJoinThread(Tcl_ThreadId id, int *result);
 MODULE_SCOPE void	TclLimitRemoveAllHandlers(Tcl_Interp *interp);
 MODULE_SCOPE Tcl_Obj *	TclLindexList(Tcl_Interp *interp,
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index 30f2081..7ab8a4e 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -838,44 +838,39 @@ Tcl_FSJoinPath(
 				 * reference count. */
     int elements)		/* Number of elements to use (-1 = all) */
 {
-    Tcl_Obj *res;
-    int i;
-    const Tcl_Filesystem *fsPtr = NULL;
+    Tcl_Obj *copy, *res;
+    int objc;
+    Tcl_Obj **objv;
 
-    if (elements < 0) {
-	if (Tcl_ListObjLength(NULL, listObj, &elements) != TCL_OK) {
-	    return NULL;
-	}
-    } else {
-	/*
-	 * Just make sure it is a valid list.
-	 */
-
-	int listTest;
-
-	if (Tcl_ListObjLength(NULL, listObj, &listTest) != TCL_OK) {
-	    return NULL;
-	}
+    if (Tcl_ListObjLength(NULL, listObj, &objc) != TCL_OK) {
+	return NULL;
+    }
 
-	/*
-	 * Correct this if it is too large, otherwise we will waste our time
-	 * joining null elements to the path.
-	 */
+    elements = ((elements >= 0) && (elements <= objc)) ? elements : objc;
+    copy = TclListObjCopy(NULL, listObj);
+    Tcl_ListObjGetElements(NULL, listObj, &objc, &objv);
+    res = TclJoinPath(elements, objv);
+    Tcl_DecrRefCount(copy);
+    return res;
+}
 
-	if (elements > listTest) {
-	    elements = listTest;
-	}
-    }
+Tcl_Obj *
+TclJoinPath(
+    int elements,
+    Tcl_Obj * const objv[])
+{
+    Tcl_Obj *res;
+    int i;
+    const Tcl_Filesystem *fsPtr = NULL;
 
     res = NULL;
 
     for (i = 0; i < elements; i++) {
-	Tcl_Obj *elt, *driveName = NULL;
 	int driveNameLength, strEltLen, length;
 	Tcl_PathType type;
 	char *strElt, *ptr;
-
-	Tcl_ListObjIndex(NULL, listObj, i, &elt);
+	Tcl_Obj *driveName = NULL;
+	Tcl_Obj *elt = objv[i];
 
 	/*
 	 * This is a special case where we can be much more efficient, where
@@ -889,9 +884,8 @@ Tcl_FSJoinPath(
 	if ((i == (elements-2)) && (i == 0)
 		&& (elt->typePtr == &tclFsPathType)
 		&& !((elt->bytes != NULL) && (elt->bytes[0] == '\0'))) {
-	    Tcl_Obj *tailObj;
+	    Tcl_Obj *tailObj = objv[i+1];
 
-	    Tcl_ListObjIndex(NULL, listObj, i+1, &tailObj);
 	    type = TclGetPathType(tailObj, NULL, NULL, NULL);
 	    if (type == TCL_PATH_RELATIVE) {
 		const char *str;
@@ -1389,7 +1383,7 @@ AppendPath(
      * of no evidence that such a foolish thing exists.  This solution was
      * chosen so that "JoinPath" operations that pass through either path
      * intrep produce the same results; that is, bugward compatibility.  If
-     * we need to fix that bug here, it needs fixing in Tcl_FSJoinPath() too.
+     * we need to fix that bug here, it needs fixing in TclJoinPath() too.
      */
     bytes = Tcl_GetStringFromObj(tail, &numBytes);
     if (numBytes == 0) {
@@ -2499,10 +2493,7 @@ SetFsPathFromAny(
 	}
 	Tcl_DStringFree(&temp);
     } else {
-	/* Bug 3479689: protect 0-refcount pathPth from getting freed */
-	pathPtr->refCount++;
-	transPtr = Tcl_FSJoinToPath(pathPtr, 0, NULL);
-	pathPtr->refCount--;
+	transPtr = TclJoinPath(1, &pathPtr);
     }
 
 #if defined(__CYGWIN__) && defined(__WIN32__)
-- 
cgit v0.12


From 84edc366a514da71f1b7e88a4984ea45cf2b6bc2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 30 Jan 2012 15:43:34 +0000
Subject: 	* generic/tclCompCmds.c (TclCompileCatchCmd): Added a more
 efficient 	bytecode generator for the case where 'catch' is used without
 any 	variable arguments; don't capture the result just to discard it.

---
 ChangeLog             | 16 +++++++++++-----
 generic/tclCompCmds.c | 30 +++++++++++++++++++++++++++++-
 2 files changed, 40 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index e43d7ac..9da588f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,10 +1,16 @@
+2012-01-30  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCompCmds.c (TclCompileCatchCmd): Added a more efficient
+	bytecode generator for the case where 'catch' is used without any
+	variable arguments; don't capture the result just to discard it.
+
 2012-01-26  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCmdAH.c:		New internal routine TclJoinPath().
-	* generic/tclFCmd.c:		Refactor all the *Join*Path* routines
-	* generic/tclFileName.c:	to give them more useful interfaces
-	* generic/tclInt.h:		that are easier to manage getting the
-	* generic/tclPathObj.c:		refcounts right. [Bug 3479689]
+	* generic/tclCmdAH.c:		[Bug 3479689]: New internal routine
+	* generic/tclFCmd.c:		TclJoinPath(). Refactor all the
+	* generic/tclFileName.c:	*Join*Path* routines to give them more
+	* generic/tclInt.h:		useful interfaces that are easier to
+	* generic/tclPathObj.c:		manage getting the refcounts right.
 
 2012-01-26  Don Porter  <dgp@users.sourceforge.net>
 
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 69b44ed..1edb56b 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -390,6 +390,32 @@ TclCompileCatchCmd(
      *    simple:            <mark> result
      */
 
+    if (resultIndex == -1) {
+	/*
+	 * Special case when neither result nor options are being saved. In
+	 * that case, we can skip quite a bit of the command epilogue; all we
+	 * have to do is drop the result and push the return code (and, of
+	 * course, finish the catch context).
+	 */
+
+	TclEmitOpcode(		INST_POP,			envPtr);
+	PushLiteral(envPtr, "0", 1);
+	TclEmitInstInt1(	INST_JUMP1, 3,			envPtr);
+	envPtr->currStackDepth = savedStackDepth;
+	ExceptionRangeTarget(envPtr, range, catchOffset);
+	TclEmitOpcode(		INST_PUSH_RETURN_CODE,		envPtr);
+	ExceptionRangeEnds(envPtr, range);
+	TclEmitOpcode(		INST_END_CATCH,			envPtr);
+
+	/*
+	 * Stack at this point:
+	 *    nonsimple:  script <mark> returnCode
+	 *    simple:            <mark> returnCode
+	 */
+
+	goto dropScriptAtEnd;
+    }
+
     /*
      * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch
      * result, and jump around the "error case" code.
@@ -467,7 +493,9 @@ TclCompileCatchCmd(
 	TclEmitOpcode(		INST_POP,			envPtr);
     }
 
-    /* 
+  dropScriptAtEnd:
+
+    /*
      * Stack is now ?script? result. Get rid of the subst'ed script
      * if it's hanging arond.
      */
-- 
cgit v0.12


From f2e09cfe50b25523b6ada8256594673c818c69c1 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 30 Jan 2012 23:34:28 +0000
Subject: Minor: make comments accurate in [catch] compiler.

---
 generic/tclCompCmds.c | 44 ++++++++++++++++++++++----------------------
 1 file changed, 22 insertions(+), 22 deletions(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 1edb56b..57a5370 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -352,8 +352,8 @@ TclCompileCatchCmd(
     }
 
     /*
-     * We will compile the catch command. Declare the exception range
-     * that it uses.
+     * We will compile the catch command. Declare the exception range that it
+     * uses.
      */
 
     range = DeclareExceptionRange(envPtr, CATCH_EXCEPTION_RANGE);
@@ -362,10 +362,10 @@ TclCompileCatchCmd(
      * If the body is a simple word, compile a BEGIN_CATCH instruction,
      * followed by the instructions to eval the body.
      * Otherwise, compile instructions to substitute the body text before
-     * starting the catch, then BEGIN_CATCH, and then EVAL_STK to
-     * evaluate the substituted body.
-     * Care has to be taken to make sure that substitution happens outside
-     * the catch range so that errors in the substitution are not caught.
+     * starting the catch, then BEGIN_CATCH, and then EVAL_STK to evaluate the
+     * substituted body.
+     * Care has to be taken to make sure that substitution happens outside the
+     * catch range so that errors in the substitution are not caught.
      * [Bug 219184]
      * The reason for duplicating the script is that EVAL_STK would otherwise
      * begin by undeflowing the stack below the mark set by BEGIN_CATCH4.
@@ -417,8 +417,8 @@ TclCompileCatchCmd(
     }
 
     /*
-     * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch
-     * result, and jump around the "error case" code.
+     * Emit the "no errors" epilogue: push "0" (TCL_OK) as the catch result,
+     * and jump around the "error case" code.
      */
 
     PushLiteral(envPtr, "0", 1);
@@ -426,8 +426,8 @@ TclCompileCatchCmd(
     /* Stack at this point: ?script? <mark> result TCL_OK */
 
     /* 
-     * Emit the "error case" epilogue. Push the interpreter result
-     * and the return code.
+     * Emit the "error case" epilogue. Push the interpreter result and the
+     * return code.
      */
 
     envPtr->currStackDepth = savedStackDepth;
@@ -446,7 +446,9 @@ TclCompileCatchCmd(
 		(int)(CurrentOffset(envPtr) - jumpFixup.codeOffset));
     }
 
-    /* Push the return options if the caller wants them */
+    /*
+     * Push the return options if the caller wants them.
+     */
 
     if (optsIndex != -1) {
 	TclEmitOpcode(		INST_PUSH_RETURN_OPTIONS,	envPtr);
@@ -472,19 +474,17 @@ TclCompileCatchCmd(
     }
 
     /*
-     * Store the result if requested, and remove it from the stack
+     * Store the result and remove it from the stack.
      */
 
-    if (resultIndex != -1) {
-	Emit14Inst(		INST_STORE_SCALAR, resultIndex,	envPtr);
-    }
+    Emit14Inst(			INST_STORE_SCALAR, resultIndex,	envPtr);
     TclEmitOpcode(		INST_POP,			envPtr);
 
     /*
      * Stack is now ?script? ?returnOptions? returnCode.
-     * If the options dict has been requested, it is buried on the stack
-     * under the return code. Reverse the stack to bring it to the top,
-     * store it and remove it from the stack.
+     * If the options dict has been requested, it is buried on the stack under
+     * the return code. Reverse the stack to bring it to the top, store it and
+     * remove it from the stack.
      */
 
     if (optsIndex != -1) {
@@ -496,8 +496,8 @@ TclCompileCatchCmd(
   dropScriptAtEnd:
 
     /*
-     * Stack is now ?script? result. Get rid of the subst'ed script
-     * if it's hanging arond.
+     * Stack is now ?script? result. Get rid of the subst'ed script if it's
+     * hanging arond.
      */
 
     if (cmdTokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
@@ -506,8 +506,8 @@ TclCompileCatchCmd(
     }
 
     /* 
-     * Result of all this, on either branch, should have been to leave
-     * one operand -- the return code -- on the stack.
+     * Result of all this, on either branch, should have been to leave one
+     * operand -- the return code -- on the stack.
      */
 
     if (envPtr->currStackDepth != initStackDepth + 1) {
-- 
cgit v0.12


From 9fa9402452dda28e0e91a33614fb63edb0d97e36 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 2 Feb 2012 18:01:11 +0000
Subject: inverted logic

---
 win/tclWinFile.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index 78128d6..331d65a 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -1584,7 +1584,7 @@ NativeAccess(
      * what permissions the OS has set for a file.
      */
 
-#ifndef UNICODE
+#ifdef UNICODE
     {
 	SECURITY_DESCRIPTOR *sdPtr = NULL;
 	unsigned long size;
-- 
cgit v0.12


From 3726e1f19cfa86bd6348c60bc1b600512748db4f Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 6 Feb 2012 16:43:46 +0000
Subject: Fix for [Bug 3484621]: insure that execution traces on bytecoded
 commands bump the interp's compile epoch.

---
 ChangeLog          |  6 ++++++
 generic/tclTrace.c | 19 +++++++++++++++++++
 tests/trace.test   | 33 +++++++++++++++++++++++++++++++++
 3 files changed, 58 insertions(+)

diff --git a/ChangeLog b/ChangeLog
index aaace29..ecd7b7c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2012-02-06  Miguel Sofer  <msofer@users.sf.net>
+
+	* generic/tclTrace.c:  Fix for [Bug 3484621]: insure that
+	* tests/trace.test:    execution traces on bytecoded commands bump
+	the interp's compile epoch.
+	
 2012-02-02  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclUniData.c: [Frq 3464401] Support Unicode 6.1
diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index 28e6934..ad81c58 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -1124,6 +1124,16 @@ Tcl_TraceCommand(
     if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
 	cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
     }
+
+    /*
+     * Bug 3484621: up the interp's epoch if this is a BC'ed command
+     */
+
+    if (cmdPtr->compileProc != NULL) {
+	Interp *iPtr = (Interp *) interp;
+	iPtr->compileEpoch++;
+    }
+    
     return TCL_OK;
 }
 
@@ -1226,6 +1236,15 @@ Tcl_UntraceCommand(
 	 */
 
 	cmdPtr->flags &= ~CMD_HAS_EXEC_TRACES;
+
+        /*
+	 * Bug 3484621: up the interp's epoch if this is a BC'ed command
+	 */
+	
+	if (cmdPtr->compileProc != NULL) {
+	    Interp *iPtr = (Interp *) interp;
+	    iPtr->compileEpoch++;
+	}
     }
 }
 
diff --git a/tests/trace.test b/tests/trace.test
index c2a760d..3297258 100644
--- a/tests/trace.test
+++ b/tests/trace.test
@@ -2558,6 +2558,39 @@ set base {
 }
 runbase {{- *} {-* *} {- *} {- *}} $base
 
+test trace-39 {bug #3484621: tracing Bc'ed commands} -setup {
+    set ::traceLog 0
+    set ::traceCalls 0
+    set ::bar [list 0 1 2 3]
+    set res {}
+    proc dotrace args {
+	incr ::traceLog
+    }
+    proc foo {} {
+	incr ::traceCalls
+	# choose a BC'ed command that is 'unlikely' to interfere with tcltest's
+	# internals 
+	lset ::bar 1 2
+    }
+} -body {
+    foo
+    lappend res $::traceLog
+
+    trace add execution lset enter dotrace
+    foo
+    lappend res $::traceLog
+
+    trace remove execution lset enter dotrace
+    foo
+    lappend res $::traceLog
+
+    list $::traceCalls | {*}$res
+} -cleanup {
+    unset ::traceLog ::traceCalls ::bar res
+    rename dotrace {}
+    rename foo {}
+} -result {3 | 0 1 1}
+    
 
 
 # Delete procedures when done, so we don't clash with other tests
-- 
cgit v0.12


From 1834758e0b748ea3a3a3ccba35a181a07413d2c7 Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 6 Feb 2012 16:53:10 +0000
Subject: fix for [Bug 3484621], take 2

---
 generic/tclTrace.c | 17 +++++++++--------
 1 file changed, 9 insertions(+), 8 deletions(-)

diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index ad81c58..f1cc505 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -1123,16 +1123,17 @@ Tcl_TraceCommand(
     cmdPtr->tracePtr = tracePtr;
     if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
 	cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
-    }
-
-    /*
-     * Bug 3484621: up the interp's epoch if this is a BC'ed command
-     */
 
-    if (cmdPtr->compileProc != NULL) {
-	Interp *iPtr = (Interp *) interp;
-	iPtr->compileEpoch++;
+	/*
+	 * Bug 3484621: up the interp's epoch if this is a BC'ed command
+	 */
+	
+	if (cmdPtr->compileProc != NULL) {
+	    Interp *iPtr = (Interp *) interp;
+	    iPtr->compileEpoch++;
+	}
     }
+
     
     return TCL_OK;
 }
-- 
cgit v0.12


From 95563b40a7e7c0078ccc04dd78b4058ad655f9fa Mon Sep 17 00:00:00 2001
From: mig <mig>
Date: Mon, 6 Feb 2012 17:10:49 +0000
Subject: fix for [Bug 3484621], take 3

---
 generic/tclTrace.c | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/generic/tclTrace.c b/generic/tclTrace.c
index f1cc505..3ea182f 100644
--- a/generic/tclTrace.c
+++ b/generic/tclTrace.c
@@ -1122,16 +1122,15 @@ Tcl_TraceCommand(
     tracePtr->refCount = 1;
     cmdPtr->tracePtr = tracePtr;
     if (tracePtr->flags & TCL_TRACE_ANY_EXEC) {
-	cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
-
 	/*
 	 * Bug 3484621: up the interp's epoch if this is a BC'ed command
 	 */
 	
-	if (cmdPtr->compileProc != NULL) {
+	if ((cmdPtr->compileProc != NULL) && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)){
 	    Interp *iPtr = (Interp *) interp;
 	    iPtr->compileEpoch++;
 	}
+	cmdPtr->flags |= CMD_HAS_EXEC_TRACES;
     }
 
     
-- 
cgit v0.12


From b0b7c57736c4ec1e0cbb46da278f135136395019 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 6 Feb 2012 18:54:08 +0000
Subject: 3485022 Disable ensemble subcommand compile inside a
 Tcl_Create*Trace().

---
 generic/tclCompCmds.c | 3 ++-
 1 file changed, 2 insertions(+), 1 deletion(-)

diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 76181ee..1f8bd21 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -6326,7 +6326,8 @@ TclCompileEnsemble(
     cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
     TclDecrRefCount(targetCmdObj);
     if (cmdPtr == NULL || cmdPtr->compileProc == NULL
-	    || cmdPtr->flags & CMD_HAS_EXEC_TRACES) {
+	    || cmdPtr->flags & CMD_HAS_EXEC_TRACES
+	    || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
 	/*
 	 * Maps to an undefined command or a command without a compiler.
 	 * Cannot compile.
-- 
cgit v0.12


From c24d7161999195800c8c642c949d60bf0fbd0fe7 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 6 Feb 2012 19:12:24 +0000
Subject: Honor per-namespace compile suppression in ensemble subcommands.

---
 generic/tclEnsemble.c | 1 +
 1 file changed, 1 insertion(+)

diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 59f38a9..1283446 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -2890,6 +2890,7 @@ TclCompileEnsemble(
     cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, targetCmdObj);
     TclDecrRefCount(targetCmdObj);
     if (cmdPtr == NULL || cmdPtr->compileProc == NULL
+	    || cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION
 	    || cmdPtr->flags * CMD_HAS_EXEC_TRACES
 	    || ((Interp *)interp)->flags & DONT_COMPILE_CMDS_INLINE) {
 	/*
-- 
cgit v0.12


From 9d25d39845a0c2c1c3282634394e39a542ae0d9e Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Fri, 10 Feb 2012 15:06:01 +0000
Subject: Document, by a retroactive bug report, a nasty Notifier issue on
 64-bits x86 that affects the 8.4 branch

---
 ChangeLog | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index f659f89..b79e92a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -2302,7 +2302,7 @@
 
 	* unix/tclUnixChan.c:		TclUnixWaitForFile(): use FD_* macros
 	* macosx/tclMacOSXNotify.c:	to manipulate select masks (Cassoff).
-					[Bug 1960647]
+					[Freq 1960647] [Bug 3486554]
 
 	* unix/tclLoadDyld.c:		use RTLD_GLOBAL instead of RTLD_LOCAL.
 					[Bug 1961211]
-- 
cgit v0.12


From 57d7c35edaec375e42a65cd9c62fbc1a9c5d7e6d Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Fri, 10 Feb 2012 15:11:38 +0000
Subject: Document, by a retroactive bug report, a nasty Notifier issue on
 64-bits x86 that affects the 8.4 branch

---
 ChangeLog | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 386639a..33ac0b8 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -6221,7 +6221,7 @@
 
 	* unix/tclUnixChan.c:		TclUnixWaitForFile(): use FD_* macros
 	* macosx/tclMacOSXNotify.c:	to manipulate select masks (Cassoff).
-					[Bug 1960647]
+					[Freq 1960647] [Bug 3486554]
 
 	* unix/tclLoadDyld.c:		use RTLD_GLOBAL instead of RTLD_LOCAL.
 					[Bug 1961211]
-- 
cgit v0.12


From 32fb8662953b599dd793aea06f5d2938ae4973ae Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sat, 11 Feb 2012 15:44:35 +0000
Subject: Minor: Formatting fixes.

---
 ChangeLog | 223 ++++++++++++++++++++++++++++++--------------------------------
 1 file changed, 109 insertions(+), 114 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 33ac0b8..c0083d6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,33 +1,33 @@
 2012-02-09  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclStringObj.c:	Converted the memcpy() calls in 
-	append operations to memmove() calls.  This adds safety in the case
-	of overlapping copies, and improves performance on some benchmarks.
+	* generic/tclStringObj.c:	Converted the memcpy() calls in append
+	operations to memmove() calls.  This adds safety in the case of
+	overlapping copies, and improves performance on some benchmarks.
 
 2012-02-06  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclEnsemble.c: [Bug 3485022] TclCompileEnsemble() avoid
+	* generic/tclEnsemble.c: [Bug 3485022]: TclCompileEnsemble() avoid
 	* tests/trace.test:	compile when exec traces set.
 
 2012-02-06  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclTrace.c:  Fix for [Bug 3484621]: insure that
-	* tests/trace.test:    execution traces on bytecoded commands bump
-	the interp's compile epoch.
-	
+	* generic/tclTrace.c:  [Bug 3484621]: Ensure that execution traces on
+	* tests/trace.test:    bytecoded commands bump the interp's compile
+	epoch.
+
 2012-02-02  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclUniData.c: [Frq 3464401] Support Unicode 6.1
+	* generic/tclUniData.c: [FRQ 3464401]: Support Unicode 6.1
 	* generic/regc_locale.c:
 
 2012-02-02  Don Porter  <dgp@users.sourceforge.net>
 
 	* win/tclWinFile.c:	[Bugs 2974459,2879351,1951574,1852572,
-	1661378,1613456]: Revisions to the NativeAccess() routine that
-	queries file permissions on Windows native filesystems.  Meant to
-	fix numerous bugs where [file writable|readable|executable] "lies"
-	about what operations are possible, especially when the file resides
-	on a Samba share.
+	1661378,1613456]: Revisions to the NativeAccess() routine that queries
+	file permissions on Windows native filesystems.  Meant to fix numerous
+	bugs where [file writable|readable|executable] "lies" about what
+	operations are possible, especially when the file resides on a Samba
+	share.
 
 2012-02-01  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -62,10 +62,10 @@
 2012-01-22  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* tools/uniClass.tcl:    [FRQ 3473670]: Various Unicode-related
-	* tools/uniParse.tcl:    speedups/robustness. Enhanced tools to
-	* generic/tclUniData.c:  be able to handle characters > 0xffff
-	* generic/tclUtf.c:      Done in all branches in order to simplify
-	* generic/regc_locale.c: merges for new Unicode versions (such as 6.1)
+	* tools/uniParse.tcl:    speedups/robustness. Enhanced tools to be
+	* generic/tclUniData.c:  able to handle characters > 0xffff. Done in
+	* generic/tclUtf.c:      all branches in order to simplify merges for
+	* generic/regc_locale.c: new Unicode versions (such as 6.1)
 
 2012-01-22  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -156,9 +156,9 @@
 
 2011-11-30  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* library/tcltest/tcltest.tcl: [Bug 967195]: Make tcltest work
-	when tclsh is compiled without using the setargv() function on mingw.
-	(no need to incr the version, since 2.2.10 is never released)
+	* library/tcltest/tcltest.tcl: [Bug 967195]: Make tcltest work when
+	tclsh is compiled without using the setargv() function on mingw (No
+	need to incr the version, since 2.2.10 is never released).
 
 2011-11-29  Jan Nijtmans  <nijtmans@users.sf.net>
 
@@ -283,10 +283,9 @@
 
 2011-10-07  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tcl.h:        Fix gcc warnings (discovered with
-	* generic/tclIORChan.c: latest mingw, based on gcc 4.6.1)
-	* tests/env.test:       Fix env.test, when running
-	under wine 1.3
+	* generic/tcl.h:        Fix gcc warnings (discovered with latest
+	* generic/tclIORChan.c: mingw, based on gcc 4.6.1)
+	* tests/env.test:       Fix env.test, when running under wine 1.3.
 
 2011-10-06  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -344,8 +343,8 @@
 2011-09-23  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclIORTrans.c: More revisions to get finalization of
-	ReflectedTransforms correct, including adopting a "dead" field as
-	was done in tclIORChan.c.
+	ReflectedTransforms correct, including adopting a "dead" field as was
+	done in tclIORChan.c.
 
 	* tests/thread.test:	Stop using the deprecated thread management
 	commands of the tcltest package.  The test suite ought to provide
@@ -367,8 +366,8 @@
 
 	* generic/tclThreadTest.c: Revise the thread exit handling of the
 	[testthread] command so that it properly maintains the per-process
-	data structures even when the thread exits for reasons other than
-	the [testthread exit] command.
+	data structures even when the thread exits for reasons other than the
+	[testthread exit] command.
 
 2011-09-21  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
@@ -450,8 +449,8 @@
 
 2011-09-13  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclUtil.c:	[Bug 3390638]: Workaround broken solaris
-	studio cc optimizer.  Thanks to Wolfgang S. Kechel.
+	* generic/tclUtil.c:	[Bug 3390638]: Workaround broken Solaris
+	Studio cc optimizer.  Thanks to Wolfgang S. Kechel.
 
 	* generic/tclDTrace.d:	[Bug 3405652]: Portability workaround for
 	broken system DTrace support.  Thanks to Dagobert Michelson.
@@ -463,8 +462,8 @@
 
 2011-09-11  Don Porter  <dgp@users.sourceforge.net>
 
-	* tests/thread.test:	Convert [testthread] use to Thread package
-	use in thread-6.1.  Eliminates a memory leak in `make valgrind`.
+	* tests/thread.test:	Convert [testthread] use to Thread package use
+	in thread-6.1.  Eliminates a memory leak in `make valgrind`.
 
 	* tests/socket.test:	[Bug 3390699]: Convert [testthread] use to
 	Thread package use in socket_*-13.1.  Eliminates a memory leak in
@@ -830,12 +829,12 @@
 
 2011-07-15  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats()
-	is called in a deleted interp.
+	* generic/tclCompile.c: Avoid segfaults when RecordByteCodeStats() is
+	called in a deleted interp.
 
-	* generic/tclCompile.c:	[Bug 467523, 3357771]: Prevent circular
-	references in values with ByteCode intreps.  They can lead to
-	memory leaks.
+	* generic/tclCompile.c: [Bug 467523, 3357771]: Prevent circular
+	references in values with ByteCode intreps.  They can lead to memory
+	leaks.
 
 2011-07-14  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -888,8 +887,8 @@
 	asynchronous connection attempt. Improve comments for some of the
 	trickery around [socket -async].
 
-	* tests/socket.test: Adjust tests to the async code changes. Add
-	more tests for corner cases of async sockets.
+	* tests/socket.test: Adjust tests to the async code changes. Add more
+	tests for corner cases of async sockets.
 
 2011-06-22  Andreas Kupries  <andreask@activestate.com>
 
@@ -899,15 +898,15 @@
 	* win/Makefile.in:
 
 	* generic/tclInt.h: Fixed the inadvertently committed disabling of
-	  stack checks, see my 2010-11-15 commit.
+	stack checks, see my 2010-11-15 commit.
 
 2011-06-22  Reinhard Max  <max@suse.de>
 
 	Merge from rmax-ipv6-branch:
 	* unix/tclUnixSock.c: Fix [socket -async], so that all addresses
 	returned by getaddrinfo() are tried, not just the first one. This
-	requires the event loop to be running while the async connection
-	is in progress. ***POTENTIAL INCOMPATIBILITY***
+	requires the event loop to be running while the async connection is in
+	progress. ***POTENTIAL INCOMPATIBILITY***
 	* tests/socket.test: Add a test for the above.
 	* doc/socket: Document the fact that -async needs the event loop
 	* generic/tclIOSock.c: AI_ADDRCONFIG is broken on HP-UX
@@ -923,9 +922,9 @@
 
 2011-06-08  Andreas Kupries  <andreask@activestate.com>
 
-	* generic/tclExecute.c: Reverted the fix for [Bug 3274728]
-	committed on 2011-04-06 and replaced with one which is
-	64bit-safe. The existing fix crashed tclsh on Windows 64bit.
+	* generic/tclExecute.c: Reverted the fix for [Bug 3274728] committed
+	on 2011-04-06 and replaced with one which is 64bit-safe. The existing
+	fix crashed tclsh on Windows 64bit.
 
 2011-06-08  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -942,8 +941,8 @@
 2011-06-02  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclBasic.c:	Removed TclCleanupLiteralTable(), and old
-	* generic/tclInt.h:	band-aid routine put in place while a fix
-	* generic/tclLiteral.c:	for [Bug 994838] took shape.  No longer needed.
+	* generic/tclInt.h:	band-aid routine put in place while a fix for
+	* generic/tclLiteral.c:	[Bug 994838] took shape.  No longer needed.
 
 2011-06-02  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -959,16 +958,16 @@
 
 2011-06-01  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclUtil.c:   Fix for [Bug 3309871]: Valgrind finds:
-	invalid read in TclMaxListLength()
+	* generic/tclUtil.c:   Fix for [Bug 3309871]: Valgrind finds: invalid
+	read in TclMaxListLength().
 
 2011-05-31  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclInt.h:	Use a complete growth algorithm for lists
-	* generic/tclListObj.c:	so that length limits do not overconstrain
-	* generic/tclStringObj.c:	by a factor of 2.  [Bug 3293874]:
-	* generic/tclUtil.c:	Fix includes rooting all growth routines
-	by default on a commone tunable parameter TCL_MIN_GROWTH.
+	* generic/tclInt.h:	  Use a complete growth algorithm for lists so
+	* generic/tclListObj.c:	  that length limits do not overconstrain by a
+	* generic/tclStringObj.c: factor of 2.  [Bug 3293874]: Fix includes
+	* generic/tclUtil.c:	  rooting all growth routines by default on a
+	common tunable parameter TCL_MIN_GROWTH.
 
 2011-05-25  Don Porter  <dgp@users.sourceforge.net>
 
@@ -1001,27 +1000,26 @@
 2011-05-17  Andreas Kupries  <andreask@activestate.com>
 
 	* generic/tclCompile.c (TclFixupForwardJump): Tracked down and fixed
-	* generic/tclBasic.c (TclArgumentBCEnter): the cause of a violation
-	of my assertion that 'ePtr->nline == objc' in TclArgumentBCEnter.
-	When a bytecode was grown during jump fixup the pc -> command line
-	mapping was not updated. When things aligned just wrong the mapping
-	would direct command A to the data for command B, with a different
-	number of arguments.
+	* generic/tclBasic.c (TclArgumentBCEnter): the cause of a violation of
+	my assertion that 'ePtr->nline == objc' in TclArgumentBCEnter.  When a
+	bytecode was grown during jump fixup the pc -> command line mapping
+	was not updated. When things aligned just wrong the mapping would
+	direct command A to the data for command B, with a different number of
+	arguments.
 
 2011-05-11  Reinhard Max  <max@suse.de>
 
 	* unix/tclUnixSock.c (TcpWatchProc): No need to check for server
-	sockets here, as the generic server code already takes care of
-	that.
-	* tests/socket.test (accept): Add tests to make sure that this
-	remains so.
+	sockets here, as the generic server code already takes care of that.
+	* tests/socket.test (accept): Add tests to make sure that this remains
+	so.
 
 2011-05-10  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclInt.h:     New internal routines TclScanElement() and
 	* generic/tclUtil.c:    TclConvertElement() are rewritten guts of
-	machinery to produce string rep of lists.  The new routines avoid
-	and correct [Bug 3173086].  See comments for much more detail.
+	machinery to produce string rep of lists.  The new routines avoid and
+	correct [Bug 3173086].  See comments for much more detail.
 
 	* generic/tclDictObj.c:         Update all callers.
 	* generic/tclIndexObj.c:
@@ -1048,8 +1046,8 @@
 
 2011-05-07  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclInt.h: fix USE_TCLALLOC so that it can be enabled
-	* unix/Makefile.in: without editing the Makefile
+	* generic/tclInt.h: Fix USE_TCLALLOC so that it can be enabled without
+	* unix/Makefile.in: editing the Makefile.
 
 2011-05-05  Don Porter  <dgp@users.sourceforge.net>
 
@@ -1066,21 +1064,21 @@
 
 2011-05-02  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCmdMZ.c:	Revised TclFindElement() interface.  The
-	* generic/tclDictObj.c:	final argument had been bracePtr, the address
-	* generic/tclListObj.c:	of a boolean var, where the caller can be told
+	* generic/tclCmdMZ.c:	Revised TclFindElement() interface. The final
+	* generic/tclDictObj.c:	argument had been bracePtr, the address of a
+	* generic/tclListObj.c:	boolean var, where the caller can be told
 	* generic/tclParse.c:	whether or not the parsed list element was
 	* generic/tclUtil.c:	enclosed in braces.  In practice, no callers
 	really care about that.  What the callers really want to know is
 	whether the list element value exists as a literal substring of the
 	string being parsed, or whether a call to TclCopyAndCollpase() is
-	needed to produce the list element value.  Now the final argument
-	is changed to do what callers actually need.  This is a better fit
-	for the calls in tclParse.c, where now a good deal of post-processing
-	checking for "naked backslashes" is no longer necessary.
+	needed to produce the list element value.  Now the final argument is
+	changed to do what callers actually need. This is a better fit for the
+	calls in tclParse.c, where now a good deal of post-processing checking
+	for "naked backslashes" is no longer necessary.
 	***POTENTIAL INCOMPATIBILITY***
-	For any callers calling in via the internal stubs table who really
-	do use the final argument explicitly to check for the enclosing brace
+	For any callers calling in via the internal stubs table who really do
+	use the final argument explicitly to check for the enclosing brace
 	scenario.  Simply looking for the braces where they must be is the
 	revision available to those callers, and it will backport cleanly.
 
@@ -1095,17 +1093,17 @@
 	* generic/tclCompCmdsSZ.c:
 
 	* generic/tclCompCmdsSZ.c: Rewrite of parts of the switch compiler to
-	better use the powers of TclFindElement() and do less parsing on
-	its own.
+	better use the powers of TclFindElement() and do less parsing on its
+	own.
 
 2011-04-28  Don Porter  <dgp@users.sourceforge.net>
 
 	* generic/tclInt.h:	New utility routines:
-	* generic/tclParse.c:	TclIsSpaceProc() and
-	* generic/tclUtil.c:	TclCountSpaceRuns()
+	* generic/tclParse.c:	TclIsSpaceProc() and TclCountSpaceRuns()
+	* generic/tclUtil.c:
 
-	* generic/tclCmdMZ.c:	Use new routines to replace calls to
-	* generic/tclListObj.c:	isspace() and their /* INTL */ risk.
+	* generic/tclCmdMZ.c:	Use new routines to replace calls to isspace()
+	* generic/tclListObj.c:	and their /* INTL */ risk.
 	* generic/tclStrToD.c:
 	* generic/tclUtf.c:
 	* unix/tclUnixFile.c:
@@ -1164,8 +1162,8 @@
 	* generic/tclConfig.c:
 	* generic/tclListObj.c:
 
-	* generic/tclInt.h:	Define and use macros that test whether
-	* generic/tclBasic.c:	a Tcl list value is canonical.
+	* generic/tclInt.h:	Define and use macros that test whether a Tcl
+	* generic/tclBasic.c:	list value is canonical.
 	* generic/tclUtil.c:
 
 2011-04-18  Donal K. Fellows  <dkf@users.sf.net>
@@ -1335,8 +1333,7 @@
 2011-03-28  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclCmdMZ.c, generic/tclConfig.c, generic/tclUtil.c: More
-	generation of errorCode information, notably when lists are
-	mis-parsed.
+	generation of errorCode information, notably when lists are mis-parsed
 
 	* generic/tclCmdMZ.c (Tcl_RegexpObjCmd, Tcl_RegsubObjCmd): Use the
 	error messages generated by the variable management code rather than
@@ -1344,11 +1341,11 @@
 
 2011-03-27  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclBasic.c (TclNREvalObjEx): fix performance issue,
-	notably apparent in tclbench's "LIST lset foreach". Many thanks to
-	twylite for patiently researching the issue and explaining it to
-	me: a missing Tcl_ResetObjResult that causes unwanted sharing of
-	the current result Tcl_Obj.
+	* generic/tclBasic.c (TclNREvalObjEx): fix performance issue, notably
+	apparent in tclbench's "LIST lset foreach". Many thanks to Twylite for
+	patiently researching the issue and explaining it to me: a missing
+	Tcl_ResetObjResult that causes unwanted sharing of the current result
+	Tcl_Obj.
 
 2011-03-26  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -1420,8 +1417,8 @@
 
 2011-03-16  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclBasic.c:	Some rewrites to eliminate calls to
-	* generic/tclParse.c:	isspace() and their /* INTL */ risk.
+	* generic/tclBasic.c:	Some rewrites to eliminate calls to isspace()
+	* generic/tclParse.c:	and their /* INTL */ risk.
 	* generic/tclProc.c:
 
 2011-03-16  Jan Nijtmans  <nijtmans@users.sf.net>
@@ -1570,20 +1567,20 @@
 	* tests/assemble.test (new file):
 	* unix/Makefile.in:
 	* win/Makefile.in:
-	* win/makefile.vc:  Merged dogeen-assembler-branch into HEAD.
-	Since all functional changes are in the tcl::unsupported namespace,
-	there's no reason to sequester this code on a separate branch.
+	* win/makefile.vc:  Merged dogeen-assembler-branch into HEAD. Since
+	all functional changes are in the tcl::unsupported namespace, there's
+	no reason to sequester this code on a separate branch.
 
 2011-03-05  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclExecute.c: cleaner mem management for TEBCdata
+	* generic/tclExecute.c: Cleaner mem management for TEBCdata
 
 	* generic/tclExecute.c:
 	* tests/nre.test: Renamed BottomData to TEBCdata, so that the name
 	refers to what it is rather than to its storage location.
 
-	* generic/tclBasic.c:     Renamed struct TEOV_callback to
-	* generic/tclCompExpr.c:  the more descriptive NRE_callback.
+	* generic/tclBasic.c:     Renamed struct TEOV_callback to the more
+	* generic/tclCompExpr.c:  descriptive NRE_callback.
 	* generic/tclCompile.c:
 	* generic/tclExecute.c:
 	* generic/tclInt.decls:
@@ -1600,9 +1597,9 @@
 
 2011-03-01  Miguel Sofer  <msofer@users.sf.net>
 
-	* generic/tclBasic.c (TclNREvalObjv): missing a variable
-	declaration in commented out non-optimised code, left for ref in
-	checkin [b97b771b6d]
+	* generic/tclBasic.c (TclNREvalObjv): Missing a variable declaration
+	in commented out non-optimised code, left for ref in checkin
+	[b97b771b6d]
 
 2011-03-03  Don Porter  <dgp@users.sourceforge.net>
 
@@ -1633,8 +1630,8 @@
 	constants in automatic vars to reduce indirection, slight perf
 	increase
 
-	* generic/tclOOCall.c (TclOODeleteContext): Added missing '*' so
-	that trunk compiles.
+	* generic/tclOOCall.c (TclOODeleteContext): Added missing '*' so that
+	trunk compiles.
 
 	* generic/tclBasic.c (TclNRRunCallbacks): [Patch 3168229]: Don't do
 	the trampoline dance for commands that do not have an nreProc.
@@ -1722,10 +1719,9 @@
 2011-01-07  Kevin B. Kenny  <kennykb@acm.org>
 
 	* tests/util.test (util-15.*): Added test cases for floating point
-	conversion of the largest denormal and the smallest normal number,
-	to avoid any possibility of the failure suffered by PHP in the
-	last couple of days. (They didn't fail, so no actual functional
-	change.)
+	conversion of the largest denormal and the smallest normal number, to
+	avoid any possibility of the failure suffered by PHP in the last
+	couple of days. (They didn't fail, so no actual functional change.)
 
 2011-01-05  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -1832,8 +1828,7 @@
 
 2010-12-14  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tcl.h:	[Bug 3137454]: Tcl CVS HEAD does not build
-	on GCC 3.
+	* generic/tcl.h: [Bug 3137454]: Tcl CVS HEAD does not build on GCC 3.
 
 2010-12-14  Reinhard Max  <max@suse.de>
 
@@ -1848,8 +1843,8 @@
 	* generic/tcl.h:    [Bug 3135271]: Link error due to hidden
 	* unix/tcl.m4:      symbols (CentOS 4.2)
 	* unix/configure:   (autoconf-2.59)
-	* win/tclWinFile.c:  Undocumented feature, only meant to be
-	used by Tk_Main. See [Patch 3124554]: Move WishPanic from Tk to Tcl
+	* win/tclWinFile.c:  Undocumented feature, only meant to be used by
+	Tk_Main. See [Patch 3124554]: Move WishPanic from Tk to Tcl
 
 2010-12-12  Stuart Cassoff  <stwo@users.sourceforge.net>
 
-- 
cgit v0.12


From 5ab653feb0f92621dfa72b70722477353ae22c75 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 15 Feb 2012 09:51:12 +0000
Subject: 	* generic/tclCompCmds.c (TclCompileDictForCmd): [Bug 3487626]:
 Fix 	crash in compilation of [dict for] when its implementation command is 
 used directly rather than through the ensemble.

---
 ChangeLog             | 16 +++++++++++-----
 generic/tclCompCmds.c |  3 ++-
 tests/dict.test       | 51 +++++++++++++++++++++++++++++++++++++++++++++++++++
 3 files changed, 64 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b79e92a..94dc4ff 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,12 +1,18 @@
+2012-02-15  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclCompCmds.c (TclCompileDictForCmd): [Bug 3487626]: Fix
+	crash in compilation of [dict for] when its implementation command is
+	used directly rather than through the ensemble.
+
 2012-02-09  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclStringObj.c:	[Bug 3484402] Correct Off-By-One
+	* generic/tclStringObj.c:	[Bug 3484402]: Correct Off-By-One
 	error appending unicode. Thanks to Poor Yorick. Also corrected test
-	for when growth is needed. 
+	for when growth is needed.
 
 2012-02-06  Don Porter  <dgp@users.sourceforge.net>
 
-	* generic/tclCompCmds.c: [Bug 3485022] TclCompileEnsemble() avoid
+	* generic/tclCompCmds.c: [Bug 3485022]: TclCompileEnsemble() avoid
 	* tests/trace.test:	compile when exec traces set.
 
 2012-02-06  Miguel Sofer  <msofer@users.sf.net>
@@ -14,10 +20,10 @@
 	* generic/tclTrace.c:  Fix for [Bug 3484621]: insure that
 	* tests/trace.test:    execution traces on bytecoded commands bump
 	the interp's compile epoch.
-	
+
 2012-02-02  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclUniData.c: [Frq 3464401] Support Unicode 6.1
+	* generic/tclUniData.c: [FRQ 3464401]: Support Unicode 6.1
 	* generic/regc_locale.c:
 
 2012-02-02  Don Porter  <dgp@users.sourceforge.net>
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 1f8bd21..9eb74f5 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -972,7 +972,7 @@ TclCompileDictForCmd(
      * Compile the loop body itself. It should be stack-neutral.
      */
 
-    SetLineInformation (4);
+    SetLineInformation(3);
     CompileBody(envPtr, bodyTokenPtr, interp);
     TclEmitOpcode(   INST_POP,					envPtr);
 
@@ -1172,6 +1172,7 @@ TclCompileDictUpdateCmd(
     TclEmitInstInt4( INST_BEGIN_CATCH4, range,			envPtr);
 
     ExceptionRangeStarts(envPtr, range);
+    SetLineInformation(parsePtr->numWords - 1);
     CompileBody(envPtr, bodyTokenPtr, interp);
     ExceptionRangeEnds(envPtr, range);
 
diff --git a/tests/dict.test b/tests/dict.test
index 5821c32..b92893e 100644
--- a/tests/dict.test
+++ b/tests/dict.test
@@ -1194,6 +1194,57 @@ test dict-22.11 {dict with command: no recursive structures [Bug 1786481]} {
     string range [append foo OK] end-1 end
 } OK
 
+proc linenumber {} {
+    dict get [info frame -1] line
+}
+test dict-23.1 {dict compilation crash: Bug 3487626} {
+    apply {n {
+	set e {}
+	set k {}
+	dict for {a b} {c {d {e {f g}}}} {
+	    ::tcl::dict::for {h i} $b {
+		dict update i e j {
+		    ::tcl::dict::update j f k {
+			return [expr {$n - [linenumber]}]
+		    }
+		}
+	    }
+	}
+    }} [linenumber]
+} 5
+test dict-23.2 {dict compilation crash: Bug 3487626} knownBug {
+    # Something isn't quite right in line number and continuation line
+    # tracking; at time of writing, this test produces 7, not 5, which
+    # indicates that the extra newlines in the non-script argument are
+    # confusing things.
+    apply {n {
+	set e {}
+	set k {}
+	dict for {a {
+b
+}} {c {d {e {f g}}}} {
+	    ::tcl::dict::for {h {
+i
+}} ${
+b
+} {
+		dict update {
+i
+} e {
+j
+} {
+		    ::tcl::dict::update {
+j
+} f k {
+			return [expr {$n - [linenumber]}]
+		    }
+		}
+	    }
+	}
+    }} [linenumber]
+} 5
+rename linenumber {}
+
 # cleanup
 ::tcltest::cleanupTests
 return
-- 
cgit v0.12


From ef8842098dc6103ef6fc6fc7deb1b7e5395e85a2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 15 Feb 2012 12:02:48 +0000
Subject: 	* generic/tclCompCmds.c (TclCompileLrangeCmd): Add compiler
 for 	[lrange] with constant indices so we can take advantage of existing 
 TCL_LIST_RANGE_IMM opcode. 	(TclCompileLindexCmd): Improve coverage of
 constant-index-style 	compliation using technique developed for [lrange]
 above.

---
 ChangeLog             |  12 ++++--
 generic/tclBasic.c    |   2 +-
 generic/tclCompCmds.c | 113 ++++++++++++++++++++++++++++++++++++++++++++++++--
 generic/tclInt.h      |   3 ++
 4 files changed, 123 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index e28342b..d29f6aa 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,14 @@
 2012-02-15  Donal K. Fellows  <dkf@users.sf.net>
 
-	* generic/tclCompCmds.c (TclCompileDictForCmd): [Bug 3487626]: Fix
-	crash in compilation of [dict for] when its implementation command is
-	used directly rather than through the ensemble.
+	* generic/tclCompCmds.c (TclCompileLrangeCmd): Add compiler for
+	[lrange] with constant indices so we can take advantage of existing
+	TCL_LIST_RANGE_IMM opcode.
+	(TclCompileLindexCmd): Improve coverage of constant-index-style
+	compliation using technique developed for [lrange] above.
+
+	(TclCompileDictForCmd): [Bug 3487626]: Fix crash in compilation of
+	[dict for] when its implementation command is used directly rather
+	than through the ensemble.
 
 2012-02-09  Don Porter  <dgp@users.sourceforge.net>
 
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 0365966..d67153c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -230,7 +230,7 @@ static const CmdInfo builtInCmds[] = {
     {"linsert",		Tcl_LinsertObjCmd,	NULL,			NULL,	1},
     {"list",		Tcl_ListObjCmd,		TclCompileListCmd,	NULL,	1},
     {"llength",		Tcl_LlengthObjCmd,	TclCompileLlengthCmd,	NULL,	1},
-    {"lrange",		Tcl_LrangeObjCmd,	NULL,			NULL,	1},
+    {"lrange",		Tcl_LrangeObjCmd,	TclCompileLrangeCmd,	NULL,	1},
     {"lrepeat",		Tcl_LrepeatObjCmd,	NULL,			NULL,	1},
     {"lreplace",	Tcl_LreplaceObjCmd,	NULL,			NULL,	1},
     {"lreverse",	Tcl_LreverseObjCmd,	NULL,			NULL,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index 18ff3dc..c96f05c 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3147,13 +3147,24 @@ TclCompileLindexCmd(
 
 	tmpObj = Tcl_NewStringObj(idxTokenPtr[1].start, idxTokenPtr[1].size);
 	result = TclGetIntFromObj(NULL, tmpObj, &idx);
+	if (result == TCL_OK) {
+	    if (idx < 0) {
+		result = TCL_ERROR;
+	    }
+	} else {
+	    result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx);
+	    if (result == TCL_OK && idx > -2) {
+		result = TCL_ERROR;
+	    }
+	}
 	TclDecrRefCount(tmpObj);
 
-	if (result == TCL_OK && idx >= 0) {
+	if (result == TCL_OK) {
 	    /*
-	     * All checks have been completed, and we have exactly this
-	     * construct:
+	     * All checks have been completed, and we have exactly one of
+	     * these constructs:
 	     *	 lindex <arbitraryValue> <posInt>
+	     *	 lindex <arbitraryValue> end-<posInt>
 	     * This is best compiled as a push of the arbitrary value followed
 	     * by an "immediate lindex" which is the most efficient variety.
 	     */
@@ -3298,6 +3309,102 @@ TclCompileLlengthCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileLrangeCmd --
+ *
+ *	How to compile the "lrange" command. We only bother because we needed
+ *	the opcode anyway for "lassign".
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLrangeCmd(
+    Tcl_Interp *interp,		/* Tcl interpreter for context. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the
+				 * command. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds the resulting instructions. */
+{
+    Tcl_Token *tokenPtr, *listTokenPtr;
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Obj *tmpObj;
+    int idx1, idx2, result;
+
+    if (parsePtr->numWords != 4) {
+	return TCL_ERROR;
+    }
+    listTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    /*
+     * Parse the first index. Will only compile if it is constant and not an
+     * _integer_ less than zero (since we reserve negative indices here for
+     * end-relative indexing).
+     */
+
+    tokenPtr = TokenAfter(listTokenPtr);
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	return TCL_ERROR;
+    }
+    tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+    result = TclGetIntFromObj(NULL, tmpObj, &idx1);
+    if (result == TCL_OK) {
+	if (idx1 < 0) {
+	    result = TCL_ERROR;
+	}
+    } else {
+	result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
+	if (result == TCL_OK && idx1 > -2) {
+	    result = TCL_ERROR;
+	}
+    }
+    TclDecrRefCount(tmpObj);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Parse the second index. Will only compile if it is constant and not an
+     * _integer_ less than zero (since we reserve negative indices here for
+     * end-relative indexing).
+     */
+
+    tokenPtr = TokenAfter(tokenPtr);
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	return TCL_ERROR;
+    }
+    tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+    result = TclGetIntFromObj(NULL, tmpObj, &idx2);
+    if (result == TCL_OK) {
+	if (idx2 < 0) {
+	    result = TCL_ERROR;
+	}
+    } else {
+	result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
+	if (result == TCL_OK && idx2 > -2) {
+	    result = TCL_ERROR;
+	}
+    }
+    TclDecrRefCount(tmpObj);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
+     * we've not proved that the 'list' argument is really a list. Not that it
+     * is worth trying to do that given current knowledge.
+     */
+
+    CompileWord(envPtr, listTokenPtr, interp, 1);
+    TclEmitInstInt4(		INST_LIST_RANGE_IMM, idx1,	envPtr);
+    TclEmitInt4(		idx2,				envPtr);
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileLsetCmd --
  *
  *	Procedure called to compile the "lset" command.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index feede54..37fce70 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3547,6 +3547,9 @@ MODULE_SCOPE int	TclCompileListCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileLlengthCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileLrangeCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileLsetCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From 182448a5403990b1f583b5f9cf6cf6d8e2b7c8de Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 15 Feb 2012 20:43:08 +0000
Subject: 	* generic/tclCompCmds.c (TclCompileLreplaceCmd): Added a
 compilation 	strategy for [lreplace] that tackles the cases which are
 equivalent to 	a static [lrange].

---
 ChangeLog             |   8 ++--
 generic/tclBasic.c    |   2 +-
 generic/tclCompCmds.c | 124 ++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclInt.h      |   3 ++
 4 files changed, 133 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index d29f6aa..e5d23bf 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,10 @@
 2012-02-15  Donal K. Fellows  <dkf@users.sf.net>
 
-	* generic/tclCompCmds.c (TclCompileLrangeCmd): Add compiler for
-	[lrange] with constant indices so we can take advantage of existing
-	TCL_LIST_RANGE_IMM opcode.
+	* generic/tclCompCmds.c (TclCompileLreplaceCmd): Added a compilation
+	strategy for [lreplace] that tackles the cases which are equivalent to
+	a static [lrange].
+	(TclCompileLrangeCmd): Add compiler for [lrange] with constant indices
+	so we can take advantage of existing TCL_LIST_RANGE_IMM opcode.
 	(TclCompileLindexCmd): Improve coverage of constant-index-style
 	compliation using technique developed for [lrange] above.
 
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index d67153c..c07fa70 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -232,7 +232,7 @@ static const CmdInfo builtInCmds[] = {
     {"llength",		Tcl_LlengthObjCmd,	TclCompileLlengthCmd,	NULL,	1},
     {"lrange",		Tcl_LrangeObjCmd,	TclCompileLrangeCmd,	NULL,	1},
     {"lrepeat",		Tcl_LrepeatObjCmd,	NULL,			NULL,	1},
-    {"lreplace",	Tcl_LreplaceObjCmd,	NULL,			NULL,	1},
+    {"lreplace",	Tcl_LreplaceObjCmd,	TclCompileLreplaceCmd,	NULL,	1},
     {"lreverse",	Tcl_LreverseObjCmd,	NULL,			NULL,	1},
     {"lsearch",		Tcl_LsearchObjCmd,	NULL,			NULL,	1},
     {"lset",		Tcl_LsetObjCmd,		TclCompileLsetCmd,	NULL,	1},
diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c
index c96f05c..5b7e0a5 100644
--- a/generic/tclCompCmds.c
+++ b/generic/tclCompCmds.c
@@ -3405,6 +3405,130 @@ TclCompileLrangeCmd(
 /*
  *----------------------------------------------------------------------
  *
+ * TclCompileLreplaceCmd --
+ *
+ *	How to compile the "lreplace" command. We only bother with the case
+ *	where there are no elements to insert and where both the 'first' and
+ *	'last' arguments are constant and one can be deterined to be at the
+ *	end of the list. (This is the case that could also be written with
+ *	"lrange".)
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileLreplaceCmd(
+    Tcl_Interp *interp,		/* Tcl interpreter for context. */
+    Tcl_Parse *parsePtr,	/* Points to a parse structure for the
+				 * command. */
+    Command *cmdPtr,		/* Points to defintion of command being
+				 * compiled. */
+    CompileEnv *envPtr)		/* Holds the resulting instructions. */
+{
+    Tcl_Token *tokenPtr, *listTokenPtr;
+    DefineLineInformation;	/* TIP #280 */
+    Tcl_Obj *tmpObj;
+    int idx1, idx2, result, guaranteedDropAll = 0;
+
+    if (parsePtr->numWords != 4) {
+	return TCL_ERROR;
+    }
+    listTokenPtr = TokenAfter(parsePtr->tokenPtr);
+
+    /*
+     * Parse the first index. Will only compile if it is constant and not an
+     * _integer_ less than zero (since we reserve negative indices here for
+     * end-relative indexing).
+     */
+
+    tokenPtr = TokenAfter(listTokenPtr);
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	return TCL_ERROR;
+    }
+    tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+    result = TclGetIntFromObj(NULL, tmpObj, &idx1);
+    if (result == TCL_OK) {
+	if (idx1 < 0) {
+	    result = TCL_ERROR;
+	}
+    } else {
+	result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx1);
+	if (result == TCL_OK && idx1 > -2) {
+	    result = TCL_ERROR;
+	}
+    }
+    TclDecrRefCount(tmpObj);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Parse the second index. Will only compile if it is constant and not an
+     * _integer_ less than zero (since we reserve negative indices here for
+     * end-relative indexing).
+     */
+
+    tokenPtr = TokenAfter(tokenPtr);
+    if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+	return TCL_ERROR;
+    }
+    tmpObj = Tcl_NewStringObj(tokenPtr[1].start, tokenPtr[1].size);
+    result = TclGetIntFromObj(NULL, tmpObj, &idx2);
+    if (result == TCL_OK) {
+	if (idx2 < 0) {
+	    result = TCL_ERROR;
+	}
+    } else {
+	result = TclGetIntForIndexM(NULL, tmpObj, -2, &idx2);
+	if (result == TCL_OK && idx2 > -2) {
+	    result = TCL_ERROR;
+	}
+    }
+    TclDecrRefCount(tmpObj);
+    if (result != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Sanity check: can only issue when we're removing a range at one or
+     * other end of the list. If we're at one end or the other, convert the
+     * indices into the equivalent for an [lrange].
+     */
+
+    if (idx1 == 0) {
+	if (idx2 == -2) {
+	    guaranteedDropAll = 1;
+	}
+	idx1 = idx2 + 1;
+	idx2 = -2;
+    } else if (idx2 == -2) {
+	idx2 = idx1 - 1;
+	idx1 = 0;
+    } else {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Issue instructions. It's not safe to skip doing the LIST_RANGE, as
+     * we've not proved that the 'list' argument is really a list. Not that it
+     * is worth trying to do that given current knowledge.
+     */
+
+    CompileWord(envPtr, listTokenPtr, interp, 1);
+    if (guaranteedDropAll) {
+	TclEmitOpcode(		INST_LIST_LENGTH,		envPtr);
+	TclEmitOpcode(		INST_POP,			envPtr);
+	PushLiteral(envPtr, "", 0);
+    } else {
+	TclEmitInstInt4(	INST_LIST_RANGE_IMM, idx1,	envPtr);
+	TclEmitInt4(		idx2,				envPtr);
+    }
+    return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * TclCompileLsetCmd --
  *
  *	Procedure called to compile the "lset" command.
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 37fce70..08b3f70 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -3550,6 +3550,9 @@ MODULE_SCOPE int	TclCompileLlengthCmd(Tcl_Interp *interp,
 MODULE_SCOPE int	TclCompileLrangeCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
+MODULE_SCOPE int	TclCompileLreplaceCmd(Tcl_Interp *interp,
+			    Tcl_Parse *parsePtr, Command *cmdPtr,
+			    struct CompileEnv *envPtr);
 MODULE_SCOPE int	TclCompileLsetCmd(Tcl_Interp *interp,
 			    Tcl_Parse *parsePtr, Command *cmdPtr,
 			    struct CompileEnv *envPtr);
-- 
cgit v0.12


From b4ca6b5a992c406bbf4f3ef73ecb5ae2a8d878a6 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 16 Feb 2012 13:51:02 +0000
Subject: * generic/tclExecute.c (INST_LIST_RANGE_IMM): Enhance implementation
 so that shortening a (not multiply-referenced) list by lopping the end off
 with [lrange] or [lreplace] is efficient.

---
 ChangeLog            |  6 ++++++
 generic/tclExecute.c | 25 +++++++++++++++++++++++--
 2 files changed, 29 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index e5d23bf..7f8c443 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,9 @@
+2012-02-16  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclExecute.c (INST_LIST_RANGE_IMM): Enhance implementation
+	so that shortening a (not multiply-referenced) list by lopping the end
+	off with [lrange] or [lreplace] is efficient.
+
 2012-02-15  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclCompCmds.c (TclCompileLreplaceCmd): Added a compilation
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 92b6612..e402634 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -4310,12 +4310,33 @@ TEBCresume(
 	 */
 
 	if (fromIdx<=toIdx && fromIdx<objc && toIdx>=0) {
-	    if (fromIdx<0) {
+	    if (fromIdx < 0) {
 		fromIdx = 0;
 	    }
 	    if (toIdx >= objc) {
 		toIdx = objc-1;
 	    }
+	    if (fromIdx == 0 && toIdx != objc-1 && !Tcl_IsShared(valuePtr)) {
+		/*
+		 * BEWARE! This is looking inside the implementation of the
+		 * list type.
+		 */
+
+		List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1;
+
+		if (listPtr->refCount == 1) {
+		    TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr),
+			    TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)));
+		    for (index=toIdx+1 ; index<objc-1 ; index++) {
+			TclDecrRefCount(objv[index]);
+		    }
+		    listPtr->elemCount = toIdx+1;
+		    listPtr->canonicalFlag = 1;
+		    TclInvalidateStringRep(valuePtr);
+		    TRACE_APPEND(("%.30s\n", O2S(valuePtr)));
+		    NEXT_INST_F(9, 0, 0);
+		}
+	    }
 	    objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, objv+fromIdx);
 	} else {
 	    TclNewObj(objResultPtr);
@@ -5716,7 +5737,7 @@ TEBCresume(
 		}
 		result = TclIncrObj(interp, valuePtr, value2Ptr);
 		if (result == TCL_OK) {
-		    Tcl_InvalidateStringRep(dictPtr);
+		    TclInvalidateStringRep(dictPtr);
 		}
 		TclDecrRefCount(value2Ptr);
 	    }
-- 
cgit v0.12


From 52c4fef3cfd97fa473a7cc98397cde9c6dde64a9 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 16 Feb 2012 23:09:59 +0000
Subject: [Bug 2233954] AIX: compile error

---
 ChangeLog           | 5 +++++
 generic/tclIOUtil.c | 3 +++
 unix/tclUnixPort.h  | 4 +++-
 3 files changed, 11 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 94dc4ff..48b6f81 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-02-17  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclIOUtil.c: [Bug 2233954] AIX: compile error
+	* unix/tclUnixPort.h:
+
 2012-02-15  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclCompCmds.c (TclCompileDictForCmd): [Bug 3487626]: Fix
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index fb8b74f..b8c76c0 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -18,6 +18,9 @@
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  */
 
+#ifdef HAVE_SYS_STAT_H
+#   include <sys/stat.h>
+#endif
 #include "tclInt.h"
 #ifdef __WIN32__
 #   include "tclWinInt.h"
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index 421d73c..e4008c9 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -85,7 +85,9 @@ typedef off_t		Tcl_SeekOffset;
 #ifdef HAVE_SYS_SELECT_H
 #   include <sys/select.h>
 #endif
-#include <sys/stat.h>
+#ifdef HAVE_SYS_STAT_H
+#   include <sys/stat.h>
+#endif
 #if TIME_WITH_SYS_TIME
 #   include <sys/time.h>
 #   include <time.h>
-- 
cgit v0.12


From 6df0a0efa540b67adb5a9d1bb2c5f58f8f656e23 Mon Sep 17 00:00:00 2001
From: sebres <sebres@users.sourceforge.net>
Date: Fri, 17 Feb 2012 15:14:16 +0000
Subject: bug fix: avoid segfaulting by deleted interp in RecordByteCodeStats

---
 generic/tclCompile.c | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 6d64feb..59d1fbf 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -4091,12 +4091,11 @@ RecordByteCodeStats(
 				 * to add to accumulated statistics. */
 {
     Interp *iPtr = (Interp *) *codePtr->interpHandle;
-    register ByteCodeStats *statsPtr = &(iPtr->stats);
-
     if (iPtr == NULL) {
 	/* Avoid segfaulting in case we're called in a deleted interp */
 	return;
     }
+    register ByteCodeStats *statsPtr = &(iPtr->stats);
 
     statsPtr->numCompilations++;
     statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
-- 
cgit v0.12


From 76adf66e550eb63f49a19c9ada4e49123efea2ec Mon Sep 17 00:00:00 2001
From: andreask <andreask>
Date: Fri, 17 Feb 2012 17:12:32 +0000
Subject: Fix: Removed C99ism (in-block variable declaration) from commit
 [39f6ebe301] which prevents building with non-gcc compilers, notably AIX,
 HPUX, Solaris, MSVC6, possibly others.

---
 generic/tclCompile.c | 4 +++-
 1 file changed, 3 insertions(+), 1 deletion(-)

diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index 59d1fbf..9b23389 100644
--- a/generic/tclCompile.c
+++ b/generic/tclCompile.c
@@ -4091,11 +4091,13 @@ RecordByteCodeStats(
 				 * to add to accumulated statistics. */
 {
     Interp *iPtr = (Interp *) *codePtr->interpHandle;
+    register ByteCodeStats *statsPtr;
+
     if (iPtr == NULL) {
 	/* Avoid segfaulting in case we're called in a deleted interp */
 	return;
     }
-    register ByteCodeStats *statsPtr = &(iPtr->stats);
+    statsPtr = &(iPtr->stats);
 
     statsPtr->numCompilations++;
     statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
-- 
cgit v0.12


From 7e1cb76f0617c08d56ca78ebe894a0e1f3d9d532 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 17 Feb 2012 21:17:27 +0000
Subject: [Bug 2233954] AIX: compile error, but don't do that for _WIN32
 (doesn't work in VS10)

---
 generic/tclIOUtil.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index b8c76c0..e714471 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -18,7 +18,7 @@
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  */
 
-#ifdef HAVE_SYS_STAT_H
+#if defined(HAVE_SYS_STAT_H) && !defined _WIN32
 #   include <sys/stat.h>
 #endif
 #include "tclInt.h"
-- 
cgit v0.12


From f40cc098f4cfadea6aa0a597de897558fc92e427 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 21 Feb 2012 10:25:45 +0000
Subject: Documentation clarification, as discussed in [Bug 3482614].

---
 doc/AddErrInfo.3 | 6 ++++++
 1 file changed, 6 insertions(+)

diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3
index 4087b41..e450a3e 100644
--- a/doc/AddErrInfo.3
+++ b/doc/AddErrInfo.3
@@ -108,6 +108,11 @@ by \fBTcl_GetReturnOptions\fR points to an unshared
 \fBTcl_Obj\fR with reference count of zero.  The dictionary
 may be written to, either adding, removing, or overwriting
 any entries in it, without the need to check for a shared object.
+As with any \fBTcl_Obj\fR with reference count of zero, it is up to
+the caller to arrange for its disposal with \fBTcl_DecrRefCount\fR or
+to a reference to it via \fBTcl_IncrRefCount\fR (or one of the many
+functions that call that, notably including \fBTcl_SetObjResult\fR and
+\fBTcl_SetVar2Ex\fR).
 .PP
 A typical usage for \fBTcl_GetReturnOptions\fR is to
 retrieve the stack trace when script evaluation returns
@@ -123,6 +128,7 @@ if (code == TCL_ERROR) {
     Tcl_DictObjGet(NULL, options, key, &stackTrace);
     Tcl_DecrRefCount(key);
     /* Do something with stackTrace */
+    Tcl_DecrRefCount(options);
 }
 .CE
 .PP
-- 
cgit v0.12


From 9e0ab0841248c6ba0cf49036de9005c8d0120a28 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 23 Feb 2012 21:08:11 +0000
Subject: Add tests relating to bug 1115587. The bug itself still exists at
 this point.

---
 ChangeLog      |  7 ++++++-
 tests/reg.test | 63 ++++++++++++++++++++++++++++++----------------------------
 2 files changed, 39 insertions(+), 31 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 48b6f81..e603d00 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,11 @@
+2012-02-23  Donal K. Fellows  <dkf@users.sf.net>
+
+	* tests/reg.test (14.21-23): Add tests relating to bug 1115587. Actual
+	bug is characterised by test marked with 'knownBug'.
+
 2012-02-17  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclIOUtil.c: [Bug 2233954] AIX: compile error
+	* generic/tclIOUtil.c: [Bug 2233954]: AIX: compile error
 	* unix/tclUnixPort.h:
 
 2012-02-15  Donal K. Fellows  <dkf@users.sf.net>
diff --git a/tests/reg.test b/tests/reg.test
index d92339f..0ebfa11 100644
--- a/tests/reg.test
+++ b/tests/reg.test
@@ -174,14 +174,32 @@ namespace eval RETest {
 	return $ret
     }
 
+    # Share the generation of the list of test constraints so it is
+    # done the same on all routes.
+    proc TestConstraints {flags} {
+	set constraints [list testregexp]
+
+	variable regBug
+	if {$regBug} {
+	    # This will trigger registration as a skipped test
+	    lappend constraints knownBug
+	}
+
+	# Tcl locale stuff doesn't do the ch/xy test fakery yet
+	if {[string match *+* $flags]} {
+	    # This will trigger registration as a skipped test
+	    lappend constraints localeRegexp
+	}
+
+	return $constraints
+    }
+
     # match expected, internal routine that does the work
     # parameters like the "real" routines except they don't have "opts",
     #  which is a possibly-empty list of switches for the regexp match attempt
     # The ! flag is used to indicate expected match failure (for REG_EXPECT,
     #  which wants argument testing even in the event of failure).
     proc MatchExpected {opts testid flags re target args} {
-	variable regBug
-
 	# if &, test as both BRE and ARE
 	if {[string match *&* $flags]} {
 	    set f [string map {& {}} $flags]
@@ -190,18 +208,7 @@ namespace eval RETest {
 	    return
 	}
 
-	set constraints [list testregexp]
-
-	if {$regBug} {
-	    # This will register as a skipped test
-	    lappend constraints knownBug
-	}
-
-	# Tcl locale stuff doesn't do the ch/xy test fakery yet
-	if {[string match *+* $flags]} {
-	    # This will register as a skipped test
-	    lappend constraints localeRegexp
-	}
+	set constraints [TestConstraints $flags]
 
 	set f [TestFlags $flags]
 	set infoflags [TestInfoFlags $flags]
@@ -252,13 +259,7 @@ namespace eval RETest {
 	    return
 	}
 
-	set constraints [list testregexp]
-
-	# Tcl locale stuff doesn't do the ch/xy test fakery yet
-	if {[string match *+* $flags]} {
-	    # This will register as a skipped test
-	    lappend constraints localeRegexp
-	}
+	set constraints [TestConstraints $flags]
 
 	set cmd [list testregexp -about {*}[TestFlags $flags] $re]
 	::tcltest::test [TestNum $testid error] [TestDesc $testid error] \
@@ -268,6 +269,7 @@ namespace eval RETest {
 
     # match failure expected
     proc expectNomatch {testid flags re target args} {
+	variable regBug
 	# if &, test as both ARE and BRE
 	if {[string match *&* $flags]} {
 	    set f [string map {& {}} $flags]
@@ -276,13 +278,7 @@ namespace eval RETest {
 	    return
 	}
 
-	set constraints [list testregexp]
-
-	# Tcl locale stuff doesn't do the ch/xy test fakery yet
-	if {[string match *+* $flags]} {
-	    # This will register as a skipped test
-	    lappend constraints localeRegexp
-	}
+	set constraints [TestConstraints $flags]
 
 	set f [TestFlags $flags]
 	set infoflags [TestInfoFlags $flags]
@@ -331,7 +327,7 @@ namespace eval RETest {
     }
 }
 namespace import RETest::*
-
+
 ######## the tests themselves ########
 
 # support functions and preliminary misc.
@@ -660,6 +656,9 @@ expectMatch	14.17 RP	{a([bc])(\1*)}	ab	ab	b	""
 expectError	14.18 -		{a((b)\1)}	ESUBREG
 expectError	14.19 -		{a(b)c\2}	ESUBREG
 expectMatch	14.20 bR	{a\(b*\)c\1}	abbcbb	abbcbb	bb
+expectMatch	14.21 RP	{^([bc])\1*$}	bbb	bbb	b
+expectMatch	14.22 RP	{^([bc])\1*$}	ccc	ccc	c
+knownBug expectNomatch 14.23 R	{^([bc])\1*$}	bcb
 
 
 doing 15 "octal escapes vs back references"
@@ -1069,7 +1068,11 @@ test reg-33.13 {Bug 1810264 - infinite loop} {
 test reg-33.14 {Bug 1810264 - super-expensive expression} nonPortable {
     regexp {(x{200}){200}$y} {x}
 } 0
-
+
 # cleanup
 ::tcltest::cleanupTests
 return
+
+# Local Variables:
+# mode: tcl
+# End:
-- 
cgit v0.12


From 714ba439a2a5271a913fede2596c072cb2564516 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 2 Mar 2012 10:05:57 +0000
Subject: (Tcl_SetByteArrayObj): Only zero out the memory block if it is not
 being immediately overwritten. Thanks to Stuart Cassoff for spotting.

---
 ChangeLog           | 8 +++++++-
 generic/tclBinary.c | 9 ++++++---
 2 files changed, 13 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b180bcd..987a251 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,12 @@
+2012-03-02  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclBinary.c (Tcl_SetByteArrayObj): Only zero out the memory
+	block if it is not being immediately overwritten. (Caller might still
+	overwrite, but we should at least avoid known-useless work.)
+
 2012-02-29  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclIOUtil.c:	[Bug 3466099] BOM in Unicode
+	* generic/tclIOUtil.c:	[Bug 3466099]: BOM in Unicode
 	* generic/tclEncoding.c:
 	* tests/source.test
 
diff --git a/generic/tclBinary.c b/generic/tclBinary.c
index 0a340f2..444e7fa 100644
--- a/generic/tclBinary.c
+++ b/generic/tclBinary.c
@@ -305,11 +305,14 @@ Tcl_SetByteArrayObj(
 
     length = (length < 0) ? 0 : length;
     byteArrayPtr = ckalloc(BYTEARRAY_SIZE(length));
-    memset(byteArrayPtr, 0, BYTEARRAY_SIZE(length));
     byteArrayPtr->used = length;
     byteArrayPtr->allocated = length;
-    if (bytes && length) {
-	memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
+    if (length) {
+	if (bytes) {
+	    memcpy(byteArrayPtr->bytes, bytes, (size_t) length);
+	} else {
+	    memset(byteArrayPtr->bytes, 0, (size_t) length);
+	}
     }
 
     objPtr->typePtr = &tclByteArrayType;
-- 
cgit v0.12


From e7d0f5ecae05758ef91de4a3c1e6422bd82953ed Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Fri, 2 Mar 2012 10:07:39 +0000
Subject: Add bug number.

---
 ChangeLog | 7 ++++---
 1 file changed, 4 insertions(+), 3 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 987a251..1f2e93d 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,9 @@
 2012-03-02  Donal K. Fellows  <dkf@users.sf.net>
 
-	* generic/tclBinary.c (Tcl_SetByteArrayObj): Only zero out the memory
-	block if it is not being immediately overwritten. (Caller might still
-	overwrite, but we should at least avoid known-useless work.)
+	* generic/tclBinary.c (Tcl_SetByteArrayObj): [Bug 3496014]: Only zero
+	out the memory block if it is not being immediately overwritten. (Our
+	caller might still overwrite, but we should at least avoid
+	known-useless work.)
 
 2012-02-29  Jan Nijtmans  <nijtmans@users.sf.net>
 
-- 
cgit v0.12


From f0662ef7a305f951d6d48a1b84c83b362cd7ae5e Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 5 Mar 2012 20:39:40 +0000
Subject: eliminate the use of intptr_t

---
 generic/tclTest.c | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/generic/tclTest.c b/generic/tclTest.c
index cb0faad..c08f281 100644
--- a/generic/tclTest.c
+++ b/generic/tclTest.c
@@ -5349,7 +5349,7 @@ TestmainthreadCmd(
     const char **argv)		/* Argument strings. */
 {
   if (argc == 1) {
-      Tcl_Obj *idObj = Tcl_NewLongObj((long)(intptr_t)Tcl_GetCurrentThread());
+      Tcl_Obj *idObj = Tcl_NewLongObj((long)(size_t)Tcl_GetCurrentThread());
       Tcl_SetObjResult(interp, idObj);
       return TCL_OK;
   } else {
@@ -6048,7 +6048,7 @@ TestChannelCmd(
 	    return TCL_ERROR;
 	}
 
-	TclFormatInt(buf, (long)(intptr_t)Tcl_GetChannelThread(chan));
+	TclFormatInt(buf, (long)(size_t)Tcl_GetChannelThread(chan));
 	Tcl_AppendResult(interp, buf, NULL);
 	return TCL_OK;
     }
-- 
cgit v0.12


From 4b85ca90cba7edb9a10caead17ffa8d407e1e2b3 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Wed, 7 Mar 2012 20:54:01 +0000
Subject: Refactor TclScanElement() part of list parsing to take advantage of
 tables constructed for the task of script parsing.  Ought to speed generation
 of string representation of lists, though the effect is likely only
 noticeable on long lists made up primarily of simple elements (not needing
 quoting).

---
 generic/tclParse.c | 14 ++------------
 generic/tclParse.h | 17 +++++++++++++++++
 generic/tclUtil.c  | 33 ++++++++++++++++++---------------
 unix/Makefile.in   |  5 +++--
 4 files changed, 40 insertions(+), 29 deletions(-)
 create mode 100644 generic/tclParse.h

diff --git a/generic/tclParse.c b/generic/tclParse.c
index 3c984bf..f0050c6 100644
--- a/generic/tclParse.c
+++ b/generic/tclParse.c
@@ -14,6 +14,7 @@
  */
  
 #include "tclInt.h"
+#include "tclParse.h"
 
 /*
  * The following table provides parsing information about each possible 8-bit
@@ -41,18 +42,7 @@
  * TYPE_BRACE -		Character is a curly brace (either left or right).
  */
 
-#define TYPE_NORMAL		0
-#define TYPE_SPACE		0x1
-#define TYPE_COMMAND_END	0x2
-#define TYPE_SUBS		0x4
-#define TYPE_QUOTE		0x8
-#define TYPE_CLOSE_PAREN	0x10
-#define TYPE_CLOSE_BRACK	0x20
-#define TYPE_BRACE		0x40
-
-#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]
-
-static const char charTypeTable[] = {
+const char charTypeTable[] = {
     /*
      * Negative character values, from -128 to -1:
      */
diff --git a/generic/tclParse.h b/generic/tclParse.h
new file mode 100644
index 0000000..be1ab15
--- /dev/null
+++ b/generic/tclParse.h
@@ -0,0 +1,17 @@
+/*
+ * Minimal set of shared macro definitions and declarations so that multiple
+ * source files can make use of the parsing table in tclParse.c
+ */
+
+#define TYPE_NORMAL		0
+#define TYPE_SPACE		0x1
+#define TYPE_COMMAND_END	0x2
+#define TYPE_SUBS		0x4
+#define TYPE_QUOTE		0x8
+#define TYPE_CLOSE_PAREN	0x10
+#define TYPE_CLOSE_BRACK	0x20
+#define TYPE_BRACE		0x40
+
+#define CHAR_TYPE(c) (charTypeTable+128)[(int)(c)]
+
+MODULE_SCOPE const char charTypeTable[];
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 31c9fd3..6ce430b 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -13,6 +13,7 @@
  */
 
 #include "tclInt.h"
+#include "tclParse.h"
 #include <math.h>
 
 /*
@@ -972,15 +973,16 @@ TclScanElement(
     }
 
     while (length) {
+      if (CHAR_TYPE(*p) != TYPE_NORMAL) {
 	switch (*p) {
-	case '{':
+	case '{':	/* TYPE_BRACE */
 #if COMPAT
 	    braceCount++;
 #endif
 	    extra++;				/* Escape '{' => '\{' */
 	    nestingLevel++;
 	    break;
-	case '}':
+	case '}':	/* TYPE_BRACE */
 #if COMPAT
 	    braceCount++;
 #endif
@@ -991,8 +993,8 @@ TclScanElement(
 		requireEscape = 1;
 	    }
 	    break;
-	case ']':
-	case '"':
+	case ']':	/* TYPE_CLOSE_BRACK */
+	case '"':	/* TYPE_SPACE */
 #if COMPAT
 	    forbidNone = 1;
 	    extra++;		/* Escapes all just prepend a backslash */
@@ -1001,22 +1003,22 @@ TclScanElement(
 #else
 	    /* FLOW THROUGH */
 #endif
-	case '[':
-	case '$':
-	case ';':
-	case ' ':
-	case '\f':
-	case '\n':
-	case '\r':
-	case '\t':
-	case '\v':
+	case '[':	/* TYPE_SUBS */
+	case '$':	/* TYPE_SUBS */
+	case ';':	/* TYPE_COMMAND_END */
+	case ' ':	/* TYPE_SPACE */
+	case '\f':	/* TYPE_SPACE */
+	case '\n':	/* TYPE_COMMAND_END */
+	case '\r':	/* TYPE_SPACE */
+	case '\t':	/* TYPE_SPACE */
+	case '\v':	/* TYPE_SPACE */
 	    forbidNone = 1;
 	    extra++;		/* Escape sequences all one byte longer. */
 #if COMPAT
 	    preferBrace = 1;
 #endif
 	    break;
-	case '\\':
+	case '\\':	/* TYPE_SUBS */
 	    extra++;				/* Escape '\' => '\\' */
 	    if ((length == 1) || ((length == -1) && (p[1] == '\0'))) {
 		/* Final backslash. Cannot format with brace quoting. */
@@ -1041,13 +1043,14 @@ TclScanElement(
 	    preferBrace = 1;
 #endif
 	    break;
-	case '\0':
+	case '\0':	/* TYPE_SUBS */
 	    if (length == -1) {
 		goto endOfString;
 	    }
 	    /* TODO: Panic on improper encoding? */
 	    break;
 	}
+      }
 	length -= (length > 0);
 	p++;
     }
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 34b9003..0a22a58 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -990,6 +990,7 @@ COMPILEHDR=$(GENERIC_DIR)/tclCompile.h
 FSHDR=$(GENERIC_DIR)/tclFileSystem.h
 IOHDR=$(GENERIC_DIR)/tclIO.h
 MATHHDRS=$(GENERIC_DIR)/tommath.h $(GENERIC_DIR)/tclTomMath.h
+PARSEHDR=$(GENERIC_DIR)/tclParse.h
 NREHDR=$(GENERIC_DIR)/tclInt.h
 
 regcomp.o: $(REGHDRS) $(GENERIC_DIR)/regcomp.c $(GENERIC_DIR)/regc_lex.c \
@@ -1186,7 +1187,7 @@ tclOOMethod.o: $(GENERIC_DIR)/tclOOMethod.c
 tclOOStubInit.o: $(GENERIC_DIR)/tclOOStubInit.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclOOStubInit.c
 
-tclParse.o: $(GENERIC_DIR)/tclParse.c
+tclParse.o: $(GENERIC_DIR)/tclParse.c $(PARSEHDR)
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclParse.c
 
 tclPanic.o: $(GENERIC_DIR)/tclPanic.c
@@ -1258,7 +1259,7 @@ tclStubInit.o: $(GENERIC_DIR)/tclStubInit.c
 tclTrace.o: $(GENERIC_DIR)/tclTrace.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclTrace.c
 
-tclUtil.o: $(GENERIC_DIR)/tclUtil.c
+tclUtil.o: $(GENERIC_DIR)/tclUtil.c $(PARSEHDR)
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclUtil.c
 
 tclUtf.o: $(GENERIC_DIR)/tclUtf.c $(GENERIC_DIR)/tclUniData.c
-- 
cgit v0.12


From 64997e6db9c283aeaa383cf901d7f45949cd0c24 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 8 Mar 2012 09:55:39 +0000
Subject: Various minor fixes (prompted by Andreas Kupries detecting a spelling
 mistake).

---
 ChangeLog  |  5 +++++
 doc/info.n | 70 ++++++++++++++++++++++++++++++++++----------------------------
 2 files changed, 43 insertions(+), 32 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index af6d1ca..3282626 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,8 @@
+2012-03-08  Donal K. Fellows  <dkf@users.sf.net>
+
+	* doc/info.n: Various minor fixes (prompted by Andreas Kupries
+	detecting a spelling mistake).
+
 2012-03-07  Andreas Kupries  <andreask@activestate.com>
 
 	* library/http/http.tcl: [Bug 3498327]: Generate upper-case
diff --git a/doc/info.n b/doc/info.n
index 0001ae9..eca5977 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -3,7 +3,7 @@
 '\" Copyright (c) 1994-1997 Sun Microsystems, Inc.
 '\" Copyright (c) 1993-1997 Bell Labs Innovations for Lucent Technologies
 '\" Copyright (c) 1998-2000 Ajuba Solutions
-'\" Copyright (c) 2007-2008 Donal K. Fellows
+'\" Copyright (c) 2007-2012 Donal K. Fellows
 '\"
 '\" See the file "license.terms" for information on usage and redistribution
 '\" of this file, and for a DISCLAIMER OF ALL WARRANTIES.
@@ -79,9 +79,9 @@ lines have been typed to complete the command.
 .TP
 \fBinfo coroutine\fR
 .VS 8.6
-Returns the name of the currently executing coroutine, or the empty string if
-either no coroutine is currently executing, or the current coroutine has been
-deleted (but has not yet returned or yielded since deletion).
+Returns the name of the currently executing \fBcoroutine\fR, or the empty
+string if either no coroutine is currently executing, or the current coroutine
+has been deleted (but has not yet returned or yielded since deletion).
 .VE 8.6
 .TP
 \fBinfo default \fIprocname arg varname\fR
@@ -97,23 +97,27 @@ into variable \fIvarname\fR.
 Returns, in a form that is programmatically easy to parse, the function names
 and arguments at each level from the call stack of the last error in the given
 \fIinterp\fR, or in the current one if not specified.
-
+.RS
+.PP
 This form is an even-sized list alternating tokens and parameters. Tokens are
 currently either \fBCALL\fR, \fBUP\fR, or \fBINNER\fR, but other values may be
 introduced in the future. \fBCALL\fR indicates a procedure call, and its
-parameter is the corresponding [info level 0]. \fBUP\fR indicates a shift in
-variable frames generated by uplevel or similar, and applies to the previous
-CALL item. Its parameter is the level offset. \fBINNER\fR identifies the
-"inner context", which is the innermost atomic command or bytecode instruction
-that raised the error, along with its arguments when available. While
-\fBCALL\fR and \fBUP\fR allow to follow complex call paths, \fBINNER\fR homes
-in on the offending operation in the innermost proc call, even going to
-sub-expr granularity.
-
-This information is also present in the
-\fB\-errorstack\fR entry of the options dictionary returned by 3-argument
-\fBcatch\fR; \fBinfo errorstack\fR is a convenient way of retrieving it for
-uncaught errors at toplevel in an interactive tclsh.
+parameter is the corresponding \fBinfo level\fR \fB0\fR. \fBUP\fR indicates a
+shift in variable frames generated by \fBuplevel\fR or similar, and applies to
+the previous \fBCALL\fR item. Its parameter is the level offset. \fBINNER\fR
+identifies the
+.QW "inner context" ,
+which is the innermost atomic command or bytecode instruction that raised the
+error, along with its arguments when available. While \fBCALL\fR and \fBUP\fR
+allow to follow complex call paths, \fBINNER\fR homes in on the offending
+operation in the innermost procedure call, even going to sub-expression
+granularity.
+.PP
+This information is also present in the \fB\-errorstack\fR entry of the
+options dictionary returned by 3-argument \fBcatch\fR; \fBinfo errorstack\fR
+is a convenient way of retrieving it for uncaught errors at top-level in an
+interactive \fBtclsh\fR.
+.RE
 .VE 8.6
 .TP
 \fBinfo exists \fIvarName\fR
@@ -176,7 +180,7 @@ means that the command is executed by \fBeval\fR or \fBuplevel\fR.
 .TP
 \fBprecompiled\fR\0\0\0\0\0\0\0\0
 .
-means that the command is found in a precompiled script (loadable by
+means that the command is found in a pre-compiled script (loadable by
 the package \fBtbcload\fR), and no further information will be
 available.
 .RE
@@ -197,9 +201,10 @@ normalized path of the file the command is in.
 \fBcmd\fR
 .
 This entry provides the string representation of the command. This is
-usually the unsubstituted form, however for commands which are a pure
-list executed by eval it is the substituted form as they have no other
-string representation. Care is taken that the pure-List property of
+usually the unsubstituted form, however for commands which are a
+canonically-constructed list (e.g., as produced by the \fBlist\fR command)
+executed by \fBeval\fR it is the substituted form as they have no other
+string representation. Care is taken that the canonicality property of
 the latter is not spoiled.
 .TP
 \fBproc\fR
@@ -226,8 +231,8 @@ locations of commands in their bodies will be reported with type
 defined procedures, and literal eval scripts in files or statically
 defined procedures.
 .PP
-In contrast, a procedure definition or \fBeval\fR within a dynamically
-\fBeval\fRuated environment count linenumbers relative to the start of
+In contrast, procedure definitions and \fBeval\fR within a dynamically
+\fBeval\fRuated environment count line numbers relative to the start of
 their script, even if they would be able to count relative to the
 start of the outer dynamic script. That type of number usually makes
 more sense.
@@ -239,8 +244,8 @@ possible the lines are counted based on the smallest possible
 than any dynamic outer scope.
 .PP
 The syntactic form \fB{*}\fR is handled like \fBeval\fR. I.e. if it
-is given a literal list argument the system tracks the linenumber
-within the list words as well, and otherwise all linenumbers are
+is given a literal list argument the system tracks the line number
+within the list words as well, and otherwise all line numbers are
 counted relative to the start of each word (smallest scope)
 .RE
 .TP
@@ -671,7 +676,7 @@ This subcommand returns a list of all variables in the private namespace of
 the object named \fIobject\fR. If the optional \fIpattern\fR argument is
 given, it is a filter (in the syntax of a \fBstring match\fR glob pattern)
 that constrains the list of variables returned. Note that this is different
-from the lit returned by \fBinfo object variables\fR; that can include
+from the list returned by \fBinfo object variables\fR; that can include
 variables that are currently unset, whereas this can include variables that
 are not automatically included by any of \fIobject\fR's methods (or those of
 its class, superclasses or mixins).
@@ -731,10 +736,11 @@ proc getDef {obj method} {
 }
 .CE
 .PP
-This is an alternate way of implementing the definition lookup is by manually
-scanning the list of methods up the inheritance tree. This code assumes that
-only single inheritance is in use, and that there is no complex use of
-mixed-in classes:
+This is an alternate way of looking up the definition; it is implemented by
+manually scanning the list of methods up the inheritance tree. This code
+assumes that only single inheritance is in use, and that there is no complex
+use of mixed-in classes (in such cases, using \fBinfo object call\fR as above
+is the simplest way of doing this by far):
 .PP
 .CS
 proc getDef {obj method} {
@@ -746,7 +752,7 @@ proc getDef {obj method} {
     while {$method ni [\fBinfo class methods\fR $cls]} {
         # Assume the simple case
         set cls [lindex [\fBinfo class superclass\fR $cls] 0]
-        if {$cls eq {}} {
+        if {$cls eq ""} {
             error "no definition for $method"
         }
     }
-- 
cgit v0.12


From 014ce74e1d7d90d99e3b310e2e4a923f789802a2 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 8 Mar 2012 21:12:24 +0000
Subject: More small bits of doc mending.

---
 ChangeLog    |  4 ++--
 doc/socket.n | 22 ++++++++++++----------
 2 files changed, 14 insertions(+), 12 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 3282626..3adc58c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,7 @@
 2012-03-08  Donal K. Fellows  <dkf@users.sf.net>
 
-	* doc/info.n: Various minor fixes (prompted by Andreas Kupries
-	detecting a spelling mistake).
+	* doc/info.n:   Various minor fixes (prompted by Andreas Kupries
+	* doc/socket.n: detecting a spelling mistake).
 
 2012-03-07  Andreas Kupries  <andreask@activestate.com>
 
diff --git a/doc/socket.n b/doc/socket.n
index e3087c9..0a60457 100644
--- a/doc/socket.n
+++ b/doc/socket.n
@@ -72,7 +72,8 @@ This option will cause the client socket to be connected
 asynchronously. This means that the socket will be created immediately
 but may not yet be connected to the server, when the call to
 \fBsocket\fR returns.
-
+.RS
+.PP
 When a \fBgets\fR or \fBflush\fR is done on the socket before the
 connection attempt succeeds or fails, if the socket is in blocking
 mode, the operation will wait until the connection is completed or
@@ -82,22 +83,20 @@ succeeds or fails, the operation returns immediately and
 \fBfblocked\fR on the socket returns 1. Synchronous client sockets may
 be switched (after they have connected) to operating in asynchronous
 mode using:
-.RS
 .PP
 .CS
 \fBchan configure \fIchan \fB\-blocking 0\fR
 .CE
 .PP
 See the \fBchan configure\fR command for more details.
-
+.PP
 The Tcl event loop should be running while an asynchronous connection
 is in progress, because it may have to do several connection attempts
-in the background. Runnig the event loop also allows you to set up a
+in the background. Running the event loop also allows you to set up a
 writable channel event on the socket to get notified when the
-asyncronous connection has succeeded or failed. See the \fBvwait\fR
-and the \fBchan\fR comands for more details on the event loop and
+asynchronous connection has succeeded or failed. See the \fBvwait\fR
+and the \fBchan\fR commands for more details on the event loop and
 channel events.
-
 .RE
 .SH "SERVER SOCKETS"
 .PP
@@ -157,9 +156,11 @@ This option gets the current error status of the given socket.  This
 is useful when you need to determine if an asynchronous connect
 operation succeeded.  If there was an error, the error message is
 returned.  If there was no error, an empty string is returned.
-
+.RS
+.PP
 Note that the error status is reset by the read operation; this mimics
 the underlying getsockopt(SO_ERROR) call.
+.RE
 .TP
 \fB\-sockname\fR
 .
@@ -168,14 +169,15 @@ client connects to a server socket) this option returns a list of
 three elements, the address, the host name and the port number for the
 socket. If the host name cannot be computed, the second element is
 identical to the address, the first element of the list.
-
+.RS
+.PP
 For server sockets this option returns a list of a multiple of three
 elements each group of which have the same meaning as described
 above. The list contains more than one group when the server socket
 was created without \fB\-myaddr\fR or with the argument to
 \fB\-myaddr\fR being a domain name that resolves multiple IP addresses
 that are local to the invoking host.
-
+.RE
 .TP
 \fB\-peername\fR
 .
-- 
cgit v0.12


From c93c3a3b39929c9a7f1c816f4dc8a058f9eea85c Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 11 Mar 2012 17:03:00 +0000
Subject: A number of small spelling and wording fixes in the docs.

---
 ChangeLog          |  4 ++++
 doc/Class.3        |  2 +-
 doc/CrtChannel.3   |  2 +-
 doc/DictObj.3      |  2 +-
 doc/Ensemble.3     |  2 +-
 doc/FileSystem.3   |  5 ++---
 doc/FindExec.3     |  2 +-
 doc/GetStdChan.3   |  2 +-
 doc/GetTime.3      | 24 +++++++++++-------------
 doc/Hash.3         |  2 +-
 doc/InitStubs.3    |  6 +++---
 doc/OpenFileChnl.3 |  2 +-
 doc/RegConfig.3    |  2 +-
 doc/SetChanErr.3   |  2 +-
 doc/SplitPath.3    |  2 +-
 doc/StringObj.3    |  4 ++--
 doc/Tcl.n          |  2 +-
 doc/Thread.3       | 12 ++++++------
 doc/binary.n       |  4 ++--
 doc/catch.n        |  2 +-
 doc/chan.n         | 36 ++++++++++++++++++------------------
 doc/close.n        | 17 +++++++++++------
 doc/gets.n         | 10 +++++++---
 doc/info.n         | 12 ++++++------
 doc/mathfunc.n     |  4 ++++
 doc/my.n           |  2 +-
 doc/next.n         |  8 ++++----
 doc/object.n       |  4 ++--
 doc/proc.n         |  4 ++--
 doc/re_syntax.n    |  5 +++--
 doc/seek.n         |  6 +++++-
 doc/self.n         |  2 +-
 32 files changed, 107 insertions(+), 88 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 3adc58c..fd1c750 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,7 @@
+2012-03-11  Donal K. Fellows  <dkf@users.sf.net>
+
+	* doc/*.n, doc/*.3: A number of small spelling and wording fixes.
+
 2012-03-08  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/info.n:   Various minor fixes (prompted by Andreas Kupries
diff --git a/doc/Class.3 b/doc/Class.3
index dbb5b99..28cea9b 100644
--- a/doc/Class.3
+++ b/doc/Class.3
@@ -125,7 +125,7 @@ any constructors.
 Every object and every class may have arbitrary amounts of metadata attached
 to it, which the object or class attaches no meaning to beyond what is
 described in a Tcl_ObjectMetadataType structure instance. Metadata to be
-attached is described by the the type of the metadata (given in the
+attached is described by the type of the metadata (given in the
 \fImetaTypePtr\fR argument) and an arbitrary pointer (the \fImetadata\fR
 argument) that are given to \fBTcl_ObjectSetMetadata\fR and
 \fBTcl_ClassSetMetadata\fR, and a particular piece of metadata can be
diff --git a/doc/CrtChannel.3 b/doc/CrtChannel.3
index 9aadba2..478ef0b 100644
--- a/doc/CrtChannel.3
+++ b/doc/CrtChannel.3
@@ -211,7 +211,7 @@ call to \fBTcl_GetStdChannel\fR or a call to \fBTcl_SetStdChannel\fR
 closing this standard channel will cause the next call to
 \fBTcl_CreateChannel\fR to make the new channel the new standard
 channel too. See \fBTcl_StandardChannels\fR for a general treatise
-about standard channels and the behaviour of the Tcl library with
+about standard channels and the behavior of the Tcl library with
 regard to them.
 .PP
 \fBTcl_GetChannelInstanceData\fR returns the instance data associated with
diff --git a/doc/DictObj.3 b/doc/DictObj.3
index 74b8dd1..a5dc9e5 100644
--- a/doc/DictObj.3
+++ b/doc/DictObj.3
@@ -62,7 +62,7 @@ Points to a variable that will have the key from a key/value pair
 placed within it.  May be NULL to indicate that the caller is not
 interested in the key.
 .AP Tcl_Obj *valuePtr in
-Points to the value for the key/value pair being manipulate within the
+Points to the value for the key/value pair being manipulated within the
 dictionary object (or sub-object, in the case of
 \fBTcl_DictObjPutKeyList\fR.)
 .AP Tcl_Obj **valuePtrPtr out
diff --git a/doc/Ensemble.3 b/doc/Ensemble.3
index 19c6099..8a8c74e 100644
--- a/doc/Ensemble.3
+++ b/doc/Ensemble.3
@@ -95,7 +95,7 @@ Pointer to a variable into which to write the current ensemble mapping
 dictionary.
 .AP Tcl_Obj *listObj in
 A list value to use for the list of formal pre-subcommand parameters, the
-defined list of subcommands in the dictionary or the unknown subcommmand
+defined list of subcommands in the dictionary or the unknown subcommand
 handler command prefix. May be NULL if the subcommand list or unknown handler
 are to be removed.
 .AP Tcl_Obj **listObjPtr out
diff --git a/doc/FileSystem.3 b/doc/FileSystem.3
index e3870c3..cf785ae 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -649,8 +649,7 @@ passed in \fIlenPtr\fR is non-NULL, the variable it points to will be
 updated to contain the number of elements in the returned list.
 .PP
 \fBTcl_FSEqualPaths\fR tests whether the two paths given represent the same
-filesystem object
-.PP
+filesystem object.
 It returns 1 if the paths are equal, and 0 if they are different. If
 either path is NULL, 0 is always returned.
 .PP
@@ -1005,7 +1004,7 @@ The \fIpathInFilesystemProc\fR field contains the address of a function
 which is called to determine whether a given path object belongs to this
 filesystem or not. Tcl will only call the rest of the filesystem
 functions with a path for which this function has returned \fBTCL_OK\fR.
-If the path does not belong, -1 should be returned (the behaviour of Tcl
+If the path does not belong, -1 should be returned (the behavior of Tcl
 for any other return value is not defined). If \fBTCL_OK\fR is returned,
 then the optional \fIclientDataPtr\fR output parameter can be used to
 return an internal (filesystem specific) representation of the path,
diff --git a/doc/FindExec.3 b/doc/FindExec.3
index 66cc1f1..e4b4ed0 100644
--- a/doc/FindExec.3
+++ b/doc/FindExec.3
@@ -47,7 +47,7 @@ will return an empty string.
 .PP
 On Windows platforms this procedure is typically invoked as the very
 first thing in the application's main program as well; Its \fIargv[0]\fR
-argument is only used to indicate wheter the executable has a stderr
+argument is only used to indicate whether the executable has a stderr
 channel (any non-null value) or not (the value null). If \fBTcl_SetPanicProc\fR
 is never called and no debugger is running, this determines whether
 the panic message is sent to stderr or to a standard system dialog.
diff --git a/doc/GetStdChan.3 b/doc/GetStdChan.3
index 7bc2e1b..e76ad66 100644
--- a/doc/GetStdChan.3
+++ b/doc/GetStdChan.3
@@ -77,7 +77,7 @@ assigned starting with standard input, followed by standard output, with
 standard error being last.
 .PP
 See \fBTcl_StandardChannels\fR for a general treatise about standard
-channels and the behaviour of the Tcl library with regard to them.
+channels and the behavior of the Tcl library with regard to them.
 
 .SH "SEE ALSO"
 Tcl_Close(3), Tcl_CreateChannel(3), Tcl_Main(3), tclsh(1)
diff --git a/doc/GetTime.3 b/doc/GetTime.3
index d902f90..f4da364 100644
--- a/doc/GetTime.3
+++ b/doc/GetTime.3
@@ -90,21 +90,19 @@ typedef void \fBTcl_ScaleTimeProc\fR(
 .CE
 .PP
 The \fItimebuf\fR fields contain the time to manipulate, and the
-\fIclientData\fR fields contain a pointer supplied at the time the
-handler functions were registered.
+\fIclientData\fR fields contain a pointer supplied at the time the handler
+functions were registered.
 .PP
-Any handler pair specified has to return data which is consistent
-between them. In other words, setting one handler of the pair to
-something assuming a 10-times slowdown, and the other handler of the
-pair to something assuming a two-times slowdown is wrong and not
-allowed.
+Any handler pair specified has to return data which is consistent between
+them. In other words, setting one handler of the pair to something assuming a
+10-times slowdown, and the other handler of the pair to something assuming a
+two-times slowdown is wrong and not allowed.
 .PP
-The set handler functions are allowed to run the delivered time
-backwards, however this should be avoided. We have to allow it as the
-native time can run backwards as the user can fiddle with the system
-time one way or other. Note that the insertion of the hooks will not
-change the behaviour of the Tcl core with regard to this situation,
-i.e. the existing behaviour is retained.
+The set handler functions are allowed to run the delivered time backwards,
+however this should be avoided. We have to allow it as the native time can run
+backwards as the user can fiddle with the system time one way or other. Note
+that the insertion of the hooks will not change the behavior of the Tcl core
+with regard to this situation, i.e. the existing behavior is retained.
 .SH "SEE ALSO"
 clock(n)
 .SH KEYWORDS
diff --git a/doc/Hash.3 b/doc/Hash.3
index 5a19d72..d8e3d2c 100644
--- a/doc/Hash.3
+++ b/doc/Hash.3
@@ -57,7 +57,7 @@ Kind of keys to use for new hash table.  Must be either
 \fBTCL_STRING_KEYS\fR, \fBTCL_ONE_WORD_KEYS\fR, \fBTCL_CUSTOM_TYPE_KEYS\fR,
 \fBTCL_CUSTOM_PTR_KEYS\fR, or an integer value greater than 1.
 .AP Tcl_HashKeyType *typePtr in
-Address of structure which defines the behaviour of the hash table.
+Address of structure which defines the behavior of the hash table.
 .AP "const void" *key in
 Key to use for probe into table.  Exact form depends on
 \fIkeyType\fR used to create table.
diff --git a/doc/InitStubs.3 b/doc/InitStubs.3
index 318c564..5f56278 100644
--- a/doc/InitStubs.3
+++ b/doc/InitStubs.3
@@ -63,9 +63,9 @@ Define the \fBUSE_TCL_STUBS\fR symbol.  Typically, you would include the
 \fB\-DUSE_TCL_STUBS\fR flag when compiling the extension.
 .IP 3) 5
 Link the extension with the Tcl stubs library instead of the standard
-Tcl library.  On Unix platforms, the library name is
-\fIlibtclstub8.1.a\fR; on Windows platforms, the library name is
-\fItclstub81.lib\fR.
+Tcl library.  For example, to use the Tcl 8.1 ABI on Unix platforms,
+the library name is \fIlibtclstub8.1.a\fR; on Windows platforms, the
+library name is \fItclstub81.lib\fR.
 .PP
 If the extension also requires the Tk API, it must also call
 \fBTk_InitStubs\fR to initialize the Tk stubs interface and link
diff --git a/doc/OpenFileChnl.3 b/doc/OpenFileChnl.3
index 337a9a9..2368492 100644
--- a/doc/OpenFileChnl.3
+++ b/doc/OpenFileChnl.3
@@ -332,7 +332,7 @@ This procedure interacts with the code managing the standard
 channels. If no standard channels were initialized before the first
 call to \fBTcl_RegisterChannel\fR, they will get initialized by that
 call. See \fBTcl_StandardChannels\fR for a general treatise about
-standard channels and the behaviour of the Tcl library with regard to
+standard channels and the behavior of the Tcl library with regard to
 them.
 .SH TCL_UNREGISTERCHANNEL
 .PP
diff --git a/doc/RegConfig.3 b/doc/RegConfig.3
index 7c41350..063cc85 100644
--- a/doc/RegConfig.3
+++ b/doc/RegConfig.3
@@ -80,7 +80,7 @@ create a namespace having the provided \fIpkgName\fR, if not yet
 existing.
 .IP (2)
 create the command \fBpkgconfig\fR in that namespace and link it to
-the provided information so that the keys from _configuration_ and
+the provided information so that the keys from \fIconfiguration\fR and
 their associated values can be retrieved through calls to
 \fBpkgconfig\fR.
 .PP
diff --git a/doc/SetChanErr.3 b/doc/SetChanErr.3
index b6c1975..0a62dac 100644
--- a/doc/SetChanErr.3
+++ b/doc/SetChanErr.3
@@ -51,7 +51,7 @@ allowed to use \fBTcl_SetChannelError\fR and \fBTcl_SetChannelErrorInterp\fR
 to place arbitrary error messages in \fBbypass areas\fR defined for channels
 and interpreters. And the generic I/O layer uses \fBTcl_GetChannelError\fR and
 \fBTcl_GetChannelErrorInterp\fR to look for messages in the bypass areas and
-arrange for their return as errors. The posix error codes set by a driver are
+arrange for their return as errors. The POSIX error codes set by a driver are
 used now if and only if no messages are present.
 .PP
 \fBTcl_SetChannelError\fR stores error information in the bypass area of the
diff --git a/doc/SplitPath.3 b/doc/SplitPath.3
index ec8f96b..7fdfce6 100644
--- a/doc/SplitPath.3
+++ b/doc/SplitPath.3
@@ -43,7 +43,7 @@ A pointer to an initialized \fBTcl_DString\fR to which the result of
 
 .SH DESCRIPTION
 .PP
-These procedures have been superceded by the objectified procedures in
+These procedures have been superseded by the objectified procedures in
 the \fBFileSystem\fR man page, which are more efficient.
 .PP
 These procedures may be used to disassemble and reassemble file
diff --git a/doc/StringObj.3 b/doc/StringObj.3
index 371cdff..412ab78 100644
--- a/doc/StringObj.3
+++ b/doc/StringObj.3
@@ -125,7 +125,7 @@ the length of an object's string representation.
 .AP "const char" *string in
 Null-terminated string value to append to \fIobjPtr\fR.
 .AP va_list argList in
-An argument list which must have been initialised using
+An argument list which must have been initialized using
 \fBva_start\fR, and cleared using \fBva_end\fR.
 .AP int limit in
 Maximum number of bytes to be appended.
@@ -230,7 +230,7 @@ object's new string representation.
 \fIobjPtr\fR.  If the object has an invalid Unicode representation,
 then \fIunicode\fR is converted to the UTF format and appended to the
 object's string representation.  Appends are optimized to handle
-repeated appends relatively efficiently (it overallocates the string
+repeated appends relatively efficiently (it over-allocates the string
 or Unicode space to avoid repeated reallocations and copies of
 object's string value).
 .PP
diff --git a/doc/Tcl.n b/doc/Tcl.n
index c14c4dc..68146ab 100644
--- a/doc/Tcl.n
+++ b/doc/Tcl.n
@@ -214,7 +214,7 @@ inserted.  The upper bits of the Unicode character will be 0.
 \e\fBU\fIhhhhhhhh\fR 
 .
 The hexadecimal digits \fIhhhhhhhh\fR (one up to eight of them) give a
-twentiy-one-bit hexadecimal value for the Unicode character that will be
+twenty-one-bit hexadecimal value for the Unicode character that will be
 inserted, in the range U+0000..U+10FFFF.  The parser will stop just
 before this range overflows, or when the maximum of eight digits
 is reached.  The upper bits of the Unicode character will be 0.
diff --git a/doc/Thread.3 b/doc/Thread.3
index 4b5e7c3..ca135ee 100644
--- a/doc/Thread.3
+++ b/doc/Thread.3
@@ -70,7 +70,7 @@ Arbitrary information. Passed as sole argument to the \fIproc\fR.
 .AP int stackSize in
 The size of the stack given to the new thread.
 .AP int flags in
-Bitmask containing flags allowing the caller to modify behaviour of
+Bitmask containing flags allowing the caller to modify behavior of
 the new thread.
 .AP int *result out
 The referred storage is used to place the exit code of the thread
@@ -91,15 +91,15 @@ and use multiple interpreters.)
 .SH DESCRIPTION
 Tcl provides \fBTcl_CreateThread\fR for creating threads. The
 caller can determine the size of the stack given to the new thread and
-modify the behaviour through the supplied \fIflags\fR. The value
+modify the behavior through the supplied \fIflags\fR. The value
 \fBTCL_THREAD_STACK_DEFAULT\fR for the \fIstackSize\fR indicates that
 the default size as specified by the operating system is to be used
 for the new thread. As for the flags, currently only the values
 \fBTCL_THREAD_NOFLAGS\fR and \fBTCL_THREAD_JOINABLE\fR are defined. The
-first of them invokes the default behaviour with no
-specialties. Using the second value marks the new thread as
-\fIjoinable\fR. This means that another thread can wait for the such
-marked thread to exit and join it.
+first of them invokes the default behavior with no special settings.
+Using the second value marks the new thread as \fIjoinable\fR. This
+means that another thread can wait for the such marked thread to exit
+and join it.
 .PP
 Restrictions: On some UNIX systems the pthread-library does not
 contain the functionality to specify the stack size of a thread. The
diff --git a/doc/binary.n b/doc/binary.n
index 8133829..68bf9cc 100644
--- a/doc/binary.n
+++ b/doc/binary.n
@@ -92,7 +92,7 @@ Instructs the decoder to throw an error if it encounters whitespace characters.
 .
 The \fBuuencode\fR binary encoding used to be common for transfer of data
 between Unix systems and on USENET, but is less common these days, having been
-largely superceded by the \fBbase64\fR binary encoding.
+largely superseded by the \fBbase64\fR binary encoding.
 .RS
 .PP
 During encoding, the following options are supported:
@@ -135,7 +135,7 @@ is a non-negative decimal integer or \fB*\fR, which normally indicates
 that all of the items in the value are to be used.  If the number of
 arguments does not match the number of fields in the format string
 that consume arguments, then an error is generated. The flag character
-is ignored for for \fBbinary format\fR.
+is ignored for \fBbinary format\fR.
 .PP
 Here is a small example to clarify the relation between the field
 specifiers and the arguments:
diff --git a/doc/catch.n b/doc/catch.n
index 1da163d..a05ca71 100644
--- a/doc/catch.n
+++ b/doc/catch.n
@@ -77,7 +77,7 @@ the corresponding level; or it may be
 .QW \fBUP\fR ,
 in which case the parameter is
 the relative level (as in \fBuplevel\fR) of the previous \fBCALL\fR. The
-salient differences wrt \fB\-errorinfo\fR are that:
+salient differences with respect to \fB\-errorinfo\fR are that:
 .IP [1]
 it is a machine-readable form that is amenable to processing with
 [\fBforeach\fR {tok prm} ...],
diff --git a/doc/chan.n b/doc/chan.n
index 16c51b0..c518455 100644
--- a/doc/chan.n
+++ b/doc/chan.n
@@ -57,7 +57,7 @@ closed).
 .PP
 If the channel is blocking and the channel is ceasing to be writable, the
 command does not return until all output is flushed.  If the channel is
-nonblocking and there is unflushed output, the channel remains open and the
+non-blocking and there is unflushed output, the channel remains open and the
 command returns immediately; output will be flushed in the background and the
 channel will be closed when all the flushing is complete.
 .PP
@@ -107,8 +107,8 @@ the command sets each of the named options to the corresponding
 .PP
 The options described below are supported for all channels. In
 addition, each channel type may add options that only it supports. See
-the manual entry for the command that creates each type of channels
-for the options that that specific type of channel supports. For
+the manual entry for the command that creates each type of channel
+for the options supported by that specific type of channel. For
 example, see the manual entry for the \fBsocket\fR command for additional
 options for sockets, and the \fBopen\fR command for additional options for
 serial devices.
@@ -118,10 +118,10 @@ serial devices.
 The \fB\-blocking\fR option determines whether I/O operations on the
 channel can cause the process to block indefinitely.  The value of the
 option must be a proper boolean value.  Channels are normally in
-blocking mode; if a channel is placed into nonblocking mode it will
+blocking mode; if a channel is placed into non-blocking mode it will
 affect the operation of the \fBchan gets\fR, \fBchan read\fR, \fBchan
 puts\fR, \fBchan flush\fR, and \fBchan close\fR commands; see the
-documentation for those commands for details.  For nonblocking mode to
+documentation for those commands for details.  For non-blocking mode to
 work correctly, the application must be using the Tcl event loop
 (e.g. by calling \fBTcl_DoOneEvent\fR or invoking the \fBvwait\fR
 command).
@@ -399,7 +399,7 @@ commands.
 When a thread or interpreter is deleted, all channels created with
 this subcommand and using this thread/interpreter as their computing
 base are deleted as well, in all interpreters they have been shared
-with or moved into, and in whatever thread they have been transfered
+with or moved into, and in whatever thread they have been transferred
 to. While this pulls the rug out under the other thread(s) and/or
 interpreter(s), this cannot be avoided. Trying to use such a channel
 will cause the generation of a regular error about unknown channel
@@ -453,7 +453,7 @@ be readable if there is unread data in an input buffer, except in the
 special case where the most recent attempt to read from the channel
 was a \fBchan gets\fR call that could not find a complete line in the
 input buffer.  This feature allows a file to be read a line at a time
-in nonblocking mode using events.  A channel is also considered to be
+in non-blocking mode using events.  A channel is also considered to be
 readable if an end of file or error condition is present on the
 underlying file or device.  It is important for \fIscript\fR to check
 for these conditions and handle them appropriately; for example, if
@@ -468,12 +468,12 @@ Note that client sockets opened in asynchronous mode become writable
 when they become connected or if the connection fails.
 .PP
 Event-driven I/O works best for channels that have been placed into
-nonblocking mode with the \fBchan configure\fR command.  In blocking
+non-blocking mode with the \fBchan configure\fR command.  In blocking
 mode, a \fBchan puts\fR command may block if you give it more data
 than the underlying file or device can accept, and a \fBchan gets\fR
 or \fBchan read\fR command will block if you attempt to read more data
 than is ready; no events will be processed while the commands block.
-In nonblocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan
+In non-blocking mode \fBchan puts\fR, \fBchan read\fR, and \fBchan
 gets\fR never block.
 .PP
 The script for a file event is executed at global level (outside the
@@ -493,7 +493,7 @@ is written.
 .PP
 If the channel is in blocking mode the command does not return until
 all the buffered output has been flushed to the channel. If the
-channel is in nonblocking mode, the command may return before all
+channel is in non-blocking mode, the command may return before all
 buffered output has been flushed; the remainder will be flushed in the
 background as fast as the underlying file or device is able to absorb
 it.
@@ -516,7 +516,7 @@ If an end-of-file occurs while part way through reading a line, the
 partial line will be returned (or written into \fIvarName\fR). When
 \fIvarName\fR is not specified, the end-of-file case can be
 distinguished from an empty line using the \fBchan eof\fR command, and
-the partial-line-but-nonblocking case can be distinguished with the
+the partial-line-but-non-blocking case can be distinguished with the
 \fBchan blocked\fR command.
 .RE
 .TP
@@ -630,16 +630,16 @@ flush\fR command.
 .PP
 When the output buffer fills up, the \fBchan puts\fR command will
 normally block until all the buffered data has been accepted for
-output by the operating system.  If \fIchannelId\fR is in nonblocking
+output by the operating system.  If \fIchannelId\fR is in non-blocking
 mode then the \fBchan puts\fR command will not block even if the
 operating system cannot accept the data.  Instead, Tcl continues to
 buffer the data and writes it in the background as fast as the
 underlying file or device can accept it.  The application must use the
-Tcl event loop for nonblocking output to work; otherwise Tcl never
+Tcl event loop for non-blocking output to work; otherwise Tcl never
 finds out that the file or device is ready for more output data.  It
 is possible for an arbitrarily large amount of data to be buffered for
-a channel in nonblocking mode, which could consume a large amount of
-memory.  To avoid wasting memory, nonblocking I/O should normally be
+a channel in non-blocking mode, which could consume a large amount of
+memory.  To avoid wasting memory, non-blocking I/O should normally be
 used in an event-driven fashion with the \fBchan event\fR command
 (do not invoke \fBchan puts\fR unless you have recently been notified
 via a file event that the channel is ready for more output data).
@@ -659,7 +659,7 @@ given to indicate that any trailing newline in the string that has
 been read should be trimmed.
 .RS
 .PP
-If \fIchannelId\fR is in nonblocking mode, \fBchan read\fR may not
+If \fIchannelId\fR is in non-blocking mode, \fBchan read\fR may not
 read as many characters as requested: once all available input has
 been read, the command will return the data that is available rather
 than blocking for more input.  If the channel is configured to use a
@@ -675,7 +675,7 @@ channel (see \fBchan configure\fR above for a discussion on the ways
 in which \fBchan configure\fR will alter input).
 .PP
 When reading from a serial port, most applications should configure
-the serial port channel to be nonblocking, like this:
+the serial port channel to be non-blocking, like this:
 .PP
 .CS
 \fBchan configure \fIchannelId \fB\-blocking \fI0\fR.
@@ -728,7 +728,7 @@ position after the end of file.
 The \fIorigin\fR argument defaults to \fBstart\fR.
 .PP
 \fBChan seek\fR flushes all buffered output for the channel before the
-command returns, even if the channel is in nonblocking mode.  It also
+command returns, even if the channel is in non-blocking mode.  It also
 discards any buffered and unread input.  This command returns an empty
 string.  An error occurs if this command is applied to channels whose
 underlying file or device does not support seeking.
diff --git a/doc/close.n b/doc/close.n
index 2577cc5..4490f6a 100644
--- a/doc/close.n
+++ b/doc/close.n
@@ -23,7 +23,8 @@ Tcl standard channel (\fBstdin\fR, \fBstdout\fR, or \fBstderr\fR),
 the return value from an invocation of \fBopen\fR or \fBsocket\fR, or
 the result of a channel creation command provided by a Tcl extension.
 .PP
-The single-argument form is a simple "full-close":
+The single-argument form is a simple
+.QW "full-close" :
 all buffered output is flushed to the channel's output device,
 any buffered input is discarded, the underlying file or device is closed,
 and \fIchannelId\fR becomes unavailable for use.
@@ -56,16 +57,20 @@ pipeline created with \fBopen\fR returns an error, \fBclose\fR
 generates an error (similar to the \fBexec\fR command.)
 .PP
 .VS 8.6
-The two-argument form is a "half-close": given a bidirectional channel like a
+The two-argument form is a
+.QW "half-close" :
+given a bidirectional channel like a
 socket or command pipeline and a (possibly abbreviated) direction, it closes
-only the substream going in that direction. This means a shutdown() on a
+only the sub-stream going in that direction. This means a shutdown() on a
 socket, and a close() of one end of a pipe for a command pipeline. Then, the
 Tcl-level channel data structure is either kept or freed depending on whether
 the other direction is still open.
 .PP
-A single-argument close on an already half-closed bi-channel is defined to
-just "finish the job. A half-close on an already closed half, or on a
-wrong-sided unidirectional channel, raises an error.
+A single-argument close on an already half-closed bidirectional channel is
+defined to just
+.QW "finish the job" .
+A half-close on an already closed half, or on a wrong-sided unidirectional
+channel, raises an error.
 .PP
 In the case of a command pipeline, the child-reaping duty falls upon the
 shoulders of the last close or half-close, which is thus allowed to report an
diff --git a/doc/gets.n b/doc/gets.n
index bed7e32..fe24058 100644
--- a/doc/gets.n
+++ b/doc/gets.n
@@ -35,12 +35,12 @@ returned.
 .PP
 If end of file occurs while scanning for an end of
 line, the command returns whatever input is available up to the end of file.
-If \fIchannelId\fR is in nonblocking mode and there is not a full
+If \fIchannelId\fR is in non-blocking mode and there is not a full
 line of input available, the command returns an empty string and
 does not consume any input.
 If \fIvarName\fR is specified and an empty string is returned in
 \fIvarName\fR because of end-of-file or because of insufficient
-data in nonblocking mode, then the return count is -1.
+data in non-blocking mode, then the return count is -1.
 Note that if \fIvarName\fR is not specified then the end-of-file
 and no-full-line-available cases can
 produce the same results as if there were an input line consisting
@@ -64,4 +64,8 @@ close $chan
 file(n), eof(n), fblocked(n), Tcl_StandardChannels(3)
 
 .SH KEYWORDS
-blocking, channel, end of file, end of line, line, nonblocking, read
+blocking, channel, end of file, end of line, line, non-blocking, read
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/info.n b/doc/info.n
index eca5977..e65a083 100644
--- a/doc/info.n
+++ b/doc/info.n
@@ -430,9 +430,9 @@ actually use \fBnext\fR to transfer control along the call chain.
 \fBinfo class constructor\fI class\fR
 .VS 8.6
 This subcommand returns a description of the definition of the constructor of
-class \fIclass\fR. The defintion is described as a two element list; the first
+class \fIclass\fR. The definition is described as a two element list; the first
 element is the list of arguments to the constructor in a form suitable for
-passing to another call to \fBproc\fR or a method defintion, and the second
+passing to another call to \fBproc\fR or a method definition, and the second
 element is the body of the constructor. If no constructor is present, this
 returns the empty list.
 .VE 8.6
@@ -440,9 +440,9 @@ returns the empty list.
 \fBinfo class definition\fI class method\fR
 .VS 8.6
 This subcommand returns a description of the definition of the method named
-\fImethod\fR of class \fIclass\fR. The defintion is described as a two element
+\fImethod\fR of class \fIclass\fR. The definition is described as a two element
 list; the first element is the list of arguments to the method in a form
-suitable for passing to another call to \fBproc\fR or a method defintion, and
+suitable for passing to another call to \fBproc\fR or a method definition, and
 the second element is the body of the method.
 .VE 8.6
 .TP
@@ -564,9 +564,9 @@ boolean value indicating whether the \fIobject\fR is of that class.
 \fBinfo object definition\fI object method\fR
 .VS 8.6
 This subcommand returns a description of the definition of the method named
-\fImethod\fR of object \fIobject\fR. The defintion is described as a two
+\fImethod\fR of object \fIobject\fR. The definition is described as a two
 element list; the first element is the list of arguments to the method in a
-form suitable for passing to another call to \fBproc\fR or a method defintion,
+form suitable for passing to another call to \fBproc\fR or a method definition,
 and the second element is the body of the method.
 .VE 8.6
 .TP
diff --git a/doc/mathfunc.n b/doc/mathfunc.n
index 3da6d5a..14b448e 100644
--- a/doc/mathfunc.n
+++ b/doc/mathfunc.n
@@ -299,3 +299,7 @@ Copyright (c) 1993 The Regents of the University of California.
 Copyright (c) 1994-2000 Sun Microsystems Incorporated.
 Copyright (c) 2005, 2006 by Kevin B. Kenny <kennykb@acm.org>.
 .fi
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/my.n b/doc/my.n
index b6a3a29..b5afc67 100644
--- a/doc/my.n
+++ b/doc/my.n
@@ -31,7 +31,7 @@ Each object has its own \fBmy\fR command, contained in its instance namespace.
 .SH EXAMPLES
 .PP
 This example shows basic use of \fBmy\fR to use the \fBvariables\fR method of
-the \fBoo::object\fR class, which is not publically visible by default:
+the \fBoo::object\fR class, which is not publicly visible by default:
 .PP
 .CS
 oo::class create c {
diff --git a/doc/next.n b/doc/next.n
index 8eb2ba6..d3f7937 100644
--- a/doc/next.n
+++ b/doc/next.n
@@ -82,7 +82,7 @@ resulting list of implementations as possible.
 .PP
 When an object has a list of filter names set upon it, or is an instance of a
 class (or has mixed in a class) that has a list of filter names set upon it,
-before every invokation of any method the filters are processed. Filter
+before every invocation of any method the filters are processed. Filter
 implementations are found in class traversal order, as are the lists of filter
 names (each of which is traversed in natural list order). Explicitly invoking
 a method used as a filter will cause that method to be invoked twice, once as
@@ -93,7 +93,7 @@ forward to the proper implementation of the method (which it does by invoking
 the \fBnext\fR command as filters are inserted into the front of the method
 call chain) and is responsible for returning the result of \fBnext\fR.
 .PP
-Filters are not invoked when processing an invokation of the \fBunknown\fR
+Filters are not invoked when processing an invocation of the \fBunknown\fR
 method because of a failure to locate a method implementation, or when
 invoking either constructors or destructors.
 .SH EXAMPLES
@@ -135,7 +135,7 @@ in the superclass, args = pureSynthesis
 after chaining from subclass
 before chaining from subclass, args = 
 in the superclass, args = a b
-in the superclassm args = pureSynthesis
+in the superclass, args = pureSynthesis
 after chaining from subclass
 .CE
 .PP
@@ -165,7 +165,7 @@ oo::class create cache {
     method flushCache {} {
         my variable ValueCache
         unset ValueCache
-        \fI# Skip the cacheing\fR
+        \fI# Skip the caching\fR
         return -level 2 ""
     }
 }
diff --git a/doc/object.n b/doc/object.n
index 0640580..96a1bfb 100644
--- a/doc/object.n
+++ b/doc/object.n
@@ -40,7 +40,7 @@ current namespace whenever a method of the object is invoked (including a
 method of the class of the object). When the object is destroyed, its instance
 namespace is deleted. The instance namespace contains the object's \fBmy\fR
 command, which may be used to invoke non-exported methods of the object or to
-create a reference to the object for the purpose of invokation which persists
+create a reference to the object for the purpose of invocation which persists
 across renamings of the object.
 .SS CONSTRUCTOR
 The \fBoo::object\fR class does not define an explicit constructor.
@@ -69,7 +69,7 @@ associated with \fIobj\fR, returning the result of the evaluation.
 .
 This method is called when an attempt to invoke the method \fImethodName\fR on
 object \fIobj\fR fails. The arguments that the user supplied to the method are
-given as \fIarg\fR argments. The default implementation (i.e. the one defined
+given as \fIarg\fR arguments. The default implementation (i.e. the one defined
 by the \fBoo::object\fR class) generates a suitable error, detailing what
 methods the object supports given whether the object was invoked by its public
 name or through the \fBmy\fR command.
diff --git a/doc/proc.n b/doc/proc.n
index bd5df09..570a37d 100644
--- a/doc/proc.n
+++ b/doc/proc.n
@@ -53,7 +53,7 @@ error).
 There is one special case to permit procedures with
 variable numbers of arguments.  If the last formal argument has the name
 \fBargs\fR, then a call to the procedure may contain more actual arguments
-than the procedure has formals.  In this case, all of the actual arguments
+than the procedure has formal arguments.  In this case, all of the actual arguments
 starting at the one that would be assigned to \fBargs\fR are combined into
 a list (as if the \fBlist\fR command had been used); this combined value
 is assigned to the local variable \fBargs\fR.
@@ -66,7 +66,7 @@ Other variables can only be accessed by invoking one of the \fBglobal\fR,
 \fBvariable\fR, \fBupvar\fR or \fBnamespace upvar\fR commands.
 The current namespace when \fIbody\fR is executed will be the
 namespace that the procedure's name exists in, which will be the
-namespace that itwas created in unless it has been changed with
+namespace that it was created in unless it has been changed with
 \fBrename\fR.
 '\" We may change this! It makes [variable] unstable when renamed and is
 '\" frankly pretty crazy, but doing it right is harder than it looks.
diff --git a/doc/re_syntax.n b/doc/re_syntax.n
index dacc41f..46a180d 100644
--- a/doc/re_syntax.n
+++ b/doc/re_syntax.n
@@ -178,7 +178,7 @@ endpoint, so e.g.
 .QW \fBa\-c\-e\fR
 is illegal. Ranges in Tcl always use the
 Unicode collating sequence, but other programs may use other collating
-sequences and this can be a source of incompatability between programs.
+sequences and this can be a source of incompatibility between programs.
 .PP
 To include a literal \fB]\fR or \fB\-\fR in the list, the simplest
 method is to enclose it in \fB[.\fR and \fB.]\fR to make it a
@@ -223,7 +223,8 @@ A character producing white space in displayed text.
 .IP \fBpunct\fR 8
 A punctuation character.
 .IP \fBgraph\fR 8
-A character with a visible representation (includes both alnum and punct).
+A character with a visible representation (includes both \fBalnum\fR
+and \fBpunct\fR).
 .IP \fBcntrl\fR 8
 A control character.
 .PP
diff --git a/doc/seek.n b/doc/seek.n
index 996a7f2..96d5c4e 100644
--- a/doc/seek.n
+++ b/doc/seek.n
@@ -49,7 +49,7 @@ position after the end of file.
 The \fIorigin\fR argument defaults to \fBstart\fR.
 .PP
 The command flushes all buffered output for the channel before the command
-returns, even if the channel is in nonblocking mode.
+returns, even if the channel is in non-blocking mode.
 It also discards any buffered and unread input.
 This command returns an empty string.
 An error occurs if this command is applied to channels whose underlying
@@ -86,3 +86,7 @@ close $f
 file(n), open(n), close(n), gets(n), tell(n), Tcl_StandardChannels(3)
 .SH KEYWORDS
 access position, file, seek
+'\" Local Variables:
+'\" mode: nroff
+'\" fill-column: 78
+'\" End:
diff --git a/doc/self.n b/doc/self.n
index 348c38f..2a04157 100644
--- a/doc/self.n
+++ b/doc/self.n
@@ -91,7 +91,7 @@ method call chain; the first element is the name of the class or object that
 declares the next part of the call chain, and the second element is the name
 of the method (with the strings \fB<constructor>\fR and \fB<destructor>\fR
 indicating constructors and destructors respectively). If invoked from a
-method that is at the end of a call chain, this subcommand returns the emtpy
+method that is at the end of a call chain, this subcommand returns the empty
 string.
 .TP
 \fBself object\fR
-- 
cgit v0.12


From dfee92e01ac6209a2c9cc21064a6325077dfaad6 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 15 Mar 2012 08:33:40 +0000
Subject: x

---
 generic/tcl.h             | 20 ++++++++++++---
 generic/tclIntPlatDecls.h |  6 ++---
 unix/tclUnixFile.c        | 34 ++++++++++++++++++++++++++
 unix/tclUnixPort.h        |  7 +++++-
 win/cat.c                 |  6 +----
 win/tclWinFile.c          | 62 -----------------------------------------------
 win/tclWinPort.h          | 55 +++++++----------------------------------
 7 files changed, 70 insertions(+), 120 deletions(-)

diff --git a/generic/tcl.h b/generic/tcl.h
index 21cd0c4..33fcb6f 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -352,7 +352,7 @@ typedef long LONG;
  */
 
 #if !defined(TCL_WIDE_INT_TYPE)&&!defined(TCL_WIDE_INT_IS_LONG)
-#   if defined(__WIN32__) && !defined(__CYGWIN__)
+#   if defined(__WIN32__)
 #      define TCL_WIDE_INT_TYPE __int64
 #      ifdef __BORLANDC__
 typedef struct stati64 Tcl_StatBuf;
@@ -415,7 +415,21 @@ typedef struct stat	Tcl_StatBuf;
  * or some other strange platform.
  */
 #   ifndef TCL_LL_MODIFIER
-#      ifdef HAVE_STRUCT_STAT64
+#      ifdef __CYGWIN__
+typedef struct _stat32i64 {
+    dev_t st_dev;
+    ino_t st_ino;
+    unsigned short st_mode;
+    short st_nlink;
+    short st_uid;
+    short st_gid;
+    dev_t st_rdev;
+    long long st_size;
+    struct {long tv_sec;} st_atim;
+    struct {long tv_sec;} st_mtim;
+    struct {long tv_sec;} st_ctim;
+} Tcl_StatBuf;
+#      elif defined(HAVE_STRUCT_STAT64)
 typedef struct stat64	Tcl_StatBuf;
 #      else
 typedef struct stat	Tcl_StatBuf;
@@ -427,7 +441,7 @@ typedef struct stat	Tcl_StatBuf;
 #   define Tcl_WideAsDouble(val)	((double)((Tcl_WideInt)(val)))
 #   define Tcl_DoubleAsWide(val)	((Tcl_WideInt)((double)(val)))
 #endif /* TCL_WIDE_INT_IS_LONG */
-
+
 /*
  * Data structures defined opaquely in this module. The definitions below just
  * provide dummy types. A few fields are made visible in Tcl_Interp
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 3c03015..13e82b9 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -36,7 +36,7 @@
  * Exported function declarations:
  */
 
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if defined(__CYGWIN__) || !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
 #ifndef TclGetAndDetachPids_TCL_DECLARED
 #define TclGetAndDetachPids_TCL_DECLARED
 /* 0 */
@@ -375,7 +375,7 @@ typedef struct TclIntPlatStubs {
     int magic;
     struct TclIntPlatStubHooks *hooks;
 
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if defined(__CYGWIN__) || !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
     void (*tclGetAndDetachPids) (Tcl_Interp *interp, Tcl_Channel chan); /* 0 */
     int (*tclpCloseFile) (TclFile file); /* 1 */
     Tcl_Channel (*tclpCreateCommandChannel) (TclFile readFile, TclFile writeFile, TclFile errorFile, int numPids, Tcl_Pid *pidPtr); /* 2 */
@@ -462,7 +462,7 @@ extern TclIntPlatStubs *tclIntPlatStubsPtr;
  * Inline function declarations:
  */
 
-#if !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
+#if defined(__CYGWIN__) || !defined(__WIN32__) && !defined(MAC_OSX_TCL) /* UNIX */
 #ifndef TclGetAndDetachPids
 #define TclGetAndDetachPids \
 	(tclIntPlatStubsPtr->tclGetAndDetachPids) /* 0 */
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 2639d59..7d82d1d 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -1164,6 +1164,40 @@ TclpUtime(
 {
     return utime(Tcl_FSGetNativePath(pathPtr), tval);
 }
+#ifdef __CYGWIN__
+int TclOSstat(const char *name, Tcl_StatBuf *statBuf) {
+    struct stat buf;
+    int result = stat(name, &buf);
+    statBuf->st_mode = buf.st_mode;
+    statBuf->st_ino = buf.st_ino;
+    statBuf->st_dev = buf.st_dev;
+    statBuf->st_rdev = buf.st_rdev;
+    statBuf->st_nlink = buf.st_nlink;
+    statBuf->st_uid = buf.st_uid;
+    statBuf->st_gid = buf.st_gid;
+    statBuf->st_size = buf.st_size;
+    statBuf->st_atime = buf.st_atime;
+    statBuf->st_mtime = buf.st_mtime;
+    statBuf->st_ctime = buf.st_ctime;
+    return result;
+}
+int TclOSlstat(const char *name, Tcl_StatBuf *statBuf) {
+    struct stat buf;
+    int result = lstat(name, &buf);
+    statBuf->st_mode = buf.st_mode;
+    statBuf->st_ino = buf.st_ino;
+    statBuf->st_dev = buf.st_dev;
+    statBuf->st_rdev = buf.st_rdev;
+    statBuf->st_nlink = buf.st_nlink;
+    statBuf->st_uid = buf.st_uid;
+    statBuf->st_gid = buf.st_gid;
+    statBuf->st_size = buf.st_size;
+    statBuf->st_atime = buf.st_atime;
+    statBuf->st_mtime = buf.st_mtime;
+    statBuf->st_ctime = buf.st_ctime;
+    return result;
+}
+#endif
 
 /*
  * Local Variables:
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index e4008c9..fef748b 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -73,7 +73,12 @@ typedef off_t		Tcl_SeekOffset;
 #   define TclOSopen		open
 #endif
 
-#ifdef HAVE_STRUCT_STAT64
+#ifdef __CYGWIN__
+MODULE_SCOPE int TclOSstat(const char *name, Tcl_StatBuf *statBuf);
+MODULE_SCOPE int TclOSlstat(const char *name, Tcl_StatBuf *statBuf);
+#undef HAVE_STRUCT_STAT_ST_BLOCKS
+#undef HAVE_STRUCT_STAT_ST_BLKSIZE
+#elif defined(HAVE_STRUCT_STAT64)
 #   define TclOSstat		stat64
 #   define TclOSlstat		lstat64
 #else
diff --git a/win/cat.c b/win/cat.c
index 2cedd5d..d413923 100644
--- a/win/cat.c
+++ b/win/cat.c
@@ -10,11 +10,7 @@
  */
 
 #include <stdio.h>
-#ifdef __CYGWIN__
-#   include <unistd.h>
-#else
-#   include <io.h>
-#endif
+#include <io.h>
 #include <string.h>
 
 int
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index f764ad8..a9b321d 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -1850,27 +1850,10 @@ TclpObjChdir(
 {
     int result;
     const TCHAR *nativePath;
-#ifdef __CYGWIN__
-    extern int cygwin_conv_to_posix_path(const char *, char *);
-    char posixPath[MAX_PATH+1];
-    const char *path;
-    Tcl_DString ds;
-#endif /* __CYGWIN__ */
 
     nativePath = (const TCHAR *) Tcl_FSGetNativePath(pathPtr);
 
-#ifdef __CYGWIN__
-    /*
-     * Cygwin chdir only groks POSIX path.
-     */
-
-    path = Tcl_WinTCharToUtf(nativePath, -1, &ds);
-    cygwin_conv_to_posix_path(path, posixPath);
-    result = (chdir(posixPath) == 0 ? 1 : 0);
-    Tcl_DStringFree(&ds);
-#else /* __CYGWIN__ */
     result = (*tclWinProcs->setCurrentDirectoryProc)(nativePath);
-#endif /* __CYGWIN__ */
 
     if (result == 0) {
 	TclWinConvertError(GetLastError());
@@ -1879,51 +1862,6 @@ TclpObjChdir(
     return 0;
 }
 
-#ifdef __CYGWIN__
-/*
- *---------------------------------------------------------------------------
- *
- * TclpReadlink --
- *
- *	This function replaces the library version of readlink().
- *
- * Results:
- *	The result is a pointer to a string specifying the contents of the
- *	symbolic link given by 'path', or NULL if the symbolic link could not
- *	be read. Storage for the result string is allocated in bufferPtr; the
- *	caller must call Tcl_DStringFree() when the result is no longer
- *	needed.
- *
- * Side effects:
- *	See readlink() documentation.
- *
- *---------------------------------------------------------------------------
- */
-
-char *
-TclpReadlink(
-    const char *path,		/* Path of file to readlink (UTF-8). */
-    Tcl_DString *linkPtr)	/* Uninitialized or free DString filled with
-				 * contents of link (UTF-8). */
-{
-    char link[MAXPATHLEN];
-    int length;
-    char *native;
-    Tcl_DString ds;
-
-    native = Tcl_UtfToExternalDString(NULL, path, -1, &ds);
-    length = readlink(native, link, sizeof(link));	/* INTL: Native. */
-    Tcl_DStringFree(&ds);
-
-    if (length < 0) {
-	return NULL;
-    }
-
-    Tcl_ExternalToUtfDString(NULL, link, length, linkPtr);
-    return Tcl_DStringValue(linkPtr);
-}
-#endif /* __CYGWIN__ */
-
 /*
  *----------------------------------------------------------------------
  *
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index 4855d12..e2cac52 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -51,12 +51,7 @@ typedef DWORD_PTR * PDWORD_PTR;
  *---------------------------------------------------------------------------
  */
 
-#ifdef __CYGWIN__
-#   include <unistd.h>
-#   include <wchar.h>
-#else
-#   include <io.h>
-#endif
+#include <io.h>
 #include <stdio.h>
 #include <stdlib.h>
 #include <errno.h>
@@ -68,18 +63,11 @@ typedef DWORD_PTR * PDWORD_PTR;
 #include <string.h>
 #include <limits.h>
 
-#ifdef __CYGWIN__
-#   include <unistd.h>
-#   ifndef _wcsicmp
-#	define _wcsicmp wcscasecmp
-#   endif
-#else
-#   ifndef strncasecmp
-#	define strncasecmp strnicmp
-#   endif
-#   ifndef strcasecmp
-#	define strcasecmp stricmp
-#   endif
+#ifndef strncasecmp
+#   define strncasecmp strnicmp
+#endif
+#ifndef strcasecmp
+#   define strcasecmp stricmp
 #endif
 
 /*
@@ -113,25 +101,6 @@ typedef DWORD_PTR * PDWORD_PTR;
 #undef ENOTSUP
 #define ENOTSUP	-1030507
 
-/*
- * cygwin does not have this struct.
- */
-#ifdef __CYGWIN__
-  struct _stat32i64 {
-    dev_t st_dev;
-    ino_t st_ino;
-    unsigned short st_mode;
-    short st_nlink;
-    short st_uid;
-    short st_gid;
-    dev_t st_rdev;
-    __int64 st_size;
-    struct {long tv_sec;} st_atim;
-    struct {long tv_sec;} st_mtim;
-    struct {long tv_sec;} st_ctim;
-  };
-#endif
-
 /* Those codes, from Visual Studio 2010, conflict with other values */
 #undef ENODATA
 #undef ENOMSG
@@ -478,18 +447,12 @@ typedef DWORD_PTR * PDWORD_PTR;
  * use by tclAlloc.c.
  */
 
-#ifdef __CYGWIN__
-#   define TclpSysAlloc(size, isBin)	malloc((size))
-#   define TclpSysFree(ptr)		free((ptr))
-#   define TclpSysRealloc(ptr, size)	realloc((ptr), (size))
-#else
-#   define TclpSysAlloc(size, isBin)	((void*)HeapAlloc(GetProcessHeap(), \
+#define TclpSysAlloc(size, isBin)	((void*)HeapAlloc(GetProcessHeap(), \
 					    (DWORD)0, (DWORD)size))
-#   define TclpSysFree(ptr)		(HeapFree(GetProcessHeap(), \
+#define TclpSysFree(ptr)		(HeapFree(GetProcessHeap(), \
 					    (DWORD)0, (HGLOBAL)ptr))
-#   define TclpSysRealloc(ptr, size)	((void*)HeapReAlloc(GetProcessHeap(), \
+#define TclpSysRealloc(ptr, size)	((void*)HeapReAlloc(GetProcessHeap(), \
 					    (DWORD)0, (LPVOID)ptr, (DWORD)size))
-#endif
 
 /*
  * The following defines map from standard socket names to our internal
-- 
cgit v0.12


From 922bb1be55898822b118f8354952137ac161b294 Mon Sep 17 00:00:00 2001
From: max <max@tclers.tk>
Date: Mon, 19 Mar 2012 16:51:06 +0000
Subject:   *  Use the values returned by getaddrinfo() for all three arguments
 to socket() instead of only using ai_family.   *  Try to keep the most
 meaningful error while iterating over the result list, because using the last
 error can be misleading.

---
 ChangeLog          |  8 ++++++++
 unix/tclUnixSock.c | 23 ++++++++++++++++++++++-
 2 files changed, 30 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index a8e4bb8..4f894be 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2012-03-19  Reinhard Max  <max@suse.de>
+
+	* unix/tclUnixSock.c (Tcl_OpenTcpServer): Use the values returned
+	by getaddrinfo() for all three arguments to socket() instead of
+	only using ai_family. Try to keep the most meaningful error while
+	iterating over the result list, because using the last error can
+	be misleading.
+
 2012-03-15  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tcl.h: [Bug 3288345] Wrong Tcl_StatBuf used on Cygwin
diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c
index 7b5c9e0..8c94e7f 100644
--- a/unix/tclUnixSock.c
+++ b/unix/tclUnixSock.c
@@ -1252,13 +1252,25 @@ Tcl_OpenTcpServer(
     const char *errorMsg = NULL;
     TcpFdList *fds = NULL, *newfds;
 
+    /*
+     * Try to record and return the most meaningful error message, i.e. the
+     * one from the first socket that went the farthest before it failed.
+     */
+    enum { START, SOCKET, BIND, LISTEN } howfar = START;
+    int my_errno = 0;
+
     if (!TclCreateSocketAddress(interp, &addrlist, myHost, port, 1, &errorMsg)) {
 	goto error;
     }
 
     for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
-	sock = socket(addrPtr->ai_family, SOCK_STREAM, 0);
+	sock = socket(addrPtr->ai_family, addrPtr->ai_socktype,
+                      addrPtr->ai_protocol);
 	if (sock == -1) {
+	    if (howfar < SOCKET) {
+		howfar = SOCKET;
+		my_errno = errno;
+	    }
 	    continue;
 	}
 	
@@ -1308,6 +1320,10 @@ Tcl_OpenTcpServer(
 
 	status = bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen);
         if (status == -1) {
+	    if (howfar < BIND) {
+		howfar = BIND;
+		my_errno = errno;
+	    }       
             close(sock);
             continue;
         }
@@ -1326,6 +1342,10 @@ Tcl_OpenTcpServer(
         }
         status = listen(sock, SOMAXCONN);
         if (status < 0) {
+	    if (howfar < LISTEN) {
+		howfar = LISTEN;
+		my_errno = errno;
+	    }
             close(sock);
             continue;
         }
@@ -1367,6 +1387,7 @@ Tcl_OpenTcpServer(
 	return statePtr->channel;
     }
     if (interp != NULL) {
+	errno = my_errno;
 	Tcl_AppendResult(interp, "couldn't open socket: ",
 		Tcl_PosixError(interp), NULL);
 	if (errorMsg != NULL) {
-- 
cgit v0.12


From 2c7e68e5aeb40ae5340c57d4f80ef18a56a7db22 Mon Sep 17 00:00:00 2001
From: venkat <venkat@comit.com>
Date: Mon, 19 Mar 2012 17:09:55 +0000
Subject: Update to tzdata 2012b

---
 ChangeLog                            |  30 ++++++
 library/tzdata/America/Atikokan      |   2 +-
 library/tzdata/America/Blanc-Sablon  |   2 +-
 library/tzdata/America/Creston       |   8 ++
 library/tzdata/America/Dawson_Creek  |   2 +-
 library/tzdata/America/Edmonton      |   2 +-
 library/tzdata/America/Glace_Bay     |   2 +-
 library/tzdata/America/Goose_Bay     |   2 +-
 library/tzdata/America/Halifax       |   2 +-
 library/tzdata/America/Havana        |   2 +-
 library/tzdata/America/Moncton       |   2 +-
 library/tzdata/America/Montreal      |   2 +-
 library/tzdata/America/Nipigon       |   2 +-
 library/tzdata/America/Rainy_River   |   2 +-
 library/tzdata/America/Regina        |   2 +-
 library/tzdata/America/Santiago      |   4 +-
 library/tzdata/America/St_Johns      |   2 +-
 library/tzdata/America/Swift_Current |   2 +-
 library/tzdata/America/Toronto       |   2 +-
 library/tzdata/America/Vancouver     |   2 +-
 library/tzdata/America/Winnipeg      |   2 +-
 library/tzdata/Antarctica/Casey      |   2 +
 library/tzdata/Antarctica/Davis      |   2 +
 library/tzdata/Antarctica/Palmer     |  12 +--
 library/tzdata/Asia/Yerevan          | 177 +---------------------------------
 library/tzdata/Atlantic/Stanley      | 179 +----------------------------------
 library/tzdata/Pacific/Easter        |   4 +-
 library/tzdata/Pacific/Fakaofo       |   1 +
 28 files changed, 73 insertions(+), 382 deletions(-)
 create mode 100644 library/tzdata/America/Creston

diff --git a/ChangeLog b/ChangeLog
index d389888..5f72921 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,33 @@
+2012-03-19  Venkat Iyer <venkat@comit.com>
+
+	* library/tzdata/America/Atikokan: Update to tzdata2012b.
+	* library/tzdata/America/Blanc-Sablon
+	* library/tzdata/America/Dawson_Creek
+	* library/tzdata/America/Edmonton
+	* library/tzdata/America/Glace_Bay
+	* library/tzdata/America/Goose_Bay
+	* library/tzdata/America/Halifax
+	* library/tzdata/America/Havana
+	* library/tzdata/America/Moncton
+	* library/tzdata/America/Montreal
+	* library/tzdata/America/Nipigon
+	* library/tzdata/America/Rainy_River
+	* library/tzdata/America/Regina
+	* library/tzdata/America/Santiago
+	* library/tzdata/America/St_Johns
+	* library/tzdata/America/Swift_Current
+	* library/tzdata/America/Toronto
+	* library/tzdata/America/Vancouver
+	* library/tzdata/America/Winnipeg
+	* library/tzdata/Antarctica/Casey
+	* library/tzdata/Antarctica/Davis
+	* library/tzdata/Antarctica/Palmer
+	* library/tzdata/Asia/Yerevan
+	* library/tzdata/Atlantic/Stanley
+	* library/tzdata/Pacific/Easter
+	* library/tzdata/Pacific/Fakaofo
+	* library/tzdata/America/Creston: (new)
+
 2012-03-15  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tcl.h: [Bug 3288345] Wrong Tcl_StatBuf used on Cygwin
diff --git a/library/tzdata/America/Atikokan b/library/tzdata/America/Atikokan
index ca0ac1c..e72b04f 100755
--- a/library/tzdata/America/Atikokan
+++ b/library/tzdata/America/Atikokan
@@ -4,7 +4,7 @@ set TZData(:America/Atikokan) {
     {-9223372036854775808 -21988 0 LMT}
     {-2366733212 -21600 0 CST}
     {-1632067200 -18000 1 CDT}
-    {-1614790800 -21600 0 CST}
+    {-1615136400 -21600 0 CST}
     {-923248800 -18000 1 CDT}
     {-880214400 -18000 0 CWT}
     {-769395600 -18000 1 CPT}
diff --git a/library/tzdata/America/Blanc-Sablon b/library/tzdata/America/Blanc-Sablon
index 47f161a..d5485e8 100755
--- a/library/tzdata/America/Blanc-Sablon
+++ b/library/tzdata/America/Blanc-Sablon
@@ -4,7 +4,7 @@ set TZData(:America/Blanc-Sablon) {
     {-9223372036854775808 -13708 0 LMT}
     {-2713896692 -14400 0 AST}
     {-1632074400 -10800 1 ADT}
-    {-1614798000 -14400 0 AST}
+    {-1615143600 -14400 0 AST}
     {-880221600 -10800 1 AWT}
     {-769395600 -10800 1 APT}
     {-765399600 -14400 0 AST}
diff --git a/library/tzdata/America/Creston b/library/tzdata/America/Creston
new file mode 100644
index 0000000..30369a9
--- /dev/null
+++ b/library/tzdata/America/Creston
@@ -0,0 +1,8 @@
+# created by tools/tclZIC.tcl - do not edit
+
+set TZData(:America/Creston) {
+    {-9223372036854775808 -27964 0 LMT}
+    {-2713882436 -25200 0 MST}
+    {-1680454800 -28800 0 PST}
+    {-1627833600 -25200 0 MST}
+}
diff --git a/library/tzdata/America/Dawson_Creek b/library/tzdata/America/Dawson_Creek
index 9f8c921..a0b5c44 100644
--- a/library/tzdata/America/Dawson_Creek
+++ b/library/tzdata/America/Dawson_Creek
@@ -4,7 +4,7 @@ set TZData(:America/Dawson_Creek) {
     {-9223372036854775808 -28856 0 LMT}
     {-2713881544 -28800 0 PST}
     {-1632060000 -25200 1 PDT}
-    {-1614783600 -28800 0 PST}
+    {-1615129200 -28800 0 PST}
     {-880207200 -25200 1 PWT}
     {-769395600 -25200 1 PPT}
     {-765385200 -28800 0 PST}
diff --git a/library/tzdata/America/Edmonton b/library/tzdata/America/Edmonton
index c4252f8..1ed38be 100644
--- a/library/tzdata/America/Edmonton
+++ b/library/tzdata/America/Edmonton
@@ -4,7 +4,7 @@ set TZData(:America/Edmonton) {
     {-9223372036854775808 -27232 0 LMT}
     {-1998663968 -25200 0 MST}
     {-1632063600 -21600 1 MDT}
-    {-1614787200 -25200 0 MST}
+    {-1615132800 -25200 0 MST}
     {-1600614000 -21600 1 MDT}
     {-1596816000 -25200 0 MST}
     {-1567954800 -21600 1 MDT}
diff --git a/library/tzdata/America/Glace_Bay b/library/tzdata/America/Glace_Bay
index 84b4822..8ee9eec 100644
--- a/library/tzdata/America/Glace_Bay
+++ b/library/tzdata/America/Glace_Bay
@@ -4,7 +4,7 @@ set TZData(:America/Glace_Bay) {
     {-9223372036854775808 -14388 0 LMT}
     {-2131646412 -14400 0 AST}
     {-1632074400 -10800 1 ADT}
-    {-1614798000 -14400 0 AST}
+    {-1615143600 -14400 0 AST}
     {-880221600 -10800 1 AWT}
     {-769395600 -10800 1 APT}
     {-765399600 -14400 0 AST}
diff --git a/library/tzdata/America/Goose_Bay b/library/tzdata/America/Goose_Bay
index 2f6368d..7b7b3d8 100644
--- a/library/tzdata/America/Goose_Bay
+++ b/library/tzdata/America/Goose_Bay
@@ -5,7 +5,7 @@ set TZData(:America/Goose_Bay) {
     {-2713895900 -12652 0 NST}
     {-1640982548 -12652 0 NST}
     {-1632076148 -9052 1 NDT}
-    {-1614799748 -12652 0 NST}
+    {-1615145348 -12652 0 NST}
     {-1609446548 -12652 0 NST}
     {-1096921748 -12600 0 NST}
     {-1072989000 -12600 0 NST}
diff --git a/library/tzdata/America/Halifax b/library/tzdata/America/Halifax
index 76f016a..08e3754 100644
--- a/library/tzdata/America/Halifax
+++ b/library/tzdata/America/Halifax
@@ -7,7 +7,7 @@ set TZData(:America/Halifax) {
     {-1680469200 -14400 0 AST}
     {-1640980800 -14400 0 AST}
     {-1632074400 -10800 1 ADT}
-    {-1614798000 -14400 0 AST}
+    {-1615143600 -14400 0 AST}
     {-1609444800 -14400 0 AST}
     {-1566763200 -10800 1 ADT}
     {-1557090000 -14400 0 AST}
diff --git a/library/tzdata/America/Havana b/library/tzdata/America/Havana
index f29db14..3f29a35 100644
--- a/library/tzdata/America/Havana
+++ b/library/tzdata/America/Havana
@@ -106,7 +106,7 @@ set TZData(:America/Havana) {
     {1288501200 -18000 0 CST}
     {1300597200 -14400 1 CDT}
     {1321160400 -18000 0 CST}
-    {1331442000 -14400 1 CDT}
+    {1333256400 -14400 1 CDT}
     {1351400400 -18000 0 CST}
     {1362891600 -14400 1 CDT}
     {1382850000 -18000 0 CST}
diff --git a/library/tzdata/America/Moncton b/library/tzdata/America/Moncton
index 408e3a1..d286c88 100755
--- a/library/tzdata/America/Moncton
+++ b/library/tzdata/America/Moncton
@@ -5,7 +5,7 @@ set TZData(:America/Moncton) {
     {-2715882052 -18000 0 EST}
     {-2131642800 -14400 0 AST}
     {-1632074400 -10800 1 ADT}
-    {-1614798000 -14400 0 AST}
+    {-1615143600 -14400 0 AST}
     {-1167595200 -14400 0 AST}
     {-1153681200 -10800 1 ADT}
     {-1145822400 -14400 0 AST}
diff --git a/library/tzdata/America/Montreal b/library/tzdata/America/Montreal
index b9535eb..bebe7dc 100644
--- a/library/tzdata/America/Montreal
+++ b/library/tzdata/America/Montreal
@@ -7,7 +7,7 @@ set TZData(:America/Montreal) {
     {-1662753600 -18000 0 EST}
     {-1640977200 -18000 0 EST}
     {-1632070800 -14400 1 EDT}
-    {-1614794400 -18000 0 EST}
+    {-1615140000 -18000 0 EST}
     {-1609441200 -18000 0 EST}
     {-1601742600 -14400 1 EDT}
     {-1583775000 -18000 0 EST}
diff --git a/library/tzdata/America/Nipigon b/library/tzdata/America/Nipigon
index e98bb8c..30690aa 100644
--- a/library/tzdata/America/Nipigon
+++ b/library/tzdata/America/Nipigon
@@ -4,7 +4,7 @@ set TZData(:America/Nipigon) {
     {-9223372036854775808 -21184 0 LMT}
     {-2366734016 -18000 0 EST}
     {-1632070800 -14400 1 EDT}
-    {-1614794400 -18000 0 EST}
+    {-1615140000 -18000 0 EST}
     {-923252400 -14400 1 EDT}
     {-880218000 -14400 0 EWT}
     {-769395600 -14400 1 EPT}
diff --git a/library/tzdata/America/Rainy_River b/library/tzdata/America/Rainy_River
index 331bac6..a2b11aa 100644
--- a/library/tzdata/America/Rainy_River
+++ b/library/tzdata/America/Rainy_River
@@ -4,7 +4,7 @@ set TZData(:America/Rainy_River) {
     {-9223372036854775808 -22696 0 LMT}
     {-2366732504 -21600 0 CST}
     {-1632067200 -18000 1 CDT}
-    {-1614790800 -21600 0 CST}
+    {-1615136400 -21600 0 CST}
     {-923248800 -18000 1 CDT}
     {-880214400 -18000 0 CWT}
     {-769395600 -18000 1 CPT}
diff --git a/library/tzdata/America/Regina b/library/tzdata/America/Regina
index 2030d75..e42b5be 100644
--- a/library/tzdata/America/Regina
+++ b/library/tzdata/America/Regina
@@ -4,7 +4,7 @@ set TZData(:America/Regina) {
     {-9223372036854775808 -25116 0 LMT}
     {-2030202084 -25200 0 MST}
     {-1632063600 -21600 1 MDT}
-    {-1614787200 -25200 0 MST}
+    {-1615132800 -25200 0 MST}
     {-1251651600 -21600 1 MDT}
     {-1238349600 -25200 0 MST}
     {-1220202000 -21600 1 MDT}
diff --git a/library/tzdata/America/Santiago b/library/tzdata/America/Santiago
index c631bd1..f42ff3d 100644
--- a/library/tzdata/America/Santiago
+++ b/library/tzdata/America/Santiago
@@ -112,8 +112,8 @@ set TZData(:America/Santiago) {
     {1286683200 -10800 1 CLST}
     {1304823600 -14400 0 CLT}
     {1313899200 -10800 1 CLST}
-    {1331434800 -14400 0 CLT}
-    {1350187200 -10800 1 CLST}
+    {1335668400 -14400 0 CLT}
+    {1346558400 -10800 1 CLST}
     {1362884400 -14400 0 CLT}
     {1381636800 -10800 1 CLST}
     {1394334000 -14400 0 CLT}
diff --git a/library/tzdata/America/St_Johns b/library/tzdata/America/St_Johns
index d9ab415..1492961 100644
--- a/library/tzdata/America/St_Johns
+++ b/library/tzdata/America/St_Johns
@@ -7,7 +7,7 @@ set TZData(:America/St_Johns) {
     {-1650137348 -12652 0 NST}
     {-1640982548 -12652 0 NST}
     {-1632076148 -9052 1 NDT}
-    {-1614799748 -12652 0 NST}
+    {-1615145348 -12652 0 NST}
     {-1609446548 -12652 0 NST}
     {-1598650148 -9052 1 NDT}
     {-1590100148 -12652 0 NST}
diff --git a/library/tzdata/America/Swift_Current b/library/tzdata/America/Swift_Current
index dc4aa37..ad07762 100644
--- a/library/tzdata/America/Swift_Current
+++ b/library/tzdata/America/Swift_Current
@@ -4,7 +4,7 @@ set TZData(:America/Swift_Current) {
     {-9223372036854775808 -25880 0 LMT}
     {-2030201320 -25200 0 MST}
     {-1632063600 -21600 1 MDT}
-    {-1614787200 -25200 0 MST}
+    {-1615132800 -25200 0 MST}
     {-880210800 -21600 1 MWT}
     {-769395600 -21600 1 MPT}
     {-765388800 -25200 0 MST}
diff --git a/library/tzdata/America/Toronto b/library/tzdata/America/Toronto
index e4fc91a..09bf786 100644
--- a/library/tzdata/America/Toronto
+++ b/library/tzdata/America/Toronto
@@ -4,7 +4,7 @@ set TZData(:America/Toronto) {
     {-9223372036854775808 -19052 0 LMT}
     {-2366736148 -18000 0 EST}
     {-1632070800 -14400 1 EDT}
-    {-1614794400 -18000 0 EST}
+    {-1615140000 -18000 0 EST}
     {-1609441200 -18000 0 EST}
     {-1601753400 -14400 1 EDT}
     {-1583697600 -18000 0 EST}
diff --git a/library/tzdata/America/Vancouver b/library/tzdata/America/Vancouver
index b2e0415..aef639a 100644
--- a/library/tzdata/America/Vancouver
+++ b/library/tzdata/America/Vancouver
@@ -4,7 +4,7 @@ set TZData(:America/Vancouver) {
     {-9223372036854775808 -29548 0 LMT}
     {-2713880852 -28800 0 PST}
     {-1632060000 -25200 1 PDT}
-    {-1614783600 -28800 0 PST}
+    {-1615129200 -28800 0 PST}
     {-880207200 -25200 1 PWT}
     {-769395600 -25200 1 PPT}
     {-765385200 -28800 0 PST}
diff --git a/library/tzdata/America/Winnipeg b/library/tzdata/America/Winnipeg
index 7e6208a..e6efe47 100644
--- a/library/tzdata/America/Winnipeg
+++ b/library/tzdata/America/Winnipeg
@@ -6,7 +6,7 @@ set TZData(:America/Winnipeg) {
     {-1694368800 -18000 1 CDT}
     {-1681671600 -21600 0 CST}
     {-1632067200 -18000 1 CDT}
-    {-1614790800 -21600 0 CST}
+    {-1615136400 -21600 0 CST}
     {-1029686400 -18000 1 CDT}
     {-1018198800 -21600 0 CST}
     {-880214400 -18000 1 CWT}
diff --git a/library/tzdata/Antarctica/Casey b/library/tzdata/Antarctica/Casey
index 119d514..cbe3e3c 100644
--- a/library/tzdata/Antarctica/Casey
+++ b/library/tzdata/Antarctica/Casey
@@ -5,4 +5,6 @@ set TZData(:Antarctica/Casey) {
     {-31536000 28800 0 WST}
     {1255802400 39600 0 CAST}
     {1267714800 28800 0 WST}
+    {1319738400 39600 0 CAST}
+    {1329843600 28800 0 WST}
 }
diff --git a/library/tzdata/Antarctica/Davis b/library/tzdata/Antarctica/Davis
index 47aece9..2762d2f 100644
--- a/library/tzdata/Antarctica/Davis
+++ b/library/tzdata/Antarctica/Davis
@@ -7,4 +7,6 @@ set TZData(:Antarctica/Davis) {
     {-28857600 25200 0 DAVT}
     {1255806000 18000 0 DAVT}
     {1268251200 25200 0 DAVT}
+    {1319742000 18000 0 DAVT}
+    {1329854400 25200 0 DAVT}
 }
diff --git a/library/tzdata/Antarctica/Palmer b/library/tzdata/Antarctica/Palmer
index 1e24754..601a684 100644
--- a/library/tzdata/Antarctica/Palmer
+++ b/library/tzdata/Antarctica/Palmer
@@ -67,16 +67,16 @@ set TZData(:Antarctica/Palmer) {
     {1160884800 -10800 1 CLST}
     {1173582000 -14400 0 CLT}
     {1192334400 -10800 1 CLST}
-    {1205031600 -14400 0 CLT}
+    {1206846000 -14400 0 CLT}
     {1223784000 -10800 1 CLST}
     {1237086000 -14400 0 CLT}
     {1255233600 -10800 1 CLST}
-    {1268535600 -14400 0 CLT}
+    {1270350000 -14400 0 CLT}
     {1286683200 -10800 1 CLST}
-    {1299985200 -14400 0 CLT}
-    {1318132800 -10800 1 CLST}
-    {1331434800 -14400 0 CLT}
-    {1350187200 -10800 1 CLST}
+    {1304823600 -14400 0 CLT}
+    {1313899200 -10800 1 CLST}
+    {1335668400 -14400 0 CLT}
+    {1346558400 -10800 1 CLST}
     {1362884400 -14400 0 CLT}
     {1381636800 -10800 1 CLST}
     {1394334000 -14400 0 CLT}
diff --git a/library/tzdata/Asia/Yerevan b/library/tzdata/Asia/Yerevan
index cd70b4f..22008ef 100644
--- a/library/tzdata/Asia/Yerevan
+++ b/library/tzdata/Asia/Yerevan
@@ -66,180 +66,5 @@ set TZData(:Asia/Yerevan) {
     {1288476000 14400 0 AMT}
     {1301176800 18000 1 AMST}
     {1319925600 14400 0 AMT}
-    {1332626400 18000 1 AMST}
-    {1351375200 14400 0 AMT}
-    {1364680800 18000 1 AMST}
-    {1382824800 14400 0 AMT}
-    {1396130400 18000 1 AMST}
-    {1414274400 14400 0 AMT}
-    {1427580000 18000 1 AMST}
-    {1445724000 14400 0 AMT}
-    {1459029600 18000 1 AMST}
-    {1477778400 14400 0 AMT}
-    {1490479200 18000 1 AMST}
-    {1509228000 14400 0 AMT}
-    {1521928800 18000 1 AMST}
-    {1540677600 14400 0 AMT}
-    {1553983200 18000 1 AMST}
-    {1572127200 14400 0 AMT}
-    {1585432800 18000 1 AMST}
-    {1603576800 14400 0 AMT}
-    {1616882400 18000 1 AMST}
-    {1635631200 14400 0 AMT}
-    {1648332000 18000 1 AMST}
-    {1667080800 14400 0 AMT}
-    {1679781600 18000 1 AMST}
-    {1698530400 14400 0 AMT}
-    {1711836000 18000 1 AMST}
-    {1729980000 14400 0 AMT}
-    {1743285600 18000 1 AMST}
-    {1761429600 14400 0 AMT}
-    {1774735200 18000 1 AMST}
-    {1792879200 14400 0 AMT}
-    {1806184800 18000 1 AMST}
-    {1824933600 14400 0 AMT}
-    {1837634400 18000 1 AMST}
-    {1856383200 14400 0 AMT}
-    {1869084000 18000 1 AMST}
-    {1887832800 14400 0 AMT}
-    {1901138400 18000 1 AMST}
-    {1919282400 14400 0 AMT}
-    {1932588000 18000 1 AMST}
-    {1950732000 14400 0 AMT}
-    {1964037600 18000 1 AMST}
-    {1982786400 14400 0 AMT}
-    {1995487200 18000 1 AMST}
-    {2014236000 14400 0 AMT}
-    {2026936800 18000 1 AMST}
-    {2045685600 14400 0 AMT}
-    {2058386400 18000 1 AMST}
-    {2077135200 14400 0 AMT}
-    {2090440800 18000 1 AMST}
-    {2108584800 14400 0 AMT}
-    {2121890400 18000 1 AMST}
-    {2140034400 14400 0 AMT}
-    {2153340000 18000 1 AMST}
-    {2172088800 14400 0 AMT}
-    {2184789600 18000 1 AMST}
-    {2203538400 14400 0 AMT}
-    {2216239200 18000 1 AMST}
-    {2234988000 14400 0 AMT}
-    {2248293600 18000 1 AMST}
-    {2266437600 14400 0 AMT}
-    {2279743200 18000 1 AMST}
-    {2297887200 14400 0 AMT}
-    {2311192800 18000 1 AMST}
-    {2329336800 14400 0 AMT}
-    {2342642400 18000 1 AMST}
-    {2361391200 14400 0 AMT}
-    {2374092000 18000 1 AMST}
-    {2392840800 14400 0 AMT}
-    {2405541600 18000 1 AMST}
-    {2424290400 14400 0 AMT}
-    {2437596000 18000 1 AMST}
-    {2455740000 14400 0 AMT}
-    {2469045600 18000 1 AMST}
-    {2487189600 14400 0 AMT}
-    {2500495200 18000 1 AMST}
-    {2519244000 14400 0 AMT}
-    {2531944800 18000 1 AMST}
-    {2550693600 14400 0 AMT}
-    {2563394400 18000 1 AMST}
-    {2582143200 14400 0 AMT}
-    {2595448800 18000 1 AMST}
-    {2613592800 14400 0 AMT}
-    {2626898400 18000 1 AMST}
-    {2645042400 14400 0 AMT}
-    {2658348000 18000 1 AMST}
-    {2676492000 14400 0 AMT}
-    {2689797600 18000 1 AMST}
-    {2708546400 14400 0 AMT}
-    {2721247200 18000 1 AMST}
-    {2739996000 14400 0 AMT}
-    {2752696800 18000 1 AMST}
-    {2771445600 14400 0 AMT}
-    {2784751200 18000 1 AMST}
-    {2802895200 14400 0 AMT}
-    {2816200800 18000 1 AMST}
-    {2834344800 14400 0 AMT}
-    {2847650400 18000 1 AMST}
-    {2866399200 14400 0 AMT}
-    {2879100000 18000 1 AMST}
-    {2897848800 14400 0 AMT}
-    {2910549600 18000 1 AMST}
-    {2929298400 14400 0 AMT}
-    {2941999200 18000 1 AMST}
-    {2960748000 14400 0 AMT}
-    {2974053600 18000 1 AMST}
-    {2992197600 14400 0 AMT}
-    {3005503200 18000 1 AMST}
-    {3023647200 14400 0 AMT}
-    {3036952800 18000 1 AMST}
-    {3055701600 14400 0 AMT}
-    {3068402400 18000 1 AMST}
-    {3087151200 14400 0 AMT}
-    {3099852000 18000 1 AMST}
-    {3118600800 14400 0 AMT}
-    {3131906400 18000 1 AMST}
-    {3150050400 14400 0 AMT}
-    {3163356000 18000 1 AMST}
-    {3181500000 14400 0 AMT}
-    {3194805600 18000 1 AMST}
-    {3212949600 14400 0 AMT}
-    {3226255200 18000 1 AMST}
-    {3245004000 14400 0 AMT}
-    {3257704800 18000 1 AMST}
-    {3276453600 14400 0 AMT}
-    {3289154400 18000 1 AMST}
-    {3307903200 14400 0 AMT}
-    {3321208800 18000 1 AMST}
-    {3339352800 14400 0 AMT}
-    {3352658400 18000 1 AMST}
-    {3370802400 14400 0 AMT}
-    {3384108000 18000 1 AMST}
-    {3402856800 14400 0 AMT}
-    {3415557600 18000 1 AMST}
-    {3434306400 14400 0 AMT}
-    {3447007200 18000 1 AMST}
-    {3465756000 14400 0 AMT}
-    {3479061600 18000 1 AMST}
-    {3497205600 14400 0 AMT}
-    {3510511200 18000 1 AMST}
-    {3528655200 14400 0 AMT}
-    {3541960800 18000 1 AMST}
-    {3560104800 14400 0 AMT}
-    {3573410400 18000 1 AMST}
-    {3592159200 14400 0 AMT}
-    {3604860000 18000 1 AMST}
-    {3623608800 14400 0 AMT}
-    {3636309600 18000 1 AMST}
-    {3655058400 14400 0 AMT}
-    {3668364000 18000 1 AMST}
-    {3686508000 14400 0 AMT}
-    {3699813600 18000 1 AMST}
-    {3717957600 14400 0 AMT}
-    {3731263200 18000 1 AMST}
-    {3750012000 14400 0 AMT}
-    {3762712800 18000 1 AMST}
-    {3781461600 14400 0 AMT}
-    {3794162400 18000 1 AMST}
-    {3812911200 14400 0 AMT}
-    {3825612000 18000 1 AMST}
-    {3844360800 14400 0 AMT}
-    {3857666400 18000 1 AMST}
-    {3875810400 14400 0 AMT}
-    {3889116000 18000 1 AMST}
-    {3907260000 14400 0 AMT}
-    {3920565600 18000 1 AMST}
-    {3939314400 14400 0 AMT}
-    {3952015200 18000 1 AMST}
-    {3970764000 14400 0 AMT}
-    {3983464800 18000 1 AMST}
-    {4002213600 14400 0 AMT}
-    {4015519200 18000 1 AMST}
-    {4033663200 14400 0 AMT}
-    {4046968800 18000 1 AMST}
-    {4065112800 14400 0 AMT}
-    {4078418400 18000 1 AMST}
-    {4096562400 14400 0 AMT}
+    {1332626400 14400 0 AMT}
 }
diff --git a/library/tzdata/Atlantic/Stanley b/library/tzdata/Atlantic/Stanley
index 545b91c..c287238 100644
--- a/library/tzdata/Atlantic/Stanley
+++ b/library/tzdata/Atlantic/Stanley
@@ -71,182 +71,5 @@ set TZData(:Atlantic/Stanley) {
     {1240117200 -14400 0 FKT}
     {1252216800 -10800 1 FKST}
     {1271566800 -14400 0 FKT}
-    {1283666400 -10800 1 FKST}
-    {1315112400 -10800 1 FKST}
-    {1334466000 -14400 0 FKT}
-    {1346565600 -10800 1 FKST}
-    {1366520400 -14400 0 FKT}
-    {1378015200 -10800 1 FKST}
-    {1397970000 -14400 0 FKT}
-    {1410069600 -10800 1 FKST}
-    {1429419600 -14400 0 FKT}
-    {1441519200 -10800 1 FKST}
-    {1460869200 -14400 0 FKT}
-    {1472968800 -10800 1 FKST}
-    {1492318800 -14400 0 FKT}
-    {1504418400 -10800 1 FKST}
-    {1523768400 -14400 0 FKT}
-    {1535868000 -10800 1 FKST}
-    {1555822800 -14400 0 FKT}
-    {1567317600 -10800 1 FKST}
-    {1587272400 -14400 0 FKT}
-    {1599372000 -10800 1 FKST}
-    {1618722000 -14400 0 FKT}
-    {1630821600 -10800 1 FKST}
-    {1650171600 -14400 0 FKT}
-    {1662271200 -10800 1 FKST}
-    {1681621200 -14400 0 FKT}
-    {1693720800 -10800 1 FKST}
-    {1713675600 -14400 0 FKT}
-    {1725170400 -10800 1 FKST}
-    {1745125200 -14400 0 FKT}
-    {1757224800 -10800 1 FKST}
-    {1776574800 -14400 0 FKT}
-    {1788674400 -10800 1 FKST}
-    {1808024400 -14400 0 FKT}
-    {1820124000 -10800 1 FKST}
-    {1839474000 -14400 0 FKT}
-    {1851573600 -10800 1 FKST}
-    {1870923600 -14400 0 FKT}
-    {1883023200 -10800 1 FKST}
-    {1902978000 -14400 0 FKT}
-    {1914472800 -10800 1 FKST}
-    {1934427600 -14400 0 FKT}
-    {1946527200 -10800 1 FKST}
-    {1965877200 -14400 0 FKT}
-    {1977976800 -10800 1 FKST}
-    {1997326800 -14400 0 FKT}
-    {2009426400 -10800 1 FKST}
-    {2028776400 -14400 0 FKT}
-    {2040876000 -10800 1 FKST}
-    {2060226000 -14400 0 FKT}
-    {2072325600 -10800 1 FKST}
-    {2092280400 -14400 0 FKT}
-    {2104380000 -10800 1 FKST}
-    {2123730000 -14400 0 FKT}
-    {2135829600 -10800 1 FKST}
-    {2155179600 -14400 0 FKT}
-    {2167279200 -10800 1 FKST}
-    {2186629200 -14400 0 FKT}
-    {2198728800 -10800 1 FKST}
-    {2218078800 -14400 0 FKT}
-    {2230178400 -10800 1 FKST}
-    {2250133200 -14400 0 FKT}
-    {2261628000 -10800 1 FKST}
-    {2281582800 -14400 0 FKT}
-    {2293682400 -10800 1 FKST}
-    {2313032400 -14400 0 FKT}
-    {2325132000 -10800 1 FKST}
-    {2344482000 -14400 0 FKT}
-    {2356581600 -10800 1 FKST}
-    {2375931600 -14400 0 FKT}
-    {2388031200 -10800 1 FKST}
-    {2407381200 -14400 0 FKT}
-    {2419480800 -10800 1 FKST}
-    {2439435600 -14400 0 FKT}
-    {2450930400 -10800 1 FKST}
-    {2470885200 -14400 0 FKT}
-    {2482984800 -10800 1 FKST}
-    {2502334800 -14400 0 FKT}
-    {2514434400 -10800 1 FKST}
-    {2533784400 -14400 0 FKT}
-    {2545884000 -10800 1 FKST}
-    {2565234000 -14400 0 FKT}
-    {2577333600 -10800 1 FKST}
-    {2597288400 -14400 0 FKT}
-    {2608783200 -10800 1 FKST}
-    {2628738000 -14400 0 FKT}
-    {2640837600 -10800 1 FKST}
-    {2660187600 -14400 0 FKT}
-    {2672287200 -10800 1 FKST}
-    {2691637200 -14400 0 FKT}
-    {2703736800 -10800 1 FKST}
-    {2723086800 -14400 0 FKT}
-    {2735186400 -10800 1 FKST}
-    {2754536400 -14400 0 FKT}
-    {2766636000 -10800 1 FKST}
-    {2786590800 -14400 0 FKT}
-    {2798085600 -10800 1 FKST}
-    {2818040400 -14400 0 FKT}
-    {2830140000 -10800 1 FKST}
-    {2849490000 -14400 0 FKT}
-    {2861589600 -10800 1 FKST}
-    {2880939600 -14400 0 FKT}
-    {2893039200 -10800 1 FKST}
-    {2912389200 -14400 0 FKT}
-    {2924488800 -10800 1 FKST}
-    {2943838800 -14400 0 FKT}
-    {2955938400 -10800 1 FKST}
-    {2975893200 -14400 0 FKT}
-    {2987992800 -10800 1 FKST}
-    {3007342800 -14400 0 FKT}
-    {3019442400 -10800 1 FKST}
-    {3038792400 -14400 0 FKT}
-    {3050892000 -10800 1 FKST}
-    {3070242000 -14400 0 FKT}
-    {3082341600 -10800 1 FKST}
-    {3101691600 -14400 0 FKT}
-    {3113791200 -10800 1 FKST}
-    {3133746000 -14400 0 FKT}
-    {3145240800 -10800 1 FKST}
-    {3165195600 -14400 0 FKT}
-    {3177295200 -10800 1 FKST}
-    {3196645200 -14400 0 FKT}
-    {3208744800 -10800 1 FKST}
-    {3228094800 -14400 0 FKT}
-    {3240194400 -10800 1 FKST}
-    {3259544400 -14400 0 FKT}
-    {3271644000 -10800 1 FKST}
-    {3290994000 -14400 0 FKT}
-    {3303093600 -10800 1 FKST}
-    {3323048400 -14400 0 FKT}
-    {3334543200 -10800 1 FKST}
-    {3354498000 -14400 0 FKT}
-    {3366597600 -10800 1 FKST}
-    {3385947600 -14400 0 FKT}
-    {3398047200 -10800 1 FKST}
-    {3417397200 -14400 0 FKT}
-    {3429496800 -10800 1 FKST}
-    {3448846800 -14400 0 FKT}
-    {3460946400 -10800 1 FKST}
-    {3480901200 -14400 0 FKT}
-    {3492396000 -10800 1 FKST}
-    {3512350800 -14400 0 FKT}
-    {3524450400 -10800 1 FKST}
-    {3543800400 -14400 0 FKT}
-    {3555900000 -10800 1 FKST}
-    {3575250000 -14400 0 FKT}
-    {3587349600 -10800 1 FKST}
-    {3606699600 -14400 0 FKT}
-    {3618799200 -10800 1 FKST}
-    {3638149200 -14400 0 FKT}
-    {3650248800 -10800 1 FKST}
-    {3670203600 -14400 0 FKT}
-    {3681698400 -10800 1 FKST}
-    {3701653200 -14400 0 FKT}
-    {3713752800 -10800 1 FKST}
-    {3733102800 -14400 0 FKT}
-    {3745202400 -10800 1 FKST}
-    {3764552400 -14400 0 FKT}
-    {3776652000 -10800 1 FKST}
-    {3796002000 -14400 0 FKT}
-    {3808101600 -10800 1 FKST}
-    {3827451600 -14400 0 FKT}
-    {3839551200 -10800 1 FKST}
-    {3859506000 -14400 0 FKT}
-    {3871605600 -10800 1 FKST}
-    {3890955600 -14400 0 FKT}
-    {3903055200 -10800 1 FKST}
-    {3922405200 -14400 0 FKT}
-    {3934504800 -10800 1 FKST}
-    {3953854800 -14400 0 FKT}
-    {3965954400 -10800 1 FKST}
-    {3985304400 -14400 0 FKT}
-    {3997404000 -10800 1 FKST}
-    {4017358800 -14400 0 FKT}
-    {4028853600 -10800 1 FKST}
-    {4048808400 -14400 0 FKT}
-    {4060908000 -10800 1 FKST}
-    {4080258000 -14400 0 FKT}
-    {4092357600 -10800 1 FKST}
+    {1283662800 -10800 0 FKST}
 }
diff --git a/library/tzdata/Pacific/Easter b/library/tzdata/Pacific/Easter
index f8e63a8..38795fb 100644
--- a/library/tzdata/Pacific/Easter
+++ b/library/tzdata/Pacific/Easter
@@ -96,8 +96,8 @@ set TZData(:Pacific/Easter) {
     {1286683200 -18000 1 EASST}
     {1304823600 -21600 0 EAST}
     {1313899200 -18000 1 EASST}
-    {1331434800 -21600 0 EAST}
-    {1350187200 -18000 1 EASST}
+    {1335668400 -21600 0 EAST}
+    {1346558400 -18000 1 EASST}
     {1362884400 -21600 0 EAST}
     {1381636800 -18000 1 EASST}
     {1394334000 -21600 0 EAST}
diff --git a/library/tzdata/Pacific/Fakaofo b/library/tzdata/Pacific/Fakaofo
index 7420639..6cfdbd1 100644
--- a/library/tzdata/Pacific/Fakaofo
+++ b/library/tzdata/Pacific/Fakaofo
@@ -3,4 +3,5 @@
 set TZData(:Pacific/Fakaofo) {
     {-9223372036854775808 -41096 0 LMT}
     {-2177411704 -36000 0 TKT}
+    {1325239200 50400 0 TKT}
 }
-- 
cgit v0.12


From 4469b8019b142def58d2f77fae3229675667eefe Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Thu, 22 Mar 2012 07:33:06 +0000
Subject: Implement tip 398 : Quickly Exit with Non-Blocking Blocked Channels.
 This is simply a revert of the (C part of the) 1025712d5b commit of
 2011-08-17.

---
 generic/tclIO.c | 5 ++---
 1 file changed, 2 insertions(+), 3 deletions(-)

diff --git a/generic/tclIO.c b/generic/tclIO.c
index 082cf70..cf875a8 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -414,8 +414,8 @@ TclFinalizeIOSubsystem(void)
 		statePtr != NULL;
 		statePtr = statePtr->nextCSPtr) {
 	    chanPtr = statePtr->topChanPtr;
-            if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED | CHANNEL_DEAD)
-                || GotFlag(statePtr, BG_FLUSH_SCHEDULED)) {
+	    if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED |
+		    CHANNEL_DEAD)) {
 		active = 1;
 		break;
 	    }
@@ -458,7 +458,6 @@ TclFinalizeIOSubsystem(void)
 		 * The refcount is greater than zero, so flush the channel.
 		 */
 
-                ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
 		Tcl_Flush((Tcl_Channel) chanPtr);
 
 		/*
-- 
cgit v0.12


From 5a62da3750ddfade44c3113b96e1f5c7a0cef1f1 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Thu, 22 Mar 2012 08:04:09 +0000
Subject: Take two. Don't forget to apply all patches, even when the phone
 rings in between.

---
 generic/tclIO.c | 6 +-----
 1 file changed, 1 insertion(+), 5 deletions(-)

diff --git a/generic/tclIO.c b/generic/tclIO.c
index cf875a8..7888352 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -427,13 +427,9 @@ TclFinalizeIOSubsystem(void)
 
 	if (active) {
 	    /*
-	     * Set the channel back into blocking mode to ensure that we wait
-	     * for all data to flush out.
+	     * TIP #398: we no longer set the channel back into blocking mode
 	     */
 
-	    (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
-		    "-blocking", "on");
-
 	    if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
 		    (chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
 		    (chanPtr == (Channel *) tsdPtr->stderrChannel)) {
-- 
cgit v0.12


From fa9a43ff5fd981089f0a432872444073f8710c99 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 23 Mar 2012 15:26:25 +0000
Subject: Revert some cygwin-related signature changes from [835f8e1e9d]
 (2010-02-01) They were an attempt to make the cygwin port compile again, but
 since cygwin is based on unix this serves no purpose any more. Add
 tclWinError.c to the CYGWIN build.

---
 ChangeLog                 | 10 ++++++++++
 generic/tclInt.decls      | 14 +++++++-------
 generic/tclIntPlatDecls.h | 20 ++++++++++----------
 unix/Makefile.in          |  4 ++++
 unix/configure            |  2 +-
 unix/tcl.m4               |  2 +-
 win/tclWinError.c         | 41 +++++++++++++++++++++++++++++------------
 7 files changed, 62 insertions(+), 31 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 7a4b653..55df617 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,15 @@
 2012-03-20  Jan Nijtmans  <nijtmans@users.sf.net>
 
+	* generic/tclInt.decls        Revert some cygwin-related signature changes from
+	* generic/tclIntPlatDecls.h   [835f8e1e9d] (2010-02-01). They were an attempt to
+	* win/tclWinError.c           make the cygwin port compile again, but since cygwin
+	                              is based on unix this serves no purpose any more.
+	* unix/Makefile.in            Add tclWinError.c to the CYGWIN build.
+	* unix/tcl.m4
+	* unix/configure
+
+2012-03-20  Jan Nijtmans  <nijtmans@users.sf.net>
+
 	* generic/tcl.decls:           [Bug 3508771] load tclreg.dll in cygwin tclsh
 	* generic/tclInt.decls:        Implement TclWinGetPlatformId, Tcl_WinUtfToTChar,
 	* generic/tclIntPlatDecls.h:   Tcl_WinTCharToUtf (and a dummy TclWinCPUID) for 
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index d06faf2..eb9da09 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -683,12 +683,12 @@ declare 169 generic {
 }
 declare 170 generic {
     int TclCheckInterpTraces(Tcl_Interp *interp, CONST char *command,
-            int numChars, Command *cmdPtr, int result, int traceFlags,
+	    int numChars, Command *cmdPtr, int result, int traceFlags,
 	    int objc, Tcl_Obj *CONST objv[])
 }
 declare 171 generic {
     int TclCheckExecutionTraces(Tcl_Interp *interp, CONST char *command,
-            int numChars, Command *cmdPtr, int result, int traceFlags,
+	    int numChars, Command *cmdPtr, int result, int traceFlags,
 	    int objc, Tcl_Obj *CONST objv[])
 }
 declare 172 generic {
@@ -955,17 +955,17 @@ interface tclIntPlat
 # Windows specific functions
 
 declare 0 win {
-    void TclWinConvertError(unsigned long errCode)
+    void TclWinConvertError(DWORD errCode)
 }
 declare 1 win {
-    void TclWinConvertWSAError(unsigned long errCode)
+    void TclWinConvertWSAError(DWORD errCode)
 }
 declare 2 win {
     struct servent *TclWinGetServByName(CONST char *nm,
 	    CONST char *proto)
 }
 declare 3 win {
-    int TclWinGetSockOpt(int s, int level, int optname,
+    int TclWinGetSockOpt(SOCKET s, int level, int optname,
 	    char FAR *optval, int FAR *optlen)
 }
 declare 4 win {
@@ -979,7 +979,7 @@ declare 6 win {
     u_short TclWinNToHS(u_short ns)
 }
 declare 7 win {
-    int TclWinSetSockOpt(int s, int level, int optname,
+    int TclWinSetSockOpt(SOCKET s, int level, int optname,
 	    CONST char FAR *optval, int optlen)
 }
 declare 8 win {
@@ -1027,7 +1027,7 @@ declare 19 win {
     TclFile TclpOpenFile(CONST char *fname, int mode)
 }
 declare 20 win {
-    void TclWinAddProcess(void *hProcess, unsigned long id)
+    void TclWinAddProcess(HANDLE hProcess, DWORD id)
 }
 
 # removed permanently for 8.4
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 37b6379..4c7c8bb 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -144,12 +144,12 @@ EXTERN int		TclWinCPUID(unsigned int index, unsigned int *regs);
 #ifndef TclWinConvertError_TCL_DECLARED
 #define TclWinConvertError_TCL_DECLARED
 /* 0 */
-EXTERN void		TclWinConvertError(unsigned long errCode);
+EXTERN void		TclWinConvertError(DWORD errCode);
 #endif
 #ifndef TclWinConvertWSAError_TCL_DECLARED
 #define TclWinConvertWSAError_TCL_DECLARED
 /* 1 */
-EXTERN void		TclWinConvertWSAError(unsigned long errCode);
+EXTERN void		TclWinConvertWSAError(DWORD errCode);
 #endif
 #ifndef TclWinGetServByName_TCL_DECLARED
 #define TclWinGetServByName_TCL_DECLARED
@@ -160,7 +160,7 @@ EXTERN struct servent *	 TclWinGetServByName(CONST char *nm,
 #ifndef TclWinGetSockOpt_TCL_DECLARED
 #define TclWinGetSockOpt_TCL_DECLARED
 /* 3 */
-EXTERN int		TclWinGetSockOpt(int s, int level, int optname,
+EXTERN int		TclWinGetSockOpt(SOCKET s, int level, int optname,
 				char FAR *optval, int FAR *optlen);
 #endif
 #ifndef TclWinGetTclInstance_TCL_DECLARED
@@ -177,7 +177,7 @@ EXTERN u_short		TclWinNToHS(u_short ns);
 #ifndef TclWinSetSockOpt_TCL_DECLARED
 #define TclWinSetSockOpt_TCL_DECLARED
 /* 7 */
-EXTERN int		TclWinSetSockOpt(int s, int level, int optname,
+EXTERN int		TclWinSetSockOpt(SOCKET s, int level, int optname,
 				CONST char FAR *optval, int optlen);
 #endif
 #ifndef TclpGetPid_TCL_DECLARED
@@ -237,7 +237,7 @@ EXTERN TclFile		TclpOpenFile(CONST char *fname, int mode);
 #ifndef TclWinAddProcess_TCL_DECLARED
 #define TclWinAddProcess_TCL_DECLARED
 /* 20 */
-EXTERN void		TclWinAddProcess(VOID *hProcess, unsigned long id);
+EXTERN void		TclWinAddProcess(HANDLE hProcess, DWORD id);
 #endif
 /* Slot 21 is reserved */
 #ifndef TclpCreateTempFile_TCL_DECLARED
@@ -449,14 +449,14 @@ typedef struct TclIntPlatStubs {
     int (*tclWinCPUID) (unsigned int index, unsigned int *regs); /* 29 */
 #endif /* UNIX */
 #ifdef __WIN32__ /* WIN */
-    void (*tclWinConvertError) (unsigned long errCode); /* 0 */
-    void (*tclWinConvertWSAError) (unsigned long errCode); /* 1 */
+    void (*tclWinConvertError) (DWORD errCode); /* 0 */
+    void (*tclWinConvertWSAError) (DWORD errCode); /* 1 */
     struct servent * (*tclWinGetServByName) (CONST char *nm, CONST char *proto); /* 2 */
-    int (*tclWinGetSockOpt) (int s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */
+    int (*tclWinGetSockOpt) (SOCKET s, int level, int optname, char FAR *optval, int FAR *optlen); /* 3 */
     HINSTANCE (*tclWinGetTclInstance) (void); /* 4 */
     VOID *reserved5;
     u_short (*tclWinNToHS) (u_short ns); /* 6 */
-    int (*tclWinSetSockOpt) (int s, int level, int optname, CONST char FAR *optval, int optlen); /* 7 */
+    int (*tclWinSetSockOpt) (SOCKET s, int level, int optname, CONST char FAR *optval, int optlen); /* 7 */
     unsigned long (*tclpGetPid) (Tcl_Pid pid); /* 8 */
     int (*tclWinGetPlatformId) (void); /* 9 */
     VOID *reserved10;
@@ -469,7 +469,7 @@ typedef struct TclIntPlatStubs {
     VOID *reserved17;
     TclFile (*tclpMakeFile) (Tcl_Channel channel, int direction); /* 18 */
     TclFile (*tclpOpenFile) (CONST char *fname, int mode); /* 19 */
-    void (*tclWinAddProcess) (VOID *hProcess, unsigned long id); /* 20 */
+    void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
     VOID *reserved21;
     TclFile (*tclpCreateTempFile) (CONST char *contents); /* 22 */
     char * (*tclpGetTZName) (int isdst); /* 23 */
diff --git a/unix/Makefile.in b/unix/Makefile.in
index 382a41b..c88736c 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -1441,6 +1441,10 @@ tclMacOSXFCmd.o: $(MAC_OSX_DIR)/tclMacOSXFCmd.c
 tclMacOSXNotify.o: $(MAC_OSX_DIR)/tclMacOSXNotify.c
 	$(CC) -c $(CC_SWITCHES) $(MAC_OSX_DIR)/tclMacOSXNotify.c
 
+# The following is a CYGWIN only source:
+tclWinError.o: $(TOP_DIR)/win/tclWinError.c
+	$(CC) -c $(CC_SWITCHES) $(TOP_DIR)/win/tclWinError.c
+
 # DTrace support
 
 $(TCL_OBJS) $(STUB_LIB_OBJS) $(TCLSH_OBJS) $(TCLTEST_OBJS) $(XTTEST_OBJS): @DTRACE_HDR@
diff --git a/unix/configure b/unix/configure
index 43c2d1c..66ef3b6 100755
--- a/unix/configure
+++ b/unix/configure
@@ -6931,7 +6931,7 @@ fi
 	    SHLIB_CFLAGS=""
 	    SHLIB_LD='${CC} -shared'
 	    SHLIB_SUFFIX=".dll"
-	    DL_OBJS="tclLoadDl.o"
+	    DL_OBJS="tclLoadDl.o tclWinError.o"
 	    DL_LIBS="-ldl"
 	    CC_SEARCH_FLAGS=""
 	    LD_SEARCH_FLAGS=""
diff --git a/unix/tcl.m4 b/unix/tcl.m4
index 37c7c74..fe9b136 100644
--- a/unix/tcl.m4
+++ b/unix/tcl.m4
@@ -1241,7 +1241,7 @@ AC_DEFUN([SC_CONFIG_CFLAGS], [
 	    SHLIB_CFLAGS=""
 	    SHLIB_LD='${CC} -shared'
 	    SHLIB_SUFFIX=".dll"
-	    DL_OBJS="tclLoadDl.o"
+	    DL_OBJS="tclLoadDl.o tclWinError.o"
 	    DL_LIBS="-ldl"
 	    CC_SEARCH_FLAGS=""
 	    LD_SEARCH_FLAGS=""
diff --git a/win/tclWinError.c b/win/tclWinError.c
index ca1b0e8..b49271e 100644
--- a/win/tclWinError.c
+++ b/win/tclWinError.c
@@ -11,12 +11,21 @@
  */
 
 #include "tclInt.h"
+#include "tclPort.h"
+
+#ifndef WSAEWOULDBLOCK
+#   define WSAEWOULDBLOCK 10035L
+#endif
+
+#ifndef __WIN32__
+#   define DWORD unsigned int
+#endif
 
 /*
  * The following table contains the mapping from Win32 errors to errno errors.
  */
 
-static char errorTable[] = {
+static CONST unsigned char errorTable[] = {
     0,
     EINVAL,	/* ERROR_INVALID_FUNCTION	1 */
     ENOENT,	/* ERROR_FILE_NOT_FOUND		2 */
@@ -284,17 +293,15 @@ static char errorTable[] = {
     EINVAL,	/* 264 */
     EINVAL,	/* 265 */
     EINVAL,	/* 266 */
-    ENOTDIR,	/* ERROR_DIRECTORY		267 */
+    ENOTDIR	/* ERROR_DIRECTORY		267 */
 };
 
-static const unsigned int tableLen = sizeof(errorTable);
-
 /*
  * The following table contains the mapping from WinSock errors to
  * errno errors.
  */
 
-static int wsaErrorTable[] = {
+static CONST int wsaErrorTable[] = {
     EWOULDBLOCK,	/* WSAEWOULDBLOCK */
     EINPROGRESS,	/* WSAEINPROGRESS */
     EALREADY,		/* WSAEALREADY */
@@ -331,7 +338,7 @@ static int wsaErrorTable[] = {
     EUSERS,		/* WSAEUSERS */
     EDQUOT,		/* WSAEDQUOT */
     ESTALE,		/* WSAESTALE */
-    EREMOTE,		/* WSAEREMOTE */
+    EREMOTE		/* WSAEREMOTE */
 };
 
 /*
@@ -352,9 +359,9 @@ static int wsaErrorTable[] = {
 
 void
 TclWinConvertError(
-    unsigned long errCode)		/* Win32 error code. */
+    DWORD errCode)		/* Win32 error code. */
 {
-    if (errCode >= tableLen) {
+    if (errCode >= sizeof(errorTable)/sizeof(errorTable[0])) {
 	Tcl_SetErrno(EINVAL);
     } else {
 	Tcl_SetErrno(errorTable[errCode]);
@@ -379,11 +386,21 @@ TclWinConvertError(
 
 void
 TclWinConvertWSAError(
-    unsigned long errCode)		/* Win32 error code. */
+    DWORD errCode)		/* Win32 error code. */
 {
-    if ((errCode >= WSAEWOULDBLOCK) && (errCode <= WSAEREMOTE)) {
-	Tcl_SetErrno(wsaErrorTable[errCode - WSAEWOULDBLOCK]);
-    } else {
+    errCode -= WSAEWOULDBLOCK;
+    if (errCode >= sizeof(wsaErrorTable)/sizeof(wsaErrorTable[0])) {
 	Tcl_SetErrno(EINVAL);
+    } else {
+	Tcl_SetErrno(wsaErrorTable[errCode]);
     }
 }
+
+/*
+ * Local Variables:
+ * mode: c
+ * c-basic-offset: 4
+ * fill-column: 78
+ * tab-width: 8
+ * End:
+ */
-- 
cgit v0.12


From 75deef8c587e76a653bb51e16c6252c09ddefbc8 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 23 Mar 2012 15:54:36 +0000
Subject: wrong date in ChangeLog

---
 ChangeLog | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 55df617..dbcd430 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,4 @@
-2012-03-20  Jan Nijtmans  <nijtmans@users.sf.net>
+2012-03-23  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclInt.decls        Revert some cygwin-related signature changes from
 	* generic/tclIntPlatDecls.h   [835f8e1e9d] (2010-02-01). They were an attempt to
-- 
cgit v0.12


From d23835257d7cdbf7c914e23117f34386a03420f4 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 26 Mar 2012 12:51:15 +0000
Subject: Implementation of TIP #380

---
 ChangeLog                 |   75 ++--
 doc/define.n              |  191 +++++++--
 doc/object.n              |   15 +-
 generic/tclOO.c           |  386 +++++++++++------
 generic/tclOOBasic.c      |    9 +-
 generic/tclOOCall.c       |   18 +-
 generic/tclOODefineCmds.c | 1042 +++++++++++++++++++++++++++++++++++----------
 generic/tclOOInt.h        |   15 +-
 tests/oo.test             |  242 ++++++++++-
 9 files changed, 1540 insertions(+), 453 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index aa2b6b7..792af60 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,34 +1,59 @@
+2012-03-26  Donal K. Fellows  <dkf@users.sf.net>
+
+	IMPLEMENTATION OF TIP#380.
+
+	* doc/define.n, doc/object.n, generic/tclOO.c, generic/tclOOBasic.c:
+	* generic/tclOOCall.c, generic/tclOODefineCmds.c, generic/tclOOInt.h:
+	* tests/oo.test: Switch definitions of lists of things in objects and
+	classes to a slot-based approach, which gives a lot more flexibility
+	and programmability at the script-level. Introduce new [::oo::Slot]
+	class which is the implementation of these things.
+
+	***POTENTIAL INCOMPATIBILITY***
+	The unknown method handler now may be asked to deal with the case
+	where no method name is provided at all. The default implementation
+	generates a compatible error message, and any override that forces the
+	presence of a first argument (i.e., a method name) will continue to
+	function as at present as well, so this is a pretty small change.
+
+	* generic/tclOOBasic.c (TclOO_Object_Destroy): Made it easier to do a
+	tailcall inside a normally-invoked destructor; prevented leakage out
+	to calling command.
+
 2012-03-25  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclInt.decls:      [Bug 3508771] load tclreg.dll in cygwin tclsh
-	* generic/tclIntPlatDecls.h: Implement TclWinConvertError, TclWinConvertWSAError,
-	* generic/tclStubInit.c:     and various more win32-specific internal functions for 
-	* unix/Makefile.in:          Cygwin, so win32 extensions using those can be
-	* unix/tcl.m4:               loaded in the cygwin version of tclsh.
-	* unix/configure:
-	* win/tclWinError.c:
+	* generic/tclInt.decls:      [Bug 3508771]: load tclreg.dll in cygwin
+	* generic/tclIntPlatDecls.h: tclsh. Implement TclWinConvertError,
+	* generic/tclStubInit.c:     TclWinConvertWSAError, and various more
+	* unix/Makefile.in:          win32-specific internal functions for
+	* unix/tcl.m4:               Cygwin, so win32 extensions using those
+	* unix/configure:            can be loaded in the cygwin version of
+	* win/tclWinError.c:         tclsh.
 
 2012-03-23  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclInt.decls        Revert some cygwin-related signature changes from
-	* generic/tclIntPlatDecls.h   [835f8e1e9d] (2010-01-22). They were an attempt to
-	* win/tclWinError.c           make the cygwin port compile again, but since cygwin
-	                              is based on unix this serves no purpose any more.
-	* win/tclWinSerial.c:         Use EAGAIN in stead of EWOULDBLOCK, because in
-	* win/tclWinSock.c:           VS10+ the value of EWOULDBLOCK is no longer the
-	                              same as EAGAIN
-	* unix/Makefile.in            Add tclWinError.c to the CYGWIN build.
-	* unix/tcl.m4
-	* unix/configure
+	* generic/tclInt.decls:       Revert some cygwin-related signature
+	* generic/tclIntPlatDecls.h:  changes from [835f8e1e9d] (2010-01-22).
+	* win/tclWinError.c:          They were an attempt to make the cygwin
+	                              port compile again, but since cygwin is
+	                              based on unix this serves no purpose any
+	                              more.
+	* win/tclWinSerial.c:         Use EAGAIN in stead of EWOULDBLOCK,
+	* win/tclWinSock.c:           because in VS10+ the value of
+	                              EWOULDBLOCK is no longer the same as
+	                              EAGAIN.
+	* unix/Makefile.in:           Add tclWinError.c to the CYGWIN build.
+	* unix/tcl.m4:
+	* unix/configure:
 
 2012-03-20  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tcl.decls:           [Bug 3508771] load tclreg.dll in cygwin tclsh
-	* generic/tclInt.decls:        Implement TclWinGetPlatformId, Tcl_WinUtfToTChar,
-	* generic/tclIntPlatDecls.h:   Tcl_WinTCharToUtf (and a dummy TclWinCPUID) for 
-	* generic/tclPlatDecls.h:      Cygwin, so win32 extensions using those can be
-	* generic/tclStubInit.c:       loaded in the cygwin version of tclsh.
-	* unix/tclUnixCompat.c:
+	* generic/tcl.decls:         [Bug 3508771]: load tclreg.dll in cygwin
+	* generic/tclInt.decls:      tclsh. Implement TclWinGetPlatformId,
+	* generic/tclIntPlatDecls.h: Tcl_WinUtfToTChar, Tcl_WinTCharToUtf (and
+	* generic/tclPlatDecls.h:    a dummy TclWinCPUID) for Cygwin, so win32
+	* generic/tclStubInit.c:     extensions using those can be loaded in
+	* unix/tclUnixCompat.c:      the cygwin version of tclsh.
 
 2012-03-19  Venkat Iyer <venkat@comit.com>
 
@@ -70,7 +95,7 @@
 
 2012-03-15  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tcl.h: [Bug 3288345] Wrong Tcl_StatBuf used on Cygwin
+	* generic/tcl.h: [Bug 3288345]: Wrong Tcl_StatBuf used on Cygwin
 	* unix/tclUnixFile.c
 	* unix/tclUnixPort.h
 	* win/cat.c:           Remove cygwin stuff no longer needed
@@ -79,7 +104,7 @@
 
 2012-03-12  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinFile.c: [Bug 3388350] mingw64 compiler warnings
+	* win/tclWinFile.c: [Bug 3388350]: mingw64 compiler warnings
 
 2012-03-11  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/doc/define.n b/doc/define.n
index 58bc4cd..6bdd9c5 100644
--- a/doc/define.n
+++ b/doc/define.n
@@ -81,14 +81,18 @@ class being defined. Note that the methods themselves may be actually defined
 by a superclass; subclass exports override superclass visibility, and may in
 turn be overridden by instances.
 .TP
-\fBfilter\fR ?\fImethodName ...\fR?
-.
-This sets or updates the list of method names that are used to guard whether a
+\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+sets or updates the list of method names that are used to guard whether
 method call to instances of the class may be called and what the method's
 results are. Each \fImethodName\fR names a single filtering method (which may
 be exposed or not exposed); it is not an error for a non-existent method to be
-named since they may be defined by subclasses. If no \fImethodName\fR
-arguments are present, the list of filter names is set to empty.
+named since they may be defined by subclasses.
+.VS
+By default, this slot works by appending.
+.VE
 .TP
 \fBforward\fI name cmdName \fR?\fIarg ...\fR?
 .
@@ -114,12 +118,16 @@ exported if \fIname\fR starts with a lower-case letter, and non-exported
 otherwise; this behavior can be overridden via \fBexport\fR and
 \fBunexport\fR.
 .TP
-\fBmixin\fR ?\fIclassName ...\fR?
-.
-This sets or updates the list of additional classes that are to be mixed into
+\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+sets or updates the list of additional classes that are to be mixed into
 all the instances of the class being defined. Each \fIclassName\fR argument
-names a single class that is to be mixed in; if no classes are present, the
-list of mixed-in classes is set to be empty.
+names a single class that is to be mixed in.
+.VS
+By default, this slot works by replacement.
+.VE
 .TP
 \fBrenamemethod\fI fromName toName\fR
 .
@@ -144,12 +152,19 @@ and
 operates identically to
 .QW "\fBoo::objdefine \fIcls subcommand ...\fR" .
 .TP
-\fBsuperclass\fI className \fR?\fIclassName ...\fR?
-.
-This allows the alteration of the superclasses of the class being defined.
+\fBsuperclass\fI ?\fI\-slotOperation\fR? \fR?\fIclassName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+allows the alteration of the superclasses of the class being defined.
 Each \fIclassName\fR argument names one class that is to be a superclass of
 the defined class. Note that objects must not be changed from being classes to
-being non-classes or vice-versa.
+being non-classes or vice-versa, that an empty parent class is equivalent to
+\fBoo::object\fR, and that the parent classes of \fBoo::object\fR and
+\fBoo::class\fR may not be modified.
+.VS
+By default, this slot works by replacement.
+.VE
 .TP
 \fBunexport\fI name \fR?\fIname ...\fR?
 .
@@ -160,18 +175,18 @@ context) by the class being defined. Note that the methods themselves may be
 actually defined by a superclass; subclass unexports override superclass
 visibility, and may be overridden by instance unexports.
 .TP
-\fBvariable\fR ?\fIname ...\fR?
+\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
 .VS
-This arranges for each of the named variables to be automatically made
+This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
+variables to be automatically made
 available in the methods, constructor and destructor declared by the class
-being defined. Note that the list of variable names is the whole list of
-variable names for the class. Each variable name must not have any namespace
+being defined. Each variable name must not have any namespace
 separators and must not look like an array access. All variables will be
 actually present in the instance object on which the method is executed. Note
 that the variable lists declared by a superclass or subclass are completely
 disjoint, as are variable lists declared by instances; the list of variable
 names is just for methods (and constructors and destructors) declared by this
-class.
+class. By default, this slot works by appending.
 .VE
 .SS "CONFIGURING OBJECTS"
 .PP
@@ -198,15 +213,19 @@ This arranges for each of the named methods, \fIname\fR, to be exported
 being defined. Note that the methods themselves may be actually defined by a
 class or superclass; object exports override class visibility.
 .TP
-\fBfilter\fR ?\fImethodName ...\fR?
-.
-This sets or updates the list of method names that are used to guard whether a
+\fBfilter\fR ?\fI\-slotOperation\fR? ?\fImethodName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+sets or updates the list of method names that are used to guard whether a
 method call to the object may be called and what the method's results are.
 Each \fImethodName\fR names a single filtering method (which may be exposed or
-not exposed); it is not an error for a non-existent method to be named. If no
-\fImethodName\fR arguments are present, the list of filter names is set to
-empty. Note that the actual list of filters also depends on the filters set
-upon any classes that the object is an instance of.
+not exposed); it is not an error for a non-existent method to be named. Note
+that the actual list of filters also depends on the filters set upon any
+classes that the object is an instance of.
+.VS
+By default, this slot works by appending.
+.VE
 .TP
 \fBforward\fI name cmdName \fR?\fIarg ...\fR?
 .
@@ -227,12 +246,16 @@ current namespace of the method will be a namespace that is unique to the
 object. The method will be exported if \fIname\fR starts with a lower-case
 letter, and non-exported otherwise.
 .TP
-\fBmixin\fR ?\fIclassName ...\fR?
-.
-This sets or updates a per-object list of additional classes that are to be
+\fBmixin\fR ?\fI\-slotOperation\fR? ?\fIclassName ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below)
+.VE
+sets or updates a per-object list of additional classes that are to be
 mixed into the object. Each argument, \fIclassName\fR, names a single class
-that is to be mixed in; if no classes are present, the list of mixed-in
-classes is set to be empty.
+that is to be mixed in.
+.VS
+By default, this slot works by replacement.
+.VE
 .TP
 \fBrenamemethod\fI fromName toName\fR
 .
@@ -250,16 +273,70 @@ just through the \fBmy\fR command visible in the object's context) by the
 object being defined. Note that the methods themselves may be actually defined
 by a class; instance unexports override class visibility.
 .TP
-\fBvariable\fR ?\fIname ...\fR?
+\fBvariable\fR ?\fI\-slotOperation\fR? ?\fIname ...\fR?
+.VS
+This slot (see \fBSLOTTED DEFINITIONS\fR below) arranges for each of the named
+variables to be automatically made available in the methods declared by the
+object being defined.  Each variable name must not have any namespace
+separators and must not look like an array access. All variables will be
+actually present in the object on which the method is executed. Note that the
+variable lists declared by the classes and mixins of which the object is an
+instance are completely disjoint; the list of variable names is just for
+methods declared by this object. By default, this slot works by appending.
+.SH "SLOTTED DEFINITIONS"
+Some of the configurable definitions of a class or object are \fIslotted
+definitions\fR. This means that the configuration is implemented by a slot
+object, that is an instance of the class \fBoo::Slot\fR, which manages a list
+of values (class names, variable names, etc.) that comprises the contents of
+the slot. The class defines three operations (as methods) that may be done on
+the slot:
+.VE
+.TP
+\fIslot\fR \fB\-append\fR ?\fImember ...\fR?
+.VS
+This appends the given \fImember\fR elements to the slot definition.
+.VE
+.TP
+\fIslot\fR \fB\-clear\fR
+.VS
+This sets the slot definition to the empty list.
+.VE
+.TP
+\fIslot\fR \fB\-set\fR ?\fImember ...\fR?
+.VS
+This replaces the slot definition with the given \fImember\fR elements.
+.PP
+A consequence of this is that any use of a slot's default operation where the
+first member argument begins with a hyphen will be an error. One of the above
+operations should be used explicitly in those circumstances.
+.SS "SLOT IMPLEMENTATION"
+Internally, slot objects also define a method \fB\-\-default\-operation\fR
+which is forwarded to the default operation of the slot (thus, for the class
+.QW \fBvariable\fR
+slot, this is forwarded to
+.QW "\fBmy \-append\fR" ),
+and these methods which provide the implementation interface:
+.VE
+.TP
+\fIslot\fR \fBGet\fR
+.VS
+Returns a list that is the current contents of the slot. This method must
+always be called from a stack frame created by a call to \fBoo::define\fR or
+\fBoo::objdefine\fR.
+.VE
+.TP
+\fIslot\fR \fBSet \fIelementList\fR
 .VS
-This arranges for each of the named variables to be automatically made
-available in the methods declared by the object being defined. Note that the
-list of variable names is the whole list of variable names for the object.
-Each variable name must not have any namespace separators and must not look
-like an array access. All variables will be actually present in the object on
-which the method is executed. Note that the variable lists declared by the
-classes and mixins of which the object is an instance are completely disjoint;
-the list of variable names is just for methods declared by this object.
+Sets the contents of the slot to the list \fIelementList\fR and returns the
+empty string. This method must always be called from a stack frame created by
+a call to \fBoo::define\fR or \fBoo::objdefine\fR.
+.PP
+The implementation of these methods is slot-dependent (and responsible for
+accessing the correct part of the class or object definition). Slots also have
+an unknown method handler to tie all these pieces together, and they hide
+their \fBdestroy\fR method so that it is not invoked inadvertently. It is
+\fIrecommended\fR that any user changes to the slot mechanism be restricted to
+defining new operations whose names start with a hyphen.
 .VE
 .SH EXAMPLES
 This example demonstrates how to use both forms of the \fBoo::define\fR and
@@ -286,11 +363,41 @@ o Foo Bar            \fI\(-> error "unknown method Foo"\fR
 \fBoo::objdefine\fR o \fBrenamemethod\fR bar lollipop
 o lollipop           \fI\(-> prints "hello world"\fR
 .CE
+.PP
+This example shows how additional classes can be mixed into an object. It also
+shows how \fBmixin\fR is a slot that supports appending:
+.PP
+.CS
+oo::object create inst
+inst m1              \fI\(-> error "unknown method m1"\fR
+inst m2              \fI\(-> error "unknown method m2"\fR
+
+oo::class create A {
+    \fBmethod\fR m1 {} {
+        puts "red brick"
+    }
+}
+\fBoo::objdefine\fR inst {
+    \fBmixin\fR A
+}
+inst m1              \fI\(-> prints "red brick"\fR
+inst m2              \fI\(-> error "unknown method m2"\fR
+
+oo::class create B {
+    \fBmethod\fR m2 {} {
+        puts "blue brick"
+    }
+}
+\fBoo::objdefine\fR inst {
+    \fBmixin -append\fR B
+}
+inst m1              \fI\(-> prints "red brick"\fR
+inst m2              \fI\(-> prints "blue brick"\fR
+.CE
 .SH "SEE ALSO"
 next(n), oo::class(n), oo::object(n)
 .SH KEYWORDS
-class, definition, method, object
-
+class, definition, method, object, slot
 .\" Local variables:
 .\" mode: nroff
 .\" fill-column: 78
diff --git a/doc/object.n b/doc/object.n
index 96a1bfb..3a948a4 100644
--- a/doc/object.n
+++ b/doc/object.n
@@ -65,14 +65,19 @@ This method concatenates the arguments, \fIarg\fR, as if with \fBconcat\fR,
 and then evaluates the resulting script in the namespace that is uniquely
 associated with \fIobj\fR, returning the result of the evaluation.
 .TP
-\fIobj \fBunknown \fImethodName\fR ?\fIarg ...\fR?
+\fIobj \fBunknown ?\fImethodName\fR? ?\fIarg ...\fR?
 .
 This method is called when an attempt to invoke the method \fImethodName\fR on
 object \fIobj\fR fails. The arguments that the user supplied to the method are
-given as \fIarg\fR arguments. The default implementation (i.e. the one defined
-by the \fBoo::object\fR class) generates a suitable error, detailing what
-methods the object supports given whether the object was invoked by its public
-name or through the \fBmy\fR command.
+given as \fIarg\fR arguments.
+.VS
+If \fImethodName\fR is absent, the object was invoked with no method name at
+all (or any other arguments).
+.VE
+The default implementation (i.e., the one defined by the \fBoo::object\fR
+class) generates a suitable error, detailing what methods the object supports
+given whether the object was invoked by its public name or through the
+\fBmy\fR command.
 .TP
 \fIobj \fBvariable \fR?\fIvarName ...\fR?
 .
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 8ac2039..6300d80 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -28,27 +28,20 @@ static const struct {
     {"deletemethod", TclOODefineDeleteMethodObjCmd, 0},
     {"destructor", TclOODefineDestructorObjCmd, 0},
     {"export", TclOODefineExportObjCmd, 0},
-    {"filter", TclOODefineFilterObjCmd, 0},
     {"forward", TclOODefineForwardObjCmd, 0},
     {"method", TclOODefineMethodObjCmd, 0},
-    {"mixin", TclOODefineMixinObjCmd, 0},
     {"renamemethod", TclOODefineRenameMethodObjCmd, 0},
     {"self", TclOODefineSelfObjCmd, 0},
-    {"superclass", TclOODefineSuperclassObjCmd, 0},
     {"unexport", TclOODefineUnexportObjCmd, 0},
-    {"variable", TclOODefineVariablesObjCmd, 0},
     {NULL, NULL, 0}
 }, objdefCmds[] = {
     {"class", TclOODefineClassObjCmd, 1},
     {"deletemethod", TclOODefineDeleteMethodObjCmd, 1},
     {"export", TclOODefineExportObjCmd, 1},
-    {"filter", TclOODefineFilterObjCmd, 1},
     {"forward", TclOODefineForwardObjCmd, 1},
     {"method", TclOODefineMethodObjCmd, 1},
-    {"mixin", TclOODefineMixinObjCmd, 1},
     {"renamemethod", TclOODefineRenameMethodObjCmd, 1},
     {"unexport", TclOODefineUnexportObjCmd, 1},
-    {"variable", TclOODefineVariablesObjCmd, 1},
     {NULL, NULL, 0}
 };
 
@@ -79,7 +72,7 @@ static int		FinalizeNext(ClientData data[],
 			    Tcl_Interp *interp, int result);
 static int		FinalizeObjectCall(ClientData data[],
 			    Tcl_Interp *interp, int result);
-static void		InitFoundation(Tcl_Interp *interp);
+static int		InitFoundation(Tcl_Interp *interp);
 static void		KillFoundation(ClientData clientData,
 			    Tcl_Interp *interp);
 static void		MyDeleted(ClientData clientData);
@@ -136,6 +129,35 @@ static char initScript[] =
 /*     "tcl_findLibrary tcloo $oo::version $oo::version" */
 /*     " tcloo.tcl OO_LIBRARY oo::library;"; */
 
+static const char *slotScript =
+"::oo::define ::oo::Slot {\n"
+"    method Get {} {error unimplemented}\n"
+"    method Set list {error unimplemented}\n"
+"    method -set args {\n"
+"        uplevel 1 [list [namespace which my] Set $args]\n"
+"    }\n"
+"    method -append args {\n"
+"        uplevel 1 [list [namespace which my] Set [list"
+"                {*}[uplevel 1 [list [namespace which my] Get]] {*}$args]]\n"
+"    }\n"
+"    method -clear {} {uplevel 1 [list [namespace which my] Set {}]}\n"
+"    forward --default-operation my -append\n"
+"    method unknown {args} {\n"
+"        set def --default-operation\n"
+"        if {[llength $args] == 0} {\n"
+"            return [uplevel 1 [list [namespace which my] $def]]\n"
+"        } elseif {![string match -* [lindex $args 0]]} {\n"
+"            return [uplevel 1 [list [namespace which my] $def {*}$args]]\n"
+"        }\n"
+"        next {*}$args\n"
+"    }\n"
+"    export -set -append -clear\n"
+"    unexport unknown destroy\n"
+"}\n"
+"::oo::objdefine ::oo::define::superclass forward --default-operation my -set\n"
+"::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
+"::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
+
 MODULE_SCOPE const TclOOStubs tclOOStubs;
 
 /*
@@ -144,6 +166,17 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
 
 #define GetFoundation(interp) \
 	((Foundation *)((Interp *)(interp))->objectFoundation)
+
+/*
+ * Macros to make inspecting into the guts of an object cleaner. Note that the
+ * roots oo::object and oo::class have _both_ their object and class flags
+ * tagged with ROOT_OBJECT and ROOT_CLASS respectively.
+ */
+
+#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
+#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
+#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
+#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
 
 /*
  * ----------------------------------------------------------------------
@@ -170,7 +203,9 @@ TclOOInit(
      * Build the core of the OO system.
      */
 
-    InitFoundation(interp);
+    if (InitFoundation(interp) != TCL_OK) {
+	return TCL_ERROR;
+    }
 
     /*
      * Run our initialization script and, if that works, declare the package
@@ -214,7 +249,7 @@ TclOOGetFoundation(
  * ----------------------------------------------------------------------
  */
 
-static void
+static int
 InitFoundation(
     Tcl_Interp *interp)
 {
@@ -292,11 +327,13 @@ InitFoundation(
 	    AllocObject(interp, "::oo::class", NULL));
     fPtr->objectCls->thisPtr->selfCls = fPtr->classCls;
     fPtr->objectCls->thisPtr->flags |= ROOT_OBJECT;
+    fPtr->objectCls->flags |= ROOT_OBJECT;
     fPtr->objectCls->superclasses.num = 0;
     ckfree(fPtr->objectCls->superclasses.list);
     fPtr->objectCls->superclasses.list = NULL;
     fPtr->classCls->thisPtr->selfCls = fPtr->classCls;
     fPtr->classCls->thisPtr->flags |= ROOT_CLASS;
+    fPtr->classCls->flags |= ROOT_CLASS;
     TclOOAddToInstances(fPtr->objectCls->thisPtr, fPtr->classCls);
     TclOOAddToInstances(fPtr->classCls->thisPtr, fPtr->classCls);
     AddRef(fPtr->objectCls->thisPtr);
@@ -357,6 +394,15 @@ InitFoundation(
 	    NULL);
     Tcl_CreateObjCommand(interp, "::oo::copy", TclOOCopyObjectCmd, NULL,NULL);
     TclOOInitInfo(interp);
+
+    /*
+     * Now make the class of slots.
+     */
+
+    if (TclOODefineSlots(fPtr) != TCL_OK) {
+	return TCL_ERROR;
+    }
+    return Tcl_Eval(interp, slotScript);
 }
 
 /*
@@ -669,8 +715,7 @@ ObjectRenamedTrace(
     int flags)			/* Why was the object deleted? */
 {
     Object *oPtr = clientData;
-    Class *clsPtr;
-    CallContext *contextPtr;
+    Foundation *fPtr = oPtr->fPtr;
 
     /*
      * If this is a rename and not a delete of the object, we just flush the
@@ -702,17 +747,20 @@ ObjectRenamedTrace(
      */
 
     AddRef(oPtr);
+    AddRef(fPtr->classCls);
+    AddRef(fPtr->objectCls);
+    AddRef(fPtr->classCls->thisPtr);
+    AddRef(fPtr->objectCls->thisPtr);
     oPtr->command = NULL;
-    oPtr->flags |= OBJECT_DELETED;
 
-    if (!(oPtr->flags & DESTRUCTOR_CALLED) && (!Tcl_InterpDeleted(interp)
-	    || (oPtr->flags & (ROOT_OBJECT|ROOT_CLASS)))) {
-	contextPtr = TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+    if (!(oPtr->flags & DESTRUCTOR_CALLED) && !Tcl_InterpDeleted(interp)) {
+	CallContext *contextPtr =
+		TclOOGetCallContext(oPtr, NULL, DESTRUCTOR, NULL);
+	int result;
+	Tcl_InterpState state;
+
 	oPtr->flags |= DESTRUCTOR_CALLED;
 	if (contextPtr != NULL) {
-	    int result;
-	    Tcl_InterpState state;
-
 	    contextPtr->callPtr->flags |= DESTRUCTOR;
 	    contextPtr->skip = 0;
 	    state = Tcl_SaveInterpState(interp, TCL_OK);
@@ -731,25 +779,20 @@ ObjectRenamedTrace(
      * and nuke the namespace (which triggers the final crushing of the object
      * structure itself).
      *
-     * The class of classes needs some special care; if it is deleted (and
+     * The class of objects needs some special care; if it is deleted (and
      * we're not killing the whole interpreter) we force the delete of the
-     * class of objects now as well. Due to the incestuous nature of those two
+     * class of classes now as well. Due to the incestuous nature of those two
      * classes, if one goes the other must too and yet the tangle can
      * sometimes not go away automatically; we force it here. [Bug 2962664]
      */
 
-    if (!Tcl_InterpDeleted(interp)) {
-	if ((oPtr->flags & ROOT_OBJECT) && oPtr->fPtr->classCls != NULL) {
-	    Tcl_DeleteCommandFromToken(interp,
-		    oPtr->fPtr->classCls->thisPtr->command);
-	} else if (oPtr->flags & ROOT_CLASS) {
-	    oPtr->fPtr->classCls = NULL;
-	}
+    if (!Tcl_InterpDeleted(interp) && IsRootObject(oPtr)
+	    && !Deleted(fPtr->classCls->thisPtr)) {
+	Tcl_DeleteCommandFromToken(interp, fPtr->classCls->thisPtr->command);
     }
 
-    clsPtr = oPtr->classPtr;
-    if (clsPtr != NULL) {
-	AddRef(clsPtr);
+    if (oPtr->classPtr != NULL) {
+	AddRef(oPtr->classPtr);
 	ReleaseClassContents(interp, oPtr);
     }
 
@@ -761,9 +804,13 @@ ObjectRenamedTrace(
     if (((Namespace *) oPtr->namespacePtr)->earlyDeleteProc != NULL) {
 	Tcl_DeleteNamespace(oPtr->namespacePtr);
     }
-    if (clsPtr) {
-	DelRef(clsPtr);
+    if (oPtr->classPtr) {
+	DelRef(oPtr->classPtr);
     }
+    DelRef(fPtr->classCls->thisPtr);
+    DelRef(fPtr->objectCls->thisPtr);
+    DelRef(fPtr->classCls);
+    DelRef(fPtr->objectCls);
     DelRef(oPtr);
 }
 
@@ -783,77 +830,128 @@ ReleaseClassContents(
     Tcl_Interp *interp,		/* The interpreter containing the class. */
     Object *oPtr)		/* The object representing the class. */
 {
-    int i, n;
-    Class *clsPtr = oPtr->classPtr, **list;
-    Object **insts;
+    FOREACH_HASH_DECLS;
+    int i;
+    Class *clsPtr = oPtr->classPtr, *mixinSubclassPtr, *subclassPtr;
+    Object *instancePtr;
+    Foundation *fPtr = oPtr->fPtr;
 
     /*
-     * Must empty list before processing the members of the list so that
-     * things happen in the correct order even if something tries to play
-     * fast-and-loose.
+     * Sanity check!
      */
 
-    list = clsPtr->mixinSubs.list;
-    n = clsPtr->mixinSubs.num;
-    clsPtr->mixinSubs.list = NULL;
-    clsPtr->mixinSubs.num = 0;
-    clsPtr->mixinSubs.size = 0;
-    for (i=0 ; i<n ; i++) {
-	AddRef(list[i]);
-	AddRef(list[i]->thisPtr);
+    if (!Deleted(oPtr)) {
+	if (IsRootClass(oPtr)) {
+	    Tcl_Panic("deleting class structure for non-deleted %s",
+		    "::oo::class");
+	} else if (IsRootObject(oPtr)) {
+	    Tcl_Panic("deleting class structure for non-deleted %s",
+		    "::oo::object");
+	} else {
+	    Tcl_Panic("deleting class structure for non-deleted %s",
+		    "general object");
+	}
     }
-    for (i=0 ; i<n ; i++) {
-	if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
-	    list[i]->thisPtr->flags |= OBJECT_DELETED;
-	    Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+
+    /*
+     * Lock a number of dependent objects until we've stopped putting our
+     * fingers in them.
+     */
+
+    FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+	if (mixinSubclassPtr != NULL) {
+	    AddRef(mixinSubclassPtr);
+	    AddRef(mixinSubclassPtr->thisPtr);
 	}
-	DelRef(list[i]->thisPtr);
-	DelRef(list[i]);
     }
-    if (list != NULL) {
-	ckfree(list);
+    FOREACH(subclassPtr, clsPtr->subclasses) {
+	if (subclassPtr != NULL && !IsRoot(subclassPtr)) {
+	    AddRef(subclassPtr);
+	    AddRef(subclassPtr->thisPtr);
+	}
     }
-
-    list = clsPtr->subclasses.list;
-    n = clsPtr->subclasses.num;
-    clsPtr->subclasses.list = NULL;
-    clsPtr->subclasses.num = 0;
-    clsPtr->subclasses.size = 0;
-    for (i=0 ; i<n ; i++) {
-	AddRef(list[i]);
-	AddRef(list[i]->thisPtr);
+    if (!IsRootClass(oPtr)) {
+	FOREACH(instancePtr, clsPtr->instances) {
+	    if (instancePtr != NULL && !IsRoot(instancePtr)) {
+		AddRef(instancePtr);
+	    }
+	}
     }
-    for (i=0 ; i<n ; i++) {
-	if (!(list[i]->thisPtr->flags & OBJECT_DELETED)) {
-	    list[i]->thisPtr->flags |= OBJECT_DELETED;
-	    Tcl_DeleteCommandFromToken(interp, list[i]->thisPtr->command);
+
+    /*
+     * Squelch classes that this class has been mixed into.
+     */
+
+    FOREACH(mixinSubclassPtr, clsPtr->mixinSubs) {
+	if (mixinSubclassPtr == NULL) {
+	    continue;
 	}
-	DelRef(list[i]->thisPtr);
-	DelRef(list[i]);
+	if (!Deleted(mixinSubclassPtr->thisPtr)) {
+	    Tcl_DeleteCommandFromToken(interp,
+		    mixinSubclassPtr->thisPtr->command);
+	}
+	DelRef(mixinSubclassPtr->thisPtr);
+	DelRef(mixinSubclassPtr);
     }
-    if (list != NULL) {
-	ckfree(list);
+    if (clsPtr->mixinSubs.list != NULL) {
+	ckfree(clsPtr->mixinSubs.list);
+	clsPtr->mixinSubs.list = NULL;
+	clsPtr->mixinSubs.num = 0;
     }
 
-    insts = clsPtr->instances.list;
-    n = clsPtr->instances.num;
-    clsPtr->instances.list = NULL;
-    clsPtr->instances.num = 0;
-    clsPtr->instances.size = 0;
-    for (i=0 ; i<n ; i++) {
-	AddRef(insts[i]);
+    /*
+     * Squelch subclasses of this class.
+     */
+
+    FOREACH(subclassPtr, clsPtr->subclasses) {
+	if (subclassPtr == NULL || IsRoot(subclassPtr)) {
+	    continue;
+	}
+	if (!Deleted(subclassPtr->thisPtr)) {
+	    Tcl_DeleteCommandFromToken(interp, subclassPtr->thisPtr->command);
+	}
+	DelRef(subclassPtr->thisPtr);
+	DelRef(subclassPtr);
+    }
+    if (clsPtr->subclasses.list != NULL) {
+	ckfree(clsPtr->subclasses.list);
+	clsPtr->subclasses.list = NULL;
+	clsPtr->subclasses.num = 0;
     }
-    for (i=0 ; i<n ; i++) {
-	if (!(insts[i]->flags & OBJECT_DELETED)) {
-	    insts[i]->flags |= OBJECT_DELETED;
-	    Tcl_DeleteCommandFromToken(interp, insts[i]->command);
+
+    /*
+     * Squelch instances of this class (includes objects we're mixed into).
+     */
+
+    if (!IsRootClass(oPtr)) {
+	FOREACH(instancePtr, clsPtr->instances) {
+	    if (instancePtr == NULL || IsRoot(instancePtr)) {
+		continue;
+	    }
+	    if (!Deleted(instancePtr)) {
+		Tcl_DeleteCommandFromToken(interp, instancePtr->command);
+	    }
+	    DelRef(instancePtr);
 	}
-	DelRef(insts[i]);
     }
-    if (insts != NULL) {
-	ckfree(insts);
+    if (clsPtr->instances.list != NULL) {
+	ckfree(clsPtr->instances.list);
+	clsPtr->instances.list = NULL;
+	clsPtr->instances.num = 0;
+    }
+
+    /*
+     * Special: We delete these after everything else.
+     */
+
+    if (IsRootClass(oPtr) && !Deleted(fPtr->objectCls->thisPtr)) {
+	Tcl_DeleteCommandFromToken(interp, fPtr->objectCls->thisPtr->command);
     }
 
+    /*
+     * Squelch method implementation chain caches.
+     */
+
     if (clsPtr->constructorChainPtr) {
 	TclOODeleteChain(clsPtr->constructorChainPtr);
 	clsPtr->constructorChainPtr = NULL;
@@ -863,7 +961,6 @@ ReleaseClassContents(
 	clsPtr->destructorChainPtr = NULL;
     }
     if (clsPtr->classChainCache) {
-	FOREACH_HASH_DECLS;
 	CallChain *callPtr;
 
 	FOREACH_HASH_VALUE(callPtr, clsPtr->classChainCache) {
@@ -874,6 +971,10 @@ ReleaseClassContents(
 	clsPtr->classChainCache = NULL;
     }
 
+    /*
+     * Squelch our filter list.
+     */
+
     if (clsPtr->filters.num) {
 	Tcl_Obj *filterObj;
 
@@ -884,9 +985,11 @@ ReleaseClassContents(
 	clsPtr->filters.num = 0;
     }
 
+    /*
+     * Squelch our metadata.
+     */
 
     if (clsPtr->metadataPtr != NULL) {
-	FOREACH_HASH_DECLS;
 	Tcl_ObjectMetadataType *metadataTypePtr;
 	ClientData value;
 
@@ -922,7 +1025,7 @@ ObjectNamespaceDeleted(
     Class *clsPtr = oPtr->classPtr, *mixinPtr;
     Method *mPtr;
     Tcl_Obj *filterObj, *variableObj;
-    int i, preserved = !(oPtr->flags & OBJECT_DELETED);
+    int i;
 
     /*
      * Instruct everyone to no longer use any allocated fields of the object.
@@ -931,27 +1034,19 @@ ObjectNamespaceDeleted(
      * point into freed memory, allowing crashes.
      */
 
-    oPtr->flags |= OBJECT_DELETED;
     if (oPtr->command) {
 	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->command);
     }
     if (oPtr->myCommand) {
 	Tcl_DeleteCommandFromToken(oPtr->fPtr->interp, oPtr->myCommand);
     }
-    if (preserved) {
-	AddRef(oPtr);
-	if (clsPtr != NULL) {
-	    AddRef(clsPtr);
-	    ReleaseClassContents(NULL, oPtr);
-	}
-    }
 
     /*
      * Splice the object out of its context. After this, we must *not* call
      * methods on the object.
      */
 
-    if (!(oPtr->flags & ROOT_OBJECT)) {
+    if (!IsRootObject(oPtr)) {
 	TclOORemoveFromInstances(oPtr, oPtr->selfCls);
     }
 
@@ -1007,11 +1102,10 @@ ObjectNamespaceDeleted(
 
     if (clsPtr != NULL) {
 	Class *superPtr;
+	Tcl_ObjectMetadataType *metadataTypePtr;
+	ClientData value;
 
 	if (clsPtr->metadataPtr != NULL) {
-	    Tcl_ObjectMetadataType *metadataTypePtr;
-	    ClientData value;
-
 	    FOREACH_HASH(metadataTypePtr, value, clsPtr->metadataPtr) {
 		metadataTypePtr->deleteProc(value);
 	    }
@@ -1028,7 +1122,7 @@ ObjectNamespaceDeleted(
 	    clsPtr->filters.num = 0;
 	}
 	FOREACH(mixinPtr, clsPtr->mixins) {
-	    if (!(mixinPtr->thisPtr->flags & OBJECT_DELETED)) {
+	    if (!Deleted(mixinPtr->thisPtr)) {
 		TclOORemoveFromMixinSubs(clsPtr, mixinPtr);
 	    }
 	}
@@ -1037,7 +1131,7 @@ ObjectNamespaceDeleted(
 	    clsPtr->mixins.num = 0;
 	}
 	FOREACH(superPtr, clsPtr->superclasses) {
-	    if (!(superPtr->thisPtr->flags & OBJECT_DELETED)) {
+	    if (!Deleted(superPtr->thisPtr)) {
 		TclOORemoveFromSubclasses(clsPtr, superPtr);
 	    }
 	}
@@ -1080,12 +1174,6 @@ ObjectNamespaceDeleted(
      */
 
     DelRef(oPtr);
-    if (preserved) {
-	if (clsPtr) {
-	    DelRef(clsPtr);
-	}
-	DelRef(oPtr);
-    }
 }
 
 /*
@@ -1116,12 +1204,16 @@ TclOORemoveFromInstances(
     return;
 
   removeInstance:
-    clsPtr->instances.num--;
-    if (i < clsPtr->instances.num) {
-	clsPtr->instances.list[i] =
-		clsPtr->instances.list[clsPtr->instances.num];
+    if (Deleted(clsPtr->thisPtr)) {
+	clsPtr->instances.list[i] = NULL;
+    } else {
+	clsPtr->instances.num--;
+	if (i < clsPtr->instances.num) {
+	    clsPtr->instances.list[i] =
+		    clsPtr->instances.list[clsPtr->instances.num];
+	}
+	clsPtr->instances.list[clsPtr->instances.num] = NULL;
     }
-    clsPtr->instances.list[clsPtr->instances.num] = NULL;
 }
 
 /*
@@ -1142,6 +1234,9 @@ TclOOAddToInstances(
 				 * assumed that the class is not already
 				 * present as an instance in the class. */
 {
+    if (Deleted(clsPtr->thisPtr)) {
+	return;
+    }
     if (clsPtr->instances.num >= clsPtr->instances.size) {
 	clsPtr->instances.size += ALLOC_CHUNK;
 	if (clsPtr->instances.size == ALLOC_CHUNK) {
@@ -1182,12 +1277,16 @@ TclOORemoveFromSubclasses(
     return;
 
   removeSubclass:
-    superPtr->subclasses.num--;
-    if (i < superPtr->subclasses.num) {
-	superPtr->subclasses.list[i] =
-		superPtr->subclasses.list[superPtr->subclasses.num];
+    if (Deleted(superPtr->thisPtr)) {
+	superPtr->subclasses.list[i] = NULL;
+    } else {
+	superPtr->subclasses.num--;
+	if (i < superPtr->subclasses.num) {
+	    superPtr->subclasses.list[i] =
+		    superPtr->subclasses.list[superPtr->subclasses.num];
+	}
+	superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
     }
-    superPtr->subclasses.list[superPtr->subclasses.num] = NULL;
 }
 
 /*
@@ -1208,6 +1307,9 @@ TclOOAddToSubclasses(
 				 * is assumed that the class is not already
 				 * present as a subclass in the superclass. */
 {
+    if (Deleted(superPtr->thisPtr)) {
+	return;
+    }
     if (superPtr->subclasses.num >= superPtr->subclasses.size) {
 	superPtr->subclasses.size += ALLOC_CHUNK;
 	if (superPtr->subclasses.size == ALLOC_CHUNK) {
@@ -1248,12 +1350,16 @@ TclOORemoveFromMixinSubs(
     return;
 
   removeSubclass:
-    superPtr->mixinSubs.num--;
-    if (i < superPtr->mixinSubs.num) {
-	superPtr->mixinSubs.list[i] =
-		superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+    if (Deleted(superPtr->thisPtr)) {
+	superPtr->mixinSubs.list[i] = NULL;
+    } else {
+	superPtr->mixinSubs.num--;
+	if (i < superPtr->mixinSubs.num) {
+	    superPtr->mixinSubs.list[i] =
+		    superPtr->mixinSubs.list[superPtr->mixinSubs.num];
+	}
+	superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
     }
-    superPtr->mixinSubs.list[superPtr->mixinSubs.num] = NULL;
 }
 
 /*
@@ -1274,6 +1380,9 @@ TclOOAddToMixinSubs(
 				 * is assumed that the class is not already
 				 * present as a subclass in the superclass. */
 {
+    if (Deleted(superPtr->thisPtr)) {
+	return;
+    }
     if (superPtr->mixinSubs.num >= superPtr->mixinSubs.size) {
 	superPtr->mixinSubs.size += ALLOC_CHUNK;
 	if (superPtr->mixinSubs.size == ALLOC_CHUNK) {
@@ -1460,7 +1569,7 @@ Tcl_NewObjectInstance(
 	     * errors by accident...) [Bug 2903011]
 	     */
 
-	    if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+	    if (result != TCL_ERROR && Deleted(oPtr)) {
 		Tcl_SetResult(interp, "object deleted in constructor",
 			TCL_STATIC);
 		Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
@@ -1475,7 +1584,7 @@ Tcl_NewObjectInstance(
 		 * bad. [Bug 2903011]
 		 */
 
-		if (!(flags & OBJECT_DELETED)) {
+		if (!Deleted(oPtr)) {
 		    Tcl_DeleteCommandFromToken(interp, oPtr->command);
 		}
 		return NULL;
@@ -1572,6 +1681,7 @@ TclNRNewObjectInstance(
      * Fire off the constructors non-recursively.
      */
 
+    AddRef(oPtr);
     TclNRAddCallback(interp, FinalizeAlloc, contextPtr, oPtr, state,
 	    objectPtr);
     TclPushTailcallPoint(interp);
@@ -1588,7 +1698,7 @@ FinalizeAlloc(
     Object *oPtr = data[1];
     Tcl_InterpState state = data[2];
     Tcl_Object *objectPtr = data[3];
-    int flags = oPtr->flags;
+    //int flags = oPtr->flags;
 
     /*
      * It's an error if the object was whacked in the constructor. Force this
@@ -1596,7 +1706,7 @@ FinalizeAlloc(
      * [Bug 2903011]
      */
 
-    if (result != TCL_ERROR && (flags & OBJECT_DELETED)) {
+    if (result != TCL_ERROR && Deleted(oPtr)) {
 	Tcl_SetResult(interp, "object deleted in constructor", TCL_STATIC);
 	Tcl_SetErrorCode(interp, "TCL", "OO", "STILLBORN", NULL);
 	result = TCL_ERROR;
@@ -1610,13 +1720,15 @@ FinalizeAlloc(
 	 * 2903011]
 	 */
 
-	if (!(flags & OBJECT_DELETED)) {
+	if (!Deleted(oPtr)) {
 	    Tcl_DeleteCommandFromToken(interp, oPtr->command);
 	}
+	DelRef(oPtr);
 	return TCL_ERROR;
     }
     Tcl_RestoreInterpState(interp, state);
     *objectPtr = (Tcl_Object) oPtr;
+    DelRef(oPtr);
     return TCL_OK;
 }
 
@@ -1656,7 +1768,7 @@ Tcl_CopyObjectInstance(
 	Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
 	return NULL;
     }
-    if (oPtr->flags & ROOT_CLASS) {
+    if (IsRootClass(oPtr)) {
 	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
 	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
 	return NULL;
@@ -1728,7 +1840,7 @@ Tcl_CopyObjectInstance(
      */
 
     o2Ptr->flags = oPtr->flags & ~(
-	    OBJECT_DELETED | ROOT_OBJECT | FILTER_HANDLING);
+	    OBJECT_DELETED | ROOT_OBJECT | ROOT_CLASS | FILTER_HANDLING);
 
     /*
      * Copy the object's metadata.
@@ -2254,9 +2366,15 @@ TclOOObjectCmdCore(
     Tcl_Obj *methodNamePtr;
     int result;
 
+    /*
+     * If we've no method name, throw this directly into the unknown
+     * processing.
+     */
+
     if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "method ?arg ...?");
-	return TCL_ERROR;
+	flags |= FORCE_UNKNOWN;
+	methodNamePtr = NULL;
+	goto noMapping;
     }
 
     /*
@@ -2710,7 +2828,7 @@ int
 Tcl_ObjectDeleted(
     Tcl_Object object)
 {
-    return (((Object *)object)->flags & OBJECT_DELETED) ? 1 : 0;
+    return Deleted(object) ? 1 : 0;
 }
 
 Tcl_Object
diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c
index b286088..329f0a4 100644
--- a/generic/tclOOBasic.c
+++ b/generic/tclOOBasic.c
@@ -281,6 +281,7 @@ TclOO_Object_Destroy(
 	    contextPtr->skip = 0;
 	    TclNRAddCallback(interp, AfterNRDestructor, contextPtr,
 		    NULL, NULL, NULL);
+	    TclPushTailcallPoint(interp);
 	    return TclOOInvokeContext(contextPtr, interp, 0, NULL);
 	}
     }
@@ -434,8 +435,14 @@ TclOO_Object_Unknown(
     const char **methodNames;
     int numMethodNames, i, skip = Tcl_ObjectContextSkippedArgs(context);
 
+    /*
+     * If no method name, generate an error asking for a method name. (Only by
+     * overriding *this* method can an object handle the absence of a method
+     * name without an error).
+     */
+
     if (objc < skip+1) {
-	Tcl_WrongNumArgs(interp, skip, objv, "methodName ?arg ...?");
+	Tcl_WrongNumArgs(interp, skip, objv, "method ?arg ...?");
 	return TCL_ERROR;
     }
 
diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 9c9f3c0..8b1aeb1 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -37,7 +37,7 @@ struct ChainBuilder {
 #define DEFINITE_PROTECTED 0x100000
 #define DEFINITE_PUBLIC    0x200000
 #define KNOWN_STATE	   (DEFINITE_PROTECTED | DEFINITE_PUBLIC)
-#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR)
+#define SPECIAL		   (CONSTRUCTOR | DESTRUCTOR | FORCE_UNKNOWN)
 
 /*
  * Function declarations for things defined in this file.
@@ -997,6 +997,22 @@ TclOOGetCallContext(
     cb.oPtr = oPtr;
 
     /*
+     * If we're working with a forced use of unknown, do that now.
+     */
+
+    if (flags & FORCE_UNKNOWN) {
+	AddSimpleChainToCallContext(oPtr, oPtr->fPtr->unknownMethodNameObj,
+		&cb, NULL, 0, NULL);
+	callPtr->flags |= OO_UNKNOWN_METHOD;
+	callPtr->epoch = -1;
+	if (count == callPtr->numChain) {
+	    TclOODeleteChain(callPtr);
+	    return NULL;
+	}
+	goto returnContext;
+    }
+
+    /*
      * Add all defined filters (if any, and if we're going to be processing
      * them; they're not processed for constructors, destructors or when we're
      * in the middle of processing a filter).
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 72732da..e986326 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -17,6 +17,23 @@
 #include "tclOOInt.h"
 
 /*
+ * Some things that make it easier to declare a slot.
+ */
+
+struct DeclaredSlot {
+    const char *name;
+    const Tcl_MethodType getterType;
+    const Tcl_MethodType setterType;
+};
+
+#define SLOT(name,getter,setter)					\
+    {"::oo::" name,							\
+	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Getter", \
+		    getter, NULL, NULL},				\
+	    {TCL_OO_METHOD_VERSION_CURRENT, "core method: " name " Setter", \
+		    setter, NULL, NULL}}
+
+/*
  * Forward declarations.
  */
 
@@ -32,6 +49,63 @@ static inline void	RecomputeClassCacheFlag(Object *oPtr);
 static int		RenameDeleteMethod(Tcl_Interp *interp, Object *oPtr,
 			    int useClass, Tcl_Obj *const fromPtr,
 			    Tcl_Obj *const toPtr);
+static int		ClassFilterGet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ClassFilterSet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ClassMixinGet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ClassMixinSet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ClassSuperGet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ClassSuperSet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ClassVarsGet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ClassVarsSet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjFilterGet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjFilterSet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjMixinGet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjMixinSet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjVarsGet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+static int		ObjVarsSet(ClientData clientData,
+			    Tcl_Interp *interp, Tcl_ObjectContext context,
+			    int objc, Tcl_Obj *const *objv);
+
+/*
+ * Now define the slots used in declarations.
+ */
+
+static const struct DeclaredSlot slots[] = {
+    SLOT("define::filter",      ClassFilterGet, ClassFilterSet),
+    SLOT("define::mixin",       ClassMixinGet,  ClassMixinSet),
+    SLOT("define::superclass",  ClassSuperGet,  ClassSuperSet),
+    SLOT("define::variable",    ClassVarsGet,   ClassVarsSet),
+    SLOT("objdefine::filter",   ObjFilterGet,   ObjFilterSet),
+    SLOT("objdefine::mixin",    ObjMixinGet,    ObjMixinSet),
+    SLOT("objdefine::variable", ObjVarsGet,     ObjVarsSet),
+    {NULL}
+};
 
 /*
  * ----------------------------------------------------------------------
@@ -1388,43 +1462,6 @@ TclOODefineExportObjCmd(
 /*
  * ----------------------------------------------------------------------
  *
- * TclOODefineFilterObjCmd --
- *	Implementation of the "filter" subcommand of the "oo::define" and
- *	"oo::objdefine" commands.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineFilterObjCmd(
-    ClientData clientData,
-    Tcl_Interp *interp,
-    int objc,
-    Tcl_Obj *const *objv)
-{
-    int isInstanceFilter = (clientData != NULL);
-    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-
-    if (oPtr == NULL) {
-	return TCL_ERROR;
-    }
-    if (!isInstanceFilter && !oPtr->classPtr) {
-	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
-	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
-	return TCL_ERROR;
-    }
-
-    if (!isInstanceFilter) {
-	TclOOClassSetFilters(interp, oPtr->classPtr, objc-1, objv+1);
-    } else {
-	TclOOObjectSetFilters(oPtr, objc-1, objv+1);
-    }
-    return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
  * TclOODefineForwardObjCmd --
  *	Implementation of the "forward" subcommand of the "oo::define" and
  *	"oo::objdefine" commands.
@@ -1656,112 +1693,6 @@ TclOODefineRenameMethodObjCmd(
 /*
  * ----------------------------------------------------------------------
  *
- * TclOODefineSuperclassObjCmd --
- *	Implementation of the "superclass" subcommand of the "oo::define"
- *	command.
- *
- * ----------------------------------------------------------------------
- */
-
-int
-TclOODefineSuperclassObjCmd(
-    ClientData clientData,
-    Tcl_Interp *interp,
-    int objc,
-    Tcl_Obj *const *objv)
-{
-    Object *oPtr;
-    Class **superclasses, *superPtr;
-    int i, j;
-
-    if (objc < 2) {
-	Tcl_WrongNumArgs(interp, 1, objv, "className ?className ...?");
-	return TCL_ERROR;
-    }
-
-    /*
-     * Get the class to operate on.
-     */
-
-    oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-    if (oPtr == NULL) {
-	return TCL_ERROR;
-    }
-    if (oPtr->classPtr == NULL) {
-	Tcl_AppendResult(interp, "only classes may have superclasses defined",
-		NULL);
-	Tcl_SetErrorCode(interp, "TCL", "OO", "OBJECT_NOT_CLASS", NULL);
-	return TCL_ERROR;
-    }
-    if (oPtr->flags & ROOT_OBJECT) {
-	Tcl_AppendResult(interp,
-		"may not modify the superclass of the root object", NULL);
-	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
-	return TCL_ERROR;
-    }
-
-    /*
-     * Allocate some working space.
-     */
-
-    superclasses = ckalloc(sizeof(Class *) * (objc-1));
-
-    /*
-     * Parse the arguments to get the class to use as superclasses.
-     */
-
-    for (i=0 ; i<objc-1 ; i++) {
-	Class *clsPtr = GetClassInOuterContext(interp, objv[i+1],
-		"only a class can be a superclass");
-
-	if (clsPtr == NULL) {
-	    goto failedAfterAlloc;
-	}
-	for (j=0 ; j<i ; j++) {
-	    if (superclasses[j] == clsPtr) {
-		Tcl_AppendResult(interp,
-			"class should only be a direct superclass once",NULL);
-		Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
-		goto failedAfterAlloc;
-	    }
-	}
-	if (TclOOIsReachable(oPtr->classPtr, clsPtr)) {
-	    Tcl_AppendResult(interp,
-		    "attempt to form circular dependency graph", NULL);
-	    Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
-	failedAfterAlloc:
-	    ckfree(superclasses);
-	    return TCL_ERROR;
-	}
-	superclasses[i] = clsPtr;
-    }
-
-    /*
-     * Install the list of superclasses into the class. Note that this also
-     * involves splicing the class out of the superclasses' subclass list that
-     * it used to be a member of and splicing it into the new superclasses'
-     * subclass list.
-     */
-
-    if (oPtr->classPtr->superclasses.num != 0) {
-	FOREACH(superPtr, oPtr->classPtr->superclasses) {
-	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
-	}
-	ckfree(oPtr->classPtr->superclasses.list);
-    }
-    oPtr->classPtr->superclasses.list = superclasses;
-    oPtr->classPtr->superclasses.num = objc-1;
-    FOREACH(superPtr, oPtr->classPtr->superclasses) {
-	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
-    }
-    BumpGlobalEpoch(interp, oPtr->classPtr);
-
-    return TCL_OK;
-}
-
-/*
- * ----------------------------------------------------------------------
- *
  * TclOODefineUnexportObjCmd --
  *	Implementation of the "unexport" subcommand of the "oo::define" and
  *	"oo::objdefine" commands.
@@ -1855,99 +1786,13 @@ TclOODefineUnexportObjCmd(
 /*
  * ----------------------------------------------------------------------
  *
- * TclOODefineVariablesObjCmd --
- *	Implementation of the "variable" subcommand of the "oo::define" and
- *	"oo::objdefine" commands.
+ * Tcl_ClassSetConstructor, Tcl_ClassSetDestructor --
+ *	How to install a constructor or destructor into a class; API to call
+ *	from C.
  *
  * ----------------------------------------------------------------------
  */
 
-int
-TclOODefineVariablesObjCmd(
-    ClientData clientData,
-    Tcl_Interp *interp,
-    int objc,
-    Tcl_Obj *const *objv)
-{
-    int isInstanceVars = (clientData != NULL);
-    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
-    Tcl_Obj *variableObj;
-    int i;
-
-    if (oPtr == NULL) {
-	return TCL_ERROR;
-    }
-    if (!isInstanceVars && !oPtr->classPtr) {
-	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
-	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
-	return TCL_ERROR;
-    }
-
-    for (i=1 ; i<objc ; i++) {
-	const char *varName = Tcl_GetString(objv[i]);
-
-	if (strstr(varName, "::") != NULL) {
-	    Tcl_AppendResult(interp, "invalid declared variable name \"",
-		    varName, "\": must not contain namespace separators",
-		    NULL);
-	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
-	    return TCL_ERROR;
-	}
-	if (Tcl_StringMatch(varName, "*(*)")) {
-	    Tcl_AppendResult(interp, "invalid declared variable name \"",
-		    varName, "\": must not refer to an array element", NULL);
-	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
-	    return TCL_ERROR;
-	}
-    }
-    for (i=1 ; i<objc ; i++) {
-	Tcl_IncrRefCount(objv[i]);
-    }
-
-    if (!isInstanceVars) {
-	FOREACH(variableObj, oPtr->classPtr->variables) {
-	    Tcl_DecrRefCount(variableObj);
-	}
-	if (i != objc-1) {
-	    if (objc == 1) {
-		ckfree(oPtr->classPtr->variables.list);
-	    } else if (i) {
-		oPtr->classPtr->variables.list =
-			ckrealloc(oPtr->classPtr->variables.list,
-			sizeof(Tcl_Obj *) * (objc-1));
-	    } else {
-		oPtr->classPtr->variables.list =
-			ckalloc(sizeof(Tcl_Obj *) * (objc-1));
-	    }
-	}
-	if (objc > 1) {
-	    memcpy(oPtr->classPtr->variables.list, objv+1,
-		    sizeof(Tcl_Obj *) * (objc-1));
-	}
-	oPtr->classPtr->variables.num = objc-1;
-    } else {
-	FOREACH(variableObj, oPtr->variables) {
-	    Tcl_DecrRefCount(variableObj);
-	}
-	if (i != objc-1) {
-	    if (objc == 1) {
-		ckfree(oPtr->variables.list);
-	    } else if (i) {
-		oPtr->variables.list = ckrealloc(oPtr->variables.list,
-			sizeof(Tcl_Obj *) * (objc-1));
-	    } else {
-		oPtr->variables.list =
-			ckalloc(sizeof(Tcl_Obj *) * (objc-1));
-	    }
-	}
-	if (objc > 1) {
-	    memcpy(oPtr->variables.list, objv+1, sizeof(Tcl_Obj *)*(objc-1));
-	}
-	oPtr->variables.num = objc-1;
-    }
-    return TCL_OK;
-}
-
 void
 Tcl_ClassSetConstructor(
     Tcl_Interp *interp,
@@ -1993,6 +1838,739 @@ Tcl_ClassSetDestructor(
 }
 
 /*
+ * ----------------------------------------------------------------------
+ *
+ * TclOODefineSlots --
+ *	Create the "::oo::Slot" class and its standard instances. Class
+ *	definition is empty at the stage (added by scripting).
+ *
+ * ----------------------------------------------------------------------
+ */
+
+int
+TclOODefineSlots(
+    Foundation *fPtr)
+{
+    const struct DeclaredSlot *slotInfoPtr;
+    Tcl_Obj *getName = Tcl_NewStringObj("Get", -1);
+    Tcl_Obj *setName = Tcl_NewStringObj("Set", -1);
+    Class *slotCls;
+
+    slotCls = ((Object *) Tcl_NewObjectInstance(fPtr->interp, (Tcl_Class)
+	    fPtr->classCls, "::oo::Slot", NULL, -1, NULL, 0))->classPtr;
+    if (slotCls == NULL) {
+	return TCL_ERROR;
+    }
+    Tcl_IncrRefCount(getName);
+    Tcl_IncrRefCount(setName);
+    for (slotInfoPtr = slots ; slotInfoPtr->name ; slotInfoPtr++) {
+	Tcl_Object slotObject = Tcl_NewObjectInstance(fPtr->interp,
+		(Tcl_Class) slotCls, slotInfoPtr->name, NULL,-1,NULL,0);
+
+	if (slotObject == NULL) {
+	    continue;
+	}
+	Tcl_NewInstanceMethod(fPtr->interp, slotObject, getName, 0,
+		&slotInfoPtr->getterType, NULL);
+	Tcl_NewInstanceMethod(fPtr->interp, slotObject, setName, 0,
+		&slotInfoPtr->setterType, NULL);
+    }
+    Tcl_DecrRefCount(getName);
+    Tcl_DecrRefCount(setName);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassFilterGet, ClassFilterSet --
+ *	Implementation of the "filter" slot accessors of the "oo::define"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassFilterGet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Tcl_Obj *resultObj, *filterObj;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    }
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    } else if (!oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    }
+
+    resultObj = Tcl_NewObj();
+    FOREACH(filterObj, oPtr->classPtr->filters) {
+	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+    }
+    Tcl_SetObjResult(interp, resultObj);
+    return TCL_OK;
+}
+
+static int
+ClassFilterSet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    int filterc;
+    Tcl_Obj **filterv;
+
+    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"filterList");
+	return TCL_ERROR;
+    }
+    objv += Tcl_ObjectContextSkippedArgs(context);
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    } else if (!oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    } else if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
+	    &filterv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    TclOOClassSetFilters(interp, oPtr->classPtr, filterc, filterv);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassMixinGet, ClassMixinSet --
+ *	Implementation of the "mixin" slot accessors of the "oo::define"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassMixinGet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Tcl_Obj *resultObj;
+    Class *mixinPtr;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    }
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    } else if (!oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    }
+
+    resultObj = Tcl_NewObj();
+    FOREACH(mixinPtr, oPtr->classPtr->mixins) {
+	Tcl_ListObjAppendElement(NULL, resultObj,
+		TclOOObjectName(interp, mixinPtr->thisPtr));
+    }
+    Tcl_SetObjResult(interp, resultObj);
+    return TCL_OK;
+
+}
+
+static int
+ClassMixinSet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    int mixinc, i;
+    Tcl_Obj **mixinv;
+    Class **mixins;
+
+    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"mixinList");
+	return TCL_ERROR;
+    }
+    objv += Tcl_ObjectContextSkippedArgs(context);
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    } else if (!oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    } else if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
+	    &mixinv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+
+    for (i=0 ; i<mixinc ; i++) {
+	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
+		"may only mix in classes");
+	if (mixins[i] == NULL) {
+	    goto freeAndError;
+	}
+	if (TclOOIsReachable(oPtr->classPtr, mixins[i])) {
+	    Tcl_AppendResult(interp, "may not mix a class into itself", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "SELF_MIXIN", NULL);
+	    goto freeAndError;
+	}
+    }
+
+    TclOOClassSetMixins(interp, oPtr->classPtr, mixinc, mixins);
+    TclStackFree(interp, mixins);
+    return TCL_OK;
+
+  freeAndError:
+    TclStackFree(interp, mixins);
+    return TCL_ERROR;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassSuperGet, ClassSuperSet --
+ *	Implementation of the "superclass" slot accessors of the "oo::define"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassSuperGet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Tcl_Obj *resultObj;
+    Class *superPtr;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    }
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    } else if (!oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    }
+
+    resultObj = Tcl_NewObj();
+    FOREACH(superPtr, oPtr->classPtr->superclasses) {
+	Tcl_ListObjAppendElement(NULL, resultObj,
+		TclOOObjectName(interp, superPtr->thisPtr));
+    }
+    Tcl_SetObjResult(interp, resultObj);
+    return TCL_OK;
+}
+
+static int
+ClassSuperSet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    int superc, i, j;
+    Tcl_Obj **superv;
+    Class **superclasses, *superPtr;
+
+    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"superclassList");
+	return TCL_ERROR;
+    }
+    objv += Tcl_ObjectContextSkippedArgs(context);
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    } else if (!oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    } else if (oPtr == oPtr->fPtr->objectCls->thisPtr) {
+	Tcl_AppendResult(interp,
+		"may not modify the superclass of the root object", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    } else if (Tcl_ListObjGetElements(interp, objv[0], &superc,
+	    &superv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    /*
+     * Allocate some working space.
+     */
+
+    superclasses = (Class **) ckalloc(sizeof(Class *) * superc);
+
+    /*
+     * Parse the arguments to get the class to use as superclasses.
+     */
+
+    for (i=0 ; i<superc ; i++) {
+	superclasses[i] = GetClassInOuterContext(interp, superv[i],
+		"only a class can be a superclass");
+	if (superclasses[i] == NULL) {
+	    goto failedAfterAlloc;
+	}
+	for (j=0 ; j<i ; j++) {
+	    if (superclasses[j] == superclasses[i]) {
+		Tcl_AppendResult(interp,
+			"class should only be a direct superclass once",NULL);
+		Tcl_SetErrorCode(interp, "TCL", "OO", "REPETITIOUS", NULL);
+		goto failedAfterAlloc;
+	    }
+	}
+	if (TclOOIsReachable(oPtr->classPtr, superclasses[i])) {
+	    Tcl_AppendResult(interp,
+		    "attempt to form circular dependency graph", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "CIRCULARITY", NULL);
+	failedAfterAlloc:
+	    ckfree((char *) superclasses);
+	    return TCL_ERROR;
+	}
+    }
+
+    /*
+     * Install the list of superclasses into the class. Note that this also
+     * involves splicing the class out of the superclasses' subclass list that
+     * it used to be a member of and splicing it into the new superclasses'
+     * subclass list.
+     */
+
+    if (oPtr->classPtr->superclasses.num != 0) {
+	FOREACH(superPtr, oPtr->classPtr->superclasses) {
+	    TclOORemoveFromSubclasses(oPtr->classPtr, superPtr);
+	}
+	ckfree((char *) oPtr->classPtr->superclasses.list);
+    }
+    oPtr->classPtr->superclasses.list = superclasses;
+    oPtr->classPtr->superclasses.num = superc;
+    FOREACH(superPtr, oPtr->classPtr->superclasses) {
+	TclOOAddToSubclasses(oPtr->classPtr, superPtr);
+    }
+    BumpGlobalEpoch(interp, oPtr->classPtr);
+
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ClassVarsGet, ClassVarsSet --
+ *	Implementation of the "variable" slot accessors of the "oo::define"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ClassVarsGet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Tcl_Obj *resultObj, *variableObj;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    }
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    } else if (!oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    }
+
+    resultObj = Tcl_NewObj();
+    FOREACH(variableObj, oPtr->classPtr->variables) {
+	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+    }
+    Tcl_SetObjResult(interp, resultObj);
+    return TCL_OK;
+}
+
+static int
+ClassVarsSet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    int varc;
+    Tcl_Obj **varv, *variableObj;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"filterList");
+	return TCL_ERROR;
+    }
+    objv += Tcl_ObjectContextSkippedArgs(context);
+
+    if (oPtr == NULL) {
+	return TCL_ERROR;
+    } else if (!oPtr->classPtr) {
+	Tcl_AppendResult(interp, "attempt to misuse API", NULL);
+	Tcl_SetErrorCode(interp, "TCL", "OO", "MONKEY_BUSINESS", NULL);
+	return TCL_ERROR;
+    } else if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+	    &varv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    for (i=0 ; i<varc ; i++) {
+	const char *varName = Tcl_GetString(varv[i]);
+
+	if (strstr(varName, "::") != NULL) {
+	    Tcl_AppendResult(interp, "invalid declared variable name \"",
+		    varName, "\": must not contain namespace separators",
+		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+	    return TCL_ERROR;
+	}
+	if (Tcl_StringMatch(varName, "*(*)")) {
+	    Tcl_AppendResult(interp, "invalid declared variable name \"",
+		    varName, "\": must not refer to an array element", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+	    return TCL_ERROR;
+	}
+    }
+
+    for (i=0 ; i<varc ; i++) {
+	Tcl_IncrRefCount(varv[i]);
+    }
+    FOREACH(variableObj, oPtr->classPtr->variables) {
+	Tcl_DecrRefCount(variableObj);
+    }
+    if (i != varc) {
+	if (varc == 0) {
+	    ckfree((char *) oPtr->classPtr->variables.list);
+	} else if (i) {
+	    oPtr->classPtr->variables.list = (Tcl_Obj **)
+		    ckrealloc((char *) oPtr->classPtr->variables.list,
+		    sizeof(Tcl_Obj *) * varc);
+	} else {
+	    oPtr->classPtr->variables.list = (Tcl_Obj **)
+		    ckalloc(sizeof(Tcl_Obj *) * varc);
+	}
+    }
+    if (varc > 0) {
+	memcpy(oPtr->classPtr->variables.list, varv,
+		sizeof(Tcl_Obj *) * varc);
+    }
+    oPtr->classPtr->variables.num = varc;
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectFilterGet, ObjectFilterSet --
+ *	Implementation of the "filter" slot accessors of the "oo::objdefine"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjFilterGet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Tcl_Obj *resultObj, *filterObj;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    } else if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    resultObj = Tcl_NewObj();
+    FOREACH(filterObj, oPtr->filters) {
+	Tcl_ListObjAppendElement(NULL, resultObj, filterObj);
+    }
+    Tcl_SetObjResult(interp, resultObj);
+    return TCL_OK;
+}
+
+static int
+ObjFilterSet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    int filterc;
+    Tcl_Obj **filterv;
+
+    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"filterList");
+	return TCL_ERROR;
+    } else if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    objv += Tcl_ObjectContextSkippedArgs(context);
+    if (Tcl_ListObjGetElements(interp, objv[0], &filterc,
+	    &filterv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    TclOOObjectSetFilters(oPtr, filterc, filterv);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectMixinGet, ObjectMixinSet --
+ *	Implementation of the "mixin" slot accessors of the "oo::objdefine"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjMixinGet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Tcl_Obj *resultObj;
+    Class *mixinPtr;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    } else if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    resultObj = Tcl_NewObj();
+    FOREACH(mixinPtr, oPtr->mixins) {
+	Tcl_ListObjAppendElement(NULL, resultObj,
+		TclOOObjectName(interp, mixinPtr->thisPtr));
+    }
+    Tcl_SetObjResult(interp, resultObj);
+    return TCL_OK;
+}
+
+static int
+ObjMixinSet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    int mixinc;
+    Tcl_Obj **mixinv;
+    Class **mixins;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"mixinList");
+	return TCL_ERROR;
+    } else if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    objv += Tcl_ObjectContextSkippedArgs(context);
+    if (Tcl_ListObjGetElements(interp, objv[0], &mixinc,
+	    &mixinv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    mixins = TclStackAlloc(interp, sizeof(Class *) * mixinc);
+
+    for (i=0 ; i<mixinc ; i++) {
+	mixins[i] = GetClassInOuterContext(interp, mixinv[i],
+		"may only mix in classes");
+	if (mixins[i] == NULL) {
+	    TclStackFree(interp, mixins);
+	    return TCL_ERROR;
+	}
+    }
+
+    TclOOObjectSetMixins(oPtr, mixinc, mixins);
+    TclStackFree(interp, mixins);
+    return TCL_OK;
+}
+
+/*
+ * ----------------------------------------------------------------------
+ *
+ * ObjectVarsGet, ObjectVarsSet --
+ *	Implementation of the "variable" slot accessors of the "oo::objdefine"
+ *	command.
+ *
+ * ----------------------------------------------------------------------
+ */
+
+static int
+ObjVarsGet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    Tcl_Obj *resultObj, *variableObj;
+    int i;
+
+    if (Tcl_ObjectContextSkippedArgs(context) != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		NULL);
+	return TCL_ERROR;
+    } else if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+
+    resultObj = Tcl_NewObj();
+    FOREACH(variableObj, oPtr->variables) {
+	Tcl_ListObjAppendElement(NULL, resultObj, variableObj);
+    }
+    Tcl_SetObjResult(interp, resultObj);
+    return TCL_OK;
+}
+
+static int
+ObjVarsSet(
+    ClientData clientData,
+    Tcl_Interp *interp,
+    Tcl_ObjectContext context,
+    int objc,
+    Tcl_Obj *const *objv)
+{
+    Object *oPtr = (Object *) TclOOGetDefineCmdContext(interp);
+    int varc, i;
+    Tcl_Obj **varv, *variableObj;
+
+    if (Tcl_ObjectContextSkippedArgs(context)+1 != objc) {
+	Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv,
+		"variableList");
+	return TCL_ERROR;
+    } else if (oPtr == NULL) {
+	return TCL_ERROR;
+    }
+    objv += Tcl_ObjectContextSkippedArgs(context);
+    if (Tcl_ListObjGetElements(interp, objv[0], &varc,
+	    &varv) != TCL_OK) {
+	return TCL_ERROR;
+    }
+
+    for (i=0 ; i<varc ; i++) {
+	const char *varName = Tcl_GetString(varv[i]);
+
+	if (strstr(varName, "::") != NULL) {
+	    Tcl_AppendResult(interp, "invalid declared variable name \"",
+		    varName, "\": must not contain namespace separators",
+		    NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+	    return TCL_ERROR;
+	}
+	if (Tcl_StringMatch(varName, "*(*)")) {
+	    Tcl_AppendResult(interp, "invalid declared variable name \"",
+		    varName, "\": must not refer to an array element", NULL);
+	    Tcl_SetErrorCode(interp, "TCL", "OO", "BAD_DECLVAR", NULL);
+	    return TCL_ERROR;
+	}
+    }
+    for (i=0 ; i<varc ; i++) {
+	Tcl_IncrRefCount(varv[i]);
+    }
+
+    FOREACH(variableObj, oPtr->variables) {
+	Tcl_DecrRefCount(variableObj);
+    }
+    if (i != varc) {
+	if (varc == 0) {
+	    ckfree((char *) oPtr->variables.list);
+	} else if (i) {
+	    oPtr->variables.list = (Tcl_Obj **)
+		    ckrealloc((char *) oPtr->variables.list,
+		    sizeof(Tcl_Obj *) * varc);
+	} else {
+	    oPtr->variables.list = (Tcl_Obj **)
+		    ckalloc(sizeof(Tcl_Obj *) * varc);
+	}
+    }
+    if (varc > 0) {
+	memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc);
+    }
+    oPtr->variables.num = varc;
+    return TCL_OK;
+}
+
+/*
  * Local Variables:
  * mode: c
  * c-basic-offset: 4
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index b151183..b9745ca 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -214,6 +214,8 @@ typedef struct Object {
 				 * class of classes, and should be treated
 				 * specially during teardown (and in a few
 				 * other spots). */
+#define FORCE_UNKNOWN 0x10000	/* States that we are *really* looking up the
+				 * unknown method handler at that point. */
 
 /*
  * And the definition of a class. Note that every class also has an associated
@@ -426,30 +428,18 @@ MODULE_SCOPE int	TclOODefineDestructorObjCmd(ClientData clientData,
 MODULE_SCOPE int	TclOODefineExportObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
-MODULE_SCOPE int	TclOODefineFilterObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOODefineForwardObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOODefineMethodObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
-MODULE_SCOPE int	TclOODefineMixinObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, const int objc,
-			    Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOODefineRenameMethodObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
-MODULE_SCOPE int	TclOODefineSuperclassObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOODefineUnexportObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
-MODULE_SCOPE int	TclOODefineVariablesObjCmd(ClientData clientData,
-			    Tcl_Interp *interp, int objc,
-			    Tcl_Obj *const *objv);
 MODULE_SCOPE int	TclOODefineClassObjCmd(ClientData clientData,
 			    Tcl_Interp *interp, int objc,
 			    Tcl_Obj *const *objv);
@@ -514,6 +504,7 @@ MODULE_SCOPE int	TclNRNewObjectInstance(Tcl_Interp *interp,
 			    const char *nsNameStr, int objc,
 			    Tcl_Obj *const *objv, int skip,
 			    Tcl_Object *objectPtr);
+MODULE_SCOPE int	TclOODefineSlots(Foundation *fPtr);
 MODULE_SCOPE void	TclOODeleteChain(CallChain *callPtr);
 MODULE_SCOPE void	TclOODeleteChainCache(Tcl_HashTable *tablePtr);
 MODULE_SCOPE void	TclOODeleteContext(CallContext *contextPtr);
diff --git a/tests/oo.test b/tests/oo.test
index 67535c9..a5c4cb0 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -131,6 +131,13 @@ test oo-1.4 {basic test of OO functionality} -body {
 test oo-1.5 {basic test of OO functionality} -body {
     oo::object doesnotexist
 } -returnCodes 1 -result {unknown method "doesnotexist": must be create, destroy or new}
+test oo-1.5.1 {basic test of OO functionality} -setup {
+    oo::object create aninstance
+} -returnCodes error -body {
+    aninstance
+} -cleanup {
+    rename aninstance {}
+} -result {wrong # args: should be "aninstance method ?arg ...?"}
 test oo-1.6 {basic test of OO functionality} -setup {
     oo::object create aninstance
 } -body {
@@ -2389,7 +2396,7 @@ test oo-22.1 {OO and info frame} -setup {
     list [i level] [i frames] [dict get [c frame] object]
 } -cleanup {
     c destroy
-} -result {1 {{type source line * file * cmd {info frame 0} method frames class ::c level 0} {type source line * file * cmd {info frame 0} method frames object ::i level 0}} ::c}
+} -result {1 {{* cmd {info frame 0} method frames class ::c level 0} {* cmd {info frame 0} method frames object ::i level 0}} ::c}
 test oo-22.2 {OO and info frame: Bug 3001438} -setup {
     oo::class create c
 } -body {
@@ -2460,6 +2467,16 @@ test oo-24.2 {unknown method method - Bug 1965063} -setup {
     }
     obj foo bar
 } -result {unknown method "foo": must be destroy, dummy, dummy2 or unknown}
+test oo-24.3 {unknown method method - absent method name} -setup {
+    set o [oo::object new]
+} -cleanup {
+    $o destroy
+} -body {
+    oo::objdefine $o method unknown args {
+	return "unknown: >>$args<<"
+    }
+    list [$o] [$o foobar] [$o foo bar]
+} -result {{unknown: >><<} {unknown: >>foobar<<} {unknown: >>foo bar<<}}
 
 # Probably need a better set of tests, but this is quite difficult to devise
 test oo-25.1 {call chain caching} -setup {
@@ -2751,6 +2768,87 @@ test oo-27.13 {variables declaration: Bug 3185009: require refcount management}
 } -cleanup {
     foo destroy
 } -result {0 7 1 7 {} 0 1 {can't read "x": no such variable}}
+test oo-27.14 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable x
+	variable y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.15 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable
+	variable x y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -result {1,1 2,2}
+test oo-27.16 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable x
+	variable -clear
+	variable y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.17 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable x
+	variable -set y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -result {1,1 1,2}
+test oo-27.18 {variables declaration - multiple use} -setup {
+    oo::class create master
+} -cleanup {
+    master destroy
+} -body {
+    oo::class create foo {
+	superclass master
+	variable x
+	variable -? y
+	method boo {} {
+	    return [incr x],[incr y]
+	}
+    }
+    foo create bar
+    list [bar boo] [bar boo]
+} -returnCodes error -match glob -result {unknown method "-?": must be *}
 
 # A feature that's not supported because the mechanism may change without
 # warning, but is supposed to work...
@@ -2832,6 +2930,148 @@ test oo-31.2 {Bug 3111059: when objects and coroutines entangle} -setup {
 } -cleanup {
     cls destroy
 } -result {0 {}}
+
+oo::class create SampleSlot {
+    superclass oo::Slot
+    constructor {} {
+	variable contents {a b c} ops {}
+    }
+    method contents {} {variable contents; return $contents}
+    method ops {} {variable ops; return $ops}
+    method Get {} {
+	variable contents
+	variable ops
+	lappend ops [info level] Get
+	return $contents
+    }
+    method Set {lst} {
+	variable contents $lst
+	variable ops
+	lappend ops [info level] Set $lst
+	return
+    }
+}
+
+test oo-32.1 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {a b c} {}}
+test oo-32.2 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot -clear] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {} {} {1 Set {}}}
+test oo-32.3 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot -append g h i] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {} {a b c g h i} {1 Get 1 Set {a b c g h i}}}
+test oo-32.4 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot -set d e f] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {} {d e f} {1 Set {d e f}}}
+test oo-32.5 {TIP 380: slots - class test} -setup {
+    SampleSlot create sampleSlot
+} -body {
+    list [info level] [sampleSlot -set d e f] [sampleSlot -append g h i] \
+	[sampleSlot contents] [sampleSlot ops]
+} -cleanup {
+    rename sampleSlot {}
+} -result {0 {} {} {d e f g h i} {1 Set {d e f} 1 Get 1 Set {d e f g h i}}}
+
+test oo-33.1 {TIP 380: slots - defaulting} -setup {
+    set s [SampleSlot new]
+} -body {
+    list [$s x y] [$s contents]
+} -cleanup {
+    rename $s {}
+} -result {{} {a b c x y}}
+test oo-33.2 {TIP 380: slots - defaulting} -setup {
+    set s [SampleSlot new]
+} -body {
+    list [$s destroy; $s unknown] [$s contents]
+} -cleanup {
+    rename $s {}
+} -result {{} {a b c destroy unknown}}
+test oo-32.3 {TIP 380: slots - defaulting} -setup {
+    set s [SampleSlot new]
+} -body {
+    oo::objdefine $s forward --default-operation  my -set
+    list [$s destroy; $s unknown] [$s contents] [$s ops]
+} -cleanup {
+    rename $s {}
+} -result {{} unknown {1 Set destroy 1 Set unknown}}
+test oo-33.4 {TIP 380: slots - errors} -setup {
+    set s [SampleSlot new]
+} -body {
+    # Method names beginning with "-" are special to slots
+    $s -grill q
+} -returnCodes error -cleanup {
+    rename $s {}
+} -result {unknown method "-grill": must be -append, -clear, -set, contents or ops}
+
+SampleSlot destroy
+
+test oo-34.1 {TIP 380: slots - presence} -setup {
+    set obj [oo::object new]
+    set result {}
+} -body {
+    oo::define oo::object {
+	::lappend ::result [::info object class filter]
+	::lappend ::result [::info object class mixin]
+	::lappend ::result [::info object class superclass]
+	::lappend ::result [::info object class variable]
+    }
+    oo::objdefine $obj {
+	::lappend ::result [::info object class filter]
+	::lappend ::result [::info object class mixin]
+	::lappend ::result [::info object class variable]
+    }
+    return $result
+} -cleanup {
+    $obj destroy
+} -result {::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot ::oo::Slot}
+test oo-34.2 {TIP 380: slots - presence} {
+    lsort [info class instances oo::Slot]
+} {::oo::define::filter ::oo::define::mixin ::oo::define::superclass ::oo::define::variable ::oo::objdefine::filter ::oo::objdefine::mixin ::oo::objdefine::variable}
+proc getMethods obj {
+    list [lsort [info object methods $obj -all]] \
+	[lsort [info object methods $obj -private]]
+}
+test oo-34.3 {TIP 380: slots - presence} {
+    getMethods oo::define::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.4 {TIP 380: slots - presence} {
+    getMethods oo::define::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.5 {TIP 380: slots - presence} {
+    getMethods oo::define::superclass
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.6 {TIP 380: slots - presence} {
+    getMethods oo::define::variable
+} {{-append -clear -set} {Get Set}}
+test oo-34.7 {TIP 380: slots - presence} {
+    getMethods oo::objdefine::filter
+} {{-append -clear -set} {Get Set}}
+test oo-34.8 {TIP 380: slots - presence} {
+    getMethods oo::objdefine::mixin
+} {{-append -clear -set} {--default-operation Get Set}}
+test oo-34.9 {TIP 380: slots - presence} {
+    getMethods oo::objdefine::variable
+} {{-append -clear -set} {Get Set}}
 
 cleanupTests
 return
-- 
cgit v0.12


From 543416450d89c9fdc7df13eea26715813d861a91 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 26 Mar 2012 13:11:58 +0000
Subject: Fix uninit variable (thanks to dgp for reporting)

---
 generic/tclOOCall.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclOOCall.c b/generic/tclOOCall.c
index 8b1aeb1..760bd7b 100644
--- a/generic/tclOOCall.c
+++ b/generic/tclOOCall.c
@@ -1005,7 +1005,7 @@ TclOOGetCallContext(
 		&cb, NULL, 0, NULL);
 	callPtr->flags |= OO_UNKNOWN_METHOD;
 	callPtr->epoch = -1;
-	if (count == callPtr->numChain) {
+	if (callPtr->numChain == 0) {
 	    TclOODeleteChain(callPtr);
 	    return NULL;
 	}
-- 
cgit v0.12


From 4d9e1c8453091e516efd3919546e5c88e768b53a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 27 Mar 2012 08:21:12 +0000
Subject: Implementation of TIP #397

---
 ChangeLog          |  13 +++++
 doc/copy.n         |  21 ++++++--
 doc/object.n       |  10 ++++
 generic/tclOO.c    | 150 ++++++++++++++++++++++++++++++++++++++++-------------
 generic/tclOOInt.h |   2 +
 tests/oo.test      |  57 ++++++++++++++++++--
 6 files changed, 209 insertions(+), 44 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 792af60..6fb55c5 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,16 @@
+2012-02-10  Donal K. Fellows  <dkf@users.sf.net>
+
+	IMPLEMENTATION OF TIP#397.
+
+	* generic/tclOO.c (Tcl_CopyObjectInstance): [Bug 3474460]: Make the
+	target object name optional when copying classes. [RFE 3485060]: Add
+	callback method ("<cloned>") so that scripted control over copying is
+	easier.
+	***POTENTIAL INCOMPATIBILITY***
+	If you'd previously been using the "<cloned>" method name, this now
+	has a standard semantics and call interface. Only a problem if you are
+	also using [oo::copy].
+
 2012-03-26  Donal K. Fellows  <dkf@users.sf.net>
 
 	IMPLEMENTATION OF TIP#380.
diff --git a/doc/copy.n b/doc/copy.n
index 51ec844..f5002f8 100644
--- a/doc/copy.n
+++ b/doc/copy.n
@@ -26,10 +26,23 @@ resolved relative to the current namespace if not an absolute qualified name.
 If \fItargetObject\fR is omitted, a new name is chosen. The copied object will
 be of the same class as the source object, and will have all its per-object
 methods copied. If it is a class, it will also have all the class methods in
-the class copied, but it will not have any of its instances copied. The
-contents of the source object's private namespace \fIwill not\fR be copied; it
-is up to the caller to do this. The result of this command will be the
-fully-qualified name of the new object or class.
+the class copied, but it will not have any of its instances copied.
+.PP
+.VS
+After the \fItargetObject\fR has been created and all definitions of its
+configuration (e.g., methods, filters, mixins) copied, the \fB<cloned>\fR
+method of \fItargetObject\fR will be invoked, to allow for customization of
+the created object such as installing related variable traces. The only
+argument given will be \fIsourceObject\fR. The default implementation of this
+method (in \fBoo::object\fR) just copies the procedures and variables in the
+namespace of \fIsourceObject\fR to the namespace of \fItargetObject\fR. If
+this method call does not return a result that is successful (i.e., an error
+or other kind of exception) then the \fItargetObject\fR will be deleted and an
+error returned.
+.VE
+.PP
+The result of the \fBoo::copy\fR command will be the fully-qualified name of
+the new object or class.
 .SH EXAMPLES
 .PP
 This example creates an object, copies it, modifies the source object, and
diff --git a/doc/object.n b/doc/object.n
index 3a948a4..6737e7e 100644
--- a/doc/object.n
+++ b/doc/object.n
@@ -91,6 +91,16 @@ must not have any namespace separators in it. The result is the empty string.
 .
 This method returns the globally qualified name of the variable \fIvarName\fR
 in the unique namespace for the object \fIobj\fR.
+.TP
+\fIobj \fB<cloned> \fIsourceObjectName\fR
+.VS
+This method is used by the \fBoo::object\fR command to copy the state of one
+object to another. It is responsible for copying the procedures and variables
+of the namespace of the source object (\fIsourceObjectName\fR) to the current
+object. It does not copy any other types of commands or any traces on the
+variables; that can be added if desired by overriding this method in a
+subclass.
+.VE
 .SH EXAMPLES
 .PP
 This example demonstrates basic use of an object.
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 6300d80..22a4d57 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -122,12 +122,33 @@ static const DeclaredClassMethod objMethods[] = {
     {NULL, 0, {0, NULL, NULL, NULL, NULL}}
 };
 
-static char initScript[] =
-    "package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
-    "namespace eval ::oo { variable version " TCLOO_VERSION " };"
-    "namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
-/*     "tcl_findLibrary tcloo $oo::version $oo::version" */
-/*     " tcloo.tcl OO_LIBRARY oo::library;"; */
+/*
+ * Scripted parts of TclOO. First, the master script (cannot be outside this
+ * file).
+ */
+
+static const char *initScript =
+"package ifneeded TclOO " TCLOO_PATCHLEVEL " {# Already present, OK?};"
+"namespace eval ::oo { variable version " TCLOO_VERSION " };"
+"namespace eval ::oo { variable patchlevel " TCLOO_PATCHLEVEL " };";
+/* "tcl_findLibrary tcloo $oo::version $oo::version" */
+/* " tcloo.tcl OO_LIBRARY oo::library;"; */
+
+/*
+ * The body of the constructor for oo::class.
+ */
+
+static const char *classConstructorBody =
+"set script [list ::oo::define [self] $definitionScript];"
+"lassign [::oo::UpCatch $script] msg opts;"
+"if {[dict get $opts -code] == 1} {"
+"    dict set opts -errorline 0xDeadBeef"
+"};"
+"return -options $opts $msg;";
+
+/*
+ * The scripted part of the definitions of slots.
+ */
 
 static const char *slotScript =
 "::oo::define ::oo::Slot {\n"
@@ -158,6 +179,38 @@ static const char *slotScript =
 "::oo::objdefine ::oo::define::mixin forward --default-operation my -set\n"
 "::oo::objdefine ::oo::objdefine::mixin forward --default-operation my -set\n";
 
+/*
+ * The body of the <cloned> method of oo::object.
+ */
+
+static const char *clonedBody =
+"foreach p [info procs [info object namespace $originObject]::*] {"
+"    set args [info args $p];"
+"    set idx -1;"
+"    foreach a $args {"
+"        lset args [incr idx] "
+"            [if {[info default $p $a d]} {list $a $d} {list $a}]"
+"    };"
+"    set b [info body $p];"
+"    set p [namespace tail $p];"
+"    proc $p $args $b;"
+"};"
+"foreach v [info vars [info object namespace $originObject]::*] {"
+"    upvar 0 $v vOrigin;"
+"    namespace upvar [namespace current] [namespace tail $v] vNew;"
+"    if {[info exists vOrigin]} {"
+"        if {[array exists vOrigin]} {"
+"            array set vNew [array get vOrigin];"
+"        } else {"
+"            set vNew $vOrigin;"
+"        }"
+"    }"
+"}";
+
+/*
+ * The actual definition of the variable holding the TclOO stub table.
+ */
+
 MODULE_SCOPE const TclOOStubs tclOOStubs;
 
 /*
@@ -168,15 +221,18 @@ MODULE_SCOPE const TclOOStubs tclOOStubs;
 	((Foundation *)((Interp *)(interp))->objectFoundation)
 
 /*
- * Macros to make inspecting into the guts of an object cleaner. Note that the
- * roots oo::object and oo::class have _both_ their object and class flags
- * tagged with ROOT_OBJECT and ROOT_CLASS respectively.
+ * Macros to make inspecting into the guts of an object cleaner.
+ *
+ * The ocPtr parameter (only in these macros) is assumed to work fine with
+ * either an oPtr or a classPtr. Note that the roots oo::object and oo::class
+ * have _both_ their object and class flags tagged with ROOT_OBJECT and
+ * ROOT_CLASS respectively.
  */
 
-#define Deleted(oPtr) (((Object *)(oPtr))->command == NULL)
-#define IsRootObject(ocPtr) ((ocPtr)->flags & ROOT_OBJECT)
-#define IsRootClass(ocPtr) ((ocPtr)->flags & ROOT_CLASS)
-#define IsRoot(ocPtr) ((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
+#define Deleted(oPtr)		(((Object *)(oPtr))->command == NULL)
+#define IsRootObject(ocPtr)	((ocPtr)->flags & ROOT_OBJECT)
+#define IsRootClass(ocPtr)	((ocPtr)->flags & ROOT_CLASS)
+#define IsRoot(ocPtr)		((ocPtr)->flags & (ROOT_OBJECT|ROOT_CLASS))
 
 /*
  * ----------------------------------------------------------------------
@@ -280,17 +336,19 @@ InitFoundation(
 	    DeletedHelpersNamespace);
     fPtr->epoch = 0;
     fPtr->tsdPtr = tsdPtr;
-    fPtr->unknownMethodNameObj = Tcl_NewStringObj("unknown", -1);
-    fPtr->constructorName = Tcl_NewStringObj("<constructor>", -1);
-    fPtr->destructorName = Tcl_NewStringObj("<destructor>", -1);
+    TclNewLiteralStringObj(fPtr->unknownMethodNameObj, "unknown");
+    TclNewLiteralStringObj(fPtr->constructorName, "<constructor>");
+    TclNewLiteralStringObj(fPtr->destructorName, "<destructor>");
+    TclNewLiteralStringObj(fPtr->clonedName, "<cloned>");
     Tcl_IncrRefCount(fPtr->unknownMethodNameObj);
     Tcl_IncrRefCount(fPtr->constructorName);
     Tcl_IncrRefCount(fPtr->destructorName);
+    Tcl_IncrRefCount(fPtr->clonedName);
     Tcl_NRCreateCommand(interp, "::oo::UpCatch", TclOOUpcatchCmd,
 	    TclOONRUpcatch, NULL, NULL);
     Tcl_CreateObjCommand(interp, "::oo::UnknownDefinition",
 	    TclOOUnknownDefinition, NULL, NULL);
-    namePtr = Tcl_NewStringObj("::oo::UnknownDefinition", -1);
+    TclNewLiteralStringObj(namePtr, "::oo::UnknownDefinition");
     Tcl_SetNamespaceUnknownHandler(interp, fPtr->defineNs, namePtr);
     Tcl_SetNamespaceUnknownHandler(interp, fPtr->objdefNs, namePtr);
 
@@ -351,6 +409,18 @@ InitFoundation(
     }
 
     /*
+     * Create the default <cloned> method implementation, used when 'oo::copy'
+     * is called to finish the copying of one object to another.
+     */
+
+    TclNewLiteralStringObj(argsPtr, "originObject");
+    Tcl_IncrRefCount(argsPtr);
+    bodyPtr = Tcl_NewStringObj(clonedBody, -1);
+    TclOONewProcMethod(interp, fPtr->objectCls, 0, fPtr->clonedName, argsPtr,
+	    bodyPtr, NULL);
+    Tcl_DecrRefCount(argsPtr);
+
+    /*
      * Finish setting up the class of classes by marking the 'new' method as
      * private; classes, unlike general objects, must have explicit names. We
      * also need to create the constructor for classes.
@@ -360,19 +430,13 @@ InitFoundation(
      * that is confusing.
      */
 
-    namePtr = Tcl_NewStringObj("new", -1);
+    TclNewLiteralStringObj(namePtr, "new");
     Tcl_NewInstanceMethod(interp, (Tcl_Object) fPtr->classCls->thisPtr,
 	    namePtr /* keeps ref */, 0 /* ==private */, NULL, NULL);
 
-    argsPtr = Tcl_NewStringObj("{definitionScript {}}", -1);
+    TclNewLiteralStringObj(argsPtr, "{definitionScript {}}");
     Tcl_IncrRefCount(argsPtr);
-    bodyPtr = Tcl_NewStringObj(
-	    "set script [list ::oo::define [self] $definitionScript];"
-	    "lassign [::oo::UpCatch $script] msg opts\n"
-	    "if {[dict get $opts -code] == 1} {"
-	    "    dict set opts -errorline 0xDeadBeef\n"
-	    "}\n"
-	    "return -options $opts $msg", -1);
+    bodyPtr = Tcl_NewStringObj(classConstructorBody, -1);
     fPtr->classCls->constructorPtr = TclOONewProcMethod(interp,
 	    fPtr->classCls, 0, NULL, argsPtr, bodyPtr, NULL);
     Tcl_DecrRefCount(argsPtr);
@@ -468,6 +532,7 @@ KillFoundation(
     Tcl_DecrRefCount(fPtr->unknownMethodNameObj);
     Tcl_DecrRefCount(fPtr->constructorName);
     Tcl_DecrRefCount(fPtr->destructorName);
+    Tcl_DecrRefCount(fPtr->clonedName);
     ckfree(fPtr);
 }
 
@@ -1755,19 +1820,14 @@ Tcl_CopyObjectInstance(
     FOREACH_HASH_DECLS;
     Method *mPtr;
     Class *mixinPtr;
-    Tcl_Obj *keyPtr, *filterObj, *variableObj;
-    int i;
+    CallContext *contextPtr;
+    Tcl_Obj *keyPtr, *filterObj, *variableObj, *args[3];
+    int i, result;
 
     /*
-     * Sanity checks.
+     * Sanity check.
      */
 
-    if (targetName == NULL && oPtr->classPtr != NULL) {
-	Tcl_AppendResult(interp, "must supply a name when copying a class",
-		NULL);
-	Tcl_SetErrorCode(interp, "TCL", "OO", "NO_COPY_TARGET", NULL);
-	return NULL;
-    }
     if (IsRootClass(oPtr)) {
 	Tcl_AppendResult(interp, "may not clone the class of classes", NULL);
 	Tcl_SetErrorCode(interp, "TCL", "OO", "CLONING_CLASS", NULL);
@@ -1991,6 +2051,26 @@ Tcl_CopyObjectInstance(
 	}
     }
 
+    contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
+    if (contextPtr) {
+	args[0] = TclOOObjectName(interp, o2Ptr);
+	args[1] = oPtr->fPtr->clonedName;
+	args[2] = TclOOObjectName(interp, oPtr);
+	Tcl_IncrRefCount(args[0]);
+	Tcl_IncrRefCount(args[1]);
+	Tcl_IncrRefCount(args[2]);
+	result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr, 3,
+		args);
+	TclDecrRefCount(args[0]);
+	TclDecrRefCount(args[1]);
+	TclDecrRefCount(args[2]);
+	TclOODeleteContext(contextPtr);
+	if (result != TCL_OK) {
+	    Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
+	    return NULL;
+	}
+    }
+
     return (Tcl_Object) o2Ptr;
 }
 
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index b9745ca..2d6f324 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -320,6 +320,8 @@ typedef struct Foundation {
 				 * constructor. */
     Tcl_Obj *destructorName;	/* Shared object containing the "name" of a
 				 * destructor. */
+    Tcl_Obj *clonedName;	/* Shared object containing the name of a
+				 * "<cloned>" pseudo-constructor. */
 } Foundation;
 
 /*
diff --git a/tests/oo.test b/tests/oo.test
index a5c4cb0..150bc97 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -1679,6 +1679,53 @@ test oo-15.5 {OO: class cloning - Bug 3474460} -setup {
 } -cleanup {
     ArbitraryClass destroy
 } -result {a b c}
+test oo-15.6 {OO: object cloning copies namespace contents} -setup {
+    oo::class create ArbitraryClass {export eval}
+} -body {
+    ArbitraryClass create a
+    a eval {proc foo x {
+	variable y
+	return [string repeat $x [incr y]]
+    }}
+    set result [list [a eval {foo 2}] [a eval {foo 3}]]
+    oo::copy a b
+    a eval {rename foo bar}
+    lappend result [b eval {foo 2}] [b eval {foo 3}] [a eval {bar 4}]
+} -cleanup {
+    ArbitraryClass destroy
+} -result {2 33 222 3333 444}
+test oo-15.7 {OO: classes can be cloned anonymously} -setup {
+    oo::class create ArbitraryClassA
+    oo::class create ArbitraryClassB {superclass ArbitraryClassA}
+} -body {
+    info object isa class [oo::copy ArbitraryClassB]
+} -cleanup {
+    ArbitraryClassA destroy
+} -result 1
+test oo-15.8 {OO: intercept object cloning} -setup {
+    oo::class create Foo
+    set result {}
+} -body {
+    oo::define Foo {
+	constructor {msg} {
+	    variable v $msg
+	}
+	method <cloned> {from} {
+	    next $from
+	    lappend ::result cloned $from [self]
+	}
+	method check {} {
+	    variable v
+	    lappend ::result check [self] $v
+	}
+    }
+    Foo create foo ok
+    oo::copy foo bar
+    foo check
+    bar check
+} -cleanup {
+    Foo destroy
+} -result {cloned ::foo ::bar check ::foo ok check ::bar ok}
 
 test oo-16.1 {OO: object introspection} -body {
     info object
@@ -1774,10 +1821,10 @@ test oo-16.11 {OO: object introspection} -setup {
 } -body {
     oo::define foo method spong {} {...}
     oo::objdefine bar method boo {a {b c} args} {the body}
-    list [info object methods bar -all] [info object methods bar -all -private]
+    list [lsort [info object methods bar -all]] [lsort [info object methods bar -all -private]]
 } -cleanup {
     foo destroy
-} -result {{boo destroy spong} {boo destroy eval spong unknown variable varname}}
+} -result {{boo destroy spong} {<cloned> boo destroy eval spong unknown variable varname}}
 test oo-16.12 {OO: object introspection} -setup {
     oo::object create foo
 } -cleanup {
@@ -1858,11 +1905,11 @@ test oo-17.9 {OO: class introspection} -setup {
 	}
     }
     oo::define subfoo method boo {a {b c} args} {the body}
-    list [info class methods subfoo -all] \
-	[info class methods subfoo -all -private]
+    list [lsort [info class methods subfoo -all]] \
+	[lsort [info class methods subfoo -all -private]]
 } -cleanup {
     foo destroy
-} -result {{bar boo destroy} {bar boo destroy eval unknown variable varname}}
+} -result {{bar boo destroy} {<cloned> bar boo destroy eval unknown variable varname}}
 test oo-17.10 {OO: class introspection} -setup {
     oo::class create foo
 } -cleanup {
-- 
cgit v0.12


From 706ba6af5218493763fbf25a29f5364a84c0719c Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 27 Mar 2012 12:26:49 +0000
Subject: Implementation of TIP #395

---
 ChangeLog          | 13 +++++++--
 doc/string.n       |  6 ++++
 generic/tclCmdMZ.c | 28 ++++++++++++-------
 tests/string.test  | 82 ++++++++++++++++++++++++++++++++++++++++++++++++++----
 4 files changed, 111 insertions(+), 18 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index e2baaa5..8dd5e8f 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,15 @@
+2012-03-27  Donal K. Fellows  <dkf@users.sf.net>
+
+	IMPLEMENTATION OF TIP#395.
+
+	* generic/tclCmdMZ.c (StringIsCmd): Implementation of the [string is
+	entier] check. Code by Jos Decoster.
+
 2012-03-27  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tcl.h:             [Bug 3508771] Wrong Tcl_StatBuf used on MinGW
-	* generic/tclFCmd.c:         [Bug 2015723] duplicate inodes from file stat on
-	* generic/tclCmdAH.c:        windows (but now for cygwin as well)
+	* generic/tcl.h:      [Bug 3508771]: Wrong Tcl_StatBuf used on MinGW.
+	* generic/tclFCmd.c:  [Bug 2015723]: Duplicate inodes from file stat
+	* generic/tclCmdAH.c: on windows (but now for cygwin as well).
 	* generic/tclOODefineCmds.c: minor gcc warning
 
 2012-03-27  Donal K. Fellows  <dkf@users.sf.net>
diff --git a/doc/string.n b/doc/string.n
index d960b71..1cbea16 100644
--- a/doc/string.n
+++ b/doc/string.n
@@ -121,6 +121,12 @@ outside of the [0\-9] range.
 Any of the valid forms for a double in Tcl, with optional surrounding
 whitespace.  In case of under/overflow in the value, 0 is returned and
 the \fIvarname\fR will contain \-1.
+.IP \fBentier\fR 12
+.VS 8.6
+Any of the valid string formats for an integer value of arbitrary size
+in Tcl, with optional surrounding whitespace. The formats accepted are
+exactly those accepted by the C routine \fBTcl_GetBignumFromObj\fR.
+.VE
 .IP \fBfalse\fR 12
 Any of the forms allowed to \fBTcl_GetBoolean\fR where the value is
 false.
diff --git a/generic/tclCmdMZ.c b/generic/tclCmdMZ.c
index 1ef6fa8..ff300b0 100644
--- a/generic/tclCmdMZ.c
+++ b/generic/tclCmdMZ.c
@@ -18,6 +18,7 @@
 
 #include "tclInt.h"
 #include "tclRegexp.h"
+#include "tommath.h"
 
 static inline Tcl_Obj *	During(Tcl_Interp *interp, int resultCode,
 			    Tcl_Obj *oldOptions, Tcl_Obj *errorInfo);
@@ -1433,21 +1434,23 @@ StringIsCmd(
     int i, failat = 0, result = 1, strict = 0, index, length1, length2;
     Tcl_Obj *objPtr, *failVarObj = NULL;
     Tcl_WideInt w;
+    mp_int big;
 
     static const char *const isClasses[] = {
 	"alnum",	"alpha",	"ascii",	"control",
-	"boolean",	"digit",	"double",	"false",
-	"graph",	"integer",	"list",		"lower",
-	"print",	"punct",	"space",	"true",
-	"upper",	"wideinteger",	"wordchar",	"xdigit",
-	NULL
+	"boolean",	"digit",	"double",	"entier",
+	"false",	"graph",	"integer",	"list",
+	"lower",	"print",	"punct",	"space",
+	"true",		"upper",	"wideinteger",	"wordchar",
+	"xdigit",	NULL
     };
     enum isClasses {
-	STR_IS_ALNUM, STR_IS_ALPHA,	STR_IS_ASCII,  STR_IS_CONTROL,
-	STR_IS_BOOL,  STR_IS_DIGIT,	STR_IS_DOUBLE, STR_IS_FALSE,
-	STR_IS_GRAPH, STR_IS_INT,	STR_IS_LIST,   STR_IS_LOWER,
-	STR_IS_PRINT, STR_IS_PUNCT, STR_IS_SPACE,  STR_IS_TRUE,
-	STR_IS_UPPER, STR_IS_WIDE,	STR_IS_WORD,   STR_IS_XDIGIT
+	STR_IS_ALNUM,	STR_IS_ALPHA,	STR_IS_ASCII,	STR_IS_CONTROL,
+	STR_IS_BOOL,	STR_IS_DIGIT,	STR_IS_DOUBLE,	STR_IS_ENTIER,
+	STR_IS_FALSE,	STR_IS_GRAPH,	STR_IS_INT,	STR_IS_LIST,
+	STR_IS_LOWER,	STR_IS_PRINT,	STR_IS_PUNCT,	STR_IS_SPACE,
+	STR_IS_TRUE,	STR_IS_UPPER,	STR_IS_WIDE,	STR_IS_WORD,
+	STR_IS_XDIGIT
     };
     static const char *const isOptions[] = {
 	"-strict", "-failindex", NULL
@@ -1575,6 +1578,11 @@ StringIsCmd(
 	    break;
 	}
 	goto failedIntParse;
+    case STR_IS_ENTIER:
+	if (TCL_OK == Tcl_GetBignumFromObj(NULL, objPtr, &big)) {
+	    break;
+	}
+	goto failedIntParse;
     case STR_IS_WIDE:
 	if (TCL_OK == Tcl_GetWideIntFromObj(NULL, objPtr, &w)) {
 	    break;
diff --git a/tests/string.test b/tests/string.test
index 85a7372..b3326ae 100644
--- a/tests/string.test
+++ b/tests/string.test
@@ -312,10 +312,10 @@ test string-6.4 {string is, too many args} {
 } {1 {wrong # args: should be "string is class ?-strict? ?-failindex var? str"}}
 test string-6.5 {string is, class check} {
     list [catch {string is bogus str} msg] $msg
-} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {bad class "bogus": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
 test string-6.6 {string is, ambiguous class} {
     list [catch {string is al str} msg] $msg
-} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
+} {1 {ambiguous class "al": must be alnum, alpha, ascii, control, boolean, digit, double, entier, false, graph, integer, list, lower, print, punct, space, true, upper, wideinteger, wordchar, or xdigit}}
 test string-6.7 {string is alpha, all ok} {
     string is alpha -strict -failindex var abc
 } 1
@@ -592,7 +592,7 @@ test string-6.90 {string is integer, bad integers} {
     foreach num $numbers {
 	lappend result [string is int -strict $num]
     }
-    set result
+    return $result
 } {1 1 0 0 0 1 0 0}
 test string-6.91 {string is double, bad doubles} {
     set result ""
@@ -600,7 +600,7 @@ test string-6.91 {string is double, bad doubles} {
     foreach num $numbers {
 	lappend result [string is double -strict $num]
     }
-    set result
+    return $result
 } {1 1 0 0 0 1 0 0}
 test string-6.92 {string is integer, 32-bit overflow} {
     # Bug 718878
@@ -664,7 +664,7 @@ test string-6.107 {string is integer, bad integers} {
     foreach num $numbers {
 	lappend result [string is wideinteger -strict $num]
     }
-    set result
+    return $result
 } {1 1 0 0 0 1 0 0}
 test string-6.108 {string is double, Bug 1382287} {
     set x 2turtledoves
@@ -674,6 +674,78 @@ test string-6.108 {string is double, Bug 1382287} {
 test string-6.109 {string is double, Bug 1360532} {
     string is double 1\u00a0
 } 0
+test string-6.110 {string is entier, true} {
+    string is entier +1234567890
+} 1
+test string-6.111 {string is entier, true on type} {
+    string is entier [expr wide(50.0)]
+} 1
+test string-6.112 {string is entier, true} {
+    string is entier [list -10]
+} 1
+test string-6.113 {string is entier, true as hex} {
+    string is entier 0xabcdef
+} 1
+test string-6.114 {string is entier, true as octal} {
+    string is entier 0123456
+} 1
+test string-6.115 {string is entier, true with whitespace} {
+    string is entier "  \n1234\v"
+} 1
+test string-6.116 {string is entier, false} {
+    list [string is entier -fail var 123abc] $var
+} {0 3}
+test string-6.117 {string is entier, false} {
+    list [string is entier -fail var 123123123123123123123123123123123123123123123123123123123123123123123123123123123123abc] $var
+} {0 84}
+test string-6.118 {string is entier, false} {
+    list [string is entier -fail var [expr double(1)]] $var
+} {0 1}
+test string-6.119 {string is entier, false} {
+    list [string is entier -fail var "    "] $var
+} {0 0}
+test string-6.120 {string is entier, false on bad octal} {
+    list [string is entier -fail var 0o36963] $var
+} {0 4}
+test string-6.121.1 {string is entier, false on bad octal} {
+    list [string is entier -fail var 0o36963] $var
+} {0 4}
+test string-6.122 {string is entier, false on bad hex} {
+    list [string is entier -fail var 0X345XYZ] $var
+} {0 5}
+test string-6.123 {string is entier, bad integers} {
+    # SF bug #634856
+    set result ""
+    set numbers [list 1 +1 ++1 +-1 -+1 -1 --1 "- +1"]
+    foreach num $numbers {
+	lappend result [string is entier -strict $num]
+    }
+    return $result
+} {1 1 0 0 0 1 0 0}
+test string-6.124 {string is entier, true} {
+    string is entier +1234567890123456789012345678901234567890
+} 1
+test string-6.125 {string is entier, true} {
+    string is entier [list -10000000000000000000000000000000000000000000000000000000000000000000000000000000000000]
+} 1
+test string-6.126 {string is entier, true as hex} {
+    string is entier 0xabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdefabcdef
+} 1
+test string-6.127 {string is entier, true as octal} {
+    string is entier 0123456112341234561234565623456123456123456123456123456123456123456123456123456123456
+} 1
+test string-6.128 {string is entier, true with whitespace} {
+    string is entier "  \n12340000000000000000000000000000000000000000000000000000000000000000000000000000000000000\v"
+} 1
+test string-6.129 {string is entier, false on bad octal} {
+    list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+} {0 87}
+test string-6.130.1 {string is entier, false on bad octal} {
+    list [string is entier -fail var 0o1234561123412345612345656234561234561234561234561234561234561234561234561234561234536963] $var
+} {0 87}
+test string-6.131 {string is entier, false on bad hex} {
+    list [string is entier -fail var 0X12345611234123456123456562345612345612345612345612345612345612345612345612345612345345XYZ] $var
+} {0 88}
 
 catch {rename largest_int {}}
 
-- 
cgit v0.12


From 346f5718f86090683709671a6028aa962edf6e54 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 27 Mar 2012 12:36:28 +0000
Subject: gcc warning: unused but set variable

---
 generic/tclOO.c | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/generic/tclOO.c b/generic/tclOO.c
index 22a4d57..9dd8162 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1618,7 +1618,7 @@ Tcl_NewObjectInstance(
 		TclOOGetCallContext(oPtr, NULL, CONSTRUCTOR, NULL);
 
 	if (contextPtr != NULL) {
-	    int result, flags;
+	    int result;
 	    Tcl_InterpState state;
 
 	    state = Tcl_SaveInterpState(interp, TCL_OK);
@@ -1626,7 +1626,6 @@ Tcl_NewObjectInstance(
 	    contextPtr->skip = skip;
 	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
 		    objc, objv);
-	    flags = oPtr->flags;
 
 	    /*
 	     * It's an error if the object was whacked in the constructor.
-- 
cgit v0.12


From 1251bcbcc6272da5c31c077c03ce238cfde19844 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 27 Mar 2012 14:26:16 +0000
Subject: se lower numbers, preventing integer overflow in tclWinError.c

---
 ChangeLog        |  2 ++
 win/tclWinPort.h | 42 +++++++++++++++++++++++++-----------------
 2 files changed, 27 insertions(+), 17 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 8dd5e8f..5c25427 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -11,6 +11,8 @@
 	* generic/tclFCmd.c:  [Bug 2015723]: Duplicate inodes from file stat
 	* generic/tclCmdAH.c: on windows (but now for cygwin as well).
 	* generic/tclOODefineCmds.c: minor gcc warning
+	* win/tclWinPort.h:   Use lower numbers, preventing integer overflow.
+	  (and remove the workaround for mingw-w64 bug 3407992. It's long fixed)
 
 2012-03-27  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/win/tclWinPort.h b/win/tclWinPort.h
index e3c5a49..db46a4a 100644
--- a/win/tclWinPort.h
+++ b/win/tclWinPort.h
@@ -226,9 +226,9 @@ typedef DWORD_PTR * PDWORD_PTR;
 #ifndef EOTHER
 #   define EOTHER	131	/* Other error */
 #endif
-/* workaround for mingw-w64 bug 3407992 */
-#undef EOVERFLOW
-#define EOVERFLOW	132	/* File too big */
+#ifndef EOVERFLOW
+#   define EOVERFLOW	132	/* File too big */
+#endif
 #ifndef EOWNERDEAD
 #   define EOWNERDEAD	133	/* Owner dead */
 #endif
@@ -255,20 +255,28 @@ typedef DWORD_PTR * PDWORD_PTR;
 #endif
 
 
-#undef ESOCKTNOSUPPORT
-#define ESOCKTNOSUPPORT WSAESOCKTNOSUPPORT	/* Socket type not supported */
-#undef ESHUTDOWN
-#define ESHUTDOWN	WSAESHUTDOWN	/* Can't send after socket shutdown */
-#undef ETOOMANYREFS
-#define ETOOMANYREFS	WSAETOOMANYREFS	/* Too many references: can't splice */
-#undef EHOSTDOWN
-#define EHOSTDOWN	WSAEHOSTDOWN	/* Host is down */
-#undef EUSERS
-#define EUSERS	WSAEUSERS	/* Too many users (for UFS) */
-#undef EDQUOT
-#define EDQUOT	WSAEDQUOT	/* Disc quota exceeded */
-#undef ESTALE
-#define ESTALE	WSAESTALE	/* Stale NFS file handle */
+/* Visual Studio doesn't have these, so just choose some high numbers */
+#ifndef ESOCKTNOSUPPORT
+#   define ESOCKTNOSUPPORT 240	/* Socket type not supported */
+#endif
+#ifndef ESHUTDOWN
+#   define ESHUTDOWN	241	/* Can't send after socket shutdown */
+#endif
+#ifndef ETOOMANYREFS
+#   define ETOOMANYREFS	242	/* Too many references: can't splice */
+#endif
+#ifndef EHOSTDOWN
+#   define EHOSTDOWN	243	/* Host is down */
+#endif
+#ifndef EUSERS
+#   define EUSERS	244	/* Too many users (for UFS) */
+#endif
+#ifndef EDQUOT
+#   define EDQUOT	245	/* Disc quota exceeded */
+#endif
+#ifndef ESTALE
+#   define ESTALE	246	/* Stale NFS file handle */
+#endif
 
 /*
  * Signals not known to the standard ANSI signal.h.  These are used
-- 
cgit v0.12


From 3c562ea4258e410e880449ac6b65936c62d0cc48 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 29 Mar 2012 09:24:33 +0000
Subject: Fix minor typos in ChangeLog messages.

---
 ChangeLog | 12 ++++++------
 1 file changed, 6 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 67e22f1..37c33cb 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,8 +1,8 @@
 2012-03-29  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclCmdMZ.c (StringIsCmd): Faster mem-leak free
-	implementation of [string is entier]
- 
+	implementation of [string is entier].
+
 2012-03-27  Donal K. Fellows  <dkf@users.sf.net>
 
 	IMPLEMENTATION OF TIP#395.
@@ -17,7 +17,7 @@
 	* generic/tclCmdAH.c: on windows (but now for cygwin as well).
 	* generic/tclOODefineCmds.c: minor gcc warning
 	* win/tclWinPort.h:   Use lower numbers, preventing integer overflow.
-	  (and remove the workaround for mingw-w64 bug 3407992. It's long fixed)
+	Remove the workaround for mingw-w64 [bug 3407992]. It's long fixed.
 
 2012-03-27  Donal K. Fellows  <dkf@users.sf.net>
 
@@ -182,7 +182,7 @@
 
 2012-02-23  Donal K. Fellows  <dkf@users.sf.net>
 
-	* tests/reg.test (14.21-23): Add tests relating to bug 1115587. Actual
+	* tests/reg.test (14.21-23): Add tests relating to Bug 1115587. Actual
 	bug is characterised by test marked with 'knownBug'.
 
 2012-02-17  Jan Nijtmans  <nijtmans@users.sf.net>
@@ -391,8 +391,8 @@
 
 2011-11-22  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinPort.h:   [Bug 2935503]: Windows: file mtime
-	* win/tclWinFile.c:  sets wrong time (VS2005+ only)
+	* win/tclWinPort.h: [Bug 2935503]: Windows: [file mtime] sets wrong
+	* win/tclWinFile.c: time (VS2005+ only).
 	* generic/tclTest.c:
 
 2011-11-20  Joe Mistachkin  <joe@mistachkin.com>
-- 
cgit v0.12


From a7b498a633acce4600fc86e73c858c6a571e6ac8 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Sun, 1 Apr 2012 18:35:33 +0000
Subject: re-generate configure

---
 unix/configure |  138 +++++-
 win/configure  | 1314 +++++++++++++++++++++++++-------------------------------
 2 files changed, 713 insertions(+), 739 deletions(-)

diff --git a/unix/configure b/unix/configure
index 66ef3b6..4a6466d 100755
--- a/unix/configure
+++ b/unix/configure
@@ -6927,7 +6927,7 @@ fi
 	    CC_SEARCH_FLAGS=""
 	    LD_SEARCH_FLAGS=""
 	    ;;
-	CYGWIN_*)
+	CYGWIN_*|MINGW32*)
 	    SHLIB_CFLAGS=""
 	    SHLIB_LD='${CC} -shared'
 	    SHLIB_SUFFIX=".dll"
@@ -6938,6 +6938,69 @@ fi
 	    TCL_NEEDS_EXP_FILE=1
 	    TCL_EXPORT_FILE_SUFFIX='${VERSION}\$\{DBGX\}.dll.a'
 	    TCL_SHLIB_LD_EXTRAS='-Wl,--out-implib,$@.a'
+	    echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5
+echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6
+if test "${ac_cv_cygwin+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+		#ifdef __CYGWIN__
+		    #error cygwin
+		#endif
+
+int
+main ()
+{
+
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  ac_cv_cygwin=no
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ac_cv_cygwin=yes
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5
+echo "${ECHO_T}$ac_cv_cygwin" >&6
+	    if test "$ac_cv_cygwin" = "no"; then
+		{ { echo "$as_me:$LINENO: error: ${CC} is not a cygwin compiler." >&5
+echo "$as_me: error: ${CC} is not a cygwin compiler." >&2;}
+   { (exit 1); exit 1; }; }
+	    fi
 	    ;;
 	dgux*)
 	    SHLIB_CFLAGS="-K PIC"
@@ -8878,7 +8941,7 @@ fi
 	case $system in
 	    AIX-*) ;;
 	    BSD/OS*) ;;
-	    CYGWIN_*) ;;
+	    CYGWIN_*|MINGW32_*) ;;
 	    IRIX*) ;;
 	    NetBSD-*|FreeBSD-*|OpenBSD-*) ;;
 	    Darwin-*) ;;
@@ -8949,6 +9012,75 @@ fi
 
 
 
+	# See if the compiler supports casting to a union type.
+	# This is used to stop gcc from printing a compiler
+	# warning when initializing a union member.
+
+	echo "$as_me:$LINENO: checking for cast to union support" >&5
+echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6
+if test "${tcl_cv_cast_to_union+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+int
+main ()
+{
+
+		  union foo { int i; double d; };
+		  union foo f = (union foo) (int) 0;
+
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  tcl_cv_cast_to_union=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+tcl_cv_cast_to_union=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
+echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
+	if test "$tcl_cv_cast_to_union" = "yes"; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_CAST_TO_UNION 1
+_ACEOF
+
+	fi
+
     # FIXME: This subst was left in only because the TCL_DL_LIBS
     # entry in tclConfig.sh uses it. It is not clear why someone
     # would use TCL_DL_LIBS instead of TCL_LIBS.
@@ -13730,6 +13862,7 @@ _ACEOF
 #	lack blkcnt_t.
 #--------------------------------------------------------------------
 
+if test "$ac_cv_cygwin" != "yes"; then
 echo "$as_me:$LINENO: checking for struct stat.st_blocks" >&5
 echo $ECHO_N "checking for struct stat.st_blocks... $ECHO_C" >&6
 if test "${ac_cv_member_struct_stat_st_blocks+set}" = set; then
@@ -13949,6 +14082,7 @@ _ACEOF
 
 fi
 
+fi
 echo "$as_me:$LINENO: checking for blkcnt_t" >&5
 echo $ECHO_N "checking for blkcnt_t... $ECHO_C" >&6
 if test "${ac_cv_type_blkcnt_t+set}" = set; then
diff --git a/win/configure b/win/configure
index 07a9436..4d837b0 100755
--- a/win/configure
+++ b/win/configure
@@ -3041,660 +3041,6 @@ fi
 
 
 #--------------------------------------------------------------------
-# Perform additinal compiler tests.
-#--------------------------------------------------------------------
-
-
-echo "$as_me:$LINENO: checking for Cygwin version of gcc" >&5
-echo $ECHO_N "checking for Cygwin version of gcc... $ECHO_C" >&6
-if test "${ac_cv_cygwin+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-#ifdef __CYGWIN__
-#error cygwin
-#endif
-
-int
-main ()
-{
-
-  ;
-  return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
-  (eval $ac_compile) 2>conftest.er1
-  ac_status=$?
-  grep -v '^ *+' conftest.er1 >conftest.err
-  rm -f conftest.er1
-  cat conftest.err >&5
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } &&
-	 { ac_try='test -z "$ac_c_werror_flag"
-			 || test ! -s conftest.err'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; } &&
-	 { ac_try='test -s conftest.$ac_objext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  ac_cv_cygwin=no
-else
-  echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-ac_cv_cygwin=yes
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-fi
-echo "$as_me:$LINENO: result: $ac_cv_cygwin" >&5
-echo "${ECHO_T}$ac_cv_cygwin" >&6
-if test "$ac_cv_cygwin" = "yes" ; then
-    { { echo "$as_me:$LINENO: error: Compiling under Cygwin is not currently supported.
-A maintainer for the Cygwin port of Tcl/Tk is needed. See the README
-file for information about building with Mingw." >&5
-echo "$as_me: error: Compiling under Cygwin is not currently supported.
-A maintainer for the Cygwin port of Tcl/Tk is needed. See the README
-file for information about building with Mingw." >&2;}
-   { (exit 1); exit 1; }; }
-fi
-
-
-echo "$as_me:$LINENO: checking for SEH support in compiler" >&5
-echo $ECHO_N "checking for SEH support in compiler... $ECHO_C" >&6
-if test "${tcl_cv_seh+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  if test "$cross_compiling" = yes; then
-  tcl_cv_seh=no
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-
-int main(int argc, char** argv) {
-    int a, b = 0;
-    __try {
-        a = 666 / b;
-    }
-    __except (EXCEPTION_EXECUTE_HANDLER) {
-        return 0;
-    }
-    return 1;
-}
-
-_ACEOF
-rm -f conftest$ac_exeext
-if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
-  (eval $ac_link) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  tcl_cv_seh=yes
-else
-  echo "$as_me: program exited with status $ac_status" >&5
-echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-( exit $ac_status )
-tcl_cv_seh=no
-fi
-rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
-fi
-
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_seh" >&5
-echo "${ECHO_T}$tcl_cv_seh" >&6
-if test "$tcl_cv_seh" = "no" ; then
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_SEH 1
-_ACEOF
-
-fi
-
-#
-# Check to see if the excpt.h include file provided contains the
-# definition for EXCEPTION_DISPOSITION; if not, which is the case
-# with Cygwin's version as of 2002-04-10, define it to be int,
-# sufficient for getting the current code to work.
-#
-echo "$as_me:$LINENO: checking for EXCEPTION_DISPOSITION support in include files" >&5
-echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6
-if test "${tcl_cv_eh_disposition+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-
-int
-main ()
-{
-
-  EXCEPTION_DISPOSITION x;
-
-  ;
-  return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
-  (eval $ac_compile) 2>conftest.er1
-  ac_status=$?
-  grep -v '^ *+' conftest.er1 >conftest.err
-  rm -f conftest.er1
-  cat conftest.err >&5
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } &&
-	 { ac_try='test -z "$ac_c_werror_flag"
-			 || test ! -s conftest.err'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; } &&
-	 { ac_try='test -s conftest.$ac_objext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  tcl_cv_eh_disposition=yes
-else
-  echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_eh_disposition=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5
-echo "${ECHO_T}$tcl_cv_eh_disposition" >&6
-if test "$tcl_cv_eh_disposition" = "no" ; then
-
-cat >>confdefs.h <<\_ACEOF
-#define EXCEPTION_DISPOSITION int
-_ACEOF
-
-fi
-
-
-# Check to see if the winsock2.h include file provided contains
-# typedefs like LPFN_ACCEPT and friends.
-#
-echo "$as_me:$LINENO: checking for LPFN_ACCEPT support in winsock2.h" >&5
-echo $ECHO_N "checking for LPFN_ACCEPT support in winsock2.h... $ECHO_C" >&6
-if test "${tcl_cv_lpfn_decls+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-#include <winsock2.h>
-
-int
-main ()
-{
-
-  LPFN_ACCEPT accept;
-
-  ;
-  return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
-  (eval $ac_compile) 2>conftest.er1
-  ac_status=$?
-  grep -v '^ *+' conftest.er1 >conftest.err
-  rm -f conftest.er1
-  cat conftest.err >&5
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } &&
-	 { ac_try='test -z "$ac_c_werror_flag"
-			 || test ! -s conftest.err'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; } &&
-	 { ac_try='test -s conftest.$ac_objext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  tcl_cv_lpfn_decls=yes
-else
-  echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_lpfn_decls=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_lpfn_decls" >&5
-echo "${ECHO_T}$tcl_cv_lpfn_decls" >&6
-if test "$tcl_cv_lpfn_decls" = "no" ; then
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_LPFN_DECLS 1
-_ACEOF
-
-fi
-
-# Check to see if winnt.h defines CHAR, SHORT, and LONG
-# even if VOID has already been #defined. The win32api
-# used by mingw and cygwin is known to do this.
-
-echo "$as_me:$LINENO: checking for winnt.h that ignores VOID define" >&5
-echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6
-if test "${tcl_cv_winnt_ignore_void+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-#define VOID void
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-
-int
-main ()
-{
-
-  CHAR c;
-  SHORT s;
-  LONG l;
-
-  ;
-  return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
-  (eval $ac_compile) 2>conftest.er1
-  ac_status=$?
-  grep -v '^ *+' conftest.er1 >conftest.err
-  rm -f conftest.er1
-  cat conftest.err >&5
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } &&
-	 { ac_try='test -z "$ac_c_werror_flag"
-			 || test ! -s conftest.err'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; } &&
-	 { ac_try='test -s conftest.$ac_objext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  tcl_cv_winnt_ignore_void=yes
-else
-  echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_winnt_ignore_void=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5
-echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6
-if test "$tcl_cv_winnt_ignore_void" = "yes" ; then
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_WINNT_IGNORE_VOID 1
-_ACEOF
-
-fi
-
-# Check to see if malloc.h is missing the alloca function
-# declaration. This is known to be a problem with Mingw.
-# If we compiled without the function declaration, it
-# would work but we would get a warning message from gcc.
-# If we add the function declaration ourselves, it
-# would not compile correctly because the _alloca
-# function expects the argument to be passed in a
-# register and not on the stack. Instead, we just
-# call it from inline asm code.
-
-echo "$as_me:$LINENO: checking for alloca declaration in malloc.h" >&5
-echo $ECHO_N "checking for alloca declaration in malloc.h... $ECHO_C" >&6
-if test "${tcl_cv_malloc_decl_alloca+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-#include <malloc.h>
-
-int
-main ()
-{
-
-  size_t arg = 0;
-  void* ptr;
-  ptr = alloca;
-  ptr = alloca(arg);
-
-  ;
-  return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
-  (eval $ac_compile) 2>conftest.er1
-  ac_status=$?
-  grep -v '^ *+' conftest.er1 >conftest.err
-  rm -f conftest.er1
-  cat conftest.err >&5
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } &&
-	 { ac_try='test -z "$ac_c_werror_flag"
-			 || test ! -s conftest.err'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; } &&
-	 { ac_try='test -s conftest.$ac_objext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  tcl_cv_malloc_decl_alloca=yes
-else
-  echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_malloc_decl_alloca=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_malloc_decl_alloca" >&5
-echo "${ECHO_T}$tcl_cv_malloc_decl_alloca" >&6
-if test "$tcl_cv_malloc_decl_alloca" = "no" &&
-   test "${GCC}" = "yes" ; then
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_ALLOCA_GCC_INLINE 1
-_ACEOF
-
-fi
-
-# See if the compiler supports casting to a union type.
-# This is used to stop gcc from printing a compiler
-# warning when initializing a union member.
-
-echo "$as_me:$LINENO: checking for cast to union support" >&5
-echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6
-if test "${tcl_cv_cast_to_union+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-int
-main ()
-{
-
-  union foo { int i; double d; };
-  union foo f = (union foo) (int) 0;
-
-  ;
-  return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
-  (eval $ac_compile) 2>conftest.er1
-  ac_status=$?
-  grep -v '^ *+' conftest.er1 >conftest.err
-  rm -f conftest.er1
-  cat conftest.err >&5
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } &&
-	 { ac_try='test -z "$ac_c_werror_flag"
-			 || test ! -s conftest.err'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; } &&
-	 { ac_try='test -s conftest.$ac_objext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  tcl_cv_cast_to_union=yes
-else
-  echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_cast_to_union=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
-echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
-if test "$tcl_cv_cast_to_union" = "yes"; then
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_CAST_TO_UNION 1
-_ACEOF
-
-fi
-
-# See if declarations like FINDEX_INFO_LEVELS are
-# missing from winbase.h. This is known to be
-# a problem with VC++ 5.2.
-
-echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
-echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6
-if test "${tcl_cv_findex_enums+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-
-int
-main ()
-{
-
-  FINDEX_INFO_LEVELS i;
-  FINDEX_SEARCH_OPS j;
-
-  ;
-  return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
-  (eval $ac_compile) 2>conftest.er1
-  ac_status=$?
-  grep -v '^ *+' conftest.er1 >conftest.err
-  rm -f conftest.er1
-  cat conftest.err >&5
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } &&
-	 { ac_try='test -z "$ac_c_werror_flag"
-			 || test ! -s conftest.err'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; } &&
-	 { ac_try='test -s conftest.$ac_objext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  tcl_cv_findex_enums=yes
-else
-  echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_findex_enums=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
-echo "${ECHO_T}$tcl_cv_findex_enums" >&6
-if test "$tcl_cv_findex_enums" = "no"; then
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_FINDEX_ENUMS 1
-_ACEOF
-
-fi
-
-# See if MWMO_ALERTABLE is missing from winuser.h
-# This is known to be a problem with Mingw.
-
-echo "$as_me:$LINENO: checking for MWMO_ALERTABLE in winuser.h" >&5
-echo $ECHO_N "checking for MWMO_ALERTABLE in winuser.h... $ECHO_C" >&6
-if test "${tcl_cv_mwmo_alertable+set}" = set; then
-  echo $ECHO_N "(cached) $ECHO_C" >&6
-else
-  cat >conftest.$ac_ext <<_ACEOF
-/* confdefs.h.  */
-_ACEOF
-cat confdefs.h >>conftest.$ac_ext
-cat >>conftest.$ac_ext <<_ACEOF
-/* end confdefs.h.  */
-
-#define WIN32_LEAN_AND_MEAN
-#include <windows.h>
-#undef WIN32_LEAN_AND_MEAN
-
-int
-main ()
-{
-
-  int i = MWMO_ALERTABLE;
-
-  ;
-  return 0;
-}
-_ACEOF
-rm -f conftest.$ac_objext
-if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
-  (eval $ac_compile) 2>conftest.er1
-  ac_status=$?
-  grep -v '^ *+' conftest.er1 >conftest.err
-  rm -f conftest.er1
-  cat conftest.err >&5
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); } &&
-	 { ac_try='test -z "$ac_c_werror_flag"
-			 || test ! -s conftest.err'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; } &&
-	 { ac_try='test -s conftest.$ac_objext'
-  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
-  (eval $ac_try) 2>&5
-  ac_status=$?
-  echo "$as_me:$LINENO: \$? = $ac_status" >&5
-  (exit $ac_status); }; }; then
-  tcl_cv_mwmo_alertable=yes
-else
-  echo "$as_me: failed program was:" >&5
-sed 's/^/| /' conftest.$ac_ext >&5
-
-tcl_cv_mwmo_alertable=no
-fi
-rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
-
-fi
-echo "$as_me:$LINENO: result: $tcl_cv_mwmo_alertable" >&5
-echo "${ECHO_T}$tcl_cv_mwmo_alertable" >&6
-if test "$tcl_cv_mwmo_alertable" = "no"; then
-
-cat >>confdefs.h <<\_ACEOF
-#define HAVE_NO_MWMO_ALERTABLE 1
-_ACEOF
-
-fi
-
-#--------------------------------------------------------------------
 # Determines the correct binary file extension (.o, .obj, .exe etc.)
 #--------------------------------------------------------------------
 
@@ -3958,16 +3304,97 @@ if test -n "$CYGPATH"; then
   echo "$as_me:$LINENO: result: $CYGPATH" >&5
 echo "${ECHO_T}$CYGPATH" >&6
 else
-  echo "$as_me:$LINENO: result: no" >&5
-echo "${ECHO_T}no" >&6
-fi
+  echo "$as_me:$LINENO: result: no" >&5
+echo "${ECHO_T}no" >&6
+fi
+
+
+    SHLIB_SUFFIX=".dll"
+
+    # MACHINE is IX86 for LINK, but this is used by the manifest,
+    # which requires x86|amd64|ia64.
+    MACHINE="X86"
+
+    if test "$GCC" = "yes"; then
+
+      echo "$as_me:$LINENO: checking for cross-compile version of gcc" >&5
+echo $ECHO_N "checking for cross-compile version of gcc... $ECHO_C" >&6
+if test "${ac_cv_cross+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+	    #ifdef __WIN32__
+		#error cross-compiler
+	    #endif
+
+int
+main ()
+{
+
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  ac_cv_cross=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
 
+ac_cv_cross=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
 
-    SHLIB_SUFFIX=".dll"
+fi
+echo "$as_me:$LINENO: result: $ac_cv_cross" >&5
+echo "${ECHO_T}$ac_cv_cross" >&6
 
-    # MACHINE is IX86 for LINK, but this is used by the manifest,
-    # which requires x86|amd64|ia64.
-    MACHINE="X86"
+      if test "$ac_cv_cross" = "yes"; then
+	case "$do64bit" in
+	    amd64|x64|yes)
+		CC="x86_64-w64-mingw32-gcc"
+		LD="x86_64-w64-mingw32-ld"
+		AR="x86_64-w64-mingw32-ar"
+		RANLIB="x86_64-w64-mingw32-ranlib"
+		RC="x86_64-w64-mingw32-windres"
+	    ;;
+	    *)
+		CC="i686-w64-mingw32-gcc"
+		LD="i686-w64-mingw32-ld"
+		AR="i686-w64-mingw32-ar"
+		RANLIB="i686-w64-mingw32-ranlib"
+		RC="i686-w64-mingw32-windres"
+	    ;;
+	esac
+      fi
+    fi
 
     # Check for a bug in gcc's windres that causes the
     # compile to fail when a Windows native path is
@@ -4002,7 +3429,7 @@ echo "${ECHO_T}yes" >&6
 	cyg_conftest=
     fi
 
-    if test "$CYGPATH" = "echo" || test "$ac_cv_cygwin" = "yes"; then
+    if test "$CYGPATH" = "echo"; then
         DEPARG='"$<"'
     else
         DEPARG='"$(shell $(CYGPATH) $<)"'
@@ -4010,6 +3437,72 @@ echo "${ECHO_T}yes" >&6
 
     # set various compiler flags depending on whether we are using gcc or cl
 
+    if test "${GCC}" = "yes" ; then
+	echo "$as_me:$LINENO: checking for mingw32 version of gcc" >&5
+echo $ECHO_N "checking for mingw32 version of gcc... $ECHO_C" >&6
+if test "${ac_cv_win32+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+		#ifdef __WIN32__
+		    #error win32
+		#endif
+
+int
+main ()
+{
+
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  ac_cv_win32=no
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+ac_cv_win32=yes
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $ac_cv_win32" >&5
+echo "${ECHO_T}$ac_cv_win32" >&6
+	if test "$ac_cv_win32" != "yes"; then
+	    { { echo "$as_me:$LINENO: error: ${CC} cannot produce win32 executables." >&5
+echo "$as_me: error: ${CC} cannot produce win32 executables." >&2;}
+   { (exit 1); exit 1; }; }
+	fi
+    fi
+
     echo "$as_me:$LINENO: checking compiler flags" >&5
 echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
     if test "${GCC}" = "yes" ; then
@@ -4032,21 +3525,6 @@ echo $ECHO_N "checking compiler flags... $ECHO_C" >&6
 	extra_cflags="-pipe"
 	extra_ldflags="-pipe"
 
-	if test "$ac_cv_cygwin" = "yes"; then
-	  touch ac$$.c
-	  if ${CC} -c -mwin32 ac$$.c >/dev/null 2>&1; then
-	    case "$extra_cflags" in
-	      *-mwin32*) ;;
-	      *) extra_cflags="-mwin32 $extra_cflags" ;;
-	    esac
-	    case "$extra_ldflags" in
-	      *-mwin32*) ;;
-	      *) extra_ldflags="-mwin32 $extra_ldflags" ;;
-	    esac
-	  fi
-	  rm -f ac$$.o ac$$.c
-	fi
-
 	if test "${SHARED_BUILD}" = "0" ; then
 	    # static
             echo "$as_me:$LINENO: result: using static flags" >&5
@@ -4139,9 +3617,9 @@ cat confdefs.h >>conftest.$ac_ext
 cat >>conftest.$ac_ext <<_ACEOF
 /* end confdefs.h.  */
 
-			#ifdef _WIN64
+		    #ifdef _WIN64
 			#error 64-bit
-			#endif
+		    #endif
 
 int
 main ()
@@ -4416,78 +3894,363 @@ echo "$as_me: error: could not find PocketPC SDK or target compiler to enable Wi
 #define $i 1
 _ACEOF
 
-	    done
-#	    if test "${ARCH}" = "X86EM"; then
-#		AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION)
-#	    fi
-	    cat >>confdefs.h <<_ACEOF
-#define _WIN32_WCE $CEVERSION
+	    done
+#	    if test "${ARCH}" = "X86EM"; then
+#		AC_DEFINE_UNQUOTED(_WIN32_WCE_EMULATION)
+#	    fi
+	    cat >>confdefs.h <<_ACEOF
+#define _WIN32_WCE $CEVERSION
+_ACEOF
+
+	    cat >>confdefs.h <<_ACEOF
+#define UNDER_CE $CEVERSION
+_ACEOF
+
+	    CFLAGS_DEBUG="-nologo -Zi -Od"
+	    CFLAGS_OPTIMIZE="-nologo -O2"
+	    lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'`
+	    lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo"
+	    LINKBIN="\"${CEBINROOT}/link.exe\""
+
+	    if test "${CEVERSION}" -lt 400 ; then
+		LIBS="coredll.lib corelibc.lib winsock.lib"
+	    else
+		LIBS="coredll.lib corelibc.lib ws2.lib"
+	    fi
+	    # celib currently stuck at wce300 status
+	    #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib"
+	    LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\""
+	    LIBS_GUI="commctrl.lib commdlg.lib"
+	else
+	    LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib"
+	fi
+
+	SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
+	# link -lib only works when -lib is the first arg
+	STLIB_LD="${LINKBIN} -lib ${lflags}"
+	RC_OUT=-fo
+	RC_TYPE=-r
+	RC_INCLUDE=-i
+	RC_DEFINE=-d
+	RES=res
+	MAKE_LIB="\${STLIB_LD} -out:\$@"
+	POST_MAKE_LIB=
+	MAKE_EXE="\${CC} -Fe\$@"
+	LIBPREFIX=""
+
+	CFLAGS_DEBUG="${CFLAGS_DEBUG} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE"
+	CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE"
+
+	EXTRA_CFLAGS=""
+	CFLAGS_WARNING="-W3"
+	LDFLAGS_DEBUG="-debug"
+	LDFLAGS_OPTIMIZE="-release"
+
+	# Specify the CC output file names based on the target name
+	CC_OBJNAME="-Fo\$@"
+	CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\""
+
+	# Specify linker flags depending on the type of app being
+	# built -- Console vs. Window.
+	if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then
+	    LDFLAGS_CONSOLE="-link ${lflags}"
+	    LDFLAGS_WINDOW=${LDFLAGS_CONSOLE}
+	else
+	    LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}"
+	    LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}"
+	fi
+    fi
+
+    if test "$do64bit" != "no" ; then
+	cat >>confdefs.h <<\_ACEOF
+#define TCL_CFG_DO64BIT 1
+_ACEOF
+
+    fi
+
+    if test "${GCC}" = "yes" ; then
+	echo "$as_me:$LINENO: checking for SEH support in compiler" >&5
+echo $ECHO_N "checking for SEH support in compiler... $ECHO_C" >&6
+if test "${tcl_cv_seh+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  if test "$cross_compiling" = yes; then
+  tcl_cv_seh=no
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+	    #define WIN32_LEAN_AND_MEAN
+	    #include <windows.h>
+	    #undef WIN32_LEAN_AND_MEAN
+
+	    int main(int argc, char** argv) {
+		int a, b = 0;
+		__try {
+		    a = 666 / b;
+		}
+		__except (EXCEPTION_EXECUTE_HANDLER) {
+		    return 0;
+		}
+		return 1;
+	    }
+
+_ACEOF
+rm -f conftest$ac_exeext
+if { (eval echo "$as_me:$LINENO: \"$ac_link\"") >&5
+  (eval $ac_link) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } && { ac_try='./conftest$ac_exeext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  tcl_cv_seh=yes
+else
+  echo "$as_me: program exited with status $ac_status" >&5
+echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+( exit $ac_status )
+tcl_cv_seh=no
+fi
+rm -f core *.core gmon.out bb.out conftest$ac_exeext conftest.$ac_objext conftest.$ac_ext
+fi
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_seh" >&5
+echo "${ECHO_T}$tcl_cv_seh" >&6
+	if test "$tcl_cv_seh" = "no" ; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_NO_SEH 1
+_ACEOF
+
+	fi
+
+	#
+	# Check to see if the excpt.h include file provided contains the
+	# definition for EXCEPTION_DISPOSITION; if not, which is the case
+	# with Cygwin's version as of 2002-04-10, define it to be int,
+	# sufficient for getting the current code to work.
+	#
+	echo "$as_me:$LINENO: checking for EXCEPTION_DISPOSITION support in include files" >&5
+echo $ECHO_N "checking for EXCEPTION_DISPOSITION support in include files... $ECHO_C" >&6
+if test "${tcl_cv_eh_disposition+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+#	    define WIN32_LEAN_AND_MEAN
+#	    include <windows.h>
+#	    undef WIN32_LEAN_AND_MEAN
+
+int
+main ()
+{
+
+		EXCEPTION_DISPOSITION x;
+
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  tcl_cv_eh_disposition=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+tcl_cv_eh_disposition=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_eh_disposition" >&5
+echo "${ECHO_T}$tcl_cv_eh_disposition" >&6
+	if test "$tcl_cv_eh_disposition" = "no" ; then
+
+cat >>confdefs.h <<\_ACEOF
+#define EXCEPTION_DISPOSITION int
+_ACEOF
+
+	fi
+
+	# Check to see if winnt.h defines CHAR, SHORT, and LONG
+	# even if VOID has already been #defined. The win32api
+	# used by mingw and cygwin is known to do this.
+
+	echo "$as_me:$LINENO: checking for winnt.h that ignores VOID define" >&5
+echo $ECHO_N "checking for winnt.h that ignores VOID define... $ECHO_C" >&6
+if test "${tcl_cv_winnt_ignore_void+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
 _ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
 
-	    cat >>confdefs.h <<_ACEOF
-#define UNDER_CE $CEVERSION
+		#define VOID void
+		#define WIN32_LEAN_AND_MEAN
+		#include <windows.h>
+		#undef WIN32_LEAN_AND_MEAN
+
+int
+main ()
+{
+
+		CHAR c;
+		SHORT s;
+		LONG l;
+
+  ;
+  return 0;
+}
 _ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  tcl_cv_winnt_ignore_void=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
 
-	    CFLAGS_DEBUG="-nologo -Zi -Od"
-	    CFLAGS_OPTIMIZE="-nologo -O2"
-	    lversion=`echo ${CEVERSION} | sed -e 's/\(.\)\(..\)/\1\.\2/'`
-	    lflags="-nodefaultlib -MACHINE:${ARCH} -LIBPATH:\"${CELIBPATH}\" -subsystem:windowsce,${lversion} -nologo"
-	    LINKBIN="\"${CEBINROOT}/link.exe\""
+tcl_cv_winnt_ignore_void=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_winnt_ignore_void" >&5
+echo "${ECHO_T}$tcl_cv_winnt_ignore_void" >&6
+	if test "$tcl_cv_winnt_ignore_void" = "yes" ; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_WINNT_IGNORE_VOID 1
+_ACEOF
 
-	    if test "${CEVERSION}" -lt 400 ; then
-		LIBS="coredll.lib corelibc.lib winsock.lib"
-	    else
-		LIBS="coredll.lib corelibc.lib ws2.lib"
-	    fi
-	    # celib currently stuck at wce300 status
-	    #LIBS="$LIBS \${CELIB_DIR}/wince-${ARCH}-pocket-${OSVERSION}-release/celib.lib"
-	    LIBS="$LIBS \"\${CELIB_DIR}/wince-${ARCH}-pocket-wce300-release/celib.lib\""
-	    LIBS_GUI="commctrl.lib commdlg.lib"
-	else
-	    LIBS_GUI="gdi32.lib comdlg32.lib imm32.lib comctl32.lib shell32.lib uuid.lib"
 	fi
 
-	SHLIB_LD="${LINKBIN} -dll -incremental:no ${lflags}"
-	# link -lib only works when -lib is the first arg
-	STLIB_LD="${LINKBIN} -lib ${lflags}"
-	RC_OUT=-fo
-	RC_TYPE=-r
-	RC_INCLUDE=-i
-	RC_DEFINE=-d
-	RES=res
-	MAKE_LIB="\${STLIB_LD} -out:\$@"
-	POST_MAKE_LIB=
-	MAKE_EXE="\${CC} -Fe\$@"
-	LIBPREFIX=""
+	# See if the compiler supports casting to a union type.
+	# This is used to stop gcc from printing a compiler
+	# warning when initializing a union member.
 
-	CFLAGS_DEBUG="${CFLAGS_DEBUG} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE"
-	CFLAGS_OPTIMIZE="${CFLAGS_OPTIMIZE} -D_CRT_SECURE_NO_DEPRECATE -D_CRT_NONSTDC_NO_DEPRECATE"
+	echo "$as_me:$LINENO: checking for cast to union support" >&5
+echo $ECHO_N "checking for cast to union support... $ECHO_C" >&6
+if test "${tcl_cv_cast_to_union+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
 
-	EXTRA_CFLAGS=""
-	CFLAGS_WARNING="-W3"
-	LDFLAGS_DEBUG="-debug"
-	LDFLAGS_OPTIMIZE="-release"
+int
+main ()
+{
 
-	# Specify the CC output file names based on the target name
-	CC_OBJNAME="-Fo\$@"
-	CC_EXENAME="-Fe\"\$(shell \$(CYGPATH) '\$@')\""
+		  union foo { int i; double d; };
+		  union foo f = (union foo) (int) 0;
 
-	# Specify linker flags depending on the type of app being
-	# built -- Console vs. Window.
-	if test "$doWince" != "no" -a "${TARGETCPU}" != "X86"; then
-	    LDFLAGS_CONSOLE="-link ${lflags}"
-	    LDFLAGS_WINDOW=${LDFLAGS_CONSOLE}
-	else
-	    LDFLAGS_CONSOLE="-link -subsystem:console ${lflags}"
-	    LDFLAGS_WINDOW="-link -subsystem:windows ${lflags}"
-	fi
-    fi
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  tcl_cv_cast_to_union=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
 
-    if test "$do64bit" != "no" ; then
-	cat >>confdefs.h <<\_ACEOF
-#define TCL_CFG_DO64BIT 1
+tcl_cv_cast_to_union=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_cast_to_union" >&5
+echo "${ECHO_T}$tcl_cv_cast_to_union" >&6
+	if test "$tcl_cv_cast_to_union" = "yes"; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_CAST_TO_UNION 1
 _ACEOF
 
+	fi
     fi
 
     # DL_LIBS is empty, but then we match the Unix version
@@ -4769,6 +4532,83 @@ _ACEOF
 fi
 
 #--------------------------------------------------------------------
+# Perform additinal compiler tests.
+#--------------------------------------------------------------------
+
+# See if declarations like FINDEX_INFO_LEVELS are
+# missing from winbase.h. This is known to be
+# a problem with VC++ 5.2.
+
+echo "$as_me:$LINENO: checking for FINDEX_INFO_LEVELS in winbase.h" >&5
+echo $ECHO_N "checking for FINDEX_INFO_LEVELS in winbase.h... $ECHO_C" >&6
+if test "${tcl_cv_findex_enums+set}" = set; then
+  echo $ECHO_N "(cached) $ECHO_C" >&6
+else
+  cat >conftest.$ac_ext <<_ACEOF
+/* confdefs.h.  */
+_ACEOF
+cat confdefs.h >>conftest.$ac_ext
+cat >>conftest.$ac_ext <<_ACEOF
+/* end confdefs.h.  */
+
+#define WIN32_LEAN_AND_MEAN
+#include <windows.h>
+#undef WIN32_LEAN_AND_MEAN
+
+int
+main ()
+{
+
+  FINDEX_INFO_LEVELS i;
+  FINDEX_SEARCH_OPS j;
+
+  ;
+  return 0;
+}
+_ACEOF
+rm -f conftest.$ac_objext
+if { (eval echo "$as_me:$LINENO: \"$ac_compile\"") >&5
+  (eval $ac_compile) 2>conftest.er1
+  ac_status=$?
+  grep -v '^ *+' conftest.er1 >conftest.err
+  rm -f conftest.er1
+  cat conftest.err >&5
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); } &&
+	 { ac_try='test -z "$ac_c_werror_flag"
+			 || test ! -s conftest.err'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; } &&
+	 { ac_try='test -s conftest.$ac_objext'
+  { (eval echo "$as_me:$LINENO: \"$ac_try\"") >&5
+  (eval $ac_try) 2>&5
+  ac_status=$?
+  echo "$as_me:$LINENO: \$? = $ac_status" >&5
+  (exit $ac_status); }; }; then
+  tcl_cv_findex_enums=yes
+else
+  echo "$as_me: failed program was:" >&5
+sed 's/^/| /' conftest.$ac_ext >&5
+
+tcl_cv_findex_enums=no
+fi
+rm -f conftest.err conftest.$ac_objext conftest.$ac_ext
+
+fi
+echo "$as_me:$LINENO: result: $tcl_cv_findex_enums" >&5
+echo "${ECHO_T}$tcl_cv_findex_enums" >&6
+if test "$tcl_cv_findex_enums" = "no"; then
+
+cat >>confdefs.h <<\_ACEOF
+#define HAVE_NO_FINDEX_ENUMS 1
+_ACEOF
+
+fi
+
+#--------------------------------------------------------------------
 # Set the default compiler switches based on the --enable-symbols
 # option.  This macro depends on C flags, and should be called
 # after SC_CONFIG_CFLAGS macro is called.
-- 
cgit v0.12


From 4c5e1cc6db788396e73b9edeeaebb92096dc644b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 2 Apr 2012 13:13:11 +0000
Subject: Implementation of TIP #396

---
 ChangeLog            | 32 +++++++++++++++++++-----------
 doc/coroutine.n      | 56 +++++++++++++++++++++++++++++++++++++++++++++++++---
 generic/tclBasic.c   | 11 ++++-------
 tests/coroutine.test | 49 +++++++++++++++++++++++++++++++--------------
 4 files changed, 111 insertions(+), 37 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 3f90c0e..72d3507 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,20 +1,28 @@
+2012-04-02  Donal K. Fellows  <dkf@users.sf.net>
+
+	IMPLEMENTATION OF TIP#396.
+
+	* generic/tclBasic.c (builtInCmds, TclNRYieldToObjCmd): Convert the
+	formerly-unsupported yieldm and yieldTo commands into [yieldto].
+
 2012-04-02  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclInt.decls:      [Bug 3508771] load tclreg.dll in cygwin tclsh
-	* generic/tclIntPlatDecls.h: Implement TclWinGetTclInstance, TclpGetTZName,
-	* generic/tclStubInit.c:     and various more win32-specific internal functions for
-	Cygwin, so win32 extensions using those can be loaded in the cygwin version of tclsh.
+	* generic/tclInt.decls: [Bug 3508771]: load tclreg.dll in cygwin tclsh
+	* generic/tclIntPlatDecls.h: Implement TclWinGetTclInstance,
+	* generic/tclStubInit.c:     TclpGetTZName, and various more
+	win32-specific internal functions for Cygwin, so win32 extensions
+	using those can be loaded in the cygwin version of tclsh.
 
 2012-03-30  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* unix/tcl.m4:        [Bug 3511806] Compiler checks too early
-	* unix/configure.in:  This change allows to build the cygwin
-	* unix/tclUnixPort.h: and mingw32 ports of Tcl/Tk to build
-	* win/tcl.m4:         out-of-the-box using a native or cross-
-	* win/configure.in:   compiler.
-	* win/tclWinPort.h:   (autoconf still to be run!)
-	* win/README          Document how to build win32 or win64
-	executables with Linux, Cygwin or Darwin.
+	* unix/tcl.m4:        [Bug 3511806]: Compiler checks too early
+	* unix/configure.in:  This change allows to build the cygwin and
+	* unix/tclUnixPort.h: mingw32 ports of Tcl/Tk to build out-of-the-box
+	* win/tcl.m4:         using a native or cross-compiler.
+	* win/configure.in:
+	* win/tclWinPort.h:
+	* win/README          Document how to build win32 or win64 executables
+	with Linux, Cygwin or Darwin.
 
 2012-03-29  Jan Nijtmans  <nijtmans@users.sf.net>
 
diff --git a/doc/coroutine.n b/doc/coroutine.n
index f4b5d5b..035d58a 100644
--- a/doc/coroutine.n
+++ b/doc/coroutine.n
@@ -9,12 +9,15 @@
 .BS
 '\" Note:  do not modify the .SH NAME line immediately below!
 .SH NAME
-coroutine, yield \- Create and produce values from coroutines
+coroutine, yield, yieldto \- Create and produce values from coroutines
 .SH SYNOPSIS
 .nf
 \fBcoroutine \fIname command\fR ?\fIarg...\fR?
 \fByield\fR ?\fIvalue\fR?
-\fIname\fR ?\fIvalue\fR?
+.VS TIP396
+\fByieldto\fR \fIcommand\fR ?\fIarg...\fR?
+\fIname\fR ?\fIvalue...\fR?
+.VE TIP396
 .fi
 .BE
 .SH DESCRIPTION
@@ -30,11 +33,37 @@ Within the context, values may be generated as results by using the
 When that is called, the context will suspend execution and the
 \fBcoroutine\fR command will return the argument to \fByield\fR. The execution
 of the context can then be resumed by calling the context command, optionally
-passing in the value to use as the result of the \fByield\fR call that caused
+passing in the \fIsingle\fR value to use as the result of the \fByield\fR call
+that caused
 the context to be suspended. If the coroutine context never yields and instead
 returns conventionally, the result of the \fBcoroutine\fR command will be the
 result of the evaluation of the context.
 .PP
+.VS TIP396
+The coroutine may also suspend its execution by use of the \fByieldto\fR
+command, which instead of returning, cedes execution to some command called
+\fIcommand\fR (resolved in the context of the coroutine) and to which \fIany
+number\fR of arguments may be passed. Since every coroutine has a context
+command, \fByieldto\fR can be used to transfer control directly from one
+coroutine to another (this is only advisable if the two coroutines are
+expecting this to happen) but \fIany\fR command may be the target. If a
+coroutine is suspended by this mechanism, the coroutine processing can be
+resumed by calling the context command optionally passing in an arbitrary
+number of arguments. The return value of the \fByieldto\fR call will be the
+list of arguments passed to the context command; it is up to the caller to
+decide what to do with those values.
+.PP
+The recommended way of writing a version of \fByield\fR that allows resumption
+with multiple arguments is by using \fByieldto\fR and the \fBreturn\fR
+command, like this:
+.PP
+.CS
+proc yieldm {value} {
+    \fByieldto\fR return -level 0 $value
+}
+.CE
+.VE TIP396
+.PP
 The coroutine can also be deleted by destroying the command \fIname\fR, and
 the name of the current coroutine can be retrieved by using
 \fBinfo coroutine\fR.
@@ -108,6 +137,27 @@ for {set i 1} {$i <= 20} {incr i} {
     puts "prime#$i = [\fIeratosthenes\fR]"
 }
 .CE
+.PP
+.VS TIP396
+This example shows how a value can be passed around a group of three
+coroutines that yield to each other:
+.PP
+.CS
+proc juggler {name target {value ""}} {
+    if {$value eq ""} {
+        set value [\fByield\fR [info coroutine]]
+    }
+    while {$value ne ""} {
+        puts "$name : $value"
+        set value [string range $value 0 end-1]
+        lassign [\fByieldto\fR $target $value] value
+    }
+}
+\fBcoroutine\fR j1 juggler Larry [
+    \fBcoroutine\fR j2 juggler Curly [
+        \fBcoroutine\fR j3 juggler Moe j1]] "Nyuck!Nyuck!Nyuck!"
+.CE
+.VE TIP396
 .SS "DETAILED SEMANTICS"
 .PP
 This example demonstrates that coroutines start from the global namespace, and
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index c07fa70..280290c 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -258,6 +258,7 @@ static const CmdInfo builtInCmds[] = {
     {"variable",	Tcl_VariableObjCmd,	TclCompileVariableCmd,	NULL,	1},
     {"while",		Tcl_WhileObjCmd,	TclCompileWhileCmd,	TclNRWhileObjCmd,	1},
     {"yield",		NULL,			NULL,			TclNRYieldObjCmd,	1},
+    {"yieldto",		NULL,			NULL,			TclNRYieldToObjCmd,	1},
 
     /*
      * Commands in the OS-interface. Note that many of these are unsafe.
@@ -830,10 +831,6 @@ Tcl_CreateInterp(void)
             TclNRAssembleObjCmd, NULL, NULL);
     cmdPtr->compileProc = &TclCompileAssembleCmd;
 
-    Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldTo", NULL,
-	    TclNRYieldToObjCmd, NULL, NULL);
-    Tcl_NRCreateCommand(interp, "::tcl::unsupported::yieldm", NULL,
-	    TclNRYieldObjCmd, INT2PTR(CORO_ACTIVATE_YIELDM), NULL);
     Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
 	    NRCoroInjectObjCmd, NULL, NULL);
     
@@ -8511,7 +8508,7 @@ TclNRYieldToObjCmd(
     }
 
     if (!corPtr) {
-	Tcl_SetResult(interp, "yieldTo can only be called in a coroutine",
+	Tcl_SetResult(interp, "yieldto can only be called in a coroutine",
 		TCL_STATIC);
 	Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD", NULL);
 	return TCL_ERROR;
@@ -8529,7 +8526,7 @@ TclNRYieldToObjCmd(
     nsObjPtr = Tcl_NewStringObj(nsPtr->fullName, -1);
     if ((TCL_OK != TclGetNamespaceFromObj(interp, nsObjPtr, &ns1Ptr))
 	    || (nsPtr != ns1Ptr)) {
-	Tcl_Panic("yieldTo failed to find the proper namespace");
+	Tcl_Panic("yieldto failed to find the proper namespace");
     }
     Tcl_IncrRefCount(nsObjPtr);
 
@@ -8542,7 +8539,7 @@ TclNRYieldToObjCmd(
 	    NULL);
     iPtr->execEnvPtr = corPtr->eePtr;
 
-    return TclNRYieldObjCmd(clientData, interp, 1, objv);
+    return TclNRYieldObjCmd(INT2PTR(CORO_ACTIVATE_YIELDM), interp, 1, objv);
 }
 
 static int
diff --git a/tests/coroutine.test b/tests/coroutine.test
index 7d5169b..7f40a7b 100644
--- a/tests/coroutine.test
+++ b/tests/coroutine.test
@@ -557,12 +557,25 @@ test coroutine-6.3 {coroutine nargs} -body {
 } -cleanup {
     rename a {}
 } -returnCodes error -result {wrong # args: should be "a ?arg?"}
-test coroutine-6.4 {unsupported: multi-argument yield} -body {
+
+test coroutine-7.1 {yieldto} -body {
+    coroutine c apply {{} {
+	yield
+	yieldto return -level 0 -code 1 quux
+	return quuy
+    }}
+    set res [list [catch c msg] $msg]
+    lappend res [catch c msg] $msg
+    lappend res [catch c msg] $msg
+} -cleanup {
+    unset res
+} -result [list 1 quux 0 quuy 1 {invalid command name "c"}]
+test coroutine-7.2 {multi-argument yielding with yieldto} -body {
     proc corobody {} {
 	set a 1
 	while 1 {
 	    set a [yield $a]
-	    set a [::tcl::unsupported::yieldm $a]
+	    set a [yieldto return -level 0 $a]
 	    lappend a [llength $a]
 	}
     }
@@ -573,20 +586,26 @@ test coroutine-6.4 {unsupported: multi-argument yield} -body {
 } -cleanup {
     rename corobody {}
 } -result {x {y z 2} \{p {\{q r 2} {} 0 {} ok {}}
-
-test coroutine-7.1 {yieldTo} -body {
-    coroutine c apply {{} {
-	yield
-	tcl::unsupported::yieldTo return -level 0 -code 1 quux
-	return quuy
-    }}
-    set res [list [catch c msg] $msg]
-    lappend res [catch c msg] $msg
-    lappend res [catch c msg] $msg
+test coroutine-7.3 {yielding between coroutines} -body {
+    proc juggler {target {value ""}} {
+	if {$value eq ""} {
+	    set value [yield [info coroutine]]
+	}
+	while {[llength $value]} {
+	    lappend ::result $value [info coroutine]
+	    set value [lrange $value 0 end-1]
+	    lassign [yieldto $target $value] value
+	}
+	# Clear nested collection of coroutines
+	catch $target
+    }
+    set result ""
+    coroutine j1 juggler [coroutine j2 juggler [coroutine j3 juggler j1]]\
+	{a b c d e}
+    list $result [info command j1] [info command j2] [info command j3]
 } -cleanup {
-    unset res
-} -result [list 1 quux 0 quuy 1 {invalid command name "c"}]
-
+    catch {rename juggler ""}
+} -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}}
 
 # cleanup
 unset lambda
-- 
cgit v0.12


From 4414f93a7afa1091660217728be8f6d33cebe7ae Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 2 Apr 2012 14:13:44 +0000
Subject: cygwin should not use ExitProcess

---
 generic/tclPanic.c | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/generic/tclPanic.c b/generic/tclPanic.c
index 7df3cb3..84a9136 100644
--- a/generic/tclPanic.c
+++ b/generic/tclPanic.c
@@ -114,6 +114,8 @@ Tcl_PanicVA(
 #   else
     DebugBreak();
 #   endif
+#endif
+#if defined(_WIN32)
     ExitProcess(1);
 #else
     abort();
-- 
cgit v0.12


From a023aca95e9b16b2d3fb63919b5f25f6279fd3b0 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 3 Apr 2012 10:58:45 +0000
Subject: [Bug 3514475]: remove TclpGetTimeZone and TclpGetTZName

---
 ChangeLog                 |   9 ++++
 generic/tclInt.decls      |  21 +++++----
 generic/tclIntDecls.h     |   8 ++--
 generic/tclIntPlatDecls.h |  24 ++++------
 generic/tclStubInit.c     |  20 ++------
 unix/tclUnixTime.c        | 116 ----------------------------------------------
 win/tclWinTime.c          | 116 ----------------------------------------------
 7 files changed, 37 insertions(+), 277 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 72d3507..861213c 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,12 @@
+2012-04-??  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclInt.decls:      [Bug 3514475]: remove TclpGetTimeZone
+	* generic/tclIntDecls.h:     and TclpGetTZName
+	* generic/tclIntPlatDecls.h:
+	* generic/tclStubInit.c:
+	* unix/tclUnixTime.c:
+	* unix/tclWinTilemc:
+
 2012-04-02  Donal K. Fellows  <dkf@users.sf.net>
 
 	IMPLEMENTATION OF TIP#396.
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 5496b4b..7cac354 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -319,9 +319,10 @@ declare 76 {
 declare 77 {
     void TclpGetTime(Tcl_Time *time)
 }
-declare 78 {
-    int TclpGetTimeZone(unsigned long time)
-}
+# Removed in 8.6:
+#declare 78 {
+#    int TclpGetTimeZone(unsigned long time)
+#}
 # Replaced by Tcl_FSListVolumes in 8.4:
 #declare 79 {
 #    int TclpListVolumes(Tcl_Interp *interp)
@@ -1098,9 +1099,10 @@ declare 20 win {
 declare 22 win {
     TclFile TclpCreateTempFile(const char *contents)
 }
-declare 23 win {
-    char *TclpGetTZName(int isdst)
-}
+# Removed in 8.6:
+#declare 23 win {
+#    char *TclpGetTZName(int isdst)
+#}
 declare 24 win {
     char *TclWinNoBackslash(char *path)
 }
@@ -1234,9 +1236,10 @@ declare 20 unix {
 declare 22 unix {
     TclFile TclpCreateTempFile(const char *contents)
 }
-declare 23 unix {
-    char *TclpGetTZName(int isdst)
-}
+# Removed in 8.6:
+#declare 23 unix {
+#    char *TclpGetTZName(int isdst)
+#}
 declare 24 unix {
     char *TclWinNoBackslash(char *path)
 }
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index b294e4f..4959087 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -214,8 +214,7 @@ EXTERN unsigned long	TclpGetClicks(void);
 EXTERN unsigned long	TclpGetSeconds(void);
 /* 77 */
 EXTERN void		TclpGetTime(Tcl_Time *time);
-/* 78 */
-EXTERN int		TclpGetTimeZone(unsigned long time);
+/* Slot 78 is reserved */
 /* Slot 79 is reserved */
 /* Slot 80 is reserved */
 /* 81 */
@@ -684,7 +683,7 @@ typedef struct TclIntStubs {
     unsigned long (*tclpGetClicks) (void); /* 75 */
     unsigned long (*tclpGetSeconds) (void); /* 76 */
     void (*tclpGetTime) (Tcl_Time *time); /* 77 */
-    int (*tclpGetTimeZone) (unsigned long time); /* 78 */
+    void (*reserved78)(void);
     void (*reserved79)(void);
     void (*reserved80)(void);
     char * (*tclpRealloc) (char *ptr, unsigned int size); /* 81 */
@@ -995,8 +994,7 @@ extern const TclIntStubs *tclIntStubsPtr;
 	(tclIntStubsPtr->tclpGetSeconds) /* 76 */
 #define TclpGetTime \
 	(tclIntStubsPtr->tclpGetTime) /* 77 */
-#define TclpGetTimeZone \
-	(tclIntStubsPtr->tclpGetTimeZone) /* 78 */
+/* Slot 78 is reserved */
 /* Slot 79 is reserved */
 /* Slot 80 is reserved */
 #define TclpRealloc \
diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index 20da2fd..bea9037 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -100,8 +100,7 @@ EXTERN void		TclWinAddProcess(void *hProcess, unsigned int id);
 /* Slot 21 is reserved */
 /* 22 */
 EXTERN TclFile		TclpCreateTempFile(const char *contents);
-/* 23 */
-EXTERN char *		TclpGetTZName(int isdst);
+/* Slot 23 is reserved */
 /* 24 */
 EXTERN char *		TclWinNoBackslash(char *path);
 /* Slot 25 is reserved */
@@ -170,8 +169,7 @@ EXTERN void		TclWinAddProcess(HANDLE hProcess, DWORD id);
 /* Slot 21 is reserved */
 /* 22 */
 EXTERN TclFile		TclpCreateTempFile(const char *contents);
-/* 23 */
-EXTERN char *		TclpGetTZName(int isdst);
+/* Slot 23 is reserved */
 /* 24 */
 EXTERN char *		TclWinNoBackslash(char *path);
 /* Slot 25 is reserved */
@@ -244,8 +242,7 @@ EXTERN void		TclWinAddProcess(void *hProcess, unsigned int id);
 /* Slot 21 is reserved */
 /* 22 */
 EXTERN TclFile		TclpCreateTempFile(const char *contents);
-/* 23 */
-EXTERN char *		TclpGetTZName(int isdst);
+/* Slot 23 is reserved */
 /* 24 */
 EXTERN char *		TclWinNoBackslash(char *path);
 /* Slot 25 is reserved */
@@ -292,7 +289,7 @@ typedef struct TclIntPlatStubs {
     void (*tclWinAddProcess) (void *hProcess, unsigned int id); /* 20 */
     void (*reserved21)(void);
     TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
-    char * (*tclpGetTZName) (int isdst); /* 23 */
+    void (*reserved23)(void);
     char * (*tclWinNoBackslash) (char *path); /* 24 */
     void (*reserved25)(void);
     void (*tclWinSetInterfaces) (int wide); /* 26 */
@@ -326,7 +323,7 @@ typedef struct TclIntPlatStubs {
     void (*tclWinAddProcess) (HANDLE hProcess, DWORD id); /* 20 */
     void (*reserved21)(void);
     TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
-    char * (*tclpGetTZName) (int isdst); /* 23 */
+    void (*reserved23)(void);
     char * (*tclWinNoBackslash) (char *path); /* 24 */
     void (*reserved25)(void);
     void (*tclWinSetInterfaces) (int wide); /* 26 */
@@ -358,7 +355,7 @@ typedef struct TclIntPlatStubs {
     void (*tclWinAddProcess) (void *hProcess, unsigned int id); /* 20 */
     void (*reserved21)(void);
     TclFile (*tclpCreateTempFile) (const char *contents); /* 22 */
-    char * (*tclpGetTZName) (int isdst); /* 23 */
+    void (*reserved23)(void);
     char * (*tclWinNoBackslash) (char *path); /* 24 */
     void (*reserved25)(void);
     void (*tclWinSetInterfaces) (int wide); /* 26 */
@@ -427,8 +424,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
 /* Slot 21 is reserved */
 #define TclpCreateTempFile \
 	(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
-#define TclpGetTZName \
-	(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
+/* Slot 23 is reserved */
 #define TclWinNoBackslash \
 	(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
 /* Slot 25 is reserved */
@@ -487,8 +483,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
 /* Slot 21 is reserved */
 #define TclpCreateTempFile \
 	(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
-#define TclpGetTZName \
-	(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
+/* Slot 23 is reserved */
 #define TclWinNoBackslash \
 	(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
 /* Slot 25 is reserved */
@@ -546,8 +541,7 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
 /* Slot 21 is reserved */
 #define TclpCreateTempFile \
 	(tclIntPlatStubsPtr->tclpCreateTempFile) /* 22 */
-#define TclpGetTZName \
-	(tclIntPlatStubsPtr->tclpGetTZName) /* 23 */
+/* Slot 23 is reserved */
 #define TclWinNoBackslash \
 	(tclIntPlatStubsPtr->tclWinNoBackslash) /* 24 */
 /* Slot 25 is reserved */
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 53b2015..2143574 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -53,7 +53,6 @@ int __stdcall GetModuleHandleExW(unsigned int, const char *, void *);
 #define TclWinGetTclInstance winGetTclInstance
 #define TclWinNToHS winNToHS
 #define TclWinSetSockOpt winSetSockOpt
-#define TclpGetTZName pGetTZName
 #define TclWinNoBackslash winNoBackslash
 #define TclWinSetInterfaces (void (*) (int)) doNothing
 #define TclWinAddProcess (void (*) (void *, unsigned int)) doNothing
@@ -97,16 +96,6 @@ TclWinSetSockOpt(void *s, int level, int optname,
 }
 
 static char *
-TclpGetTZName(int isdst)
-{
-    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-    const char *zone = getenv("TZ");
-    Tcl_ExternalToUtf(NULL, NULL, zone, strlen(zone), 0, NULL,
-	    tsdPtr->tzName, sizeof(tsdPtr->tzName), NULL, NULL, NULL);
-    return tsdPtr->tzName;
-}
-
-static char *
 TclWinNoBackslash(char *path)
 {
     char *p;
@@ -172,7 +161,6 @@ Tcl_WinTCharToUtf(
 #   define TclWinNToHS (unsigned short (*) _ANSI_ARGS_((unsigned short ns))) TclpMakeFile
 #   define TclWinSetSockOpt (int (*) _ANSI_ARGS_((void *, int, int, const char *, int))) TclpOpenFile
 #   define TclWinAddProcess 0
-#   define TclpGetTZName 0
 #   define TclWinNoBackslash 0
 #   define TclWinSetInterfaces 0
 #   define TclWinFlushDirtyChannels 0
@@ -280,7 +268,7 @@ static const TclIntStubs tclIntStubs = {
     TclpGetClicks, /* 75 */
     TclpGetSeconds, /* 76 */
     TclpGetTime, /* 77 */
-    TclpGetTimeZone, /* 78 */
+    0, /* 78 */
     0, /* 79 */
     0, /* 80 */
     TclpRealloc, /* 81 */
@@ -482,7 +470,7 @@ static const TclIntPlatStubs tclIntPlatStubs = {
     TclWinAddProcess, /* 20 */
     0, /* 21 */
     TclpCreateTempFile, /* 22 */
-    TclpGetTZName, /* 23 */
+    0, /* 23 */
     TclWinNoBackslash, /* 24 */
     0, /* 25 */
     TclWinSetInterfaces, /* 26 */
@@ -516,7 +504,7 @@ static const TclIntPlatStubs tclIntPlatStubs = {
     TclWinAddProcess, /* 20 */
     0, /* 21 */
     TclpCreateTempFile, /* 22 */
-    TclpGetTZName, /* 23 */
+    0, /* 23 */
     TclWinNoBackslash, /* 24 */
     0, /* 25 */
     TclWinSetInterfaces, /* 26 */
@@ -548,7 +536,7 @@ static const TclIntPlatStubs tclIntPlatStubs = {
     TclWinAddProcess, /* 20 */
     0, /* 21 */
     TclpCreateTempFile, /* 22 */
-    TclpGetTZName, /* 23 */
+    0, /* 23 */
     TclWinNoBackslash, /* 24 */
     0, /* 25 */
     TclWinSetInterfaces, /* 26 */
diff --git a/unix/tclUnixTime.c b/unix/tclUnixTime.c
index 02a90a5..c7921fe 100644
--- a/unix/tclUnixTime.c
+++ b/unix/tclUnixTime.c
@@ -224,122 +224,6 @@ TclpWideClicksToNanoseconds(
 /*
  *----------------------------------------------------------------------
  *
- * TclpGetTimeZone --
- *
- *	Determines the current timezone. The method varies wildly between
- *	different platform implementations, so its hidden in this function.
- *
- * Results:
- *	The return value is the local time zone, measured in minutes away from
- *	GMT (-ve for east, +ve for west).
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclpGetTimeZone(
-    unsigned long currentTime)
-{
-    int timeZone;
-
-    /*
-     * We prefer first to use the time zone in "struct tm" if the structure
-     * contains such a member. Following that, we try to locate the external
-     * 'timezone' variable and use its value. If both of those methods fail,
-     * we attempt to convert a known time to local time and use the difference
-     * from UTC as the local time zone. In all cases, we need to undo any
-     * Daylight Saving Time adjustment.
-     */
-
-#if defined(HAVE_TM_TZADJ)
-#define TCL_GOT_TIMEZONE
-    /*
-     * Struct tm contains tm_tzadj - that value may be used.
-     */
-
-    time_t curTime = (time_t) currentTime;
-    struct tm *timeDataPtr = TclpLocaltime(&curTime);
-
-    timeZone = timeDataPtr->tm_tzadj / 60;
-    if (timeDataPtr->tm_isdst) {
-	timeZone += 60;
-    }
-#endif
-
-#if defined(HAVE_TM_GMTOFF) && !defined (TCL_GOT_TIMEZONE)
-#define TCL_GOT_TIMEZONE
-    /*
-     * Struct tm contains tm_gmtoff - that value may be used.
-     */
-
-    time_t curTime = (time_t) currentTime;
-    struct tm *timeDataPtr = TclpLocaltime(&curTime);
-
-    timeZone = -(timeDataPtr->tm_gmtoff / 60);
-    if (timeDataPtr->tm_isdst) {
-	timeZone += 60;
-    }
-#endif
-
-#if defined(HAVE_TIMEZONE_VAR) && !defined(TCL_GOT_TIMEZONE) && !defined(USE_DELTA_FOR_TZ)
-#define TCL_GOT_TIMEZONE
-    /*
-     * The 'timezone' external var is present and may be used.
-     */
-
-    SetTZIfNecessary();
-
-    /*
-     * Note: this is not a typo in "timezone" below! See tzset documentation
-     * for details.
-     */
-
-    timeZone = timezone / 60;
-#endif
-
-#if !defined(TCL_GOT_TIMEZONE)
-#define TCL_GOT_TIMEZONE
-    /*
-     * Fallback - determine time zone with a known reference time.
-     */
-
-    time_t tt;
-    struct tm *stm;
-
-    tt = 849268800L;		/* 1996-11-29 12:00:00  GMT */
-    stm = TclpLocaltime(&tt);	/* eg 1996-11-29  6:00:00  CST6CDT */
-
-    /*
-     * The calculation below assumes a max of +12 or -12 hours from GMT.
-     */
-
-    timeZone = (12 - stm->tm_hour)*60 + (0 - stm->tm_min);
-    if (stm->tm_isdst) {
-	timeZone += 60;
-    }
-
-    /*
-     * Now have offset for our known reference time, eg +360 for CST6CDT.
-     */
-#endif
-
-#ifndef TCL_GOT_TIMEZONE
-    /*
-     * Cause fatal compile error, we don't know how to get timezone.
-     */
-
-#error autoconf did not figure out how to determine the timezone.
-#endif
-
-    return timeZone;
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * Tcl_GetTime --
  *
  *	Gets the current system time in seconds and microseconds since the
diff --git a/win/tclWinTime.c b/win/tclWinTime.c
index d3e19c0..daa229d 100644
--- a/win/tclWinTime.c
+++ b/win/tclWinTime.c
@@ -200,35 +200,6 @@ TclpGetClicks(void)
 /*
  *----------------------------------------------------------------------
  *
- * TclpGetTimeZone --
- *
- *	Determines the current timezone. The method varies wildly between
- *	different Platform implementations, so its hidden in this function.
- *
- * Results:
- *	Minutes west of GMT.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-int
-TclpGetTimeZone(
-    unsigned long currentTime)
-{
-    int timeZone;
-
-    tzset();
-    timeZone = timezone / 60;
-
-    return timeZone;
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * Tcl_GetTime --
  *
  *	Gets the current system time in seconds and microseconds since the
@@ -518,93 +489,6 @@ StopCalibration(
 /*
  *----------------------------------------------------------------------
  *
- * TclpGetTZName --
- *
- *	Gets the current timezone string.
- *
- * Results:
- *	Returns a pointer to a static string, or NULL on failure.
- *
- * Side effects:
- *	None.
- *
- *----------------------------------------------------------------------
- */
-
-char *
-TclpGetTZName(
-    int dst)
-{
-    int len;
-    char *zone, *p;
-    TIME_ZONE_INFORMATION tz;
-    Tcl_Encoding encoding;
-    ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
-    char *name = tsdPtr->tzName;
-
-    /*
-     * tzset() under Borland doesn't seem to set up tzname[] at all.
-     * tzset() under MSVC has the following weird observed behavior:
-     *	 First time we call "clock format [clock seconds] -format %Z -gmt 1"
-     *	 we get "GMT", but on all subsequent calls we get the current time
-     *	 ezone string, even though env(TZ) is GMT and the variable _timezone
-     *	 is 0.
-     */
-
-    name[0] = '\0';
-
-    zone = getenv("TZ");
-    if (zone != NULL) {
-	/*
-	 * TZ is of form "NST-4:30NDT", where "NST" would be the name of the
-	 * standard time zone for this area, "-4:30" is the offset from GMT in
-	 * hours, and "NDT is the name of the daylight savings time zone in
-	 * this area. The offset and DST strings are optional.
-	 */
-
-	len = strlen(zone);
-	if (len > 3) {
-	    len = 3;
-	}
-	if (dst != 0) {
-	    /*
-	     * Skip the offset string and get the DST string.
-	     */
-
-	    p = zone + len;
-	    p += strspn(p, "+-:0123456789");
-	    if (*p != '\0') {
-		zone = p;
-		len = strlen(zone);
-		if (len > 3) {
-		    len = 3;
-		}
-	    }
-	}
-	Tcl_ExternalToUtf(NULL, NULL, zone, len, 0, NULL, name,
-		sizeof(tsdPtr->tzName), NULL, NULL, NULL);
-    }
-    if (name[0] == '\0') {
-	if (GetTimeZoneInformation(&tz) == TIME_ZONE_ID_UNKNOWN) {
-	    /*
-	     * MSDN: On NT this is returned if DST is not used in the current
-	     * TZ
-	     */
-
-	    dst = 0;
-	}
-	encoding = Tcl_GetEncoding(NULL, "unicode");
-	Tcl_ExternalToUtf(NULL, encoding,
-		(char *) ((dst) ? tz.DaylightName : tz.StandardName), -1,
-		0, NULL, name, sizeof(tsdPtr->tzName), NULL, NULL, NULL);
-	Tcl_FreeEncoding(encoding);
-    }
-    return name;
-}
-
-/*
- *----------------------------------------------------------------------
- *
  * TclpGetDate --
  *
  *	This function converts between seconds and struct tm. If useGMT is
-- 
cgit v0.12


From 75978a26daf2595c582c0177de45b97dd19b4af8 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 4 Apr 2012 10:51:02 +0000
Subject: Added characterisation of Bug 3514761; currently knownBug...

---
 tests/oo.test | 16 ++++++++++++++++
 1 file changed, 16 insertions(+)

diff --git a/tests/oo.test b/tests/oo.test
index 150bc97..ccea42a 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -337,6 +337,22 @@ test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup {
 } -cleanup {
     foo destroy
 } -result good
+test oo-2.7 {construction, method calls and ensembles - Bug 3514761} -setup {
+    namespace eval k {}
+} -constraints knownBug -body {
+    namespace eval k {
+	oo::class create s {
+	    constructor {j} {
+		# nothing
+	    }
+	}
+	namespace export s
+	namespace ensemble create
+    }
+    k s create X
+} -returnCodes error -cleanup {
+    namespace delete k
+} -result {wrong # args: should be "k s create X j"}
 
 test oo-3.1 {basic test of OO functionality: destructor} -setup {
     # This is a bit complex because it needs to run in a sub-interp as we're
-- 
cgit v0.12


From f9c97ea67073aa3e2fa22b80e826b3d491e3440c Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 4 Apr 2012 20:51:06 +0000
Subject: Fix [Bug 3514761] and related ensemble/construction problems.

---
 ChangeLog       | 16 +++++++++++++---
 generic/tclOO.c | 23 +++++++++++++++++++++++
 tests/oo.test   | 36 +++++++++++++++++++++++++++++++++++-
 3 files changed, 71 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index bb3f9f0..4c961d0 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,6 +1,16 @@
+2012-04-04  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance):
+	[Bug 3514761]: Fixed bogosity with automated argument description
+	handling when constructing an instance of a class that is itself a
+	member of an ensemble. Thanks to Andreas Kupries for identifying that
+	this was a problem case at all!
+	(Tcl_CopyObjectInstance): Fix potential bleed-over of ensemble
+	information into [oo::copy].
+
 2012-04-04  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinSock.c:     [Bug 510001]: TclSockMinimumBuffers needs plat imp
+	* win/tclWinSock.c: [Bug 510001]: TclSockMinimumBuffers needs plat imp
 	* generic/tclIOSock.c:
 	* generic/tclInt.decls:
 	* generic/tclIntDecls.h:
@@ -8,8 +18,8 @@
 
 2012-04-03  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclStubInit.c      Remove the TclpGetTZName implementation for
-	* generic/tclIntDecls.h:     Cygwin (from 2012-04-02 commit) , re-generated
+	* generic/tclStubInit.c: Remove the TclpGetTZName implementation for
+	* generic/tclIntDecls.h: Cygwin (from 2012-04-02 commit), re-generated
 	* generic/tclIntPlatDecls.h:
 
 2012-04-02  Donal K. Fellows  <dkf@users.sf.net>
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 9dd8162..1d1276d 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1624,6 +1624,15 @@ Tcl_NewObjectInstance(
 	    state = Tcl_SaveInterpState(interp, TCL_OK);
 	    contextPtr->callPtr->flags |= CONSTRUCTOR;
 	    contextPtr->skip = skip;
+
+	    /*
+	     * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+	     */
+
+	    if (((Interp*) interp)->ensembleRewrite.sourceObjs) {
+		((Interp*) interp)->ensembleRewrite.numInsertedObjs += skip-1;
+		((Interp*) interp)->ensembleRewrite.numRemovedObjs += skip-1;
+	    }
 	    result = Tcl_NRCallObjProc(interp, TclOOInvokeContext, contextPtr,
 		    objc, objv);
 
@@ -1742,6 +1751,15 @@ TclNRNewObjectInstance(
     contextPtr->skip = skip;
 
     /*
+     * Adjust the ensmble tracking record if necessary. [Bug 3514761]
+     */
+
+    if (((Interp *) interp)->ensembleRewrite.sourceObjs) {
+	((Interp *) interp)->ensembleRewrite.numInsertedObjs += skip - 1;
+	((Interp *) interp)->ensembleRewrite.numRemovedObjs += skip - 1;
+    }
+
+    /*
      * Fire off the constructors non-recursively.
      */
 
@@ -2050,6 +2068,7 @@ Tcl_CopyObjectInstance(
 	}
     }
 
+    TclResetRewriteEnsemble(interp, 1);
     contextPtr = TclOOGetCallContext(o2Ptr, oPtr->fPtr->clonedName, 0, NULL);
     if (contextPtr) {
 	args[0] = TclOOObjectName(interp, o2Ptr);
@@ -2064,6 +2083,10 @@ Tcl_CopyObjectInstance(
 	TclDecrRefCount(args[1]);
 	TclDecrRefCount(args[2]);
 	TclOODeleteContext(contextPtr);
+	if (result == TCL_ERROR) {
+	    Tcl_AddErrorInfo(interp,
+		    "\n    (while performing post-copy callback)");
+	}
 	if (result != TCL_OK) {
 	    Tcl_DeleteCommandFromToken(interp, o2Ptr->command);
 	    return NULL;
diff --git a/tests/oo.test b/tests/oo.test
index ccea42a..8c5aeb3 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -339,7 +339,7 @@ test oo-2.6 {OO constructor and tailcall - Bug 2414858} -setup {
 } -result good
 test oo-2.7 {construction, method calls and ensembles - Bug 3514761} -setup {
     namespace eval k {}
-} -constraints knownBug -body {
+} -body {
     namespace eval k {
 	oo::class create s {
 	    constructor {j} {
@@ -353,6 +353,29 @@ test oo-2.7 {construction, method calls and ensembles - Bug 3514761} -setup {
 } -returnCodes error -cleanup {
     namespace delete k
 } -result {wrong # args: should be "k s create X j"}
+test oo-2.8 {construction, method calls and ensembles - Bug 3514761} -setup {
+    namespace eval k {}
+} -body {
+    namespace eval k {
+	oo::class create s {
+	    constructor {j} {
+		# nothing
+	    }
+	}
+	oo::class create t {
+	    superclass s
+	    constructor args {
+		k next {*}$args
+	    }
+	}
+	interp alias {} ::k::next {} ::oo::Helpers::next
+	namespace export t next
+	namespace ensemble create
+    }
+    k t create X
+} -returnCodes error -cleanup {
+    namespace delete k
+} -result {wrong # args: should be "k next j"}
 
 test oo-3.1 {basic test of OO functionality: destructor} -setup {
     # This is a bit complex because it needs to run in a sub-interp as we're
@@ -1742,6 +1765,17 @@ test oo-15.8 {OO: intercept object cloning} -setup {
 } -cleanup {
     Foo destroy
 } -result {cloned ::foo ::bar check ::foo ok check ::bar ok}
+test oo-15.9 {ensemble rewriting must not bleed through oo::copy} -setup {
+    oo::class create Foo
+} -body {
+    oo::define Foo {
+	method <cloned> {a b} {}
+    }
+    interp alias {} Bar {} oo::copy [Foo create foo]
+    Bar bar
+} -returnCodes error -cleanup {
+    Foo destroy
+} -result {wrong # args: should be "::bar <cloned> a b"}
 
 test oo-16.1 {OO: object introspection} -body {
     info object
-- 
cgit v0.12


From 32dda4af9bc7d9e23f8dc6722d26609e4714a470 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 5 Apr 2012 07:07:10 +0000
Subject: cygwin should use SetEnvironmentVariable for windows env

---
 generic/tclEnv.c  | 23 ++++++-----------------
 generic/tclPort.h |  7 +++++--
 2 files changed, 11 insertions(+), 19 deletions(-)

diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index a516cce..24fa106 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -45,11 +45,8 @@ MODULE_SCOPE void	TclSetEnv(const char *name, const char *value);
 MODULE_SCOPE void	TclUnsetEnv(const char *name);
 
 #if defined(__CYGWIN__)
-/* On Cygwin, the environment is imported from the Cygwin DLL. */
-     DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value);
-     DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value);
-#    define putenv TclCygwinPutenv
-static void		TclCygwinPutenv(char *string);
+    static void TclCygwinPutenv(char *string);
+#   define putenv TclCygwinPutenv
 #endif
 
 /*
@@ -753,15 +750,11 @@ TclCygwinPutenv(
 	 */
 
 	if (strcmp(name, "Path") == 0) {
-#ifdef __WIN32__
-	    SetEnvironmentVariable("PATH", NULL);
-#endif
+	    SetEnvironmentVariableA("PATH", NULL);
 	    unsetenv("PATH");
 	}
 
-#ifdef __WIN32__
-	SetEnvironmentVariable(name, value);
-#endif
+	SetEnvironmentVariableA(name, value);
     } else {
 	char *buf;
 
@@ -769,9 +762,7 @@ TclCygwinPutenv(
 	 * Eliminate any Path variable, to prevent any confusion.
 	 */
 
-#ifdef __WIN32__
-	SetEnvironmentVariable("Path", NULL);
-#endif
+	SetEnvironmentVariableA("Path", NULL);
 	unsetenv("Path");
 
 	if (value == NULL) {
@@ -784,9 +775,7 @@ TclCygwinPutenv(
 	    cygwin_posix_to_win32_path_list(value, buf);
 	}
 
-#ifdef __WIN32__
-	SetEnvironmentVariable(name, buf);
-#endif
+	SetEnvironmentVariableA(name, buf);
     }
 }
 #endif /* __CYGWIN__ */
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 23c6191..79bea88 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -29,10 +29,13 @@
 #   define USE_PUTENV 1
 #   define USE_PUTENV_FOR_UNSET 1
 /* On Cygwin, the environment is imported from the Cygwin DLL. */
-    DLLIMPORT extern char **__cygwin_environ;
-    DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *);
 #   define environ __cygwin_environ
 #   define timezone _timezone
+    DLLIMPORT extern char **__cygwin_environ;
+    DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *);
+    DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value);
+    DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value);
+    DLLIMPORT extern void __stdcall SetEnvironmentVariableA(const char*, const char *);
 #endif
 
 #if !defined(LLONG_MIN)
-- 
cgit v0.12


From f19dc488c7222a8e782fd227736f0d440c806bc4 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 5 Apr 2012 09:34:56 +0000
Subject: Reduce amount of unreachable code. Refactor Win socket and load code
 to be less baroque in its internals.

---
 generic/tclEnsemble.c    |   6 -
 generic/tclFileName.c    |  76 ++-------
 generic/tclHash.c        |   4 +-
 generic/tclIOSock.c      |  12 +-
 generic/tclLoad.c        |  32 +---
 generic/tclOOInt.h       |  15 --
 generic/tclThreadAlloc.c |   8 -
 generic/tclUtil.c        |  11 --
 generic/tclVar.c         |   4 +-
 win/tclWinLoad.c         | 229 ++++++++++++++-------------
 win/tclWinSock.c         | 399 +++++++++++++++++++++--------------------------
 11 files changed, 324 insertions(+), 472 deletions(-)

diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index 1283446..f33ad31 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -1823,11 +1823,6 @@ NsEnsembleImplementationCmdNR(
 	 * count both as inserted and removed arguments.
 	 */
 
-#if 0
-	if (TclInitRewriteEnsemble(interp, 2 + ensemblePtr->numParameters, prefixObjc + ensemblePtr->numParameters, objv)) {
-	    TclNRAddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL);
-	}
-#else
 	if (iPtr->ensembleRewrite.sourceObjs == NULL) {
 	    iPtr->ensembleRewrite.sourceObjs = objv;
 	    iPtr->ensembleRewrite.numRemovedObjs =
@@ -1848,7 +1843,6 @@ NsEnsembleImplementationCmdNR(
 		iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2;
 	    }
 	}
-#endif
 
 	/*
 	 * Hand off to the target command.
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index 90bf8d1..b6b89dd 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -2160,67 +2160,6 @@ DoGlob(
     }
 
     /*
-     * This block of code is not exercised by the Tcl test suite as of Tcl
-     * 8.5a0. Simplifications to the calling paths suggest it may not be
-     * necessary any more, since path separators are handled elsewhere. It is
-     * left in place in case new bugs are reported.
-     */
-
-#if 0 /* PROBABLY_OBSOLETE */
-    /*
-     * Deal with path separators.
-     */
-
-    if (pathPtr == NULL) {
-	/*
-	 * Length used to be the length of the prefix, and lastChar the
-	 * lastChar of the prefix. But, none of this is used any more.
-	 */
-
-	int length = 0;
-	char lastChar = 0;
-
-	switch (tclPlatform) {
-	case TCL_PLATFORM_WINDOWS:
-	    /*
-	     * If this is a drive relative path, add the colon and the
-	     * trailing slash if needed. Otherwise add the slash if this is
-	     * the first absolute element, or a later relative element. Add an
-	     * extra slash if this is a UNC path.
-	     */
-
-	    if (*name == ':') {
-		Tcl_DStringAppend(&append, ":", 1);
-		if (count > 1) {
-		    Tcl_DStringAppend(&append, "/", 1);
-		}
-	    } else if ((*pattern != '\0') && (((length > 0)
-		    && (strchr(separators, lastChar) == NULL))
-		    || ((length == 0) && (count > 0)))) {
-		Tcl_DStringAppend(&append, "/", 1);
-		if ((length == 0) && (count > 1)) {
-		    Tcl_DStringAppend(&append, "/", 1);
-		}
-	    }
-
-	    break;
-	case TCL_PLATFORM_UNIX:
-	    /*
-	     * Add a separator if this is the first absolute element, or a
-	     * later relative element.
-	     */
-
-	    if ((*pattern != '\0') && (((length > 0)
-		    && (strchr(separators, lastChar) == NULL))
-		    || ((length == 0) && (count > 0)))) {
-		Tcl_DStringAppend(&append, "/", 1);
-	    }
-	    break;
-	}
-    }
-#endif /* PROBABLY_OBSOLETE */
-
-    /*
      * Look for the first matching pair of braces or the first directory
      * separator that is not inside a pair of braces.
      */
@@ -2278,8 +2217,8 @@ DoGlob(
 
     if (openBrace != NULL) {
 	char *element;
-
 	Tcl_DString newName;
+
 	Tcl_DStringInit(&newName);
 
 	/*
@@ -2328,12 +2267,13 @@ DoGlob(
      */
 
     if (*p != '\0') {
+	char savedChar = *p;
+
 	/*
 	 * Note that we are modifying the string in place. This won't work if
 	 * the string is a static.
 	 */
 
-	char savedChar = *p;
 	*p = '\0';
 	firstSpecialChar = strpbrk(pattern, "*[]?\\");
 	*p = savedChar;
@@ -2398,6 +2338,7 @@ DoGlob(
 			const char *bytes;
 			int numBytes;
 			Tcl_Obj *fixme, *newObj;
+
 			Tcl_ListObjIndex(NULL, matchesObj, repair, &fixme);
 			bytes = Tcl_GetStringFromObj(fixme, &numBytes);
 			newObj = Tcl_NewStringObj(bytes+2, numBytes-2);
@@ -2418,6 +2359,9 @@ DoGlob(
      */
 
     if (*p == '\0') {
+	int length;
+	Tcl_DString append;
+
 	/*
 	 * This is the code path reached by a command like 'glob foo'.
 	 *
@@ -2430,9 +2374,6 @@ DoGlob(
 	 * approach).
 	 */
 
-	int length;
-	Tcl_DString append;
-
 	Tcl_DStringInit(&append);
 	Tcl_DStringAppend(&append, pattern, p-pattern);
 
@@ -2464,8 +2405,9 @@ DoGlob(
 		}
 	    }
 #if defined(__CYGWIN__) && !defined(__WIN32__)
-	    DLLIMPORT extern int cygwin_conv_to_posix_path(const char *, char *);
 	    {
+		DLLIMPORT extern int cygwin_conv_to_posix_path(const char *,
+			char *);
 		char winbuf[MAXPATHLEN+1];
 
 		cygwin_conv_to_posix_path(Tcl_DStringValue(&append), winbuf);
diff --git a/generic/tclHash.c b/generic/tclHash.c
index c8dc939..90be511 100644
--- a/generic/tclHash.c
+++ b/generic/tclHash.c
@@ -46,7 +46,9 @@ static int		CompareArrayKeys(void *keyPtr, Tcl_HashEntry *hPtr);
 static unsigned int	HashArrayKey(Tcl_HashTable *tablePtr, void *keyPtr);
 
 /*
- * Prototypes for the one word hash key methods.
+ * Prototypes for the one word hash key methods. Not actually declared because
+ * this is a critical path that is implemented in the core hash table access
+ * function.
  */
 
 #if 0
diff --git a/generic/tclIOSock.c b/generic/tclIOSock.c
index 6921af4..7b7b647 100644
--- a/generic/tclIOSock.c
+++ b/generic/tclIOSock.c
@@ -177,6 +177,7 @@ TclCreateSocketAddress(
     }
 
     hints.ai_socktype = SOCK_STREAM;
+
 #if 0
     /*
      * We found some problems when using AI_ADDRCONFIG, e.g. on systems that
@@ -184,15 +185,16 @@ TclCreateSocketAddress(
      * localhost. See bugs 3385024, 3382419, 3382431. As the advantage of
      * using AI_ADDRCONFIG in situations where it works, is probably low,
      * we'll leave it out for now. After all, it is just an optimisation.
-     */
-#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux)
-    /*
+     *
      * Missing on: OpenBSD, NetBSD.
      * Causes failure when used on AIX 5.1 and HP-UX
      */
+
+#if defined(AI_ADDRCONFIG) && !defined(_AIX) && !defined(__hpux)
     hints.ai_flags |= AI_ADDRCONFIG;
-#endif
-#endif
+#endif /* AI_ADDRCONFIG && !_AIX && !__hpux */
+#endif /* 0 */
+
     if (willBind) {
 	hints.ai_flags |= AI_PASSIVE;
     } 
diff --git a/generic/tclLoad.c b/generic/tclLoad.c
index 202e66a..008a99d 100644
--- a/generic/tclLoad.c
+++ b/generic/tclLoad.c
@@ -873,40 +873,10 @@ Tcl_UnloadObjCmd(
   done:
     Tcl_DStringFree(&pkgName);
     Tcl_DStringFree(&tmp);
-    if (!complain && code!=TCL_OK) {
+    if (!complain && (code != TCL_OK)) {
 	code = TCL_OK;
 	Tcl_ResetResult(interp);
     }
-    if (code == TCL_OK) {
-#if 0
-	/*
-	 * Result of [unload] was not documented in TIP#100, so force to be
-	 * the empty string by commenting this out. DKF.
-	 */
-
-	Tcl_Obj *resultObjPtr, *objPtr[2];
-
-	/*
-	 * Our result is the two reference counts.
-	 */
-
-	TclNewIntObj(objPtr[0], trustedRefCount);
-	TclNewIntObj(objPtr[1], safeRefCount);
-	if (objPtr[0] == NULL || objPtr[1] == NULL) {
-	    if (objPtr[0]) {
-		Tcl_DecrRefCount(objPtr[0]);
-	    }
-	    if (objPtr[1]) {
-		Tcl_DecrRefCount(objPtr[1]);
-	    }
-	} else {
-	    TclNewListObj(resultObjPtr, 2, objPtr);
-	    if (resultObjPtr != NULL) {
-		Tcl_SetObjResult(interp, resultObjPtr);
-	    }
-	}
-#endif
-    }
     return code;
 }
 
diff --git a/generic/tclOOInt.h b/generic/tclOOInt.h
index 2d6f324..7988452 100644
--- a/generic/tclOOInt.h
+++ b/generic/tclOOInt.h
@@ -381,21 +381,6 @@ typedef struct CallContext {
 #define DESTRUCTOR	  0x10	/* This is a destructor. */
 
 /*
- * Assorted flags for call frames. Note that bits 1 and 2 are already taken by
- * Tcl itself.
- */
-
-#if 0
-#define FRAME_IS_METHOD	0x4	/* The frame is a method body, and the frame's
-				 * clientData field contains a CallContext
-				 * reference. */
-#define FRAME_IS_OO_DEFINE 0x8	/* The frame is part of the inside workings of
-				 * the [oo::define] command; the clientData
-				 * field contains an Object reference that has
-				 * been confirmed to refer to a class. */
-#endif
-
-/*
  * Structure containing definition information about basic class methods.
  */
 
diff --git a/generic/tclThreadAlloc.c b/generic/tclThreadAlloc.c
index ad1d510..e4261d6 100644
--- a/generic/tclThreadAlloc.c
+++ b/generic/tclThreadAlloc.c
@@ -812,15 +812,7 @@ LockBucket(
     Cache *cachePtr,
     int bucket)
 {
-#if 0
-    if (Tcl_MutexTryLock(bucketInfo[bucket].lockPtr) != TCL_OK) {
-	Tcl_MutexLock(bucketInfo[bucket].lockPtr);
-	cachePtr->buckets[bucket].numWaits++;
-	sharedPtr->buckets[bucket].numWaits++;
-    }
-#else
     Tcl_MutexLock(bucketInfo[bucket].lockPtr);
-#endif
     cachePtr->buckets[bucket].numLocks++;
     sharedPtr->buckets[bucket].numLocks++;
 }
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index 6ce430b..a1c1996 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -4121,20 +4121,9 @@ TclReToGlob(
 	*exactPtr = (anchorLeft && anchorRight);
     }
 
-#if 0
-    fprintf(stderr, "INPUT RE '%.*s' OUTPUT GLOB '%s' anchor %d:%d \n",
-	    reStrLen, reStr,
-	    Tcl_DStringValue(dsPtr), anchorLeft, anchorRight);
-    fflush(stderr);
-#endif
     return TCL_OK;
 
   invalidGlob:
-#if 0
-    fprintf(stderr, "INPUT RE '%.*s' NO OUTPUT GLOB %s (%c)\n",
-	    reStrLen, reStr, msg, *p);
-    fflush(stderr);
-#endif
     if (interp != NULL) {
 	Tcl_AppendResult(interp, msg, NULL);
 	Tcl_SetErrorCode(interp, "TCL", "RE2GLOB", code, NULL);
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 4df5d43..1bf4abc 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -762,7 +762,7 @@ TclObjLookupVarEx(
     }
 
   donePart1:
-#if 0
+#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */
     if (varPtr == NULL) {
 	if (flags & TCL_LEAVE_ERR_MSG) {
 	    part1 = TclGetString(part1Ptr);
@@ -1892,7 +1892,7 @@ TclPtrSetVar(
 	varPtr->value.objPtr = NULL;
     }
     if (flags & (TCL_APPEND_VALUE|TCL_LIST_ELEMENT)) {
-#if 0
+#if 0 /* ENABLE_NS_VARNAME_CACHING perhaps? */
 	/*
 	 * Can't happen now!
 	 */
diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index 3f4d4d9..5848daa 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -14,24 +14,22 @@
 #include "tclWinInt.h"
 
 /*
- * Mutex protecting static data in this file;
+ * Native name of the directory in the native filesystem where DLLs used in
+ * this process are copied prior to loading, and mutex used to protect its
+ * allocation.
  */
 
-static Tcl_Mutex loadMutex;
+static WCHAR *dllDirectoryName = NULL;
+static Tcl_Mutex dllDirectoryNameMutex;
 
 /*
- * Name of the directory in the native filesystem where DLLs used in this
- * process are copied prior to loading.
+ * Static functions defined within this file.
  */
 
-static WCHAR* dllDirectoryName = NULL;
-
-/* Static functions defined within this file */
-
-void* FindSymbol(Tcl_Interp* interp, Tcl_LoadHandle loadHandle,
-		 const char* symbol);
-void UnloadFile(Tcl_LoadHandle loadHandle);
-
+static void *		FindSymbol(Tcl_Interp *interp,
+			    Tcl_LoadHandle loadHandle, const char *symbol);
+static void		InitDLLDirectoryName(void);
+static void		UnloadFile(Tcl_LoadHandle loadHandle);
 
 /*
  *----------------------------------------------------------------------
@@ -75,8 +73,7 @@ TclpDlopen(
      */
 
     nativeName = Tcl_FSGetNativePath(pathPtr);
-    hInstance = LoadLibraryEx(nativeName, NULL,
-	    LOAD_WITH_ALTERED_SEARCH_PATH);
+    hInstance = LoadLibraryEx(nativeName,NULL,LOAD_WITH_ALTERED_SEARCH_PATH);
     if (hInstance == NULL) {
 	/*
 	 * Let the OS loader examine the binary search path for whatever
@@ -85,9 +82,8 @@ TclpDlopen(
 	 */
 
 	Tcl_DString ds;
-	const char *fileName = Tcl_GetString(pathPtr);
 
-	nativeName = Tcl_WinUtfToTChar(fileName, -1, &ds);
+	nativeName = Tcl_WinUtfToTChar(Tcl_GetString(pathPtr), -1, &ds);
 	hInstance = LoadLibraryEx(nativeName, NULL,
 		LOAD_WITH_ALTERED_SEARCH_PATH);
 	Tcl_DStringFree(&ds);
@@ -96,23 +92,6 @@ TclpDlopen(
     if (hInstance == NULL) {
 	DWORD lastError = GetLastError();
 
-#if 0
-	/*
-	 * It would be ideal if the FormatMessage stuff worked better, but
-	 * unfortunately it doesn't seem to want to...
-	 */
-
-	LPTSTR lpMsgBuf;
-	char *buf;
-	int size;
-
-	size = FormatMessage(FORMAT_MESSAGE_FROM_SYSTEM |
-		FORMAT_MESSAGE_ALLOCATE_BUFFER, NULL, lastError, 0,
-		(LPTSTR) &lpMsgBuf, 0, NULL);
-	buf = ckalloc(TCL_INTEGER_SPACE + size + 1);
-	sprintf(buf, "%d %s", lastError, (char *)lpMsgBuf);
-#endif
-
 	Tcl_AppendResult(interp, "couldn't load library \"",
 		Tcl_GetString(pathPtr), "\": ", NULL);
 
@@ -185,24 +164,25 @@ TclpDlopen(
  *----------------------------------------------------------------------
  */
 
-void *
+static void *
 FindSymbol(
     Tcl_Interp *interp,
     Tcl_LoadHandle loadHandle,
     const char *symbol)
 {
+    HINSTANCE hInstance = (HINSTANCE) loadHandle->clientData;
     Tcl_PackageInitProc *proc = NULL;
-    HINSTANCE hInstance = (HINSTANCE)(loadHandle->clientData);
 
     /*
      * For each symbol, check for both Symbol and _Symbol, since Borland
      * generates C symbols with a leading '_' by default.
      */
 
-    proc = (void*) GetProcAddress(hInstance, symbol);
+    proc = (void *) GetProcAddress(hInstance, symbol);
     if (proc == NULL) {
 	Tcl_DString ds;
-	const char* sym2;
+	const char *sym2;
+
 	Tcl_DStringInit(&ds);
 	Tcl_DStringAppend(&ds, "_", 1);
 	sym2 = Tcl_DStringAppend(&ds, symbol, -1);
@@ -234,7 +214,7 @@ FindSymbol(
  *----------------------------------------------------------------------
  */
 
-void
+static void
 UnloadFile(
     Tcl_LoadHandle loadHandle)	/* loadHandle returned by a previous call to
 				 * TclpDlopen(). The loadHandle is a token
@@ -277,7 +257,7 @@ TclGuessPackageName(
 }
 
 /*
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
  *
  * TclpTempFileNameForLibrary --
  *
@@ -287,86 +267,125 @@ TclGuessPackageName(
  *	Returns the constructed file name.
  *
  * On Windows, a DLL is identified by the final component of its path name.
- * Cross linking among DLL's (and hence, preloading) will not work unless
- * this name is preserved when copying a DLL from a VFS to a temp file for
- * preloading. For this reason, all DLLs in a given process are copied
- * to a temp directory, and their names are preserved.
+ * Cross linking among DLL's (and hence, preloading) will not work unless this
+ * name is preserved when copying a DLL from a VFS to a temp file for
+ * preloading. For this reason, all DLLs in a given process are copied to a
+ * temp directory, and their names are preserved.
  *
- *-----------------------------------------------------------------------------
+ *----------------------------------------------------------------------
  */
 
-Tcl_Obj*
-TclpTempFileNameForLibrary(Tcl_Interp* interp, /* Tcl interpreter */
-			   Tcl_Obj* path)      /* Path name of the DLL in
-						* the VFS */
+Tcl_Obj *
+TclpTempFileNameForLibrary(
+    Tcl_Interp *interp,		/* Tcl interpreter. */
+    Tcl_Obj *path)		/* Path name of the DLL in the VFS. */
 {
-    size_t nameLen;		/* Length of the temp folder name */
-    WCHAR name[MAX_PATH];	/* Path name of the temp folder */
-    BOOL status;		/* Status from Win32 API calls */
-    Tcl_Obj* fileName;		/* Name of the temp file */
-    Tcl_Obj* tail;		/* Tail of the source path */
+    Tcl_Obj *fileName;		/* Name of the temp file. */
+    Tcl_Obj *tail;		/* Tail of the source path. */
 
-    /*
-     * Determine the name of the directory to use, and create it.
-     * (Keep trying with new names until an attempt to create the directory
-     * succeeds)
-     */
-
-    nameLen = 0;
+    Tcl_MutexLock(&dllDirectoryNameMutex);
     if (dllDirectoryName == NULL) {
-	Tcl_MutexLock(&loadMutex);
-	if (dllDirectoryName == NULL) {
-	    nameLen = GetTempPathW(MAX_PATH, name);
-	    if (nameLen >= MAX_PATH-12) {
-		Tcl_SetErrno(ENAMETOOLONG);
-		nameLen = 0;
-	    } else {
-		wcscpy(name+nameLen, L"TCLXXXXXXXX");
-		nameLen += 11;
-	    }
-	    status = 1;
-	    if (nameLen != 0) {
-		DWORD id;
-		int i = 0;
-		id = GetCurrentProcessId();
-		for (;;) {
-		    DWORD lastError;
-		    wsprintfW(name+nameLen-8, L"%08x", id);
-		    status = CreateDirectoryW(name, NULL);
-		    if (status) {
-			break;
-		    }
-		    if ((lastError = GetLastError()) != ERROR_ALREADY_EXISTS) {
-			TclWinConvertError(lastError);
-			break;
-		    } else if (++i > 256) {
-			TclWinConvertError(lastError);
-			break;
-		    }
-		    id *= 16777619;
-		}
-	    }
-	    if (status != 0) {
-		dllDirectoryName = ckalloc((nameLen+1) * sizeof(WCHAR));
-		wcscpy(dllDirectoryName, name);
-	    }
+	if (InitDLLDirectoryName() == TCL_ERROR) {
+	    Tcl_AppendResult(interp, "couldn't create temporary directory: ",
+		    Tcl_PosixError(interp), NULL);
+	    Tcl_MutexUnlock(&dllDirectoryNameMutex);
+	    return NULL;
 	}
-	Tcl_MutexUnlock(&loadMutex);
-    }
-    if (dllDirectoryName == NULL) {
-	Tcl_AppendResult(interp, "couldn't create temporary directory: ",
-		Tcl_PosixError(interp), NULL);
     }
+    Tcl_MutexUnlock(&dllDirectoryNameMutex);
+
+    /*
+     * Now we know where to put temporary DLLs, construct the name.
+     */
+
     fileName = TclpNativeToNormalized(dllDirectoryName);
     tail = TclPathPart(interp, path, TCL_PATH_TAIL);
     if (tail == NULL) {
 	Tcl_DecrRefCount(fileName);
 	return NULL;
-    } else {
-	Tcl_AppendToObj(fileName, "/", 1);
-	Tcl_AppendObjToObj(fileName, tail);
-	return fileName;
     }
+    Tcl_AppendToObj(fileName, "/", 1);
+    Tcl_AppendObjToObj(fileName, tail);
+    return fileName;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitDLLDirectoryName --
+ *
+ *	Helper for TclpTempFileNameForLibrary; builds a temporary directory
+ *	that is specific to the current process. Should only be called once
+ *	per process start. Caller must hold dllDirectoryNameMutex.
+ *
+ * Results:
+ *	Tcl result code.
+ *
+ * Side-effects:
+ *	Creates temp directory.
+ *	Allocates memory pointed to by dllDirectoryName.
+ *
+ *----------------------------------------------------------------------
+ * [Candidate for process global?]
+ */
+
+static int
+InitDLLDirectoryName(void)
+{
+    size_t nameLen;		/* Length of the temp folder name. */
+    WCHAR name[MAX_PATH];	/* Path name of the temp folder. */
+    DWORD id;			/* The process id. */
+    DWORD lastError;		/* Last error to happen in Win API. */
+    int i;
+
+    /*
+     * Determine the name of the directory to use, and create it.  (Keep
+     * trying with new names until an attempt to create the directory
+     * succeeds)
+     */
+
+    nameLen = GetTempPathW(MAX_PATH, name);
+    if (nameLen >= MAX_PATH-12) {
+	Tcl_SetErrno(ENAMETOOLONG);
+	return TCL_ERROR;
+    }
+
+    wcscpy(name+nameLen, L"TCLXXXXXXXX");
+    nameLen += 11;
+
+    id = GetCurrentProcessId();
+    lastError = ERROR_ALREADY_EXISTS;
+
+    for (i=0 ; i<256 ; i++) {
+	wsprintfW(name+nameLen-8, L"%08x", id);
+	if (CreateDirectoryW(name, NULL)) {
+	    /*
+	     * Issue: we don't schedule this directory for deletion by anyone.
+	     * Can we ask the OS to do this for us?  There appears to be
+	     * potential for using CreateFile (with the flag
+	     * FILE_FLAG_BACKUP_SEMANTICS) and RemoveDirectory to do this...
+	     */
+
+	    goto copyToGlobalBuffer;
+	}
+	lastError = GetLastError();
+	if (lastError != ERROR_ALREADY_EXISTS) {
+	    break;
+	}
+	id *= 16777619;
+    }
+
+    TclWinConvertError(lastError);
+    return TCL_ERROR;
+
+    /*
+     * Store our computed value in the global.
+     */
+
+  copyToGlobalBuffer:
+    dllDirectoryName = ckalloc((nameLen+1) * sizeof(WCHAR));
+    wcscpy(dllDirectoryName, name);
+    return TCL_OK;
 }
 
 /*
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index cbaedcb..2f14c17 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -47,6 +47,13 @@
 
 #include "tclWinInt.h"
 
+/*
+ * Which version of the winsock API do we want?
+ */
+
+#define WSA_VERSION_MAJOR	1
+#define WSA_VERSION_MINOR	1
+
 #ifdef _MSC_VER
 #   pragma comment (lib, "ws2_32")
 #endif
@@ -91,16 +98,17 @@ static ProcessGlobalValue hostName = {
  * The following defines declare the messages used on socket windows.
  */
 
-#define SOCKET_MESSAGE	    WM_USER+1
-#define SOCKET_SELECT	    WM_USER+2
-#define SOCKET_TERMINATE    WM_USER+3
-#define SELECT		    TRUE
-#define UNSELECT	    FALSE
+#define SOCKET_MESSAGE		WM_USER+1
+#define SOCKET_SELECT		WM_USER+2
+#define SOCKET_TERMINATE	WM_USER+3
+#define SELECT			TRUE
+#define UNSELECT		FALSE
 
 /*
  * This is needed to comply with the strict aliasing rules of GCC, but it also
  * simplifies casting between the different sockaddr types.
  */
+
 typedef union {
     struct sockaddr sa;
     struct sockaddr_in sa4;
@@ -206,10 +214,6 @@ static WNDCLASS windowClass;
 static SocketInfo *	CreateSocket(Tcl_Interp *interp, int port,
 			    const char *host, int server, const char *myaddr,
 			    int myport, int async);
-#if 0
-static int		CreateSocketAddress(LPSOCKADDR_IN sockaddrPtr,
-			    const char *host, int port);
-#endif
 static void		InitSockets(void);
 static SocketInfo *	NewSocketInfo(SOCKET socket);
 static void		SocketExitHandler(ClientData clientData);
@@ -284,9 +288,8 @@ static const Tcl_ChannelType tcpChannelType = {
 static void
 InitSockets(void)
 {
-    DWORD id;
+    DWORD id, err;
     WSADATA wsaData;
-    DWORD err;
     ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
     if (!initialized) {
@@ -322,11 +325,8 @@ InitSockets(void)
 	 * that it not be less than 1.1.
 	 */
 
-#define WSA_VERSION_MAJOR 1
-#define WSA_VERSION_MINOR 1
-#define WSA_VERSION_REQD  MAKEWORD(WSA_VERSION_MAJOR, WSA_VERSION_MINOR)
-
-	err = WSAStartup((WORD)WSA_VERSION_REQD, &wsaData);
+	err = WSAStartup((WORD) MAKEWORD(WSA_VERSION_MAJOR,WSA_VERSION_MINOR),
+		&wsaData);
 	if (err != 0) {
 	    TclWinConvertError(err);
 	    goto initFailure;
@@ -334,8 +334,8 @@ InitSockets(void)
 
 	/*
 	 * Note the byte positions ae swapped for the comparison, so that
-	 * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1).
-	 * We want the comparison to be 0x0200 < 0x0101.
+	 * 0x0002 (2.0, MAKEWORD(2,0)) doesn't look less than 0x0101 (1.1). We
+	 * want the comparison to be 0x0200 < 0x0101.
 	 */
 
 	if (MAKEWORD(HIBYTE(wsaData.wVersion), LOBYTE(wsaData.wVersion))
@@ -344,50 +344,54 @@ InitSockets(void)
 	    WSACleanup();
 	    goto initFailure;
 	}
-
-#undef WSA_VERSION_REQD
-#undef WSA_VERSION_MAJOR
-#undef WSA_VERSION_MINOR
     }
 
     /*
      * Check for per-thread initialization.
      */
 
-    if (tsdPtr == NULL) {
-	tsdPtr = TCL_TSD_INIT(&dataKey);
-	tsdPtr->socketList = NULL;
-	tsdPtr->hwnd       = NULL;
-	tsdPtr->threadId   = Tcl_GetCurrentThread();
-	tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
-	if (tsdPtr->readyEvent == NULL) {
-	    goto initFailure;
-	}
-	tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
-	if (tsdPtr->socketListLock == NULL) {
-	    goto initFailure;
-	}
-	tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr,
-		0, &id);
-	if (tsdPtr->socketThread == NULL) {
-	    goto initFailure;
-	}
+    if (tsdPtr != NULL) {
+	return;
+    }
 
-	SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);
+    /*
+     * OK, this thread has never done anything with sockets before.  Construct
+     * a worker thread to handle asynchronous events related to sockets
+     * assigned to _this_ thread.
+     */
 
-	/*
-	 * Wait for the thread to signal when the window has been created and
-	 * if it is ready to go.
-	 */
+    tsdPtr = TCL_TSD_INIT(&dataKey);
+    tsdPtr->socketList = NULL;
+    tsdPtr->hwnd       = NULL;
+    tsdPtr->threadId   = Tcl_GetCurrentThread();
+    tsdPtr->readyEvent = CreateEvent(NULL, FALSE, FALSE, NULL);
+    if (tsdPtr->readyEvent == NULL) {
+	goto initFailure;
+    }
+    tsdPtr->socketListLock = CreateEvent(NULL, FALSE, TRUE, NULL);
+    if (tsdPtr->socketListLock == NULL) {
+	goto initFailure;
+    }
+    tsdPtr->socketThread = CreateThread(NULL, 256, SocketThread, tsdPtr, 0,
+	    &id);
+    if (tsdPtr->socketThread == NULL) {
+	goto initFailure;
+    }
 
-	WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
+    SetThreadPriority(tsdPtr->socketThread, THREAD_PRIORITY_HIGHEST);
 
-	if (tsdPtr->hwnd == NULL) {
-	    goto initFailure; /* Trouble creating the window */
-	}
+    /*
+     * Wait for the thread to signal when the window has been created and if
+     * it is ready to go.
+     */
+
+    WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
 
-	Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
+    if (tsdPtr->hwnd == NULL) {
+	goto initFailure;	/* Trouble creating the window. */
     }
+
+    Tcl_CreateEventSource(SocketSetupProc, SocketCheckProc, NULL);
     return;
 
   initFailure:
@@ -417,6 +421,7 @@ static int
 SocketsEnabled(void)
 {
     int enabled;
+
     Tcl_MutexLock(&socketMutex);
     enabled = (initialized == 1);
     Tcl_MutexUnlock(&socketMutex);
@@ -447,6 +452,7 @@ SocketExitHandler(
     ClientData clientData)		/* Not used. */
 {
     Tcl_MutexLock(&socketMutex);
+
     /*
      * Make sure the socket event handling window is cleaned-up for, at
      * most, this thread.
@@ -483,32 +489,38 @@ TclpFinalizeSockets(void)
 {
     ThreadSpecificData *tsdPtr = TclThreadDataKeyGet(&dataKey);
 
-    if (tsdPtr != NULL) {
-	if (tsdPtr->socketThread != NULL) {
-	    if (tsdPtr->hwnd != NULL) {
-		PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);
+    /*
+     * Careful! This is a finalizer!
+     */
 
-		/*
-		 * Wait for the thread to exit. This ensures that we are
-		 * completely cleaned up before we leave this function.
-		 */
+    if (tsdPtr == NULL) {
+	return;
+    }
 
-		WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
-		tsdPtr->hwnd = NULL;
-	    }
-	    CloseHandle(tsdPtr->socketThread);
-	    tsdPtr->socketThread = NULL;
-	}
-	if (tsdPtr->readyEvent != NULL) {
-	    CloseHandle(tsdPtr->readyEvent);
-	    tsdPtr->readyEvent = NULL;
-	}
-	if (tsdPtr->socketListLock != NULL) {
-	    CloseHandle(tsdPtr->socketListLock);
-	    tsdPtr->socketListLock = NULL;
+    if (tsdPtr->socketThread != NULL) {
+	if (tsdPtr->hwnd != NULL) {
+	    PostMessage(tsdPtr->hwnd, SOCKET_TERMINATE, 0, 0);
+
+	    /*
+	     * Wait for the thread to exit. This ensures that we are
+	     * completely cleaned up before we leave this function.
+	     */
+
+	    WaitForSingleObject(tsdPtr->readyEvent, INFINITE);
+	    tsdPtr->hwnd = NULL;
 	}
-	Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
+	CloseHandle(tsdPtr->socketThread);
+	tsdPtr->socketThread = NULL;
+    }
+    if (tsdPtr->readyEvent != NULL) {
+	CloseHandle(tsdPtr->readyEvent);
+	tsdPtr->readyEvent = NULL;
     }
+    if (tsdPtr->socketListLock != NULL) {
+	CloseHandle(tsdPtr->socketListLock);
+	tsdPtr->socketListLock = NULL;
+    }
+    Tcl_DeleteEventSource(SocketSetupProc, SocketCheckProc, NULL);
 }
 
 /*
@@ -677,8 +689,7 @@ SocketEventProc(
 {
     SocketInfo *infoPtr;
     SocketEvent *eventPtr = (SocketEvent *) evPtr;
-    int mask = 0;
-    int events;
+    int mask = 0, events;
     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
     TcpFdList *fds;
 
@@ -739,6 +750,7 @@ SocketEventProc(
 	 */
 
 	Tcl_Time blockTime = { 0, 0 };
+
 	Tcl_SetMaxBlockTime(&blockTime);
 	mask |= TCL_READABLE|TCL_WRITABLE;
     } else if (events & FD_READ) {
@@ -901,28 +913,28 @@ TcpClose2Proc(
     int flags)			/* Flags that indicate which side to close. */
 {
     SocketInfo *infoPtr = instanceData;
-    int errorCode = 0;
-    int sd;
+    int errorCode = 0, sd;
 
     /*
      * Shutdown the OS socket handle.
      */
-    switch(flags)
-	{
-	case TCL_CLOSE_READ:
-	    sd=SD_RECEIVE;
-	    break;
-	case TCL_CLOSE_WRITE:
-	    sd=SD_SEND;
-	    break;
-	default:
-	    if (interp) {
-		Tcl_AppendResult(interp,
-			"Socket close2proc called bidirectionally", NULL);
-	    }
-	    return TCL_ERROR;
+
+    switch (flags) {
+    case TCL_CLOSE_READ:
+	sd = SD_RECEIVE;
+	break;
+    case TCL_CLOSE_WRITE:
+	sd = SD_SEND;
+	break;
+    default:
+	if (interp) {
+	    Tcl_AppendResult(interp,
+		    "Socket close2proc called bidirectionally", NULL);
 	}
-    if (shutdown(infoPtr->sockets->fd,sd) == SOCKET_ERROR) {
+	return TCL_ERROR;
+    }
+
+    if (shutdown(infoPtr->sockets->fd, sd) == SOCKET_ERROR) {
 	TclWinConvertError((DWORD) WSAGetLastError());
 	errorCode = Tcl_GetErrno();
     }
@@ -1012,8 +1024,10 @@ CreateSocket(
     int asyncConnect = 0;	/* Will be 1 if async connect is in
 				 * progress. */
     unsigned short chosenport = 0;
-    struct addrinfo *addrlist = NULL, *addrPtr;	/* socket address */
-    struct addrinfo *myaddrlist = NULL, *myaddrPtr; /* Socket address for client */
+    struct addrinfo *addrlist = NULL, *addrPtr;
+				/* Socket address to connect to. */
+    struct addrinfo *myaddrlist = NULL, *myaddrPtr;
+				/* Socket address for our side. */
     const char *errorMsg = NULL;
     SOCKET sock = INVALID_SOCKET;
     SocketInfo *infoPtr = NULL;	/* The returned value. */
@@ -1029,15 +1043,22 @@ CreateSocket(
 	return NULL;
     }
 
-    if (!TclCreateSocketAddress(interp, &addrlist, host, port, server, &errorMsg)) {
+    /*
+     * Construct the addresses for each end of the socket.
+     */
+
+    if (!TclCreateSocketAddress(interp, &addrlist, host, port, server,
+	    &errorMsg)) {
 	goto error;
     }
-    if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1, &errorMsg)) {
+    if (!TclCreateSocketAddress(interp, &myaddrlist, myaddr, myport, 1,
+	    &errorMsg)) {
 	goto error;
     }
 
     if (server) {
 	TcpFdList *fds = NULL, *newfds;
+
 	for (addrPtr = addrlist; addrPtr != NULL; addrPtr = addrPtr->ai_next) {
 	    sock = socket(addrPtr->ai_family, SOCK_STREAM, 0);
 	    if (sock == INVALID_SOCKET) {
@@ -1065,9 +1086,10 @@ CreateSocket(
 	     * As sockaddr_in6 uses the same offset and size for the port
 	     * member as sockaddr_in, we can handle both through the IPv4 API.
 	     */
+
 	    if (port == 0 && chosenport != 0) {
 		((struct sockaddr_in *) addrPtr->ai_addr)->sin_port =
-		    htons(chosenport);
+			htons(chosenport);
 	    }
 
 	    /*
@@ -1081,7 +1103,7 @@ CreateSocket(
 	     */
 
 	    if (bind(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
-		== SOCKET_ERROR) {
+		    == SOCKET_ERROR) {
 		TclWinConvertError((DWORD) WSAGetLastError());
 		closesocket(sock);
 		continue;
@@ -1089,19 +1111,21 @@ CreateSocket(
 	    if (port == 0 && chosenport == 0) {
 		address sockname;
 		socklen_t namelen = sizeof(sockname);
+
 		/*
 		 * Synchronize port numbers when binding to port 0 of multiple
 		 * addresses.
 		 */
+
 		if (getsockname(sock, &sockname.sa, &namelen) >= 0) {
 		    chosenport = ntohs(sockname.sa4.sin_port);
 		}
 	    }
 
 	    /*
-	     * Set the maximum number of pending connect requests to the max value
-	     * allowed on each platform (Win32 and Win32s may be different, and
-	     * there may be differences between TCP/IP stacks).
+	     * Set the maximum number of pending connect requests to the max
+	     * value allowed on each platform (Win32 and Win32s may be
+	     * different, and there may be differences between TCP/IP stacks).
 	     */
 
 	    if (listen(sock, SOMAXCONN) == SOCKET_ERROR) {
@@ -1144,6 +1168,7 @@ CreateSocket(
 		 * No need to try combinations of local and remote addresses
 		 * of different families.
 		 */
+
 		if (myaddrPtr->ai_family != addrPtr->ai_family) {
 		    continue;
 		}
@@ -1165,14 +1190,14 @@ CreateSocket(
 		 * Set kernel space buffering
 		 */
 
-		TclSockMinimumBuffers((void *)sock, TCP_BUFFER_SIZE);
+		TclSockMinimumBuffers((void *) sock, TCP_BUFFER_SIZE);
 
 		/*
 		 * Try to bind to a local port.
 		 */
 
 		if (bind(sock, myaddrPtr->ai_addr, myaddrPtr->ai_addrlen)
-		    == SOCKET_ERROR) {
+			== SOCKET_ERROR) {
 		    TclWinConvertError((DWORD) WSAGetLastError());
 		    goto looperror;
 		}
@@ -1180,12 +1205,10 @@ CreateSocket(
 		 * Set the socket into nonblocking mode if the connect should
 		 * be done in the background.
 		 */
-		if (async) {
-		    if (ioctlsocket(sock, (long) FIONBIO, &flag)
+		if (async && ioctlsocket(sock, (long) FIONBIO, &flag)
 			== SOCKET_ERROR) {
-			TclWinConvertError((DWORD) WSAGetLastError());
-			goto looperror;
-		    }
+		    TclWinConvertError((DWORD) WSAGetLastError());
+		    goto looperror;
 		}
 
 		/*
@@ -1193,7 +1216,7 @@ CreateSocket(
 		 */
 
 		if (connect(sock, addrPtr->ai_addr, addrPtr->ai_addrlen)
-		    == SOCKET_ERROR) {
+			== SOCKET_ERROR) {
 		    TclWinConvertError((DWORD) WSAGetLastError());
 		    if (Tcl_GetErrno() != EAGAIN) {
 			goto looperror;
@@ -1204,10 +1227,9 @@ CreateSocket(
 		     */
 
 		    asyncConnect = 1;
-		    goto connected;
-		} else {
-		    goto connected;
 		}
+		goto connected;
+
 	    looperror:
 		if (sock != INVALID_SOCKET) {
 		    closesocket(sock);
@@ -1225,8 +1247,8 @@ CreateSocket(
 	infoPtr = NewSocketInfo(sock);
 
 	/*
-	 * Set up the select mask for read/write events. If the
-	 * connect attempt has not completed, include connect events.
+	 * Set up the select mask for read/write events. If the connect
+	 * attempt has not completed, include connect events.
 	 */
 
 	infoPtr->selectEvents = FD_READ | FD_WRITE | FD_CLOSE;
@@ -1237,10 +1259,12 @@ CreateSocket(
     }
 
   error:
-    if (addrlist == NULL)
+    if (addrlist == NULL) {
 	freeaddrinfo(addrlist);
-    if (myaddrlist == NULL)
+    }
+    if (myaddrlist == NULL) {
 	freeaddrinfo(myaddrlist);
+    }
 
     /*
      * Register for interest in events in the select mask. Note that this
@@ -1249,7 +1273,8 @@ CreateSocket(
 
     if (infoPtr != NULL) {
 	ioctlsocket(sock, (long) FIONBIO, &flag);
-	SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT, (LPARAM) infoPtr);
+	SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+		(LPARAM) infoPtr);
 
 	return infoPtr;
     }
@@ -1264,80 +1289,6 @@ CreateSocket(
     return NULL;
 }
 
-#if 0
-/*
- *----------------------------------------------------------------------
- *
- * CreateSocketAddress --
- *
- *	This function initializes a sockaddr structure for a host and port.
- *
- * Results:
- *	1 if the host was valid, 0 if the host could not be converted to an IP
- *	address.
- *
- * Side effects:
- *	Fills in the *sockaddrPtr structure.
- *
- *----------------------------------------------------------------------
- */
-
-static int
-CreateSocketAddress(
-    LPSOCKADDR_IN sockaddrPtr,	/* Socket address */
-    const char *host,		/* Host. NULL implies INADDR_ANY */
-    int port)			/* Port number */
-{
-    struct hostent *hostent;	/* Host database entry */
-    struct in_addr addr;	/* For 64/32 bit madness */
-
-    /*
-     * Check that WinSock is initialized; do not call it if not, to prevent
-     * system crashes. This can happen at exit time if the exit handler for
-     * WinSock ran before other exit handlers that want to use sockets.
-     */
-
-    if (!SocketsEnabled()) {
-	Tcl_SetErrno(EFAULT);
-	return 0;
-    }
-
-    ZeroMemory(sockaddrPtr, sizeof(SOCKADDR_IN));
-    sockaddrPtr->sin_family = AF_INET;
-    sockaddrPtr->sin_port = htons((u_short) (port & 0xFFFF));
-    if (host == NULL) {
-	addr.s_addr = INADDR_ANY;
-    } else {
-	addr.s_addr = inet_addr(host);
-	if (addr.s_addr == INADDR_NONE) {
-	    hostent = gethostbyname(host);
-	    if (hostent != NULL) {
-		memcpy(&addr, hostent->h_addr, (size_t) hostent->h_length);
-	    } else {
-#ifdef	EHOSTUNREACH
-		Tcl_SetErrno(EHOSTUNREACH);
-#else
-#ifdef ENXIO
-		Tcl_SetErrno(ENXIO);
-#endif
-#endif
-		return 0;	/* Error. */
-	    }
-	}
-    }
-
-    /*
-     * NOTE: On 64 bit machines the assignment below is rumored to not do the
-     * right thing. Please report errors related to this if you observe
-     * incorrect behavior on 64 bit machines such as DEC Alphas. Should we
-     * modify this code to do an explicit memcpy?
-     */
-
-    sockaddrPtr->sin_addr.s_addr = addr.s_addr;
-    return 1;			/* Success. */
-}
-#endif
-
 /*
  *----------------------------------------------------------------------
  *
@@ -1377,7 +1328,6 @@ WaitForSocketEvent(
 
     SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) UNSELECT,
 	    (LPARAM) infoPtr);
-
     SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
 	    (LPARAM) infoPtr);
 
@@ -1452,17 +1402,16 @@ Tcl_OpenTcpClient(
 
     infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
 	    infoPtr, (TCL_READABLE | TCL_WRITABLE));
-    if (Tcl_SetChannelOption(interp, infoPtr->channel, "-translation",
-	    "auto crlf") == TCL_ERROR) {
-	Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
-	return (Tcl_Channel) NULL;
-    }
-    if (Tcl_SetChannelOption(NULL, infoPtr->channel, "-eofchar", "")
-	    == TCL_ERROR) {
-	Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
-	return (Tcl_Channel) NULL;
+    if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel,
+	    "-translation", "auto crlf")) {
+	Tcl_Close(NULL, infoPtr->channel);
+	return NULL;
+    } else if (TCL_ERROR == Tcl_SetChannelOption(NULL, infoPtr->channel,
+	    "-eofchar", "")) {
+	Tcl_Close(NULL, infoPtr->channel);
+	return NULL;
     }
-    return infoPtr->channel;
+    return infoPtr->channel
 }
 
 /*
@@ -1510,8 +1459,7 @@ Tcl_MakeTcpClientChannel(
      */
 
     infoPtr->selectEvents = FD_READ | FD_CLOSE | FD_WRITE;
-    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
-	    (WPARAM) SELECT, (LPARAM) infoPtr);
+    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);
 
     sprintf(channelName, "sock%Id", (size_t) infoPtr->sockets->fd);
     infoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
@@ -1572,8 +1520,8 @@ Tcl_OpenTcpServer(
 	    infoPtr, 0);
     if (Tcl_SetChannelOption(interp, infoPtr->channel, "-eofchar", "")
 	    == TCL_ERROR) {
-	Tcl_Close((Tcl_Interp *) NULL, infoPtr->channel);
-	return (Tcl_Channel) NULL;
+	Tcl_Close(NULL, infoPtr->channel);
+	return NULL;
     }
 
     return infoPtr->channel;
@@ -1614,12 +1562,13 @@ TcpAccept(
 
     len = sizeof(SOCKADDR_IN);
 
-    newSocket = accept(fds->fd, (SOCKADDR *)&addr, &len);
+    newSocket = accept(fds->fd, (SOCKADDR *) &addr, &len);
 
     /*
      * Protect access to sockets (acceptEventCount, readyEvents) in socketList
      * by the lock.  Fix for SF Tcl Bug 3056775.
      */
+
     WaitForSingleObject(tsdPtr->socketListLock, INFINITE);
 
     /*
@@ -1668,20 +1617,20 @@ TcpAccept(
      */
 
     newInfoPtr->selectEvents = (FD_READ | FD_WRITE | FD_CLOSE);
-    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
-	    (WPARAM) SELECT, (LPARAM) newInfoPtr);
+    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM) SELECT,
+	    (LPARAM) newInfoPtr);
 
     sprintf(channelName, "sock%Id", (size_t) newInfoPtr->sockets->fd);
     newInfoPtr->channel = Tcl_CreateChannel(&tcpChannelType, channelName,
 	    newInfoPtr, (TCL_READABLE | TCL_WRITABLE));
     if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-translation",
 	    "auto crlf") == TCL_ERROR) {
-	Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel);
+	Tcl_Close(NULL, newInfoPtr->channel);
 	return;
     }
     if (Tcl_SetChannelOption(NULL, newInfoPtr->channel, "-eofchar", "")
 	    == TCL_ERROR) {
-	Tcl_Close((Tcl_Interp *) NULL, newInfoPtr->channel);
+	Tcl_Close(NULL, newInfoPtr->channel);
 	return;
     }
 
@@ -1826,8 +1775,7 @@ TcpInputProc(
 	}
     }
 
-    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
-	    (WPARAM) SELECT, (LPARAM) infoPtr);
+    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);
 
     return bytesRead;
 }
@@ -1935,8 +1883,7 @@ TcpOutputProc(
 	}
     }
 
-    SendMessage(tsdPtr->hwnd, SOCKET_SELECT,
-	    (WPARAM) SELECT, (LPARAM) infoPtr);
+    SendMessage(tsdPtr->hwnd, SOCKET_SELECT, (WPARAM)SELECT, (LPARAM)infoPtr);
 
     return bytesWritten;
 }
@@ -2117,6 +2064,7 @@ TcpGetOptionProc(
 	    (strncmp(optionName, "-peername", len) == 0))) {
 	address peername;
 	socklen_t size = sizeof(peername);
+
 	if (getpeername(sock, (LPSOCKADDR) &(peername.sa), &size) == 0) {
 	    if (len == 0) {
 		Tcl_DStringAppendElement(dsPtr, "-peername");
@@ -2170,8 +2118,8 @@ TcpGetOptionProc(
 	    size = sizeof(sockname);
 	    if (getsockname(sock, &(sockname.sa), &size) >= 0) {
 		int flags = reverseDNS;
-		found = 1;
 
+		found = 1;
 		getnameinfo(&sockname.sa, size, host, sizeof(host),
 			NULL, 0, NI_NUMERICHOST);
 		Tcl_DStringAppendElement(dsPtr, host);
@@ -2299,7 +2247,7 @@ TcpWatchProc(
 
     /*
      * Update the watch events mask. Only if the socket is not a server
-     * socket. Fix for SF Tcl Bug #557878.
+     * socket. [Bug 557878]
      */
 
     if (!infoPtr->acceptProc) {
@@ -2318,6 +2266,7 @@ TcpWatchProc(
 
 	if (infoPtr->readyEvents & infoPtr->watchEvents) {
 	    Tcl_Time blockTime = { 0, 0 };
+
 	    Tcl_SetMaxBlockTime(&blockTime);
 	}
     }
@@ -2379,8 +2328,8 @@ SocketThread(
      * Create a dummy window receiving socket events.
      */
 
-    tsdPtr->hwnd = CreateWindow(classname, classname,
-	    WS_TILED, 0, 0, 0, 0, NULL, NULL, windowClass.hInstance, arg);
+    tsdPtr->hwnd = CreateWindow(classname, classname, WS_TILED, 0, 0, 0, 0,
+	    NULL, NULL, windowClass.hInstance, arg);
 
     /*
      * Signalize thread creator that we are done creating the window.
@@ -2673,8 +2622,12 @@ InitializeHostName(
  */
 
 int
-TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval,
-	int *optlen)
+TclWinGetSockOpt(
+    SOCKET s,
+    int level,
+    int optname,
+    char *optval,
+    int *optlen)
 {
     /*
      * Check that WinSock is initialized; do not call it if not, to prevent
@@ -2690,7 +2643,11 @@ TclWinGetSockOpt(SOCKET s, int level, int optname, char *optval,
 }
 
 int
-TclWinSetSockOpt(SOCKET s, int level, int optname, const char *optval,
+TclWinSetSockOpt(
+    SOCKET s,
+    int level,
+    int optname,
+    const char *optval,
     int optlen)
 {
     /*
-- 
cgit v0.12


From 4d8a945fc474dc4d42a6c0903f3eb2e0b62bd9a4 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 9 Apr 2012 17:04:21 +0000
Subject: Fix [Bug 2712377]: [info vars] and object declared variables

---
 ChangeLog        |  7 ++++++
 generic/tclOO.c  |  1 -
 generic/tclVar.c | 52 ++++++++++++++++++++++++++++++++++++----
 tests/oo.test    | 72 ++++++++++++++++++++++++++++++++++++++++++++++++++++++++
 4 files changed, 127 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 4c961d0..d66e5b7 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2012-04-09  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclVar.c (AppendLocals): [Bug 2712377]: Fix problem with
+	reporting of declared variables in methods. It's really a problem with
+	how [info vars] interacts with variable resolvers; this is just a bit
+	of a hack so it is no longer a big problem.
+
 2012-04-04  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclOO.c (Tcl_NewObjectInstance, TclNRNewObjectInstance):
diff --git a/generic/tclOO.c b/generic/tclOO.c
index 1d1276d..d5cc6e1 100644
--- a/generic/tclOO.c
+++ b/generic/tclOO.c
@@ -1780,7 +1780,6 @@ FinalizeAlloc(
     Object *oPtr = data[1];
     Tcl_InterpState state = data[2];
     Tcl_Object *objectPtr = data[3];
-    //int flags = oPtr->flags;
 
     /*
      * It's an error if the object was whacked in the constructor. Force this
diff --git a/generic/tclVar.c b/generic/tclVar.c
index 1bf4abc..e92dc5f 100644
--- a/generic/tclVar.c
+++ b/generic/tclVar.c
@@ -18,6 +18,7 @@
  */
 
 #include "tclInt.h"
+#include "tclOOInt.h"
 
 /*
  * Prototypes for the variable hash key methods.
@@ -6083,7 +6084,7 @@ TclInfoVarsCmd(
 		}
 	    }
 	}
-    } else if (((Interp *)interp)->varFramePtr->procPtr != NULL) {
+    } else if (iPtr->varFramePtr->procPtr != NULL) {
 	AppendLocals(interp, listPtr, simplePatternPtr, 1);
     }
 
@@ -6269,17 +6270,21 @@ AppendLocals(
 {
     Interp *iPtr = (Interp *) interp;
     Var *varPtr;
-    int i, localVarCt;
+    int i, localVarCt, added;
     Tcl_Obj **varNamePtr, *objNamePtr;
     const char *varName;
     TclVarHashTable *localVarTablePtr;
     Tcl_HashSearch search;
+    Tcl_HashTable addedTable;
     const char *pattern = patternPtr? TclGetString(patternPtr) : NULL;
 
     localVarCt = iPtr->varFramePtr->numCompiledLocals;
     varPtr = iPtr->varFramePtr->compiledLocals;
     localVarTablePtr = iPtr->varFramePtr->varTablePtr;
     varNamePtr = &iPtr->varFramePtr->localCachePtr->varName0;
+    if (includeLinks) {
+	Tcl_InitObjHashTable(&addedTable);
+    }
 
     for (i = 0; i < localVarCt; i++, varNamePtr++) {
 	/*
@@ -6291,6 +6296,9 @@ AppendLocals(
 	    varName = TclGetString(*varNamePtr);
 	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
 		Tcl_ListObjAppendElement(interp, listPtr, *varNamePtr);
+		if (includeLinks) {
+		    Tcl_CreateHashEntry(&addedTable, *varNamePtr, &added);
+		}
 	    }
 	}
 	varPtr++;
@@ -6301,7 +6309,7 @@ AppendLocals(
      */
 
     if (localVarTablePtr == NULL) {
-	return;
+	goto objectVars;
     }
 
     /*
@@ -6315,9 +6323,13 @@ AppendLocals(
 		    && (includeLinks || !TclIsVarLink(varPtr))) {
 		Tcl_ListObjAppendElement(interp, listPtr,
 			VarHashGetKey(varPtr));
+		if (includeLinks) {
+		    Tcl_CreateHashEntry(&addedTable, VarHashGetKey(varPtr),
+			    &added);
+		}
 	    }
 	}
-	return;
+	goto objectVars;
     }
 
     /*
@@ -6333,9 +6345,41 @@ AppendLocals(
 	    varName = TclGetString(objNamePtr);
 	    if ((pattern == NULL) || Tcl_StringMatch(varName, pattern)) {
 		Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
+		if (includeLinks) {
+		    Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
+		}
+	    }
+	}
+    }
+
+  objectVars:
+    if (!includeLinks) {
+	return;
+    }
+
+    if (iPtr->varFramePtr->isProcCallFrame & FRAME_IS_METHOD) {
+	CallContext *contextPtr = iPtr->varFramePtr->clientData;
+	Method *mPtr = contextPtr->callPtr->chain[contextPtr->index].mPtr;
+
+	if (mPtr->declaringObjectPtr) {
+	    FOREACH(objNamePtr, mPtr->declaringObjectPtr->variables) {
+		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
+		if (added && (!pattern ||
+			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
+		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
+		}
+	    }
+	} else {
+	    FOREACH(objNamePtr, mPtr->declaringClassPtr->variables) {
+		Tcl_CreateHashEntry(&addedTable, objNamePtr, &added);
+		if (added && (!pattern ||
+			Tcl_StringMatch(TclGetString(objNamePtr), pattern))) {
+		    Tcl_ListObjAppendElement(interp, listPtr, objNamePtr);
+		}
 	    }
 	}
     }
+    Tcl_DeleteHashTable(&addedTable);
 }
 
 /*
diff --git a/tests/oo.test b/tests/oo.test
index 8c5aeb3..a0e7345 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2946,6 +2946,78 @@ test oo-27.18 {variables declaration - multiple use} -setup {
     foo create bar
     list [bar boo] [bar boo]
 } -returnCodes error -match glob -result {unknown method "-?": must be *}
+test oo-27.19 {variables declaration and [info vars]: Bug 2712377} -setup {
+    oo::class create Foo
+    set result {}
+} -body {
+    # This is really a test of problems to do with Tcl's introspection when a
+    # variable resolver is present...
+    oo::define Foo {
+	variable foo bar
+	method setvars {f b} {
+	    set foo $f
+	    set bar $b
+	}
+	method dump1 {} {
+	    lappend ::result <1>
+	    foreach v [lsort [info vars *]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result [info locals] [info locals *]
+	}
+	method dump2 {} {
+	    lappend ::result <2>
+	    foreach v [lsort [info vars *]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result | foo=$foo [info locals] [info locals *]
+	}
+    }
+
+    Foo create stuff
+    stuff setvars what ever
+    stuff dump1
+    stuff dump2
+    return $result
+} -cleanup {
+    Foo destroy
+} -result {<1> bar=ever foo=what v v <2> bar=ever foo=what | foo=what v v}
+test oo-27.20 {variables declaration and [info vars]: Bug 2712377} -setup {
+    oo::class create Foo
+    set result {}
+} -body {
+    # This is really a test of problems to do with Tcl's introspection when a
+    # variable resolver is present...
+    oo::define Foo {
+	variable foo bar
+	method setvars {f b} {
+	    set foo $f
+	    set bar $b
+	}
+	method dump1 {} {
+	    lappend ::result <1>
+	    foreach v [lsort [info vars *o]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result [info locals] [info locals *]
+	}
+	method dump2 {} {
+	    lappend ::result <2>
+	    foreach v [lsort [info vars *o]] {
+		lappend ::result $v=[set $v]
+	    }
+	    lappend ::result | foo=$foo [info locals] [info locals *]
+	}
+    }
+
+    Foo create stuff
+    stuff setvars what ever
+    stuff dump1
+    stuff dump2
+    return $result
+} -cleanup {
+    Foo destroy
+} -result {<1> foo=what v v <2> foo=what | foo=what v v}
 
 # A feature that's not supported because the mechanism may change without
 # warning, but is supposed to work...
-- 
cgit v0.12


From ba795792d6185008b4de5f9c0463f26fa2ddab0a Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 9 Apr 2012 21:38:27 +0000
Subject: Fix [Bug 3396896]

---
 ChangeLog                 |  4 ++++
 generic/tclOODefineCmds.c | 52 ++++++++++++++++++++++++++++++++++++++++++-----
 tests/oo.test             | 18 ++++++++++++++--
 3 files changed, 67 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index d66e5b7..c632c42 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2012-04-09  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclOODefineCmds.c (ClassVarsSet, ObjVarsSet): [Bug 3396896]:
+	Ensure that the lists of variable names used to drive variable
+	resolution will never have the same name twice.
+
 	* generic/tclVar.c (AppendLocals): [Bug 2712377]: Fix problem with
 	reporting of declared variables in methods. It's really a problem with
 	how [info vars] interacts with variable resolvers; this is just a bit
diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c
index 926966b..3d72690 100644
--- a/generic/tclOODefineCmds.c
+++ b/generic/tclOODefineCmds.c
@@ -2306,11 +2306,32 @@ ClassVarsSet(
 		    ckalloc(sizeof(Tcl_Obj *) * varc);
 	}
     }
+
+    oPtr->classPtr->variables.num = 0;
     if (varc > 0) {
-	memcpy(oPtr->classPtr->variables.list, varv,
-		sizeof(Tcl_Obj *) * varc);
+	int created, n;
+	Tcl_HashTable uniqueTable;
+
+	Tcl_InitObjHashTable(&uniqueTable);
+	for (i=n=0 ; i<varc ; i++) {
+	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+	    if (created) {
+		oPtr->classPtr->variables.list[n++] = varv[i];
+	    } else {
+		Tcl_DecrRefCount(varv[i]);
+	    }
+	}
+	oPtr->classPtr->variables.num = n;
+
+	/*
+	 * Shouldn't be necessary, but maintain num/list invariant.
+	 */
+
+	oPtr->classPtr->variables.list = (Tcl_Obj **)
+		ckrealloc((char *) oPtr->classPtr->variables.list,
+		sizeof(Tcl_Obj *) * n);
+	Tcl_DeleteHashTable(&uniqueTable);
     }
-    oPtr->classPtr->variables.num = varc;
     return TCL_OK;
 }
 
@@ -2563,10 +2584,31 @@ ObjVarsSet(
 		    ckalloc(sizeof(Tcl_Obj *) * varc);
 	}
     }
+    oPtr->variables.num = 0;
     if (varc > 0) {
-	memcpy(oPtr->variables.list, varv, sizeof(Tcl_Obj *)*varc);
+	int created, n;
+	Tcl_HashTable uniqueTable;
+
+	Tcl_InitObjHashTable(&uniqueTable);
+	for (i=n=0 ; i<varc ; i++) {
+	    Tcl_CreateHashEntry(&uniqueTable, varv[i], &created);
+	    if (created) {
+		oPtr->variables.list[n++] = varv[i];
+	    } else {
+		Tcl_DecrRefCount(varv[i]);
+	    }
+	}
+	oPtr->variables.num = n;
+
+	/*
+	 * Shouldn't be necessary, but maintain num/list invariant.
+	 */
+
+	oPtr->variables.list = (Tcl_Obj **)
+		ckrealloc((char *) oPtr->variables.list,
+		sizeof(Tcl_Obj *) * n);
+	Tcl_DeleteHashTable(&uniqueTable);
     }
-    oPtr->variables.num = varc;
     return TCL_OK;
 }
 
diff --git a/tests/oo.test b/tests/oo.test
index a0e7345..f3c0bda 100644
--- a/tests/oo.test
+++ b/tests/oo.test
@@ -2973,7 +2973,6 @@ test oo-27.19 {variables declaration and [info vars]: Bug 2712377} -setup {
 	    lappend ::result | foo=$foo [info locals] [info locals *]
 	}
     }
-
     Foo create stuff
     stuff setvars what ever
     stuff dump1
@@ -3009,7 +3008,6 @@ test oo-27.20 {variables declaration and [info vars]: Bug 2712377} -setup {
 	    lappend ::result | foo=$foo [info locals] [info locals *]
 	}
     }
-
     Foo create stuff
     stuff setvars what ever
     stuff dump1
@@ -3018,6 +3016,22 @@ test oo-27.20 {variables declaration and [info vars]: Bug 2712377} -setup {
 } -cleanup {
     Foo destroy
 } -result {<1> foo=what v v <2> foo=what | foo=what v v}
+test oo-27.21 {variables declaration uniqueifies: Bug 3396896} -setup {
+    oo::class create Foo
+} -body {
+    oo::define Foo variable v v v t t v t
+    info class variable Foo
+} -cleanup {
+    Foo destroy
+} -result {v t}
+test oo-27.22 {variables declaration uniqueifies: Bug 3396896} -setup {
+    oo::object create foo
+} -body {
+    oo::objdefine foo variable v v v t t v t
+    info object variable foo
+} -cleanup {
+    foo destroy
+} -result {v t}
 
 # A feature that's not supported because the mechanism may change without
 # warning, but is supposed to work...
-- 
cgit v0.12


From c0862c727dbeca43d2aee244d1582595ac28a74b Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 10 Apr 2012 09:17:01 +0000
Subject: 	* generic/tcl.h (TCL_DEPRECATED_API): Added macro that can be
 used to 	mark parts of Tcl's API as deprecated. Currently only used for
 fields 	of Tcl_Interp, which TIPs 330 and 336 have deprecated with a
 migration 	strategy; we want to encourage people to move away from those
 fields.

---
 ChangeLog     |  7 +++++++
 generic/tcl.h | 32 ++++++++++++++++++++++++++------
 2 files changed, 33 insertions(+), 6 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index c632c42..c735fae 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2012-04-10  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tcl.h (TCL_DEPRECATED_API): Added macro that can be used to
+	mark parts of Tcl's API as deprecated. Currently only used for fields
+	of Tcl_Interp, which TIPs 330 and 336 have deprecated with a migration
+	strategy; we want to encourage people to move away from those fields.
+
 2012-04-09  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tclOODefineCmds.c (ClassVarsSet, ObjVarsSet): [Bug 3396896]:
diff --git a/generic/tcl.h b/generic/tcl.h
index 875a171..729e521 100644
--- a/generic/tcl.h
+++ b/generic/tcl.h
@@ -163,6 +163,23 @@ extern "C" {
 #endif
 
 /*
+ * Allow a part of Tcl's API to be explicitly marked as deprecated.
+ *
+ * Used to make TIP 330/336 generate moans even if people use the
+ * compatibility macros. Change your code, guys! We won't support you forever.
+ */
+
+#if defined(__GNUC__) && ((__GNUC__ >= 4) || ((__GNUC__ == 3) && (__GNUC_MINOR__ >= 1)))
+#   if (__GNUC__ > 4) || ((__GNUC__ == 4) && (__GNUC__MINOR__ >= 5))
+#	define TCL_DEPRECATED_API(msg)	__attribute__ ((__deprecated__ (msg)))
+#   else
+#	define TCL_DEPRECATED_API(msg)	__attribute__ ((__deprecated__))
+#   endif
+#else
+#   define TCL_DEPRECATED_API(msg)	/* nothing portable */
+#endif
+
+/*
  *----------------------------------------------------------------------------
  * Macros used to declare a function to be exported by a DLL. Used by Windows,
  * maps to no-op declarations on non-Windows systems. The default build on
@@ -487,9 +504,11 @@ typedef struct Tcl_Interp {
     /* TIP #330: Strongly discourage extensions from using the string
      * result. */
 #ifdef USE_INTERP_RESULT
-    char *result;		/* If the last command returned a string
+    char *result TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult");
+				/* If the last command returned a string
 				 * result, this points to it. */
-    void (*freeProc) (char *blockPtr);
+    void (*freeProc) (char *blockPtr)
+	    TCL_DEPRECATED_API("use Tcl_GetResult/Tcl_SetResult");
 				/* Zero means the string result is statically
 				 * allocated. TCL_DYNAMIC means it was
 				 * allocated with ckalloc and should be freed
@@ -498,15 +517,16 @@ typedef struct Tcl_Interp {
 				 * Tcl_Eval must free it before executing next
 				 * command. */
 #else
-    char *unused3;
-    void (*unused4) (char *);
+    char *unused3 TCL_DEPRECATED_API("bad field access");
+    void (*unused4) (char *) TCL_DEPRECATED_API("bad field access");
 #endif
 #ifdef USE_INTERP_ERRORLINE
-    int errorLine;		/* When TCL_ERROR is returned, this gives the
+    int errorLine TCL_DEPRECATED_API("use Tcl_GetErrorLine/Tcl_SetErrorLine");
+				/* When TCL_ERROR is returned, this gives the
 				 * line number within the command where the
 				 * error occurred (1 if first line). */
 #else
-    int unused5;
+    int unused5 TCL_DEPRECATED_API("bad field access");
 #endif
 } Tcl_Interp;
 
-- 
cgit v0.12


From 9981d5779018fe775afd850a35a6dc41e6f8b3b9 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 10 Apr 2012 09:29:24 +0000
Subject: very slight tidy up to make build messages more regular

---
 unix/Makefile.in | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/unix/Makefile.in b/unix/Makefile.in
index 81185b4..a9024db 100644
--- a/unix/Makefile.in
+++ b/unix/Makefile.in
@@ -1211,7 +1211,7 @@ tclPkg.o: $(GENERIC_DIR)/tclPkg.c
 # prefix/exec_prefix but all the different paths individually.
 
 tclPkgConfig.o: $(GENERIC_DIR)/tclPkgConfig.c
-	$(CC)	-c $(CC_SWITCHES)					\
+	$(CC) -c $(CC_SWITCHES)					\
 		-DCFG_INSTALL_LIBDIR="\"$(LIB_INSTALL_DIR)\"" \
 		-DCFG_INSTALL_BINDIR="\"$(BIN_INSTALL_DIR)\"" \
 		-DCFG_INSTALL_SCRDIR="\"$(SCRIPT_INSTALL_DIR)\"" \
@@ -1269,7 +1269,7 @@ tclVar.o: $(GENERIC_DIR)/tclVar.c
 	$(CC) -c $(CC_SWITCHES) $(GENERIC_DIR)/tclVar.c
 
 tclZlib.o: $(GENERIC_DIR)/tclZlib.c
-	$(CC) -c $(ZLIB_INCLUDE) $(CC_SWITCHES) $(GENERIC_DIR)/tclZlib.c
+	$(CC) -c $(CC_SWITCHES) $(ZLIB_INCLUDE) $(GENERIC_DIR)/tclZlib.c
 
 tclTest.o: $(GENERIC_DIR)/tclTest.c $(IOHDR) $(TCLREHDRS)
 	$(CC) -c $(APP_CC_SWITCHES) $(GENERIC_DIR)/tclTest.c
-- 
cgit v0.12


From 8da9d0139793f1b1f781de518a5bb8094a0c880e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 10 Apr 2012 09:30:49 +0000
Subject: corrected changelog entry

---
 ChangeLog | 9 +++++----
 1 file changed, 5 insertions(+), 4 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index c735fae..74ad3c4 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,9 +1,10 @@
 2012-04-10  Donal K. Fellows  <dkf@users.sf.net>
 
-	* generic/tcl.h (TCL_DEPRECATED_API): Added macro that can be used to
-	mark parts of Tcl's API as deprecated. Currently only used for fields
-	of Tcl_Interp, which TIPs 330 and 336 have deprecated with a migration
-	strategy; we want to encourage people to move away from those fields.
+	* generic/tcl.h (TCL_DEPRECATED_API): [Bug 2458976]: Added macro that
+	can be used to mark parts of Tcl's API as deprecated. Currently only
+	used for fields of Tcl_Interp, which TIPs 330 and 336 have deprecated
+	with a migration strategy; we want to encourage people to move away
+	from those fields.
 
 2012-04-09  Donal K. Fellows  <dkf@users.sf.net>
 
-- 
cgit v0.12


From 8c9ff9ac6ac043b04ecfe5593ba048130c61bcbd Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Tue, 10 Apr 2012 21:28:05 +0000
Subject: Ensure all documented functions are listed in index line.

---
 doc/Notifier.3 | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/doc/Notifier.3 b/doc/Notifier.3
index 435f779..f65d580 100644
--- a/doc/Notifier.3
+++ b/doc/Notifier.3
@@ -9,7 +9,7 @@
 .TH Notifier 3 8.1 Tcl "Tcl Library Procedures"
 .BS
 .SH NAME
-Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode \- the event queue and notifier interfaces
+Tcl_CreateEventSource, Tcl_DeleteEventSource, Tcl_SetMaxBlockTime, Tcl_QueueEvent, Tcl_ThreadQueueEvent, Tcl_ThreadAlert, Tcl_GetCurrentThread, Tcl_DeleteEvents, Tcl_InitNotifier, Tcl_FinalizeNotifier, Tcl_WaitForEvent, Tcl_AlertNotifier, Tcl_SetTimer, Tcl_ServiceAll, Tcl_ServiceEvent, Tcl_GetServiceMode, Tcl_SetServiceMode, Tcl_ServiceModeHook, Tcl_SetNotifier \- the event queue and notifier interfaces
 .SH SYNOPSIS
 .nf
 \fB#include <tcl.h>\fR
-- 
cgit v0.12


From 7a6d97a527bd8148991a5a5da76fb6f75abd687e Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 11 Apr 2012 20:36:16 +0000
Subject: fix windows build broken by [92cfbef048] (Refactor Win socket and
 load code to be less baroque in its internals)

---
 win/tclWinLoad.c | 2 +-
 win/tclWinSock.c | 2 +-
 2 files changed, 2 insertions(+), 2 deletions(-)

diff --git a/win/tclWinLoad.c b/win/tclWinLoad.c
index 5848daa..e5b927d 100644
--- a/win/tclWinLoad.c
+++ b/win/tclWinLoad.c
@@ -28,7 +28,7 @@ static Tcl_Mutex dllDirectoryNameMutex;
 
 static void *		FindSymbol(Tcl_Interp *interp,
 			    Tcl_LoadHandle loadHandle, const char *symbol);
-static void		InitDLLDirectoryName(void);
+static int		InitDLLDirectoryName(void);
 static void		UnloadFile(Tcl_LoadHandle loadHandle);
 
 /*
diff --git a/win/tclWinSock.c b/win/tclWinSock.c
index 2f14c17..7181701 100644
--- a/win/tclWinSock.c
+++ b/win/tclWinSock.c
@@ -1411,7 +1411,7 @@ Tcl_OpenTcpClient(
 	Tcl_Close(NULL, infoPtr->channel);
 	return NULL;
     }
-    return infoPtr->channel
+    return infoPtr->channel;
 }
 
 /*
-- 
cgit v0.12


From b54406ffc1f268bdb88f9512f500f04e0bc0be2f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 15 Apr 2012 10:07:22 +0000
Subject: 	* generic/tclZlib.c (ZlibTransformSetOption): [Bug 3517696]:
 Make 	flushing work correctly in a pushed compressing channel transform.

---
 ChangeLog         | 24 +++++++++++++++---------
 generic/tclZlib.c | 22 ++++++++++++----------
 tests/zlib.test   | 12 ++++++++++++
 3 files changed, 39 insertions(+), 19 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 06e7d7b..05631c6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,7 +1,12 @@
+2012-04-15  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclZlib.c (ZlibTransformSetOption): [Bug 3517696]: Make
+	flushing work correctly in a pushed compressing channel transform.
+
 2012-04-12  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* generic/tclInt.decls:      [Bug 3514475]: remove TclpGetTimeZone
-	* generic/tclIntDecls.h:     and TclpGetTZName
+	* generic/tclInt.decls:      [Bug 3514475]: Remove TclpGetTimeZone and
+	* generic/tclIntDecls.h:     TclpGetTZName
 	* generic/tclIntPlatDecls.h:
 	* generic/tclStubInit.c:
 	* unix/tclUnixTime.c:
@@ -9,20 +14,21 @@
 
 2012-04-11  Jan Nijtmans  <nijtmans@users.sf.net>
 
-	* win/tclWinInit.c:     [Bug 3448512]: clock scan "1958-01-01" fails only
-	* win/tcl.m4:           in debug compilation.
+	* win/tclWinInit.c:     [Bug 3448512]: clock scan "1958-01-01" fails
+	* win/tcl.m4:           only in debug compilation.
 	* win/configure:
 	* unix/tcl.m4:          Use NDEBUG consistantly meaning: no debugging.
 	* unix/configure:
 	* generic/tclBasic.c:
-	* library/dde/pkgIndex.tcl   Use [::tcl::pkgconfig get debug] in stead
+	* library/dde/pkgIndex.tcl   Use [::tcl::pkgconfig get debug] instead
 	* library/reg/pkgIndex.tcl   of [info exists ::tcl_platform(debug)]
 
 	***POTENTIAL INCOMPATIBILITY***
-	The variables $tcl_platform(debug) and $tcl_platform(threaded) no longer
-	exist. They don't belong in the tcl_platform array, were never documented,
-	disturbed the platform-1.1 test, $tcl_platform(debug) was only available
-	on Windows anyway, and TIP #59 provides a much better alternative.
+	The variables $tcl_platform(debug) and $tcl_platform(threaded) no
+	longer exist. They don't belong in the tcl_platform array, were never
+	documented, disturbed the platform-1.1 test, $tcl_platform(debug) was
+	only available on Windows anyway, and TIP #59 provides a much better
+	alternative.
 
 2012-04-10  Donal K. Fellows  <dkf@users.sf.net>
 
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 81012dc..341f8e0 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -2495,27 +2495,29 @@ ZlibTransformSetOption(			/* not used */
 	 */
 
 	cd->outStream.avail_in = 0;
-	do {
+	while (1) {
 	    int e;
 
 	    cd->outStream.next_out = (Bytef *) cd->outBuffer;
 	    cd->outStream.avail_out = cd->outAllocated;
 
 	    e = deflate(&cd->outStream, flushType);
-	    if (e != Z_OK) {
+	    if (e == Z_BUF_ERROR) {
+		break;
+	    } else if (e != Z_OK) {
 		ConvertError(interp, e);
 		return TCL_ERROR;
+	    } else if (cd->outStream.avail_out == 0) {
+		break;
 	    }
 
-	    if (cd->outStream.avail_out > 0) {
-		if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
-			PTR2INT(cd->outStream.next_out)) < 0) {
-		    Tcl_AppendResult(interp, "problem flushing channel: ",
-			    Tcl_PosixError(interp), NULL);
-		    return TCL_ERROR;
-		}
+	    if (Tcl_WriteRaw(cd->parent, cd->outBuffer,
+		    cd->outStream.next_out - (Bytef*)cd->outBuffer) < 0) {
+		Tcl_AppendResult(interp, "problem flushing channel: ",
+			Tcl_PosixError(interp), NULL);
+		return TCL_ERROR;
 	    }
-	} while (cd->outStream.avail_out > 0);
+	}
 	return TCL_OK;
     }
 
diff --git a/tests/zlib.test b/tests/zlib.test
index 236e6b6..3aaca29 100644
--- a/tests/zlib.test
+++ b/tests/zlib.test
@@ -156,6 +156,18 @@ test zlib-8.3 {zlib transformation and fileevent} -constraints zlib -setup {
     close $srv
     removeFile $file
 } -result 81920-->81920
+test zlib-8.4 {transformation and flushing: Bug 3517696} -setup {
+    set file [makeFile {} test.z]
+    set fd [open $file w]
+} -constraints zlib -body {
+    zlib push compress $fd
+    puts $fd "qwertyuiop"
+    fconfigure $fd -flush sync
+    puts $fd "qwertyuiop"
+} -cleanup {
+    catch {close $fd}
+    removeFile $file
+} -result {}
 
 test zlib-9.1 "check fcopy with push" -constraints zlib -setup {
     set sfile [makeFile {} testsrc.gz]
-- 
cgit v0.12


From 495633568f2ab50817ea65125683cd79de9da091 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 15 Apr 2012 14:07:25 +0000
Subject: Remove some low-value C stack frames.

---
 ChangeLog             |  4 ++++
 generic/tclEnsemble.c |  2 +-
 generic/tclIOUtil.c   | 13 +++++++++----
 3 files changed, 14 insertions(+), 5 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 05631c6..04a4343 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,5 +1,9 @@
 2012-04-15  Donal K. Fellows  <dkf@users.sf.net>
 
+	* generic/tclEnsemble.c (NsEnsembleImplementationCmdNR):
+	* generic/tclIOUtil.c (Tcl_FSEvalFileEx): Cut out levels of the C
+	stack by going direct to the relevant internal evaluation function.
+
 	* generic/tclZlib.c (ZlibTransformSetOption): [Bug 3517696]: Make
 	flushing work correctly in a pushed compressing channel transform.
 
diff --git a/generic/tclEnsemble.c b/generic/tclEnsemble.c
index f33ad31..1e1a901 100644
--- a/generic/tclEnsemble.c
+++ b/generic/tclEnsemble.c
@@ -1849,7 +1849,7 @@ NsEnsembleImplementationCmdNR(
 	 */
 
 	iPtr->evalFlags |= TCL_EVAL_REDIRECT;
-	return Tcl_NREvalObj(interp, copyPtr, TCL_EVAL_INVOKE);
+	return TclNREvalObjEx(interp, copyPtr, TCL_EVAL_INVOKE, NULL,INT_MIN);
     }
 
   unknownOrAmbiguousSubcommand:
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 9905256..3c98128 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1729,9 +1729,12 @@ Tcl_FSEvalFileEx(
 
     objPtr = Tcl_NewObj();
     Tcl_IncrRefCount(objPtr);
-    /* Try to read first character of stream, so we can
-     * check for utf-8 BOM to be handled especially.
+
+    /*
+     * Try to read first character of stream, so we can check for utf-8 BOM to
+     * be handled especially.
      */
+
     if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
 	Tcl_Close(interp, chan);
 	Tcl_AppendResult(interp, "couldn't read file \"",
@@ -1739,10 +1742,12 @@ Tcl_FSEvalFileEx(
 	goto end;
     }
     string = Tcl_GetString(objPtr);
+
     /*
      * If first character is not a BOM, append the remaining characters,
-     * otherwise replace them [Bug 3466099].
+     * otherwise replace them. [Bug 3466099]
      */
+
     if (Tcl_ReadChars(chan, objPtr, -1,
 	    memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
 	Tcl_Close(interp, chan);
@@ -1766,7 +1771,7 @@ Tcl_FSEvalFileEx(
      */
 
     iPtr->evalFlags |= TCL_EVAL_FILE;
-    result = Tcl_EvalEx(interp, string, length, 0);
+    result = TclEvalEx(interp, string, length, 0, 1, NULL, string);
 
     /*
      * Now we have to be careful; the script may have changed the
-- 
cgit v0.12


From 6a7ba7b04d63d79b6944f10426385c91f060a4b0 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Sun, 15 Apr 2012 17:36:34 +0000
Subject: minor comment formatting

---
 generic/tclBasic.c  | 109 +++++++++++++++++++++++++++++++++-------------------
 generic/tclIOUtil.c |  13 +++++--
 2 files changed, 79 insertions(+), 43 deletions(-)

diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 8905849..21fb2e2 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -833,7 +833,7 @@ Tcl_CreateInterp(void)
 
     Tcl_NRCreateCommand(interp, "::tcl::unsupported::inject", NULL,
 	    NRCoroInjectObjCmd, NULL, NULL);
-    
+
 #ifdef USE_DTRACE
     /*
      * Register the tcl::dtrace command.
@@ -3113,8 +3113,8 @@ Tcl_DeleteCommandFromToken(
      * from a CmdName Tcl object in some ByteCode code sequence. In that case,
      * delay the cleanup until all references are either discarded (when a
      * ByteCode is freed) or replaced by a new reference (when a cached
-     * CmdName Command reference is found to be invalid and TclNRExecuteByteCode
-     * looks up the command in the command hashtable).
+     * CmdName Command reference is found to be invalid and
+     * TclNRExecuteByteCode looks up the command in the command hashtable).
      */
 
     TclCleanupCommandMacro(cmdPtr);
@@ -4303,7 +4303,7 @@ TclNREvalObjv(
         return TCL_OK;
     } else {
 	return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv);
-    }        
+    }
 }
 
 void
@@ -8333,7 +8333,7 @@ TclNRTailcallObjCmd(
         Tcl_Namespace *nsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
         Tcl_Namespace *ns1Ptr;
         NRE_callback *tailcallPtr;
-        
+
         listPtr = Tcl_NewListObj(objc-1, objv+1);
         Tcl_IncrRefCount(listPtr);
 
@@ -8344,7 +8344,8 @@ TclNRTailcallObjCmd(
         }
         Tcl_IncrRefCount(nsObjPtr);
 
-        TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr, NULL, NULL);
+        TclNRAddCallback(interp, NRTailcallEval, listPtr, nsObjPtr,
+                NULL, NULL);
         tailcallPtr = TOP_CB(interp);
         TOP_CB(interp) = tailcallPtr->nextPtr;
         iPtr->varFramePtr->tailcallPtr = tailcallPtr;
@@ -8374,7 +8375,7 @@ NRTailcallEval(
          * Tailcall execution was preempted, eg by an intervening catch or by
          * a now-gone namespace: cleanup and return.
          */
-        
+
         TailcallCleanup(data, interp, result);
         return result;
     }
@@ -8457,6 +8458,7 @@ TclNRYieldObjCmd(
     Tcl_Obj *const objv[])
 {
     CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+
     if (objc > 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "?returnValue?");
 	return TCL_ERROR;
@@ -8626,7 +8628,7 @@ NRCoroutineCallerCallback(
     NRE_ASSERT(COR_IS_SUSPENDED(corPtr));
     SAVE_CONTEXT(corPtr->running);
     RESTORE_CONTEXT(corPtr->caller);
-    
+
     if (cmdPtr->flags & CMD_IS_DELETED) {
 	/*
 	 * The command was deleted while it was running: wind down the
@@ -8688,16 +8690,21 @@ NRCoroutineExitCallback(
     return result;
 }
 
-
 /*
+ *----------------------------------------------------------------------
+ *
  * NRCoroutineActivateCallback --
  *
- * This is the workhorse for coroutines: it implements both yield and resume.
+ *      This is the workhorse for coroutines: it implements both yield and
+ *      resume.
  *
- * It is important that both be implemented in the same callback: the
- * detection of the impossibility to suspend due to a busy C-stack relies on
- * the precise position of a local variable in the stack. We do not want the
- * compiler to play tricks on us, either by moving things around or inlining.
+ *      It is important that both be implemented in the same callback: the
+ *      detection of the impossibility to suspend due to a busy C-stack relies
+ *      on the precise position of a local variable in the stack. We do not
+ *      want the compiler to play tricks on us, either by moving things around
+ *      or inlining.
+ *
+ *----------------------------------------------------------------------
  */
 
 static int
@@ -8714,18 +8721,18 @@ NRCoroutineActivateCallback(
     if (!corPtr->stackLevel) {
         /*
          * -- Coroutine is suspended --
-         * Push the callback to restore the caller's context on yield or return
+         * Push the callback to restore the caller's context on yield or
+         * return.
          */
 
-        TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr, NULL, NULL,
-                NULL);
+        TclNRAddCallback(interp, NRCoroutineCallerCallback, corPtr,
+                NULL, NULL, NULL);
 
         /*
          * Record the stackLevel at which the resume is happening, then swap
-         * the interp's environment to make it suitable to run this
-         * coroutine. 
+         * the interp's environment to make it suitable to run this coroutine.
          */
-        
+
         corPtr->stackLevel = stackLevel;
         numLevels = corPtr->auxNumLevels;
         corPtr->auxNumLevels = iPtr->numLevels;
@@ -8735,8 +8742,6 @@ NRCoroutineActivateCallback(
         RESTORE_CONTEXT(corPtr->running);
         iPtr->execEnvPtr = corPtr->eePtr;
         iPtr->numLevels += numLevels;
-        
-        return TCL_OK;
     } else {
         /*
          * Coroutine is active: yield
@@ -8749,15 +8754,15 @@ NRCoroutineActivateCallback(
                     NULL);
             return TCL_ERROR;
         }
-        
-        if (type == CORO_ACTIVATE_YIELD) { 
+
+        if (type == CORO_ACTIVATE_YIELD) {
             corPtr->nargs = COROUTINE_ARGUMENTS_SINGLE_OPTIONAL;
         } else if (type == CORO_ACTIVATE_YIELDM) {
             corPtr->nargs = COROUTINE_ARGUMENTS_ARBITRARY;
         } else {
             Tcl_Panic("Yield received an option which is not implemented");
         }
-        
+
         corPtr->stackLevel = NULL;
 
         numLevels = iPtr->numLevels;
@@ -8765,10 +8770,20 @@ NRCoroutineActivateCallback(
         corPtr->auxNumLevels = numLevels - corPtr->auxNumLevels;
 
         iPtr->execEnvPtr = corPtr->callerEEPtr;
-        return TCL_OK;
     }
+
+    return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * NRCoroInjectObjCmd --
+ *
+ *      Implementation of [::tcl::unsupported::inject] command.
+ *
+ *----------------------------------------------------------------------
+ */
 
 static int
 NRCoroInjectObjCmd(
@@ -8780,7 +8795,7 @@ NRCoroInjectObjCmd(
     Command *cmdPtr;
     CoroutineData *corPtr;
     ExecEnv *savedEEPtr = iPtr->execEnvPtr;
-    
+
     /*
      * Usage more or less like tailcall:
      *   inject coroName cmd ?arg1 arg2 ...?
@@ -8793,25 +8808,30 @@ NRCoroInjectObjCmd(
 
     cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[1]);
     if ((!cmdPtr) || (cmdPtr->nreProc != NRInterpCoroutine)) {
-        Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a coroutine", -1));
+        Tcl_AppendResult(interp, "can only inject a command into a coroutine",
+                NULL);
+        Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COROUTINE",
+                TclGetString(objv[1]), NULL);
         return TCL_ERROR;
     }
 
-    corPtr = (CoroutineData *) cmdPtr->objClientData;
+    corPtr = cmdPtr->objClientData;
     if (!COR_IS_SUSPENDED(corPtr)) {
-        Tcl_SetObjResult(interp, Tcl_NewStringObj("can only inject a command into a suspended coroutine", -1));
+        Tcl_AppendResult(interp,
+                "can only inject a command into a suspended coroutine", NULL);
+        Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ACTIVE", NULL);
         return TCL_ERROR;
     }
 
     /*
      * Add the callback to the coro's execEnv, so that it is the first thing
-     * to happen when the coro is resumed
+     * to happen when the coro is resumed.
      */
-    
+
     iPtr->execEnvPtr = corPtr->eePtr;
-    Tcl_NREvalObj(interp, Tcl_NewListObj(objc-2, objv+2), 0);    
+    TclNREvalObjEx(interp, Tcl_NewListObj(objc-2, objv+2), 0, NULL, INT_MIN);
     iPtr->execEnvPtr = savedEEPtr;
-    
+
     return TCL_OK;
 }
 
@@ -8868,6 +8888,17 @@ NRInterpCoroutine(
     return TCL_OK;
 }
 
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclNRCoroutineObjCmd --
+ *
+ *      Implementation of [coroutine] command; see documentation for
+ *      description of what this does.
+ *
+ *----------------------------------------------------------------------
+ */
+
 int
 TclNRCoroutineObjCmd(
     ClientData dummy,		/* Not used. */
@@ -8881,7 +8912,7 @@ TclNRCoroutineObjCmd(
     Namespace *nsPtr, *altNsPtr, *cxtNsPtr;
     Tcl_DString ds;
     Namespace *lookupNsPtr = iPtr->varFramePtr->nsPtr;
-    
+
     if (objc < 3) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name cmd ?arg ...?");
 	return TCL_ERROR;
@@ -8977,16 +9008,16 @@ TclNRCoroutineObjCmd(
     corPtr->stackLevel = NULL;
     corPtr->auxNumLevels = 0;
     iPtr->numLevels--;
-    
+
     /*
      * Create the coro's execEnv, switch to it to push the exit and coro
-     * command callbacks, then switch back. 
+     * command callbacks, then switch back.
      */
 
     corPtr->eePtr = TclCreateExecEnv(interp, CORO_STACK_INITIAL_SIZE);
     corPtr->callerEEPtr = iPtr->execEnvPtr;
     corPtr->eePtr->corPtr = corPtr;
-    
+
     SAVE_CONTEXT(corPtr->caller);
     corPtr->callerEEPtr = iPtr->execEnvPtr;
     RESTORE_CONTEXT(corPtr->running);
@@ -9001,7 +9032,7 @@ TclNRCoroutineObjCmd(
     SAVE_CONTEXT(corPtr->running);
     RESTORE_CONTEXT(corPtr->caller);
     iPtr->execEnvPtr = corPtr->callerEEPtr;
-    
+
     /*
      * Now just resume the coroutine. Take care to insure that the command is
      * looked up in the correct namespace.
diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c
index 3c98128..c4e7db0 100644
--- a/generic/tclIOUtil.c
+++ b/generic/tclIOUtil.c
@@ -1860,9 +1860,12 @@ TclNREvalFile(
 
     objPtr = Tcl_NewObj();
     Tcl_IncrRefCount(objPtr);
-    /* Try to read first character of stream, so we can
-     * check for utf-8 BOM to be handled especially.
+
+    /*
+     * Try to read first character of stream, so we can check for utf-8 BOM to
+     * be handled especially.
      */
+
     if (Tcl_ReadChars(chan, objPtr, 1, 0) < 0) {
 	Tcl_Close(interp, chan);
 	Tcl_AppendResult(interp, "couldn't read file \"",
@@ -1871,15 +1874,17 @@ TclNREvalFile(
 	return TCL_ERROR;
     }
     string = Tcl_GetString(objPtr);
+
     /*
      * If first character is not a BOM, append the remaining characters,
-     * otherwise replace them [Bug 3466099].
+     * otherwise replace them. [Bug 3466099]
      */
+
     if (Tcl_ReadChars(chan, objPtr, -1,
 	    memcmp(string, "\xef\xbb\xbf", 3)) < 0) {
 	Tcl_Close(interp, chan);
 	Tcl_AppendResult(interp, "couldn't read file \"",
-			Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
+		Tcl_GetString(pathPtr), "\": ", Tcl_PosixError(interp), NULL);
 	Tcl_DecrRefCount(objPtr);
 	return TCL_ERROR;
     }
-- 
cgit v0.12


From e5ced1c96d6213766cd6263eddcab12ba1a916a9 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Tue, 17 Apr 2012 13:49:46 +0000
Subject: Restore the tcl_platform(threaded) variable.

---
 ChangeLog           |  7 -------
 generic/tclBasic.c  | 11 +++++++++++
 tests/platform.test |  2 ++
 3 files changed, 13 insertions(+), 7 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 668108b..96f8d1e 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -34,13 +34,6 @@
 	* library/dde/pkgIndex.tcl   Use [::tcl::pkgconfig get debug] instead
 	* library/reg/pkgIndex.tcl   of [info exists ::tcl_platform(debug)]
 
-	***POTENTIAL INCOMPATIBILITY***
-	The variables $tcl_platform(debug) and $tcl_platform(threaded) no
-	longer exist. They don't belong in the tcl_platform array, were never
-	documented, disturbed the platform-1.1 test, $tcl_platform(debug) was
-	only available on Windows anyway, and TIP #59 provides a much better
-	alternative.
-
 2012-04-10  Donal K. Fellows  <dkf@users.sf.net>
 
 	* generic/tcl.h (TCL_DEPRECATED_API): [Bug 2458976]: Added macro that
diff --git a/generic/tclBasic.c b/generic/tclBasic.c
index 21fb2e2..e09ea1e 100644
--- a/generic/tclBasic.c
+++ b/generic/tclBasic.c
@@ -928,6 +928,17 @@ Tcl_CreateInterp(void)
 	    TclPrecTraceProc, NULL);
     TclpSetVariables(interp);
 
+#ifdef TCL_THREADS
+    /*
+     * The existence of the "threaded" element of the tcl_platform array
+     * indicates that this particular Tcl shell has been compiled with threads
+     * turned on. Using "info exists tcl_platform(threaded)" a Tcl script can
+     * introspect on the interpreter level of thread safety.
+     */
+
+    Tcl_SetVar2(interp, "tcl_platform", "threaded", "1", TCL_GLOBAL_ONLY);
+#endif
+
     /*
      * Register Tcl's version number.
      * TIP #268: Full patchlevel instead of just major.minor
diff --git a/tests/platform.test b/tests/platform.test
index 33c96ba..8cb8dcd 100644
--- a/tests/platform.test
+++ b/tests/platform.test
@@ -18,6 +18,8 @@ testConstraint testWinCPUID [llength [info commands testwincpuid]]
 
 test platform-1.1 {TclpSetVariables: tcl_platform} {
     interp create i
+    i eval {catch {unset tcl_platform(debug)}}
+    i eval {catch {unset tcl_platform(threaded)}}
     set result [i eval {lsort [array names tcl_platform]}]
     interp delete i
     set result
-- 
cgit v0.12


From eaa13cf52586163655438eb6476745a85dbc34d5 Mon Sep 17 00:00:00 2001
From: Kevin B Kenny <kennykb@acm.org>
Date: Wed, 18 Apr 2012 12:44:05 +0000
Subject: Apply tzdata2012c

---
 ChangeLog                             |   8 ++
 library/tzdata/Africa/Casablanca      | 176 ++++++++++++++++++++++++++++++++++
 library/tzdata/America/Port-au-Prince |   2 +
 library/tzdata/Asia/Damascus          | 176 +++++++++++++++++-----------------
 library/tzdata/Asia/Gaza              |   2 +
 library/tzdata/Asia/Hebron            |   2 +
 6 files changed, 278 insertions(+), 88 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 4a7e267..78c4940 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2012-04-18  Kevin B. Kenny  <kennykb@acm.org>
+
+	* library/tzdata/Africa/Casablanca:
+	* library/tzdata/America/Port-au-Prince:
+	* library/tzdata/Asia/Damascus:
+	* library/tzdata/Asia/Gaza:
+	* library/tzdata/Asia/Hebron: tzdata2012c
+
 2012-04-16  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/FileSystem.3 (Tcl_FSOpenFileChannelProc): [Bug 3518244]: Fixed
diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca
index 0eef1ac..3817077 100644
--- a/library/tzdata/Africa/Casablanca
+++ b/library/tzdata/Africa/Casablanca
@@ -29,4 +29,180 @@ set TZData(:Africa/Casablanca) {
     {1281222000 0 0 WET}
     {1301788800 3600 1 WEST}
     {1312066800 0 0 WET}
+    {1335664800 3600 1 WEST}
+    {1348970400 0 0 WET}
+    {1367114400 3600 1 WEST}
+    {1380420000 0 0 WET}
+    {1398564000 3600 1 WEST}
+    {1411869600 0 0 WET}
+    {1430013600 3600 1 WEST}
+    {1443319200 0 0 WET}
+    {1461463200 3600 1 WEST}
+    {1474768800 0 0 WET}
+    {1493517600 3600 1 WEST}
+    {1506218400 0 0 WET}
+    {1524967200 3600 1 WEST}
+    {1538272800 0 0 WET}
+    {1556416800 3600 1 WEST}
+    {1569722400 0 0 WET}
+    {1587866400 3600 1 WEST}
+    {1601172000 0 0 WET}
+    {1619316000 3600 1 WEST}
+    {1632621600 0 0 WET}
+    {1650765600 3600 1 WEST}
+    {1664071200 0 0 WET}
+    {1682820000 3600 1 WEST}
+    {1695520800 0 0 WET}
+    {1714269600 3600 1 WEST}
+    {1727575200 0 0 WET}
+    {1745719200 3600 1 WEST}
+    {1759024800 0 0 WET}
+    {1777168800 3600 1 WEST}
+    {1790474400 0 0 WET}
+    {1808618400 3600 1 WEST}
+    {1821924000 0 0 WET}
+    {1840672800 3600 1 WEST}
+    {1853373600 0 0 WET}
+    {1872122400 3600 1 WEST}
+    {1885428000 0 0 WET}
+    {1903572000 3600 1 WEST}
+    {1916877600 0 0 WET}
+    {1935021600 3600 1 WEST}
+    {1948327200 0 0 WET}
+    {1966471200 3600 1 WEST}
+    {1979776800 0 0 WET}
+    {1997920800 3600 1 WEST}
+    {2011226400 0 0 WET}
+    {2029975200 3600 1 WEST}
+    {2042676000 0 0 WET}
+    {2061424800 3600 1 WEST}
+    {2074730400 0 0 WET}
+    {2092874400 3600 1 WEST}
+    {2106180000 0 0 WET}
+    {2124324000 3600 1 WEST}
+    {2137629600 0 0 WET}
+    {2155773600 3600 1 WEST}
+    {2169079200 0 0 WET}
+    {2187223200 3600 1 WEST}
+    {2200528800 0 0 WET}
+    {2219277600 3600 1 WEST}
+    {2232583200 0 0 WET}
+    {2250727200 3600 1 WEST}
+    {2264032800 0 0 WET}
+    {2282176800 3600 1 WEST}
+    {2295482400 0 0 WET}
+    {2313626400 3600 1 WEST}
+    {2326932000 0 0 WET}
+    {2345076000 3600 1 WEST}
+    {2358381600 0 0 WET}
+    {2377130400 3600 1 WEST}
+    {2389831200 0 0 WET}
+    {2408580000 3600 1 WEST}
+    {2421885600 0 0 WET}
+    {2440029600 3600 1 WEST}
+    {2453335200 0 0 WET}
+    {2471479200 3600 1 WEST}
+    {2484784800 0 0 WET}
+    {2502928800 3600 1 WEST}
+    {2516234400 0 0 WET}
+    {2534378400 3600 1 WEST}
+    {2547684000 0 0 WET}
+    {2566432800 3600 1 WEST}
+    {2579133600 0 0 WET}
+    {2597882400 3600 1 WEST}
+    {2611188000 0 0 WET}
+    {2629332000 3600 1 WEST}
+    {2642637600 0 0 WET}
+    {2660781600 3600 1 WEST}
+    {2674087200 0 0 WET}
+    {2692231200 3600 1 WEST}
+    {2705536800 0 0 WET}
+    {2724285600 3600 1 WEST}
+    {2736986400 0 0 WET}
+    {2755735200 3600 1 WEST}
+    {2769040800 0 0 WET}
+    {2787184800 3600 1 WEST}
+    {2800490400 0 0 WET}
+    {2818634400 3600 1 WEST}
+    {2831940000 0 0 WET}
+    {2850084000 3600 1 WEST}
+    {2863389600 0 0 WET}
+    {2881533600 3600 1 WEST}
+    {2894839200 0 0 WET}
+    {2913588000 3600 1 WEST}
+    {2926288800 0 0 WET}
+    {2945037600 3600 1 WEST}
+    {2958343200 0 0 WET}
+    {2976487200 3600 1 WEST}
+    {2989792800 0 0 WET}
+    {3007936800 3600 1 WEST}
+    {3021242400 0 0 WET}
+    {3039386400 3600 1 WEST}
+    {3052692000 0 0 WET}
+    {3070836000 3600 1 WEST}
+    {3084141600 0 0 WET}
+    {3102890400 3600 1 WEST}
+    {3116196000 0 0 WET}
+    {3134340000 3600 1 WEST}
+    {3147645600 0 0 WET}
+    {3165789600 3600 1 WEST}
+    {3179095200 0 0 WET}
+    {3197239200 3600 1 WEST}
+    {3210544800 0 0 WET}
+    {3228688800 3600 1 WEST}
+    {3241994400 0 0 WET}
+    {3260743200 3600 1 WEST}
+    {3273444000 0 0 WET}
+    {3292192800 3600 1 WEST}
+    {3305498400 0 0 WET}
+    {3323642400 3600 1 WEST}
+    {3336948000 0 0 WET}
+    {3355092000 3600 1 WEST}
+    {3368397600 0 0 WET}
+    {3386541600 3600 1 WEST}
+    {3399847200 0 0 WET}
+    {3417991200 3600 1 WEST}
+    {3431296800 0 0 WET}
+    {3450045600 3600 1 WEST}
+    {3462746400 0 0 WET}
+    {3481495200 3600 1 WEST}
+    {3494800800 0 0 WET}
+    {3512944800 3600 1 WEST}
+    {3526250400 0 0 WET}
+    {3544394400 3600 1 WEST}
+    {3557700000 0 0 WET}
+    {3575844000 3600 1 WEST}
+    {3589149600 0 0 WET}
+    {3607898400 3600 1 WEST}
+    {3620599200 0 0 WET}
+    {3639348000 3600 1 WEST}
+    {3652653600 0 0 WET}
+    {3670797600 3600 1 WEST}
+    {3684103200 0 0 WET}
+    {3702247200 3600 1 WEST}
+    {3715552800 0 0 WET}
+    {3733696800 3600 1 WEST}
+    {3747002400 0 0 WET}
+    {3765146400 3600 1 WEST}
+    {3778452000 0 0 WET}
+    {3797200800 3600 1 WEST}
+    {3809901600 0 0 WET}
+    {3828650400 3600 1 WEST}
+    {3841956000 0 0 WET}
+    {3860100000 3600 1 WEST}
+    {3873405600 0 0 WET}
+    {3891549600 3600 1 WEST}
+    {3904855200 0 0 WET}
+    {3922999200 3600 1 WEST}
+    {3936304800 0 0 WET}
+    {3954448800 3600 1 WEST}
+    {3967754400 0 0 WET}
+    {3986503200 3600 1 WEST}
+    {3999808800 0 0 WET}
+    {4017952800 3600 1 WEST}
+    {4031258400 0 0 WET}
+    {4049402400 3600 1 WEST}
+    {4062708000 0 0 WET}
+    {4080852000 3600 1 WEST}
+    {4094157600 0 0 WET}
 }
diff --git a/library/tzdata/America/Port-au-Prince b/library/tzdata/America/Port-au-Prince
index 04ee62c..639972b 100644
--- a/library/tzdata/America/Port-au-Prince
+++ b/library/tzdata/America/Port-au-Prince
@@ -38,4 +38,6 @@ set TZData(:America/Port-au-Prince) {
     {1130644800 -18000 0 EST}
     {1143954000 -14400 1 EDT}
     {1162094400 -18000 0 EST}
+    {1331449200 -14400 1 EDT}
+    {1352008800 -18000 0 EST}
 }
diff --git a/library/tzdata/Asia/Damascus b/library/tzdata/Asia/Damascus
index 2ea1770..fafef49 100644
--- a/library/tzdata/Asia/Damascus
+++ b/library/tzdata/Asia/Damascus
@@ -101,180 +101,180 @@ set TZData(:Asia/Damascus) {
     {1288299600 7200 0 EET}
     {1301608800 10800 1 EEST}
     {1319749200 7200 0 EET}
-    {1333663200 10800 1 EEST}
+    {1333058400 10800 1 EEST}
     {1351198800 7200 0 EET}
-    {1365112800 10800 1 EEST}
+    {1364508000 10800 1 EEST}
     {1382648400 7200 0 EET}
-    {1396562400 10800 1 EEST}
+    {1395957600 10800 1 EEST}
     {1414702800 7200 0 EET}
-    {1428012000 10800 1 EEST}
+    {1427407200 10800 1 EEST}
     {1446152400 7200 0 EET}
-    {1459461600 10800 1 EEST}
+    {1458856800 10800 1 EEST}
     {1477602000 7200 0 EET}
-    {1491516000 10800 1 EEST}
+    {1490911200 10800 1 EEST}
     {1509051600 7200 0 EET}
-    {1522965600 10800 1 EEST}
+    {1522360800 10800 1 EEST}
     {1540501200 7200 0 EET}
-    {1554415200 10800 1 EEST}
+    {1553810400 10800 1 EEST}
     {1571950800 7200 0 EET}
-    {1585864800 10800 1 EEST}
+    {1585260000 10800 1 EEST}
     {1604005200 7200 0 EET}
-    {1617314400 10800 1 EEST}
+    {1616709600 10800 1 EEST}
     {1635454800 7200 0 EET}
-    {1648764000 10800 1 EEST}
+    {1648159200 10800 1 EEST}
     {1666904400 7200 0 EET}
-    {1680818400 10800 1 EEST}
+    {1680213600 10800 1 EEST}
     {1698354000 7200 0 EET}
-    {1712268000 10800 1 EEST}
+    {1711663200 10800 1 EEST}
     {1729803600 7200 0 EET}
-    {1743717600 10800 1 EEST}
+    {1743112800 10800 1 EEST}
     {1761858000 7200 0 EET}
-    {1775167200 10800 1 EEST}
+    {1774562400 10800 1 EEST}
     {1793307600 7200 0 EET}
-    {1806616800 10800 1 EEST}
+    {1806012000 10800 1 EEST}
     {1824757200 7200 0 EET}
-    {1838671200 10800 1 EEST}
+    {1838066400 10800 1 EEST}
     {1856206800 7200 0 EET}
-    {1870120800 10800 1 EEST}
+    {1869516000 10800 1 EEST}
     {1887656400 7200 0 EET}
-    {1901570400 10800 1 EEST}
+    {1900965600 10800 1 EEST}
     {1919106000 7200 0 EET}
-    {1933020000 10800 1 EEST}
+    {1932415200 10800 1 EEST}
     {1951160400 7200 0 EET}
-    {1964469600 10800 1 EEST}
+    {1963864800 10800 1 EEST}
     {1982610000 7200 0 EET}
-    {1995919200 10800 1 EEST}
+    {1995314400 10800 1 EEST}
     {2014059600 7200 0 EET}
-    {2027973600 10800 1 EEST}
+    {2027368800 10800 1 EEST}
     {2045509200 7200 0 EET}
-    {2059423200 10800 1 EEST}
+    {2058818400 10800 1 EEST}
     {2076958800 7200 0 EET}
-    {2090872800 10800 1 EEST}
+    {2090268000 10800 1 EEST}
     {2109013200 7200 0 EET}
-    {2122322400 10800 1 EEST}
+    {2121717600 10800 1 EEST}
     {2140462800 7200 0 EET}
-    {2153772000 10800 1 EEST}
+    {2153167200 10800 1 EEST}
     {2171912400 7200 0 EET}
-    {2185221600 10800 1 EEST}
+    {2184616800 10800 1 EEST}
     {2203362000 7200 0 EET}
-    {2217276000 10800 1 EEST}
+    {2216671200 10800 1 EEST}
     {2234811600 7200 0 EET}
-    {2248725600 10800 1 EEST}
+    {2248120800 10800 1 EEST}
     {2266261200 7200 0 EET}
-    {2280175200 10800 1 EEST}
+    {2279570400 10800 1 EEST}
     {2298315600 7200 0 EET}
-    {2311624800 10800 1 EEST}
+    {2311020000 10800 1 EEST}
     {2329765200 7200 0 EET}
-    {2343074400 10800 1 EEST}
+    {2342469600 10800 1 EEST}
     {2361214800 7200 0 EET}
-    {2375128800 10800 1 EEST}
+    {2374524000 10800 1 EEST}
     {2392664400 7200 0 EET}
-    {2406578400 10800 1 EEST}
+    {2405973600 10800 1 EEST}
     {2424114000 7200 0 EET}
-    {2438028000 10800 1 EEST}
+    {2437423200 10800 1 EEST}
     {2455563600 7200 0 EET}
-    {2469477600 10800 1 EEST}
+    {2468872800 10800 1 EEST}
     {2487618000 7200 0 EET}
-    {2500927200 10800 1 EEST}
+    {2500322400 10800 1 EEST}
     {2519067600 7200 0 EET}
-    {2532376800 10800 1 EEST}
+    {2531772000 10800 1 EEST}
     {2550517200 7200 0 EET}
-    {2564431200 10800 1 EEST}
+    {2563826400 10800 1 EEST}
     {2581966800 7200 0 EET}
-    {2595880800 10800 1 EEST}
+    {2595276000 10800 1 EEST}
     {2613416400 7200 0 EET}
-    {2627330400 10800 1 EEST}
+    {2626725600 10800 1 EEST}
     {2645470800 7200 0 EET}
-    {2658780000 10800 1 EEST}
+    {2658175200 10800 1 EEST}
     {2676920400 7200 0 EET}
-    {2690229600 10800 1 EEST}
+    {2689624800 10800 1 EEST}
     {2708370000 7200 0 EET}
-    {2722284000 10800 1 EEST}
+    {2721679200 10800 1 EEST}
     {2739819600 7200 0 EET}
-    {2753733600 10800 1 EEST}
+    {2753128800 10800 1 EEST}
     {2771269200 7200 0 EET}
-    {2785183200 10800 1 EEST}
+    {2784578400 10800 1 EEST}
     {2802718800 7200 0 EET}
-    {2816632800 10800 1 EEST}
+    {2816028000 10800 1 EEST}
     {2834773200 7200 0 EET}
-    {2848082400 10800 1 EEST}
+    {2847477600 10800 1 EEST}
     {2866222800 7200 0 EET}
-    {2879532000 10800 1 EEST}
+    {2878927200 10800 1 EEST}
     {2897672400 7200 0 EET}
-    {2911586400 10800 1 EEST}
+    {2910981600 10800 1 EEST}
     {2929122000 7200 0 EET}
-    {2943036000 10800 1 EEST}
+    {2942431200 10800 1 EEST}
     {2960571600 7200 0 EET}
-    {2974485600 10800 1 EEST}
+    {2973880800 10800 1 EEST}
     {2992626000 7200 0 EET}
-    {3005935200 10800 1 EEST}
+    {3005330400 10800 1 EEST}
     {3024075600 7200 0 EET}
-    {3037384800 10800 1 EEST}
+    {3036780000 10800 1 EEST}
     {3055525200 7200 0 EET}
-    {3068834400 10800 1 EEST}
+    {3068229600 10800 1 EEST}
     {3086974800 7200 0 EET}
-    {3100888800 10800 1 EEST}
+    {3100284000 10800 1 EEST}
     {3118424400 7200 0 EET}
-    {3132338400 10800 1 EEST}
+    {3131733600 10800 1 EEST}
     {3149874000 7200 0 EET}
-    {3163788000 10800 1 EEST}
+    {3163183200 10800 1 EEST}
     {3181928400 7200 0 EET}
-    {3195237600 10800 1 EEST}
+    {3194632800 10800 1 EEST}
     {3213378000 7200 0 EET}
-    {3226687200 10800 1 EEST}
+    {3226082400 10800 1 EEST}
     {3244827600 7200 0 EET}
-    {3258741600 10800 1 EEST}
+    {3258136800 10800 1 EEST}
     {3276277200 7200 0 EET}
-    {3290191200 10800 1 EEST}
+    {3289586400 10800 1 EEST}
     {3307726800 7200 0 EET}
-    {3321640800 10800 1 EEST}
+    {3321036000 10800 1 EEST}
     {3339176400 7200 0 EET}
-    {3353090400 10800 1 EEST}
+    {3352485600 10800 1 EEST}
     {3371230800 7200 0 EET}
-    {3384540000 10800 1 EEST}
+    {3383935200 10800 1 EEST}
     {3402680400 7200 0 EET}
-    {3415989600 10800 1 EEST}
+    {3415384800 10800 1 EEST}
     {3434130000 7200 0 EET}
-    {3448044000 10800 1 EEST}
+    {3447439200 10800 1 EEST}
     {3465579600 7200 0 EET}
-    {3479493600 10800 1 EEST}
+    {3478888800 10800 1 EEST}
     {3497029200 7200 0 EET}
-    {3510943200 10800 1 EEST}
+    {3510338400 10800 1 EEST}
     {3529083600 7200 0 EET}
-    {3542392800 10800 1 EEST}
+    {3541788000 10800 1 EEST}
     {3560533200 7200 0 EET}
-    {3573842400 10800 1 EEST}
+    {3573237600 10800 1 EEST}
     {3591982800 7200 0 EET}
-    {3605896800 10800 1 EEST}
+    {3605292000 10800 1 EEST}
     {3623432400 7200 0 EET}
-    {3637346400 10800 1 EEST}
+    {3636741600 10800 1 EEST}
     {3654882000 7200 0 EET}
-    {3668796000 10800 1 EEST}
+    {3668191200 10800 1 EEST}
     {3686331600 7200 0 EET}
-    {3700245600 10800 1 EEST}
+    {3699640800 10800 1 EEST}
     {3718386000 7200 0 EET}
-    {3731695200 10800 1 EEST}
+    {3731090400 10800 1 EEST}
     {3749835600 7200 0 EET}
-    {3763144800 10800 1 EEST}
+    {3762540000 10800 1 EEST}
     {3781285200 7200 0 EET}
-    {3795199200 10800 1 EEST}
+    {3794594400 10800 1 EEST}
     {3812734800 7200 0 EET}
-    {3826648800 10800 1 EEST}
+    {3826044000 10800 1 EEST}
     {3844184400 7200 0 EET}
-    {3858098400 10800 1 EEST}
+    {3857493600 10800 1 EEST}
     {3876238800 7200 0 EET}
-    {3889548000 10800 1 EEST}
+    {3888943200 10800 1 EEST}
     {3907688400 7200 0 EET}
-    {3920997600 10800 1 EEST}
+    {3920392800 10800 1 EEST}
     {3939138000 7200 0 EET}
-    {3952447200 10800 1 EEST}
+    {3951842400 10800 1 EEST}
     {3970587600 7200 0 EET}
-    {3984501600 10800 1 EEST}
+    {3983896800 10800 1 EEST}
     {4002037200 7200 0 EET}
-    {4015951200 10800 1 EEST}
+    {4015346400 10800 1 EEST}
     {4033486800 7200 0 EET}
-    {4047400800 10800 1 EEST}
+    {4046796000 10800 1 EEST}
     {4065541200 7200 0 EET}
-    {4078850400 10800 1 EEST}
+    {4078245600 10800 1 EEST}
     {4096990800 7200 0 EET}
 }
diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza
index 18b1506..2094969 100644
--- a/library/tzdata/Asia/Gaza
+++ b/library/tzdata/Asia/Gaza
@@ -96,4 +96,6 @@ set TZData(:Asia/Gaza) {
     {1281474000 7200 0 EET}
     {1301738460 10800 1 EEST}
     {1312146000 7200 0 EET}
+    {1333058400 10800 1 EEST}
+    {1348779600 7200 0 EET}
 }
diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron
index 71e0064..69addd8 100644
--- a/library/tzdata/Asia/Hebron
+++ b/library/tzdata/Asia/Hebron
@@ -99,4 +99,6 @@ set TZData(:Asia/Hebron) {
     {1312146000 7200 0 EET}
     {1314655200 10800 1 EEST}
     {1317340800 7200 0 EET}
+    {1333058400 10800 1 EEST}
+    {1348790400 7200 0 EET}
 }
-- 
cgit v0.12


From 61bc85933fbf275bf50f7507d57008d99f2a7907 Mon Sep 17 00:00:00 2001
From: Kevin B Kenny <kennykb@acm.org>
Date: Wed, 18 Apr 2012 12:47:02 +0000
Subject: Apply tzdata2012c

---
 ChangeLog                             |   8 ++
 library/tzdata/Africa/Casablanca      | 176 ++++++++++++++++++++++++++++++++++
 library/tzdata/America/Port-au-Prince |   2 +
 library/tzdata/Asia/Damascus          | 176 +++++++++++++++++-----------------
 library/tzdata/Asia/Gaza              |   2 +
 library/tzdata/Asia/Hebron            |   2 +
 6 files changed, 278 insertions(+), 88 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 96f8d1e..33d08fe 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,11 @@
+2012-04-18  Kevin B. Kenny  <kennykb@acm.org>
+
+	* library/tzdata/Africa/Casablanca:
+	* library/tzdata/America/Port-au-Prince:
+	* library/tzdata/Asia/Damascus:
+	* library/tzdata/Asia/Gaza:
+	* library/tzdata/Asia/Hebron: tzdata2012c
+
 2012-04-16  Donal K. Fellows  <dkf@users.sf.net>
 
 	* doc/FileSystem.3 (Tcl_FSOpenFileChannelProc): [Bug 3518244]: Fixed
diff --git a/library/tzdata/Africa/Casablanca b/library/tzdata/Africa/Casablanca
index 0eef1ac..3817077 100644
--- a/library/tzdata/Africa/Casablanca
+++ b/library/tzdata/Africa/Casablanca
@@ -29,4 +29,180 @@ set TZData(:Africa/Casablanca) {
     {1281222000 0 0 WET}
     {1301788800 3600 1 WEST}
     {1312066800 0 0 WET}
+    {1335664800 3600 1 WEST}
+    {1348970400 0 0 WET}
+    {1367114400 3600 1 WEST}
+    {1380420000 0 0 WET}
+    {1398564000 3600 1 WEST}
+    {1411869600 0 0 WET}
+    {1430013600 3600 1 WEST}
+    {1443319200 0 0 WET}
+    {1461463200 3600 1 WEST}
+    {1474768800 0 0 WET}
+    {1493517600 3600 1 WEST}
+    {1506218400 0 0 WET}
+    {1524967200 3600 1 WEST}
+    {1538272800 0 0 WET}
+    {1556416800 3600 1 WEST}
+    {1569722400 0 0 WET}
+    {1587866400 3600 1 WEST}
+    {1601172000 0 0 WET}
+    {1619316000 3600 1 WEST}
+    {1632621600 0 0 WET}
+    {1650765600 3600 1 WEST}
+    {1664071200 0 0 WET}
+    {1682820000 3600 1 WEST}
+    {1695520800 0 0 WET}
+    {1714269600 3600 1 WEST}
+    {1727575200 0 0 WET}
+    {1745719200 3600 1 WEST}
+    {1759024800 0 0 WET}
+    {1777168800 3600 1 WEST}
+    {1790474400 0 0 WET}
+    {1808618400 3600 1 WEST}
+    {1821924000 0 0 WET}
+    {1840672800 3600 1 WEST}
+    {1853373600 0 0 WET}
+    {1872122400 3600 1 WEST}
+    {1885428000 0 0 WET}
+    {1903572000 3600 1 WEST}
+    {1916877600 0 0 WET}
+    {1935021600 3600 1 WEST}
+    {1948327200 0 0 WET}
+    {1966471200 3600 1 WEST}
+    {1979776800 0 0 WET}
+    {1997920800 3600 1 WEST}
+    {2011226400 0 0 WET}
+    {2029975200 3600 1 WEST}
+    {2042676000 0 0 WET}
+    {2061424800 3600 1 WEST}
+    {2074730400 0 0 WET}
+    {2092874400 3600 1 WEST}
+    {2106180000 0 0 WET}
+    {2124324000 3600 1 WEST}
+    {2137629600 0 0 WET}
+    {2155773600 3600 1 WEST}
+    {2169079200 0 0 WET}
+    {2187223200 3600 1 WEST}
+    {2200528800 0 0 WET}
+    {2219277600 3600 1 WEST}
+    {2232583200 0 0 WET}
+    {2250727200 3600 1 WEST}
+    {2264032800 0 0 WET}
+    {2282176800 3600 1 WEST}
+    {2295482400 0 0 WET}
+    {2313626400 3600 1 WEST}
+    {2326932000 0 0 WET}
+    {2345076000 3600 1 WEST}
+    {2358381600 0 0 WET}
+    {2377130400 3600 1 WEST}
+    {2389831200 0 0 WET}
+    {2408580000 3600 1 WEST}
+    {2421885600 0 0 WET}
+    {2440029600 3600 1 WEST}
+    {2453335200 0 0 WET}
+    {2471479200 3600 1 WEST}
+    {2484784800 0 0 WET}
+    {2502928800 3600 1 WEST}
+    {2516234400 0 0 WET}
+    {2534378400 3600 1 WEST}
+    {2547684000 0 0 WET}
+    {2566432800 3600 1 WEST}
+    {2579133600 0 0 WET}
+    {2597882400 3600 1 WEST}
+    {2611188000 0 0 WET}
+    {2629332000 3600 1 WEST}
+    {2642637600 0 0 WET}
+    {2660781600 3600 1 WEST}
+    {2674087200 0 0 WET}
+    {2692231200 3600 1 WEST}
+    {2705536800 0 0 WET}
+    {2724285600 3600 1 WEST}
+    {2736986400 0 0 WET}
+    {2755735200 3600 1 WEST}
+    {2769040800 0 0 WET}
+    {2787184800 3600 1 WEST}
+    {2800490400 0 0 WET}
+    {2818634400 3600 1 WEST}
+    {2831940000 0 0 WET}
+    {2850084000 3600 1 WEST}
+    {2863389600 0 0 WET}
+    {2881533600 3600 1 WEST}
+    {2894839200 0 0 WET}
+    {2913588000 3600 1 WEST}
+    {2926288800 0 0 WET}
+    {2945037600 3600 1 WEST}
+    {2958343200 0 0 WET}
+    {2976487200 3600 1 WEST}
+    {2989792800 0 0 WET}
+    {3007936800 3600 1 WEST}
+    {3021242400 0 0 WET}
+    {3039386400 3600 1 WEST}
+    {3052692000 0 0 WET}
+    {3070836000 3600 1 WEST}
+    {3084141600 0 0 WET}
+    {3102890400 3600 1 WEST}
+    {3116196000 0 0 WET}
+    {3134340000 3600 1 WEST}
+    {3147645600 0 0 WET}
+    {3165789600 3600 1 WEST}
+    {3179095200 0 0 WET}
+    {3197239200 3600 1 WEST}
+    {3210544800 0 0 WET}
+    {3228688800 3600 1 WEST}
+    {3241994400 0 0 WET}
+    {3260743200 3600 1 WEST}
+    {3273444000 0 0 WET}
+    {3292192800 3600 1 WEST}
+    {3305498400 0 0 WET}
+    {3323642400 3600 1 WEST}
+    {3336948000 0 0 WET}
+    {3355092000 3600 1 WEST}
+    {3368397600 0 0 WET}
+    {3386541600 3600 1 WEST}
+    {3399847200 0 0 WET}
+    {3417991200 3600 1 WEST}
+    {3431296800 0 0 WET}
+    {3450045600 3600 1 WEST}
+    {3462746400 0 0 WET}
+    {3481495200 3600 1 WEST}
+    {3494800800 0 0 WET}
+    {3512944800 3600 1 WEST}
+    {3526250400 0 0 WET}
+    {3544394400 3600 1 WEST}
+    {3557700000 0 0 WET}
+    {3575844000 3600 1 WEST}
+    {3589149600 0 0 WET}
+    {3607898400 3600 1 WEST}
+    {3620599200 0 0 WET}
+    {3639348000 3600 1 WEST}
+    {3652653600 0 0 WET}
+    {3670797600 3600 1 WEST}
+    {3684103200 0 0 WET}
+    {3702247200 3600 1 WEST}
+    {3715552800 0 0 WET}
+    {3733696800 3600 1 WEST}
+    {3747002400 0 0 WET}
+    {3765146400 3600 1 WEST}
+    {3778452000 0 0 WET}
+    {3797200800 3600 1 WEST}
+    {3809901600 0 0 WET}
+    {3828650400 3600 1 WEST}
+    {3841956000 0 0 WET}
+    {3860100000 3600 1 WEST}
+    {3873405600 0 0 WET}
+    {3891549600 3600 1 WEST}
+    {3904855200 0 0 WET}
+    {3922999200 3600 1 WEST}
+    {3936304800 0 0 WET}
+    {3954448800 3600 1 WEST}
+    {3967754400 0 0 WET}
+    {3986503200 3600 1 WEST}
+    {3999808800 0 0 WET}
+    {4017952800 3600 1 WEST}
+    {4031258400 0 0 WET}
+    {4049402400 3600 1 WEST}
+    {4062708000 0 0 WET}
+    {4080852000 3600 1 WEST}
+    {4094157600 0 0 WET}
 }
diff --git a/library/tzdata/America/Port-au-Prince b/library/tzdata/America/Port-au-Prince
index 04ee62c..639972b 100644
--- a/library/tzdata/America/Port-au-Prince
+++ b/library/tzdata/America/Port-au-Prince
@@ -38,4 +38,6 @@ set TZData(:America/Port-au-Prince) {
     {1130644800 -18000 0 EST}
     {1143954000 -14400 1 EDT}
     {1162094400 -18000 0 EST}
+    {1331449200 -14400 1 EDT}
+    {1352008800 -18000 0 EST}
 }
diff --git a/library/tzdata/Asia/Damascus b/library/tzdata/Asia/Damascus
index 2ea1770..fafef49 100644
--- a/library/tzdata/Asia/Damascus
+++ b/library/tzdata/Asia/Damascus
@@ -101,180 +101,180 @@ set TZData(:Asia/Damascus) {
     {1288299600 7200 0 EET}
     {1301608800 10800 1 EEST}
     {1319749200 7200 0 EET}
-    {1333663200 10800 1 EEST}
+    {1333058400 10800 1 EEST}
     {1351198800 7200 0 EET}
-    {1365112800 10800 1 EEST}
+    {1364508000 10800 1 EEST}
     {1382648400 7200 0 EET}
-    {1396562400 10800 1 EEST}
+    {1395957600 10800 1 EEST}
     {1414702800 7200 0 EET}
-    {1428012000 10800 1 EEST}
+    {1427407200 10800 1 EEST}
     {1446152400 7200 0 EET}
-    {1459461600 10800 1 EEST}
+    {1458856800 10800 1 EEST}
     {1477602000 7200 0 EET}
-    {1491516000 10800 1 EEST}
+    {1490911200 10800 1 EEST}
     {1509051600 7200 0 EET}
-    {1522965600 10800 1 EEST}
+    {1522360800 10800 1 EEST}
     {1540501200 7200 0 EET}
-    {1554415200 10800 1 EEST}
+    {1553810400 10800 1 EEST}
     {1571950800 7200 0 EET}
-    {1585864800 10800 1 EEST}
+    {1585260000 10800 1 EEST}
     {1604005200 7200 0 EET}
-    {1617314400 10800 1 EEST}
+    {1616709600 10800 1 EEST}
     {1635454800 7200 0 EET}
-    {1648764000 10800 1 EEST}
+    {1648159200 10800 1 EEST}
     {1666904400 7200 0 EET}
-    {1680818400 10800 1 EEST}
+    {1680213600 10800 1 EEST}
     {1698354000 7200 0 EET}
-    {1712268000 10800 1 EEST}
+    {1711663200 10800 1 EEST}
     {1729803600 7200 0 EET}
-    {1743717600 10800 1 EEST}
+    {1743112800 10800 1 EEST}
     {1761858000 7200 0 EET}
-    {1775167200 10800 1 EEST}
+    {1774562400 10800 1 EEST}
     {1793307600 7200 0 EET}
-    {1806616800 10800 1 EEST}
+    {1806012000 10800 1 EEST}
     {1824757200 7200 0 EET}
-    {1838671200 10800 1 EEST}
+    {1838066400 10800 1 EEST}
     {1856206800 7200 0 EET}
-    {1870120800 10800 1 EEST}
+    {1869516000 10800 1 EEST}
     {1887656400 7200 0 EET}
-    {1901570400 10800 1 EEST}
+    {1900965600 10800 1 EEST}
     {1919106000 7200 0 EET}
-    {1933020000 10800 1 EEST}
+    {1932415200 10800 1 EEST}
     {1951160400 7200 0 EET}
-    {1964469600 10800 1 EEST}
+    {1963864800 10800 1 EEST}
     {1982610000 7200 0 EET}
-    {1995919200 10800 1 EEST}
+    {1995314400 10800 1 EEST}
     {2014059600 7200 0 EET}
-    {2027973600 10800 1 EEST}
+    {2027368800 10800 1 EEST}
     {2045509200 7200 0 EET}
-    {2059423200 10800 1 EEST}
+    {2058818400 10800 1 EEST}
     {2076958800 7200 0 EET}
-    {2090872800 10800 1 EEST}
+    {2090268000 10800 1 EEST}
     {2109013200 7200 0 EET}
-    {2122322400 10800 1 EEST}
+    {2121717600 10800 1 EEST}
     {2140462800 7200 0 EET}
-    {2153772000 10800 1 EEST}
+    {2153167200 10800 1 EEST}
     {2171912400 7200 0 EET}
-    {2185221600 10800 1 EEST}
+    {2184616800 10800 1 EEST}
     {2203362000 7200 0 EET}
-    {2217276000 10800 1 EEST}
+    {2216671200 10800 1 EEST}
     {2234811600 7200 0 EET}
-    {2248725600 10800 1 EEST}
+    {2248120800 10800 1 EEST}
     {2266261200 7200 0 EET}
-    {2280175200 10800 1 EEST}
+    {2279570400 10800 1 EEST}
     {2298315600 7200 0 EET}
-    {2311624800 10800 1 EEST}
+    {2311020000 10800 1 EEST}
     {2329765200 7200 0 EET}
-    {2343074400 10800 1 EEST}
+    {2342469600 10800 1 EEST}
     {2361214800 7200 0 EET}
-    {2375128800 10800 1 EEST}
+    {2374524000 10800 1 EEST}
     {2392664400 7200 0 EET}
-    {2406578400 10800 1 EEST}
+    {2405973600 10800 1 EEST}
     {2424114000 7200 0 EET}
-    {2438028000 10800 1 EEST}
+    {2437423200 10800 1 EEST}
     {2455563600 7200 0 EET}
-    {2469477600 10800 1 EEST}
+    {2468872800 10800 1 EEST}
     {2487618000 7200 0 EET}
-    {2500927200 10800 1 EEST}
+    {2500322400 10800 1 EEST}
     {2519067600 7200 0 EET}
-    {2532376800 10800 1 EEST}
+    {2531772000 10800 1 EEST}
     {2550517200 7200 0 EET}
-    {2564431200 10800 1 EEST}
+    {2563826400 10800 1 EEST}
     {2581966800 7200 0 EET}
-    {2595880800 10800 1 EEST}
+    {2595276000 10800 1 EEST}
     {2613416400 7200 0 EET}
-    {2627330400 10800 1 EEST}
+    {2626725600 10800 1 EEST}
     {2645470800 7200 0 EET}
-    {2658780000 10800 1 EEST}
+    {2658175200 10800 1 EEST}
     {2676920400 7200 0 EET}
-    {2690229600 10800 1 EEST}
+    {2689624800 10800 1 EEST}
     {2708370000 7200 0 EET}
-    {2722284000 10800 1 EEST}
+    {2721679200 10800 1 EEST}
     {2739819600 7200 0 EET}
-    {2753733600 10800 1 EEST}
+    {2753128800 10800 1 EEST}
     {2771269200 7200 0 EET}
-    {2785183200 10800 1 EEST}
+    {2784578400 10800 1 EEST}
     {2802718800 7200 0 EET}
-    {2816632800 10800 1 EEST}
+    {2816028000 10800 1 EEST}
     {2834773200 7200 0 EET}
-    {2848082400 10800 1 EEST}
+    {2847477600 10800 1 EEST}
     {2866222800 7200 0 EET}
-    {2879532000 10800 1 EEST}
+    {2878927200 10800 1 EEST}
     {2897672400 7200 0 EET}
-    {2911586400 10800 1 EEST}
+    {2910981600 10800 1 EEST}
     {2929122000 7200 0 EET}
-    {2943036000 10800 1 EEST}
+    {2942431200 10800 1 EEST}
     {2960571600 7200 0 EET}
-    {2974485600 10800 1 EEST}
+    {2973880800 10800 1 EEST}
     {2992626000 7200 0 EET}
-    {3005935200 10800 1 EEST}
+    {3005330400 10800 1 EEST}
     {3024075600 7200 0 EET}
-    {3037384800 10800 1 EEST}
+    {3036780000 10800 1 EEST}
     {3055525200 7200 0 EET}
-    {3068834400 10800 1 EEST}
+    {3068229600 10800 1 EEST}
     {3086974800 7200 0 EET}
-    {3100888800 10800 1 EEST}
+    {3100284000 10800 1 EEST}
     {3118424400 7200 0 EET}
-    {3132338400 10800 1 EEST}
+    {3131733600 10800 1 EEST}
     {3149874000 7200 0 EET}
-    {3163788000 10800 1 EEST}
+    {3163183200 10800 1 EEST}
     {3181928400 7200 0 EET}
-    {3195237600 10800 1 EEST}
+    {3194632800 10800 1 EEST}
     {3213378000 7200 0 EET}
-    {3226687200 10800 1 EEST}
+    {3226082400 10800 1 EEST}
     {3244827600 7200 0 EET}
-    {3258741600 10800 1 EEST}
+    {3258136800 10800 1 EEST}
     {3276277200 7200 0 EET}
-    {3290191200 10800 1 EEST}
+    {3289586400 10800 1 EEST}
     {3307726800 7200 0 EET}
-    {3321640800 10800 1 EEST}
+    {3321036000 10800 1 EEST}
     {3339176400 7200 0 EET}
-    {3353090400 10800 1 EEST}
+    {3352485600 10800 1 EEST}
     {3371230800 7200 0 EET}
-    {3384540000 10800 1 EEST}
+    {3383935200 10800 1 EEST}
     {3402680400 7200 0 EET}
-    {3415989600 10800 1 EEST}
+    {3415384800 10800 1 EEST}
     {3434130000 7200 0 EET}
-    {3448044000 10800 1 EEST}
+    {3447439200 10800 1 EEST}
     {3465579600 7200 0 EET}
-    {3479493600 10800 1 EEST}
+    {3478888800 10800 1 EEST}
     {3497029200 7200 0 EET}
-    {3510943200 10800 1 EEST}
+    {3510338400 10800 1 EEST}
     {3529083600 7200 0 EET}
-    {3542392800 10800 1 EEST}
+    {3541788000 10800 1 EEST}
     {3560533200 7200 0 EET}
-    {3573842400 10800 1 EEST}
+    {3573237600 10800 1 EEST}
     {3591982800 7200 0 EET}
-    {3605896800 10800 1 EEST}
+    {3605292000 10800 1 EEST}
     {3623432400 7200 0 EET}
-    {3637346400 10800 1 EEST}
+    {3636741600 10800 1 EEST}
     {3654882000 7200 0 EET}
-    {3668796000 10800 1 EEST}
+    {3668191200 10800 1 EEST}
     {3686331600 7200 0 EET}
-    {3700245600 10800 1 EEST}
+    {3699640800 10800 1 EEST}
     {3718386000 7200 0 EET}
-    {3731695200 10800 1 EEST}
+    {3731090400 10800 1 EEST}
     {3749835600 7200 0 EET}
-    {3763144800 10800 1 EEST}
+    {3762540000 10800 1 EEST}
     {3781285200 7200 0 EET}
-    {3795199200 10800 1 EEST}
+    {3794594400 10800 1 EEST}
     {3812734800 7200 0 EET}
-    {3826648800 10800 1 EEST}
+    {3826044000 10800 1 EEST}
     {3844184400 7200 0 EET}
-    {3858098400 10800 1 EEST}
+    {3857493600 10800 1 EEST}
     {3876238800 7200 0 EET}
-    {3889548000 10800 1 EEST}
+    {3888943200 10800 1 EEST}
     {3907688400 7200 0 EET}
-    {3920997600 10800 1 EEST}
+    {3920392800 10800 1 EEST}
     {3939138000 7200 0 EET}
-    {3952447200 10800 1 EEST}
+    {3951842400 10800 1 EEST}
     {3970587600 7200 0 EET}
-    {3984501600 10800 1 EEST}
+    {3983896800 10800 1 EEST}
     {4002037200 7200 0 EET}
-    {4015951200 10800 1 EEST}
+    {4015346400 10800 1 EEST}
     {4033486800 7200 0 EET}
-    {4047400800 10800 1 EEST}
+    {4046796000 10800 1 EEST}
     {4065541200 7200 0 EET}
-    {4078850400 10800 1 EEST}
+    {4078245600 10800 1 EEST}
     {4096990800 7200 0 EET}
 }
diff --git a/library/tzdata/Asia/Gaza b/library/tzdata/Asia/Gaza
index 18b1506..2094969 100644
--- a/library/tzdata/Asia/Gaza
+++ b/library/tzdata/Asia/Gaza
@@ -96,4 +96,6 @@ set TZData(:Asia/Gaza) {
     {1281474000 7200 0 EET}
     {1301738460 10800 1 EEST}
     {1312146000 7200 0 EET}
+    {1333058400 10800 1 EEST}
+    {1348779600 7200 0 EET}
 }
diff --git a/library/tzdata/Asia/Hebron b/library/tzdata/Asia/Hebron
index 71e0064..69addd8 100644
--- a/library/tzdata/Asia/Hebron
+++ b/library/tzdata/Asia/Hebron
@@ -99,4 +99,6 @@ set TZData(:Asia/Hebron) {
     {1312146000 7200 0 EET}
     {1314655200 10800 1 EEST}
     {1317340800 7200 0 EET}
+    {1333058400 10800 1 EEST}
+    {1348790400 7200 0 EET}
 }
-- 
cgit v0.12


From bcd88b005a09280f4b9725d611fd3763fd07241f Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Thu, 19 Apr 2012 10:28:34 +0000
Subject: Added example to platform(n) manpage

---
 doc/platform.n | 24 ++++++++++++++++++++++--
 1 file changed, 22 insertions(+), 2 deletions(-)

diff --git a/doc/platform.n b/doc/platform.n
index 053448d..1553698 100644
--- a/doc/platform.n
+++ b/doc/platform.n
@@ -12,7 +12,7 @@
 platform \- System identification support code and utilities
 .SH SYNOPSIS
 .nf
-\fBpackage require platform ?1.0.4?\fR
+\fBpackage require platform ?1.0.10?\fR
 .sp
 \fBplatform::generic\fR
 \fBplatform::identify\fR
@@ -45,6 +45,7 @@ architecture a Tcl program is running on.
 .SH COMMANDS
 .TP
 \fBplatform::identify\fR
+.
 This command returns an identifier describing the platform the Tcl
 core is running on. The returned identifier has the general format
 \fIOS\fR-\fICPU\fR. The \fIOS\fR part of the identifier may contain
@@ -53,14 +54,33 @@ may contain dashes as well.  The \fICPU\fR part will not contain
 dashes, making the preceding dash the last dash in the result.
 .TP
 \fBplatform::generic\fR
+.
 This command returns a simplified identifier describing the platform
 the Tcl core is running on. In contrast to \fBplatform::identify\fR it
 leaves out details like kernel version, libc version, etc. The
 returned identifier has the general format \fIOS\fR-\fICPU\fR.
 .TP
-\fBplatform::patterns 	\fIidentifier\fR
+\fBplatform::patterns \fIidentifier\fR
+.
 This command takes an identifier as returned by
 \fBplatform::identify\fR and returns a list of identifiers describing
 compatible architectures.
+.SH EXAMPLE
+.PP
+This can be used to allow an application to be shipped with multiple builds of
+a shared library, so that the same package works on many versions of an
+operating system. For example:
+.PP
+.CS
+\fBpackage require platform\fR
+# Assume that app script is .../theapp/bin/theapp.tcl
+set binDir [file dirname [file normalize [info script]]]
+set libDir [file join $binDir .. lib]
+set platLibDir [file join $libDir [\fBplatform::identify\fR]]
+load [file join $platLibDir support[info sharedlibextension]]
+.CE
 .SH KEYWORDS
 operating system, cpu architecture, platform, architecture
+'\" Local Variables:
+'\" mode: nroff
+'\" End:
-- 
cgit v0.12


From 154f6e364d28d67ef3d2f09c4a991d46e53ad2d4 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Mon, 23 Apr 2012 08:20:59 +0000
Subject: fix MSVC warning: tclStubInit.c(306) : warning C4113: 'int (__cdecl
 *)()' differs in parameter lists from 'int (__cdecl *)(int ,int )'

---
 generic/tclStubInit.c | 4 +---
 1 file changed, 1 insertion(+), 3 deletions(-)

diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 8f42f96..a300afc 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -46,9 +46,7 @@
 #   define TclSockMinimumBuffersOld 0
 #else
 #define TclSockMinimumBuffersOld sockMinimumBuffersOld
-static int TclSockMinimumBuffersOld(sock, size)
-    int sock;
-    int size;
+static int TclSockMinimumBuffersOld(int sock, int size)
 {
     return TclSockMinimumBuffers(INT2PTR(sock), size);
 }
-- 
cgit v0.12


From 55b3c5a95d03b9102041c8aa71c94dd7f7b07b52 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Mon, 23 Apr 2012 14:13:35 +0000
Subject: autoconf

---
 unix/configure | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/unix/configure b/unix/configure
index d87b633..848d6c3 100755
--- a/unix/configure
+++ b/unix/configure
@@ -9132,7 +9132,7 @@ fi
 	UNSHARED_LIB_SUFFIX='${VERSION}.a'
 fi
 
-	DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
+    DLL_INSTALL_DIR="\$(LIB_INSTALL_DIR)"
 
     if test "${SHARED_BUILD}" = 1 -a "${SHLIB_SUFFIX}" != ""; then
 
-- 
cgit v0.12


From cc79d413c959197709155dc84b0680e37c20400e Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Mon, 23 Apr 2012 17:02:54 +0000
Subject: grammar fix (reported on Tcler's Chat)

---
 doc/FileSystem.3 | 4 ++--
 1 file changed, 2 insertions(+), 2 deletions(-)

diff --git a/doc/FileSystem.3 b/doc/FileSystem.3
index 52eeb23..d7198b1 100644
--- a/doc/FileSystem.3
+++ b/doc/FileSystem.3
@@ -1218,8 +1218,8 @@ In addition, if \fIinterp\fR is non-NULL, the
 \fBTcl_FSOpenFileChannelProc\fR leaves an error message in \fIinterp\fR's
 result after any error.
 .PP
-The newly created channel must not registered in the supplied
-interpreter; that task is up to the caller of
+The newly created channel must not be registered in the supplied interpreter
+by a \fBTcl_FSOpenFileChannelProc\fR; that task is up to the caller of
 \fBTcl_FSOpenFileChannel\fR (if necessary). If one of
 the standard channels, \fBstdin\fR, \fBstdout\fR or \fBstderr\fR was
 previously closed, the act of creating the new channel also assigns it
-- 
cgit v0.12


From 136ab8e516a21b2151c13a72576fd4311094953b Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 24 Apr 2012 21:25:42 +0000
Subject: gcc warnings

---
 unix/tclUnixFile.c | 3 +--
 1 file changed, 1 insertion(+), 2 deletions(-)

diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index dc5af66..8fb9fd9 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -39,7 +39,6 @@ TclpFindExecutable(
     CONST char *argv0)		/* The value of the application's argv[0]
 				 * (native). */
 {
-    int length;
 #ifdef __CYGWIN__
     char buf[PATH_MAX * TCL_UTF_MAX + 1];
     char name[PATH_MAX * TCL_UTF_MAX + 1];
@@ -72,7 +71,7 @@ TclpFindExecutable(
     buf[length] = '\0';
 #else
     if (argv0 == NULL) {
-	return NULL;
+	return;
     }
     Tcl_DStringInit(&buffer);
 
-- 
cgit v0.12


From 5e51fad7d7a9da7e201afd58883e13e04b2aae74 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Tue, 24 Apr 2012 21:50:55 +0000
Subject: fix merge error

---
 generic/tclIntPlatDecls.h | 2 ++
 1 file changed, 2 insertions(+)

diff --git a/generic/tclIntPlatDecls.h b/generic/tclIntPlatDecls.h
index a05c71a..bc0f4fd 100644
--- a/generic/tclIntPlatDecls.h
+++ b/generic/tclIntPlatDecls.h
@@ -638,6 +638,8 @@ extern const TclIntPlatStubs *tclIntPlatStubsPtr;
 #undef TclpLocaltime_unix
 #undef TclpGmtime_unix
 #undef TclIntPlatReserved13
+#undef TclWinConvertWSAError
+#define TclWinConvertWSAError TclWinConvertError
 
 #if !defined(__WIN32__)
 # undef TclpGetPid
-- 
cgit v0.12


From 46a826db38fe47acda1efb7714281b9df8ead242 Mon Sep 17 00:00:00 2001
From: dkf <donal.k.fellows@manchester.ac.uk>
Date: Wed, 25 Apr 2012 12:07:45 +0000
Subject: 	* generic/tclUtil.c (TclDStringToObj): Added internal function
 to make 	the fairly-common operation of converting a DString into an
 Obj a more 	efficient one.

---
 ChangeLog             | 11 ++++++++++
 generic/tclCmdAH.c    | 12 +++--------
 generic/tclFileName.c | 13 ++++--------
 generic/tclInt.h      |  1 +
 generic/tclMain.c     | 23 +++++++++++---------
 generic/tclPathObj.c  |  5 +----
 generic/tclRegexp.c   |  4 +---
 generic/tclUtil.c     | 58 +++++++++++++++++++++++++++++++++++++++++++++++++++
 generic/tclZlib.c     |  8 ++-----
 unix/tclUnixFCmd.c    |  6 ++----
 unix/tclUnixFile.c    | 22 ++++---------------
 unix/tclUnixInit.c    |  7 ++-----
 win/tclWinFCmd.c      | 12 +++++------
 win/tclWinFile.c      |  6 +-----
 win/tclWinInit.c      |  5 ++---
 15 files changed, 110 insertions(+), 83 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 17daabc..bf2201b 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,14 @@
+2012-04-25  Donal K. Fellows  <dkf@users.sf.net>
+
+	* generic/tclUtil.c (TclDStringToObj): Added internal function to make
+	the fairly-common operation of converting a DString into an Obj a more
+	efficient one; for long strings, it can just transfer the ownership of
+	the buffer directly. Replaces this:
+	   obj=Tcl_NewStringObj(Tcl_DStringValue(&ds),Tcl_DStringLength(&ds));
+	   Tcl_DStringFree(&ds);
+	with this:
+	   obj=TclDStringToObj(&ds);
+
 2012-04-24  Jan Nijtmans  <nijtmans@users.sf.net>
 
 	* generic/tclInt.decls:      [Bug 3508771] load tclreg.dll in cygwin tclsh
diff --git a/generic/tclCmdAH.c b/generic/tclCmdAH.c
index 1cbc4d2..70aef8d 100644
--- a/generic/tclCmdAH.c
+++ b/generic/tclCmdAH.c
@@ -563,9 +563,7 @@ Tcl_EncodingObjCmd(
 	     * truncate the string at the first null byte.
 	     */
 
-	    Tcl_SetObjResult(interp, Tcl_NewStringObj(
-		    Tcl_DStringValue(&ds), Tcl_DStringLength(&ds)));
-	    Tcl_DStringFree(&ds);
+	    Tcl_SetObjResult(interp, TclDStringToObj(&ds));
 	} else {
 	    /*
 	     * Store the result as binary data.
@@ -1869,20 +1867,16 @@ PathNativeNameCmd(
     int objc,
     Tcl_Obj *const objv[])
 {
-    const char *fileName;
     Tcl_DString ds;
 
     if (objc != 2) {
 	Tcl_WrongNumArgs(interp, 1, objv, "name");
 	return TCL_ERROR;
     }
-    fileName = Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds);
-    if (fileName == NULL) {
+    if (Tcl_TranslateFileName(interp, TclGetString(objv[1]), &ds) == NULL) {
 	return TCL_ERROR;
     }
-    Tcl_SetObjResult(interp, Tcl_NewStringObj(fileName,
-	    Tcl_DStringLength(&ds)));
-    Tcl_DStringFree(&ds);
+    Tcl_SetObjResult(interp, TclDStringToObj(&ds));
     return TCL_OK;
 }
 
diff --git a/generic/tclFileName.c b/generic/tclFileName.c
index b6b89dd..5048308 100644
--- a/generic/tclFileName.c
+++ b/generic/tclFileName.c
@@ -445,8 +445,7 @@ TclpGetNativePathType(
 	    if ((rootEnd != path) && (driveNameLengthPtr != NULL)) {
 		*driveNameLengthPtr = rootEnd - path;
 		if (driveNameRef != NULL) {
-		    *driveNameRef = Tcl_NewStringObj(Tcl_DStringValue(&ds),
-			    Tcl_DStringLength(&ds));
+		    *driveNameRef = TclDStringToObj(&ds);
 		    Tcl_IncrRefCount(*driveNameRef);
 		}
 	    }
@@ -724,8 +723,7 @@ SplitWinPath(
      */
 
     if (p != path) {
-	Tcl_ListObjAppendElement(NULL, result, Tcl_NewStringObj(
-		Tcl_DStringValue(&buf), Tcl_DStringLength(&buf)));
+	Tcl_ListObjAppendElement(NULL, result, TclDStringToObj(&buf));
     }
     Tcl_DStringFree(&buf);
 
@@ -1751,14 +1749,12 @@ TclGlob(
 	    if (head != Tcl_DStringValue(&buffer)) {
 		Tcl_DStringAppend(&buffer, head, -1);
 	    }
-	    pathPrefix = Tcl_NewStringObj(Tcl_DStringValue(&buffer),
-		    Tcl_DStringLength(&buffer));
+	    pathPrefix = TclDStringToObj(&buffer);
 	    Tcl_IncrRefCount(pathPrefix);
 	    globFlags |= TCL_GLOBMODE_DIR;
 	    if (c != '\0') {
 		tail++;
 	    }
-	    Tcl_DStringFree(&buffer);
 	} else {
 	    tail = pattern;
 	}
@@ -2423,8 +2419,7 @@ DoGlob(
 	 */
 
 	if (pathPtr == NULL) {
-	    joinedPtr = Tcl_NewStringObj(Tcl_DStringValue(&append),
-		    Tcl_DStringLength(&append));
+	    joinedPtr = TclDStringToObj(&append);
 	} else if (flags) {
 	    joinedPtr = TclNewFSPathObj(pathPtr, Tcl_DStringValue(&append),
 		    Tcl_DStringLength(&append));
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 08b3f70..9068dfb 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -2920,6 +2920,7 @@ MODULE_SCOPE void	TclCreateLateExitHandler(Tcl_ExitProc *proc,
 			    ClientData clientData);
 MODULE_SCOPE void	TclDeleteLateExitHandler(Tcl_ExitProc *proc,
 			    ClientData clientData);
+MODULE_SCOPE Tcl_Obj *	TclDStringToObj(Tcl_DString *dsPtr);
 MODULE_SCOPE void	TclFinalizeAllocSubsystem(void);
 MODULE_SCOPE void	TclFinalizeAsync(void);
 MODULE_SCOPE void	TclFinalizeDoubleConversion(void);
diff --git a/generic/tclMain.c b/generic/tclMain.c
index 373e3f6..88b4e51 100644
--- a/generic/tclMain.c
+++ b/generic/tclMain.c
@@ -53,20 +53,23 @@
 #endif
 
 /*
- * Further on, in UNICODE mode, we need to use Tcl_NewUnicodeObj,
- * while otherwise NewNativeObj is needed (which provides proper
- * conversion from native encoding to UTF-8).
+ * Further on, in UNICODE mode we just use Tcl_NewUnicodeObj, otherwise
+ * NewNativeObj is needed (which provides proper conversion from native
+ * encoding to UTF-8).
  */
+
 #ifdef UNICODE
 #   define NewNativeObj Tcl_NewUnicodeObj
 #else /* !UNICODE */
-    static Tcl_Obj *NewNativeObj(char *string, int length) {
-	Tcl_Obj *obj;
-	Tcl_DString ds;
-	Tcl_ExternalToUtfDString(NULL, string, length, &ds);
-	obj = Tcl_NewStringObj(Tcl_DStringValue(&ds), Tcl_DStringLength(&ds));
-	Tcl_DStringFree(&ds);
-	return obj;
+static inline Tcl_Obj *
+NewNativeObj(
+    char *string,
+    int length)
+{
+    Tcl_DString ds;
+
+    Tcl_ExternalToUtfDString(NULL, string, length, &ds);
+    return TclDStringToObj(&ds);
 }
 #endif /* !UNICODE */
 
diff --git a/generic/tclPathObj.c b/generic/tclPathObj.c
index ba07808..4f86755 100644
--- a/generic/tclPathObj.c
+++ b/generic/tclPathObj.c
@@ -2373,7 +2373,6 @@ SetFsPathFromAny(
      */
 
     if (name[0] == '~') {
-	char *expandedUser;
 	Tcl_DString temp;
 	int split;
 	char separator = '/';
@@ -2442,8 +2441,7 @@ SetFsPathFromAny(
 	    }
 	}
 
-	expandedUser = Tcl_DStringValue(&temp);
-	transPtr = Tcl_NewStringObj(expandedUser, Tcl_DStringLength(&temp));
+	transPtr = TclDStringToObj(&temp);
 
 	if (split != len) {
 	    /*
@@ -2488,7 +2486,6 @@ SetFsPathFromAny(
 		transPtr = joined;
 	    }
 	}
-	Tcl_DStringFree(&temp);
     } else {
 	transPtr = TclJoinPath(1, &pathPtr);
     }
diff --git a/generic/tclRegexp.c b/generic/tclRegexp.c
index 5c5af7b..53d7153 100644
--- a/generic/tclRegexp.c
+++ b/generic/tclRegexp.c
@@ -947,10 +947,8 @@ CompileRegexp(
      */
 
     if (TclReToGlob(NULL, string, length, &stringBuf, &exact) == TCL_OK) {
-	regexpPtr->globObjPtr = Tcl_NewStringObj(Tcl_DStringValue(&stringBuf),
-		Tcl_DStringLength(&stringBuf));
+	regexpPtr->globObjPtr = TclDStringToObj(&stringBuf);
 	Tcl_IncrRefCount(regexpPtr->globObjPtr);
-	Tcl_DStringFree(&stringBuf);
     } else {
 	regexpPtr->globObjPtr = NULL;
     }
diff --git a/generic/tclUtil.c b/generic/tclUtil.c
index a1c1996..d5a3b94 100644
--- a/generic/tclUtil.c
+++ b/generic/tclUtil.c
@@ -2715,6 +2715,64 @@ Tcl_DStringGetResult(
 /*
  *----------------------------------------------------------------------
  *
+ * TclDStringToObj --
+ *
+ *	This function moves a dynamic string's contents to a new Tcl_Obj. Be
+ *	aware that this function does *not* check that the encoding of the
+ *	contents of the dynamic string is correct; this is the caller's
+ *	responsibility to enforce.
+ *
+ * Results:
+ *	The newly-allocated untyped (i.e., typePtr==NULL) Tcl_Obj with a
+ *	reference count of zero.
+ *
+ * Side effects:
+ *	The string is "moved" to the object. dsPtr is reinitialized to an
+ *	empty string; it does not need to be Tcl_DStringFree'd after this if
+ *	not used further.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_Obj *
+TclDStringToObj(
+    Tcl_DString *dsPtr)
+{
+    Tcl_Obj *result;
+
+    if (dsPtr->length == 0) {
+	TclNewObj(result);
+    } else if (dsPtr->string == dsPtr->staticSpace) {
+	/*
+	 * Static buffer, so must copy.
+	 */
+
+	TclNewStringObj(result, dsPtr->string, dsPtr->length);
+    } else {
+	/*
+	 * Dynamic buffer, so transfer ownership and reset.
+	 */
+
+	TclNewObj(result);
+	result->bytes = dsPtr->string;
+	result->length = dsPtr->length;
+    }
+
+    /*
+     * Re-establish the DString as empty with no buffer allocated.
+     */
+
+    dsPtr->string = dsPtr->staticSpace;
+    dsPtr->spaceAvl = TCL_DSTRING_STATIC_SIZE;
+    dsPtr->length = 0;
+    dsPtr->staticSpace[0] = '\0';
+
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * Tcl_DStringStartSublist --
  *
  *	This function adds the necessary information to a dynamic string
diff --git a/generic/tclZlib.c b/generic/tclZlib.c
index 341f8e0..3673833 100644
--- a/generic/tclZlib.c
+++ b/generic/tclZlib.c
@@ -399,9 +399,7 @@ ExtractHeader(
 
 	Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->comment, -1,
 		&tmp);
-	SetValue(dictObj, "comment", Tcl_NewStringObj(Tcl_DStringValue(&tmp),
-		Tcl_DStringLength(&tmp)));
-	Tcl_DStringFree(&tmp);
+	SetValue(dictObj, "comment", TclDStringToObj(&tmp));
     }
     SetValue(dictObj, "crc", Tcl_NewBooleanObj(headerPtr->hcrc));
     if (headerPtr->name != Z_NULL) {
@@ -418,9 +416,7 @@ ExtractHeader(
 
 	Tcl_ExternalToUtfDString(latin1enc, (char *) headerPtr->name, -1,
 		&tmp);
-	SetValue(dictObj, "filename", Tcl_NewStringObj(Tcl_DStringValue(&tmp),
-		Tcl_DStringLength(&tmp)));
-	Tcl_DStringFree(&tmp);
+	SetValue(dictObj, "filename", TclDStringToObj(&tmp));
     }
     if (headerPtr->os != 255) {
 	SetValue(dictObj, "os", Tcl_NewIntObj(headerPtr->os));
diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c
index e3d9022..fce071f 100644
--- a/unix/tclUnixFCmd.c
+++ b/unix/tclUnixFCmd.c
@@ -1387,11 +1387,9 @@ GetOwnerAttribute(
 	*attributePtrPtr = Tcl_NewIntObj((int) statBuf.st_uid);
     } else {
 	Tcl_DString ds;
-	const char *utf;
 
-	utf = Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds);
-	*attributePtrPtr = Tcl_NewStringObj(utf, Tcl_DStringLength(&ds));
-	Tcl_DStringFree(&ds);
+	(void) Tcl_ExternalToUtfDString(NULL, pwPtr->pw_name, -1, &ds);
+	*attributePtrPtr = TclDStringToObj(&ds);
     }
     return TCL_OK;
 }
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 05c8058..0b8aaf9 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -1002,12 +1002,8 @@ TclpObjLink(
 	}
 
 	Tcl_ExternalToUtfDString(NULL, link, length, &ds);
-	linkPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
-		Tcl_DStringLength(&ds));
-	Tcl_DStringFree(&ds);
-	if (linkPtr != NULL) {
-	    Tcl_IncrRefCount(linkPtr);
-	}
+	linkPtr = TclDStringToObj(&ds);
+	Tcl_IncrRefCount(linkPtr);
 	return linkPtr;
     }
 }
@@ -1069,19 +1065,9 @@ TclpNativeToNormalized(
     ClientData clientData)
 {
     Tcl_DString ds;
-    Tcl_Obj *objPtr;
-    int len;
-
-    const char *copy;
-    Tcl_ExternalToUtfDString(NULL, (const char*)clientData, -1, &ds);
-
-    copy = Tcl_DStringValue(&ds);
-    len = Tcl_DStringLength(&ds);
-
-    objPtr = Tcl_NewStringObj(copy,len);
-    Tcl_DStringFree(&ds);
 
-    return objPtr;
+    Tcl_ExternalToUtfDString(NULL, (const char *) clientData, -1, &ds);
+    return TclDStringToObj(&ds);
 }
 
 /*
diff --git a/unix/tclUnixInit.c b/unix/tclUnixInit.c
index 8f872d5..bc1b0e7 100644
--- a/unix/tclUnixInit.c
+++ b/unix/tclUnixInit.c
@@ -454,8 +454,7 @@ TclpInitLibraryPath(
 	 * If TCL_LIBRARY is set, search there.
 	 */
 
-	objPtr = Tcl_NewStringObj(str, -1);
-	Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
+	Tcl_ListObjAppendElement(NULL, pathPtr, Tcl_NewStringObj(str, -1));
 
 	Tcl_SplitPath(str, &pathc, &pathv);
 	if ((pathc > 0) && (strcasecmp(installLib + 4, pathv[pathc-1]) != 0)) {
@@ -469,9 +468,7 @@ TclpInitLibraryPath(
 
 	    pathv[pathc - 1] = installLib + 4;
 	    str = Tcl_JoinPath(pathc, pathv, &ds);
-	    objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
-	    Tcl_ListObjAppendElement(NULL, pathPtr, objPtr);
-	    Tcl_DStringFree(&ds);
+	    Tcl_ListObjAppendElement(NULL, pathPtr, TclDStringToObj(&ds));
 	}
 	ckfree(pathv);
     }
diff --git a/win/tclWinFCmd.c b/win/tclWinFCmd.c
index aa0d665..9d0131e 100644
--- a/win/tclWinFCmd.c
+++ b/win/tclWinFCmd.c
@@ -1011,13 +1011,12 @@ TclpObjRemoveDirectory(
     }
 
     if (ret != TCL_OK) {
-	int len = Tcl_DStringLength(&ds);
-	if (len > 0) {
+	if (Tcl_DStringLength(&ds) > 0) {
 	    if (normPtr != NULL &&
 		    !strcmp(Tcl_DStringValue(&ds), TclGetString(normPtr))) {
 		*errorPtr = pathPtr;
 	    } else {
-		*errorPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds), -1);
+		*errorPtr = TclDStringToObj(&ds);
 	    }
 	    Tcl_IncrRefCount(*errorPtr);
 	}
@@ -1762,6 +1761,7 @@ ConvertFileNameFormat(
 
 	    Tcl_DStringInit(&dsTemp);
 	    Tcl_WinTCharToUtf(nativeName, -1, &dsTemp);
+	    Tcl_DStringFree(&ds);
 
 	    /*
 	     * Deal with issues of tildes being absolute.
@@ -1771,13 +1771,11 @@ ConvertFileNameFormat(
 		TclNewLiteralStringObj(tempPath, "./");
 		Tcl_AppendToObj(tempPath, Tcl_DStringValue(&dsTemp),
 			Tcl_DStringLength(&dsTemp));
+		Tcl_DStringFree(&dsTemp);
 	    } else {
-		tempPath = Tcl_NewStringObj(Tcl_DStringValue(&dsTemp),
-			Tcl_DStringLength(&dsTemp));
+		tempPath = TclDStringToObj(&dsTemp);
 	    }
 	    Tcl_ListObjReplace(NULL, splitPath, i, 1, 1, &tempPath);
-	    Tcl_DStringFree(&ds);
-	    Tcl_DStringFree(&dsTemp);
 	    FindClose(handle);
 	}
     }
diff --git a/win/tclWinFile.c b/win/tclWinFile.c
index dcc05bb..2cc14ec 100644
--- a/win/tclWinFile.c
+++ b/win/tclWinFile.c
@@ -2350,13 +2350,9 @@ TclpFilesystemPathType(
 	return NULL;
     } else {
 	Tcl_DString ds;
-	Tcl_Obj *objPtr;
 
 	Tcl_WinTCharToUtf(volType, -1, &ds);
-	objPtr = Tcl_NewStringObj(Tcl_DStringValue(&ds),
-		Tcl_DStringLength(&ds));
-	Tcl_DStringFree(&ds);
-	return objPtr;
+	return TclDStringToObj(&ds);
     }
 #undef VOL_BUF_SIZE
 }
diff --git a/win/tclWinInit.c b/win/tclWinInit.c
index fb53685..3bfff63 100644
--- a/win/tclWinInit.c
+++ b/win/tclWinInit.c
@@ -299,9 +299,8 @@ AppendEnvironment(
 
 	    pathv[pathc - 1] = shortlib;
 	    Tcl_DStringInit(&ds);
-	    str = Tcl_JoinPath(pathc, pathv, &ds);
-	    objPtr = Tcl_NewStringObj(str, Tcl_DStringLength(&ds));
-	    Tcl_DStringFree(&ds);
+	    (void) Tcl_JoinPath(pathc, pathv, &ds);
+	    objPtr = TclDStringToObj(&ds);
 	} else {
 	    objPtr = Tcl_NewStringObj(buf, -1);
 	}
-- 
cgit v0.12


From 1de31d745e8ee5370417e15a8784bc72ac4f54dd Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 26 Apr 2012 10:43:30 +0000
Subject: fix crash on Mac OSX

---
 generic/tclStubInit.c | 3 ---
 1 file changed, 3 deletions(-)

diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 8a85919..787fd4a 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -221,9 +221,6 @@ Tcl_WinTCharToUtf(
 #   define TclWinFlushDirtyChannels 0
 #   define TclWinResetInterfaces 0
 #   define TclpGetPid 0
-#   define TclMacOSXGetFileAttribute 0 /* Only implemented in Tcl >= 8.5 */
-#   define TclMacOSXMatchType 0 /* Only implemented in Tcl >= 8.5 */
-#   define TclMacOSXNotifierAddRunLoopMode 0 /* Only implemented in Tcl >= 8.5 */
 #   ifndef MAC_OSX_TCL
 #	define Tcl_MacOSXOpenBundleResources 0
 #	define Tcl_MacOSXOpenVersionedBundleResources 0
-- 
cgit v0.12


From 9d2e439a664858bfbe32eef058ab965b1e43ce4b Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 26 Apr 2012 12:59:43 +0000
Subject: fix Linux build ;-(

---
 generic/tclStubInit.c | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 787fd4a..7ce50ba 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -222,6 +222,9 @@ Tcl_WinTCharToUtf(
 #   define TclWinResetInterfaces 0
 #   define TclpGetPid 0
 #   ifndef MAC_OSX_TCL
+#	define TclMacOSXMatchType 0
+#	define TclMacOSXNotifierAddRunLoopMode 0
+#	define TclMacOSXGetFileAttribute 0
 #	define Tcl_MacOSXOpenBundleResources 0
 #	define Tcl_MacOSXOpenVersionedBundleResources 0
 #   endif
-- 
cgit v0.12


From f9c3c819472813905c28f23456d1e94d8a167aa1 Mon Sep 17 00:00:00 2001
From: dgp <dgp@users.sourceforge.net>
Date: Thu, 26 Apr 2012 13:21:01 +0000
Subject: Repair more build breakage.

---
 unix/tclUnixFile.c | 12 +++++-------
 1 file changed, 5 insertions(+), 7 deletions(-)

diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index c187e0e..b4a1012 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -43,13 +43,6 @@ TclpFindExecutable(
     int length;
     char buf[PATH_MAX * TCL_UTF_MAX + 1];
     char name[PATH_MAX * TCL_UTF_MAX + 1];
-#else
-    const char *name, *p;
-    Tcl_StatBuf statBuf;
-    Tcl_DString buffer, nameString, cwd, utfName;
-#endif
-
-#ifdef __CYGWIN__
 
     /* Make some symbols available without including <windows.h> */
 #   define CP_UTF8 65001
@@ -69,6 +62,11 @@ TclpFindExecutable(
 	TclSetObjNameOfExecutable(
 		Tcl_NewStringObj(name, length), Tcl_GetEncoding(NULL, NULL));
 #else
+    const char *name, *p;
+    Tcl_StatBuf statBuf;
+    Tcl_DString buffer, nameString, cwd, utfName;
+    Tcl_Encoding encoding;
+
     if (argv0 == NULL) {
 	return;
     }
-- 
cgit v0.12


From 4ff4797d7f983f119eb1f4df6b88bcf5850331a9 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Thu, 26 Apr 2012 14:59:50 +0000
Subject: compiler warning

---
 generic/tclStubInit.c | 2 +-
 1 file changed, 1 insertion(+), 1 deletion(-)

diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 7ce50ba..03b363d 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -212,7 +212,7 @@ Tcl_WinTCharToUtf(
 #   define TclWinGetTclInstance (void *(*)()) TclpCreateProcess
 #   define TclWinNToHS (unsigned short (*) _ANSI_ARGS_((unsigned short ns))) TclpMakeFile
 #   define TclWinSetSockOpt (int (*) _ANSI_ARGS_((void *, int, int, const char *, int))) TclpOpenFile
-#   define TclWinGetSockOpt (int (*) _ANSI_ARGS_((void *, int, int, char *, int))) TclpCreatePipe
+#   define TclWinGetSockOpt (int (*) _ANSI_ARGS_((void *, int, int, char *, int *))) TclpCreatePipe
 #   define TclWinGetServByName (struct servent *(*) _ANSI_ARGS_((const char *nm, const char *proto))) TclpCreateCommandChannel
 #   define TclIntPlatReserved13 (void (*) ()) TclpInetNtoa
 #   define TclWinAddProcess 0
-- 
cgit v0.12


From 4457676798e94230b3296a67ab9caed2dc95e8d5 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Fri, 27 Apr 2012 14:30:23 +0000
Subject: Move CYGWIN-specific stuff from tclPort.h to tclUnixPort.h, where it
 belongs

---
 ChangeLog          |  7 +++++++
 generic/tclEnv.c   |  1 +
 generic/tclPort.h  | 12 ------------
 unix/tclUnixFile.c | 26 ++++++++++++--------------
 unix/tclUnixPort.h | 13 +++++++++++--
 5 files changed, 31 insertions(+), 28 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index 655a8ee..4667490 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,3 +1,10 @@
+2012-04-27  Jan Nijtmans  <nijtmans@users.sf.net>
+
+	* generic/tclPort.h:    Move CYGWIN-specific stuff from tclPort.h to
+	* generic/tclEnv.c:     tclUnixPort.h, where it belongs.
+	* unix/tclUnixPort.h:
+	* unix/tclUnixFile.c:
+
 2012-04-27  Donal K. Fellows  <dkf@users.sf.net>
 
 	* library/init.tcl (auto_execok): Allow shell builtins to be detected
diff --git a/generic/tclEnv.c b/generic/tclEnv.c
index 24fa106..bcc0ff1 100644
--- a/generic/tclEnv.c
+++ b/generic/tclEnv.c
@@ -696,6 +696,7 @@ TclFinalizeEnvironment(void)
  * fork) and the Windows environment (in case the application TCL code calls
  * exec, which calls the Windows CreateProcess function).
  */
+DLLIMPORT extern void __stdcall SetEnvironmentVariableA(const char*, const char *);
 
 static void
 TclCygwinPutenv(
diff --git a/generic/tclPort.h b/generic/tclPort.h
index 7c9bf3c..7021b8d 100644
--- a/generic/tclPort.h
+++ b/generic/tclPort.h
@@ -25,18 +25,6 @@
 #   include "tclUnixPort.h"
 #endif
 
-#if defined(__CYGWIN__)
-#   define USE_PUTENV 1
-#   define USE_PUTENV_FOR_UNSET 1
-/* On Cygwin, the environment is imported from the Cygwin DLL. */
-#   define environ __cygwin_environ
-#   define timezone _timezone
-    DLLIMPORT extern char **__cygwin_environ;
-    DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *);
-    DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value);
-    DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value);
-#endif
-
 #if !defined(LLONG_MIN)
 #   ifdef TCL_WIDE_INT_IS_LONG
 #      define LLONG_MIN LONG_MIN
diff --git a/unix/tclUnixFile.c b/unix/tclUnixFile.c
index 8fb9fd9..f428af7 100644
--- a/unix/tclUnixFile.c
+++ b/unix/tclUnixFile.c
@@ -39,23 +39,17 @@ TclpFindExecutable(
     CONST char *argv0)		/* The value of the application's argv[0]
 				 * (native). */
 {
+    Tcl_Encoding encoding;
 #ifdef __CYGWIN__
+    int length;
     char buf[PATH_MAX * TCL_UTF_MAX + 1];
     char name[PATH_MAX * TCL_UTF_MAX + 1];
-#else
-    CONST char *name, *p;
-    Tcl_StatBuf statBuf;
-    Tcl_DString buffer, nameString, cwd, utfName;
-    Tcl_Encoding encoding;
-#endif
-
-#ifdef __CYGWIN__
 
     /* Make some symbols available without including <windows.h> */
 #   define CP_UTF8 65001
-    extern int cygwin_conv_to_full_posix_path(const char *, char *);
-    extern __stdcall int GetModuleFileNameW(void *, const char *, int);
-    extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
+    DLLIMPORT extern int cygwin_conv_to_full_posix_path(const char *, char *);
+    DLLIMPORT extern __stdcall int GetModuleFileNameW(void *, const char *, int);
+    DLLIMPORT extern __stdcall int WideCharToMultiByte(int, int, const char *, int,
 		const char *, int, const char *, const char *);
 
     GetModuleFileNameW(NULL, name, PATH_MAX);
@@ -66,10 +60,14 @@ TclpFindExecutable(
 	/* Strip '.exe' part. */
 	length -= 4;
     }
-    tclNativeExecutableName = (char *) ckalloc(length + 1);
-    memcpy(tclNativeExecutableName, name, length);
-    buf[length] = '\0';
+	encoding = Tcl_GetEncoding(NULL, NULL);
+	TclSetObjNameOfExecutable(
+		Tcl_NewStringObj(name, length), encoding);
 #else
+    const char *name, *p;
+    Tcl_StatBuf statBuf;
+    Tcl_DString buffer, nameString, cwd, utfName;
+
     if (argv0 == NULL) {
 	return;
     }
diff --git a/unix/tclUnixPort.h b/unix/tclUnixPort.h
index 5abe602..70ea2d4 100644
--- a/unix/tclUnixPort.h
+++ b/unix/tclUnixPort.h
@@ -74,8 +74,17 @@ typedef off_t		Tcl_SeekOffset;
 #endif
 
 #ifdef __CYGWIN__
-MODULE_SCOPE int TclOSstat(const char *name, Tcl_StatBuf *statBuf);
-MODULE_SCOPE int TclOSlstat(const char *name, Tcl_StatBuf *statBuf);
+#   define USE_PUTENV 1
+#   define USE_PUTENV_FOR_UNSET 1
+/* On Cygwin, the environment is imported from the Cygwin DLL. */
+#   define environ __cygwin_environ
+#   define timezone _timezone
+    DLLIMPORT extern char **__cygwin_environ;
+    DLLIMPORT extern int cygwin_conv_to_win32_path(const char *, char *);
+    DLLIMPORT extern int cygwin_posix_to_win32_path_list_buf_size(char *value);
+    DLLIMPORT extern void cygwin_posix_to_win32_path_list(char *buf, char *value);
+    MODULE_SCOPE int TclOSstat(const char *name, Tcl_StatBuf *statBuf);
+    MODULE_SCOPE int TclOSlstat(const char *name, Tcl_StatBuf *statBuf);
 #elif defined(HAVE_STRUCT_STAT64)
 #   define TclOSstat		stat64
 #   define TclOSlstat		lstat64
-- 
cgit v0.12


From 39e076480d96baa096f628753c88b68eb9d7f601 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Sat, 28 Apr 2012 17:03:10 +0000
Subject: Compat flag, test, and doc update.

---
 doc/close.n     |  6 ++++--
 generic/tclIO.c | 32 +++++++++++++++++++++++++++++---
 tests/io.test   | 21 ++++++++++++++++++++-
 3 files changed, 53 insertions(+), 6 deletions(-)

diff --git a/doc/close.n b/doc/close.n
index 4490f6a..2826d82 100644
--- a/doc/close.n
+++ b/doc/close.n
@@ -48,8 +48,10 @@ When the last interpreter in which the channel is registered invokes
 \fBinterp\fR command for a description of channel sharing.
 .PP
 Channels are automatically closed when an interpreter is destroyed and
-when the process exits.  Channels are switched to blocking mode, to ensure
-that all output is correctly flushed before the process exits.
+when the process exits.
+.VS 8.6
+From 8.6 on (TIP#398), nonblocking channels are no longer switched to blocking mode when exiting; this guarantees a timely exit even when the peer or a communication channel is stalled. To ensure proper flushing of stalled nonblocking channels on exit, one must now either (a) actively switch them back to blocking or (b) use the environment variable TCL_FLUSH_NONBLOCKING_ON_EXIT,  which when set and not equal to "0" restores the previous behavior.
+.VE 8.6
 .PP
 The command returns an empty string, and may generate an error if
 an error occurs while flushing output.  If a command in a command
diff --git a/generic/tclIO.c b/generic/tclIO.c
index e1e1193..527ae0c 100644
--- a/generic/tclIO.c
+++ b/generic/tclIO.c
@@ -396,6 +396,19 @@ TclFinalizeIOSubsystem(void)
     Channel *chanPtr = NULL;	/* Iterates over open channels. */
     ChannelState *statePtr;	/* State of channel stack */
     int active = 1;		/* Flag == 1 while there's still work to do */
+    int doflushnb;
+
+    /* Fetch the pre-TIP#398 compatibility flag */ 
+    {
+        const char *s;
+        Tcl_DString ds;
+        
+        s = TclGetEnv("TCL_FLUSH_NONBLOCKING_ON_EXIT", &ds);
+        doflushnb = ((s != NULL) && strcmp(s, "0"));
+        if (s != NULL) {
+            Tcl_DStringFree(&ds);
+        }
+    }
 
     /*
      * Walk all channel state structures known to this thread and close
@@ -414,8 +427,8 @@ TclFinalizeIOSubsystem(void)
 		statePtr != NULL;
 		statePtr = statePtr->nextCSPtr) {
 	    chanPtr = statePtr->topChanPtr;
-	    if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED |
-		    CHANNEL_DEAD)) {
+	    if (!GotFlag(statePtr, CHANNEL_INCLOSE | CHANNEL_CLOSED | CHANNEL_DEAD)
+                || (doflushnb && GotFlag(statePtr, BG_FLUSH_SCHEDULED))) {
 		active = 1;
 		break;
 	    }
@@ -426,9 +439,21 @@ TclFinalizeIOSubsystem(void)
 	 */
 
 	if (active) {
+
 	    /*
-	     * TIP #398: we no longer set the channel back into blocking mode
+	     * TIP #398:  by default, we no  longer set the  channel back into
+             * blocking  mode.  To  restore  the old  blocking  behavior,  the
+             * environment variable  TCL_FLUSH_NONBLOCKING_ON_EXIT must be set
+             * and not be "0".
 	     */
+            if (doflushnb) {
+                    /* Set the channel back into blocking mode to ensure that we wait
+                     * for all data to flush out.
+                     */
+                
+                (void) Tcl_SetChannelOption(NULL, (Tcl_Channel) chanPtr,
+                                            "-blocking", "on");                    
+            }
 
 	    if ((chanPtr == (Channel *) tsdPtr->stdinChannel) ||
 		    (chanPtr == (Channel *) tsdPtr->stdoutChannel) ||
@@ -454,6 +479,7 @@ TclFinalizeIOSubsystem(void)
 		 * The refcount is greater than zero, so flush the channel.
 		 */
 
+                ResetFlag(statePtr, BG_FLUSH_SCHEDULED);
 		Tcl_Flush((Tcl_Channel) chanPtr);
 
 		/*
diff --git a/tests/io.test b/tests/io.test
index 53b85fa..74a246c 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -2736,6 +2736,25 @@ test io-29.33 {Tcl_Flush, implicit flush on exit} {exec} {
     close $f
     set r
 } "hello\nbye\nstrange\n"
+set path(script2) [makeFile {} script2]
+test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} {
+    set f [open $path(script) w]
+    puts $f {
+		fconfigure stdout -blocking 0
+		puts -nonewline stdout [string repeat A 655360]
+		flush stdout
+	}
+    close $f
+    set f [open $path(script2) w]
+    puts $f {after 2000}
+    close $f
+	set t1 [clock seconds]
+	set ff [open "|[list [interpreter] $path(script2)]" w]
+	exec [interpreter] $path(script) >@ $ff
+	set t2 [clock seconds]
+	close $ff
+	expr {($t2-$t1)/2}
+} 0
 test io-29.34 {Tcl_Close, async flush on close, using sockets} {socket tempNotMac fileevent} {
     variable c 0
     variable x running
@@ -7761,7 +7780,7 @@ test io-73.2 {channel Tcl_Obj SetChannelFromAny, bug 2407783} -setup {
 # ### ### ### ######### ######### #########
 
 # cleanup
-foreach file [list fooBar longfile script output test1 pipe my_script \
+foreach file [list fooBar longfile script script2 output test1 pipe my_script \
 	test2 test3 cat stdout kyrillic.txt utf8-fcopy.txt utf8-rp.txt] {
     removeFile $file
 }
-- 
cgit v0.12


From 4fe66ccda0979071b4d247a7e1bfb7d8425afd65 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Mon, 30 Apr 2012 09:15:34 +0000
Subject: Mention compatibility matters in Changelog. Make test insensitive to
 ambient compat flag.

---
 ChangeLog     | 4 ++--
 tests/io.test | 1 +
 2 files changed, 3 insertions(+), 2 deletions(-)

diff --git a/ChangeLog b/ChangeLog
index b431346..672490a 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -3,8 +3,8 @@
 	IMPLEMENTATION OF TIP#398
 
 	* generic/tclIO.c: Quickly Exit with Non-Blocking Blocked Channels
-	* tests/io.test
-	* doc/close.n
+	* tests/io.test  : *** POTENTIAL INCOMPATIBILITY ***
+	* doc/close.n    : (compat flag available)
 
 2012-04-27  Jan Nijtmans  <nijtmans@users.sf.net>
 
diff --git a/tests/io.test b/tests/io.test
index 74a246c..e6cea16 100644
--- a/tests/io.test
+++ b/tests/io.test
@@ -2750,6 +2750,7 @@ test io-29.33b {TIP#398, no implicit flush of nonblocking on exit} {exec} {
     close $f
 	set t1 [clock seconds]
 	set ff [open "|[list [interpreter] $path(script2)]" w]
+	catch {unset ::env(TCL_FLUSH_NONBLOCKING_ON_EXIT)}
 	exec [interpreter] $path(script) >@ $ff
 	set t2 [clock seconds]
 	close $ff
-- 
cgit v0.12


From ccc7189d02db07692cedcc82141038304536e5f5 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Mon, 30 Apr 2012 12:55:24 +0000
Subject: Revert introduction of non-portable asm snippet in function
 TclWinCPUID, to restore compilability on Linux.

---
 unix/tclUnixCompat.c | 3 +++
 1 file changed, 3 insertions(+)

diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c
index d3da962..1c42056 100644
--- a/unix/tclUnixCompat.c
+++ b/unix/tclUnixCompat.c
@@ -991,9 +991,12 @@ TclWinCPUID(
     int status = TCL_ERROR;
 
 #ifdef HAVE_CPUID
+	/* disabled in emergency -- fails on linux */
+# if 0
     __asm__ __volatile__ ("cpuid":\
     "=a" (regsPtr[0]), "=b" (regsPtr[1]), "=c" (regsPtr[2]), "=d" (regsPtr[3]) : "a" (index));
     status = TCL_OK;
+# endif
 #endif
     return status;
 }
-- 
cgit v0.12


From 67a898d6e777d135ab218d8a50fe701644f179a6 Mon Sep 17 00:00:00 2001
From: ferrieux <ferrieux@users.sourceforge.net>
Date: Mon, 30 Apr 2012 21:53:55 +0000
Subject: Tame deadlocks in broken refchan tests [Bug 3522560]

---
 ChangeLog        | 6 +++++-
 tests/ioCmd.test | 3 +++
 2 files changed, 8 insertions(+), 1 deletion(-)

diff --git a/ChangeLog b/ChangeLog
index 672490a..6694ad6 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,4 +1,8 @@
-2012-14-28  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+2012-04-30  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
+
+	* tests/ioCmd.test: Tame deadlocks in broken refchan tests [Bug 3522560]
+
+2012-04-28  Alexandre Ferrieux  <ferrieux@users.sourceforge.net>
 
 	IMPLEMENTATION OF TIP#398
 
diff --git a/tests/ioCmd.test b/tests/ioCmd.test
index 4c08229..6b1da73 100644
--- a/tests/ioCmd.test
+++ b/tests/ioCmd.test
@@ -2575,6 +2575,7 @@ test iocmd.tf-24.15 {chan write, EAGAIN means that writing is not allowed at thi
     set res
 } -cleanup {
     proc foo {args} {onfinal; set ::done-24.15 1; return 3}
+    after 1000 {set ::done-24.15 2}
     vwait done-24.15
     rename foo {}
     unset res
@@ -2603,10 +2604,12 @@ test iocmd.tf-24.16 {chan write, note the background flush setup by close due to
     proc foo {args} { onfinal; note BG ; track ; set ::endbody-24.16 1}
     # Flush (sic!) the event-queue to capture the write from a
     # BG-flush.
+    after 1000 {set ::endbody-24.16 2}
     vwait endbody-24.16
     set res
 } -cleanup {
     proc foo {args} {onfinal; set ::done-24.16 1; return 3}
+    after 1000 {set ::done-24.16 2}
     vwait done-24.16
     rename foo {}
     unset res
-- 
cgit v0.12


From 99557b6c57a524f31c81cde6d39cc2a5e51983f3 Mon Sep 17 00:00:00 2001
From: "jan.nijtmans" <nijtmans@users.sourceforge.net>
Date: Wed, 2 May 2012 14:37:55 +0000
Subject: cpuid-on-unix

---
 unix/tclUnixCompat.c | 13 ++++++-------
 1 file changed, 6 insertions(+), 7 deletions(-)

diff --git a/unix/tclUnixCompat.c b/unix/tclUnixCompat.c
index a39dbbe..1424ab3 100644
--- a/unix/tclUnixCompat.c
+++ b/unix/tclUnixCompat.c
@@ -990,14 +990,13 @@ TclWinCPUID(
 {
     int status = TCL_ERROR;
 
-#if defined(HAVE_CPUID) && defined(__CYGWIN__)
-    __asm__ __volatile__("pushl %%ebx      \n\t" /* save %ebx */
+#if defined(HAVE_CPUID)
+    __asm__ __volatile__("mov %%ebx, %%edi     \n\t" /* save %ebx */
                  "cpuid            \n\t"
-                 "movl %%ebx, %1   \n\t" /* save what cpuid just put in %ebx */
-                 "popl %%ebx       \n\t" /* restore the old %ebx */
-                 : "=a"(regsPtr[0]), "=r"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
-                 : "a"(index)
-                 : "cc");
+                 "mov %%ebx, %%esi   \n\t" /* save what cpuid just put in %ebx */
+                 "mov %%edi, %%ebx  \n\t" /* restore the old %ebx */
+                 : "=a"(regsPtr[0]), "=S"(regsPtr[1]), "=c"(regsPtr[2]), "=d"(regsPtr[3])
+                 : "a"(index));
     status = TCL_OK;
 #endif
     return status;
-- 
cgit v0.12