summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
-rw-r--r--ChangeLog88
-rw-r--r--generic/tclInt.decls24
-rw-r--r--generic/tclInt.h13
-rw-r--r--generic/tclIntDecls.h45
-rw-r--r--generic/tclNamesp.c257
-rw-r--r--generic/tclResolve.c13
-rw-r--r--generic/tclStubInit.c6
7 files changed, 375 insertions, 71 deletions
diff --git a/ChangeLog b/ChangeLog
index 4b3545c..3e79fb1 100644
--- a/ChangeLog
+++ b/ChangeLog
@@ -1,58 +1,68 @@
+2009-07-15 Donal K. Fellows <dkf@users.sf.net>
+
+ * generic/tclInt.h (Namespace): Added machinery to allow
+ * generic/tclNamesp.c (many functions): reduction of memory used
+ * generic/tclResolve.c (BumpCmdRefEpochs): by namespaces. Currently
+ #ifdef'ed out because of compatibility concerns.
+
+ * generic/tclInt.decls: Added four functions for better integration
+ with itcl-ng.
+
2009-07-14 Kevin B. Kenny <kennykb@acm.org>
* generic/tclInt.h (TclNRSwitchObjCmd):
* generic/tclBasic.c (builtInCmds):
* generic/tclCmdMZ.c (Tcl_SwitchObjCmd):
* tests/switch.test (switch-15.1):
- Make non-bytecoded [switch] command aware of NRE. [Bug 2821401]
+ [Bug 2821401]: Make non-bytecoded [switch] command aware of NRE.
2009-07-13 Andreas Kupries <andreask@activestate.com>
- * generic/tclCompile.c (TclInitCompileEnv, EnterCmdWordIndex,
- TclCleanupByteCode, TclCompileScript):
+ * generic/tclCompile.c (TclInitCompileEnv, EnterCmdWordIndex)
+ (TclCleanupByteCode, TclCompileScript):
* generic/tclExecute.c (TclCompileObj, TclExecuteByteCode):
* tclCompile.h (ExtCmdLoc):
* tclInt.h (ExtIndex, CFWordBC, CmdFrame):
- * tclBasic.c (DeleteInterpProc, TclArgumentBCEnter,
- TclArgumentBCRelease, TclArgumentGet, SAVE_CONTEXT,
- RESTORE_CONTEXT, NRCoroutineExitCallback, TclNRCoroutineObjCmd):
+ * tclBasic.c (DeleteInterpProc, TclArgumentBCEnter)
+ (TclArgumentBCRelease, TclArgumentGet, SAVE_CONTEXT)
+ (RESTORE_CONTEXT, NRCoroutineExitCallback, TclNRCoroutineObjCmd):
* generic/tclCmdAH.c (TclNRForObjCmd, TclNRForIterCallback,
- ForNextCallback):
+ (ForNextCallback):
* generic/tclCmdMZ.c (TclNRWhileObjCmd):
Extended the bytecode compiler initialization to recognize the
- compilation of whole files (NRE enabled 'source' command) and
- switch to the counting of absolute lines in that case.
-
- Further extended the bytecode compiler to track the start line in
- the generated information, and modified the bytecode execution to
- recompile an object if the location as per the calling context
- doesn't match the location saved in the bytecode. This part could
- be optimized more by using more memory to keep all possibilities
- which occur around, or by just adjusting the location information
- instead of a total recompile.
-
- Reworked the handling of literal command arguments in bytecode to
- be saved (compiler) and used (execution) per command (See the
- TCL_INVOKE_STK* instructions), and not per the whole bytecode.
- This, and the previous change remove the problems with location
- data caused by literal sharing (across whole files, but also proc
- bodies). Simplified the associated datastructures (ExtIndex is
- gone, as is the function EnterCmdWordIndex).
-
- The last change causes the hashtable 'lineLABCPtr' to be state
- which has to be kept per coroutine, like the CmdFrame stack.
- Reworked the coroutine support code to create, delete and switch
- the information as needed. Further reworked the tailcall command
- as well, it has to pop its own arguments when run in a bytecode
- context to keep a proper stack in 'lineLABCPtr'.
-
- Fixed the mishandling of line information in the NRE-enabled 'for'
- and 'while' commands introduced when both were made to share their
- iteration callbacks without taking into account that the loop body
- is found in different words of the command. Introduced a separate
- data structure to hold all the callback information, as we went
- over the limit of 4 direct client-data values for NRE callbacks.
+ compilation of whole files (NRE enabled 'source' command) and switch
+ to the counting of absolute lines in that case.
+
+ Further extended the bytecode compiler to track the start line in the
+ generated information, and modified the bytecode execution to
+ recompile an object if the location as per the calling context doesn't
+ match the location saved in the bytecode. This part could be optimized
+ more by using more memory to keep all possibilities which occur
+ around, or by just adjusting the location information instead of a
+ total recompile.
+
+ Reworked the handling of literal command arguments in bytecode to be
+ saved (compiler) and used (execution) per command (See the
+ TCL_INVOKE_STK* instructions), and not per the whole bytecode. This,
+ and the previous change remove the problems with location data caused
+ by literal sharing (across whole files, but also proc bodies).
+ Simplified the associated datastructures (ExtIndex is gone, as is the
+ function EnterCmdWordIndex).
+
+ The last change causes the hashtable 'lineLABCPtr' to be state which
+ has to be kept per coroutine, like the CmdFrame stack. Reworked the
+ coroutine support code to create, delete and switch the information as
+ needed. Further reworked the tailcall command as well, it has to pop
+ its own arguments when run in a bytecode context to keep a proper
+ stack in 'lineLABCPtr'.
+
+ Fixed the mishandling of line information in the NRE-enabled 'for' and
+ 'while' commands introduced when both were made to share their
+ iteration callbacks without taking into account that the loop body is
+ found in different words of the command. Introduced a separate data
+ structure to hold all the callback information, as we went over the
+ limit of 4 direct client-data values for NRE callbacks.
The above fixes [Bug 1605269].
diff --git a/generic/tclInt.decls b/generic/tclInt.decls
index 0847324..dc4a7ff 100644
--- a/generic/tclInt.decls
+++ b/generic/tclInt.decls
@@ -13,10 +13,10 @@
# See the file "license.terms" for information on usage and redistribution
# of this file, and for a DISCLAIMER OF ALL WARRANTIES.
#
-# RCS: @(#) $Id: tclInt.decls,v 1.139 2009/06/18 09:41:26 dkf Exp $
+# RCS: @(#) $Id: tclInt.decls,v 1.140 2009/07/15 13:17:18 dkf Exp $
library tcl
-
+
# Define the unsupported generic interfaces.
interface tclInt
@@ -976,6 +976,21 @@ declare 243 generic {
void TclDbDumpActiveObjects(FILE *outFile)
}
+# Functions to make things better for itcl
+declare 244 generic {
+ Tcl_HashTable *TclGetNamespaceChildTable(Tcl_Namespace *nsPtr)
+}
+declare 245 generic {
+ Tcl_HashTable *TclGetNamespaceCommandTable(Tcl_Namespace *nsPtr)
+}
+declare 246 generic {
+ int TclInitRewriteEnsemble(Tcl_Interp *interp, int numRemoved,
+ int numInserted, Tcl_Obj *const *objv)
+}
+declare 247 generic {
+ void TclResetRewriteEnsemble(Tcl_Interp *interp, int isRootEnsemble)
+}
+
##############################################################################
# Define the platform specific internal Tcl interface. These functions are
@@ -1190,3 +1205,8 @@ declare 18 macosx {
declare 19 macosx {
void TclMacOSXNotifierAddRunLoopMode(const void *runLoopMode)
}
+
+
+# Local Variables:
+# mode: tcl
+# End:
diff --git a/generic/tclInt.h b/generic/tclInt.h
index 8c5cf3d..d2d8830 100644
--- a/generic/tclInt.h
+++ b/generic/tclInt.h
@@ -15,7 +15,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclInt.h,v 1.429 2009/07/14 16:52:28 kennykb Exp $
+ * RCS: @(#) $Id: tclInt.h,v 1.430 2009/07/15 13:17:18 dkf Exp $
*/
#ifndef _TCLINT
@@ -215,6 +215,15 @@ typedef struct TclVarHashTable {
TclVarHashCreateVar((tablePtr), (key), NULL)
/*
+ * Define this to reduce the amount of space that the average namespace
+ * consumes by only allocating the table of child namespaces when necessary.
+ * Defining it breaks compatibility for Tcl extensions (e.g., itcl) which
+ * reach directly into the Namespace structure.
+ */
+
+#undef BREAK_NAMESPACE_COMPAT
+
+/*
* The structure below defines a namespace.
* Note: the first five fields must match exactly the fields in a
* Tcl_Namespace structure (see tcl.h). If you change one, be sure to change
@@ -236,7 +245,7 @@ typedef struct Namespace {
struct Namespace *parentPtr;/* Points to the namespace that contains this
* one. NULL if this is the global
* namespace. */
-#if 1
+#ifndef BREAK_NAMESPACE_COMPAT
Tcl_HashTable childTable; /* Contains any child namespaces. Indexed by
* strings; values have type (Namespace *). */
#else
diff --git a/generic/tclIntDecls.h b/generic/tclIntDecls.h
index bdcdf29..5672e25 100644
--- a/generic/tclIntDecls.h
+++ b/generic/tclIntDecls.h
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclIntDecls.h,v 1.133 2009/06/18 09:42:40 dkf Exp $
+ * RCS: @(#) $Id: tclIntDecls.h,v 1.134 2009/07/15 13:17:18 dkf Exp $
*/
#ifndef _TCLINTDECLS
@@ -1030,6 +1030,29 @@ EXTERN int TclNREvalObjv (Tcl_Interp * interp, int objc,
/* 243 */
EXTERN void TclDbDumpActiveObjects (FILE * outFile);
#endif
+#ifndef TclGetNamespaceChildTable_TCL_DECLARED
+#define TclGetNamespaceChildTable_TCL_DECLARED
+/* 244 */
+EXTERN Tcl_HashTable * TclGetNamespaceChildTable (Tcl_Namespace * nsPtr);
+#endif
+#ifndef TclGetNamespaceCommandTable_TCL_DECLARED
+#define TclGetNamespaceCommandTable_TCL_DECLARED
+/* 245 */
+EXTERN Tcl_HashTable * TclGetNamespaceCommandTable (Tcl_Namespace * nsPtr);
+#endif
+#ifndef TclInitRewriteEnsemble_TCL_DECLARED
+#define TclInitRewriteEnsemble_TCL_DECLARED
+/* 246 */
+EXTERN int TclInitRewriteEnsemble (Tcl_Interp * interp,
+ int numRemoved, int numInserted,
+ Tcl_Obj *const * objv);
+#endif
+#ifndef TclResetRewriteEnsemble_TCL_DECLARED
+#define TclResetRewriteEnsemble_TCL_DECLARED
+/* 247 */
+EXTERN void TclResetRewriteEnsemble (Tcl_Interp * interp,
+ int isRootEnsemble);
+#endif
typedef struct TclIntStubs {
int magic;
@@ -1279,6 +1302,10 @@ typedef struct TclIntStubs {
int (*tclNREvalObjEx) (Tcl_Interp * interp, Tcl_Obj * objPtr, int flags, const CmdFrame * invoker, int word); /* 241 */
int (*tclNREvalObjv) (Tcl_Interp * interp, int objc, Tcl_Obj *const objv[], int flags, Command * cmdPtr); /* 242 */
void (*tclDbDumpActiveObjects) (FILE * outFile); /* 243 */
+ Tcl_HashTable * (*tclGetNamespaceChildTable) (Tcl_Namespace * nsPtr); /* 244 */
+ Tcl_HashTable * (*tclGetNamespaceCommandTable) (Tcl_Namespace * nsPtr); /* 245 */
+ int (*tclInitRewriteEnsemble) (Tcl_Interp * interp, int numRemoved, int numInserted, Tcl_Obj *const * objv); /* 246 */
+ void (*tclResetRewriteEnsemble) (Tcl_Interp * interp, int isRootEnsemble); /* 247 */
} TclIntStubs;
#if defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS)
@@ -1985,6 +2012,22 @@ extern const TclIntStubs *tclIntStubsPtr;
#define TclDbDumpActiveObjects \
(tclIntStubsPtr->tclDbDumpActiveObjects) /* 243 */
#endif
+#ifndef TclGetNamespaceChildTable
+#define TclGetNamespaceChildTable \
+ (tclIntStubsPtr->tclGetNamespaceChildTable) /* 244 */
+#endif
+#ifndef TclGetNamespaceCommandTable
+#define TclGetNamespaceCommandTable \
+ (tclIntStubsPtr->tclGetNamespaceCommandTable) /* 245 */
+#endif
+#ifndef TclInitRewriteEnsemble
+#define TclInitRewriteEnsemble \
+ (tclIntStubsPtr->tclInitRewriteEnsemble) /* 246 */
+#endif
+#ifndef TclResetRewriteEnsemble
+#define TclResetRewriteEnsemble \
+ (tclIntStubsPtr->tclResetRewriteEnsemble) /* 247 */
+#endif
#endif /* defined(USE_TCL_STUBS) && !defined(USE_TCL_STUB_PROCS) */
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;
+ }
}
/*
diff --git a/generic/tclResolve.c b/generic/tclResolve.c
index af7d4cb..8455793 100644
--- a/generic/tclResolve.c
+++ b/generic/tclResolve.c
@@ -11,7 +11,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclResolve.c,v 1.10 2008/04/27 22:21:32 dkf Exp $
+ * RCS: @(#) $Id: tclResolve.c,v 1.11 2009/07/15 13:17:19 dkf Exp $
*/
#include "tclInt.h"
@@ -262,12 +262,23 @@ BumpCmdRefEpochs(
nsPtr->cmdRefEpoch++;
+#ifndef BREAK_NAMESPACE_COMPAT
for (entry = Tcl_FirstHashEntry(&nsPtr->childTable, &search);
entry != NULL; entry = Tcl_NextHashEntry(&search)) {
Namespace *childNsPtr = Tcl_GetHashValue(entry);
BumpCmdRefEpochs(childNsPtr);
}
+#else
+ if (nsPtr->childTablePtr != NULL) {
+ for (entry = Tcl_FirstHashEntry(nsPtr->childTablePtr, &search);
+ entry != NULL; entry = Tcl_NextHashEntry(&search)) {
+ Namespace *childNsPtr = Tcl_GetHashValue(entry);
+
+ BumpCmdRefEpochs(childNsPtr);
+ }
+ }
+#endif
TclInvalidateNsPath(nsPtr);
}
diff --git a/generic/tclStubInit.c b/generic/tclStubInit.c
index 9241677..d80c19a 100644
--- a/generic/tclStubInit.c
+++ b/generic/tclStubInit.c
@@ -8,7 +8,7 @@
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclStubInit.c,v 1.182 2009/06/30 00:56:08 das Exp $
+ * RCS: @(#) $Id: tclStubInit.c,v 1.183 2009/07/15 13:17:19 dkf Exp $
*/
#include "tclInt.h"
@@ -290,6 +290,10 @@ static const TclIntStubs tclIntStubs = {
TclNREvalObjEx, /* 241 */
TclNREvalObjv, /* 242 */
TclDbDumpActiveObjects, /* 243 */
+ TclGetNamespaceChildTable, /* 244 */
+ TclGetNamespaceCommandTable, /* 245 */
+ TclInitRewriteEnsemble, /* 246 */
+ TclResetRewriteEnsemble, /* 247 */
};
static const TclIntPlatStubs tclIntPlatStubs = {