From 1543f6fbfc86e643435f8db696b104c0327f92e7 Mon Sep 17 00:00:00 2001 From: dkf Date: Sat, 30 Jan 2010 16:33:25 +0000 Subject: Make the [unset] command be bytecode compiled. --- ChangeLog | 60 ++-- generic/tclBasic.c | 4 +- generic/tclCompCmds.c | 128 +++++++- generic/tclCompile.c | 19 +- generic/tclCompile.h | 10 +- generic/tclExecute.c | 820 +++++++++++++++++++++++++++++--------------------- generic/tclInt.h | 12 +- generic/tclVar.c | 72 ++++- 8 files changed, 724 insertions(+), 401 deletions(-) diff --git a/ChangeLog b/ChangeLog index c4656c5..0f7713d 100644 --- a/ChangeLog +++ b/ChangeLog @@ -1,30 +1,40 @@ +2010-01-30 Donal K. Fellows + + * generic/tclCompile.c (tclInstructionTable): Bytecode instructions + * generic/tclCompCmds.c (TclCompileUnsetCmd): to allow the [unset] + * generic/tclExecute.c (TclExecuteByteCode): command to be compiled + with the compiler being a complete compilation for all compile-time + decidable uses. + + * generic/tclVar.c (TclPtrUnsetVar): Var reference version of the code + to unset a variable. Required for INST_UNSET bytecodes. + 2010-01-29 Jan Nijtmans - * generic/tcl.h Reverted Tcl_ThreadDataKey type change, - see Bug #2942081 - Changed some Tcl_CallFrame fields from "char *" - to "void *". This saves unnecessary space on - Cray's (and it's simply more correct). - - * tools/genStubs.tcl: No longer generate a space after "*" and - immediately after a function name, so the - format of function definitions in tcl*Decls.h - match all other tcl*.h header files. - * doc/ParseArgs.3: Change Tcl_ArgvFuncProc, Tcl_ArgvGenFuncProc - * generic/tcl.h and GetFrameInfoValueProc to be function - * generic/tclInt.h definitions, not pointers, for consistency - * generic/tclOOInt.h with all other Tcl function definitions. - * generic/tclIndexObj.c - * generic/regguts.h: CONST -> const - * generic/tcl.decls Formatting - * generic/tclTomMath.decls Formatting - * generic/tclDecls.h (regenerated) - * generic/tclIntDecls.h - * generic/tclIntPlatDecls.h - * generic/tclOODecls.h - * generic/tclOOIntDecls.h - * generic/tclPlatDecls.h - * generic/tclTomMathDecls.h + * generic/tcl.h: [Bug 2942081]: Reverted Tcl_ThreadDataKey type change + Changed some Tcl_CallFrame fields from "char *" + to "void *". This saves unnecessary space on + Cray's (and it's simply more correct). + + * tools/genStubs.tcl: No longer generate a space after "*" and + immediately after a function name, so the + format of function definitions in tcl*Decls.h + match all other tcl*.h header files. + * doc/ParseArgs.3: Change Tcl_ArgvFuncProc, Tcl_ArgvGenFuncProc + * generic/tcl.h: and GetFrameInfoValueProc to be function + * generic/tclInt.h: definitions, not pointers, for consistency + * generic/tclOOInt.h: with all other Tcl function definitions. + * generic/tclIndexObj.c: + * generic/regguts.h: CONST -> const + * generic/tcl.decls: Formatting + * generic/tclTomMath.decls: Formatting + * generic/tclDecls.h: (regenerated) + * generic/tclIntDecls.h: + * generic/tclIntPlatDecls.h: + * generic/tclOODecls.h: + * generic/tclOOIntDecls.h: + * generic/tclPlatDecls.h: + * generic/tclTomMathDecls.h: 2010-01-28 Donal K. Fellows diff --git a/generic/tclBasic.c b/generic/tclBasic.c index 254760d..2612aef 100644 --- a/generic/tclBasic.c +++ b/generic/tclBasic.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclBasic.c,v 1.438 2010/01/03 20:29:11 msofer Exp $ + * RCS: @(#) $Id: tclBasic.c,v 1.439 2010/01/30 16:33:25 dkf Exp $ */ #include "tclInt.h" @@ -242,7 +242,7 @@ static const CmdInfo builtInCmds[] = { {"throw", Tcl_ThrowObjCmd, NULL, NULL, 1}, {"trace", Tcl_TraceObjCmd, NULL, NULL, 1}, {"try", Tcl_TryObjCmd, NULL, TclNRTryObjCmd, 1}, - {"unset", Tcl_UnsetObjCmd, NULL, NULL, 1}, + {"unset", Tcl_UnsetObjCmd, TclCompileUnsetCmd, NULL, 1}, {"uplevel", Tcl_UplevelObjCmd, NULL, TclNRUplevelObjCmd, 1}, {"upvar", Tcl_UpvarObjCmd, TclCompileUpvarCmd, NULL, 1}, {"variable", Tcl_VariableObjCmd, TclCompileVariableCmd, NULL, 1}, diff --git a/generic/tclCompCmds.c b/generic/tclCompCmds.c index 6ec2265..5455e5d 100644 --- a/generic/tclCompCmds.c +++ b/generic/tclCompCmds.c @@ -12,7 +12,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompCmds.c,v 1.157 2009/09/11 20:13:27 dgp Exp $ + * RCS: @(#) $Id: tclCompCmds.c,v 1.158 2010/01/30 16:33:25 dkf Exp $ */ #include "tclInt.h" @@ -27,14 +27,14 @@ */ #define CompileWord(envPtr, tokenPtr, interp, word) \ - if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ + if ((tokenPtr)->type == TCL_TOKEN_SIMPLE_WORD) { \ TclEmitPush(TclRegisterNewLiteral((envPtr), (tokenPtr)[1].start, \ - (tokenPtr)[1].size), (envPtr)); \ - } else { \ - envPtr->line = mapPtr->loc[eclIndex].line[word]; \ - envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ + (tokenPtr)[1].size), (envPtr)); \ + } else { \ + envPtr->line = mapPtr->loc[eclIndex].line[word]; \ + envPtr->clNext = mapPtr->loc[eclIndex].next[word]; \ TclCompileTokens((interp), (tokenPtr)+1, (tokenPtr)->numComponents, \ - (envPtr)); \ + (envPtr)); \ } /* @@ -124,13 +124,13 @@ #define DeclareExceptionRange(envPtr, type) \ (TclCreateExceptRange((type), (envPtr))) #define ExceptionRangeStarts(envPtr, index) \ - (((envPtr)->exceptDepth++), \ - ((envPtr)->maxExceptDepth = \ - TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ + (((envPtr)->exceptDepth++), \ + ((envPtr)->maxExceptDepth = \ + TclMax((envPtr)->exceptDepth, (envPtr)->maxExceptDepth)), \ ((envPtr)->exceptArrayPtr[(index)].codeOffset = CurrentOffset(envPtr))) #define ExceptionRangeEnds(envPtr, index) \ - (((envPtr)->exceptDepth--), \ - ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ + (((envPtr)->exceptDepth--), \ + ((envPtr)->exceptArrayPtr[(index)].numCodeBytes = \ CurrentOffset(envPtr) - (envPtr)->exceptArrayPtr[(index)].codeOffset)) #define ExceptionRangeTarget(envPtr, index, targetType) \ ((envPtr)->exceptArrayPtr[(index)].targetType = CurrentOffset(envPtr)) @@ -184,9 +184,9 @@ static void CompileReturnInternal(CompileEnv *envPtr, Tcl_Obj *returnOpts); #define PushVarNameWord(i,v,e,f,l,s,sc,word) \ - PushVarName (i,v,e,f,l,s,sc, \ - mapPtr->loc [eclIndex].line [(word)], \ - mapPtr->loc [eclIndex].next [(word)]) + PushVarName(i,v,e,f,l,s,sc, \ + mapPtr->loc[eclIndex].line[(word)], \ + mapPtr->loc[eclIndex].next[(word)]) /* * Flags bits used by PushVarName. @@ -5019,6 +5019,104 @@ PrintJumptableInfo( /* *---------------------------------------------------------------------- * + * TclCompileUnsetCmd -- + * + * Procedure called to compile the "unset" command. + * + * Results: + * Returns TCL_OK for a successful compile. Returns TCL_ERROR to defer + * evaluation to runtime. + * + * Side effects: + * Instructions are added to envPtr to execute the "unset" command at + * runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileUnsetCmd( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *varTokenPtr; + int isScalar, simpleVarName, localIndex, numWords, flags, i; + Tcl_Obj *leadingWord; + DefineLineInformation; /* TIP #280 */ + + numWords = parsePtr->numWords-1; + flags = 1; + varTokenPtr = TokenAfter(parsePtr->tokenPtr); + leadingWord = Tcl_NewObj(); + if (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--; + } + } else { + /* + * Cannot guarantee that the first word is not '-nocomplain' at + * evaluation with reasonable effort, so spill to interpreted version. + */ + + return TCL_ERROR; + } + TclDecrRefCount(leadingWord); + + for (i=0 ; iflags & VAR_TRACED_READ) #define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE) +#define UnsetTraced(varPtr) ((varPtr)->flags & VAR_TRACED_UNSET) /* * Bottom of allocated stack holds the NR data @@ -2041,6 +2042,7 @@ TclExecuteByteCode( if (iPtr->execEnvPtr->corPtr) { CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + if (!corPtr->base.cmdFramePtr) { /* * First coroutine run, incomplete init: @@ -2167,10 +2169,6 @@ TclExecuteByteCode( */ if ((TAUX.instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) { - /* - * Check for asynchronous handlers [Bug 746722]; we do the check every - * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1). - */ int localResult; if (TclAsyncReady(iPtr)) { @@ -2383,19 +2381,17 @@ TclExecuteByteCode( NEXT_INST_F(1, 0, 1); case INST_OVER: { - int opnd; + int opnd = TclGetUInt4AtPtr(pc+1); - opnd = TclGetUInt4AtPtr(pc+1); objResultPtr = OBJ_AT_DEPTH(opnd); TRACE_WITH_OBJ(("=> "), objResultPtr); NEXT_INST_F(5, 0, 1); } case INST_REVERSE: { - int opnd; Tcl_Obj **a, **b; + int opnd = TclGetUInt4AtPtr(pc+1); - opnd = TclGetUInt4AtPtr(pc+1); a = tosPtr-(opnd-1); b = tosPtr; while (anumLevels++; - Tcl_NRAddCallback(interp, NRCommand, NULL, NULL, NULL, NULL); + Tcl_NRAddCallback(interp, NRCommand, NULL,NULL,NULL,NULL); goto doInvocationFromEval; } } @@ -2737,15 +2733,15 @@ TclExecuteByteCode( if (objc) { pcAdjustment = 1; goto doInvocation; - } else { - /* - * Nothing was expanded, return {}. - */ - - TclNewObj(objResultPtr); - NEXT_INST_F(1, 0, 1); } + /* + * Nothing was expanded, return {}. + */ + + TclNewObj(objResultPtr); + NEXT_INST_F(1, 0, 1); + case INST_INVOKE_STK4: objc = TclGetUInt4AtPtr(pc+1); pcAdjustment = 5; @@ -2756,230 +2752,226 @@ TclExecuteByteCode( pcAdjustment = 2; doInvocation: - { - objv = &OBJ_AT_DEPTH(objc-1); - cleanup = objc; + objv = &OBJ_AT_DEPTH(objc-1); + cleanup = objc; doInvocationFromEval: #ifdef TCL_COMPILE_DEBUG - if (tclTraceExec >= 2) { - int i; + if (tclTraceExec >= 2) { + int i; - if (traceInstructions) { - strncpy(cmdNameBuf, TclGetString(objv[0]), 20); - TRACE(("%u => call ", objc)); - } else { - fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, - (unsigned)(pc - codePtr->codeStart)); - } - for (i = 0; i < objc; i++) { - TclPrintObject(stdout, objv[i], 15); - fprintf(stdout, " "); - } - fprintf(stdout, "\n"); - fflush(stdout); + if (traceInstructions) { + strncpy(cmdNameBuf, TclGetString(objv[0]), 20); + TRACE(("%u => call ", objc)); + } else { + fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels, + (unsigned)(pc - codePtr->codeStart)); } + for (i = 0; i < objc; i++) { + TclPrintObject(stdout, objv[i], 15); + fprintf(stdout, " "); + } + fprintf(stdout, "\n"); + fflush(stdout); + } #endif /*TCL_COMPILE_DEBUG*/ - /* - * Finally, let TclEvalObjv handle the command. - * - * TIP #280: Record the last piece of info needed by - * 'TclGetSrcInfoForPc', and push the frame. - */ + /* + * Finally, let TclEvalObjv handle the command. + * + * TIP #280: Record the last piece of info needed by + * 'TclGetSrcInfoForPc', and push the frame. + */ - bcFramePtr->data.tebc.pc = (char *) pc; - iPtr->cmdFramePtr = bcFramePtr; + bcFramePtr->data.tebc.pc = (char *) pc; + iPtr->cmdFramePtr = bcFramePtr; - /* - * Reset the instructionCount variable, since we're about to check - * for async stuff anyway while processing TclEvalObjv - */ + /* + * Reset the instructionCount variable, since we're about to check for + * async stuff anyway while processing TclEvalObjv + */ - TAUX.instructionCount = 1; + TAUX.instructionCount = 1; - TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, - codePtr, bcFramePtr, pc - codePtr->codeStart); + TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc, + codePtr, bcFramePtr, pc - codePtr->codeStart); - DECACHE_STACK_INFO(); + DECACHE_STACK_INFO(); - TRESULT = TclNREvalObjv(interp, objc, objv, - (*pc == INST_EVAL_STK) ? 0 : TCL_EVAL_NOERR, NULL); - TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); - CACHE_STACK_INFO(); + TRESULT = TclNREvalObjv(interp, objc, objv, + (*pc == INST_EVAL_STK) ? 0 : TCL_EVAL_NOERR, NULL); + TRESULT = TclNRRunCallbacks(interp, TRESULT, BP->rootPtr, 1); + CACHE_STACK_INFO(); - if (TOP_CB(interp) != BP->rootPtr) { - NRE_ASSERT(TRESULT == TCL_OK); - pc += pcAdjustment; + if (TOP_CB(interp) != BP->rootPtr) { + NRE_ASSERT(TRESULT == TCL_OK); + pc += pcAdjustment; - nonRecursiveCallSetup: { - TEOV_callback *callbackPtr = TOP_CB(interp); - int type = PTR2INT(callbackPtr->data[0]); - ClientData param = callbackPtr->data[1]; + nonRecursiveCallSetup: + { + TEOV_callback *callbackPtr = TOP_CB(interp); + int type = PTR2INT(callbackPtr->data[0]); + ClientData param = callbackPtr->data[1]; - pcAdjustment = 0; /* silence warning */ + pcAdjustment = 0; /* silence warning */ - NRE_ASSERT(callbackPtr != BP->rootPtr); - NRE_ASSERT(callbackPtr->procPtr == NRCallTEBC); + NRE_ASSERT(callbackPtr != BP->rootPtr); + NRE_ASSERT(callbackPtr->procPtr == NRCallTEBC); - TOP_CB(interp) = callbackPtr->nextPtr; - TCLNR_FREE(interp, callbackPtr); + TOP_CB(interp) = callbackPtr->nextPtr; + TCLNR_FREE(interp, callbackPtr); - NR_DATA_BURY(); - switch (type) { - case TCL_NR_BC_TYPE: - if (param) { - codePtr = param; - goto nonRecursiveCallStart; - } else { - OBP = BP; - goto resumeCoroutine; - } - break; - case TCL_NR_TAILCALL_TYPE: - /* - * A request to perform a tailcall: just drop this - * bytecode. */ + NR_DATA_BURY(); + switch (type) { + case TCL_NR_BC_TYPE: + if (param) { + codePtr = param; + goto nonRecursiveCallStart; + } else { + OBP = BP; + goto resumeCoroutine; + } + break; + case TCL_NR_TAILCALL_TYPE: + /* + * A request to perform a tailcall: just drop this + * bytecode. + */ #ifdef TCL_COMPILE_DEBUG - if (traceInstructions) { - fprintf(stdout, " Tailcall request received\n"); - } + if (traceInstructions) { + fprintf(stdout, " Tailcall request received\n"); + } #endif /* TCL_COMPILE_DEBUG */ - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); - - if (catchTop != initCatchTop) { - TclClearTailcall(interp, param); - iPtr->varFramePtr->tailcallPtr = NULL; - TRESULT = TCL_ERROR; - Tcl_SetResult(interp, - "tailcall called from within a catch environment", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", - "ILLEGAL", NULL); - pc--; - goto checkForCatch; - } - iPtr->varFramePtr->tailcallPtr = param; - TclSpliceTailcall(interp, param); - goto abnormalReturn; - case TCL_NR_YIELD_TYPE: { /* [yield] */ - CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; - - if (!corPtr) { - Tcl_SetResult(interp, - "yield can only be called in a coroutine", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", - "ILLEGAL_YIELD", NULL); - TRESULT = TCL_ERROR; - pc--; - goto checkForCatch; - } - - NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); - NRE_ASSERT(corPtr->stackLevel != NULL); - NRE_ASSERT(BP == corPtr->eePtr->bottomPtr); - if (corPtr->stackLevel != &TAUX) { - Tcl_SetResult(interp, "cannot yield: C stack busy", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "COROUTINE", - "CANT_YIELD", NULL); - TRESULT = TCL_ERROR; - pc--; - goto checkForCatch; - } - - /* - * Mark suspended, save our state and return - */ - - corPtr->stackLevel = NULL; - iPtr->execEnvPtr = corPtr->callerEEPtr; - OBP = *corPtr->callerBPPtr; - goto returnToCaller; + iPtr->cmdFramePtr = bcFramePtr->nextPtr; + TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + + if (catchTop != initCatchTop) { + TclClearTailcall(interp, param); + iPtr->varFramePtr->tailcallPtr = NULL; + TRESULT = TCL_ERROR; + Tcl_SetResult(interp, + "tailcall called from within a catch environment", + TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", + NULL); + pc--; + goto checkForCatch; } - default: - Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); + iPtr->varFramePtr->tailcallPtr = param; + TclSpliceTailcall(interp, param); + goto abnormalReturn; + case TCL_NR_YIELD_TYPE: { /* [yield] */ + CoroutineData *corPtr = iPtr->execEnvPtr->corPtr; + + if (!corPtr) { + Tcl_SetResult(interp, + "yield can only be called in a coroutine", + TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", + "ILLEGAL_YIELD", NULL); + TRESULT = TCL_ERROR; + pc--; + goto checkForCatch; } - } - } - pc += pcAdjustment; + NRE_ASSERT(iPtr->execEnvPtr == corPtr->eePtr); + NRE_ASSERT(corPtr->stackLevel != NULL); + NRE_ASSERT(BP == corPtr->eePtr->bottomPtr); + if (corPtr->stackLevel != &TAUX) { + Tcl_SetResult(interp, "cannot yield: C stack busy", + TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "COROUTINE", + "CANT_YIELD", NULL); + TRESULT = TCL_ERROR; + pc--; + goto checkForCatch; + } - nonRecursiveCallReturn: + /* + * Mark suspended, save our state and return + */ - if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { - iPtr->flags |= ERR_ALREADY_LOGGED; - codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; + corPtr->stackLevel = NULL; + iPtr->execEnvPtr = corPtr->callerEEPtr; + OBP = *corPtr->callerBPPtr; + goto returnToCaller; + } + default: + Tcl_Panic("TEBC: TRCB sent us a callback we cannot handle!"); + } } - NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); - iPtr->cmdFramePtr = bcFramePtr->nextPtr; - TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + } - /* - * If the CallFrame is marked as tailcalling, keep tailcalling - */ + pc += pcAdjustment; - if (iPtr->varFramePtr->tailcallPtr) { - if (catchTop != initCatchTop) { - TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); - iPtr->varFramePtr->tailcallPtr = NULL; - TRESULT = TCL_ERROR; - Tcl_SetResult(interp, - "tailcall called from within a catch environment", - TCL_STATIC); - Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", - NULL); - pc--; - goto checkForCatch; - } - goto abnormalReturn; - } + nonRecursiveCallReturn: + if (codePtr->flags & TCL_BYTECODE_RECOMPILE) { + iPtr->flags |= ERR_ALREADY_LOGGED; + codePtr->flags &= ~TCL_BYTECODE_RECOMPILE; + } + NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr); + iPtr->cmdFramePtr = bcFramePtr->nextPtr; + TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr); + + /* + * If the CallFrame is marked as tailcalling, keep tailcalling + */ - if (iPtr->execEnvPtr->rewind) { + if (iPtr->varFramePtr->tailcallPtr) { + if (catchTop != initCatchTop) { + TclClearTailcall(interp, iPtr->varFramePtr->tailcallPtr); + iPtr->varFramePtr->tailcallPtr = NULL; TRESULT = TCL_ERROR; - goto abnormalReturn; + Tcl_SetResult(interp, + "tailcall called from within a catch environment", + TCL_STATIC); + Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL); + pc--; + goto checkForCatch; } + goto abnormalReturn; + } - if (TRESULT == TCL_OK) { - Tcl_Obj *objPtr; + if (iPtr->execEnvPtr->rewind) { + TRESULT = TCL_ERROR; + goto abnormalReturn; + } + + if (TRESULT == TCL_OK) { + Tcl_Obj *objPtr; #ifndef TCL_COMPILE_DEBUG - if (*pc == INST_POP) { - NEXT_INST_V(1, cleanup, 0); - } + if (*pc == INST_POP) { + NEXT_INST_V(1, cleanup, 0); + } #endif - /* - * Push the call's object result and continue execution with - * the next instruction. - */ + /* + * Push the call's object result and continue execution with the + * next instruction. + */ - TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", - objc, cmdNameBuf), Tcl_GetObjResult(interp)); + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", + objc, cmdNameBuf), Tcl_GetObjResult(interp)); - objResultPtr = Tcl_GetObjResult(interp); + objResultPtr = Tcl_GetObjResult(interp); - /* - * Reset the interp's result to avoid possible duplications of - * large objects [Bug 781585]. We do not call Tcl_ResetResult - * to avoid any side effects caused by the resetting of - * errorInfo and errorCode [Bug 804681], which are not needed - * here. We chose instead to manipulate the interp's object - * result directly. - * - * Note that the result object is now in objResultPtr, it - * keeps the refCount it had in its role of - * iPtr->objResultPtr. - */ + /* + * Reset the interp's result to avoid possible duplications of + * large objects [Bug 781585]. We do not call Tcl_ResetResult to + * avoid any side effects caused by the resetting of errorInfo and + * errorCode [Bug 804681], which are not needed here. We chose + * instead to manipulate the interp's object result directly. + * + * Note that the result object is now in objResultPtr, it keeps + * the refCount it had in its role of iPtr->objResultPtr. + */ - TclNewObj(objPtr); - Tcl_IncrRefCount(objPtr); - iPtr->objResultPtr = objPtr; - NEXT_INST_V(0, cleanup, -1); - } else { - pc--; - goto processExceptionReturn; - } + TclNewObj(objPtr); + Tcl_IncrRefCount(objPtr); + iPtr->objResultPtr = objPtr; + NEXT_INST_V(0, cleanup, -1); + } else { + pc--; + goto processExceptionReturn; } #if TCL_SUPPORT_84_BYTECODE @@ -2992,7 +2984,7 @@ TclExecuteByteCode( */ int opnd, numArgs; - Tcl_Obj *objPtr; + Tcl_Obj *objPtr, *tmpPtr1, *tmpPtr2; opnd = TclGetUInt1AtPtr(pc+1); if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { @@ -3011,12 +3003,11 @@ TclExecuteByteCode( if (numArgs == 0) { PUSH_OBJECT(objPtr); } else if (numArgs == 1) { - Tcl_Obj *tmpPtr1 = POP_OBJECT(); + tmpPtr1 = POP_OBJECT(); PUSH_OBJECT(objPtr); PUSH_OBJECT(tmpPtr1); Tcl_DecrRefCount(tmpPtr1); } else { - Tcl_Obj *tmpPtr1, *tmpPtr2; tmpPtr2 = POP_OBJECT(); tmpPtr1 = POP_OBJECT(); PUSH_OBJECT(objPtr); @@ -3077,7 +3068,7 @@ TclExecuteByteCode( } /* - * --------------------------------------------------------- + * ----------------------------------------------------------------- * Start of INST_LOAD instructions. * * WARNING: more 'goto' here than your doctor recommended! The different @@ -3086,9 +3077,8 @@ TclExecuteByteCode( */ { int opnd, pcAdjustment; - Tcl_Obj *part1Ptr, *part2Ptr; + Tcl_Obj *objPtr, *part1Ptr, *part2Ptr; Var *varPtr, *arrayPtr; - Tcl_Obj *objPtr; case INST_LOAD_SCALAR1: instLoadScalar1: @@ -3235,11 +3225,7 @@ TclExecuteByteCode( /* * End of INST_LOAD instructions. - * --------------------------------------------------------- - */ - - /* - * --------------------------------------------------------- + * ----------------------------------------------------------------- * Start of INST_STORE and related instructions. * * WARNING: more 'goto' here than your doctor recommended! The different @@ -3249,9 +3235,8 @@ TclExecuteByteCode( { int opnd, pcAdjustment, storeFlags; - Tcl_Obj *part1Ptr, *part2Ptr; + Tcl_Obj *part1Ptr, *part2Ptr, *objPtr, *valuePtr; Var *varPtr, *arrayPtr; - Tcl_Obj *objPtr, *valuePtr; case INST_STORE_ARRAY4: opnd = TclGetUInt4AtPtr(pc+1); @@ -3500,11 +3485,7 @@ TclExecuteByteCode( /* * End of INST_STORE and related instructions. - * --------------------------------------------------------- - */ - - /* - * --------------------------------------------------------- + * ----------------------------------------------------------------- * Start of INST_INCR instructions. * * WARNING: more 'goto' here than your doctor recommended! The different @@ -3515,13 +3496,12 @@ TclExecuteByteCode( /*TODO: Consider more untangling here; merge with LOAD and STORE ? */ { - Tcl_Obj *objPtr, *incrPtr; + Tcl_Obj *objPtr, *incrPtr, *part1Ptr, *part2Ptr; int opnd, pcAdjustment; #ifndef NO_WIDE_TYPE Tcl_WideInt w; #endif long i; - Tcl_Obj *part1Ptr, *part2Ptr; Var *varPtr, *arrayPtr; case INST_INCR_SCALAR1: @@ -3646,34 +3626,32 @@ TclExecuteByteCode( goto doneIncr; } #ifndef NO_WIDE_TYPE - { - w = (Tcl_WideInt)augend; + w = (Tcl_WideInt)augend; - TRACE(("%u %ld => ", opnd, i)); - if (Tcl_IsShared(objPtr)) { - objPtr->refCount--; /* We know it's shared. */ - objResultPtr = Tcl_NewWideIntObj(w+i); - Tcl_IncrRefCount(objResultPtr); - varPtr->value.objPtr = objResultPtr; - } else { - objResultPtr = objPtr; + TRACE(("%u %ld => ", opnd, i)); + if (Tcl_IsShared(objPtr)) { + objPtr->refCount--; /* We know it's shared. */ + objResultPtr = Tcl_NewWideIntObj(w+i); + Tcl_IncrRefCount(objResultPtr); + varPtr->value.objPtr = objResultPtr; + } else { + objResultPtr = objPtr; - /* - * We know the sum value is outside the long - * range; use macro form that doesn't range test - * again. - */ + /* + * We know the sum value is outside the long range; + * use macro form that doesn't range test again. + */ - TclSetWideIntObj(objPtr, w+i); - } - goto doneIncr; + TclSetWideIntObj(objPtr, w+i); } + goto doneIncr; #endif } /* end if (type == TCL_NUMBER_LONG) */ #ifndef NO_WIDE_TYPE if (type == TCL_NUMBER_WIDE) { Tcl_WideInt sum; - w = *((const Tcl_WideInt *)ptr); + + w = *((const Tcl_WideInt *) ptr); sum = w + i; /* @@ -3785,20 +3763,17 @@ TclExecuteByteCode( /* * End of INST_INCR instructions. - * --------------------------------------------------------- - */ - - /* - * --------------------------------------------------------- + * ----------------------------------------------------------------- * Start of INST_EXIST instructions. */ + { Tcl_Obj *part1Ptr, *part2Ptr; Var *varPtr, *arrayPtr; + int opnd; - case INST_EXIST_SCALAR: { - int opnd = TclGetUInt4AtPtr(pc+1); - + case INST_EXIST_SCALAR: + opnd = TclGetUInt4AtPtr(pc+1); varPtr = LOCAL(opnd); while (TclIsVarLink(varPtr)) { varPtr = varPtr->value.linkPtr; @@ -3822,11 +3797,9 @@ TclExecuteByteCode( objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 0, 1); - } - - case INST_EXIST_ARRAY: { - int opnd = TclGetUInt4AtPtr(pc+1); + case INST_EXIST_ARRAY: + opnd = TclGetUInt4AtPtr(pc+1); part2Ptr = OBJ_AT_TOS; arrayPtr = LOCAL(opnd); while (TclIsVarLink(arrayPtr)) { @@ -3857,7 +3830,6 @@ TclExecuteByteCode( objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1); TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 1, 1); - } case INST_EXIST_ARRAY_STK: cleanup = 2; @@ -3894,82 +3866,201 @@ TclExecuteByteCode( /* * End of INST_EXIST instructions. - * --------------------------------------------------------- + * ----------------------------------------------------------------- + * Start of INST_UNSET instructions. */ - case INST_UPVAR: { - int opnd; - Var *varPtr, *otherPtr; + { + Tcl_Obj *part1Ptr, *part2Ptr; + Var *varPtr, *arrayPtr; + int opnd, flags, localResult; - TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); + case INST_UNSET_SCALAR: + flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; + opnd = TclGetUInt4AtPtr(pc+2); + varPtr = LOCAL(opnd); + while (TclIsVarLink(varPtr)) { + varPtr = varPtr->value.linkPtr; + } + TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd)); + if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) { + /* + * No errors, no traces, no searches: just make the variable cease + * to exist. + */ - { - CallFrame *framePtr, *savedFramePtr; + if (!TclIsVarUndefined(varPtr)) { + Tcl_DecrRefCount(varPtr->value.objPtr); + } else if (flags & TCL_LEAVE_ERR_MSG) { + goto slowUnsetScalar; + } + varPtr->value.objPtr = NULL; + NEXT_INST_F(6, 0, 0); + } + slowUnsetScalar: + DECACHE_STACK_INFO(); + localResult = TclPtrUnsetVar(interp, varPtr, NULL, NULL, NULL, flags, + opnd); + CACHE_STACK_INFO(); + if (localResult != TCL_OK && flags) { + goto errorInUnset; + } + NEXT_INST_F(6, 0, 0); - TRESULT = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr); - if (TRESULT != -1) { + case INST_UNSET_ARRAY: + flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; + opnd = TclGetUInt4AtPtr(pc+2); + part2Ptr = OBJ_AT_TOS; + arrayPtr = LOCAL(opnd); + while (TclIsVarLink(arrayPtr)) { + arrayPtr = arrayPtr->value.linkPtr; + } + TRACE(("%s %u \"%.30s\"\n", (flags?"normal":"noerr"), opnd, O2S(part2Ptr))); + if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) { + varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr); + if (varPtr && TclIsVarDirectUnsettable(varPtr)) { /* - * Locate the other variable. + * No nasty traces and element exists, so we can proceed to + * unset it. Might still not exist though... */ - savedFramePtr = iPtr->varFramePtr; - iPtr->varFramePtr = framePtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr = savedFramePtr; - if (otherPtr) { - TRESULT = TCL_OK; - goto doLinkVars; + if (!TclIsVarUndefined(varPtr)) { + Tcl_DecrRefCount(varPtr->value.objPtr); + } else if (flags & TCL_LEAVE_ERR_MSG) { + goto slowUnsetArray; } + varPtr->value.objPtr = NULL; + NEXT_INST_F(6, 1, 0); } - TRESULT = TCL_ERROR; - goto checkForCatch; } + slowUnsetArray: + DECACHE_STACK_INFO(); + varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, flags, "unset", + 0, 0, arrayPtr, opnd); + if (!varPtr && (flags & TCL_LEAVE_ERR_MSG)) { + CACHE_STACK_INFO(); + goto errorInUnset; + } + if (varPtr) { + localResult = TclPtrUnsetVar(interp, varPtr, arrayPtr, NULL, + part2Ptr, flags, opnd); + } else { + localResult = TCL_OK; + } + CACHE_STACK_INFO(); + if (localResult != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { + goto errorInUnset; + } + NEXT_INST_F(6, 1, 0); - case INST_VARIABLE: - TRACE(("variable ")); - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - if (otherPtr) { + case INST_UNSET_ARRAY_STK: + flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; + cleanup = 2; + part2Ptr = OBJ_AT_TOS; /* element name */ + part1Ptr = OBJ_UNDER_TOS; /* array name */ + TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"), + O2S(part1Ptr), O2S(part2Ptr))); + goto doUnsetStk; + + case INST_UNSET_STK: + flags = TclGetUInt1AtPtr(pc+1) ? TCL_LEAVE_ERR_MSG : 0; + cleanup = 1; + part2Ptr = NULL; + part1Ptr = OBJ_AT_TOS; /* variable name */ + TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr))); + + doUnsetStk: + DECACHE_STACK_INFO(); + localResult = TclObjUnsetVar2(interp, part1Ptr, part2Ptr, flags); + CACHE_STACK_INFO(); + if (localResult != TCL_OK && (flags & TCL_LEAVE_ERR_MSG)) { + goto errorInUnset; + } + NEXT_INST_V(2, cleanup, 0); + + errorInUnset: + TRESULT = TCL_ERROR; + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); + goto checkForCatch; + } + + /* + * End of INST_UNSET instructions. + * ----------------------------------------------------------------- + * Start of variable linking instructions. + */ + + { + int opnd; + Var *varPtr, *otherPtr; + + case INST_UPVAR: { + CallFrame *framePtr, *savedFramePtr; + + TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS); + + TRESULT = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr); + if (TRESULT == -1) { /* - * Do the [variable] magic. + * Locate the other variable. */ - TclSetVarNamespaceVar(otherPtr); - TRESULT = TCL_OK; - goto doLinkVars; + savedFramePtr = iPtr->varFramePtr; + iPtr->varFramePtr = framePtr; + otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, + TCL_LEAVE_ERR_MSG, "access", /*createPart1*/ 1, + /*createPart2*/ 1, &varPtr); + iPtr->varFramePtr = savedFramePtr; + if (otherPtr) { + TRESULT = TCL_OK; + goto doLinkVars; + } } TRESULT = TCL_ERROR; goto checkForCatch; + } - case INST_NSUPVAR: - TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); + case INST_NSUPVAR: { + Tcl_Namespace *nsPtr, *savedNsPtr; - { - Tcl_Namespace *nsPtr, *savedNsPtr; - - TRESULT = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr); - if (TRESULT == TCL_OK) { - /* - * Locate the other variable. - */ + TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS); + TRESULT = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr); + if (TRESULT == TCL_OK) { + /* + * Locate the other variable. + */ - savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; - iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; - otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, - (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", - /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); - iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; - if (otherPtr) { - goto doLinkVars; - } + savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr; + iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr; + otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr; + if (otherPtr) { + goto doLinkVars; } + } + TRESULT = TCL_ERROR; + goto checkForCatch; + } + + case INST_VARIABLE: + TRACE(("variable ")); + otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL, + (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access", + /*createPart1*/ 1, /*createPart2*/ 1, &varPtr); + if (!otherPtr) { TRESULT = TCL_ERROR; goto checkForCatch; } + /* + * Do the [variable] magic. + */ + + TclSetVarNamespaceVar(otherPtr); + TRESULT = TCL_OK; + doLinkVars: /* @@ -4020,6 +4111,11 @@ TclExecuteByteCode( NEXT_INST_F(5, 1, 0); } + /* + * End of variable linking instructions. + * ----------------------------------------------------------------- + */ + case INST_JUMP1: { int opnd = TclGetInt1AtPtr(pc+1); @@ -4165,7 +4261,7 @@ TclExecuteByteCode( } /* - * --------------------------------------------------------- + * ----------------------------------------------------------------- * Start of INST_LIST and related instructions. */ @@ -4587,7 +4683,8 @@ TclExecuteByteCode( /* * End of INST_LIST and related instructions. - * --------------------------------------------------------- + * ----------------------------------------------------------------- + * Start of string-related instructions. */ case INST_STR_EQ: @@ -4791,6 +4888,7 @@ TclExecuteByteCode( /* * Get char length to calulate what 'end' means. */ + length = Tcl_GetCharLength(valuePtr); TRESULT = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index); if (TRESULT != TCL_OK) { @@ -4865,12 +4963,29 @@ TclExecuteByteCode( /* * Reuse value2Ptr object already on stack if possible. Adjustment is * 2 due to the nocase byte - * TODO: consider peephole opt. */ TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + + /* + * Peep-hole optimisation: if you're about to jump, do jump from here. + */ + + pc += 2; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + } +#endif objResultPtr = TCONST(match); - NEXT_INST_F(2, 2, 1); + NEXT_INST_F(0, 2, 1); } case INST_REGEXP: { @@ -4899,14 +5014,37 @@ TclExecuteByteCode( O2S(valuePtr), O2S(value2Ptr)), objResultPtr); TRESULT = TCL_ERROR; goto checkForCatch; - } else { - TRACE(("%.20s %.20s => %d\n", - O2S(valuePtr), O2S(value2Ptr), match)); - objResultPtr = TCONST(match); - NEXT_INST_F(2, 2, 1); } + + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); + + /* + * Peep-hole optimisation: if you're about to jump, do jump from here. + */ + + pc += 2; +#ifndef TCL_COMPILE_DEBUG + switch (*pc) { + case INST_JUMP_FALSE1: + NEXT_INST_F((match? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE1: + NEXT_INST_F((match? TclGetInt1AtPtr(pc+1) : 2), 2, 0); + case INST_JUMP_FALSE4: + NEXT_INST_F((match? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); + case INST_JUMP_TRUE4: + NEXT_INST_F((match? TclGetInt4AtPtr(pc+1) : 5), 2, 0); + } +#endif + objResultPtr = TCONST(match); + NEXT_INST_F(0, 2, 1); } + /* + * End of string-related instructions. + * ----------------------------------------------------------------- + * Start of numeric operator instructions. + */ + case INST_EQ: case INST_NEQ: case INST_LT: @@ -6933,6 +7071,11 @@ TclExecuteByteCode( NEXT_INST_F(1, 0, 0); } + /* + * End of numeric operator instructions. + * ----------------------------------------------------------------- + */ + case INST_BREAK: /* DECACHE_STACK_INFO(); @@ -7185,10 +7328,18 @@ TclExecuteByteCode( NEXT_INST_F(2*code -1, 1, 0); } + /* + * ----------------------------------------------------------------- + * Start of dictionary-related instructions. + */ + { - int opnd, opnd2, allocateDict; - Tcl_Obj *dictPtr, *valuePtr, *val2Ptr; + int opnd, opnd2, allocateDict, done, i, length, allocdict; + Tcl_Obj *dictPtr, *valuePtr, *val2Ptr, *statePtr, *keyPtr; + Tcl_Obj *emptyPtr, **keyPtrPtr; Var *varPtr; + Tcl_DictSearch *searchPtr; + DictUpdateInfo *duiPtr; case INST_DICT_GET: opnd = TclGetUInt4AtPtr(pc+1); @@ -7390,26 +7541,24 @@ TclExecuteByteCode( if (valuePtr == NULL) { valuePtr = Tcl_NewListObj(1, &OBJ_AT_TOS); - } else if (Tcl_IsShared(valuePtr)) { + break; + } + if (Tcl_IsShared(valuePtr)) { valuePtr = Tcl_DuplicateObj(valuePtr); TRESULT = Tcl_ListObjAppendElement(interp, valuePtr, OBJ_AT_TOS); if (TRESULT != TCL_OK) { TclDecrRefCount(valuePtr); - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto checkForCatch; } } else { TRESULT = Tcl_ListObjAppendElement(interp, valuePtr, OBJ_AT_TOS); - if (TRESULT != TCL_OK) { - if (allocateDict) { - TclDecrRefCount(dictPtr); - } - goto checkForCatch; + } + if (TRESULT != TCL_OK) { + if (allocateDict) { + TclDecrRefCount(dictPtr); } + goto checkForCatch; } break; default: @@ -7449,13 +7598,6 @@ TclExecuteByteCode( #endif TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); NEXT_INST_F(5, 2, 1); - } - - { - int opnd, done; - Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr; - Var *varPtr; - Tcl_DictSearch *searchPtr; case INST_DICT_FIRST: opnd = TclGetUInt4AtPtr(pc+1); @@ -7540,13 +7682,6 @@ TclExecuteByteCode( Tcl_IncrRefCount(emptyPtr); } NEXT_INST_F(5, 0, 0); - } - - { - int opnd, opnd2, i, length, allocdict; - Tcl_Obj **keyPtrPtr, *dictPtr, *valuePtr; - DictUpdateInfo *duiPtr; - Var *varPtr; case INST_DICT_UPDATE_START: opnd = TclGetUInt4AtPtr(pc+1); @@ -7674,6 +7809,11 @@ TclExecuteByteCode( NEXT_INST_F(9, 1, 0); } + /* + * End of dictionary-related instructions. + * ----------------------------------------------------------------- + */ + default: Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc); } /* end of switch on opCode */ diff --git a/generic/tclInt.h b/generic/tclInt.h index c1da3d4..97a5e44 100644 --- a/generic/tclInt.h +++ b/generic/tclInt.h @@ -15,7 +15,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclInt.h,v 1.455 2010/01/29 16:17:20 nijtmans Exp $ + * RCS: @(#) $Id: tclInt.h,v 1.456 2010/01/30 16:33:25 dkf Exp $ */ #ifndef _TCLINT @@ -808,6 +808,9 @@ typedef struct VarInHash { #define TclIsVarDirectWritable(varPtr) \ !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_WRITE|VAR_DEAD_HASH)) +#define TclIsVarDirectUnsettable(varPtr) \ + !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_UNSET|VAR_DEAD_HASH)) + #define TclIsVarDirectModifyable(varPtr) \ ( !((varPtr)->flags & (VAR_ARRAY|VAR_LINK|VAR_TRACED_READ|VAR_TRACED_WRITE)) \ && (varPtr)->value.objPtr) @@ -3392,6 +3395,9 @@ MODULE_SCOPE int TclCompileSubstCmd(Tcl_Interp *interp, MODULE_SCOPE int TclCompileSwitchCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); +MODULE_SCOPE int TclCompileUnsetCmd(Tcl_Interp *interp, + Tcl_Parse *parsePtr, Command *cmdPtr, + struct CompileEnv *envPtr); MODULE_SCOPE int TclCompileUpvarCmd(Tcl_Interp *interp, Tcl_Parse *parsePtr, Command *cmdPtr, struct CompileEnv *envPtr); @@ -3569,6 +3575,10 @@ MODULE_SCOPE Tcl_Obj * TclPtrIncrObjVar(Tcl_Interp *interp, const int flags, int index); MODULE_SCOPE int TclPtrObjMakeUpvar(Tcl_Interp *interp, Var *otherPtr, Tcl_Obj *myNamePtr, int myFlags, int index); +MODULE_SCOPE int TclPtrUnsetVar(Tcl_Interp *interp, Var *varPtr, + Var *arrayPtr, Tcl_Obj *part1Ptr, + Tcl_Obj *part2Ptr, const int flags, + int index); MODULE_SCOPE void TclInvalidateNsPath(Namespace *nsPtr); /* diff --git a/generic/tclVar.c b/generic/tclVar.c index 54699ce..c2aea55 100644 --- a/generic/tclVar.c +++ b/generic/tclVar.c @@ -16,7 +16,7 @@ * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclVar.c,v 1.184 2009/11/20 00:19:46 dgp Exp $ + * RCS: @(#) $Id: tclVar.c,v 1.185 2010/01/30 16:33:25 dkf Exp $ */ #include "tclInt.h" @@ -158,7 +158,7 @@ static ArraySearch * ParseSearchId(Tcl_Interp *interp, const Var *varPtr, Tcl_Obj *varNamePtr, Tcl_Obj *handleObj); static void UnsetVarStruct(Var *varPtr, Var *arrayPtr, Interp *iPtr, Tcl_Obj *part1Ptr, - Tcl_Obj *part2Ptr, int flags); + Tcl_Obj *part2Ptr, int flags, int index); static int SetArraySearchObj(Tcl_Interp *interp, Tcl_Obj *objPtr); @@ -2204,10 +2204,7 @@ TclObjUnsetVar2( * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, * TCL_LEAVE_ERR_MSG. */ { - Var *varPtr; - Interp *iPtr = (Interp *) interp; - Var *arrayPtr; - int result; + Var *varPtr, *arrayPtr; varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, flags, "unset", /*createPart1*/ 0, /*createPart2*/ 0, &arrayPtr); @@ -2215,7 +2212,52 @@ TclObjUnsetVar2( return TCL_ERROR; } - result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); + return TclPtrUnsetVar(interp, varPtr, arrayPtr, part1Ptr, part2Ptr, flags, + -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclPtrUnsetVar -- + * + * Delete a variable, given the pointers to the variable's (and possibly + * containing array's) VAR structure. + * + * Results: + * Returns TCL_OK if the variable was successfully deleted, TCL_ERROR if + * the variable can't be unset. In the event of an error, if the + * TCL_LEAVE_ERR_MSG flag is set then an error message is left in the + * interp's result. + * + * Side effects: + * If varPtr and arrayPtr indicate a local or global variable in interp, + * it is deleted. If varPtr is an array reference and part2Ptr is NULL, + * then the whole array is deleted. + * + *---------------------------------------------------------------------- + */ + +int +TclPtrUnsetVar( + Tcl_Interp *interp, /* Command interpreter in which varName is to + * be looked up. */ + register Var *varPtr, /* The variable to be unset. */ + Var *arrayPtr, /* NULL for scalar variables, pointer to the + * containing array otherwise. */ + Tcl_Obj *part1Ptr, /* Name of an array (if part2 is non-NULL) or + * the name of a variable. */ + Tcl_Obj *part2Ptr, /* If non-NULL, gives the name of an element + * in the array part1. */ + const int flags, /* OR-ed combination of any of + * TCL_GLOBAL_ONLY, TCL_NAMESPACE_ONLY, + * TCL_LEAVE_ERR_MSG. */ + int index) /* Index into the local variable table of the + * variable, or -1. Only used when part1Ptr is + * NULL. */ +{ + Interp *iPtr = (Interp *) interp; + int result = (TclIsVarUndefined(varPtr)? TCL_ERROR : TCL_OK); /* * Keep the variable alive until we're done with it. We used to @@ -2228,7 +2270,7 @@ TclObjUnsetVar2( VarHashRefCount(varPtr)++; } - UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags); + UnsetVarStruct(varPtr, arrayPtr, iPtr, part1Ptr, part2Ptr, flags, index); /* * It's an error to unset an undefined variable. @@ -2237,7 +2279,7 @@ TclObjUnsetVar2( if (result != TCL_OK) { if (flags & TCL_LEAVE_ERR_MSG) { TclObjVarErrMsg(interp, part1Ptr, part2Ptr, "unset", - ((arrayPtr == NULL) ? noSuchVar : noSuchElement), -1); + ((arrayPtr == NULL) ? noSuchVar : noSuchElement), index); Tcl_SetErrorCode(interp, "TCL", "UNSET", "VARNAME", NULL); } } @@ -2294,7 +2336,8 @@ UnsetVarStruct( Interp *iPtr, Tcl_Obj *part1Ptr, Tcl_Obj *part2Ptr, - int flags) + int flags, + int index) { Var dummyVar; int traced = TclIsVarTraced(varPtr) @@ -2364,7 +2407,7 @@ UnsetVarStruct( TclObjCallVarTraces(iPtr, arrayPtr, &dummyVar, part1Ptr, part2Ptr, (flags & (TCL_GLOBAL_ONLY|TCL_NAMESPACE_ONLY)) | TCL_TRACE_UNSETS, - /* leaveErrMsg */ 0, -1); + /* leaveErrMsg */ 0, index); /* * The traces that we just called may have triggered a change in @@ -4418,7 +4461,7 @@ TclDeleteNamespaceVars( * hash. */ Tcl_GetVariableFullName(interp, (Tcl_Var) varPtr, objPtr); UnsetVarStruct(varPtr, NULL, iPtr, /* part1 */ objPtr, - NULL, flags); + NULL, flags, -1); Tcl_DecrRefCount(objPtr); /* free no longer needed obj */ @@ -4506,7 +4549,8 @@ TclDeleteVars( */ VarHashInvalidateEntry(varPtr); - UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags); + UnsetVarStruct(varPtr, NULL, iPtr, VarHashGetKey(varPtr), NULL, flags, + -1); } VarHashDeleteTable(tablePtr); } @@ -4548,7 +4592,7 @@ TclDeleteCompiledLocalVars( namePtrPtr = &localName(framePtr, 0); for (i=0 ; inumCompiledLocals = 0; } -- cgit v0.12