diff options
author | dkf <donal.k.fellows@manchester.ac.uk> | 2013-09-20 13:02:29 (GMT) |
---|---|---|
committer | dkf <donal.k.fellows@manchester.ac.uk> | 2013-09-20 13:02:29 (GMT) |
commit | e3309e4d57407994dfba25053019cd7f1f5bd083 (patch) | |
tree | bf68b0b0a6c8342c24a522435cd2cf797929427a /generic | |
parent | 2f5ec3509d4e78728930acdb71d70eec99124817 (diff) | |
parent | a28b7ede49c7e21c0d7150cca682433e94a78464 (diff) | |
download | tcl-e3309e4d57407994dfba25053019cd7f1f5bd083.zip tcl-e3309e4d57407994dfba25053019cd7f1f5bd083.tar.gz tcl-e3309e4d57407994dfba25053019cd7f1f5bd083.tar.bz2 |
merge trunk
Diffstat (limited to 'generic')
-rw-r--r-- | generic/tcl.h | 4 | ||||
-rw-r--r-- | generic/tclAssembly.c | 1 | ||||
-rw-r--r-- | generic/tclBasic.c | 449 | ||||
-rw-r--r-- | generic/tclBinary.c | 304 | ||||
-rw-r--r-- | generic/tclCompCmds.c | 49 | ||||
-rw-r--r-- | generic/tclCompCmdsGR.c | 33 | ||||
-rw-r--r-- | generic/tclCompCmdsSZ.c | 95 | ||||
-rw-r--r-- | generic/tclCompExpr.c | 101 | ||||
-rw-r--r-- | generic/tclExecute.c | 5 | ||||
-rw-r--r-- | generic/tclIOUtil.c | 2 | ||||
-rw-r--r-- | generic/tclInt.h | 2 | ||||
-rw-r--r-- | generic/tclInterp.c | 56 | ||||
-rw-r--r-- | generic/tclNamesp.c | 2 | ||||
-rw-r--r-- | generic/tclOO.h | 2 | ||||
-rw-r--r-- | generic/tclOOBasic.c | 16 | ||||
-rw-r--r-- | generic/tclOODefineCmds.c | 2 | ||||
-rw-r--r-- | generic/tclOOMethod.c | 52 | ||||
-rw-r--r-- | generic/tclParse.c | 2 | ||||
-rw-r--r-- | generic/tclTest.c | 22 | ||||
-rw-r--r-- | generic/tclUtil.c | 3 |
20 files changed, 781 insertions, 421 deletions
diff --git a/generic/tcl.h b/generic/tcl.h index a833218..1b120fb 100644 --- a/generic/tcl.h +++ b/generic/tcl.h @@ -56,10 +56,10 @@ extern "C" { #define TCL_MAJOR_VERSION 8 #define TCL_MINOR_VERSION 6 #define TCL_RELEASE_LEVEL TCL_FINAL_RELEASE -#define TCL_RELEASE_SERIAL 0 +#define TCL_RELEASE_SERIAL 1 #define TCL_VERSION "8.6" -#define TCL_PATCH_LEVEL "8.6.0" +#define TCL_PATCH_LEVEL "8.6.1" /* *---------------------------------------------------------------------------- diff --git a/generic/tclAssembly.c b/generic/tclAssembly.c index 100e9ef..946c729 100644 --- a/generic/tclAssembly.c +++ b/generic/tclAssembly.c @@ -2617,6 +2617,7 @@ AllocBB( bb->minStackDepth = 0; bb->maxStackDepth = 0; bb->finalStackDepth = 0; + bb->catchDepth = 0; bb->enclosingCatch = NULL; bb->foreignExceptionBase = -1; bb->foreignExceptionCount = 0; diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 7c664be..5131571 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -133,7 +133,6 @@ static Tcl_NRPostProc NRCoroutineCallerCallback; static Tcl_NRPostProc NRCoroutineExitCallback; static int NRCommand(ClientData data[], Tcl_Interp *interp, int result); -static Tcl_NRPostProc NRRunObjProc; static Tcl_ObjCmdProc OldMathFuncProc; static void OldMathFuncDeleteProc(ClientData clientData); static void ProcessUnexpectedResult(Tcl_Interp *interp, @@ -148,7 +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); + Tcl_Obj *const objv[]); static Tcl_NRPostProc RewindCoroutineCallback; static Tcl_NRPostProc TailcallCleanup; static Tcl_NRPostProc TEOEx_ByteCodeCallback; @@ -158,8 +157,11 @@ 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; +static Tcl_NRPostProc NRPostInvoke; MODULE_SCOPE const TclStubs tclStubs; @@ -2175,7 +2177,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 @@ -2242,8 +2245,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. @@ -4095,43 +4117,39 @@ TclNREvalObjv( * requested Command struct to be invoked. */ { Interp *iPtr = (Interp *) interp; - int result; - Namespace *lookupNsPtr = iPtr->lookupNsPtr; - Command **cmdPtrPtr; - NRE_callback *callbackPtr; - - 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. */ 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); - - if ((result != TCL_OK) || (objc == 0)) { - return result; - } - - if (cmdPtr) { - goto commandFound; - } + TclNRAddCallback(interp, EvalObjvCore, cmdPtr, INT2PTR(flags), + INT2PTR(objc), objv); + return TCL_OK; +} +static int +EvalObjvCore( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + 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; + Namespace *lookupNsPtr = NULL; + int enterTracesDone = 0; + /* * Push records for task to be done on return, in INVERSE order. First, if * needed, the exception handlers (as they should happen last). @@ -4141,63 +4159,150 @@ TclNREvalObjv( TEOV_PushExceptionHandlers(interp, objc, objv, flags); } + if (TCL_OK != TclInterpReady(interp)) { + return TCL_ERROR; + } + + if (objc == 0) { + return TCL_OK; + } + + if (TclLimitExceeded(iPtr->limit)) { + return TCL_ERROR; + } + /* * Configure evaluation context to match the requested flags. */ - if ((flags & TCL_EVAL_INVOKE) || lookupNsPtr) { - if (!lookupNsPtr) { - lookupNsPtr = iPtr->globalNsPtr; - } + if (iPtr->lookupNsPtr) { + + /* + * 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 { - if (flags & TCL_EVAL_GLOBAL) { - TEOV_SwitchVarFrame(interp); - lookupNsPtr = iPtr->globalNsPtr; - } /* * TCL_EVAL_INVOKE was not set: clear rewrite rules */ iPtr->ensembleRewrite.sourceObjs = NULL; + + if (flags & TCL_EVAL_GLOBAL) { + TEOV_SwitchVarFrame(interp); + lookupNsPtr = iPtr->globalNsPtr; + } } /* - * Lookup the command + * Lookup the Command to dispatch. */ - cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + reresolve: + assert(cmdPtr == NULL); + if (preCmdPtr) { + /* 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; + } } - - iPtr->cmdCount++; - if (TclLimitExceeded(iPtr->limit)) { - return TCL_ERROR; + if (cmdPtr == NULL) { + cmdPtr = TEOV_LookupCmdFromObj(interp, objv[0], lookupNsPtr); + if (!cmdPtr) { + return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + } } - /* - * Found a command! The real work begins now ... - */ - - commandFound: - if (iPtr->tracePtr || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - /* - * Call enter traces. They will schedule a call to the leave traces if - * necessary. - */ + if (enterTracesDone || iPtr->tracePtr + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { - result = TEOV_RunEnterTraces(interp, &cmdPtr, TclGetSourceFromFrame( + Tcl_Obj *commandPtr = TclGetSourceFromFrame( flags & TCL_EVAL_SOURCE_IN_FRAME ? iPtr->cmdFramePtr : NULL, - objc, objv), objc, objv, lookupNsPtr); - if (result != TCL_OK) { - return result; - } - if (!cmdPtr) { - return TEOV_NotFound(interp, objc, objv, lookupNsPtr); + objc, objv); + Tcl_IncrRefCount(commandPtr); + + if (!enterTracesDone) { + + int code = TEOV_RunEnterTraces(interp, &cmdPtr, commandPtr, + objc, objv); + + /* + * 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) { + Tcl_DecrRefCount(commandPtr); + return code; + } + + /* + * If the enter traces made the resolved cmdPtr unusable, go + * back and resolve again, but next time don't run enter + * traces again. + */ + + if (cmdPtr == NULL) { + enterTracesDone = 1; + Tcl_DecrRefCount(commandPtr); + goto reresolve; + } } + + /* + * 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, + 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()) { @@ -4218,34 +4323,18 @@ 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++; - - /* - * Find the objProc to call: nreProc if available, objProc otherwise. Push - * a callback to do the actual running. - */ - if (cmdPtr->nreProc) { - TclNRAddCallback(interp, NRRunObjProc, cmdPtr, - INT2PTR(objc), (ClientData) objv, NULL); - return TCL_OK; - } else { - return cmdPtr->objProc(cmdPtr->objClientData, interp, objc, objv); - } + iPtr->cmdCount++; + return objProc(clientData, interp, objc, objv); } int @@ -4291,13 +4380,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 @@ -4324,22 +4408,6 @@ NRCommand( return result; } - -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); -} - /* *---------------------------------------------------------------------- @@ -4605,25 +4673,19 @@ TEOV_RunEnterTraces( Command **cmdPtrPtr, Tcl_Obj *commandPtr, int objc, - Tcl_Obj *const objv[], - Namespace *lookupNsPtr) + 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; - - 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++; @@ -4638,29 +4700,22 @@ TEOV_RunEnterTraces( newEpoch = cmdPtr->cmdEpoch; 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); - *cmdPtrPtr = cmdPtr; + 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; } - - 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 @@ -4675,12 +4730,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); @@ -4690,7 +4743,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. @@ -4701,8 +4753,18 @@ TEOV_RunLeaveTraces( TclCleanupCommandMacro(cmdPtr); if (traceCode != TCL_OK) { - return traceCode; + 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; + } + result = traceCode; } + Tcl_DecrRefCount(commandPtr); return result; } @@ -4718,7 +4780,6 @@ TEOV_LookupCmdFromObj( if (lookupNsPtr) { iPtr->varFramePtr->nsPtr = lookupNsPtr; - iPtr->lookupNsPtr = NULL; } cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, namePtr); iPtr->varFramePtr->nsPtr = savedNsPtr; @@ -6473,30 +6534,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 (TclInterpReady(interp) == TCL_ERROR) { - return TCL_ERROR; - } +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; @@ -6512,36 +6575,27 @@ TclObjInvoke( } cmdPtr = Tcl_GetHashValue(hPtr); - /* - * 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); - } + /* Avoid the exception-handling brain damage when numLevels == 0 . */ + iPtr->numLevels++; + Tcl_NRAddCallback(interp, NRPostInvoke, NULL, NULL, NULL, NULL); /* - * If an error occurred, record information about what was being executed - * when the error occurred. + * 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). */ - 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; + return TclNREvalObjv(interp, objc, objv, TCL_EVAL_NORESOLVE, 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; } @@ -7992,39 +8046,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); } /* @@ -8117,7 +8143,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/tclBinary.c b/generic/tclBinary.c index 901237b..58583f4 100644 --- a/generic/tclBinary.c +++ b/generic/tclBinary.c @@ -87,10 +87,13 @@ static int BinaryDecodeHex(ClientData clientData, static int BinaryEncode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecodeUu(ClientData clientData, +static int BinaryDecode64(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); -static int BinaryDecode64(ClientData clientData, +static int BinaryEncodeUu(ClientData clientData, + Tcl_Interp *interp, int objc, + Tcl_Obj *const objv[]); +static int BinaryDecodeUu(ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]); @@ -139,9 +142,9 @@ static const EnsembleImplMap binaryMap[] = { { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap encodeMap[] = { - { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, (ClientData)HexDigits, 0 }, - { "uuencode", BinaryEncode64, NULL, NULL, (ClientData)UueDigits, 0 }, - { "base64", BinaryEncode64, NULL, NULL, (ClientData)B64Digits, 0 }, + { "hex", BinaryEncodeHex, TclCompileBasic1ArgCmd, NULL, NULL, 0 }, + { "uuencode", BinaryEncodeUu, NULL, NULL, NULL, 0 }, + { "base64", BinaryEncode64, NULL, NULL, NULL, 0 }, { NULL, NULL, NULL, NULL, NULL, 0 } }; static const EnsembleImplMap decodeMap[] = { @@ -2312,7 +2315,6 @@ BinaryEncodeHex( Tcl_Obj *resultObj = NULL; unsigned char *data = NULL; unsigned char *cursor = NULL; - const char *digits = clientData; int offset = 0, count = 0; if (objc != 2) { @@ -2324,8 +2326,8 @@ BinaryEncodeHex( data = Tcl_GetByteArrayFromObj(objv[1], &count); cursor = Tcl_SetByteArrayLength(resultObj, count * 2); for (offset = 0; offset < count; ++offset) { - *cursor++ = digits[((data[offset] >> 4) & 0x0f)]; - *cursor++ = digits[(data[offset] & 0x0f)]; + *cursor++ = HexDigits[((data[offset] >> 4) & 0x0f)]; + *cursor++ = HexDigits[(data[offset] & 0x0f)]; } Tcl_SetObjResult(interp, resultObj); return TCL_OK; @@ -2386,29 +2388,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; @@ -2436,7 +2441,7 @@ BinaryDecodeHex( * This implements a generic 6 bit binary encoding. Input is broken into * 6 bit chunks and a lookup table passed in via clientData is used to * turn these values into output characters. This is used to implement - * base64 and uuencode binary encodings. + * base64 binary encodings. * * Results: * Interp result set to an encoded byte array object @@ -2472,7 +2477,6 @@ BinaryEncode64( { Tcl_Obj *resultObj; unsigned char *data, *cursor, *limit; - const char *digits = clientData; int maxlen = 0; const char *wrapchar = "\n"; int wrapcharlen = 1; @@ -2495,6 +2499,12 @@ BinaryEncode64( if (Tcl_GetIntFromObj(interp, objv[i+1], &maxlen) != TCL_OK) { return TCL_ERROR; } + if (maxlen < 0) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } break; case OPT_WRAPCHAR: wrapchar = Tcl_GetStringFromObj(objv[i+1], &wrapcharlen); @@ -2525,17 +2535,17 @@ BinaryEncode64( for (i = 0; i < 3 && offset+i < count; ++i) { d[i] = data[offset + i]; } - OUTPUT(digits[d[0] >> 2]); - OUTPUT(digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); + OUTPUT(B64Digits[d[0] >> 2]); + OUTPUT(B64Digits[((d[0] & 0x03) << 4) | (d[1] >> 4)]); if (offset+1 < count) { - OUTPUT(digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); + OUTPUT(B64Digits[((d[1] & 0x0f) << 2) | (d[2] >> 6)]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } if (offset+2 < count) { - OUTPUT(digits[d[2] & 0x3f]); + OUTPUT(B64Digits[d[2] & 0x3f]); } else { - OUTPUT(digits[64]); + OUTPUT(B64Digits[64]); } } } @@ -2547,6 +2557,124 @@ BinaryEncode64( /* *---------------------------------------------------------------------- * + * BinaryEncodeUu -- + * + * This implements the uuencode binary encoding. Input is broken into 6 + * bit chunks and a lookup table is used to turn these values into output + * characters. This differs from the generic code above in that line + * lengths are also encoded. + * + * Results: + * Interp result set to an encoded byte array object + * + * Side effects: + * None + * + *---------------------------------------------------------------------- + */ + +static int +BinaryEncodeUu( + ClientData clientData, + Tcl_Interp *interp, + int objc, + Tcl_Obj *const objv[]) +{ + Tcl_Obj *resultObj; + unsigned char *data, *start, *cursor; + int offset, count, rawLength, n, i, j, bits, index; + int lineLength = 61; + const unsigned char SingleNewline[] = { (unsigned char) '\n' }; + const unsigned char *wrapchar = SingleNewline; + int wrapcharlen = sizeof(SingleNewline); + enum { OPT_MAXLEN, OPT_WRAPCHAR }; + static const char *const optStrings[] = { "-maxlen", "-wrapchar", NULL }; + + if (objc < 2 || objc%2 != 0) { + Tcl_WrongNumArgs(interp, 1, objv, + "?-maxlen len? ?-wrapchar char? data"); + return TCL_ERROR; + } + for (i = 1; i < objc-1; i += 2) { + if (Tcl_GetIndexFromObj(interp, objv[i], optStrings, "option", + TCL_EXACT, &index) != TCL_OK) { + return TCL_ERROR; + } + switch (index) { + case OPT_MAXLEN: + if (Tcl_GetIntFromObj(interp, objv[i+1], &lineLength) != TCL_OK) { + return TCL_ERROR; + } + if (lineLength < 3 || lineLength > 85) { + Tcl_SetResult(interp, "line length out of range", TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "ENCODE", + "LINE_LENGTH", NULL); + return TCL_ERROR; + } + break; + case OPT_WRAPCHAR: + wrapchar = Tcl_GetByteArrayFromObj(objv[i+1], &wrapcharlen); + break; + } + } + + /* + * Allocate the buffer. This is a little bit too long, but is "good + * enough". + */ + + resultObj = Tcl_NewObj(); + offset = 0; + data = Tcl_GetByteArrayFromObj(objv[objc-1], &count); + rawLength = (lineLength - 1) * 3 / 4; + start = cursor = Tcl_SetByteArrayLength(resultObj, + (lineLength + wrapcharlen) * + ((count + (rawLength - 1)) / rawLength)); + n = bits = 0; + + /* + * Encode the data. Each output line first has the length of raw data + * encoded by the output line described in it by one encoded byte, then + * the encoded data follows (encoding each 6 bits as one character). + * Encoded lines are always terminated by a newline. + */ + + while (offset < count) { + int lineLen = count - offset; + + if (lineLen > rawLength) { + lineLen = rawLength; + } + *cursor++ = UueDigits[lineLen]; + for (i=0 ; i<lineLen ; i++) { + n <<= 8; + n |= data[offset++]; + for (bits += 8; bits > 6 ; bits -= 6) { + *cursor++ = UueDigits[(n >> (bits-6)) & 0x3f]; + } + } + if (bits > 0) { + n <<= 8; + *cursor++ = UueDigits[(n >> (bits + 2)) & 0x3f]; + bits = 0; + } + for (j=0 ; j<wrapcharlen ; ++j) { + *cursor++ = wrapchar[j]; + } + } + + /* + * Fix the length of the output bytearray. + */ + + Tcl_SetByteArrayLength(resultObj, cursor-start); + Tcl_SetObjResult(interp, resultObj); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * BinaryDecodeUu -- * * Decode a uuencoded string. @@ -2570,8 +2698,8 @@ BinaryDecodeUu( Tcl_Obj *resultObj = NULL; unsigned char *data, *datastart, *dataend; unsigned char *begin, *cursor; - int i, index, size, count = 0, cut = 0, strict = 0; - char c; + int i, index, size, count = 0, strict = 0, lineLen; + unsigned char c; enum {OPT_STRICT }; static const char *const optStrings[] = { "-strict", NULL }; @@ -2597,44 +2725,112 @@ BinaryDecodeUu( dataend = data + count; size = ((count + 3) & ~3) * 3 / 4; begin = cursor = Tcl_SetByteArrayLength(resultObj, size); + lineLen = -1; + + /* + * The decoding loop. First, we get the length of line (strictly, the + * number of data bytes we expect to generate from the line) we're + * processing this time round if it is not already known (i.e., when the + * lineLen variable is set to the magic value, -1). + */ + while (data < dataend) { char d[4] = {0, 0, 0, 0}; + if (lineLen < 0) { + c = *data++; + if (c < 32 || c > 96) { + if (strict || !isspace(c)) { + goto badUu; + } + i--; + continue; + } + lineLen = (c - 32) & 0x3f; + } + + /* + * Now we read a four-character grouping. + */ + for (i=0 ; i<4 ; i++) { if (data < dataend) { d[i] = c = *data++; - if (c < 33 || c > 96) { - if (strict || !isspace(UCHAR(c))) { - goto badUu; + if (c < 32 || c > 96) { + if (strict) { + if (!isspace(c)) { + goto badUu; + } else if (c == '\n') { + goto shortUu; + } } i--; continue; } - } else { - cut++; } } - if (cut > 3) { - cut = 3; + + /* + * Translate that grouping into (up to) three binary bytes output. + */ + + if (lineLen > 0) { + *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) + | (((d[1] - 0x20) & 0x3f) >> 4); + if (--lineLen > 0) { + *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) + | (((d[2] - 0x20) & 0x3f) >> 2); + if (--lineLen > 0) { + *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) + | (((d[3] - 0x20) & 0x3f)); + lineLen--; + } + } + } + + /* + * If we've reached the end of the line, skip until we process a + * newline. + */ + + if (lineLen == 0 && data < dataend) { + lineLen = -1; + do { + c = *data++; + if (c == '\n') { + break; + } else if (c >= 32 && c <= 96) { + data--; + break; + } else if (strict || !isspace(c)) { + goto badUu; + } + } while (data < dataend); } - *cursor++ = (((d[0] - 0x20) & 0x3f) << 2) - | (((d[1] - 0x20) & 0x3f) >> 4); - *cursor++ = (((d[1] - 0x20) & 0x3f) << 4) - | (((d[2] - 0x20) & 0x3f) >> 2); - *cursor++ = (((d[2] - 0x20) & 0x3f) << 6) - | (((d[3] - 0x20) & 0x3f)); } - if (cut > size) { - cut = size; + + /* + * Sanity check, clean up and finish. + */ + + if (lineLen > 0 && strict) { + goto shortUu; } - Tcl_SetByteArrayLength(resultObj, cursor - begin - cut); + Tcl_SetByteArrayLength(resultObj, cursor - begin); Tcl_SetObjResult(interp, resultObj); return TCL_OK; + shortUu: + Tcl_SetObjResult(interp, Tcl_ObjPrintf("short uuencode data")); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "SHORT", NULL); + TclDecrRefCount(resultObj); + return TCL_ERROR; + badUu: Tcl_SetObjResult(interp, Tcl_ObjPrintf( "invalid uuencode character \"%c\" at position %d", c, (int) (data - datastart - 1))); + Tcl_SetErrorCode(interp, "TCL", "BINARY", "DECODE", "INVALID", NULL); TclDecrRefCount(resultObj); return TCL_ERROR; } diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 2a6f88d..8f4363b 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -847,7 +847,7 @@ TclCompileDictSetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i, dictVarIndex; + int i, dictVarIndex; DefineLineInformation; /* TIP #280 */ Tcl_Token *varTokenPtr; @@ -876,8 +876,7 @@ TclCompileDictSetCmd( */ tokenPtr = TokenAfter(varTokenPtr); - numWords = parsePtr->numWords-1; - for (i=1 ; i<numWords ; i++) { + for (i=2 ; i< parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } @@ -886,7 +885,7 @@ TclCompileDictSetCmd( * Now emit the instruction to do the dict manipulation. */ - TclEmitInstInt4( INST_DICT_SET, numWords-2, envPtr); + TclEmitInstInt4( INST_DICT_SET, parsePtr->numWords-3, envPtr); TclEmitInt4( dictVarIndex, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; @@ -958,7 +957,7 @@ TclCompileDictIncrCmd( * Emit the key and the code to actually do the increment. */ - CompileWord(envPtr, keyTokenPtr, interp, 3); + CompileWord(envPtr, keyTokenPtr, interp, 2); TclEmitInstInt4( INST_DICT_INCR_IMM, incrAmount, envPtr); TclEmitInt4( dictVarIndex, envPtr); return TCL_OK; @@ -974,7 +973,7 @@ TclCompileDictGetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -987,17 +986,16 @@ TclCompileDictGetCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Only compile this because we need INST_DICT_GET anyway. */ - for (i=0 ; i<numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_GET, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_GET, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1012,7 +1010,7 @@ TclCompileDictExistsCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *tokenPtr; - int numWords, i; + int i; DefineLineInformation; /* TIP #280 */ /* @@ -1025,17 +1023,16 @@ TclCompileDictExistsCmd( return TCL_ERROR; } tokenPtr = TokenAfter(parsePtr->tokenPtr); - numWords = parsePtr->numWords-1; /* * Now we do the code generation. */ - for (i=0 ; i<numWords ; i++) { + for (i=1 ; i<parsePtr->numWords ; i++) { CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } - TclEmitInstInt4(INST_DICT_EXISTS, numWords-1, envPtr); + TclEmitInstInt4(INST_DICT_EXISTS, parsePtr->numWords-2, envPtr); TclAdjustStackDepth(-1, envPtr); return TCL_OK; } @@ -1434,7 +1431,7 @@ CompileDictEachCmd( * this point. */ - CompileWord(envPtr, dictTokenPtr, interp, 3); + CompileWord(envPtr, dictTokenPtr, interp, 2); /* * Now we catch errors from here on so that we can finalize the search @@ -1643,7 +1640,7 @@ TclCompileDictUpdateCmd( infoIndex = TclCreateAuxData(duiPtr, &tclDictUpdateInfoType, envPtr); for (i=0 ; i<numVars ; i++) { - CompileWord(envPtr, keyTokenPtrs[i], interp, i); + CompileWord(envPtr, keyTokenPtrs[i], interp, 2*i+2); } TclEmitInstInt4( INST_LIST, numVars, envPtr); TclEmitInstInt4( INST_DICT_UPDATE_START, dictIndex, envPtr); @@ -1800,8 +1797,8 @@ TclCompileDictLappendCmd( * Issue the implementation. */ - CompileWord(envPtr, keyTokenPtr, interp, 3); - CompileWord(envPtr, valueTokenPtr, interp, 4); + CompileWord(envPtr, keyTokenPtr, interp, 2); + CompileWord(envPtr, valueTokenPtr, interp, 3); TclEmitInstInt4( INST_DICT_LAPPEND, dictVarIndex, envPtr); return TCL_OK; } @@ -1886,7 +1883,7 @@ TclCompileDictWithCmd( tokenPtr = TokenAfter(varTokenPtr); for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1913,7 +1910,7 @@ TclCompileDictWithCmd( tokenPtr = varTokenPtr; for (i=1 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4(INST_LIST, parsePtr->numWords-3,envPtr); @@ -1927,7 +1924,7 @@ TclCompileDictWithCmd( * Case: Direct dict in non-simple var with empty body. */ - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); TclEmitOpcode( INST_DUP, envPtr); TclEmitOpcode( INST_LOAD_STK, envPtr); PushStringLiteral(envPtr, ""); @@ -1962,13 +1959,13 @@ TclCompileDictWithCmd( */ if (dictVar == -1) { - CompileWord(envPtr, varTokenPtr, interp, 0); + CompileWord(envPtr, varTokenPtr, interp, 1); Emit14Inst( INST_STORE_SCALAR, varNameTmp, envPtr); } tokenPtr = TokenAfter(varTokenPtr); if (gotPath) { for (i=2 ; i<parsePtr->numWords-1 ; i++) { - CompileWord(envPtr, tokenPtr, interp, i-1); + CompileWord(envPtr, tokenPtr, interp, i); tokenPtr = TokenAfter(tokenPtr); } TclEmitInstInt4( INST_LIST, parsePtr->numWords-3,envPtr); @@ -2257,7 +2254,7 @@ TclCompileForCmd( { Tcl_Token *startTokenPtr, *testTokenPtr, *nextTokenPtr, *bodyTokenPtr; JumpFixup jumpEvalCondFixup; - int testCodeOffset, bodyCodeOffset, nextCodeOffset, jumpDist; + int bodyCodeOffset, nextCodeOffset, jumpDist; int bodyRange, nextRange; DefineLineInformation; /* TIP #280 */ @@ -2338,13 +2335,9 @@ TclCompileForCmd( * terminates the for. */ - testCodeOffset = CurrentOffset(envPtr); - - jumpDist = testCodeOffset - jumpEvalCondFixup.codeOffset; - if (TclFixupForwardJump(envPtr, &jumpEvalCondFixup, jumpDist, 127)) { + if (TclFixupForwardJumpToHere(envPtr, &jumpEvalCondFixup, 127)) { bodyCodeOffset += 3; nextCodeOffset += 3; - testCodeOffset += 3; } SetLineInformation(2); diff --git a/generic/tclCompCmdsGR.c b/generic/tclCompCmdsGR.c index 150c378..43ea3d3 100644 --- a/generic/tclCompCmdsGR.c +++ b/generic/tclCompCmdsGR.c @@ -85,14 +85,17 @@ TclCompileGlobalCmd( */ varTokenPtr = TokenAfter(parsePtr->tokenPtr); - for (i=2; i<=numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { + for (i=1; i<numWords; varTokenPtr = TokenAfter(varTokenPtr),i++) { localIndex = IndexTailVarIfKnown(interp, varTokenPtr, envPtr); if (localIndex < 0) { return TCL_ERROR; } - CompileWord(envPtr, varTokenPtr, interp, 1); + /* TODO: Consider what value can pass throug the + * IndexTailVarIfKnown() screen. Full CompileWord() + * likely does not apply here. Push known value instead. */ + CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_NSUPVAR, localIndex, envPtr); } @@ -584,6 +587,7 @@ TclCompileInfoCommandsCmd( * that the result needs to be list-ified. */ + /* TODO: Just push the known value */ CompileWord(envPtr, tokenPtr, interp, 1); TclEmitOpcode( INST_RESOLVE_COMMAND, envPtr); TclEmitOpcode( INST_DUP, envPtr); @@ -1899,13 +1903,13 @@ TclCompileNamespaceUpvarCmd( */ localTokenPtr = tokenPtr; - for (i=3; i<=numWords; i+=2) { + for (i=2; i<numWords; i+=2) { otherTokenPtr = TokenAfter(localTokenPtr); localTokenPtr = TokenAfter(otherTokenPtr); - CompileWord(envPtr, otherTokenPtr, interp, 1); + CompileWord(envPtr, otherTokenPtr, interp, i); PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + &localIndex, &isScalar, i+1); if ((localIndex < 0) || !isScalar) { return TCL_ERROR; @@ -2568,16 +2572,14 @@ TclCompileUpvarCmd( Tcl_Token *tokenPtr, *otherTokenPtr, *localTokenPtr; int isScalar, localIndex, numWords, i; DefineLineInformation; /* TIP #280 */ - Tcl_Obj *objPtr = Tcl_NewObj(); + Tcl_Obj *objPtr; if (envPtr->procPtr == NULL) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } numWords = parsePtr->numWords; if (numWords < 3) { - Tcl_DecrRefCount(objPtr); return TCL_ERROR; } @@ -2585,6 +2587,7 @@ TclCompileUpvarCmd( * Push the frame index if it is known at compile time */ + objPtr = Tcl_NewObj(); tokenPtr = TokenAfter(parsePtr->tokenPtr); if (TclWordKnownAtCompileTime(tokenPtr, objPtr)) { CallFrame *framePtr; @@ -2603,16 +2606,17 @@ TclCompileUpvarCmd( if (numWords%2) { return TCL_ERROR; } + /* TODO: Push the known value instead? */ CompileWord(envPtr, tokenPtr, interp, 1); otherTokenPtr = TokenAfter(tokenPtr); - i = 4; + i = 2; } else { if (!(numWords%2)) { return TCL_ERROR; } PushStringLiteral(envPtr, "1"); otherTokenPtr = tokenPtr; - i = 3; + i = 1; } } else { Tcl_DecrRefCount(objPtr); @@ -2625,12 +2629,12 @@ TclCompileUpvarCmd( * be called at runtime. */ - for (; i<=numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { + for (; i<numWords; i+=2, otherTokenPtr = TokenAfter(localTokenPtr)) { localTokenPtr = TokenAfter(otherTokenPtr); - CompileWord(envPtr, otherTokenPtr, interp, 1); + CompileWord(envPtr, otherTokenPtr, interp, i); PushVarNameWord(interp, localTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + &localIndex, &isScalar, i+1); if ((localIndex < 0) || !isScalar) { return TCL_ERROR; @@ -2706,6 +2710,9 @@ TclCompileVariableCmd( return TCL_ERROR; } + /* TODO: Consider what value can pass throug the + * IndexTailVarIfKnown() screen. Full CompileWord() + * likely does not apply here. Push known value instead. */ CompileWord(envPtr, varTokenPtr, interp, i); TclEmitInstInt4( INST_VARIABLE, localIndex, envPtr); diff --git a/generic/tclCompCmdsSZ.c b/generic/tclCompCmdsSZ.c index 0cab490..96d691d 100644 --- a/generic/tclCompCmdsSZ.c +++ b/generic/tclCompCmdsSZ.c @@ -1894,6 +1894,7 @@ TclCompileTailcallCmd( } /* make room for the nsObjPtr */ + /* TODO: Doesn't this have to be a known value? */ CompileWord(envPtr, tokenPtr, interp, 0); for (i=1 ; i<parsePtr->numWords ; i++) { tokenPtr = TokenAfter(tokenPtr); @@ -2844,39 +2845,81 @@ TclCompileUnsetCmd( CompileEnv *envPtr) /* Holds resulting instructions. */ { Tcl_Token *varTokenPtr; - int isScalar, localIndex, numWords, flags, i; - Tcl_Obj *leadingWord; + int isScalar, localIndex, flags = 1, i, varCount = 0, haveFlags = 0; DefineLineInformation; /* TIP #280 */ /* TODO: Consider support for compiling expanded args. */ - numWords = parsePtr->numWords-1; - flags = 1; - varTokenPtr = TokenAfter(parsePtr->tokenPtr); - leadingWord = Tcl_NewObj(); - if (numWords > 0 && TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { - int len; - const char *bytes = Tcl_GetStringFromObj(leadingWord, &len); - - if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { - flags = 0; - varTokenPtr = TokenAfter(varTokenPtr); - numWords--; - } else if (len == 2 && !strncmp("--", bytes, 2)) { - varTokenPtr = TokenAfter(varTokenPtr); - numWords--; + + /* + * Verify that all words - except the first non-option one - are known at + * compile time so that we can handle them without needing to do a nasty + * push/rotate. [Bug 3970f54c4e] + */ + + for (i=1,varTokenPtr=parsePtr->tokenPtr ; i<parsePtr->numWords ; i++) { + Tcl_Obj *leadingWord = Tcl_NewObj(); + + varTokenPtr = TokenAfter(varTokenPtr); + if (!TclWordKnownAtCompileTime(varTokenPtr, leadingWord)) { + TclDecrRefCount(leadingWord); + + /* + * We can tolerate non-trivial substitutions in the first variable + * to be unset. If a '--' or '-nocomplain' was present, anything + * goes in that one place! (All subsequent variable names must be + * constants since we don't want to have to push them all first.) + */ + + if (varCount == 0) { + if (haveFlags) { + continue; + } + + /* + * In fact, we're OK as long as we're the first argument *and* + * we provably don't start with a '-'. If that is true, then + * even if everything else is varying, we still can't be a + * flag. Otherwise we'll spill to runtime to place a limit on + * the trickiness. + */ + + if (varTokenPtr->type == TCL_TOKEN_WORD + && varTokenPtr[1].type == TCL_TOKEN_TEXT + && varTokenPtr[1].size > 0 + && varTokenPtr[1].start[0] != '-') { + continue; + } + } + return TCL_ERROR; } - } else { - /* - * Cannot guarantee that the first word is not '-nocomplain' at - * evaluation with reasonable effort, so spill to interpreted version. - */ + if (i == 1) { + const char *bytes; + int len; + bytes = Tcl_GetStringFromObj(leadingWord, &len); + if (len == 11 && !strncmp("-nocomplain", bytes, 11)) { + flags = 0; + haveFlags = 1; + } else if (len == 2 && !strncmp("--", bytes, 2)) { + haveFlags = 1; + } else { + varCount++; + } + } else { + varCount++; + } TclDecrRefCount(leadingWord); - return TCL_ERROR; } - TclDecrRefCount(leadingWord); - for (i=0 ; i<numWords ; i++) { + /* + * Issue instructions to unset each of the named variables. + */ + + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + if (haveFlags) { + varTokenPtr = TokenAfter(varTokenPtr); + } + for (i=1+haveFlags ; i<parsePtr->numWords ; i++) { /* * Decide if we can use a frame slot for the var/array name or if we * need to emit code to compute and push the name at runtime. We use a @@ -2886,7 +2929,7 @@ TclCompileUnsetCmd( */ PushVarNameWord(interp, varTokenPtr, envPtr, 0, - &localIndex, &isScalar, 1); + &localIndex, &isScalar, i); /* * Emit instructions to unset the variable. diff --git a/generic/tclCompExpr.c b/generic/tclCompExpr.c index 2a48117..d8e4d9f 100644 --- a/generic/tclCompExpr.c +++ b/generic/tclCompExpr.c @@ -490,13 +490,6 @@ typedef struct JumpList { JumpFixup jump; /* Pass this argument to matching calls of * TclEmitForwardJump() and * TclFixupForwardJump(). */ - int depth; /* Remember the currStackDepth of the - * CompileEnv here. */ - int offset; /* Data used to compute jump lengths to pass - * to TclFixupForwardJump() */ - int convert; /* Temporary storage used to compute whether - * numeric conversion will be needed following - * the operator we're compiling. */ struct JumpList *next; /* Point to next item on the stack */ } JumpList; @@ -2261,30 +2254,8 @@ CompileExprTree( if (nodePtr->mark == MARK_LEFT) { next = nodePtr->left; - switch (nodePtr->lexeme) { - case QUESTION: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; + if (nodePtr->lexeme == QUESTION) { convert = 1; - break; - case AND: - case OR: - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - newJump = TclStackAlloc(interp, sizeof(JumpList)); - newJump->next = jumpPtr; - jumpPtr = newJump; - jumpPtr->depth = envPtr->currStackDepth; - break; } } else if (nodePtr->mark == MARK_RIGHT) { next = nodePtr->right; @@ -2317,25 +2288,35 @@ CompileExprTree( break; } case QUESTION: + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); break; case COLON: - CLANG_ASSERT(jumpPtr); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->jump); - envPtr->currStackDepth = jumpPtr->depth; - jumpPtr->offset = (envPtr->codeNext - envPtr->codeStart); - jumpPtr->convert = convert; + &jumpPtr->jump); + TclAdjustStackDepth(-1, envPtr); + if (convert) { + jumpPtr->jump.jumpType = TCL_TRUE_JUMP; + } convert = 1; break; case AND: - TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpPtr->jump); - break; case OR: - TclEmitForwardJump(envPtr, TCL_TRUE_JUMP, &jumpPtr->jump); + newJump = TclStackAlloc(interp, sizeof(JumpList)); + newJump->next = jumpPtr; + jumpPtr = newJump; + TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) + ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, &jumpPtr->jump); break; } } else { + int pc1, pc2, target; + switch (nodePtr->lexeme) { case START: case QUESTION: @@ -2375,18 +2356,20 @@ CompileExprTree( break; case COLON: CLANG_ASSERT(jumpPtr); - if (TclFixupForwardJump(envPtr, &jumpPtr->next->jump, - (envPtr->codeNext - envPtr->codeStart) - - jumpPtr->next->jump.codeOffset, 127)) { - jumpPtr->offset += 3; + if (jumpPtr->jump.jumpType == TCL_TRUE_JUMP) { + jumpPtr->jump.jumpType = TCL_UNCONDITIONAL_JUMP; + convert = 1; + } + target = jumpPtr->jump.codeOffset + 2; + if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { + target += 3; } - TclFixupForwardJump(envPtr, &jumpPtr->jump, - jumpPtr->offset - jumpPtr->jump.codeOffset, 127); - convert |= jumpPtr->convert; - envPtr->currStackDepth = jumpPtr->depth + 1; freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); + TclFixupForwardJump(envPtr, &jumpPtr->jump, + target - jumpPtr->jump.codeOffset, 127); + freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); @@ -2394,30 +2377,24 @@ CompileExprTree( case AND: case OR: CLANG_ASSERT(jumpPtr); - TclEmitForwardJump(envPtr, (nodePtr->lexeme == AND) - ? TCL_FALSE_JUMP : TCL_TRUE_JUMP, - &jumpPtr->next->jump); + pc1 = CurrentOffset(envPtr); + TclEmitInstInt1((nodePtr->lexeme == AND) ? INST_JUMP_FALSE1 + : INST_JUMP_TRUE1, 0, envPtr); TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "1" : "0", 1), envPtr); - TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, - &jumpPtr->next->next->jump); + pc2 = CurrentOffset(envPtr); + TclEmitInstInt1(INST_JUMP1, 0, envPtr); TclAdjustStackDepth(-1, envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->jump, 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc1, + envPtr->codeStart + pc1 + 1); if (TclFixupForwardJumpToHere(envPtr, &jumpPtr->jump, 127)) { - jumpPtr->next->next->jump.codeOffset += 3; + pc2 += 3; } TclEmitPush(TclRegisterNewLiteral(envPtr, (nodePtr->lexeme == AND) ? "0" : "1", 1), envPtr); - TclFixupForwardJumpToHere(envPtr, &jumpPtr->next->next->jump, - 127); + TclStoreInt1AtPtr(CurrentOffset(envPtr) - pc2, + envPtr->codeStart + pc2 + 1); convert = 0; - envPtr->currStackDepth = jumpPtr->depth + 1; - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); - freePtr = jumpPtr; - jumpPtr = jumpPtr->next; - TclStackFree(interp, freePtr); freePtr = jumpPtr; jumpPtr = jumpPtr->next; TclStackFree(interp, freePtr); diff --git a/generic/tclExecute.c b/generic/tclExecute.c index d066476..0ca393b 100644 --- a/generic/tclExecute.c +++ b/generic/tclExecute.c @@ -4738,7 +4738,7 @@ TEBCresume( if (listPtr->refCount == 1) { TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5))); - for (index=toIdx+1 ; index<objc-1 ; index++) { + for (index=toIdx+1; index<objc ; index++) { TclDecrRefCount(objv[index]); } listPtr->elemCount = toIdx+1; @@ -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. diff --git a/generic/tclIOUtil.c b/generic/tclIOUtil.c index 6259216..6332453 100644 --- a/generic/tclIOUtil.c +++ b/generic/tclIOUtil.c @@ -1944,7 +1944,7 @@ TclNREvalFile( iPtr->evalFlags |= TCL_EVAL_FILE; TclNRAddCallback(interp, EvalFileCallback, oldScriptFile, pathPtr, objPtr, NULL); - return TclNREvalObjEx(interp, objPtr, 0, NULL, INT_MIN); + return TclNREvalObjEx(interp, objPtr, TCL_EVAL_DIRECT, NULL, INT_MIN); } static int diff --git a/generic/tclInt.h b/generic/tclInt.h index 6056119..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: @@ -2725,6 +2726,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..0da5d47 100644 --- a/generic/tclInterp.c +++ b/generic/tclInterp.c @@ -279,6 +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; + /* *---------------------------------------------------------------------- @@ -481,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; @@ -590,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[] = { @@ -2372,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); @@ -2462,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[] = { @@ -3052,7 +3079,11 @@ SlaveInvokeHidden( Tcl_AllowExceptions(slaveInterp); if (namespaceName == NULL) { - result = TclObjInvoke(slaveInterp, objc, objv, TCL_INVOKE_HIDDEN); + 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; @@ -3071,6 +3102,23 @@ SlaveInvokeHidden( Tcl_Release(slaveInterp); return result; } + +static int +NRPostInvokeHidden( + ClientData data[], + Tcl_Interp *interp, + int result) +{ + Tcl_Interp *slaveInterp = (Tcl_Interp *)data[0]; + NRE_callback *rootPtr = (NRE_callback *)data[1]; + + if (interp != slaveInterp) { + result = TclNRRunCallbacks(slaveInterp, result, rootPtr); + Tcl_TransferResult(slaveInterp, result, interp); + } + Tcl_Release(slaveInterp); + return result; +} /* *---------------------------------------------------------------------- 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/tclOO.h b/generic/tclOO.h index cf253b1..d5ab8a0 100644 --- a/generic/tclOO.h +++ b/generic/tclOO.h @@ -39,7 +39,7 @@ extern const char *TclOOInitializeStubs( * win/tclooConfig.sh */ -#define TCLOO_VERSION "1.0" +#define TCLOO_VERSION "1.0.1" #define TCLOO_PATCHLEVEL TCLOO_VERSION /* diff --git a/generic/tclOOBasic.c b/generic/tclOOBasic.c index f8cd1a4..853e2ec 100644 --- a/generic/tclOOBasic.c +++ b/generic/tclOOBasic.c @@ -4,7 +4,7 @@ * This file contains implementations of the "simple" commands and * methods from the object-system core. * - * Copyright (c) 2005-2012 by Donal K. Fellows + * Copyright (c) 2005-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. @@ -88,7 +88,7 @@ TclOO_Class_Constructor( Tcl_Obj *const *objv) { Object *oPtr = (Object *) Tcl_ObjectContextObject(context); - Tcl_Obj *invoke[3]; + 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]; @@ -115,7 +116,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 +132,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; } diff --git a/generic/tclOODefineCmds.c b/generic/tclOODefineCmds.c index f0983cc..5a6c0ad 100644 --- a/generic/tclOODefineCmds.c +++ b/generic/tclOODefineCmds.c @@ -4,7 +4,7 @@ * This file contains the implementation of the ::oo::define command, * part of the object-system core (NB: not Tcl_Obj, but ::oo). * - * Copyright (c) 2006-2012 by Donal K. Fellows + * Copyright (c) 2006-2013 by Donal K. Fellows * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. diff --git a/generic/tclOOMethod.c b/generic/tclOOMethod.c index f9f980a..61215de 100644 --- a/generic/tclOOMethod.c +++ b/generic/tclOOMethod.c @@ -1290,11 +1290,57 @@ CloneProcedureMethod( ClientData *newClientData) { ProcedureMethod *pmPtr = clientData; - ProcedureMethod *pm2Ptr = ckalloc(sizeof(ProcedureMethod)); + ProcedureMethod *pm2Ptr; + Tcl_Obj *bodyObj, *argsObj; + CompiledLocal *localPtr; + /* + * Copy the argument list. + */ + + argsObj = Tcl_NewObj(); + for (localPtr=pmPtr->procPtr->firstLocalPtr; localPtr!=NULL; + localPtr=localPtr->nextPtr) { + if (TclIsVarArgument(localPtr)) { + Tcl_Obj *argObj = Tcl_NewObj(); + + Tcl_ListObjAppendElement(NULL, argObj, + Tcl_NewStringObj(localPtr->name, -1)); + if (localPtr->defValuePtr != NULL) { + Tcl_ListObjAppendElement(NULL, argObj, localPtr->defValuePtr); + } + Tcl_ListObjAppendElement(NULL, argsObj, argObj); + } + } + + /* + * Must strip the internal representation in order to ensure that any + * bound references to instance variables are removed. [Bug 3609693] + */ + + bodyObj = Tcl_DuplicateObj(pmPtr->procPtr->bodyPtr); + TclFreeIntRep(bodyObj); + + /* + * Create the actual copy of the method record, manufacturing a new proc + * record. + */ + + pm2Ptr = ckalloc(sizeof(ProcedureMethod)); memcpy(pm2Ptr, pmPtr, sizeof(ProcedureMethod)); pm2Ptr->refCount = 1; - pm2Ptr->procPtr->refCount++; + Tcl_IncrRefCount(argsObj); + Tcl_IncrRefCount(bodyObj); + if (TclCreateProc(interp, NULL, "", argsObj, bodyObj, + &pm2Ptr->procPtr) != TCL_OK) { + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + ckfree(pm2Ptr); + return TCL_ERROR; + } + Tcl_DecrRefCount(argsObj); + Tcl_DecrRefCount(bodyObj); + if (pmPtr->cloneClientdataProc) { pm2Ptr->clientData = pmPtr->cloneClientdataProc(pmPtr->clientData); } @@ -1421,7 +1467,7 @@ InvokeForwardMethod( Tcl_NRAddCallback(interp, FinalizeForwardCall, argObjs, NULL, NULL, NULL); ((Interp *)interp)->lookupNsPtr = (Namespace *) contextPtr->oPtr->namespacePtr; - return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_INVOKE, NULL); + return TclNREvalObjv(interp, len, argObjs, TCL_EVAL_NOERR, NULL); } static int 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 <assert.h> #include "tclInt.h" #include "tclParse.h" +#include <assert.h> /* * The following table provides parsing information about each possible 8-bit 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; } 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)); |