diff options
| -rw-r--r-- | ChangeLog | 88 | ||||
| -rw-r--r-- | generic/tclInt.decls | 24 | ||||
| -rw-r--r-- | generic/tclInt.h | 13 | ||||
| -rw-r--r-- | generic/tclIntDecls.h | 45 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 257 | ||||
| -rw-r--r-- | generic/tclResolve.c | 13 | ||||
| -rw-r--r-- | generic/tclStubInit.c | 6 |
7 files changed, 375 insertions, 71 deletions
@@ -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 = { |