From 2bcd186571b8f37c820add859b48f7046260d261 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 8 Apr 2013 18:11:33 +0000 Subject: Revise TclNREvalObjv so that pre-resolution of the Command by a caller does not force suppression of exception handling. Let those be separable demands. Aim is to bring TclObjInvoke*() into the fold. --- generic/tclBasic.c | 17 ++++++++++++----- generic/tclNamesp.c | 2 +- generic/tclOOMethod.c | 2 +- 3 files changed, 14 insertions(+), 7 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index cde1cb9..22ec6b0 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4188,10 +4188,6 @@ TclNREvalObjv( return result; } - if (cmdPtr) { - goto commandFound; - } - /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4201,6 +4197,10 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (cmdPtr) { + goto commandFound; + } + /* * Configure evaluation context to match the requested flags. */ @@ -6620,9 +6620,11 @@ TclObjInvoke( Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } +#if 1 if (TclInterpReady(interp) == TCL_ERROR) { return TCL_ERROR; } +#endif cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6638,6 +6640,7 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); +#if 1 /* * Invoke the command function. */ @@ -6669,6 +6672,9 @@ TclObjInvoke( iPtr->flags &= ~ERR_ALREADY_LOGGED; } return result; +#else + +#endif } /* @@ -8243,7 +8249,8 @@ Tcl_NRCmdSwap( Tcl_Obj *const objv[], int flags) { - return TclNREvalObjv(interp, objc, objv, flags, (Command *) cmd); + return TclNREvalObjv(interp, objc, objv, flags|TCL_EVAL_NOERR, + (Command *) cmd); } /***************************************************************************** diff --git a/generic/tclNamesp.c b/generic/tclNamesp.c index aed623a..bdd5386 100644 --- a/generic/tclNamesp.c +++ b/generic/tclNamesp.c @@ -1942,7 +1942,7 @@ InvokeImportedNRCmd( Command *realCmdPtr = dataPtr->realCmdPtr; TclSkipTailcall(interp); - return Tcl_NRCmdSwap(interp, (Tcl_Command) realCmdPtr, objc, objv, 0); + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NOERR, realCmdPtr); } static int diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index 98b4078..bd2744a 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1429,7 +1429,7 @@ InvokeForwardMethod( contextPtr->oPtr->namespacePtr, 0 /* normal lookup */); } Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, cmdPtr); + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, cmdPtr); } static int -- cgit v0.12 From 2816004e58ac0da7bde02b0159b164e54c04ab6a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 14:39:56 +0000 Subject: New internal routine TclNRInvoke() - NR-enabled path through the machinery behind invokehidden commands. --- generic/tclBasic.c | 77 +++++++++++++++++++++-------------------------------- generic/tclInt.h | 1 + generic/tclInterp.c | 7 ++++- 3 files changed, 37 insertions(+), 48 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 22ec6b0..82ce385 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -162,6 +162,7 @@ static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; static Tcl_ObjCmdProc NRCoroInjectObjCmd; +static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; @@ -6599,32 +6600,32 @@ TclObjInvoke( * TCL_INVOKE_HIDDEN, TCL_INVOKE_NO_UNKNOWN, * or TCL_INVOKE_NO_TRACEBACK. */ { - register Interp *iPtr = (Interp *) interp; - Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ - const char *cmdName; /* Name of the command from objv[0]. */ - Tcl_HashEntry *hPtr = NULL; - Command *cmdPtr; - int result; - if (interp == NULL) { return TCL_ERROR; } - if ((objc < 1) || (objv == NULL)) { Tcl_SetObjResult(interp, Tcl_NewStringObj( "illegal argument vector", -1)); return TCL_ERROR; } - if ((flags & TCL_INVOKE_HIDDEN) == 0) { Tcl_Panic("TclObjInvoke: called without TCL_INVOKE_HIDDEN"); } + return Tcl_NRCallObjProc(interp, TclNRInvoke, NULL, objc, objv); +} -#if 1 - if (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } -#endif +int +TclNRInvoke( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + register Interp *iPtr = (Interp *) interp; + Tcl_HashTable *hTblPtr; /* Table of hidden commands. */ + const char *cmdName; /* Name of the command from objv[0]. */ + Tcl_HashEntry *hPtr = NULL; + Command *cmdPtr; cmdName = TclGetString(objv[0]); hTblPtr = iPtr->hiddenCmdTablePtr; @@ -6640,41 +6641,23 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); -#if 1 - /* - * Invoke the command function. - */ - - iPtr->cmdCount++; - if (cmdPtr->objProc != NULL) { - result = cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } else { - result = Tcl_NRCallObjProc(interp, cmdPtr->nreProc, - cmdPtr->objClientData, objc, objv); - } - - /* - * If an error occurred, record information about what was being executed - * when the error occurred. - */ - - if ((result == TCL_ERROR) - && ((flags & TCL_INVOKE_NO_TRACEBACK) == 0) - && ((iPtr->flags & ERR_ALREADY_LOGGED) == 0)) { - int length; - Tcl_Obj *command = Tcl_NewListObj(objc, objv); - const char *cmdString; + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); + + /* TODO: how to get re-resolution right */ + return TclNREvalObjv(interp, objc, objv, 0, cmdPtr); +} - Tcl_IncrRefCount(command); - cmdString = Tcl_GetStringFromObj(command, &length); - Tcl_LogCommandInfo(interp, cmdString, cmdString, length); - Tcl_DecrRefCount(command); - iPtr->flags &= ~ERR_ALREADY_LOGGED; - } +static int +NRPostInvoke( + ClientData clientData[], + Tcl_Interp *interp, + int result) +{ + Interp *iPtr = (Interp *)interp; + iPtr->numLevels--; return result; -#else - -#endif } /* diff --git a/generic/tclInt.h b/generic/tclInt.h index 1f939c0..70d6d02 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2739,6 +2739,7 @@ MODULE_SCOPE Tcl_ObjCmdProc TclNRCoroutineObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldmObjCmd; MODULE_SCOPE Tcl_ObjCmdProc TclNRYieldToObjCmd; +MODULE_SCOPE Tcl_ObjCmdProc TclNRInvoke; MODULE_SCOPE void TclSetTailcall(Tcl_Interp *interp, Tcl_Obj *tailcallPtr); MODULE_SCOPE void TclPushTailcallPoint(Tcl_Interp *interp); diff --git a/generic/tclInterp.c b/generic/tclInterp.c index 1a4297b..ac51d9d 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -3052,7 +3052,12 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + if (interp == slaveInterp) { + Tcl_Release(slaveInterp); + return TclNRInvoke(NULL, slaveInterp, objc, objv); + } else { + result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + } } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; -- cgit v0.12 From 87dc28ad0ec271d380acc051908672eb9a3adb43 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 19:36:37 +0000 Subject: More revisions let multi-interp test case work, but at cost of panics and segfaults. Pushing the NRE-envelope. --- generic/tclInterp.c | 18 +++++++++++++++++- 1 file changed, 17 insertions(+), 1 deletion(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index ac51d9d..e9ed790 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,6 +279,7 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); +static Tcl_NRPostProc NRPostInvokeHidden; /* *---------------------------------------------------------------------- @@ -3056,7 +3057,9 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + NULL, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } } else { Namespace *nsPtr, *dummy1, *dummy2; @@ -3076,6 +3079,19 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + + Tcl_TransferResult(slaveInterp, result, interp); + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- -- cgit v0.12 From f54af08a171ccb68fa91d72cead431736ff19908 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 11 Apr 2013 21:30:40 +0000 Subject: More progress. NR-enable [interp] and [$slave], completely with invokehidden subcommand. Test suite passes with no errors. --- generic/tclInterp.c | 51 +++++++++++++++++++++++++++++++++++++++------------ 1 file changed, 39 insertions(+), 12 deletions(-) diff --git a/generic/tclInterp.c b/generic/tclInterp.c index e9ed790..0da5d47 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,7 +279,12 @@ static void DeleteScriptLimitCallback(ClientData clientData); static void RunLimitHandlers(LimitHandler *handlerPtr, Tcl_Interp *interp); static void TimeLimitCallback(ClientData clientData); + +/* NRE enabling */ static Tcl_NRPostProc NRPostInvokeHidden; +static Tcl_ObjCmdProc NRInterpCmd; +static Tcl_ObjCmdProc NRSlaveCmd; + /* *---------------------------------------------------------------------- @@ -482,7 +487,8 @@ TclInterpInit( slavePtr->interpCmd = NULL; Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); - Tcl_CreateObjCommand(interp, "interp", Tcl_InterpObjCmd, NULL, NULL); + Tcl_NRCreateCommand(interp, "interp", Tcl_InterpObjCmd, NRInterpCmd, + NULL, NULL); Tcl_CallWhenDeleted(interp, InterpInfoDeleteProc, NULL); return TCL_OK; @@ -591,6 +597,16 @@ Tcl_InterpObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRInterpCmd, clientData, objc, objv); +} + +static int +NRInterpCmd( + ClientData clientData, /* Unused. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp; int index; static const char *const options[] = { @@ -2373,8 +2389,8 @@ SlaveCreate( slavePtr->masterInterp = masterInterp; slavePtr->slaveEntryPtr = hPtr; slavePtr->slaveInterp = slaveInterp; - slavePtr->interpCmd = Tcl_CreateObjCommand(masterInterp, path, - SlaveObjCmd, slaveInterp, SlaveObjCmdDeleteProc); + slavePtr->interpCmd = Tcl_NRCreateCommand(masterInterp, path, + SlaveObjCmd, NRSlaveCmd, slaveInterp, SlaveObjCmdDeleteProc); Tcl_InitHashTable(&slavePtr->aliasTable, TCL_STRING_KEYS); Tcl_SetHashValue(hPtr, slavePtr); Tcl_SetVar(slaveInterp, "tcl_interactive", "0", TCL_GLOBAL_ONLY); @@ -2463,6 +2479,16 @@ SlaveObjCmd( int objc, /* Number of arguments. */ Tcl_Obj *const objv[]) /* Argument objects. */ { + return Tcl_NRCallObjProc(interp, NRSlaveCmd, clientData, objc, objv); +} + +static int +NRSlaveCmd( + ClientData clientData, /* Slave interpreter. */ + Tcl_Interp *interp, /* Current interpreter. */ + int objc, /* Number of arguments. */ + Tcl_Obj *const objv[]) /* Argument objects. */ +{ Tcl_Interp *slaveInterp = clientData; int index; static const char *const options[] = { @@ -3053,14 +3079,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - if (interp == slaveInterp) { - Tcl_Release(slaveInterp); - return TclNRInvoke(NULL, slaveInterp, objc, objv); - } else { - Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, - NULL, NULL, NULL); - return TclNRInvoke(NULL, slaveInterp, objc, objv); - } + NRE_callback *rootPtr = TOP_CB(slaveInterp); + + Tcl_NRAddCallback(interp, NRPostInvokeHidden, slaveInterp, + rootPtr, NULL, NULL); + return TclNRInvoke(NULL, slaveInterp, objc, objv); } else { Namespace *nsPtr, *dummy1, *dummy2; const char *tail; @@ -3087,8 +3110,12 @@ NRPostInvokeHidden( int result) { Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; - Tcl_TransferResult(slaveInterp, result, interp); + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } Tcl_Release(slaveInterp); return result; } -- cgit v0.12 From 654dc20b4af9b37825f7faffaa0e714dad02ce92 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 15 Jul 2013 19:09:59 +0000 Subject: Possible improvement in light of [86ceb4e2b6]. --- library/tm.tcl | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/library/tm.tcl b/library/tm.tcl index d2af4f5..955e84d 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,6 +238,15 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } + if {[string length [package ifneeded $pkgname $pkgversion]]} { + # There's already a provide script registered for + # this version of this package. Since all units of + # code claiming to be the same version of the same + # package ought to be identical, just stick with + # the one we already have. + continue + } + # We have found a candidate, generate a "provide script" # for it, and remember it. Note that we are using ::list # to do this; locally [list] means something else without -- cgit v0.12 From 7f660cabfb7f9a21f1a60e6e2b06cbd9449b8d13 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 19 Aug 2013 15:22:15 +0000 Subject: Testing doing away with the NRRunObjProc routine, which looks like a useless extra bounce on the NRE trampoline. Normal testing has no problem with it, but debug-enabled testing triggers an assert failure. Either it would be good to have a normal test that fails in the conditions of the assert failure, or it would be good to discover the assert is asserting something not actually required, and then make the purge. --- generic/tclBasic.c | 8 ++++++++ 1 file changed, 8 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4a95340..020f2f2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -133,7 +133,9 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); +#if 0 static Tcl_NRPostProc NRRunObjProc; +#endif static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -4238,9 +4240,13 @@ TclNREvalObjv( */ if (cmdPtr->nreProc) { +#if 0 TclNRAddCallback(interp, NRRunObjProc, cmdPtr, INT2PTR(objc), (ClientData) objv, NULL); return TCL_OK; +#else + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); +#endif } else { return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); } @@ -4323,6 +4329,7 @@ NRCommand( return result; } +#if 0 static int NRRunObjProc( ClientData data[], @@ -4337,6 +4344,7 @@ NRRunObjProc( return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); } +#endif /* -- cgit v0.12 From 4837b605c2c1f2aa65ba75d080a2cb5076303abd Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 19 Aug 2013 16:34:10 +0000 Subject: Revise execution trace handling to take account of the new reality in Tcl 8.6 that callers can pre-resolve a cmdPtr for us. In that case a re-resolution in the form of another command name lookup isn't the right thing. --- generic/tclBasic.c | 51 +++++++++++++++++++++++++++++++++++++-------------- 1 file changed, 37 insertions(+), 14 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 64563ee..8ac5781 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -148,7 +148,8 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr); + Tcl_Obj *const objv[], Namespace *lookupNsPtr, + int weLookUp); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -4098,6 +4099,7 @@ TclNREvalObjv( Namespace *lookupNsPtr = iPtr->lookupNsPtr; Command **cmdPtrPtr; NRE_callback *callbackPtr; + int weLookUp = (cmdPtr == NULL); iPtr->lookupNsPtr = NULL; @@ -4136,7 +4138,7 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (cmdPtr) { + if (!weLookUp) { goto commandFound; } @@ -4188,12 +4190,16 @@ TclNREvalObjv( result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr); + objc, objv), objc, objv, lookupNsPtr, weLookUp); if (result != TCL_OK) { return result; } - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (cmdPtr == NULL) { + if (weLookUp) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + /* Is this right??? */ + return TCL_OK; } } @@ -4605,7 +4611,8 @@ TEOV_RunEnterTraces( Tcl_Obj *commandPtr, int objc, Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + Namespace *lookupNsPtr, + int weLookUp) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; @@ -4613,7 +4620,7 @@ TEOV_RunEnterTraces( int cmdEpoch = cmdPtr->cmdEpoch; int newEpoch; const char *command; - int length; + int length, deleted; Tcl_IncrRefCount(commandPtr); command = Tcl_GetStringFromObj(commandPtr, &length); @@ -4635,16 +4642,32 @@ TEOV_RunEnterTraces( cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); - /* - * If the traces modified/deleted the command or any existing traces, they - * will update the command's epoch. We need to lookup again, but do not - * run enter traces on the newly found cmdPtr. - */ - if (cmdEpoch != newEpoch) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + + /* + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. + */ + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } + } *cmdPtrPtr = cmdPtr; } -- cgit v0.12 From 107aa17d8d2388a56f1fd3374e8b49b135e1ae41 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 20 Aug 2013 14:00:05 +0000 Subject: Push out a trial patch for more eyes to see. --- generic/tclBasic.c | 22 ++++++++++++++++++++++ 1 file changed, 22 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 020f2f2..ca49bec 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -161,6 +161,8 @@ static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc Dispatch; + static Tcl_ObjCmdProc NRCoroInjectObjCmd; MODULE_SCOPE const TclStubs tclStubs; @@ -4234,6 +4236,9 @@ TclNREvalObjv( *cmdPtrPtr = cmdPtr; cmdPtr->refCount++; + TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); + return TCL_OK; + /* * Find the objProc to call: nreProc if available, objProc otherwise. Push * a callback to do the actual running. @@ -4252,6 +4257,23 @@ TclNREvalObjv( } } +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = data[0]; + int objc = PTR2INT(data[1]); + Tcl_Obj **objv = data[2]; + + if (cmdPtr->nreProc) { + return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); + } else { + return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); + } +} + int TclNRRunCallbacks( Tcl_Interp *interp, -- cgit v0.12 From 3f61f168eb9d98c28312cdea25b214827c3692f2 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 21 Aug 2013 10:25:18 +0000 Subject: [3612422]: Refer to correct part of tclvars(n) rather than page itself. --- doc/AddErrInfo.3 | 12 ++++++------ doc/CrtInterp.3 | 7 ++++--- doc/Environment.3 | 2 +- doc/bgerror.n | 5 ++++- doc/binary.n | 2 +- doc/catch.n | 3 ++- doc/eval.n | 3 ++- doc/info.n | 12 ++++++------ doc/library.n | 10 +++++++--- doc/return.n | 4 ++-- doc/tclsh.1 | 8 +++++--- doc/throw.n | 2 +- 12 files changed, 41 insertions(+), 29 deletions(-) diff --git a/doc/AddErrInfo.3 b/doc/AddErrInfo.3 index b9c6a63..36f6a20 100644 --- a/doc/AddErrInfo.3 +++ b/doc/AddErrInfo.3 @@ -176,16 +176,16 @@ these return options. The \fB\-errorinfo\fR option holds a stack trace of the operations that were in progress when an error occurred, and is intended to be human-readable. -The \fB\-errorcode\fR option holds a list of items that +The \fB\-errorcode\fR option holds a Tcl list of items that are intended to be machine-readable. The first item in the \fB\-errorcode\fR value identifies the class of error that occurred -(e.g. POSIX means an error occurred in a POSIX system call) +(e.g., POSIX means an error occurred in a POSIX system call) and additional elements hold additional pieces of information that depend on the class. -See the \fBtclvars\fR manual entry for details on the various -formats for the \fB\-errorcode\fR option used by -Tcl's built-in commands. +See the manual entry on the \fBerrorCode\fR variable for details on the +various formats for the \fB\-errorcode\fR option used by Tcl's built-in +commands. .PP The \fB\-errorinfo\fR option value is gradually built up as an error unwinds through the nested operations. @@ -307,6 +307,6 @@ so they continue to hold a record of information about the most recent error seen in an interpreter. .SH "SEE ALSO" Tcl_DecrRefCount(3), Tcl_IncrRefCount(3), Tcl_Interp(3), Tcl_ResetResult(3), -Tcl_SetErrno(3), tclvars(n) +Tcl_SetErrno(3), errorCode(n), errorInfo(n) .SH KEYWORDS error, value, value result, stack, trace, variable diff --git a/doc/CrtInterp.3 b/doc/CrtInterp.3 index a248cf4..1156a20 100644 --- a/doc/CrtInterp.3 +++ b/doc/CrtInterp.3 @@ -41,8 +41,9 @@ may only be passed to Tcl routines called from the same thread as the original \fBTcl_CreateInterp\fR call. It is not safe for multiple threads to pass the same token to Tcl's routines. The new interpreter is initialized with the built-in Tcl commands -and with the variables documented in the \fBtclvars\fR manual page. To bind in -additional commands, call \fBTcl_CreateCommand\fR. +and with standard variables like \fBtcl_platform\fR and \fBenv\fR. To +bind in additional commands, call \fBTcl_CreateCommand\fR, and to +create additional variables, call \fBTcl_SetVar\fR. .PP \fBTcl_DeleteInterp\fR marks an interpreter as deleted; the interpreter will eventually be deleted when all calls to \fBTcl_Preserve\fR for it have @@ -144,6 +145,6 @@ should be used to determine when an interpreter is a candidate for deletion due to inactivity. .VE 8.6 .SH "SEE ALSO" -Tcl_Preserve(3), Tcl_Release(3), tclvars(n) +Tcl_Preserve(3), Tcl_Release(3) .SH KEYWORDS command, create, delete, interpreter diff --git a/doc/Environment.3 b/doc/Environment.3 index 3753f43..46262ab 100644 --- a/doc/Environment.3 +++ b/doc/Environment.3 @@ -33,6 +33,6 @@ Tcl-based applications using \fBputenv\fR should redefine it to \fBTcl_PutEnv\fR so that they will interface properly to the Tcl runtime. .SH "SEE ALSO" -tclvars(n) +env(n) .SH KEYWORDS environment, variable diff --git a/doc/bgerror.n b/doc/bgerror.n index ac53eca..16a23a3 100644 --- a/doc/bgerror.n +++ b/doc/bgerror.n @@ -85,6 +85,9 @@ proc bgerror {message} { } .CE .SH "SEE ALSO" -after(n), interp(n), tclvars(n) +after(n), errorCode(n), errorInfo(n), interp(n) .SH KEYWORDS background error, reporting +'\" Local Variables: +'\" mode: nroff +'\" End: diff --git a/doc/binary.n b/doc/binary.n index 68bf9cc..a40afe6 100644 --- a/doc/binary.n +++ b/doc/binary.n @@ -884,7 +884,7 @@ close $f puts [\fBbinary encode\fR base64 \-maxlen 64 $data] .CE .SH "SEE ALSO" -format(n), scan(n), tclvars(n) +format(n), scan(n), tcl_platform(n) .SH KEYWORDS binary, format, scan '\" Local Variables: diff --git a/doc/catch.n b/doc/catch.n index a05ca71..9597ccf 100644 --- a/doc/catch.n +++ b/doc/catch.n @@ -115,7 +115,8 @@ if { [\fBcatch\fR {open $someFile w} fid] } { There are more complex examples of \fBcatch\fR usage in the documentation for the \fBreturn\fR command. .SH "SEE ALSO" -break(n), continue(n), dict(n), error(n), info(n), return(n), tclvars(n) +break(n), continue(n), dict(n), error(n), errorCode(n), errorInfo(n), info(n), +return(n) .SH KEYWORDS catch, error, exception '\" Local Variables: diff --git a/doc/eval.n b/doc/eval.n index da88757..13b54be 100644 --- a/doc/eval.n +++ b/doc/eval.n @@ -75,7 +75,8 @@ However, the last line would now normally be written without set var [linsert $var 0 {*}$args] .CE .SH "SEE ALSO" -catch(n), concat(n), error(n), interp(n), list(n), namespace(n), subst(n), tclvars(n), uplevel(n) +catch(n), concat(n), error(n), errorCode(n), errorInfo(n), interp(n), list(n), +namespace(n), subst(n), uplevel(n) .SH KEYWORDS concatenate, evaluate, script '\" Local Variables: diff --git a/doc/info.n b/doc/info.n index e65a083..14a9e50 100644 --- a/doc/info.n +++ b/doc/info.n @@ -296,7 +296,6 @@ Returns the name of the library directory in which standard Tcl scripts are stored. This is actually the value of the \fBtcl_library\fR variable and may be changed by setting \fBtcl_library\fR. -See the \fBtclvars\fR manual entry for more information. .TP \fBinfo loaded \fR?\fIinterp\fR? . @@ -336,8 +335,8 @@ described in \fBOBJECT INTROSPECTION\fR below. .TP \fBinfo patchlevel\fR . -Returns the value of the global variable \fBtcl_patchLevel\fR; see -the \fBtclvars\fR manual entry for more information. +Returns the value of the global variable \fBtcl_patchLevel\fR, which holds +the exact version of the Tcl library by default. .TP \fBinfo procs \fR?\fIpattern\fR? . @@ -374,8 +373,8 @@ string is returned. .TP \fBinfo tclversion\fR . -Returns the value of the global variable \fBtcl_version\fR; see -the \fBtclvars\fR manual entry for more information. +Returns the value of the global variable \fBtcl_version\fR, which holds the +major and minor version of the Tcl library by default. .TP \fBinfo vars\fR ?\fIpattern\fR? . @@ -763,8 +762,9 @@ proc getDef {obj method} { .VE 8.6 .SH "SEE ALSO" .VS 8.6 -global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n) +global(n), oo::class(n), oo::define(n), oo::object(n), proc(n), self(n), .VE 8.6 +tcl_library(n), tcl_patchLevel(n), tcl_version(n) .SH KEYWORDS command, information, interpreter, introspection, level, namespace, .VS 8.6 diff --git a/doc/library.n b/doc/library.n index 2413692..98dcb35 100644 --- a/doc/library.n +++ b/doc/library.n @@ -262,13 +262,17 @@ If set to any value, then \fBunknown\fR will not attempt to auto-load any commands. .TP \fBauto_path\fR +. If set, then it must contain a valid Tcl list giving directories to -search during auto-load operations. +search during auto-load operations (including for package index +files when using the default \fBpackage unknown\fR handler). This variable is initialized during startup to contain, in order: the directories listed in the \fBTCLLIBPATH\fR environment variable, -the directory named by the \fBtcl_library\fR variable, +the directory named by the \fBtcl_library\fR global variable, the parent directory of \fBtcl_library\fR, the directories listed in the \fBtcl_pkgPath\fR variable. +Additional locations to look for files and package indices should +normally be added to this variable using \fBlappend\fR. .TP \fBenv(TCL_LIBRARY)\fR If set, then it specifies the location of the directory containing @@ -306,7 +310,7 @@ considered to be a word character. On Windows platforms, words are comprised of any character that is not a space, tab, or newline. Under Unix, words are comprised of numbers, letters or underscores. .SH "SEE ALSO" -info(n), re_syntax(n), tclvars(n) +env(n), info(n), re_syntax(n) .SH KEYWORDS auto-exec, auto-load, library, unknown, word, whitespace '\"Local Variables: diff --git a/doc/return.n b/doc/return.n index b59a93d..a1abccf 100644 --- a/doc/return.n +++ b/doc/return.n @@ -317,8 +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), throw(n), try(n) +break(n), catch(n), continue(n), dict(n), error(n), errorCode(n), +errorInfo(n), proc(n), source(n), throw(n), try(n) .SH KEYWORDS break, catch, continue, error, exception, procedure, result, return .\" Local Variables: diff --git a/doc/tclsh.1 b/doc/tclsh.1 index 8e7fb9e..dfc2635 100644 --- a/doc/tclsh.1 +++ b/doc/tclsh.1 @@ -102,7 +102,9 @@ but also the disadvantage of making it harder to write scripts that start up uniformly across different versions of Tcl. .SH "VARIABLES" .PP -\fBTclsh\fR sets the following Tcl variables: +\fBTclsh\fR sets the following global Tcl variables in addition to those +created by the Tcl library itself (such as \fBenv\fR, which maps +environment variables such as \fBPATH\fR into Tcl): .TP 15 \fBargc\fR . @@ -129,7 +131,7 @@ device), 0 otherwise. When \fBtclsh\fR is invoked interactively it normally prompts for each command with .QW "\fB% \fR" . -You can change the prompt by setting the +You can change the prompt by setting the global variables \fBtcl_prompt1\fR and \fBtcl_prompt2\fR. If variable \fBtcl_prompt1\fR exists then it must consist of a Tcl script to output a prompt; instead of outputting a prompt \fBtclsh\fR @@ -142,6 +144,6 @@ incomplete commands. .PP See \fBTcl_StandardChannels\fR for more explanations. .SH "SEE ALSO" -encoding(n), fconfigure(n), tclvars(n) +auto_path(n), encoding(n), env(n), fconfigure(n) .SH KEYWORDS application, argument, interpreter, prompt, script file, shell diff --git a/doc/throw.n b/doc/throw.n index d49fb24..b28f2e4 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), tclvars(n), try(n) +catch(n), error(n), errorCode(n), errorInfo(n), return(n), try(n) .SH "KEYWORDS" error, exception '\" Local Variables: -- cgit v0.12 From b9100f680a4f29439312a01ce54c8340b5d53374 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 18:27:23 +0000 Subject: Don't use automatic storage to hold the invocation words of oo::define. That practice doesn't agree with NRE execution. --- generic/tclOOBasic.c | 13 ++++++++----- 1 file changed, 8 insertions(+), 5 deletions(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index f8cd1a4..073abab 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -88,7 +88,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj *invoke[3]; + Tcl_Obj **invoke = ckalloc(3 * sizeof(Tcl_Obj *)); if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -115,7 +115,7 @@ TclOO_Class_Constructor( Tcl_IncrRefCount(invoke[1]); Tcl_IncrRefCount(invoke[2]); TclNRAddCallback(interp, DecrRefsPostClassConstructor, - invoke[0], invoke[1], invoke[2], NULL); + invoke, NULL, NULL, NULL); /* * Tricky point: do not want the extra reported level in the Tcl stack @@ -131,9 +131,12 @@ DecrRefsPostClassConstructor( Tcl_Interp *interp, int result) { - TclDecrRefCount((Tcl_Obj *) data[0]); - TclDecrRefCount((Tcl_Obj *) data[1]); - TclDecrRefCount((Tcl_Obj *) data[2]); + Tcl_Obj **invoke = data[0]; + + TclDecrRefCount(invoke[0]); + TclDecrRefCount(invoke[1]); + TclDecrRefCount(invoke[2]); + ckfree(invoke); return result; } -- cgit v0.12 From 88f6a82f096bab2c48289cf27f99c6f2df66da9b Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 19:00:17 +0000 Subject: Don't allocate memory until you know you're going to use it and arrange for it to be freed. Leak! --- generic/tclOOBasic.c | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index 073abab..aba06a5 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -88,7 +88,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj **invoke = ckalloc(3 * sizeof(Tcl_Obj *)); + Tcl_Obj **invoke; if (objc-1 > Tcl_ObjectContextSkippedArgs(context)) { Tcl_WrongNumArgs(interp, Tcl_ObjectContextSkippedArgs(context), objv, @@ -102,6 +102,7 @@ TclOO_Class_Constructor( * Delegate to [oo::define] to do the work. */ + invoke = ckalloc(3 * sizeof(Tcl_Obj *)); invoke[0] = oPtr->fPtr->defineName; invoke[1] = TclOOObjectName(interp, oPtr); invoke[2] = objv[objc-1]; -- cgit v0.12 From cb779b2f4466180ab1678cc0a9e38159704b7efd Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 21 Aug 2013 19:18:28 +0000 Subject: Tidy the code and add a test. --- generic/tclBasic.c | 39 --------------------------------------- tests/coroutine.test | 9 +++++++++ 2 files changed, 9 insertions(+), 39 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index ca49bec..c1032f9 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -133,9 +133,6 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); -#if 0 -static Tcl_NRPostProc NRRunObjProc; -#endif static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -160,7 +157,6 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; - static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; @@ -4238,23 +4234,6 @@ TclNREvalObjv( TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); return TCL_OK; - - /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. - */ - - if (cmdPtr->nreProc) { -#if 0 - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - return TCL_OK; -#else - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -#endif - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } } static int @@ -4350,24 +4329,6 @@ NRCommand( return result; } - -#if 0 -static int -NRRunObjProc( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - /* OPT: do not call? */ - - Command* cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); -} -#endif - /* *---------------------------------------------------------------------- diff --git a/tests/coroutine.test b/tests/coroutine.test index 1d9040b..faa5a42 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -609,6 +609,15 @@ test coroutine-7.3 {yielding between coroutines} -body { } -cleanup { catch {rename juggler ""} } -result {{{a b c d e} ::j1 {a b c d} ::j2 {a b c} ::j3 {a b} ::j1 a ::j2} {} {} {}} + +test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { + proc foo {a b} {catch yield; return 1} +} -cleanup { + rename foo {} +} -body { + coroutine demo lsort -command foo {a b} +} -result {b a} + # cleanup unset lambda -- cgit v0.12 From ff681132dc338549a4dc9fc52cdb33e2ea1ce37f Mon Sep 17 00:00:00 2001 From: dkf Date: Thu, 22 Aug 2013 08:07:33 +0000 Subject: Correction to documentation --- doc/Method.3 | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/doc/Method.3 b/doc/Method.3 index 43b3609..2537d5e 100644 --- a/doc/Method.3 +++ b/doc/Method.3 @@ -172,8 +172,9 @@ typedef struct { .PP The \fIversion\fR field allows for future expansion of the structure, and should always be declared equal to TCL_OO_METHOD_VERSION_CURRENT. The -\fIname\fR field provides a human-readable name for the type, and is reserved -for debugging. +\fIname\fR field provides a human-readable name for the type, and is the value +that is exposed via the \fBinfo class methodtype\fR and +\fBinfo object methodtype\fR Tcl commands. .PP The \fIcallProc\fR field gives a function that is called when the method is invoked; it must never be NULL. -- cgit v0.12 From 6bdb21a3a0573fcd1a3750d8f163f624d4e07a69 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 13:01:31 +0000 Subject: More coroutine tests. --- tests/coroutine.test | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index faa5a42..8a7fdf3 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -618,6 +618,21 @@ test coroutine-7.4 {Bug 8ff0cb9fe1} -setup { coroutine demo lsort -command foo {a b} } -result {b a} +test coroutine-7.5 {return codes} { + set result {} + foreach code {0 1 2 3 4 5} { + lappend result [catch {coroutine demo return -level 0 -code $code}] + } + set result +} {0 1 2 3 4 5} + +test coroutine-7.6 {Early yield crashes} { + proc foo args {} + trace add execution foo enter {catch yield} + coroutine demo foo + rename foo {} +} {} + # cleanup unset lambda -- cgit v0.12 From f8dfc60a3d144141a5b93a3b9326e162cbf5cdef Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 16:13:29 +0000 Subject: Remove assertion that is not true in some circumstances (--enable-dtrace). --- generic/tclExecute.c | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d066476..96004e2 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -8798,8 +8798,7 @@ TclGetSrcInfoForPc( &cfPtr->len, NULL, NULL); } - assert(cfPtr->cmd != NULL); - { + if (cfPtr->cmd != NULL) { /* * We now have the command. We can get the srcOffset back and from * there find the list of word locations for this command. -- cgit v0.12 From f12764701b58ae91225b1ce8311378ef722b7a00 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 20:21:15 +0000 Subject: Make Dispatch() the single point for calling a Tcl_ObjCmdProc, and attach the DTRACE machinery there (one place, not two). --- generic/tclBasic.c | 91 +++++++++++++++++++----------------------------------- 1 file changed, 32 insertions(+), 59 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index c1032f9..5371f31 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4196,6 +4196,31 @@ TclNREvalObjv( } } + /* + * Fix the original callback to point to the now known cmdPtr. Insure that + * the Command struct lives until the command returns. + */ + + *cmdPtrPtr = cmdPtr; + cmdPtr->refCount++; + + TclNRAddCallback(interp, Dispatch, + cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, + cmdPtr->objClientData, INT2PTR(objc), objv); + return TCL_OK; +} + +static int +Dispatch( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_ObjCmdProc *objProc = data[0]; + ClientData clientData = data[1]; + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; #ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { @@ -4216,41 +4241,17 @@ TclNREvalObjv( TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); TclDecrRefCount(info); } - if (TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) { + if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) + && objc) { TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); } - if (TCL_DTRACE_CMD_ENTRY_ENABLED()) { + if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, (Tcl_Obj **)(objv + 1)); } #endif /* USE_DTRACE */ - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - - TclNRAddCallback(interp, Dispatch, cmdPtr, INT2PTR(objc), objv, NULL); - return TCL_OK; -} - -static int -Dispatch( - ClientData data[], - Tcl_Interp *interp, - int result) -{ - Command *cmdPtr = data[0]; - int objc = PTR2INT(data[1]); - Tcl_Obj **objv = data[2]; - if (cmdPtr->nreProc) { - return cmdPtr->nreProc(cmdPtr->objClientData, interp, objc, objv); - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + return objProc(clientData, interp, objc, objv); } int @@ -7981,39 +7982,11 @@ Tcl_NRCallObjProc( int objc, Tcl_Obj *const objv[]) { - int result = TCL_OK; NRE_callback *rootPtr = TOP_CB(interp); -#ifdef USE_DTRACE - if (TCL_DTRACE_CMD_ARGS_ENABLED()) { - const char *a[10]; - int i = 0; - - while (i < 10) { - a[i] = i < objc ? TclGetString(objv[i]) : NULL; i++; - } - TCL_DTRACE_CMD_ARGS(a[0], a[1], a[2], a[3], a[4], a[5], a[6], a[7], - a[8], a[9]); - } - if (TCL_DTRACE_CMD_INFO_ENABLED() && ((Interp *) interp)->cmdFramePtr) { - Tcl_Obj *info = TclInfoFrame(interp, ((Interp *) interp)->cmdFramePtr); - const char *a[6]; int i[2]; - - TclDTraceInfo(info, a, i); - TCL_DTRACE_CMD_INFO(a[0], a[1], a[2], a[3], i[0], i[1], a[4], a[5]); - TclDecrRefCount(info); - } - if ((TCL_DTRACE_CMD_RETURN_ENABLED() || TCL_DTRACE_CMD_RESULT_ENABLED()) - && objc) { - TclNRAddCallback(interp, DTraceCmdReturn, objv[0], NULL, NULL, NULL); - } - if (TCL_DTRACE_CMD_ENTRY_ENABLED() && objc) { - TCL_DTRACE_CMD_ENTRY(TclGetString(objv[0]), objc - 1, - (Tcl_Obj **)(objv + 1)); - } -#endif /* USE_DTRACE */ - result = objProc(clientData, interp, objc, objv); - return TclNRRunCallbacks(interp, result, rootPtr); + TclNRAddCallback(interp, Dispatch, objProc, clientData, + INT2PTR(objc), objv); + return TclNRRunCallbacks(interp, TCL_OK, rootPtr); } /* -- cgit v0.12 From b3792d779d73852a163fd142bbb96acc46c98153 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 22 Aug 2013 20:34:30 +0000 Subject: compiler warning --- generic/tclBasic.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 5371f31..fc449cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4220,9 +4220,9 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; +#ifdef USE_DTRACE Interp *iPtr = (Interp *) interp; -#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; -- cgit v0.12 From c3b526dd8620621345e9c5ff0f72234cff838715 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Aug 2013 05:59:48 +0000 Subject: Remove complications that no longer server any required purpose. --- generic/tclBasic.c | 20 +------------------- 1 file changed, 1 insertion(+), 19 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index fc449cc..4d56f3a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4095,8 +4095,6 @@ TclNREvalObjv( Interp *iPtr = (Interp *) interp; int result; Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Command **cmdPtrPtr; - NRE_callback *callbackPtr; iPtr->lookupNsPtr = NULL; @@ -4111,13 +4109,10 @@ TclNREvalObjv( */ if (iPtr->deferredCallbacks) { - callbackPtr = iPtr->deferredCallbacks; iPtr->deferredCallbacks = NULL; } else { TclNRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); - callbackPtr = TOP_CB(interp); } - cmdPtrPtr = (Command **) &(callbackPtr->data[0]); iPtr->numLevels++; result = TclInterpReady(interp); @@ -4196,14 +4191,6 @@ TclNREvalObjv( } } - /* - * Fix the original callback to point to the now known cmdPtr. Insure that - * the Command struct lives until the command returns. - */ - - *cmdPtrPtr = cmdPtr; - cmdPtr->refCount++; - TclNRAddCallback(interp, Dispatch, cmdPtr->nreProc ? cmdPtr->nreProc : cmdPtr->objProc, cmdPtr->objClientData, INT2PTR(objc), objv); @@ -4297,13 +4284,8 @@ NRCommand( int result) { Interp *iPtr = (Interp *) interp; - Command *cmdPtr = data[0]; - /* int cmdStart = PTR2INT(data[1]); NOT USED HERE */ - if (cmdPtr) { - TclCleanupCommandMacro(cmdPtr); - } - ((Interp *)interp)->numLevels--; + iPtr->numLevels--; /* * If there is a tailcall, schedule it -- cgit v0.12 From 19fa970aea5f91d40bff7847090106710637151e Mon Sep 17 00:00:00 2001 From: mig Date: Fri, 23 Aug 2013 13:08:15 +0000 Subject: fix NRE docs --- doc/NRE.3 | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index 7ebeb39..a27a359 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -8,7 +8,8 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, +Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR @@ -207,7 +208,7 @@ is something like: .PP .CS int -\fITheCmdObjProc\fR( +\fITheCmdOldObjProc\fR( ClientData clientData, Tcl_Interp *interp, int objc, @@ -225,7 +226,7 @@ int return result; } \fBTcl_CreateObjCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, clientData, TheCmdDeleteProc); + \fITheCmdOldObjProc\fR, clientData, TheCmdDeleteProc); .CE .PP To enable a command like this one for trampoline-based evaluation, @@ -255,8 +256,8 @@ int int objc, Tcl_Obj *const objv[]) { - return \fBTcl_NRCallObjProc\fR(interp, name, - \fITheCmdNRObjProc\fR, clientData, objc, objv); + return \fBTcl_NRCallObjProc\fR(interp, \fITheCmdNRObjProc\fR, + clientData, objc, objv); } .CE .PP @@ -317,7 +318,7 @@ and the second is for use when there is already a trampoline in place. .PP .CS \fBTcl_NRCreateCommand\fR(interp, "theCommand", - \fITheCmdObjProc\fR, \fITheCmdNRObjProc\fR, clientData, + \fITheCmdNewObjProc\fR, \fITheCmdNRObjProc\fR, clientData, TheCmdDeleteProc); .CE .SH "SEE ALSO" -- cgit v0.12 From 0ae283a82593a1994e6ed6e5c7577603fa7f72bb Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 23 Aug 2013 16:23:47 +0000 Subject: Make sure all Tcl_NR*Eval*() routines do a schedule only. No errors raised. --- generic/tclBasic.c | 49 ++++++++++++++++++++++++++++++++----------------- 1 file changed, 32 insertions(+), 17 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 4d56f3a..96d74c4 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -157,6 +157,7 @@ static Tcl_NRPostProc TEOV_Exception; static Tcl_NRPostProc TEOV_NotFoundCallback; static Tcl_NRPostProc TEOV_RestoreVarFrame; static Tcl_NRPostProc TEOV_RunLeaveTraces; +static Tcl_NRPostProc EvalObjvCore; static Tcl_NRPostProc Dispatch; static Tcl_ObjCmdProc NRCoroInjectObjCmd; @@ -4093,16 +4094,8 @@ TclNREvalObjv( * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - - iPtr->lookupNsPtr = NULL; /* - * Push a callback with cleanup tasks for commands; the cmdPtr at data[0] - * will be filled later when the command is found: save its address at - * objProcPtr. - * * data[1] stores a marker for use by tailcalls; it will be set to 1 by * command redirectors (imports, alias, ensembles) so that tailcalls * finishes the source command and not just the target. @@ -4115,12 +4108,38 @@ TclNREvalObjv( } iPtr->numLevels++; - result = TclInterpReady(interp); + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} - if ((result != TCL_OK) || (objc == 0)) { - return result; +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Command *cmdPtr = data[0]; + int flags = PTR2INT(data[1]); + int objc = PTR2INT(data[2]); + Tcl_Obj **objv = data[3]; + Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = iPtr->lookupNsPtr; + + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; } + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + + iPtr->lookupNsPtr = NULL; + if (cmdPtr) { goto commandFound; } @@ -4164,11 +4183,6 @@ TclNREvalObjv( return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; - } - /* * Found a command! The real work begins now ... */ @@ -4207,9 +4221,9 @@ Dispatch( ClientData clientData = data[1]; int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; -#ifdef USE_DTRACE Interp *iPtr = (Interp *) interp; +#ifdef USE_DTRACE if (TCL_DTRACE_CMD_ARGS_ENABLED()) { const char *a[10]; int i = 0; @@ -4238,6 +4252,7 @@ Dispatch( } #endif /* USE_DTRACE */ + iPtr->cmdCount++; return objProc(clientData, interp, objc, objv); } -- cgit v0.12 From 8463ceabbba1e8736e395eda5a6f37428dc9c12c Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 24 Aug 2013 09:42:43 +0000 Subject: Unbreak doc; the apropos index entry *must* be one line. (This is an external constraint forced by the requirement to fit into the standard Unix manual system.) --- doc/NRE.3 | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/doc/NRE.3 b/doc/NRE.3 index a27a359..ce609e6 100644 --- a/doc/NRE.3 +++ b/doc/NRE.3 @@ -8,8 +8,7 @@ .TH NRE 3 8.6 Tcl "Tcl Library Procedures" .BS .SH NAME -Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, -Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. +Tcl_NRCreateCommand, Tcl_NRCallObjProc, Tcl_NREvalObj, Tcl_NREvalObjv, Tcl_NRCmdSwap, Tcl_NRExprObj, Tcl_NRAddCallback \- Non-Recursive (stackless) evaluation of Tcl scripts. .SH SYNOPSIS .nf \fB#include \fR -- cgit v0.12 From 9150a7225d0e28174587948bb96b6a11f70493dc Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 18:11:53 +0000 Subject: Add test for Bug 2486550. --- tests/coroutine.test | 9 +++++++++ 1 file changed, 9 insertions(+) diff --git a/tests/coroutine.test b/tests/coroutine.test index 8a7fdf3..03c63ad 100644 --- a/tests/coroutine.test +++ b/tests/coroutine.test @@ -633,6 +633,15 @@ test coroutine-7.6 {Early yield crashes} { rename foo {} } {} +test coroutine-7.7 {Bug 2486550} -setup { + interp hide {} yield +} -body { + coroutine demo interp invokehidden {} yield ok +} -cleanup { + demo + interp expose {} yield +} -result ok + # cleanup unset lambda -- cgit v0.12 From f300f251bd0a7b4aeb3ee2ad971c5b766629ed04 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:03:57 +0000 Subject: Inline TEOV_RunEnterTraces() so its interface can be redesigned. --- generic/tclBasic.c | 74 +++++++++++++++++++++++++++++++++++++++++++++++++++--- 1 file changed, 71 insertions(+), 3 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 82aa833..8407edb 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4197,9 +4197,77 @@ EvalObjvCore( * necessary. */ - result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr, weLookUp); + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + const char *command; + int length, deleted; + + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); + + Tcl_IncrRefCount(commandPtr); + command = Tcl_GetStringFromObj(commandPtr, &length); + + /* + * Call trace functions. + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the traces + * so that the structure doesn't go away underneath our feet. + */ + + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; + TclCleanupCommandMacro(cmdPtr); + + if (cmdEpoch != newEpoch) { + + /* + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. + */ + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } + } + } + + if (cmdPtr && (traceCode == TCL_OK)) { + /* + * Command was found: push a record to schedule the leave traces. + */ + + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } + result = traceCode; + if (result != TCL_OK) { return result; } -- cgit v0.12 From 7ddfa6aeb8f6eb66f66f4ae36b5ee59cc56524f6 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:06:08 +0000 Subject: Exceptions raised from enter traces take priority over re-resolution games. --- generic/tclBasic.c | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 8407edb..172c698 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4230,6 +4230,11 @@ EvalObjvCore( deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); + if (traceCode != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return traceCode; + } + if (cmdEpoch != newEpoch) { /* @@ -4255,7 +4260,7 @@ EvalObjvCore( } } - if (cmdPtr && (traceCode == TCL_OK)) { + if (cmdPtr) { /* * Command was found: push a record to schedule the leave traces. */ @@ -4266,11 +4271,6 @@ EvalObjvCore( } else { Tcl_DecrRefCount(commandPtr); } - result = traceCode; - - if (result != TCL_OK) { - return result; - } if (cmdPtr == NULL) { if (weLookUp) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); -- cgit v0.12 From 9ba19b667f4232117cc4abd68576dead47e19c10 Mon Sep 17 00:00:00 2001 From: dgp Date: Tue, 27 Aug 2013 20:25:15 +0000 Subject: Tidy up indenting for clarity in refactoring. --- generic/tclBasic.c | 123 +++++++++++++++++++++++++++-------------------------- 1 file changed, 62 insertions(+), 61 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 172c698..3f579d1 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4197,80 +4197,81 @@ EvalObjvCore( * necessary. */ - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; + int traceCode = TCL_OK; + int cmdEpoch = cmdPtr->cmdEpoch; + int newEpoch; + const char *command; + int length, deleted; - Tcl_Obj *commandPtr = TclGetSourceFromFrame( - flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv); + Tcl_Obj *commandPtr = TclGetSourceFromFrame( + flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, + objc, objv); - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); + Tcl_IncrRefCount(commandPtr); + command = Tcl_GetStringFromObj(commandPtr, &length); - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. - */ + /* + * Call trace functions. + * Execute any command or execution traces. Note that we bump up the + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. + */ - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; - TclCleanupCommandMacro(cmdPtr); + cmdPtr->refCount++; + if (iPtr->tracePtr) { + traceCode = TclCheckInterpTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { + traceCode = TclCheckExecutionTraces(interp, command, length, + cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); + } + newEpoch = cmdPtr->cmdEpoch; + deleted = cmdPtr->flags & CMD_IS_DELETED; + TclCleanupCommandMacro(cmdPtr); - if (traceCode != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return traceCode; - } + if (traceCode != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return traceCode; + } - if (cmdEpoch != newEpoch) { - - /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. - */ - if (weLookUp) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { + if (cmdEpoch != newEpoch) { /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. + * The traces did something to the traced command. How should + * we respond? + * + * If we got the trace command by looking up a command name, we + * should just look it up again. */ - if (deleted) { - cmdPtr = NULL; + if (weLookUp) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + } else { + + /* + * If we did not look up a command name, we got the cmdPtr + * from a caller. If that cmdPtr has been deleted, we need + * to avoid a crash. Otherwise, press on. We don't have + * any foundation to claim a better answer. + */ + if (deleted) { + cmdPtr = NULL; + } } } - } - if (cmdPtr) { - /* - * Command was found: push a record to schedule the leave traces. - */ + if (cmdPtr) { + /* + * Command was found: push a record to schedule the leave traces. + */ + + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); + cmdPtr->refCount++; + } else { + Tcl_DecrRefCount(commandPtr); + } - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } if (cmdPtr == NULL) { if (weLookUp) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); -- cgit v0.12 From 3aa655bce1d9e291450cc8bdfe5890058dcf1700 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Aug 2013 02:44:50 +0000 Subject: Clarfy and prettify influence of flag settings and command lookups. --- generic/tclBasic.c | 77 ++++++++++++++++++++++++++++-------------------------- 1 file changed, 40 insertions(+), 37 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 3f579d1..af747cd 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4121,13 +4121,21 @@ EvalObjvCore( Tcl_Interp *interp, int result) { - Command *cmdPtr = data[0]; + Command *cmdPtr = NULL, *preCmdPtr = data[0]; int flags = PTR2INT(data[1]); int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + + /* + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + */ + Namespace *lookupNsPtr = iPtr->lookupNsPtr; - int weLookUp = (cmdPtr == NULL); + iPtr->lookupNsPtr = NULL; if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; @@ -4141,8 +4149,6 @@ EvalObjvCore( return TCL_ERROR; } - iPtr->lookupNsPtr = NULL; - /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4152,45 +4158,43 @@ EvalObjvCore( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (!weLookUp) { - goto commandFound; - } - - /* - * Configure evaluation context to match the requested flags. - */ - - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (preCmdPtr) { + cmdPtr = preCmdPtr; } else { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules + * Configure evaluation context to match the requested flags. */ - iPtr->ensembleRewrite.sourceObjs = NULL; - } + if (lookupNsPtr) { + /* + * Do nothing. Caller gave us the lookup namespace. Use it. + * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + */ + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { - /* - * Lookup the command - */ + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); - } + iPtr->ensembleRewrite.sourceObjs = NULL; - /* - * Found a command! The real work begins now ... - */ + if (flags & TCL_EVAL_GLOBAL) { + /* TODO: Check we do this whenever needed. */ + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } + } + + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } + + } - commandFound: if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { /* * Call enter traces. They will schedule a call to the leave traces if @@ -4244,7 +4248,7 @@ EvalObjvCore( * If we got the trace command by looking up a command name, we * should just look it up again. */ - if (weLookUp) { + if (preCmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); } else { @@ -4273,7 +4277,7 @@ EvalObjvCore( } if (cmdPtr == NULL) { - if (weLookUp) { + if (preCmdPtr == NULL) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } /* Is this right??? */ @@ -4798,7 +4802,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; -- cgit v0.12 From 09922916778d4f09686dbdb94e6e4716ab9b8f59 Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 28 Aug 2013 18:05:07 +0000 Subject: Rework the re-resolution after enter traces machinery with cleaner separations and neater interfaces. --- generic/tclBasic.c | 214 +++++++++++++++++------------------------------------ 1 file changed, 69 insertions(+), 145 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index af747cd..bafb4c2 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -147,8 +147,7 @@ static int TEOV_NotFound(Tcl_Interp *interp, int objc, Tcl_Obj *const objv[], Namespace *lookupNsPtr); static int TEOV_RunEnterTraces(Tcl_Interp *interp, Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], Namespace *lookupNsPtr, - int weLookUp); + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -4126,6 +4125,7 @@ EvalObjvCore( int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + int enterTracesDone = 0; /* * Capture the namespace we should do command name resolution in, as @@ -4152,137 +4152,100 @@ EvalObjvCore( /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). + * TODO: Consider moving this up. */ if (!(flags & TCL_EVAL_NOERR)) { TEOV_PushExceptionHandlers(interp, objc, objv, flags); } - if (preCmdPtr) { - cmdPtr = preCmdPtr; - } else { + /* + * Configure evaluation context to match the requested flags. + */ + if (lookupNsPtr) { /* - * Configure evaluation context to match the requested flags. + * Do nothing. Caller gave us the lookup namespace. Use it. + * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + * TODO: Is that a bug? */ + } else if (flags & TCL_EVAL_INVOKE) { + lookupNsPtr = iPtr->globalNsPtr; + } else { - if (lookupNsPtr) { - /* - * Do nothing. Caller gave us the lookup namespace. Use it. - * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. - */ - } else if (flags & TCL_EVAL_INVOKE) { - lookupNsPtr = iPtr->globalNsPtr; - } else { - - /* - * TCL_EVAL_INVOKE was not set: clear rewrite rules - */ + /* + * TCL_EVAL_INVOKE was not set: clear rewrite rules + */ - iPtr->ensembleRewrite.sourceObjs = NULL; + iPtr->ensembleRewrite.sourceObjs = NULL; - if (flags & TCL_EVAL_GLOBAL) { - /* TODO: Check we do this whenever needed. */ - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; } + } + reresolve: + if (preCmdPtr) { + if (preCmdPtr->flags & CMD_IS_DELETED) { + Tcl_SetObjResult(interp, Tcl_ObjPrintf( + "attempt to invoke a deleted command")); + Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); + return TCL_ERROR; + } + cmdPtr = preCmdPtr; + } else { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); } - } - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. - */ - - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { Tcl_Obj *commandPtr = TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, objc, objv); - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); - /* - * Call trace functions. - * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the - * traces so that the structure doesn't go away underneath our feet. - */ + if (!enterTracesDone) { - cmdPtr->refCount++; - if (iPtr->tracePtr) { - traceCode = TclCheckInterpTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - if ((cmdPtr->flags & CMD_HAS_EXEC_TRACES) && (traceCode == TCL_OK)) { - traceCode = TclCheckExecutionTraces(interp, command, length, - cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); - } - newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; - TclCleanupCommandMacro(cmdPtr); - - if (traceCode != TCL_OK) { - Tcl_DecrRefCount(commandPtr); - return traceCode; - } - - if (cmdEpoch != newEpoch) { + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. + * Send any exception from enter traces back as an exception + * raised by the traced command. */ - if (preCmdPtr == NULL) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { - /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. - */ - if (deleted) { - cmdPtr = NULL; - } + if (code != TCL_OK) { + Tcl_DecrRefCount(commandPtr); + return code; } - } - if (cmdPtr) { /* - * Command was found: push a record to schedule the leave traces. + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. */ - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); - } - - if (cmdPtr == NULL) { - if (preCmdPtr == NULL) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; } - /* Is this right??? */ - return TCL_OK; } + + /* + * Schedule leave traces. Raise the refCount on the resolved + * cmdPtr, so that when it passes to the leave traces we know + * it's still valid. + */ + + cmdPtr->refCount++; + TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), + commandPtr, cmdPtr, objv); } TclNRAddCallback(interp, Dispatch, @@ -4672,26 +4635,19 @@ TEOV_RunEnterTraces( Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr, - int weLookUp) + Tcl_Obj *const objv[]) { Interp *iPtr = (Interp *) interp; Command *cmdPtr = *cmdPtrPtr; - int traceCode = TCL_OK; - int cmdEpoch = cmdPtr->cmdEpoch; - int newEpoch; - const char *command; - int length, deleted; - - Tcl_IncrRefCount(commandPtr); - command = Tcl_GetStringFromObj(commandPtr, &length); + int newEpoch, cmdEpoch = cmdPtr->cmdEpoch; + int length, traceCode = TCL_OK; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); /* * Call trace functions. * Execute any command or execution traces. Note that we bump up the - * command's reference count for the duration of the calling of the traces - * so that the structure doesn't go away underneath our feet. + * command's reference count for the duration of the calling of the + * traces so that the structure doesn't go away underneath our feet. */ cmdPtr->refCount++; @@ -4704,47 +4660,15 @@ TEOV_RunEnterTraces( cmdPtr, TCL_OK, TCL_TRACE_ENTER_EXEC, objc, objv); } newEpoch = cmdPtr->cmdEpoch; - deleted = cmdPtr->flags & CMD_IS_DELETED; TclCleanupCommandMacro(cmdPtr); - if (cmdEpoch != newEpoch) { - - /* - * The traces did something to the traced command. How should - * we respond? - * - * If we got the trace command by looking up a command name, we - * should just look it up again. - */ - if (weLookUp) { - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - } else { - - /* - * If we did not look up a command name, we got the cmdPtr - * from a caller. If that cmdPtr has been deleted, we need - * to avoid a crash. Otherwise, press on. We don't have - * any foundation to claim a better answer. - */ - if (deleted) { - cmdPtr = NULL; - } - } - *cmdPtrPtr = cmdPtr; + if (traceCode != TCL_OK) { + return traceCode; } - - if (cmdPtr && (traceCode == TCL_OK)) { - /* - * Command was found: push a record to schedule the leave traces. - */ - - TclNRAddCallback(interp, TEOV_RunLeaveTraces, INT2PTR(objc), - commandPtr, cmdPtr, objv); - cmdPtr->refCount++; - } else { - Tcl_DecrRefCount(commandPtr); + if (cmdEpoch != newEpoch) { + *cmdPtrPtr = NULL; } - return traceCode; + return TCL_OK; } static int -- cgit v0.12 From 012f63b012e81a2c53f6fef7a69cf7672d630a94 Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 29 Aug 2013 17:59:36 +0000 Subject: New internal eval flag value so that all TclNREvalObjv() callers that pre-resolve command names can choose whether or not TclNREvalObjv() should attempt to re-do the resolution from objv[0] when something goes wrong. --- generic/tclBasic.c | 75 ++++++++++++++++++++++++++++++++++-------------------- generic/tclInt.h | 1 + 2 files changed, 49 insertions(+), 27 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index bafb4c2..884b5cc 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4125,18 +4125,18 @@ EvalObjvCore( int objc = PTR2INT(data[2]); Tcl_Obj **objv = data[3]; Interp *iPtr = (Interp *) interp; + Namespace *lookupNsPtr = NULL; int enterTracesDone = 0; - + /* - * Capture the namespace we should do command name resolution in, as - * instructed by our caller sneaking it in to us in a private interp - * field. Clear that field right away so we cannot possibly have its - * use leak where it should not. The sneaky message pass is done. + * Push records for task to be done on return, in INVERSE order. First, if + * needed, the exception handlers (as they should happen last). */ - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - iPtr->lookupNsPtr = NULL; - + if (!(flags & TCL_EVAL_NOERR)) { + TEOV_PushExceptionHandlers(interp, objc, objv, flags); + } + if (TCL_OK != TclInterpReady(interp)) { return TCL_ERROR; } @@ -4150,25 +4150,23 @@ EvalObjvCore( } /* - * Push records for task to be done on return, in INVERSE order. First, if - * needed, the exception handlers (as they should happen last). - * TODO: Consider moving this up. - */ - - if (!(flags & TCL_EVAL_NOERR)) { - TEOV_PushExceptionHandlers(interp, objc, objv, flags); - } - - /* * Configure evaluation context to match the requested flags. */ - if (lookupNsPtr) { + if (iPtr->lookupNsPtr) { + /* - * Do nothing. Caller gave us the lookup namespace. Use it. - * Overrides TCL_EVAL_GLOBAL. For both lookup and eval. + * Capture the namespace we should do command name resolution in, as + * instructed by our caller sneaking it in to us in a private interp + * field. Clear that field right away so we cannot possibly have its + * use leak where it should not. The sneaky message pass is done. + * + * Use of this mechanism overrides the TCL_EVAL_GLOBAL flag. * TODO: Is that a bug? */ + + lookupNsPtr = iPtr->lookupNsPtr; + iPtr->lookupNsPtr = NULL; } else if (flags & TCL_EVAL_INVOKE) { lookupNsPtr = iPtr->globalNsPtr; } else { @@ -4185,16 +4183,29 @@ EvalObjvCore( } } + /* + * Lookup the Command to dispatch. + */ + reresolve: + assert(cmdPtr == NULL); if (preCmdPtr) { - if (preCmdPtr->flags & CMD_IS_DELETED) { + /* Caller gave it to us */ + if (!(preCmdPtr->flags & CMD_IS_DELETED)) { + /* So long as it exists, use it. */ + cmdPtr = preCmdPtr; + } else if (flags & TCL_EVAL_NORESOLVE) { + /* + * When it's been deleted, and we're told not to attempt + * resolving it ourselves, all we can do is raise an error. + */ Tcl_SetObjResult(interp, Tcl_ObjPrintf( "attempt to invoke a deleted command")); Tcl_SetErrorCode(interp, "TCL", "EVAL", "DELETEDCOMMAND", NULL); return TCL_ERROR; } - cmdPtr = preCmdPtr; - } else { + } + if (cmdPtr == NULL) { cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); if (!cmdPtr) { return TEOV_NotFound(interp, objc, objv, lookupNsPtr); @@ -4217,6 +4228,11 @@ EvalObjvCore( /* * Send any exception from enter traces back as an exception * raised by the traced command. + * TODO: Is this a bug? Letting an execution trace BREAK or + * CONTINUE or RETURN in the place of the traced command? + * Would either converting all exceptions to TCL_ERROR, or + * just swallowing them be better? (Swallowing them has the + * problem of permanently hiding program errors.) */ if (code != TCL_OK) { @@ -6524,9 +6540,14 @@ TclNRInvoke( /* Avoid the exception-handling brain damage when numLevels == 0 . */ iPtr->numLevels++; Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); - - /* TODO: how to get re-resolution right */ - return TclNREvalObjv(interp, objc, objv, 0, cmdPtr); + + /* + * Normal command resolution of objv[0] isn't going to find cmdPtr. + * That's the whole point of **hidden** commands. So tell the + * Eval core machinery not to even try (and risk finding something wrong). + */ + + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, cmdPtr); } static int diff --git a/generic/tclInt.h b/generic/tclInt.h index e0e694f..380284f 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -2201,6 +2201,7 @@ typedef struct Interp { #define TCL_ALLOW_EXCEPTIONS 0x04 #define TCL_EVAL_FILE 0x02 #define TCL_EVAL_SOURCE_IN_FRAME 0x10 +#define TCL_EVAL_NORESOLVE 0x20 /* * Flag bits for Interp structures: -- cgit v0.12 From 1d512f82013b5c80636c8522357aabe3b429f143 Mon Sep 17 00:00:00 2001 From: dgp Date: Fri, 30 Aug 2013 21:57:26 +0000 Subject: Bump to tcltest 2.3.6 to account for changes since Tcl 8.6.0 release. --- library/tcltest/pkgIndex.tcl | 2 +- library/tcltest/tcltest.tcl | 2 +- unix/Makefile.in | 4 ++-- win/Makefile.in | 4 ++-- 4 files changed, 6 insertions(+), 6 deletions(-) diff --git a/library/tcltest/pkgIndex.tcl b/library/tcltest/pkgIndex.tcl index 4b0a9bc..60a9485 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.5 [list source [file join $dir tcltest.tcl]] +package ifneeded tcltest 2.3.6 [list source [file join $dir tcltest.tcl]] diff --git a/library/tcltest/tcltest.tcl b/library/tcltest/tcltest.tcl index d6e6487..c30d2e4 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.5 + variable Version 2.3.6 # Compatibility support for dumb variables defined in tcltest 1 # Do not use these. Call [package provide Tcl] and [info patchlevel] diff --git a/unix/Makefile.in b/unix/Makefile.in index 443e70d..505f7e0 100644 --- a/unix/Makefile.in +++ b/unix/Makefile.in @@ -850,8 +850,8 @@ install-libraries: libraries done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/msgcat/msgcat.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(INSTALL_DATA) $(TOP_DIR)/library/tcltest/tcltest.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(INSTALL_DATA) $(TOP_DIR)/library/platform/platform.tcl "$(SCRIPT_INSTALL_DIR)"/../tcl8/8.4/platform-1.0.12.tm; diff --git a/win/Makefile.in b/win/Makefile.in index 47f3fdd..5109e7a 100644 --- a/win/Makefile.in +++ b/win/Makefile.in @@ -650,8 +650,8 @@ install-libraries: libraries install-tzdata install-msgs done; @echo "Installing package msgcat 1.5.2 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/msgcat/msgcat.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/msgcat-1.5.2.tm; - @echo "Installing package tcltest 2.3.5 as a Tcl Module"; - @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.5.tm; + @echo "Installing package tcltest 2.3.6 as a Tcl Module"; + @$(COPY) $(ROOT_DIR)/library/tcltest/tcltest.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.5/tcltest-2.3.6.tm; @echo "Installing package platform 1.0.12 as a Tcl Module"; @$(COPY) $(ROOT_DIR)/library/platform/platform.tcl $(SCRIPT_INSTALL_DIR)/../tcl8/8.4/platform-1.0.12.tm; @echo "Installing package platform::shell 1.1.4 as a Tcl Module"; -- cgit v0.12 From 0576e11ae0dee27fb806110d84024c8aff28f941 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 1 Sep 2013 20:08:50 +0000 Subject: [b98fa55285]: Fix handling of whitespace at end of hex strings to decode. --- ChangeLog | 6 ++++++ generic/tclBinary.c | 43 +++++++++++++++++++++++-------------------- tests/binary.test | 28 ++++++++++++++++++++++++++++ 3 files changed, 57 insertions(+), 20 deletions(-) diff --git a/ChangeLog b/ChangeLog index ddde893..e0b623b 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,3 +1,9 @@ +2013-09-01 Donal Fellows + + * generic/tclBinary.c (BinaryDecodeHex): [Bug b98fa55285]: Ensure that + whitespace at the end of a string don't cause the decoder to drop the + last decoded byte. + 2013-08-03 Donal Fellows * library/auto.tcl: [Patch 3611643]: Allow TclOO classes to be found diff --git a/generic/tclBinary.c b/generic/tclBinary.c index 901237b..7625d39 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -2386,29 +2386,32 @@ BinaryDecodeHex( while (data < dataend) { value = 0; for (i=0 ; i<2 ; i++) { - if (data < dataend) { - c = *data++; - - if (!isxdigit((int) c)) { - if (strict || !isspace(c)) { - goto badChar; - } - i--; - continue; - } + if (data >= dataend) { value <<= 4; - c -= '0'; - if (c > 9) { - c += ('0' - 'A') + 10; - } - if (c > 16) { - c += ('A' - 'a'); + break; + } + + c = *data++; + if (!isxdigit((int) c)) { + if (strict || !isspace(c)) { + goto badChar; } - value |= (c & 0xf); - } else { - value <<= 4; - cut++; + i--; + continue; } + + value <<= 4; + c -= '0'; + if (c > 9) { + c += ('0' - 'A') + 10; + } + if (c > 16) { + c += ('A' - 'a'); + } + value |= (c & 0xf); + } + if (i < 2) { + cut++; } *cursor++ = UCHAR(value); value = 0; diff --git a/tests/binary.test b/tests/binary.test index 4393245..d424837 100644 --- a/tests/binary.test +++ b/tests/binary.test @@ -2499,6 +2499,34 @@ test binary-71.9 {binary decode hex} -body { test binary-71.10 {binary decode hex} -body { string length [binary decode hex " "] } -result 0 +test binary-71.11 {binary decode hex: Bug b98fa55285} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c26\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {29 38} +test binary-71.12 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.13 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} +test binary-71.14 {binary decode hex: Bug b98fa55285 cross check} -body { + apply {{} { + set str "137b6f95e7519389e7c4b36599781e2ccf492699649249aae43fbe8c2\n\n\n" + set decoded [binary decode hex $str] + list [string length $decoded] [scan [string index $decoded end] %c] + }} +} -result {28 140} test binary-72.1 {binary encode base64} -body { binary encode base64 -- cgit v0.12 From 5441277b9a31d73e4d91383584882c9303e5c758 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Mon, 2 Sep 2013 14:01:00 +0000 Subject: typo --- tests/zlib.test | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/tests/zlib.test b/tests/zlib.test index c469eea..2ea185f 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -233,7 +233,7 @@ test zlib-8.7 {transformation and fconfigure} -setup { # Dictionary is that which is proposed _in_ SPDY draft set spdyHeaders "HTTP/1.0 200 OK\r\nContent-Type: text/html; charset=utf-8\r\nX-Robots-Tag: noarchive\r\nLast-Modified: Tue, 05 Jun 2012 02:43:25 GMT\r\nETag: \"1338864205129|#public|0|en|||0\"\r\nExpires: Tue, 05 Jun 2012 16:17:11 GMT\r\nDate: Tue, 05 Jun 2012 16:17:06 GMT\r\nCache-Control: public, max-age=5\r\nX-Content-Type-Options: nosniff\r\nX-XSS-Protection: 1; mode=block\r\nServer: GSE\r\n" set spdyDict "optionsgetheadpostputdeletetraceacceptaccept-charsetaccept-encodingaccept-languageauthorizationexpectfromhostif-modified-sinceif-matchif-none-matchif-rangeif-unmodifiedsincemax-forwardsproxy-authorizationrangerefererteuser-agent100101200201202203204205206300301302303304305306307400401402403404405406407408409410411412413414415416417500501502503504505accept-rangesageetaglocationproxy-authenticatepublicretry-afterservervarywarningwww-authenticateallowcontent-basecontent-encodingcache-controlconnectiondatetrailertransfer-encodingupgradeviawarningcontent-languagecontent-lengthcontent-locationcontent-md5content-rangecontent-typeetagexpireslast-modifiedset-cookieMondayTuesdayWednesdayThursdayFridaySaturdaySundayJanFebMarAprMayJunJulAugSepOctNovDecchunkedtext/htmlimage/pngimage/jpgimage/gifapplication/xmlapplication/xhtmltext/plainpublicmax-agecharset=iso-8859-1utf-8gzipdeflateHTTP/1.1statusversionurl" -test zlib-8.8 {transformtion and fconfigure} -setup { +test zlib-8.8 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push compress $outSide -dictionary $spdyDict @@ -250,7 +250,7 @@ test zlib-8.8 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {260 222 {need dictionary} {TCL ZLIB NEED_DICT 2381337010} 2381337010} -test zlib-8.9 {transformtion and fconfigure} -setup { +test zlib-8.9 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream decompress] } -constraints zlib -body { @@ -267,7 +267,7 @@ test zlib-8.9 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {3064818174 358 358} -test zlib-8.10 {transformtion and fconfigure} -setup { +test zlib-8.10 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide } -constraints zlib -body { zlib push deflate $outSide -dictionary $spdyDict @@ -284,7 +284,7 @@ test zlib-8.10 {transformtion and fconfigure} -setup { catch {close $outSide} catch {close $inSide} } -result {254 212 {data error} {TCL ZLIB DATA}} -test zlib-8.11 {transformtion and fconfigure} -setup { +test zlib-8.11 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream inflate] } -constraints zlib -body { @@ -300,7 +300,7 @@ test zlib-8.11 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.12 {transformtion and fconfigure} -setup { +test zlib-8.12 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -317,7 +317,7 @@ test zlib-8.12 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.13 {transformtion and fconfigure} -setup { +test zlib-8.13 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream compress] } -constraints zlib -body { @@ -334,7 +334,7 @@ test zlib-8.13 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358 3064818174} -test zlib-8.14 {transformtion and fconfigure} -setup { +test zlib-8.14 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { @@ -350,7 +350,7 @@ test zlib-8.14 {transformtion and fconfigure} -setup { catch {close $inSide} catch {$strm close} } -result {358 358} -test zlib-8.15 {transformtion and fconfigure} -setup { +test zlib-8.15 {transformation and fconfigure} -setup { lassign [chan pipe] inSide outSide set strm [zlib stream deflate] } -constraints zlib -body { -- cgit v0.12 From a01e0439ec88f4f83820d36da9ed018cc3b9ff00 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Sep 2013 17:59:42 +0000 Subject: [010f4162ef] First step of fix on stammering errorstack. errorstack fixed. errorinfo revision still under consideration. --- generic/tclBasic.c | 6 ++++++ 1 file changed, 6 insertions(+) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 884b5cc..e909a1a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4679,6 +4679,9 @@ TEOV_RunEnterTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + iPtr->flags |= ERR_ALREADY_LOGGED; + } return traceCode; } if (cmdEpoch != newEpoch) { @@ -4725,6 +4728,9 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { + if (traceCode == TCL_ERROR) { + iPtr->flags |= ERR_ALREADY_LOGGED; + } return traceCode; } return result; -- cgit v0.12 From bfee748b41a556c2c213d22b99ce12b156acb1d8 Mon Sep 17 00:00:00 2001 From: dgp Date: Mon, 2 Sep 2013 18:47:07 +0000 Subject: Add test and improve errorInfo. --- generic/tclBasic.c | 22 ++++++++++++++++------ tests/error.test | 10 ++++++++++ 2 files changed, 26 insertions(+), 6 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index e909a1a..a10a11a 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -4680,6 +4680,12 @@ TEOV_RunEnterTraces( if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (enter trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } return traceCode; @@ -4702,12 +4708,10 @@ TEOV_RunLeaveTraces( Tcl_Obj *commandPtr = data[1]; Command *cmdPtr = data[2]; Tcl_Obj **objv = data[3]; - + int length; + const char *command = Tcl_GetStringFromObj(commandPtr, &length); if (!(cmdPtr->flags & CMD_IS_DELETED)) { - int length; - const char *command = Tcl_GetStringFromObj(commandPtr, &length); - if (cmdPtr->flags & CMD_HAS_EXEC_TRACES){ traceCode = TclCheckExecutionTraces(interp, command, length, cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); @@ -4717,7 +4721,6 @@ TEOV_RunLeaveTraces( cmdPtr, result, TCL_TRACE_LEAVE_EXEC, objc, objv); } } - Tcl_DecrRefCount(commandPtr); /* * As cmdPtr is set, TclNRRunCallbacks is about to reduce the numlevels. @@ -4729,10 +4732,17 @@ TEOV_RunLeaveTraces( if (traceCode != TCL_OK) { if (traceCode == TCL_ERROR) { + Tcl_Obj *info; + + TclNewLiteralStringObj(info, "\n (leave trace on \""); + Tcl_AppendLimitedToObj(info, command, length, 55, "..."); + Tcl_AppendToObj(info, "\")", 2); + Tcl_AppendObjToErrorInfo(interp, info); iPtr->flags |= ERR_ALREADY_LOGGED; } - return traceCode; + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } diff --git a/tests/error.test b/tests/error.test index 06f8eca..0de644c 100644 --- a/tests/error.test +++ b/tests/error.test @@ -182,6 +182,16 @@ test error-4.7 {errorstack via options dict } -body { catch {f 12} m d dict get $d -errorstack } -match glob -result {INNER * CALL {g 1212} CALL {f 12} UP 1} +test error-4.8 {errorstack from exec traces} -body { + proc foo args {} + proc goo {} foo + trace add execution foo enter {error bar;#} + catch goo m d + dict get $d -errorstack +} -cleanup { + rename goo {}; rename foo {} + unset -nocomplain m d +} -result {INNER {error bar} CALL goo UP 1} # Errors in error command itself -- cgit v0.12 From 5e237c28521e9a2146369913d30a10b2712b9fc2 Mon Sep 17 00:00:00 2001 From: "jan.nijtmans" Date: Wed, 4 Sep 2013 07:22:45 +0000 Subject: Fix 3 trivial (possible) errors, discovered by covertity.com --- generic/tclUtil.c | 3 +-- unix/tclUnixFCmd.c | 4 ++-- unix/tclUnixSock.c | 2 ++ 3 files changed, 5 insertions(+), 4 deletions(-) diff --git a/generic/tclUtil.c b/generic/tclUtil.c index 27e2474..b089132 100644 --- a/generic/tclUtil.c +++ b/generic/tclUtil.c @@ -3580,10 +3580,9 @@ UpdateStringOfEndOffset( register Tcl_Obj *objPtr) { char buffer[TCL_INTEGER_SPACE + 5]; - register int len; + register int len = 3; memcpy(buffer, "end", 4); - len = sizeof("end") - 1; if (objPtr->internalRep.longValue != 0) { buffer[len++] = '-'; len += TclFormatInt(buffer+len, -(objPtr->internalRep.longValue)); diff --git a/unix/tclUnixFCmd.c b/unix/tclUnixFCmd.c index e27f78f..e270b6a 100644 --- a/unix/tclUnixFCmd.c +++ b/unix/tclUnixFCmd.c @@ -462,10 +462,10 @@ DoCopyFile( switch ((int) (statBufPtr->st_mode & S_IFMT)) { #ifndef DJGPP case S_IFLNK: { - char linkBuf[MAXPATHLEN]; + char linkBuf[MAXPATHLEN+1]; int length; - length = readlink(src, linkBuf, sizeof(linkBuf)); + length = readlink(src, linkBuf, MAXPATHLEN); /* INTL: Native. */ if (length == -1) { return TCL_ERROR; diff --git a/unix/tclUnixSock.c b/unix/tclUnixSock.c index 9c3d7eb..a6360c2 100644 --- a/unix/tclUnixSock.c +++ b/unix/tclUnixSock.c @@ -1358,6 +1358,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (port == 0 && chosenport == 0) { @@ -1380,6 +1381,7 @@ Tcl_OpenTcpServer( my_errno = errno; } close(sock); + sock = -1; continue; } if (statePtr == NULL) { -- cgit v0.12 From f16149f5a641a30843d2bb4e3dd2734e50ecbe14 Mon Sep 17 00:00:00 2001 From: dkf Date: Wed, 4 Sep 2013 09:36:22 +0000 Subject: [98c8b3ec12] Make test fail in less catastrophic manner. --- tests/zlib.test | 5 ++++- 1 file changed, 4 insertions(+), 1 deletion(-) diff --git a/tests/zlib.test b/tests/zlib.test index 2ea185f..0712929 100644 --- a/tests/zlib.test +++ b/tests/zlib.test @@ -276,7 +276,10 @@ test zlib-8.10 {transformation and fconfigure} -setup { puts -nonewline $outSide $spdyHeaders chan pop $outSide set compressed [read $inSide] - catch {zlib inflate $compressed} err opt + catch { + zlib inflate $compressed + throw UNREACHABLE "should be unreachable" + } err opt list [string length [zlib deflate $spdyHeaders]] \ [string length $compressed] \ $err [dict get $opt -errorcode] -- cgit v0.12 From 0a973a55fed4b9cba1558fc7c93d412665f7063c Mon Sep 17 00:00:00 2001 From: dgp Date: Wed, 4 Sep 2013 12:45:51 +0000 Subject: Cleaned up test command trying to make valgrind happy. --- generic/tclTest.c | 22 ++++++++++++++++++++-- 1 file changed, 20 insertions(+), 2 deletions(-) diff --git a/generic/tclTest.c b/generic/tclTest.c index 96973d7..f121d0d 100644 --- a/generic/tclTest.c +++ b/generic/tclTest.c @@ -4408,8 +4408,26 @@ TestseterrorcodeCmd( Tcl_SetResult(interp, "too many args", TCL_STATIC); return TCL_ERROR; } - Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], - argv[5], NULL); + switch (argc) { + case 1: + Tcl_SetErrorCode(interp, "NONE", NULL); + break; + case 2: + Tcl_SetErrorCode(interp, argv[1], NULL); + break; + case 3: + Tcl_SetErrorCode(interp, argv[1], argv[2], NULL); + break; + case 4: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], NULL); + break; + case 5: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], NULL); + break; + case 6: + Tcl_SetErrorCode(interp, argv[1], argv[2], argv[3], argv[4], + argv[5], NULL); + } return TCL_ERROR; } -- cgit v0.12 From 133768540d48de8f9bf0638fd9983178588bd18a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 12:45:11 +0000 Subject: Error in order of #include lines broke some windows builds. --- generic/tclParse.c | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/generic/tclParse.c b/generic/tclParse.c index c5cb1d1..ee0d4c4 100644 --- a/generic/tclParse.c +++ b/generic/tclParse.c @@ -13,9 +13,9 @@ * this file, and for a DISCLAIMER OF ALL WARRANTIES. */ -#include #include "tclInt.h" #include "tclParse.h" +#include /* * The following table provides parsing information about each possible 8-bit -- cgit v0.12 From 4bba36ca59c3760f9e2a593e8135aa6f8352919e Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 15:47:29 +0000 Subject: Use ne instead of [string length] for less shimmer risk. --- library/tm.tcl | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/library/tm.tcl b/library/tm.tcl index 955e84d..55efda6 100644 --- a/library/tm.tcl +++ b/library/tm.tcl @@ -238,7 +238,7 @@ proc ::tcl::tm::UnknownHandler {original name args} { continue } - if {[string length [package ifneeded $pkgname $pkgversion]]} { + if {[package ifneeded $pkgname $pkgversion] ne {}} { # There's already a provide script registered for # this version of this package. Since all units of # code claiming to be the same version of the same -- cgit v0.12 From 76023565adb6e64816efbf4cae39b1c5d2ab725a Mon Sep 17 00:00:00 2001 From: dgp Date: Thu, 5 Sep 2013 17:21:41 +0000 Subject: Partial revert of [a16752c252] bug fix to stop crashes in buggy tclcompiler. --- generic/tclBasic.c | 24 ++++++++++++++++++++++-- 1 file changed, 22 insertions(+), 2 deletions(-) diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 314b5fc..c3ab871 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -1967,7 +1967,8 @@ Tcl_CreateCommand( * * Side effects: * If a command named "cmdName" already exists for interp, it is - * first deleted. Then the new command is created from the arguments. + * first deleted. Then the new command is created from the arguments. + * [***] (See below for exception). * * In the future, during bytecode evaluation when "cmdName" is seen as * the name of a command by Tcl_EvalObj or Tcl_Eval, the object-based @@ -2034,8 +2035,27 @@ Tcl_CreateObjCommand( if (!isNew) { cmdPtr = Tcl_GetHashValue(hPtr); + /* Command already exists. */ + + /* + * [***] This is wrong. See Tcl Bug a16752c252. + * However, this buggy behavior is kept under particular + * circumstances to accommodate deployed binaries of the + * "tclcompiler" program. http://sourceforge.net/projects/tclpro/ + * that crash if the bug is fixed. + */ + + if (cmdPtr->objProc == TclInvokeStringCommand + && cmdPtr->clientData == clientData + && cmdPtr->deleteData == clientData + && cmdPtr->deleteProc == deleteProc) { + cmdPtr->objProc = proc; + cmdPtr->objClientData = clientData; + return (Tcl_Command) cmdPtr; + } + /* - * Command already exists; delete it. Be careful to preserve any + * Otherwise, we delete the old command. Be careful to preserve any * existing import links so we can restore them down below. That way, * you can redefine a command and its import status will remain * intact. -- cgit v0.12 From 991ddbd26c7c24de6598ff9fe61a1d9f13186548 Mon Sep 17 00:00:00 2001 From: dkf Date: Sun, 8 Sep 2013 10:21:37 +0000 Subject: [3611643] Stop polluting the global namespace. Refactor the index entry generation so it is done right, once. Handle more of [namespace ensemble create]'s behavior. --- library/auto.tcl | 69 +++++++++++++++++++++++++++++++++++--------------------- 1 file changed, 43 insertions(+), 26 deletions(-) diff --git a/library/auto.tcl b/library/auto.tcl index 78c219e..02edcc4 100644 --- a/library/auto.tcl +++ b/library/auto.tcl @@ -513,6 +513,32 @@ proc auto_mkindex_parser::fullname {name} { return [string map [list \0 \$] $name] } +# auto_mkindex_parser::indexEntry -- +# +# Used by commands like "proc" within the auto_mkindex parser to add a +# correctly-quoted entry to the index. This is shared code so it is done +# *right*, in one place. +# +# Arguments: +# name - Name that is being added to index. + +proc auto_mkindex_parser::indexEntry {name} { + variable index + variable scriptFile + + # We convert all metacharacters to their backslashed form, and pre-split + # the file name that we know about (which will be a proper list, and so + # correctly quoted). + + set name [string range [list \}[fullname $name]] 2 end] + set filenameParts [file split $scriptFile] + + append index [format \ + {set auto_index(%s) [list source [file join $dir %s]]%s} \ + $name $filenameParts \n] + return +} + if {[llength $::auto_mkindex_parser::initCommands]} { return } @@ -524,15 +550,7 @@ if {[llength $::auto_mkindex_parser::initCommands]} { # Adds an entry to the auto index list for the given procedure name. auto_mkindex_parser::command proc {name args} { - variable index - variable scriptFile - # Do some fancy reformatting on the "source" call to handle platform - # differences with respect to pathnames. Use format just so that the - # command is a little easier to read (otherwise it'd be full of - # backslashed dollar signs, etc. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } # Conditionally add support for Tcl byte code files. There are some tricky @@ -559,14 +577,7 @@ auto_mkindex_parser::hook { # procedure name. auto_mkindex_parser::commandInit tbcload::bcproc {name args} { - variable index - variable scriptFile - # Do some nice reformatting of the "source" call, to get around - # path differences on different platforms. We use the format - # command just so that the code is a little easier to read. - append index [list set auto_index([fullname $name])] \ - [format { [list source [file join $dir %s]]} \ - [file split $scriptFile]] "\n" + indexEntry $name } } } @@ -610,6 +621,13 @@ auto_mkindex_parser::command namespace {op args} { variable contextStack if {[lindex $args 0] eq "create"} { set name ::[join [lreverse $contextStack] ::] + catch { + set name [dict get [lrange $args 1 end] -command] + if {![string match ::* $name]} { + set name ::[join [lreverse $contextStack] ::]$name + } + regsub -all ::+ $name :: name + } # create artifical proc to force an entry in the tclIndex $parser eval [list ::proc $name {} {}] } @@ -619,15 +637,14 @@ auto_mkindex_parser::command namespace {op args} { # AUTO MKINDEX: oo::class create name ?definition? # Adds an entry to the auto index list for the given class name. -foreach cmd {oo::class class} { - auto_mkindex_parser::command $cmd {ecmd name {body ""}} { - if {$cmd eq "create"} { - variable index - variable scriptFile - append index [format "set %s \[list source \[%s]]\n" \ - [list auto_index([fullname $name])] \ - [list file join $dir {*}[file split $scriptFile]]] - } +auto_mkindex_parser::command oo::class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name + } +} +auto_mkindex_parser::command class {op name {body ""}} { + if {$op eq "create"} { + indexEntry $name } } -- cgit v0.12