diff options
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclNamesp.c | 404 |
2 files changed, 243 insertions, 168 deletions
@@ -1,3 +1,10 @@ +2008-07-15 Donal K. Fellows <dkf@users.sf.net> + + * generic/tclNamesp.c (EnsembleUnknownCallback): Factor out some of + the more complex parts of the ensemble code to make it easier to + understand and hence to permit tighter compilation of code on the + critical path. + 2008-07-14 Miguel Sofer <msofer@users.sf.net> * generic/tclParse.c: reverting the "fix" for [Bug 2017583], diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index a0a651b..3faae95 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.165 2008/07/13 09:03:35 msofer Exp $ + * RCS: @(#) $Id: tclNamesp.c,v 1.166 2008/07/15 10:15:52 dkf Exp $ */ #include "tclInt.h" @@ -154,6 +154,9 @@ static int DoImport(Tcl_Interp *interp, const char *cmdName, const char *pattern, Namespace *importNsPtr, int allowOverwrite); static void DupNsNameInternalRep(Tcl_Obj *objPtr,Tcl_Obj *copyPtr); +static inline int EnsembleUnknownCallback(Tcl_Interp *interp, + EnsembleConfig *ensemblePtr, int objc, + Tcl_Obj *const objv[], Tcl_Obj **prefixObjPtr); static char * ErrorCodeRead(ClientData clientData,Tcl_Interp *interp, const char *name1, const char *name2, int flags); static char * ErrorInfoRead(ClientData clientData,Tcl_Interp *interp, @@ -1645,7 +1648,8 @@ DoImport( dataPtr = (ImportedCmdData *) ckalloc(sizeof(ImportedCmdData)); importedCmd = TclNR_CreateCommand(interp, Tcl_DStringValue(&ds), - InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, DeleteImportedCmd); + InvokeImportedCmd, InvokeImportedNRCmd, dataPtr, + DeleteImportedCmd); dataPtr->realCmdPtr = cmdPtr; dataPtr->selfPtr = (Command *) importedCmd; dataPtr->selfPtr->compileProc = cmdPtr->compileProc; @@ -1893,11 +1897,10 @@ InvokeImportedNRCmd( register Command *realCmdPtr = dataPtr->realCmdPtr; if (!realCmdPtr->nreProc) { - return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, - objc, objv); + return realCmdPtr->objProc(realCmdPtr->objClientData, interp, + objc, objv); } - return (*realCmdPtr->nreProc)(realCmdPtr->objClientData, interp, - objc, objv); + return realCmdPtr->nreProc(realCmdPtr->objClientData, interp, objc, objv); } static int @@ -1911,8 +1914,7 @@ InvokeImportedCmd( register ImportedCmdData *dataPtr = clientData; register Command *realCmdPtr = dataPtr->realCmdPtr; - return (*realCmdPtr->objProc)(realCmdPtr->objClientData, interp, - objc, objv); + return realCmdPtr->objProc(realCmdPtr->objClientData, interp, objc, objv); } /* @@ -2797,7 +2799,8 @@ Tcl_NamespaceObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { - return TclNR_CallObjProc(interp, TclNRNamespaceObjCmd, clientData, objc, objv); + return TclNR_CallObjProc(interp, TclNRNamespaceObjCmd, clientData, objc, + objv); } int @@ -3260,35 +3263,6 @@ NamespaceDeleteCmd( */ static int -NsEval_Callback( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Tcl_Namespace *namespacePtr = data[0]; - - if (result == TCL_ERROR) { - int length = strlen(namespacePtr->fullName); - int limit = 200; - int overflow = (length > limit); - char *cmd = data[1]; - - Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( - "\n (in namespace %s \"%.*s%s\" script line %d)", - cmd, - (overflow ? limit : length), namespacePtr->fullName, - (overflow ? "..." : ""), interp->errorLine)); - } - - /* - * Restore the previous "current" namespace. - */ - - TclPopStackFrame(interp); - return result; -} - -static int NamespaceEvalCmd( ClientData dummy, /* Not used. */ Tcl_Interp *interp, /* Current interpreter. */ @@ -3358,9 +3332,39 @@ NamespaceEvalCmd( * TIP #280: Make invoking context available to eval'd script. */ - TclNR_AddCallback(interp, NsEval_Callback, namespacePtr, "eval", NULL, NULL); + TclNR_AddCallback(interp, NsEval_Callback, namespacePtr, "eval", + NULL, NULL); return TclNREvalObjEx(interp, objPtr, 0, iPtr->cmdFramePtr, 3); } + +static int +NsEval_Callback( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Namespace *namespacePtr = data[0]; + + if (result == TCL_ERROR) { + int length = strlen(namespacePtr->fullName); + int limit = 200; + int overflow = (length > limit); + char *cmd = data[1]; + + Tcl_AppendObjToErrorInfo(interp, Tcl_ObjPrintf( + "\n (in namespace %s \"%.*s%s\" script line %d)", + cmd, + (overflow ? limit : length), namespacePtr->fullName, + (overflow ? "..." : ""), interp->errorLine)); + } + + /* + * Restore the previous "current" namespace. + */ + + TclPopStackFrame(interp); + return result; +} /* *---------------------------------------------------------------------- @@ -3774,7 +3778,8 @@ NamespaceInscopeCmd( Tcl_DecrRefCount(listPtr); /* We're done with the list object. */ } - TclNR_AddCallback(interp, NsEval_Callback, namespacePtr, "inscope", NULL, NULL); + TclNR_AddCallback(interp, NsEval_Callback, namespacePtr, "inscope", + NULL, NULL); return TclNREvalObjEx(interp, cmdObjPtr, 0, NULL, 0); } @@ -6045,21 +6050,6 @@ NsEnsembleImplementationCmd( clientData, objc, objv); } -int -TclClearRootEnsemble( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Interp *iPtr = (Interp *) interp; - - iPtr->ensembleRewrite.sourceObjs = NULL; - iPtr->ensembleRewrite.numRemovedObjs = 0; - iPtr->ensembleRewrite.numInsertedObjs = 0; - - return result; -} - static int NsEnsembleImplementationCmdNR( ClientData clientData, @@ -6069,19 +6059,12 @@ NsEnsembleImplementationCmdNR( { EnsembleConfig *ensemblePtr = clientData; /* The ensemble itself. */ - Tcl_Obj **tempObjv; /* Space used to construct the list of - * arguments to pass to the command that - * implements the ensemble subcommand. */ - int result; /* The result of the subcommand execution. */ Tcl_Obj *prefixObj; /* An object containing the prefix words of * the command that implements the * subcommand. */ Tcl_HashEntry *hPtr; /* Used for efficient lookup of fully * specified but not yet cached command * names. */ - Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the - * target command prefix. */ - int prefixObjc; /* Size of prefixObjv of course! */ int reparseCount = 0; /* Number of reparses. */ if (objc < 2) { @@ -6133,7 +6116,7 @@ NsEnsembleImplementationCmdNR( /* * Look in the hashtable for the subcommand name; this is the fastest way - * of all. + * of all if there is no cache in operation. */ hPtr = Tcl_FindHashEntry(&ensemblePtr->subcommandTable, @@ -6232,48 +6215,58 @@ NsEnsembleImplementationCmdNR( */ { + Tcl_Obj **prefixObjv; /* The list of objects to substitute in as the + * target command prefix. */ + Tcl_Obj *copyPtr; /* The actual list of words to dispatch to. + * Will be freed by the dispatch engine. */ + int prefixObjc, copyObjc; Interp *iPtr = (Interp *) interp; - int isRootEnsemble, i, tempObjc; - Tcl_Obj *copyPtr; - List *listRepPtr; /* * Get the prefix that we're rewriting to. To do this we need to * ensure that the internal representation of the list does not change * so that we can safely keep the internal representations of the * elements in the list. + * + * TODO: Use conventional list operations to make this code sane! */ TclListObjGetElements(NULL, prefixObj, &prefixObjc, &prefixObjv); - tempObjc = objc - 2 + prefixObjc; - copyPtr = Tcl_NewListObj(tempObjc, NULL); - if (tempObjc > 0) { - listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; - listRepPtr->elemCount = tempObjc; - tempObjv = &listRepPtr->elements; - - memcpy(tempObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); - memcpy(tempObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); - - for (i=0; i < tempObjc; i++) { - Tcl_IncrRefCount(tempObjv[i]); + copyObjc = objc - 2 + prefixObjc; + copyPtr = Tcl_NewListObj(copyObjc, NULL); + if (copyObjc > 0) { + register Tcl_Obj **copyObjv; + /* Space used to construct the list of + * arguments to pass to the command that + * implements the ensemble subcommand. */ + register List *listRepPtr = copyPtr->internalRep.twoPtrValue.ptr1; + register int i; + + listRepPtr->elemCount = copyObjc; + copyObjv = &listRepPtr->elements; + memcpy(copyObjv, prefixObjv, sizeof(Tcl_Obj *) * prefixObjc); + memcpy(copyObjv+prefixObjc, objv+2, sizeof(Tcl_Obj *) * (objc-2)); + + for (i=0; i < copyObjc; i++) { + Tcl_IncrRefCount(copyObjv[i]); } } - Tcl_DecrRefCount(prefixObj); + TclDecrRefCount(prefixObj); /* * Record what arguments the script sent in so that things like * Tcl_WrongNumArgs can give the correct error message. */ - isRootEnsemble = (iPtr->ensembleRewrite.sourceObjs == NULL); - if (isRootEnsemble) { + if (iPtr->ensembleRewrite.sourceObjs == NULL) { iPtr->ensembleRewrite.sourceObjs = objv; iPtr->ensembleRewrite.numRemovedObjs = 2; iPtr->ensembleRewrite.numInsertedObjs = prefixObjc; + TclNR_AddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, + NULL); } else { - int ni = iPtr->ensembleRewrite.numInsertedObjs; + register int ni = iPtr->ensembleRewrite.numInsertedObjs; if (ni < 2) { iPtr->ensembleRewrite.numRemovedObjs += 2 - ni; @@ -6287,10 +6280,6 @@ NsEnsembleImplementationCmdNR( * Hand off to the target command. */ - if (isRootEnsemble) { - TclNR_AddCallback(interp, TclClearRootEnsemble, NULL, NULL, NULL, NULL); - } - return TclNREvalCmd(interp, copyPtr, TCL_EVAL_INVOKE); } @@ -6303,90 +6292,15 @@ NsEnsembleImplementationCmdNR( */ if (ensemblePtr->unknownHandler != NULL && reparseCount++ < 1) { - int paramc, i; - Tcl_Obj **paramv, *unknownCmd, *ensObj; - - unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); - TclNewObj(ensObj); - Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); - Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); - for (i=1 ; i<objc ; i++) { - Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]); - } - TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv); - Tcl_Preserve(ensemblePtr); - Tcl_IncrRefCount(unknownCmd); - result = Tcl_EvalObjv(interp, paramc, paramv, 0); - if (result == TCL_OK) { - prefixObj = Tcl_GetObjResult(interp); - Tcl_IncrRefCount(prefixObj); - Tcl_DecrRefCount(unknownCmd); - Tcl_Release(ensemblePtr); - Tcl_ResetResult(interp); - if (ensemblePtr->flags & ENS_DEAD) { - Tcl_DecrRefCount(prefixObj); - Tcl_SetResult(interp, - "unknown subcommand handler deleted its ensemble", - TCL_STATIC); - return TCL_ERROR; - } - - /* - * Namespace is still there. Check if the result is a valid list. - * If it is, and it is non-empty, that list is what we are using - * as our replacement. - */ - - if (TclListObjLength(interp, prefixObj, &prefixObjc) != TCL_OK) { - Tcl_DecrRefCount(prefixObj); - Tcl_AddErrorInfo(interp, "\n while parsing result of " - "ensemble unknown subcommand handler"); - return TCL_ERROR; - } - if (prefixObjc > 0) { - goto runResultingSubcommand; - } - - /* - * Namespace alive & empty result => reparse. - */ - - Tcl_DecrRefCount(prefixObj); + switch (EnsembleUnknownCallback(interp, ensemblePtr, objc, objv, + &prefixObj)) { + case TCL_OK: + goto runResultingSubcommand; + case TCL_ERROR: + return TCL_ERROR; + case TCL_CONTINUE: goto restartEnsembleParse; } - if (!Tcl_InterpDeleted(interp)) { - if (result != TCL_ERROR) { - char buf[TCL_INTEGER_SPACE]; - - Tcl_ResetResult(interp); - Tcl_SetResult(interp, - "unknown subcommand handler returned bad code: ", - TCL_STATIC); - switch (result) { - case TCL_RETURN: - Tcl_AppendResult(interp, "return", NULL); - break; - case TCL_BREAK: - Tcl_AppendResult(interp, "break", NULL); - break; - case TCL_CONTINUE: - Tcl_AppendResult(interp, "continue", NULL); - break; - default: - sprintf(buf, "%d", result); - Tcl_AppendResult(interp, buf, NULL); - } - Tcl_AddErrorInfo(interp, "\n result of " - "ensemble unknown subcommand handler: "); - Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); - } else { - Tcl_AddErrorInfo(interp, - "\n (ensemble unknown subcommand handler)"); - } - } - Tcl_DecrRefCount(unknownCmd); - Tcl_Release(ensemblePtr); - return TCL_ERROR; } /* @@ -6426,6 +6340,160 @@ NsEnsembleImplementationCmdNR( TclGetString(objv[1]), NULL); return TCL_ERROR; } + +int +TclClearRootEnsemble( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *) interp; + + iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.numRemovedObjs = 0; + iPtr->ensembleRewrite.numInsertedObjs = 0; + + return result; +} + +/* + * ---------------------------------------------------------------------- + * + * EnsmebleUnknownCallback -- + * + * Helper for the ensemble engine that handles the procesing of unknown + * callbacks. See the user documentation of the ensemble unknown handler + * for details; this function is only ever called when such a function is + * defined, and is only ever called once per ensemble dispatch (i.e. if a + * reparse still fails, this isn't called again). + * + * Results: + * TCL_OK - *prefixObjPtr contains the command words to dispatch + * to. + * TCL_CONTINUE - Need to reparse (*prefixObjPtr is invalid). + * TCL_ERROR - Something went wrong! Error message in interpreter. + * + * Side effects: + * Calls the Tcl interpreter, so arbitrary. + * + * ---------------------------------------------------------------------- + */ + +static inline int +EnsembleUnknownCallback( + Tcl_Interp *interp, + EnsembleConfig *ensemblePtr, + int objc, + Tcl_Obj *const objv[], + Tcl_Obj **prefixObjPtr) +{ + int paramc, i, result, prefixObjc; + Tcl_Obj **paramv, *unknownCmd, *ensObj; + char buf[TCL_INTEGER_SPACE]; + + /* + * Create the unknown command callback to determine what to do. + */ + + unknownCmd = Tcl_DuplicateObj(ensemblePtr->unknownHandler); + TclNewObj(ensObj); + Tcl_GetCommandFullName(interp, ensemblePtr->token, ensObj); + Tcl_ListObjAppendElement(NULL, unknownCmd, ensObj); + for (i=1 ; i<objc ; i++) { + Tcl_ListObjAppendElement(NULL, unknownCmd, objv[i]); + } + TclListObjGetElements(NULL, unknownCmd, ¶mc, ¶mv); + Tcl_IncrRefCount(unknownCmd); + + /* + * Now call the unknown handler. (We don't bother NRE-enabling this; deep + * recursing through unknown handlers is horribly perverse.) Note that it + * is always an error for an unknown handler to delete its ensemble; don't + * do that! + */ + + Tcl_Preserve(ensemblePtr); + result = Tcl_EvalObjv(interp, paramc, paramv, 0); + if ((result == TCL_OK) && (ensemblePtr->flags & ENS_DEAD)) { + Tcl_SetResult(interp, + "unknown subcommand handler deleted its ensemble", + TCL_STATIC); + result = TCL_ERROR; + } + Tcl_Release(ensemblePtr); + + /* + * If we succeeded, we should either have a list of words that form the + * command to be executed, or an empty list. In the empty-list case, the + * ensemble is believed to be updated so we should ask the ensemble engine + * to reparse the original command. + */ + + if (result == TCL_OK) { + *prefixObjPtr = Tcl_GetObjResult(interp); + Tcl_IncrRefCount(*prefixObjPtr); + TclDecrRefCount(unknownCmd); + Tcl_ResetResult(interp); + + /* + * Namespace is still there. Check if the result is a valid list. If + * it is, and it is non-empty, that list is what we are using as our + * replacement. + */ + + if (TclListObjLength(interp, *prefixObjPtr, &prefixObjc) != TCL_OK) { + TclDecrRefCount(*prefixObjPtr); + Tcl_AddErrorInfo(interp, "\n while parsing result of " + "ensemble unknown subcommand handler"); + return TCL_ERROR; + } + if (prefixObjc > 0) { + return TCL_OK; + } + + /* + * Namespace alive & empty result => reparse. + */ + + TclDecrRefCount(*prefixObjPtr); + return TCL_CONTINUE; + } + + /* + * Oh no! An exceptional result. Convert to an error. + */ + + if (!Tcl_InterpDeleted(interp)) { + if (result != TCL_ERROR) { + Tcl_ResetResult(interp); + Tcl_SetResult(interp, + "unknown subcommand handler returned bad code: ", + TCL_STATIC); + switch (result) { + case TCL_RETURN: + Tcl_AppendResult(interp, "return", NULL); + break; + case TCL_BREAK: + Tcl_AppendResult(interp, "break", NULL); + break; + case TCL_CONTINUE: + Tcl_AppendResult(interp, "continue", NULL); + break; + default: + sprintf(buf, "%d", result); + Tcl_AppendResult(interp, buf, NULL); + } + Tcl_AddErrorInfo(interp, "\n result of " + "ensemble unknown subcommand handler: "); + Tcl_AddErrorInfo(interp, TclGetString(unknownCmd)); + } else { + Tcl_AddErrorInfo(interp, + "\n (ensemble unknown subcommand handler)"); + } + } + TclDecrRefCount(unknownCmd); + return TCL_ERROR; +} /* *---------------------------------------------------------------------- |