summaryrefslogtreecommitdiffstats
path: root/generic/tclExecute.c
diff options
context:
space:
mode:
authordkf <donal.k.fellows@manchester.ac.uk>2010-01-30 16:33:25 (GMT)
committerdkf <donal.k.fellows@manchester.ac.uk>2010-01-30 16:33:25 (GMT)
commit1543f6fbfc86e643435f8db696b104c0327f92e7 (patch)
tree8f37ec0b8c0aca813318fc602941b066f8fd80f2 /generic/tclExecute.c
parent8f9f9d5b20e83bc7ee369eb5a7ba6d66076bf0e6 (diff)
downloadtcl-1543f6fbfc86e643435f8db696b104c0327f92e7.zip
tcl-1543f6fbfc86e643435f8db696b104c0327f92e7.tar.gz
tcl-1543f6fbfc86e643435f8db696b104c0327f92e7.tar.bz2
Make the [unset] command be bytecode compiled.
Diffstat (limited to 'generic/tclExecute.c')
-rw-r--r--generic/tclExecute.c820
1 files changed, 480 insertions, 340 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index 812e68b..cbf59c9 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -14,7 +14,7 @@
* See the file "license.terms" for information on usage and redistribution of
* this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
- * RCS: @(#) $Id: tclExecute.c,v 1.470 2010/01/22 10:22:51 dkf Exp $
+ * RCS: @(#) $Id: tclExecute.c,v 1.471 2010/01/30 16:33:25 dkf Exp $
*/
#include "tclInt.h"
@@ -1879,6 +1879,7 @@ TclExecuteByteCode(
#define ReadTraced(varPtr) ((varPtr)->flags & 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 (a<b) {
@@ -2659,11 +2655,11 @@ TclExecuteByteCode(
goto nonRecursiveCallStart;
}
- {
/*
* INVOCATION BLOCK
*/
+ {
int objc, pcAdjustment;
Tcl_Obj **objv;
@@ -2703,7 +2699,7 @@ TclExecuteByteCode(
*/
iPtr->numLevels++;
- 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 */