Added code to save space in namespaces. Currently #ifdef'ed out for compat.

Also added code from itcl-ng for better separation of concerns.

1 files changed, 232 insertions, 25 deletions

diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c
index ff0bf99..74d5ebb 100644
--- a/generic/tclNamesp.c
+++ b/generic/tclNamesp.c
@@ -23,7 +23,7 @@
  * See the file "license.terms" for information on usage and redistribution of
  * this file, and for a DISCLAIMER OF ALL WARRANTIES.
  *
- * RCS: @(#) $Id: tclNamesp.c,v 1.191 2009/03/21 12:24:49 msofer Exp $
+ * RCS: @(#) $Id: tclNamesp.c,v 1.192 2009/07/15 13:17:18 dkf Exp $
  */
 
 #include "tclInt.h"
@@ -511,9 +511,9 @@ Tcl_PopCallFrame(
 
     if (framePtr->tailcallPtr) {
 	/*
-	 * Find the splicing spot: right before the NRCommand of the thing being
-	 * tailcalled. Note that we skip NRCommands marked in data[1] (used by
-	 * command redirectors) 
+	 * Find the splicing spot: right before the NRCommand of the thing
+	 * being tailcalled. Note that we skip NRCommands marked in data[1]
+	 * (used by command redirectors)
 	 */
 
 	TEOV_callback *tailcallPtr, *runPtr;
@@ -822,7 +822,14 @@ Tcl_CreateNamespace(
 	 * already exist in the parent namespace.
 	 */
 
-	if (Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL) {
+	if (
+#ifndef BREAK_NAMESPACE_COMPAT
+	    Tcl_FindHashEntry(&parentPtr->childTable, simpleName) != NULL
+#else
+	    parentPtr->childTablePtr != NULL &&
+	    Tcl_FindHashEntry(parentPtr->childTablePtr, simpleName) != NULL
+#endif
+	) {
 	    Tcl_AppendResult(interp, "can't create namespace \"", name,
 		    "\": already exists", NULL);
 	    return NULL;
@@ -841,7 +848,11 @@ Tcl_CreateNamespace(
     nsPtr->clientData = clientData;
     nsPtr->deleteProc = deleteProc;
     nsPtr->parentPtr = parentPtr;
+#ifndef BREAK_NAMESPACE_COMPAT
     Tcl_InitHashTable(&nsPtr->childTable, TCL_STRING_KEYS);
+#else
+    nsPtr->childTablePtr = NULL;
+#endif
     nsPtr->nsId = ++(tsdPtr->numNsCreated);
     nsPtr->interp = interp;
     nsPtr->flags = 0;
@@ -865,8 +876,9 @@ Tcl_CreateNamespace(
     nsPtr->commandPathSourceList = NULL;
 
     if (parentPtr != NULL) {
-	entryPtr = Tcl_CreateHashEntry(&parentPtr->childTable, simpleName,
-		&newEntry);
+	entryPtr = Tcl_CreateHashEntry(
+		TclGetNamespaceChildTable((Tcl_Namespace *)parentPtr),
+		simpleName, &newEntry);
 	Tcl_SetHashValue(entryPtr, nsPtr);
     } else {
 	/*
@@ -1019,8 +1031,9 @@ Tcl_DeleteNamespace(
     if (nsPtr->activationCount - (nsPtr == globalNsPtr) > 0) {
 	nsPtr->flags |= NS_DYING;
 	if (nsPtr->parentPtr != NULL) {
-	    entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
-		    nsPtr->name);
+	    entryPtr = Tcl_FindHashEntry(
+		    TclGetNamespaceChildTable((Tcl_Namespace *)
+			    nsPtr->parentPtr), nsPtr->name);
 	    if (entryPtr != NULL) {
 		Tcl_DeleteHashEntry(entryPtr);
 	    }
@@ -1049,7 +1062,14 @@ Tcl_DeleteNamespace(
 
 	    TclDeleteNamespaceVars(nsPtr);
 
+#ifndef BREAK_NAMESPACE_COMPAT
 	    Tcl_DeleteHashTable(&nsPtr->childTable);
+#else
+	    if (nsPtr->childTablePtr != NULL) {
+		Tcl_DeleteHashTable(nsPtr->childTablePtr);
+		ckfree((char *) nsPtr->childTablePtr);
+	    }
+#endif
 	    Tcl_DeleteHashTable(&nsPtr->cmdTable);
 
 	    /*
@@ -1145,8 +1165,9 @@ TclTeardownNamespace(
      */
 
     if (nsPtr->parentPtr != NULL) {
-	entryPtr = Tcl_FindHashEntry(&nsPtr->parentPtr->childTable,
-		nsPtr->name);
+	entryPtr = Tcl_FindHashEntry(
+		TclGetNamespaceChildTable((Tcl_Namespace *)
+			nsPtr->parentPtr), nsPtr->name);
 	if (entryPtr != NULL) {
 	    Tcl_DeleteHashEntry(entryPtr);
 	}
@@ -1183,12 +1204,23 @@ TclTeardownNamespace(
      * Don't optimize to Tcl_NextHashEntry() because of traces.
      */
 
+#ifndef BREAK_NAMESPACE_COMPAT
     for (entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
 	    entryPtr != NULL;
 	    entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search)) {
 	childNsPtr = Tcl_GetHashValue(entryPtr);
 	Tcl_DeleteNamespace(childNsPtr);
     }
+#else
+    if (nsPtr->childTablePtr != NULL) {
+	for (entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+		entryPtr != NULL;
+		entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr,&search)) {
+	    childNsPtr = Tcl_GetHashValue(entryPtr);
+	    Tcl_DeleteNamespace(childNsPtr);
+	}
+    }
+#endif
 
     /*
      * Free the namespace's export pattern array.
@@ -1541,7 +1573,7 @@ Tcl_Import(
      */
 
     if (strlen(pattern) == 0) {
-	Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern", -1));
+	Tcl_SetObjResult(interp, Tcl_NewStringObj("empty import pattern",-1));
 	return TCL_ERROR;
     }
     TclGetNamespaceForQualName(interp, pattern, nsPtr,
@@ -1632,7 +1664,8 @@ DoImport(
      */
 
     while (!exported && (i < importNsPtr->numExportPatterns)) {
-	exported |= Tcl_StringMatch(cmdName, importNsPtr->exportArrayPtr[i++]);
+	exported |= Tcl_StringMatch(cmdName,
+		importNsPtr->exportArrayPtr[i++]);
     }
     if (!exported) {
 	return TCL_OK;
@@ -1859,7 +1892,7 @@ Tcl_ForgetImport(
 	    }
 	    origin = firstToken;
 	}
-	if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)) {
+	if (Tcl_StringMatch(Tcl_GetCommandName(NULL, origin), simplePattern)){
 	    Tcl_DeleteCommandFromToken(interp, token);
 	}
     }
@@ -2246,7 +2279,15 @@ TclGetNamespaceForQualName(
 	 */
 
 	if (nsPtr != NULL) {
+#ifndef BREAK_NAMESPACE_COMPAT
 	    entryPtr = Tcl_FindHashEntry(&nsPtr->childTable, nsName);
+#else
+	    if (nsPtr->childTablePtr == NULL) {
+		entryPtr = NULL;
+	    } else {
+		entryPtr = Tcl_FindHashEntry(nsPtr->childTablePtr, nsName);
+	    }
+#endif
 	    if (entryPtr != NULL) {
 		nsPtr = Tcl_GetHashValue(entryPtr);
 	    } else if (flags & TCL_CREATE_NS_IF_UNKNOWN) {
@@ -2255,8 +2296,8 @@ TclGetNamespaceForQualName(
 		(void) TclPushStackFrame(interp, &framePtr,
 			(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 0);
 
-		nsPtr = (Namespace *) Tcl_CreateNamespace(interp, nsName,
-			NULL, NULL);
+		nsPtr = (Namespace *)
+			Tcl_CreateNamespace(interp, nsName, NULL, NULL);
 		TclPopStackFrame(interp);
 
 		if (nsPtr == NULL) {
@@ -2273,7 +2314,15 @@ TclGetNamespaceForQualName(
 	 */
 
 	if (altNsPtr != NULL) {
+#ifndef BREAK_NAMESPACE_COMPAT
 	    entryPtr = Tcl_FindHashEntry(&altNsPtr->childTable, nsName);
+#else
+	    if (altNsPtr->childTablePtr != NULL) {
+		entryPtr = Tcl_FindHashEntry(altNsPtr->childTablePtr, nsName);
+	    } else {
+		entryPtr = NULL;
+	    }
+#endif
 	    if (entryPtr != NULL) {
 		altNsPtr = Tcl_GetHashValue(entryPtr);
 	    } else {
@@ -2653,8 +2702,17 @@ TclResetShadowedCmdRefs(
 
 	for (i = trailFront;  i >= 0;  i--) {
 	    trailNsPtr = trailPtr[i];
+#ifndef BREAK_NAMESPACE_COMPAT
 	    hPtr = Tcl_FindHashEntry(&shadowNsPtr->childTable,
 		    trailNsPtr->name);
+#else
+	    if (shadowNsPtr->childTablePtr != NULL) {
+		hPtr = Tcl_FindHashEntry(shadowNsPtr->childTablePtr,
+			trailNsPtr->name);
+	    } else {
+		hPtr = NULL;
+	    }
+#endif
 	    if (hPtr != NULL) {
 		shadowNsPtr = Tcl_GetHashValue(hPtr);
 	    } else {
@@ -2983,7 +3041,7 @@ NamespaceChildrenCmd(
     if (objc == 2) {
 	nsPtr = (Namespace *) TclGetCurrentNamespace(interp);
     } else if ((objc == 3) || (objc == 4)) {
-	if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK) {
+	if (TclGetNamespaceFromObj(interp, objv[2], &namespacePtr) != TCL_OK){
 	    return TCL_ERROR;
 	}
 	nsPtr = (Namespace *) namespacePtr;
@@ -3024,13 +3082,27 @@ NamespaceChildrenCmd(
 	if (strncmp(pattern, nsPtr->fullName, length) != 0) {
 	    goto searchDone;
 	}
-	if (Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL) {
+	if (
+#ifndef BREAK_NAMESPACE_COMPAT
+	    Tcl_FindHashEntry(&nsPtr->childTable, pattern+length) != NULL
+#else
+	    nsPtr->childTablePtr != NULL &&
+	    Tcl_FindHashEntry(nsPtr->childTablePtr, pattern+length) != NULL
+#endif
+	) {
 	    Tcl_ListObjAppendElement(interp, listPtr,
 		    Tcl_NewStringObj(pattern, -1));
 	}
 	goto searchDone;
     }
+#ifndef BREAK_NAMESPACE_COMPAT
     entryPtr = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
+#else
+    if (nsPtr->childTablePtr == NULL) {
+	goto searchDone;
+    }
+    entryPtr = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+#endif
     while (entryPtr != NULL) {
 	childNsPtr = Tcl_GetHashValue(entryPtr);
 	if ((pattern == NULL)
@@ -3815,7 +3887,7 @@ NamespaceInscopeCmd(
 
 	listPtr = Tcl_NewListObj(0, NULL);
 	for (i = 4;  i < objc;  i++) {
-	    if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK) {
+	    if (Tcl_ListObjAppendElement(interp, listPtr, objv[i]) != TCL_OK){
 		Tcl_DecrRefCount(listPtr);	/* Free unneeded obj. */
 		return TCL_ERROR;
 	    }
@@ -4806,6 +4878,61 @@ SetNsNameFromAny(
 /*
  *----------------------------------------------------------------------
  *
+ * TclGetNamespaceCommandTable --
+ *
+ *	Returns the hash table of commands.
+ *
+ * Results:
+ *	Pointer to the hash table.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_HashTable *
+TclGetNamespaceCommandTable(
+    Tcl_Namespace *nsPtr)
+{
+    return &((Namespace *) nsPtr)->cmdTable;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclGetNamespaceChildTable --
+ *
+ *	Returns the hash table of child namespaces.
+ *
+ * Results:
+ *	Pointer to the hash table.
+ *
+ * Side effects:
+ *	Might allocate memory.
+ *
+ *----------------------------------------------------------------------
+ */
+
+Tcl_HashTable *
+TclGetNamespaceChildTable(
+    Tcl_Namespace *nsPtr)
+{
+    Namespace *nPtr = (Namespace *) nsPtr;
+#ifndef BREAK_NAMESPACE_COMPAT
+    return &nPtr->childTable;
+#else
+    if (nPtr->childTablePtr == NULL) {
+	nPtr->childTablePtr = (Tcl_HashTable*) ckalloc(sizeof(Tcl_HashTable));
+	Tcl_InitHashTable(nPtr->childTablePtr, TCL_STRING_KEYS);
+    }
+    return nPtr->childTablePtr;
+#endif
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
  * NamespaceEnsembleCmd --
  *
  *	Invoked to implement the "namespace ensemble" command that creates and
@@ -6109,7 +6236,7 @@ Tcl_FindEnsemble(
 
 	cmdPtr = (Command *) TclGetOriginalCommand((Tcl_Command) cmdPtr);
 
-	if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd) {
+	if (cmdPtr == NULL || cmdPtr->objProc != NsEnsembleImplementationCmd){
 	    if (flags & TCL_LEAVE_ERR_MSG) {
 		Tcl_AppendResult(interp, "\"", TclGetString(cmdNameObj),
 			"\" is not an ensemble command", NULL);
@@ -6167,7 +6294,7 @@ Tcl_IsEnsemble(
  *	The 'name' parameter may be a single command name or a list if
  *	creating an ensemble subcommand (see the binary implementation).
  *
- * 	Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
+ *	Currently, the TCL_ENSEMBLE_PREFIX ensemble flag is only used on
  *	top-level ensemble commands.
  *
  * Results:
@@ -6567,6 +6694,11 @@ 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 =
@@ -6587,6 +6719,7 @@ NsEnsembleImplementationCmdNR(
 		iPtr->ensembleRewrite.numInsertedObjs += prefixObjc-2;
 	    }
 	}
+#endif
 
 	/*
 	 * Hand off to the target command.
@@ -6662,13 +6795,87 @@ TclClearRootEnsemble(
     Tcl_Interp *interp,
     int result)
 {
+    TclResetRewriteEnsemble(interp, 1);
+    return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitRewriteEnsemble --
+ *
+ *	Applies a rewrite of arguments so that an ensemble subcommand will
+ *	report error messages correctly for the overall command.
+ *
+ * Results:
+ *	Whether this is the first rewrite applied, a value which must be
+ *	passed to TclResetRewriteEnsemble when undoing this command's
+ *	behaviour.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclInitRewriteEnsemble(
+    Tcl_Interp *interp,
+    int numRemoved,
+    int numInserted,
+    Tcl_Obj *const *objv)
+{
     Interp *iPtr = (Interp *) interp;
 
-    iPtr->ensembleRewrite.sourceObjs = NULL;
-    iPtr->ensembleRewrite.numRemovedObjs = 0;
-    iPtr->ensembleRewrite.numInsertedObjs = 0;
+    int isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL);
 
-    return result;
+    if (isRootEnsemble) {
+        iPtr->ensembleRewrite.sourceObjs = objv;
+        iPtr->ensembleRewrite.numRemovedObjs = numRemoved;
+        iPtr->ensembleRewrite.numInsertedObjs = numInserted;
+    } else {
+        int numIns = iPtr->ensembleRewrite.numInsertedObjs;
+
+        if (numIns < numRemoved) {
+            iPtr->ensembleRewrite.numRemovedObjs += numRemoved - numIns;
+            iPtr->ensembleRewrite.numInsertedObjs += numInserted - 1;
+        } else {
+            iPtr->ensembleRewrite.numInsertedObjs += numInserted - numRemoved;
+        }
+    }
+    return isRootEnsemble;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclResetRewriteEnsemble --
+ *
+ *	Removes any rewrites applied to support proper reporting of error
+ *	messages used in ensembles. Should be paired with
+ *	TclInitRewriteEnsemble.
+ *
+ * Results:
+ *	None.
+ *
+ * Side effects:
+ *	None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclResetRewriteEnsemble(
+    Tcl_Interp *interp,
+    int isRootEnsemble)
+{
+    Interp *iPtr = (Interp *) interp;
+
+    if (isRootEnsemble) {
+        iPtr->ensembleRewrite.sourceObjs = NULL;
+        iPtr->ensembleRewrite.numRemovedObjs = 0;
+        iPtr->ensembleRewrite.numInsertedObjs = 0;
+    }
 }
 
 /*