summaryrefslogtreecommitdiffstats
path: root/generic/tclExecute.c
diff options
context:
space:
mode:
authorjan.nijtmans <nijtmans@users.sourceforge.net>2014-02-18 10:56:12 (GMT)
committerjan.nijtmans <nijtmans@users.sourceforge.net>2014-02-18 10:56:12 (GMT)
commit340a361ed19847861c47b986eb8d522c1a6cc700 (patch)
tree6b6bdfeebd073f7857ec4893ca9bb3a9b008b3aa /generic/tclExecute.c
parente810c9099a64e6af0d3aad22f673de6edcb68cd7 (diff)
parentecc126bc275141ebdaa83e74dd87645d1680d01c (diff)
downloadtcl-340a361ed19847861c47b986eb8d522c1a6cc700.zip
tcl-340a361ed19847861c47b986eb8d522c1a6cc700.tar.gz
tcl-340a361ed19847861c47b986eb8d522c1a6cc700.tar.bz2
merge novem
Diffstat (limited to 'generic/tclExecute.c')
-rw-r--r--generic/tclExecute.c2009
1 files changed, 1544 insertions, 465 deletions
diff --git a/generic/tclExecute.c b/generic/tclExecute.c
index fe27f0d..9607d6e 100644
--- a/generic/tclExecute.c
+++ b/generic/tclExecute.c
@@ -117,34 +117,32 @@ long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
typedef struct {
ByteCode *codePtr; /* Constant until the BC returns */
/* -----------------------------------------*/
- const unsigned char *pc; /* These fields are used on return TO this */
- ptrdiff_t *catchTop; /* this level: they record the state when a */
- int cleanup; /* new codePtr was received for NR */
- Tcl_Obj *auxObjList; /* execution. */
- int checkInterp;
- CmdFrame cmdFrame;
+ ptrdiff_t *catchTop; /* These fields are used on return TO this */
+ Tcl_Obj *auxObjList; /* this level: they record the state when a */
+ CmdFrame cmdFrame; /* new codePtr was received for NR */
+ /* execution. */
void *stack[1]; /* Start of the actual combined catch and obj
* stacks; the struct will be expanded as
* necessary */
} TEBCdata;
#define TEBC_YIELD() \
- do { \
- esPtr->tosPtr = tosPtr; \
- TD->pc = pc; \
- TD->cleanup = cleanup; \
- TclNRAddCallback(interp, TEBCresume, TD, INT2PTR(1), NULL, NULL); \
+ do { \
+ esPtr->tosPtr = tosPtr; \
+ TclNRAddCallback(interp, TEBCresume, \
+ TD, pc, INT2PTR(cleanup), NULL); \
} while (0)
#define TEBC_DATA_DIG() \
do { \
- pc = TD->pc; \
- cleanup = TD->cleanup; \
tosPtr = esPtr->tosPtr; \
} while (0)
#define PUSH_TAUX_OBJ(objPtr) \
do { \
+ if (auxObjList) { \
+ objPtr->length += auxObjList->length; \
+ } \
objPtr->internalRep.ptrAndLongRep.ptr = auxObjList; \
auxObjList = objPtr; \
} while (0)
@@ -200,7 +198,7 @@ VarHashCreateVar(
/* Verify the stack depth, only when no expansion is in progress */
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
#define CHECK_STACK() \
do { \
ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, \
@@ -233,12 +231,14 @@ VarHashCreateVar(
switch (nCleanup) { \
case 1: goto cleanup1_pushObjResultPtr; \
case 2: goto cleanup2_pushObjResultPtr; \
+ case 0: break; \
} \
} else { \
pc += (pcAdjustment); \
switch (nCleanup) { \
case 1: goto cleanup1; \
case 2: goto cleanup2; \
+ case 0: break; \
} \
} \
} while (0)
@@ -258,6 +258,70 @@ VarHashCreateVar(
} \
} while (0)
+#ifndef TCL_COMPILE_DEBUG
+#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
+ do { \
+ pc += (pcAdjustment); \
+ switch (*pc) { \
+ case INST_JUMP_FALSE1: \
+ NEXT_INST_F(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
+ case INST_JUMP_TRUE1: \
+ NEXT_INST_F(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
+ case INST_JUMP_FALSE4: \
+ NEXT_INST_F(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
+ case INST_JUMP_TRUE4: \
+ NEXT_INST_F(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
+ default: \
+ if ((condition) < 0) { \
+ TclNewLongObj(objResultPtr, -1); \
+ } else { \
+ objResultPtr = TCONST((condition) > 0); \
+ } \
+ NEXT_INST_F(0, (cleanup), 1); \
+ } \
+ } while (0)
+#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
+ do { \
+ pc += (pcAdjustment); \
+ switch (*pc) { \
+ case INST_JUMP_FALSE1: \
+ NEXT_INST_V(((condition)? 2 : TclGetInt1AtPtr(pc+1)), (cleanup), 0); \
+ case INST_JUMP_TRUE1: \
+ NEXT_INST_V(((condition)? TclGetInt1AtPtr(pc+1) : 2), (cleanup), 0); \
+ case INST_JUMP_FALSE4: \
+ NEXT_INST_V(((condition)? 5 : TclGetInt4AtPtr(pc+1)), (cleanup), 0); \
+ case INST_JUMP_TRUE4: \
+ NEXT_INST_V(((condition)? TclGetInt4AtPtr(pc+1) : 5), (cleanup), 0); \
+ default: \
+ if ((condition) < 0) { \
+ TclNewLongObj(objResultPtr, -1); \
+ } else { \
+ objResultPtr = TCONST((condition) > 0); \
+ } \
+ NEXT_INST_V(0, (cleanup), 1); \
+ } \
+ } while (0)
+#else /* TCL_COMPILE_DEBUG */
+#define JUMP_PEEPHOLE_F(condition, pcAdjustment, cleanup) \
+ do{ \
+ if ((condition) < 0) { \
+ TclNewLongObj(objResultPtr, -1); \
+ } else { \
+ objResultPtr = TCONST((condition) > 0); \
+ } \
+ NEXT_INST_F((pcAdjustment), (cleanup), 1); \
+ } while (0)
+#define JUMP_PEEPHOLE_V(condition, pcAdjustment, cleanup) \
+ do{ \
+ if ((condition) < 0) { \
+ TclNewLongObj(objResultPtr, -1); \
+ } else { \
+ objResultPtr = TCONST((condition) > 0); \
+ } \
+ NEXT_INST_V((pcAdjustment), (cleanup), 1); \
+ } while (0)
+#endif
+
/*
* Macros used to cache often-referenced Tcl evaluation stack information
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
@@ -300,6 +364,8 @@ VarHashCreateVar(
#define CURR_DEPTH ((ptrdiff_t) (tosPtr - initTosPtr))
+#define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
+
/*
* Macros used to trace instruction execution. The macros TRACE,
* TRACE_WITH_OBJ, and O2S are only used inside TclNRExecuteByteCode. O2S is
@@ -321,6 +387,8 @@ VarHashCreateVar(
printf a; \
break; \
}
+# define TRACE_ERROR(interp) \
+ TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
# define TRACE_WITH_OBJ(a, objPtr) \
while (traceInstructions) { \
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
@@ -337,6 +405,7 @@ VarHashCreateVar(
#else /* !TCL_COMPILE_DEBUG */
# define TRACE(a)
# define TRACE_APPEND(a)
+# define TRACE_ERROR(interp)
# define TRACE_WITH_OBJ(a, objPtr)
# define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
@@ -377,6 +446,23 @@ VarHashCreateVar(
* ClientData *ptrPtr, int *tPtr);
*/
+#ifdef TCL_WIDE_INT_IS_LONG
+#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(tPtr) = TCL_NUMBER_LONG, \
+ *(ptrPtr) = (ClientData) \
+ (&((objPtr)->internalRep.longValue)), TCL_OK) : \
+ ((objPtr)->typePtr == &tclDoubleType) \
+ ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
+ ? (*(tPtr) = TCL_NUMBER_NAN) \
+ : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
+ *(ptrPtr) = (ClientData) \
+ (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
+ ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
+ (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
+ ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
+ TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
+#else /* !TCL_WIDE_INT_IS_LONG */
#define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
(((objPtr)->typePtr == &tclIntType) \
? (*(tPtr) = TCL_NUMBER_LONG, \
@@ -394,8 +480,9 @@ VarHashCreateVar(
(&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
(((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
- ? TCL_ERROR : \
+ ? (*(tPtr) = TCL_NUMBER_LONG),TCL_ERROR : \
TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
+#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Macro used in this file to save a function call for common uses of
@@ -419,6 +506,13 @@ VarHashCreateVar(
* Tcl_WideInt *wideIntPtr);
*/
+#ifdef TCL_WIDE_INT_IS_LONG
+#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
+ (((objPtr)->typePtr == &tclIntType) \
+ ? (*(wideIntPtr) = (Tcl_WideInt) \
+ ((objPtr)->internalRep.longValue), TCL_OK) : \
+ Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
+#else /* !TCL_WIDE_INT_IS_LONG */
#define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
(((objPtr)->typePtr == &tclWideIntType) \
? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
@@ -426,6 +520,7 @@ VarHashCreateVar(
? (*(wideIntPtr) = (Tcl_WideInt) \
((objPtr)->internalRep.longValue), TCL_OK) : \
Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
+#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Macro used to make the check for type overflow more mnemonic. This works by
@@ -635,20 +730,21 @@ static ExceptionRange * GetExceptRangeForPc(const unsigned char *pc,
int catchOnly, ByteCode *codePtr);
static const char * GetSrcInfoForPc(const unsigned char *pc,
ByteCode *codePtr, int *lengthPtr,
- const unsigned char **pcBeg);
+ const unsigned char **pcBeg, int *cmdIdxPtr);
static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth,
int move);
static void IllegalExprOperandType(Tcl_Interp *interp,
const unsigned char *pc, Tcl_Obj *opndPtr);
static void InitByteCodeExecution(Tcl_Interp *interp);
-static inline int OFFSET(void *ptr);
+static inline int wordSkip(void *ptr);
static void ReleaseDictIterator(Tcl_Obj *objPtr);
/* Useful elsewhere, make available in tclInt.h or stubs? */
static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords);
static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords);
static Tcl_NRPostProc CopyCallback;
static Tcl_NRPostProc ExprObjCallback;
-
+static Tcl_NRPostProc FinalizeOONext;
+static Tcl_NRPostProc FinalizeOONextFilter;
static Tcl_NRPostProc TEBCresume;
/*
@@ -799,7 +895,7 @@ TclCreateExecEnv(
esPtr->nextPtr = NULL;
esPtr->markerPtr = NULL;
esPtr->endPtr = &esPtr->stackWords[size-1];
- esPtr->tosPtr = &esPtr->stackWords[-1];
+ esPtr->tosPtr = STACK_BASE(esPtr);
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
@@ -918,13 +1014,13 @@ TclFinalizeExecution(void)
(TCL_ALLOCALIGN/sizeof(Tcl_Obj *))
/*
- * OFFSET computes how many words have to be skipped until the next aligned
+ * wordSkip computes how many words have to be skipped until the next aligned
* word. Note that we are only interested in the low order bits of ptr, so
* that any possible information loss in PTR2INT is of no consequence.
*/
static inline int
-OFFSET(
+wordSkip(
void *ptr)
{
int mask = TCL_ALLOCALIGN-1;
@@ -937,7 +1033,7 @@ OFFSET(
*/
#define MEMSTART(markerPtr) \
- ((markerPtr) + OFFSET(markerPtr))
+ ((markerPtr) + wordSkip(markerPtr))
/*
*----------------------------------------------------------------------
@@ -982,7 +1078,7 @@ GrowEvaluationStack(
} else {
#ifndef PURIFY
Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
- int offset = OFFSET(tmpMarkerPtr);
+ int offset = wordSkip(tmpMarkerPtr);
if (needed + offset < 0) {
/*
@@ -1020,8 +1116,8 @@ GrowEvaluationStack(
if (esPtr->nextPtr) {
oldPtr = esPtr;
esPtr = oldPtr->nextPtr;
- currElems = esPtr->endPtr - &esPtr->stackWords[-1];
- if (esPtr->markerPtr || (esPtr->tosPtr != &esPtr->stackWords[-1])) {
+ currElems = esPtr->endPtr - STACK_BASE(esPtr);
+ if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) {
Tcl_Panic("STACK: Stack after current is in use");
}
if (esPtr->nextPtr) {
@@ -1033,7 +1129,7 @@ GrowEvaluationStack(
DeleteExecStack(esPtr);
esPtr = oldPtr;
} else {
- currElems = esPtr->endPtr - &esPtr->stackWords[-1];
+ currElems = esPtr->endPtr - STACK_BASE(esPtr);
}
/*
@@ -1187,10 +1283,10 @@ TclStackFree(
while (esPtr->nextPtr) {
esPtr = esPtr->nextPtr;
}
- esPtr->tosPtr = &esPtr->stackWords[-1];
+ esPtr->tosPtr = STACK_BASE(esPtr);
while (esPtr->prevPtr) {
ExecStack *tmpPtr = esPtr->prevPtr;
- if (tmpPtr->tosPtr == &tmpPtr->stackWords[-1]) {
+ if (tmpPtr->tosPtr == STACK_BASE(tmpPtr)) {
DeleteExecStack(tmpPtr);
} else {
break;
@@ -1340,17 +1436,12 @@ Tcl_NRExprObj(
Tcl_Obj *resultPtr)
{
ByteCode *codePtr;
+ Tcl_InterpState state = Tcl_SaveInterpState(interp, TCL_OK);
- /* TODO: consider saving whole state? */
- Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
-
- Tcl_IncrRefCount(saveObjPtr);
-
+ Tcl_ResetResult(interp);
codePtr = CompileExprObj(interp, objPtr);
- /* TODO: Confirm reset not required? */
- /*Tcl_ResetResult(interp);*/
- Tcl_NRAddCallback(interp, ExprObjCallback, saveObjPtr, resultPtr,
+ Tcl_NRAddCallback(interp, ExprObjCallback, state, resultPtr,
NULL, NULL);
return TclNRExecuteByteCode(interp, codePtr);
}
@@ -1361,14 +1452,15 @@ ExprObjCallback(
Tcl_Interp *interp,
int result)
{
- Tcl_Obj *saveObjPtr = data[0];
+ Tcl_InterpState state = data[0];
Tcl_Obj *resultPtr = data[1];
if (result == TCL_OK) {
TclSetDuplicateObj(resultPtr, Tcl_GetObjResult(interp));
- Tcl_SetObjResult(interp, saveObjPtr);
+ (void) Tcl_RestoreInterpState(interp, state);
+ } else {
+ Tcl_DiscardInterpState(state);
}
- TclDecrRefCount(saveObjPtr);
return result;
}
@@ -1785,6 +1877,7 @@ TclIncrObj(
TclSetLongObj(valuePtr, sum);
return TCL_OK;
}
+#ifndef TCL_WIDE_INT_IS_LONG
{
Tcl_WideInt w1 = (Tcl_WideInt) augend;
Tcl_WideInt w2 = (Tcl_WideInt) addend;
@@ -1797,6 +1890,7 @@ TclIncrObj(
TclSetWideIntObj(valuePtr, w1 + w2);
return TCL_OK;
}
+#endif
}
if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
@@ -1816,6 +1910,7 @@ TclIncrObj(
return TCL_ERROR;
}
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
Tcl_WideInt w1, w2, sum;
@@ -1832,6 +1927,7 @@ TclIncrObj(
return TCL_OK;
}
}
+#endif
Tcl_TakeBignumFromObj(interp, valuePtr, &value);
Tcl_GetBignumFromObj(interp, incrPtr, &incr);
@@ -1844,6 +1940,41 @@ TclIncrObj(
/*
*----------------------------------------------------------------------
*
+ * ArgumentBCEnter --
+ *
+ * This is a helper for TclNRExecuteByteCode/TEBCresume that encapsulates
+ * a code sequence that is fairly common in the code but *not* commonly
+ * called.
+ *
+ * Results:
+ * None
+ *
+ * Side effects:
+ * May register information about the bytecode in the command frame.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ArgumentBCEnter(
+ Tcl_Interp *interp,
+ ByteCode *codePtr,
+ TEBCdata *tdPtr,
+ const unsigned char *pc,
+ int objc,
+ Tcl_Obj **objv)
+{
+ int cmd;
+
+ if (GetSrcInfoForPc(pc, codePtr, NULL, NULL, &cmd)) {
+ TclArgumentBCEnter(interp, objv, objc, codePtr, &tdPtr->cmdFrame, cmd,
+ pc - codePtr->codeStart);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
* TclNRExecuteByteCode --
*
* This procedure executes the instructions of a ByteCode structure. It
@@ -1876,10 +2007,6 @@ TclNRExecuteByteCode(
* sizeof(void *);
int numWords = (size + sizeof(Tcl_Obj *) - 1) / sizeof(Tcl_Obj *);
- if (iPtr->execEnvPtr->rewind) {
- return TCL_ERROR;
- }
-
codePtr->refCount++;
/*
@@ -1898,11 +2025,8 @@ TclNRExecuteByteCode(
esPtr->tosPtr = initTosPtr;
TD->codePtr = codePtr;
- TD->pc = codePtr->codeStart;
TD->catchTop = initCatchTop;
- TD->cleanup = 0;
TD->auxObjList = NULL;
- TD->checkInterp = 0;
/*
* TIP #280: Initialize the frame. Do not push it yet: it will be pushed
@@ -1912,7 +2036,6 @@ TclNRExecuteByteCode(
bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
- bcFramePtr->numLevels = iPtr->numLevels;
bcFramePtr->framePtr = iPtr->framePtr;
bcFramePtr->nextPtr = iPtr->cmdFramePtr;
bcFramePtr->nline = 0;
@@ -1920,8 +2043,9 @@ TclNRExecuteByteCode(
bcFramePtr->litarg = NULL;
bcFramePtr->data.tebc.codePtr = codePtr;
bcFramePtr->data.tebc.pc = NULL;
- bcFramePtr->cmd.str.cmd = NULL;
- bcFramePtr->cmd.str.len = 0;
+ bcFramePtr->cmdObj = NULL;
+ bcFramePtr->cmd = NULL;
+ bcFramePtr->len = 0;
#ifdef TCL_COMPILE_STATS
iPtr->stats.numExecutions++;
@@ -1931,8 +2055,8 @@ TclNRExecuteByteCode(
* Push the callback for bytecode execution
*/
- TclNRAddCallback(interp, TEBCresume, TD, /*resume*/ INT2PTR(0),
- NULL, NULL);
+ TclNRAddCallback(interp, TEBCresume, TD, /* pc */ NULL,
+ /* cleanup */ INT2PTR(0), NULL);
return TCL_OK;
}
@@ -1988,9 +2112,6 @@ TEBCresume(
#define auxObjList (TD->auxObjList)
#define catchTop (TD->catchTop)
#define codePtr (TD->codePtr)
-#define checkInterp (TD->checkInterp)
- /* Indicates when a check of interp readyness is
- * necessary. Set by CACHE_STACK_INFO() */
/*
* Globals: variables that store state, must remain valid at all times.
@@ -1998,7 +2119,8 @@ TEBCresume(
Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
* stack. */
- const unsigned char *pc; /* The current program counter. */
+ const unsigned char *pc = data[1];
+ /* The current program counter. */
unsigned char inst; /* The currently running instruction */
/*
@@ -2006,8 +2128,10 @@ TEBCresume(
* executing an instruction.
*/
- int cleanup = 0;
+ int cleanup = PTR2INT(data[2]);
Tcl_Obj *objResultPtr;
+ int checkInterp; /* Indicates when a check of interp readyness
+ * is necessary. Set by CACHE_STACK_INFO() */
/*
* Locals - variables that are used within opcodes or bounded sections of
@@ -2032,82 +2156,77 @@ TEBCresume(
TEBC_DATA_DIG();
#ifdef TCL_COMPILE_DEBUG
- if (!data[1] && (tclTraceExec >= 2)) {
+ if (!pc && (tclTraceExec >= 2)) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
fflush(stdout);
}
#endif
- if (data[1] /* resume from invocation */) {
+ if (!pc) {
+ /* bytecode is starting from scratch */
+ checkInterp = 0;
+ pc = codePtr->codeStart;
+ goto cleanup0;
+ } else {
+ /* resume from invocation */
+ CACHE_STACK_INFO();
if (iPtr->execEnvPtr->rewind) {
result = TCL_ERROR;
+ goto abnormalReturn;
}
+
NRE_ASSERT(iPtr->cmdFramePtr == bcFramePtr);
+ if (bcFramePtr->cmdObj) {
+ Tcl_DecrRefCount(bcFramePtr->cmdObj);
+ bcFramePtr->cmdObj = NULL;
+ bcFramePtr->cmd = NULL;
+ }
iPtr->cmdFramePtr = bcFramePtr->nextPtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCRelease((Tcl_Interp *) iPtr, bcFramePtr);
+ TclArgumentBCRelease(interp, bcFramePtr);
}
if (codePtr->flags & TCL_BYTECODE_RECOMPILE) {
iPtr->flags |= ERR_ALREADY_LOGGED;
codePtr->flags &= ~TCL_BYTECODE_RECOMPILE;
}
- CACHE_STACK_INFO();
- if (result == TCL_OK) {
-#ifndef TCL_COMPILE_DEBUG
- if (*pc == INST_POP) {
- NEXT_INST_V(1, cleanup, 0);
- }
-#endif
- /*
- * 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));
-
- 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.
- */
-
- TclNewObj(objPtr);
- Tcl_IncrRefCount(objPtr);
- iPtr->objResultPtr = objPtr;
- NEXT_INST_V(0, cleanup, -1);
+ if (result != TCL_OK) {
+ pc--;
+ goto processExceptionReturn;
}
/*
- * Result not TCL_OK: fall through
+ * Push the call's object result and continue execution with the next
+ * instruction.
*/
- }
-
- if (iPtr->execEnvPtr->rewind) {
- result = TCL_ERROR;
- goto abnormalReturn;
- }
- if (result != TCL_OK) {
- pc--;
- goto processExceptionReturn;
- }
+ TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
+ objc, cmdNameBuf), Tcl_GetObjResult(interp));
- /*
- * Loop executing instructions until a "done" instruction, a TCL_RETURN,
- * or some error.
- */
+ /*
+ * 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.
+ */
- goto cleanup0;
+ objResultPtr = Tcl_GetObjResult(interp);
+ TclNewObj(objPtr);
+ Tcl_IncrRefCount(objPtr);
+ iPtr->objResultPtr = objPtr;
+#ifndef TCL_COMPILE_DEBUG
+ if (*pc == INST_POP) {
+ TclDecrRefCount(objResultPtr);
+ NEXT_INST_V(1, cleanup, 0);
+ }
+#endif
+ NEXT_INST_V(0, cleanup, -1);
+ }
/*
* Targets for standard instruction endings; unrolled for speed in the
@@ -2233,7 +2352,7 @@ TEBCresume(
goto instLoadScalar1;
} else if (inst == INST_PUSH1) {
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
- TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
+ TRACE_WITH_OBJ(("%u => ", TclGetUInt1AtPtr(pc+1)), OBJ_AT_TOS);
inst = *(pc += 2);
goto peepholeStart;
} else if (inst == INST_START_CMD) {
@@ -2275,7 +2394,7 @@ TEBCresume(
TRACE(("%u %u => ", code, level));
result = TclProcessReturn(interp, code, level, OBJ_AT_TOS);
if (result == TCL_OK) {
- TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
O2S(objResultPtr)));
NEXT_INST_F(9, 1, 0);
}
@@ -2284,6 +2403,7 @@ TEBCresume(
iPtr->flags &= ~ERR_ALREADY_LOGGED;
}
cleanup = 2;
+ TRACE_APPEND(("\n"));
goto processExceptionReturn;
}
@@ -2294,7 +2414,7 @@ TEBCresume(
if (result == TCL_OK) {
Tcl_DecrRefCount(OBJ_AT_TOS);
OBJ_AT_TOS = objResultPtr;
- TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
+ TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")\n",
O2S(objResultPtr)));
NEXT_INST_F(1, 0, 0);
} else if (result == TCL_ERROR) {
@@ -2314,27 +2434,96 @@ TEBCresume(
Tcl_SetObjResult(interp, objResultPtr);
}
cleanup = 1;
+ TRACE_APPEND(("\n"));
goto processExceptionReturn;
- case INST_YIELD: {
- CoroutineData *corPtr = iPtr->execEnvPtr->corPtr;
+ {
+ CoroutineData *corPtr;
+ int yieldParameter;
+ case INST_YIELD:
+ corPtr = iPtr->execEnvPtr->corPtr;
TRACE(("%.30s => ", O2S(OBJ_AT_TOS)));
if (!corPtr) {
TRACE_APPEND(("ERROR: yield outside coroutine\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"yield can only be called in a coroutine", -1));
+ DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
NULL);
+ CACHE_STACK_INFO();
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
- TRACE_WITH_OBJ(("yield, result="), iPtr->objResultPtr);
- if (traceInstructions) {
- fprintf(stdout, "\n");
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ TRACE_APPEND(("YIELD...\n"));
+ } else {
+ fprintf(stdout, "%d: (%u) yielding value \"%.30s\"\n",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ Tcl_GetString(OBJ_AT_TOS));
+ }
+ fflush(stdout);
+ }
+#endif
+ yieldParameter = 0;
+ Tcl_SetObjResult(interp, OBJ_AT_TOS);
+ goto doYield;
+
+ case INST_YIELD_TO_INVOKE:
+ corPtr = iPtr->execEnvPtr->corPtr;
+ valuePtr = OBJ_AT_TOS;
+ if (!corPtr) {
+ TRACE(("[%.30s] => ERROR: yield outside coroutine\n",
+ O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto can only be called in a coroutine", -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "ILLEGAL_YIELD",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ if (((Namespace *)TclGetCurrentNamespace(interp))->flags & NS_DYING) {
+ TRACE(("[%.30s] => ERROR: yield in deleted\n",
+ O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "yieldto called in deleted namespace", -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "COROUTINE", "YIELDTO_IN_DELETED",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ TRACE(("[%.30s] => YIELD...\n", O2S(valuePtr)));
+ } else {
+ /* FIXME: What is the right thing to trace? */
+ fprintf(stdout, "%d: (%u) yielding to [%.30s]\n",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart),
+ Tcl_GetString(valuePtr));
+ }
+ fflush(stdout);
}
#endif
+
+ /*
+ * Install a tailcall record in the caller and continue with the
+ * yield. The yield is switched into multi-return mode (via the
+ * 'yieldParameter').
+ */
+
+ Tcl_IncrRefCount(valuePtr);
+ iPtr->execEnvPtr = corPtr->callerEEPtr;
+ TclSetTailcall(interp, valuePtr);
+ iPtr->execEnvPtr = corPtr->eePtr;
+ yieldParameter = (PTR2INT(NULL)+1); /*==CORO_ACTIVATE_YIELDM*/
+
+ doYield:
/* TIP #280: Record the last piece of info needed by
* 'TclGetSrcInfoForPc', and push the frame.
*/
@@ -2343,18 +2532,14 @@ TEBCresume(
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
}
pc++;
cleanup = 1;
TEBC_YIELD();
-
- Tcl_SetObjResult(interp, OBJ_AT_TOS);
TclNRAddCallback(interp, TclNRCoroutineActivateCallback, corPtr,
- INT2PTR(0), NULL, NULL);
-
+ INT2PTR(yieldParameter), NULL, NULL);
return TCL_OK;
}
@@ -2367,11 +2552,14 @@ TEBCresume(
TRACE(("%d => ERROR: tailcall in non-proc context\n", opnd));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"tailcall can only be called from a proc or lambda", -1));
+ DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "TAILCALL", "ILLEGAL", NULL);
+ CACHE_STACK_INFO();
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
+ /* FIXME: What is the right thing to trace? */
{
register int i;
@@ -2445,7 +2633,7 @@ TEBCresume(
case INST_OVER:
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = OBJ_AT_DEPTH(opnd);
- TRACE_WITH_OBJ(("=> "), objResultPtr);
+ TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_REVERSE: {
@@ -2460,10 +2648,11 @@ TEBCresume(
*b = tmpPtr;
a++; b--;
}
+ TRACE(("%u => OK\n", opnd));
NEXT_INST_F(5, 0, 0);
}
- case INST_CONCAT1: {
+ case INST_STR_CONCAT1: {
int appendLen = 0;
char *bytes, *p;
Tcl_Obj **currPtr;
@@ -2543,7 +2732,7 @@ TEBCresume(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
-#if !TCL_COMPILE_DEBUG
+#ifndef TCL_COMPILE_DEBUG
if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
TclFreeIntRep(objResultPtr);
objResultPtr->bytes = ckrealloc(bytes, length+appendLen+1);
@@ -2579,7 +2768,7 @@ TEBCresume(
Tcl_Panic("max size for a Tcl value (%d bytes) exceeded",
INT_MAX);
}
-#if !TCL_COMPILE_DEBUG
+#ifndef TCL_COMPILE_DEBUG
if (!Tcl_IsShared(objResultPtr)) {
bytes = (char *) Tcl_SetByteArrayLength(objResultPtr,
length + appendLen);
@@ -2612,6 +2801,17 @@ TEBCresume(
NEXT_INST_V(2, opnd, 1);
}
+ case INST_CONCAT_STK:
+ /*
+ * Pop the opnd (objc) top stack elements, run through Tcl_ConcatObj,
+ * and then decrement their ref counts.
+ */
+
+ opnd = TclGetUInt4AtPtr(pc+1);
+ objResultPtr = Tcl_ConcatObj(opnd, &OBJ_AT_DEPTH(opnd-1));
+ TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
+ NEXT_INST_V(5, opnd, 1);
+
case INST_EXPAND_START:
/*
* Push an element to the auxObjList. This records the current
@@ -2628,9 +2828,28 @@ TEBCresume(
TclNewObj(objPtr);
objPtr->internalRep.ptrAndLongRep.value = CURR_DEPTH;
+ objPtr->length = 0;
PUSH_TAUX_OBJ(objPtr);
+ TRACE(("=> mark depth as %d\n", (int) CURR_DEPTH));
NEXT_INST_F(1, 0, 0);
+ case INST_EXPAND_DROP:
+ /*
+ * Drops an element of the auxObjList, popping stack elements to
+ * restore the stack to the state before the point where the aux
+ * element was created.
+ */
+
+ CLANG_ASSERT(auxObjList);
+ objc = CURR_DEPTH - auxObjList->internalRep.ptrAndLongRep.value;
+ POP_TAUX_OBJ();
+#ifdef TCL_COMPILE_DEBUG
+ /* Ugly abuse! */
+ starting = 1;
+#endif
+ TRACE(("=> drop %d items\n", objc));
+ NEXT_INST_V(1, objc, 0);
+
case INST_EXPAND_STKTOP: {
int i;
ptrdiff_t moved;
@@ -2642,9 +2861,9 @@ TEBCresume(
*/
objPtr = OBJ_AT_TOS;
+ TRACE(("\"%.30s\" => ", O2S(objPtr)));
if (TclListObjGetElements(interp, objPtr, &objc, &objv) != TCL_OK) {
- TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(objPtr)),
- Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
(void) POP_OBJECT();
@@ -2656,22 +2875,27 @@ TEBCresume(
* stack depth, as seen by the compiler.
*/
- length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
- DECACHE_STACK_INFO();
- moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
- - (Tcl_Obj **) TD;
- if (moved) {
- /*
- * Change the global data to point to the new stack: move the
- * TEBCdataPtr TD, recompute the position of every other
- * stack-allocated parameter, update the stack pointers.
- */
+ auxObjList->length += objc - 1;
+ if ((objc > 1) && (auxObjList->length > 0)) {
+ length = auxObjList->length /* Total expansion room we need */
+ + codePtr->maxStackDepth /* Beyond the original max */
+ - CURR_DEPTH; /* Relative to where we are */
+ DECACHE_STACK_INFO();
+ moved = GrowEvaluationStack(iPtr->execEnvPtr, length, 1)
+ - (Tcl_Obj **) TD;
+ if (moved) {
+ /*
+ * Change the global data to point to the new stack: move the
+ * TEBCdataPtr TD, recompute the position of every other
+ * stack-allocated parameter, update the stack pointers.
+ */
- esPtr = iPtr->execEnvPtr->execStackPtr;
- TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
+ esPtr = iPtr->execEnvPtr->execStackPtr;
+ TD = (TEBCdata *) (((Tcl_Obj **)TD) + moved);
- catchTop += moved;
- tosPtr += moved;
+ catchTop += moved;
+ tosPtr += moved;
+ }
}
/*
@@ -2683,6 +2907,7 @@ TEBCresume(
PUSH_OBJECT(objv[i]);
}
+ TRACE_APPEND(("OK\n"));
Tcl_DecrRefCount(objPtr);
NEXT_INST_F(5, 0, 0);
}
@@ -2775,8 +3000,7 @@ TEBCresume(
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
}
DECACHE_STACK_INFO();
@@ -2784,7 +3008,7 @@ TEBCresume(
pc += pcAdjustment;
TEBC_YIELD();
return TclNREvalObjv(interp, objc, objv,
- TCL_EVAL_NOERR, NULL);
+ TCL_EVAL_NOERR | TCL_EVAL_SOURCE_IN_FRAME, NULL);
/*
* INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the
@@ -2846,8 +3070,7 @@ TEBCresume(
bcFramePtr->data.tebc.pc = (char *) pc;
iPtr->cmdFramePtr = bcFramePtr;
if (iPtr->flags & INTERP_DEBUG_FRAME) {
- TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
- codePtr, bcFramePtr, pc - codePtr->codeStart);
+ ArgumentBCEnter(interp, codePtr, TD, pc, objc, objv);
}
iPtr->ensembleRewrite.sourceObjs = objv;
iPtr->ensembleRewrite.numRemovedObjs = opnd;
@@ -2946,7 +3169,7 @@ TEBCresume(
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd);
if (varPtr == NULL) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
cleanup = 1;
@@ -2972,7 +3195,7 @@ TEBCresume(
TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1,
&arrayPtr);
if (!varPtr) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -2999,7 +3222,7 @@ TEBCresume(
part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (!objResultPtr) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
@@ -3148,7 +3371,7 @@ TEBCresume(
varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
if (!varPtr) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
cleanup = ((part2Ptr == NULL)? 2 : 3);
@@ -3198,7 +3421,7 @@ TEBCresume(
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
if (!varPtr) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
goto doCallPtrSetVar;
@@ -3246,7 +3469,7 @@ TEBCresume(
part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
CACHE_STACK_INFO();
if (!objResultPtr) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
#ifndef TCL_COMPILE_DEBUG
@@ -3272,7 +3495,9 @@ TEBCresume(
{
Tcl_Obj *incrPtr;
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w;
+#endif
long increment;
case INST_INCR_SCALAR1:
@@ -3319,9 +3544,11 @@ TEBCresume(
varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr);
if (!varPtr) {
+ DECACHE_STACK_INFO();
Tcl_AddErrorInfo(interp,
"\n (reading value of variable to increment)");
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
Tcl_DecrRefCount(incrPtr);
goto gotError;
}
@@ -3347,7 +3574,7 @@ TEBCresume(
varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd);
if (!varPtr) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
Tcl_DecrRefCount(incrPtr);
goto gotError;
}
@@ -3392,6 +3619,7 @@ TEBCresume(
}
goto doneIncr;
}
+#ifndef TCL_WIDE_INT_IS_LONG
w = (Tcl_WideInt)augend;
TRACE(("%u %ld => ", opnd, increment));
@@ -3411,7 +3639,9 @@ TEBCresume(
TclSetWideIntObj(objPtr, w+increment);
}
goto doneIncr;
+#endif
} /* end if (type == TCL_NUMBER_LONG) */
+#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
Tcl_WideInt sum;
@@ -3443,6 +3673,7 @@ TEBCresume(
goto doneIncr;
}
}
+#endif
}
if (Tcl_IsShared(objPtr)) {
objPtr->refCount--; /* We know it's shared */
@@ -3455,8 +3686,7 @@ TEBCresume(
TclNewLongObj(incrPtr, increment);
if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
Tcl_DecrRefCount(incrPtr);
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
Tcl_DecrRefCount(incrPtr);
@@ -3478,7 +3708,7 @@ TEBCresume(
arrayPtr = NULL;
part1Ptr = part2Ptr = NULL;
cleanup = 0;
- TRACE(("%u %ld => ", opnd, increment));
+ TRACE(("%u %s => ", opnd, Tcl_GetString(incrPtr)));
doIncrVar:
if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
@@ -3493,8 +3723,7 @@ TEBCresume(
}
if (TclIncrObj(interp, objResultPtr, incrPtr) != TCL_OK) {
Tcl_DecrRefCount(incrPtr);
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
Tcl_DecrRefCount(incrPtr);
@@ -3505,8 +3734,7 @@ TEBCresume(
CACHE_STACK_INFO();
Tcl_DecrRefCount(incrPtr);
if (objResultPtr == NULL) {
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
}
@@ -3527,6 +3755,8 @@ TEBCresume(
*/
case INST_EXIST_SCALAR:
+ cleanup = 0;
+ pcAdjustment = 5;
opnd = TclGetUInt4AtPtr(pc+1);
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
@@ -3543,16 +3773,11 @@ TEBCresume(
varPtr = NULL;
}
}
-
- /*
- * Tricky! Arrays always exist.
- */
-
- objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_F(5, 0, 1);
+ goto afterExistsPeephole;
case INST_EXIST_ARRAY:
+ cleanup = 1;
+ pcAdjustment = 5;
opnd = TclGetUInt4AtPtr(pc+1);
part2Ptr = OBJ_AT_TOS;
arrayPtr = LOCAL(opnd);
@@ -3563,7 +3788,7 @@ TEBCresume(
if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
if (!varPtr || !ReadTraced(varPtr)) {
- goto doneExistArray;
+ goto afterExistsPeephole;
}
}
varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access",
@@ -3580,13 +3805,11 @@ TEBCresume(
varPtr = NULL;
}
}
- doneExistArray:
- objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_F(5, 1, 1);
+ goto afterExistsPeephole;
case INST_EXIST_ARRAY_STK:
cleanup = 2;
+ pcAdjustment = 1;
part2Ptr = OBJ_AT_TOS; /* element name */
part1Ptr = OBJ_UNDER_TOS; /* array name */
TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr)));
@@ -3594,6 +3817,7 @@ TEBCresume(
case INST_EXIST_STK:
cleanup = 1;
+ pcAdjustment = 1;
part2Ptr = NULL;
part1Ptr = OBJ_AT_TOS; /* variable name */
TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
@@ -3613,9 +3837,17 @@ TEBCresume(
varPtr = NULL;
}
}
- objResultPtr = TCONST(!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1);
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(1, cleanup, 1);
+
+ /*
+ * Peep-hole optimisation: if you're about to jump, do jump from here.
+ */
+
+ afterExistsPeephole: {
+ int found = (varPtr && !TclIsVarUndefined(varPtr));
+
+ TRACE_APPEND(("%d\n", found ? 1 : 0));
+ JUMP_PEEPHOLE_V(found, pcAdjustment, cleanup);
+ }
/*
* End of INST_EXIST instructions.
@@ -3633,7 +3865,7 @@ TEBCresume(
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
- TRACE(("%s %u\n", (flags?"normal":"noerr"), opnd));
+ TRACE(("%s %u => ", (flags ? "normal" : "noerr"), opnd));
if (TclIsVarDirectUnsettable(varPtr) && !TclIsVarInHash(varPtr)) {
/*
* No errors, no traces, no searches: just make the variable cease
@@ -3646,6 +3878,7 @@ TEBCresume(
goto slowUnsetScalar;
}
varPtr->value.objPtr = NULL;
+ TRACE_APPEND(("OK\n"));
NEXT_INST_F(6, 0, 0);
}
@@ -3666,7 +3899,7 @@ TEBCresume(
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
- TRACE(("%s %u \"%.30s\"\n",
+ TRACE(("%s %u \"%.30s\" => ",
(flags ? "normal" : "noerr"), opnd, O2S(part2Ptr)));
if (TclIsVarArray(arrayPtr) && !UnsetTraced(arrayPtr)) {
varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
@@ -3682,12 +3915,14 @@ TEBCresume(
goto slowUnsetArray;
}
varPtr->value.objPtr = NULL;
+ TRACE_APPEND(("OK\n"));
NEXT_INST_F(6, 1, 0);
} else if (!varPtr && !(flags & TCL_LEAVE_ERR_MSG)) {
/*
* Don't need to do anything here.
*/
+ TRACE_APPEND(("OK\n"));
NEXT_INST_F(6, 1, 0);
}
}
@@ -3711,7 +3946,7 @@ TEBCresume(
cleanup = 2;
part2Ptr = OBJ_AT_TOS; /* element name */
part1Ptr = OBJ_UNDER_TOS; /* array name */
- TRACE(("%s \"%.30s(%.30s)\"\n", (flags?"normal":"noerr"),
+ TRACE(("%s \"%.30s(%.30s)\" => ", (flags ? "normal" : "noerr"),
O2S(part1Ptr), O2S(part2Ptr)));
goto doUnsetStk;
@@ -3720,7 +3955,8 @@ TEBCresume(
cleanup = 1;
part2Ptr = NULL;
part1Ptr = OBJ_AT_TOS; /* variable name */
- TRACE(("%s \"%.30s\"\n", (flags?"normal":"noerr"), O2S(part1Ptr)));
+ TRACE(("%s \"%.30s\" => ", (flags ? "normal" : "noerr"),
+ O2S(part1Ptr)));
doUnsetStk:
DECACHE_STACK_INFO();
@@ -3729,11 +3965,12 @@ TEBCresume(
goto errorInUnset;
}
CACHE_STACK_INFO();
+ TRACE_APPEND(("OK\n"));
NEXT_INST_V(2, cleanup, 0);
errorInUnset:
CACHE_STACK_INFO();
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
/*
@@ -3742,7 +3979,7 @@ TEBCresume(
case INST_DICT_DONE:
opnd = TclGetUInt4AtPtr(pc+1);
- TRACE(("%u\n", opnd));
+ TRACE(("%u => OK\n", opnd));
varPtr = LOCAL(opnd);
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
@@ -3795,8 +4032,7 @@ TEBCresume(
TCL_GLOBAL_ONLY|TCL_TRACE_ARRAY), 1, opnd);
CACHE_STACK_INFO();
if (result == TCL_ERROR) {
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
}
@@ -3829,7 +4065,7 @@ TEBCresume(
varPtr = TclObjLookupVarEx(interp, part1Ptr, NULL, TCL_LEAVE_ERR_MSG,
"set", /*createPart1*/1, /*createPart2*/0, &arrayPtr);
if (varPtr == NULL) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
doArrayMake:
@@ -3841,9 +4077,10 @@ TEBCresume(
TclObjVarErrMsg(interp, part1Ptr, NULL, "array set",
"variable isn't array", opnd);
+ DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "WRITE", "ARRAY", NULL);
- TRACE_APPEND(("ERROR: bad array ref: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
goto gotError;
}
TclSetVarArray(varPtr);
@@ -3871,9 +4108,11 @@ TEBCresume(
Namespace *savedNsPtr;
case INST_UPVAR:
- TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
+ TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1),
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
if (TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr) == -1) {
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -3888,13 +4127,16 @@ TEBCresume(
/*createPart2*/ 1, &varPtr);
iPtr->varFramePtr = savedFramePtr;
if (!otherPtr) {
+ TRACE_ERROR(interp);
goto gotError;
}
goto doLinkVars;
case INST_NSUPVAR:
- TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);
+ TRACE(("%d %.30s %.30s => ", TclGetInt4AtPtr(pc+1),
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
if (TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr) != TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -3909,16 +4151,18 @@ TEBCresume(
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
iPtr->varFramePtr->nsPtr = savedNsPtr;
if (!otherPtr) {
+ TRACE_ERROR(interp);
goto gotError;
}
goto doLinkVars;
case INST_VARIABLE:
- TRACE(("variable "));
+ TRACE(("%d, %.30s => ", TclGetInt4AtPtr(pc+1), O2S(OBJ_AT_TOS)));
otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
(TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
/*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
if (!otherPtr) {
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -3936,7 +4180,7 @@ TEBCresume(
* if there are no errors; otherwise, let it handle the case.
*/
- opnd = TclGetInt4AtPtr(pc+1);;
+ opnd = TclGetInt4AtPtr(pc+1);
varPtr = LOCAL(opnd);
if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr)
&& (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) {
@@ -3948,6 +4192,7 @@ TEBCresume(
Var *linkPtr = varPtr->value.linkPtr;
if (linkPtr == otherPtr) {
+ TRACE_APPEND(("already linked\n"));
NEXT_INST_F(5, 1, 0);
}
if (TclIsVarInHash(linkPtr)) {
@@ -3964,6 +4209,7 @@ TEBCresume(
}
} else if (TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0,
opnd) != TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -3972,6 +4218,7 @@ TEBCresume(
* variables - and [variable] did not push it at all.
*/
+ TRACE_APPEND(("link made\n"));
NEXT_INST_F(5, 1, 0);
}
@@ -4018,32 +4265,30 @@ TEBCresume(
doCondJump:
valuePtr = OBJ_AT_TOS;
+ TRACE(("%d => ", jmpOffset[
+ (*pc==INST_JUMP_FALSE1 || *pc==INST_JUMP_FALSE4) ? 0 : 1]));
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
if (TclGetBooleanFromObj(interp, valuePtr, &b) != TCL_OK) {
- TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[
- ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4))
- ? 0 : 1]), Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
#ifdef TCL_COMPILE_DEBUG
if (b) {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
- TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1],
- O2S(valuePtr),
+ TRACE_APPEND(("%.20s true, new pc %u\n", O2S(valuePtr),
(unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
} else {
- TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr)));
+ TRACE_APPEND(("%.20s true\n", O2S(valuePtr)));
}
} else {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
- TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr)));
+ TRACE_APPEND(("%.20s false\n", O2S(valuePtr)));
} else {
- TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0],
- O2S(valuePtr),
- (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
+ TRACE_APPEND(("%.20s false, new pc %u\n", O2S(valuePtr),
+ (unsigned)(pc + jmpOffset[0] - codePtr->codeStart)));
}
}
#endif
@@ -4061,7 +4306,7 @@ TEBCresume(
opnd = TclGetInt4AtPtr(pc+1);
jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
- TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS)));
+ TRACE(("%d \"%.20s\" => ", opnd, O2S(OBJ_AT_TOS)));
hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS));
if (hPtr != NULL) {
int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr));
@@ -4156,13 +4401,11 @@ TEBCresume(
register CallFrame *framePtr = iPtr->varFramePtr;
register CallFrame *rootFramePtr = iPtr->rootFramePtr;
- valuePtr = OBJ_AT_TOS;
- if (TclGetIntFromObj(interp, valuePtr, &level) != TCL_OK) {
- TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
- Tcl_GetObjResult(interp));
+ TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
+ if (TclGetIntFromObj(interp, OBJ_AT_TOS, &level) != TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
- TRACE(("%d => ", level));
if (level <= 0) {
level += framePtr->level;
}
@@ -4171,38 +4414,76 @@ TEBCresume(
/* Empty loop body */
}
if (framePtr == rootFramePtr) {
- Tcl_AppendResult(interp, "bad level \"", TclGetString(valuePtr),
- "\"", NULL);
- TRACE_APPEND(("ERROR: bad level\n"));
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "bad level \"%s\"", TclGetString(OBJ_AT_TOS)));
+ TRACE_ERROR(interp);
+ DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "STACK_LEVEL",
- TclGetString(valuePtr), NULL);
+ TclGetString(OBJ_AT_TOS), NULL);
+ CACHE_STACK_INFO();
goto gotError;
}
objResultPtr = Tcl_NewListObj(framePtr->objc, framePtr->objv);
TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
- case INST_RESOLVE_COMMAND: {
- Tcl_Command cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
+ {
+ Tcl_Command cmd, origCmd;
+ case INST_RESOLVE_COMMAND:
+ cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
TclNewObj(objResultPtr);
if (cmd != NULL) {
Tcl_GetCommandFullName(interp, cmd, objResultPtr);
}
TRACE_WITH_OBJ(("\"%.20s\" => ", O2S(OBJ_AT_TOS)), objResultPtr);
NEXT_INST_F(1, 1, 1);
+
+ case INST_ORIGIN_COMMAND:
+ TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
+ cmd = Tcl_GetCommandFromObj(interp, OBJ_AT_TOS);
+ if (cmd == NULL) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "invalid command name \"%s\"", TclGetString(OBJ_AT_TOS)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "COMMAND",
+ TclGetString(OBJ_AT_TOS), NULL);
+ CACHE_STACK_INFO();
+ TRACE_APPEND(("ERROR: not command\n"));
+ goto gotError;
+ }
+ origCmd = TclGetOriginalCommand(cmd);
+ if (origCmd == NULL) {
+ origCmd = cmd;
+ }
+ TclNewObj(objResultPtr);
+ Tcl_GetCommandFullName(interp, origCmd, objResultPtr);
+ TRACE_APPEND(("\"%.30s\"", O2S(OBJ_AT_TOS)));
+ NEXT_INST_F(1, 1, 1);
}
- case INST_TCLOO_SELF: {
- CallFrame *framePtr = iPtr->varFramePtr;
+
+ /*
+ * -----------------------------------------------------------------
+ * Start of TclOO support instructions.
+ */
+
+ {
+ Object *oPtr;
+ CallFrame *framePtr;
CallContext *contextPtr;
+ int skip, newDepth;
+ case INST_TCLOO_SELF:
+ framePtr = iPtr->varFramePtr;
if (framePtr == NULL ||
!(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
TRACE(("=> ERROR: no TclOO call context\n"));
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"self may only be called from inside a method",
-1));
+ DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ CACHE_STACK_INFO();
goto gotError;
}
contextPtr = framePtr->clientData;
@@ -4214,9 +4495,212 @@ TEBCresume(
objResultPtr = TclOOObjectName(interp, contextPtr->oPtr);
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
- }
- {
- Object *oPtr;
+
+ case INST_TCLOO_NEXT_CLASS:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ framePtr = iPtr->varFramePtr;
+ valuePtr = OBJ_AT_DEPTH(opnd - 2);
+ objv = &OBJ_AT_DEPTH(opnd - 1);
+ skip = 2;
+ TRACE(("%d => ", opnd));
+ if (framePtr == NULL ||
+ !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ TRACE_APPEND(("ERROR: no TclOO call context\n"));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "nextto may only be called from inside a method",
+ -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ contextPtr = framePtr->clientData;
+
+ oPtr = (Object *) Tcl_GetObjectFromObj(interp, valuePtr);
+ if (oPtr == NULL) {
+ TRACE_APPEND(("ERROR: \"%.30s\" not object\n", O2S(valuePtr)));
+ goto gotError;
+ } else {
+ Class *classPtr = oPtr->classPtr;
+ struct MInvoke *miPtr;
+ int i;
+ const char *methodType;
+
+ if (classPtr == NULL) {
+ TRACE_APPEND(("ERROR: \"%.30s\" not class\n", O2S(valuePtr)));
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "\"%s\" is not a class", TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+ for (i=contextPtr->index+1 ; i<contextPtr->callPtr->numChain ; i++) {
+ miPtr = contextPtr->callPtr->chain + i;
+ if (!miPtr->isFilter &&
+ miPtr->mPtr->declaringClassPtr == classPtr) {
+ newDepth = i;
+#ifdef TCL_COMPILE_DEBUG
+ if (tclTraceExec >= 2) {
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ",
+ iPtr->numLevels,
+ (unsigned)(pc - codePtr->codeStart));
+ }
+ for (i = 0; i < opnd; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ goto doInvokeNext;
+ }
+ }
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ TRACE_APPEND(("ERROR: \"%.30s\" not on reachable chain\n",
+ O2S(valuePtr)));
+ for (i=contextPtr->index ; i>=0 ; i--) {
+ miPtr = contextPtr->callPtr->chain + i;
+ if (miPtr->isFilter
+ || miPtr->mPtr->declaringClassPtr != classPtr) {
+ continue;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s implementation by \"%s\" not reachable from here",
+ methodType, TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_REACHABLE",
+ NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "%s has no non-filter implementation by \"%s\"",
+ methodType, TclGetString(valuePtr)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CLASS_NOT_THERE", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+
+ case INST_TCLOO_NEXT:
+ opnd = TclGetUInt1AtPtr(pc+1);
+ objv = &OBJ_AT_DEPTH(opnd - 1);
+ framePtr = iPtr->varFramePtr;
+ skip = 1;
+ TRACE(("%d => ", opnd));
+ if (framePtr == NULL ||
+ !(framePtr->isProcCallFrame & FRAME_IS_METHOD)) {
+ TRACE_APPEND(("ERROR: no TclOO call context\n"));
+ Tcl_SetObjResult(interp, Tcl_NewStringObj(
+ "next may only be called from inside a method",
+ -1));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "CONTEXT_REQUIRED", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+ }
+ contextPtr = framePtr->clientData;
+
+ newDepth = contextPtr->index + 1;
+ if (newDepth >= contextPtr->callPtr->numChain) {
+ /*
+ * We're at the end of the chain; generate an error message unless
+ * the interpreter is being torn down, in which case we might be
+ * getting here because of methods/destructors doing a [next] (or
+ * equivalent) unexpectedly.
+ */
+
+ const char *methodType;
+
+ if (contextPtr->callPtr->flags & CONSTRUCTOR) {
+ methodType = "constructor";
+ } else if (contextPtr->callPtr->flags & DESTRUCTOR) {
+ methodType = "destructor";
+ } else {
+ methodType = "method";
+ }
+
+ TRACE_APPEND(("ERROR: no TclOO next impl\n"));
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "no next %s implementation", methodType));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "OO", "NOTHING_NEXT", NULL);
+ CACHE_STACK_INFO();
+ goto gotError;
+#ifdef TCL_COMPILE_DEBUG
+ } else if (tclTraceExec >= 2) {
+ int i;
+
+ if (traceInstructions) {
+ strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
+ } else {
+ fprintf(stdout, "%d: (%u) invoking ",
+ iPtr->numLevels, (unsigned)(pc - codePtr->codeStart));
+ }
+ for (i = 0; i < opnd; i++) {
+ TclPrintObject(stdout, objv[i], 15);
+ fprintf(stdout, " ");
+ }
+ fprintf(stdout, "\n");
+ fflush(stdout);
+#endif /*TCL_COMPILE_DEBUG*/
+ }
+
+ doInvokeNext:
+ bcFramePtr->data.tebc.pc = (char *) pc;
+ iPtr->cmdFramePtr = bcFramePtr;
+
+ if (iPtr->flags & INTERP_DEBUG_FRAME) {
+ ArgumentBCEnter(interp, codePtr, TD, pc, opnd, objv);
+ }
+
+ pcAdjustment = 2;
+ cleanup = opnd;
+ DECACHE_STACK_INFO();
+ iPtr->varFramePtr = framePtr->callerVarPtr;
+ pc += pcAdjustment;
+ TEBC_YIELD();
+
+ oPtr = contextPtr->oPtr;
+ if (oPtr->flags & FILTER_HANDLING) {
+ TclNRAddCallback(interp, FinalizeOONextFilter,
+ framePtr, contextPtr, INT2PTR(contextPtr->index),
+ INT2PTR(contextPtr->skip));
+ } else {
+ TclNRAddCallback(interp, FinalizeOONext,
+ framePtr, contextPtr, INT2PTR(contextPtr->index),
+ INT2PTR(contextPtr->skip));
+ }
+ contextPtr->skip = skip;
+ contextPtr->index = newDepth;
+ if (contextPtr->callPtr->chain[newDepth].isFilter
+ || contextPtr->callPtr->flags & FILTER_HANDLING) {
+ oPtr->flags |= FILTER_HANDLING;
+ } else {
+ oPtr->flags &= ~FILTER_HANDLING;
+ }
+
+ {
+ register Method *const mPtr =
+ contextPtr->callPtr->chain[newDepth].mPtr;
+
+ return mPtr->typePtr->callProc(mPtr->clientData, interp,
+ (Tcl_ObjectContext) contextPtr, opnd, objv);
+ }
case INST_TCLOO_IS_OBJECT:
oPtr = (Object *) Tcl_GetObjectFromObj(interp, OBJ_AT_TOS);
@@ -4250,6 +4734,7 @@ TEBCresume(
}
/*
+ * End of TclOO support instructions.
* -----------------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
@@ -4271,19 +4756,19 @@ TEBCresume(
NEXT_INST_V(5, opnd, 1);
case INST_LIST_LENGTH:
- valuePtr = OBJ_AT_TOS;
- if (TclListObjLength(interp, valuePtr, &length) != TCL_OK) {
- TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
- Tcl_GetObjResult(interp));
+ TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
+ if (TclListObjLength(interp, OBJ_AT_TOS, &length) != TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
TclNewLongObj(objResultPtr, length);
- TRACE(("%.20s => %d\n", O2S(valuePtr), length));
+ TRACE_APPEND(("%d\n", length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX: /* lindex with objc == 3 */
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
+ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Extract the desired list element.
@@ -4301,8 +4786,7 @@ TEBCresume(
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
if (!objResultPtr) {
- TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr),
- O2S(value2Ptr)), Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -4310,8 +4794,7 @@ TEBCresume(
* Stash the list element on the stack.
*/
- TRACE(("%.20s %.20s => %s\n",
- O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */
case INST_LIST_INDEX_IMM: /* lindex with objc==3 and index in bytecode
@@ -4323,6 +4806,7 @@ TEBCresume(
valuePtr = OBJ_AT_TOS;
opnd = TclGetInt4AtPtr(pc+1);
+ TRACE(("\%.30s\" %d => ", O2S(valuePtr), opnd));
/*
* Get the contents of the list, making sure that it really is a list
@@ -4330,8 +4814,7 @@ TEBCresume(
*/
if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
- TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
- Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -4354,8 +4837,7 @@ TEBCresume(
TclNewObj(objResultPtr);
}
- TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd),
- objResultPtr);
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
case INST_LIST_INDEX_MULTI: /* 'lindex' with multiple index args */
@@ -4370,10 +4852,11 @@ TEBCresume(
* Do the 'lindex' operation.
*/
+ TRACE(("%d => ", opnd));
objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIndices),
numIndices, &OBJ_AT_DEPTH(numIndices - 1));
if (!objResultPtr) {
- TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -4381,7 +4864,7 @@ TEBCresume(
* Set result.
*/
- TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(5, opnd, -1);
case INST_LSET_FLAT:
@@ -4391,6 +4874,7 @@ TEBCresume(
opnd = TclGetUInt4AtPtr(pc + 1);
numIndices = opnd - 2;
+ TRACE(("%d => ", opnd));
/*
* Get the old value of variable, and remove the stack ref. This is
@@ -4409,7 +4893,7 @@ TEBCresume(
objResultPtr = TclLsetFlat(interp, valuePtr, numIndices,
&OBJ_AT_DEPTH(numIndices), OBJ_AT_TOS);
if (!objResultPtr) {
- TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -4417,7 +4901,7 @@ TEBCresume(
* Set result.
*/
- TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(5, numIndices+1, -1);
case INST_LSET_LIST: /* 'lset' with 4 args */
@@ -4437,6 +4921,8 @@ TEBCresume(
valuePtr = OBJ_AT_TOS;
value2Ptr = OBJ_UNDER_TOS;
+ TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
+ O2S(value2Ptr), O2S(valuePtr), O2S(objPtr)));
/*
* Compute the new variable value.
@@ -4444,8 +4930,7 @@ TEBCresume(
objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
if (!objResultPtr) {
- TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
- Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -4453,7 +4938,7 @@ TEBCresume(
* Set result.
*/
- TRACE(("=> %s\n", O2S(objResultPtr)));
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1);
case INST_LIST_RANGE_IMM: /* lrange with objc==4 and both indices in
@@ -4466,6 +4951,8 @@ TEBCresume(
valuePtr = OBJ_AT_TOS;
fromIdx = TclGetInt4AtPtr(pc+1);
toIdx = TclGetInt4AtPtr(pc+5);
+ TRACE(("\"%.30s\" %d %d => ", O2S(valuePtr), TclGetInt4AtPtr(pc+1),
+ TclGetInt4AtPtr(pc+5)));
/*
* Get the contents of the list, making sure that it really is a list
@@ -4473,8 +4960,7 @@ TEBCresume(
*/
if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK) {
- TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
- fromIdx, toIdx), Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -4531,9 +5017,7 @@ TEBCresume(
List *listPtr = valuePtr->internalRep.twoPtrValue.ptr1;
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;
@@ -4548,8 +5032,7 @@ TEBCresume(
TclNewObj(objResultPtr);
}
- TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr),
- TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr);
+ TRACE_APPEND(("\"%.30s\"", O2S(objResultPtr)));
NEXT_INST_F(9, 1, 1);
case INST_LIST_IN:
@@ -4558,9 +5041,9 @@ TEBCresume(
valuePtr = OBJ_UNDER_TOS;
s1 = TclGetStringFromObj(valuePtr, &s1len);
+ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
if (TclListObjLength(interp, value2Ptr, &length) != TCL_OK) {
- TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
- O2S(value2Ptr)), Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
match = 0;
@@ -4591,7 +5074,7 @@ TEBCresume(
match = !match;
}
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
+ TRACE_APPEND(("%d\n", match));
/*
* Peep-hole optimisation: if you're about to jump, do jump from here.
@@ -4599,21 +5082,7 @@ TEBCresume(
* for branching.
*/
- pc++;
-#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);
+ JUMP_PEEPHOLE_F(match, 1, 2);
case INST_LIST_CONCAT:
value2Ptr = OBJ_AT_TOS;
@@ -4623,7 +5092,7 @@ TEBCresume(
objResultPtr = Tcl_DuplicateObj(valuePtr);
if (Tcl_ListObjAppendList(interp, objResultPtr,
value2Ptr) != TCL_OK) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
TclDecrRefCount(objResultPtr);
goto gotError;
}
@@ -4631,7 +5100,7 @@ TEBCresume(
NEXT_INST_F(1, 2, 1);
} else {
if (Tcl_ListObjAppendList(interp, valuePtr, value2Ptr) != TCL_OK){
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
@@ -4766,25 +5235,71 @@ TEBCresume(
break;
}
}
- if (match < 0) {
- TclNewLongObj(objResultPtr, -1);
- } else {
- objResultPtr = TCONST(match > 0);
- }
- TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
- O2S(objResultPtr)));
- NEXT_INST_F(1, 2, 1);
+
+ TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr),
+ (match < 0 ? -1 : match > 0 ? 1 : 0)));
+ JUMP_PEEPHOLE_F(match, 1, 2);
case INST_STR_LEN:
valuePtr = OBJ_AT_TOS;
length = Tcl_GetCharLength(valuePtr);
TclNewLongObj(objResultPtr, length);
- TRACE(("%.20s => %d\n", O2S(valuePtr), length));
+ TRACE(("\"%.20s\" => %d\n", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
+ case INST_STR_UPPER:
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.20s\" => ", O2S(valuePtr)));
+ if (Tcl_IsShared(valuePtr)) {
+ s1 = TclGetStringFromObj(valuePtr, &length);
+ TclNewStringObj(objResultPtr, s1, length);
+ length = Tcl_UtfToUpper(TclGetString(objResultPtr));
+ Tcl_SetObjLength(objResultPtr, length);
+ TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ length = Tcl_UtfToUpper(TclGetString(valuePtr));
+ Tcl_SetObjLength(valuePtr, length);
+ TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+ case INST_STR_LOWER:
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.20s\" => ", O2S(valuePtr)));
+ if (Tcl_IsShared(valuePtr)) {
+ s1 = TclGetStringFromObj(valuePtr, &length);
+ TclNewStringObj(objResultPtr, s1, length);
+ length = Tcl_UtfToLower(TclGetString(objResultPtr));
+ Tcl_SetObjLength(objResultPtr, length);
+ TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ length = Tcl_UtfToLower(TclGetString(valuePtr));
+ Tcl_SetObjLength(valuePtr, length);
+ TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+ case INST_STR_TITLE:
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.20s\" => ", O2S(valuePtr)));
+ if (Tcl_IsShared(valuePtr)) {
+ s1 = TclGetStringFromObj(valuePtr, &length);
+ TclNewStringObj(objResultPtr, s1, length);
+ length = Tcl_UtfToTitle(TclGetString(objResultPtr));
+ Tcl_SetObjLength(objResultPtr, length);
+ TRACE_APPEND(("\"%.20s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ length = Tcl_UtfToTitle(TclGetString(valuePtr));
+ Tcl_SetObjLength(valuePtr, length);
+ TRACE_APPEND(("\"%.20s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+
case INST_STR_INDEX:
value2Ptr = OBJ_AT_TOS;
valuePtr = OBJ_UNDER_TOS;
+ TRACE(("\"%.20s\" %.20s => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Get char length to calulate what 'end' means.
@@ -4792,6 +5307,7 @@ TEBCresume(
length = Tcl_GetCharLength(valuePtr);
if (TclGetIntForIndexM(interp, value2Ptr, length-1, &index)!=TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -4817,18 +5333,18 @@ TEBCresume(
objResultPtr = Tcl_NewStringObj(buf, length);
}
- TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
- O2S(objResultPtr)));
+ TRACE_APPEND(("\"%s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_STR_RANGE:
- TRACE(("\"%.20s\" %s %s =>",
+ TRACE(("\"%.20s\" %.20s %.20s =>",
O2S(OBJ_AT_DEPTH(2)), O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS)));
length = Tcl_GetCharLength(OBJ_AT_DEPTH(2)) - 1;
if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
&fromIdx) != TCL_OK
|| TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
&toIdx) != TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -4888,33 +5404,206 @@ TEBCresume(
int length3;
Tcl_Obj *value3Ptr;
+ case INST_STR_REPLACE:
+ value3Ptr = POP_OBJECT();
+ valuePtr = OBJ_AT_DEPTH(2);
+ length = Tcl_GetCharLength(valuePtr) - 1;
+ TRACE(("\"%.20s\" %s %s \"%.20s\" => ", O2S(valuePtr),
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), O2S(value3Ptr)));
+ if (TclGetIntForIndexM(interp, OBJ_UNDER_TOS, length,
+ &fromIdx) != TCL_OK
+ || TclGetIntForIndexM(interp, OBJ_AT_TOS, length,
+ &toIdx) != TCL_OK) {
+ TclDecrRefCount(value3Ptr);
+ TRACE_ERROR(interp);
+ goto gotError;
+ }
+ TclDecrRefCount(OBJ_AT_TOS);
+ (void) POP_OBJECT();
+ TclDecrRefCount(OBJ_AT_TOS);
+ (void) POP_OBJECT();
+ if (fromIdx < 0) {
+ fromIdx = 0;
+ }
+
+ if (fromIdx > toIdx || fromIdx > length) {
+ TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ TclDecrRefCount(value3Ptr);
+ NEXT_INST_F(1, 0, 0);
+ }
+
+ if (toIdx > length) {
+ toIdx = length;
+ }
+
+ if (fromIdx == 0 && toIdx == length) {
+ TclDecrRefCount(OBJ_AT_TOS);
+ OBJ_AT_TOS = value3Ptr;
+ TRACE_APPEND(("\"%.30s\"\n", O2S(value3Ptr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+
+ length3 = Tcl_GetCharLength(value3Ptr);
+
+ /*
+ * Remove substring. In-place.
+ */
+
+ if (length3 == 0 && !Tcl_IsShared(valuePtr) && toIdx == length) {
+ TclDecrRefCount(value3Ptr);
+ Tcl_SetObjLength(valuePtr, fromIdx);
+ TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+
+ /*
+ * See if we can splice in place. This happens when the number of
+ * characters being replaced is the same as the number of characters
+ * in the string to be inserted.
+ */
+
+ if (length3 - 1 == toIdx - fromIdx) {
+ unsigned char *bytes1, *bytes2;
+
+ if (Tcl_IsShared(valuePtr)) {
+ objResultPtr = Tcl_DuplicateObj(valuePtr);
+ if (TclIsPureByteArray(objResultPtr)
+ && TclIsPureByteArray(value3Ptr)) {
+ bytes1 = Tcl_GetByteArrayFromObj(objResultPtr, NULL);
+ bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
+ memcpy(bytes1 + fromIdx, bytes2, length3);
+ } else {
+ ustring1 = Tcl_GetUnicodeFromObj(objResultPtr, NULL);
+ ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
+ memcpy(ustring1 + fromIdx, ustring2,
+ length3 * sizeof(Tcl_UniChar));
+
+ /*
+ * Magic! Flush the info in the string internal rep that
+ * refers to the about-to-be-invalidated UTF-8 rep. This
+ * sets the 'allocated' field of the String structure to 0
+ * to indicate that a new buffer needs to be allocated.
+ * This is safe; we know we've got a tclStringTypePtr set
+ * at this point (post Tcl_GetUnicodeFromObj).
+ */
+
+ ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0;
+ }
+ Tcl_InvalidateStringRep(objResultPtr);
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ } else {
+ if (TclIsPureByteArray(valuePtr)
+ && TclIsPureByteArray(value3Ptr)) {
+ bytes1 = Tcl_GetByteArrayFromObj(valuePtr, NULL);
+ bytes2 = Tcl_GetByteArrayFromObj(value3Ptr, NULL);
+ memcpy(bytes1 + fromIdx, bytes2, length3);
+ } else {
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, NULL);
+ ustring2 = Tcl_GetUnicodeFromObj(value3Ptr, NULL);
+ memcpy(ustring1 + fromIdx, ustring2,
+ length3 * sizeof(Tcl_UniChar));
+
+ /*
+ * Magic! Flush the info in the string internal rep that
+ * refers to the about-to-be-invalidated UTF-8 rep. This
+ * sets the 'allocated' field of the String structure to 0
+ * to indicate that a new buffer needs to be allocated.
+ * This is safe; we know we've got a tclStringTypePtr set
+ * at this point (post Tcl_GetUnicodeFromObj).
+ */
+
+ ((int *) objResultPtr->internalRep.otherValuePtr)[1] = 0;
+ }
+ Tcl_InvalidateStringRep(valuePtr);
+ TRACE_APPEND(("\"%.30s\"\n", O2S(valuePtr)));
+ NEXT_INST_F(1, 0, 0);
+ }
+ }
+
+ /*
+ * Get the unicode representation; this is where we guarantee to lose
+ * bytearrays.
+ */
+
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ length--;
+
+ /*
+ * Remove substring using copying.
+ */
+
+ if (length3 == 0) {
+ if (fromIdx > 0) {
+ objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
+ if (toIdx < length) {
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ } else {
+ objResultPtr = Tcl_NewUnicodeObj(ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ TclDecrRefCount(value3Ptr);
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+ }
+
+ /*
+ * Splice string pieces by full copying.
+ */
+
+ if (fromIdx > 0) {
+ objResultPtr = Tcl_NewUnicodeObj(ustring1, fromIdx);
+ Tcl_AppendObjToObj(objResultPtr, value3Ptr);
+ if (toIdx < length) {
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ } else if (Tcl_IsShared(value3Ptr)) {
+ objResultPtr = Tcl_DuplicateObj(value3Ptr);
+ if (toIdx < length) {
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ } else {
+ objResultPtr = value3Ptr;
+ if (toIdx < length) {
+ Tcl_AppendUnicodeToObj(objResultPtr, ustring1 + toIdx + 1,
+ length - toIdx);
+ }
+ }
+ TclDecrRefCount(value3Ptr);
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
+ NEXT_INST_F(1, 1, 1);
+
case INST_STR_MAP:
valuePtr = OBJ_AT_TOS; /* "Main" string. */
value3Ptr = OBJ_UNDER_TOS; /* "Target" string. */
value2Ptr = OBJ_AT_DEPTH(2); /* "Source" string. */
if (value3Ptr == value2Ptr) {
objResultPtr = valuePtr;
- NEXT_INST_V(1, 3, 1);
+ goto doneStringMap;
} else if (valuePtr == value2Ptr) {
objResultPtr = value3Ptr;
- NEXT_INST_V(1, 3, 1);
+ goto doneStringMap;
}
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
if (length == 0) {
objResultPtr = valuePtr;
- NEXT_INST_V(1, 3, 1);
+ goto doneStringMap;
}
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
if (length2 > length || length2 == 0) {
objResultPtr = valuePtr;
- NEXT_INST_V(1, 3, 1);
+ goto doneStringMap;
} else if (length2 == length) {
if (memcmp(ustring1, ustring2, sizeof(Tcl_UniChar) * length)) {
objResultPtr = valuePtr;
} else {
objResultPtr = value3Ptr;
}
- NEXT_INST_V(1, 3, 1);
+ goto doneStringMap;
}
ustring3 = Tcl_GetUnicodeFromObj(value3Ptr, &length3);
@@ -4943,6 +5632,7 @@ TEBCresume(
Tcl_AppendUnicodeToObj(objResultPtr, p, ustring1 - p);
}
+ doneStringMap:
TRACE_WITH_OBJ(("%.20s %.20s %.20s => ",
O2S(value2Ptr), O2S(value3Ptr), O2S(valuePtr)), objResultPtr);
NEXT_INST_V(1, 3, 1);
@@ -4965,7 +5655,6 @@ TEBCresume(
TRACE(("%.20s %.20s => %d\n",
O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), match));
-
TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
@@ -4989,6 +5678,25 @@ TEBCresume(
TclNewLongObj(objResultPtr, match);
NEXT_INST_F(1, 2, 1);
+
+ case INST_STR_CLASS:
+ opnd = TclGetInt1AtPtr(pc+1);
+ valuePtr = OBJ_AT_TOS;
+ TRACE(("%s \"%.30s\" => ", tclStringClassTable[opnd].name,
+ O2S(valuePtr)));
+ ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length);
+ match = 1;
+ if (length > 0) {
+ end = ustring1 + length;
+ for (p=ustring1 ; p<end ; p++) {
+ if (!tclStringClassTable[opnd].comparator(*p)) {
+ match = 0;
+ break;
+ }
+ }
+ }
+ TRACE_APPEND(("%d\n", match));
+ JUMP_PEEPHOLE_F(match, 2, 1);
}
case INST_STR_MATCH:
@@ -5031,26 +5739,77 @@ TEBCresume(
* 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);
+ JUMP_PEEPHOLE_F(match, 2, 2);
+
+ {
+ const char *string1, *string2;
+ int trim1, trim2;
+
+ case INST_STR_TRIM_LEFT:
+ valuePtr = OBJ_UNDER_TOS; /* String */
+ value2Ptr = OBJ_AT_TOS; /* TrimSet */
+ string2 = TclGetStringFromObj(value2Ptr, &length2);
+ string1 = TclGetStringFromObj(valuePtr, &length);
+ trim1 = TclTrimLeft(string1, length, string2, length2);
+ trim2 = 0;
+ goto createTrimmedString;
+ case INST_STR_TRIM_RIGHT:
+ valuePtr = OBJ_UNDER_TOS; /* String */
+ value2Ptr = OBJ_AT_TOS; /* TrimSet */
+ string2 = TclGetStringFromObj(value2Ptr, &length2);
+ string1 = TclGetStringFromObj(valuePtr, &length);
+ trim2 = TclTrimRight(string1, length, string2, length2);
+ trim1 = 0;
+ goto createTrimmedString;
+ case INST_STR_TRIM:
+ valuePtr = OBJ_UNDER_TOS; /* String */
+ value2Ptr = OBJ_AT_TOS; /* TrimSet */
+ string2 = TclGetStringFromObj(value2Ptr, &length2);
+ string1 = TclGetStringFromObj(valuePtr, &length);
+ trim1 = TclTrimLeft(string1, length, string2, length2);
+ if (trim1 < length) {
+ trim2 = TclTrimRight(string1, length, string2, length2);
+ } else {
+ trim2 = 0;
+ }
+ createTrimmedString:
+ /*
+ * Careful here; trim set often contains non-ASCII characters so we
+ * take care when printing. [Bug 971cb4f1db]
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ TRACE(("\"%.30s\" ", O2S(valuePtr)));
+ TclPrintObject(stdout, value2Ptr, 30);
+ printf(" => ");
}
#endif
- objResultPtr = TCONST(match);
- NEXT_INST_F(0, 2, 1);
+ if (trim1 == 0 && trim2 == 0) {
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ TclPrintObject(stdout, valuePtr, 30);
+ printf("\n");
+ }
+#endif
+ NEXT_INST_F(1, 1, 0);
+ } else {
+ objResultPtr = Tcl_NewStringObj(string1+trim1, length-trim1-trim2);
+#ifdef TCL_COMPILE_DEBUG
+ if (traceInstructions) {
+ TclPrintObject(stdout, objResultPtr, 30);
+ printf("\n");
+ }
+#endif
+ NEXT_INST_F(1, 2, 1);
+ }
+ }
case INST_REGEXP:
cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */
valuePtr = OBJ_AT_TOS; /* String */
value2Ptr = OBJ_UNDER_TOS; /* Pattern */
+ TRACE(("\"%.30s\" \"%.30s\" => ", O2S(valuePtr), O2S(value2Ptr)));
/*
* Compile and match the regular expression.
@@ -5061,44 +5820,24 @@ TEBCresume(
Tcl_GetRegExpFromObj(interp, value2Ptr, cflags);
if (regExpr == NULL) {
- goto regexpFailure;
+ TRACE_ERROR(interp);
+ goto gotError;
}
-
match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0);
-
if (match < 0) {
- regexpFailure:
-#ifdef TCL_COMPILE_DEBUG
- objResultPtr = Tcl_GetObjResult(interp);
- TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",
- O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
-#endif
+ TRACE_ERROR(interp);
goto gotError;
}
}
- TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
+ TRACE_APPEND(("%d\n", match));
/*
* Peep-hole optimisation: if you're about to jump, do jump from here.
* Adjustment is 2 due to the nocase byte.
*/
- 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);
+ JUMP_PEEPHOLE_F(match, 2, 2);
}
/*
@@ -5112,6 +5851,14 @@ TEBCresume(
int type1, type2;
long l1, l2, lResult;
+ case INST_NUM_TYPE:
+ if (GetNumberFromObj(NULL, OBJ_AT_TOS, &ptr1, &type1) != TCL_OK) {
+ type1 = 0;
+ }
+ TclNewLongObj(objResultPtr, type1);
+ TRACE(("\"%.20s\" => %d\n", O2S(OBJ_AT_TOS), type1));
+ NEXT_INST_F(1, 1, 1);
+
case INST_EQ:
case INST_NEQ:
case INST_LT:
@@ -5196,21 +5943,9 @@ TEBCresume(
*/
foundResult:
- pc++;
-#ifndef TCL_COMPILE_DEBUG
- switch (*pc) {
- case INST_JUMP_FALSE1:
- NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
- case INST_JUMP_TRUE1:
- NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
- case INST_JUMP_FALSE4:
- NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
- case INST_JUMP_TRUE4:
- NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
- }
-#endif
- objResultPtr = TCONST(iResult);
- NEXT_INST_F(0, 2, 1);
+ TRACE(("\"%.20s\" \"%.20s\" => %d\n", O2S(valuePtr), O2S(value2Ptr),
+ iResult));
+ JUMP_PEEPHOLE_F(iResult, 1, 2);
}
case INST_MOD:
@@ -5297,13 +6032,13 @@ TEBCresume(
if (l2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
-#if 0
+#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
NULL);
CACHE_STACK_INFO();
-#endif
+#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else if (l1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
@@ -5345,13 +6080,13 @@ TEBCresume(
if (l2 < 0) {
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"negative shift argument", -1));
-#if 0
+#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"domain error: argument not in valid range",
NULL);
CACHE_STACK_INFO();
-#endif
+#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else if (l1 == 0) {
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
@@ -5368,12 +6103,12 @@ TEBCresume(
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"integer value too large to represent", -1));
-#if 0
+#ifdef ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR
DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", NULL);
CACHE_STACK_INFO();
-#endif
+#endif /* ERROR_CODE_FOR_EARLY_DETECTED_ARITH_ERROR */
goto gotError;
} else {
int shift = (int) l2;
@@ -5431,8 +6166,7 @@ TEBCresume(
TRACE_APPEND(("DIVIDE BY ZERO\n"));
goto divideByZero;
} else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
- TRACE_APPEND(("ERROR: %s\n",
- TclGetString(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
} else if (objResultPtr == NULL) {
TRACE_APPEND(("%s\n", O2S(valuePtr)));
@@ -5509,12 +6243,26 @@ TEBCresume(
w1 = (Tcl_WideInt) l1;
w2 = (Tcl_WideInt) l2;
wResult = w1 + w2;
+#ifdef TCL_WIDE_INT_IS_LONG
+ /*
+ * Check for overflow.
+ */
+
+ if (Overflowing(w1, w2, wResult)) {
+ goto overflow;
+ }
+#endif
goto wideResultOfArithmetic;
case INST_SUB:
w1 = (Tcl_WideInt) l1;
w2 = (Tcl_WideInt) l2;
wResult = w1 - w2;
+#ifdef TCL_WIDE_INT_IS_LONG
+ if (Overflowing(w1, ~w2, wResult)) {
+ goto overflow;
+ }
+#endif
wideResultOfArithmetic:
TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
if (Tcl_IsShared(valuePtr)) {
@@ -5580,8 +6328,7 @@ TEBCresume(
TRACE_APPEND(("EXPONENT OF ZERO\n"));
goto exponOfZero;
} else if (objResultPtr == GENERAL_ARITHMETIC_ERROR) {
- TRACE_APPEND(("ERROR: %s\n",
- TclGetString(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
} else if (objResultPtr == NULL) {
TRACE_APPEND(("%s\n", O2S(valuePtr)));
@@ -5599,7 +6346,7 @@ TEBCresume(
/* TODO - check claim that taking address of b harms performance */
/* TODO - consider optimization search for constants */
if (TclGetBooleanFromObj(NULL, valuePtr, &b) != TCL_OK) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
+ TRACE(("\"%.20s\" => ERROR: illegal type %s\n", O2S(valuePtr),
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
@@ -5608,18 +6355,20 @@ TEBCresume(
}
/* TODO: Consider peephole opt. */
objResultPtr = TCONST(!b);
+ TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), objResultPtr);
NEXT_INST_F(1, 1, 1);
}
case INST_BITNOT:
valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
|| (type1==TCL_NUMBER_NAN) || (type1==TCL_NUMBER_DOUBLE)) {
/*
* ... ~$NonInteger => raise an error.
*/
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ TRACE_APPEND(("ERROR: illegal type %s\n",
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
@@ -5630,23 +6379,28 @@ TEBCresume(
l1 = *((const long *) ptr1);
if (Tcl_IsShared(valuePtr)) {
TclNewLongObj(objResultPtr, ~l1);
+ TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
TclSetLongObj(valuePtr, ~l1);
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr);
if (objResultPtr != NULL) {
+ TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
case INST_UMINUS:
valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if ((GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK)
|| IsErroringNaNType(type1)) {
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ TRACE_APPEND(("ERROR: illegal type %s \n",
(valuePtr->typePtr? valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
@@ -5656,23 +6410,28 @@ TEBCresume(
switch (type1) {
case TCL_NUMBER_NAN:
/* -NaN => NaN */
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
case TCL_NUMBER_LONG:
l1 = *((const long *) ptr1);
if (l1 != LONG_MIN) {
if (Tcl_IsShared(valuePtr)) {
TclNewLongObj(objResultPtr, -l1);
+ TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
}
TclSetLongObj(valuePtr, -l1);
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
/* FALLTHROUGH */
}
objResultPtr = ExecuteExtendedUnaryMathOp(*pc, valuePtr);
if (objResultPtr != NULL) {
+ TRACE_APPEND(("%s\n", O2S(objResultPtr)));
NEXT_INST_F(1, 1, 1);
} else {
+ TRACE_APPEND(("%s\n", O2S(valuePtr)));
NEXT_INST_F(1, 0, 0);
}
@@ -5685,6 +6444,7 @@ TEBCresume(
*/
valuePtr = OBJ_AT_TOS;
+ TRACE(("\"%.20s\" => ", O2S(valuePtr)));
if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
if (*pc == INST_UPLUS) {
@@ -5692,7 +6452,7 @@ TEBCresume(
* ... +$NonNumeric => raise an error.
*/
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ TRACE_APPEND(("ERROR: illegal type %s\n",
(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
@@ -5701,7 +6461,7 @@ TEBCresume(
}
/* ... TryConvertToNumeric($NonNumeric) is acceptable */
- TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
+ TRACE_APPEND(("not numeric\n"));
NEXT_INST_F(1, 0, 0);
}
if (IsErroringNaNType(type1)) {
@@ -5710,7 +6470,7 @@ TEBCresume(
* ... +$NonNumeric => raise an error.
*/
- TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
+ TRACE_APPEND(("ERROR: illegal type %s\n",
(valuePtr->typePtr? valuePtr->typePtr->name:"null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
@@ -5720,8 +6480,7 @@ TEBCresume(
* Numeric conversion of NaN -> error.
*/
- TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
- O2S(objResultPtr)));
+ TRACE_APPEND(("ERROR: IEEE floating pt error\n"));
DECACHE_STACK_INFO();
TclExprFloatError(interp, *((const double *) ptr1));
CACHE_STACK_INFO();
@@ -5739,7 +6498,7 @@ TEBCresume(
*/
if (valuePtr->bytes == NULL) {
- TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr)));
+ TRACE_APPEND(("numeric, same Tcl_Obj\n"));
NEXT_INST_F(1, 0, 0);
}
if (Tcl_IsShared(valuePtr)) {
@@ -5754,11 +6513,11 @@ TEBCresume(
valuePtr->bytes = NULL;
objResultPtr = Tcl_DuplicateObj(valuePtr);
valuePtr->bytes = savedString;
- TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr)));
+ TRACE_APPEND(("numeric, new Tcl_Obj\n"));
NEXT_INST_F(1, 1, 1);
}
TclInvalidateStringRep(valuePtr);
- TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr)));
+ TRACE_APPEND(("numeric, same Tcl_Obj\n"));
NEXT_INST_F(1, 0, 0);
}
@@ -5767,6 +6526,17 @@ TEBCresume(
* -----------------------------------------------------------------
*/
+ case INST_TRY_CVT_TO_BOOLEAN:
+ valuePtr = OBJ_AT_TOS;
+ if (valuePtr->typePtr == &tclBooleanType) {
+ objResultPtr = TCONST(1);
+ } else {
+ int result = (TclSetBooleanFromAny(NULL, valuePtr) == TCL_OK);
+ objResultPtr = TCONST(result);
+ }
+ TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(valuePtr)), objResultPtr);
+ NEXT_INST_F(1, 0, 1);
+
case INST_BREAK:
/*
DECACHE_STACK_INFO();
@@ -5775,6 +6545,7 @@ TEBCresume(
*/
result = TCL_BREAK;
cleanup = 0;
+ TRACE(("=> BREAK!\n"));
goto processExceptionReturn;
case INST_CONTINUE:
@@ -5785,6 +6556,7 @@ TEBCresume(
*/
result = TCL_CONTINUE;
cleanup = 0;
+ TRACE(("=> CONTINUE!\n"));
goto processExceptionReturn;
{
@@ -5796,7 +6568,7 @@ TEBCresume(
int varIndex, valIndex, continueLoop, j, iterTmpIndex;
long i;
- case INST_FOREACH_START4:
+ case INST_FOREACH_START4: /* DEPRECATED */
/*
* Initialize the temporary local var that holds the count of the
* number of iterations of the loop body to -1.
@@ -5829,13 +6601,14 @@ TEBCresume(
NEXT_INST_F(5, 0, 0);
#endif
- case INST_FOREACH_STEP4:
+ case INST_FOREACH_STEP4: /* DEPRECATED */
/*
* "Step" a foreach loop (i.e., begin its next iteration) by assigning
* the next value list element to each loop var.
*/
opnd = TclGetUInt4AtPtr(pc+1);
+ TRACE(("%u => ", opnd));
infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
numLists = infoPtr->numLists;
@@ -5862,8 +6635,8 @@ TEBCresume(
listVarPtr = LOCAL(listTmpIndex);
listPtr = listVarPtr->value.objPtr;
if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
- TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
- opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
+ TRACE_APPEND(("ERROR converting list %ld, \"%.30s\": %s\n",
+ i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
if (listLen > iterNum * numVars) {
@@ -5918,9 +6691,9 @@ TEBCresume(
if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
CACHE_STACK_INFO();
- TRACE_WITH_OBJ((
- "%u => ERROR init. index temp %d: ",
- opnd,varIndex), Tcl_GetObjResult(interp));
+ TRACE_APPEND((
+ "ERROR init. index temp %d: %s\n",
+ varIndex, O2S(Tcl_GetObjResult(interp))));
TclDecrRefCount(listPtr);
goto gotError;
}
@@ -5932,8 +6705,8 @@ TEBCresume(
listTmpIndex++;
}
}
- TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
- iterNum, (continueLoop? "continue" : "exit")));
+ TRACE_APPEND(("%d lists, iter %d, %s loop\n",
+ numLists, iterNum, (continueLoop? "continue" : "exit")));
/*
* Run-time peep-hole optimisation: the compiler ALWAYS follows
@@ -5947,6 +6720,200 @@ TEBCresume(
} else {
NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
}
+
+ }
+ {
+ ForeachInfo *infoPtr;
+ Tcl_Obj *listPtr, **elements, *tmpPtr;
+ ForeachVarList *varListPtr;
+ int numLists, iterMax, listLen, numVars;
+ int iterTmp, iterNum, listTmpDepth;
+ int varIndex, valIndex, j;
+ long i;
+
+ case INST_FOREACH_START:
+ /*
+ * Initialize the data for the looping construct, pushing the
+ * corresponding Tcl_Objs to the stack.
+ */
+
+ opnd = TclGetUInt4AtPtr(pc+1);
+ infoPtr = codePtr->auxDataArrayPtr[opnd].clientData;
+ numLists = infoPtr->numLists;
+ TRACE(("%u => ", opnd));
+
+ /*
+ * Compute the number of iterations that will be run: iterMax
+ */
+
+ iterMax = 0;
+ listTmpDepth = numLists-1;
+ for (i = 0; i < numLists; i++) {
+ varListPtr = infoPtr->varLists[i];
+ numVars = varListPtr->numVars;
+ listPtr = OBJ_AT_DEPTH(listTmpDepth);
+ if (TclListObjLength(interp, listPtr, &listLen) != TCL_OK) {
+ TRACE_APPEND(("ERROR converting list %ld, \"%s\": %s",
+ i, O2S(listPtr), O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ if (Tcl_IsShared(listPtr)) {
+ objPtr = TclListObjCopy(NULL, listPtr);
+ Tcl_IncrRefCount(objPtr);
+ Tcl_DecrRefCount(listPtr);
+ OBJ_AT_DEPTH(listTmpDepth) = objPtr;
+ }
+ iterTmp = (listLen + (numVars - 1))/numVars;
+ if (iterTmp > iterMax) {
+ iterMax = iterTmp;
+ }
+ listTmpDepth--;
+ }
+
+ /*
+ * Store the iterNum and iterMax in a single Tcl_Obj; we keep a
+ * nul-string obj with the pointer stored in the ptrValue so that the
+ * thing is properly garbage collected. THIS OBJ MAKES NO SENSE, but
+ * it will never leave this scope and is read-only.
+ */
+
+ TclNewObj(tmpPtr);
+ tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(0);
+ tmpPtr->internalRep.twoPtrValue.ptr2 = INT2PTR(iterMax);
+ PUSH_OBJECT(tmpPtr); /* iterCounts object */
+
+ /*
+ * Store a pointer to the ForeachInfo struct; same dirty trick
+ * as above
+ */
+
+ TclNewObj(tmpPtr);
+ tmpPtr->internalRep.otherValuePtr = infoPtr;
+ PUSH_OBJECT(tmpPtr); /* infoPtr object */
+ TRACE_APPEND(("jump to loop step\n"));
+
+ /*
+ * Jump directly to the INST_FOREACH_STEP instruction; the C code just
+ * falls through.
+ */
+
+ pc += 5 - infoPtr->loopCtTemp;
+
+ case INST_FOREACH_STEP:
+ /*
+ * "Step" a foreach loop (i.e., begin its next iteration) by assigning
+ * the next value list element to each loop var.
+ */
+
+ tmpPtr = OBJ_AT_TOS;
+ infoPtr = tmpPtr->internalRep.otherValuePtr;
+ numLists = infoPtr->numLists;
+ TRACE(("=> "));
+
+ tmpPtr = OBJ_AT_DEPTH(1);
+ iterNum = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr1);
+ iterMax = PTR2INT(tmpPtr->internalRep.twoPtrValue.ptr2);
+
+ /*
+ * If some list still has a remaining list element iterate one more
+ * time. Assign to var the next element from its value list.
+ */
+
+ if (iterNum < iterMax) {
+ /*
+ * Set the variables and jump back to run the body
+ */
+
+ tmpPtr->internalRep.twoPtrValue.ptr1 = INT2PTR(iterNum + 1);
+
+ listTmpDepth = numLists + 1;
+
+ for (i = 0; i < numLists; i++) {
+ varListPtr = infoPtr->varLists[i];
+ numVars = varListPtr->numVars;
+
+ listPtr = OBJ_AT_DEPTH(listTmpDepth);
+ TclListObjGetElements(interp, listPtr, &listLen, &elements);
+
+ valIndex = (iterNum * numVars);
+ for (j = 0; j < numVars; j++) {
+ if (valIndex >= listLen) {
+ TclNewObj(valuePtr);
+ } else {
+ valuePtr = elements[valIndex];
+ }
+
+ varIndex = varListPtr->varIndexes[j];
+ varPtr = LOCAL(varIndex);
+ while (TclIsVarLink(varPtr)) {
+ varPtr = varPtr->value.linkPtr;
+ }
+ if (TclIsVarDirectWritable(varPtr)) {
+ value2Ptr = varPtr->value.objPtr;
+ if (valuePtr != value2Ptr) {
+ if (value2Ptr != NULL) {
+ TclDecrRefCount(value2Ptr);
+ }
+ varPtr->value.objPtr = valuePtr;
+ Tcl_IncrRefCount(valuePtr);
+ }
+ } else {
+ DECACHE_STACK_INFO();
+ if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
+ valuePtr, TCL_LEAVE_ERR_MSG, varIndex)==NULL){
+ CACHE_STACK_INFO();
+ TRACE_APPEND(("ERROR init. index temp %d: %.30s",
+ varIndex, O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
+ }
+ CACHE_STACK_INFO();
+ }
+ valIndex++;
+ }
+ listTmpDepth--;
+ }
+ TRACE_APPEND(("jump to loop start\n"));
+ /* loopCtTemp being 'misused' for storing the jump size */
+ NEXT_INST_F(infoPtr->loopCtTemp, 0, 0);
+ }
+
+ TRACE_APPEND(("loop has no more iterations\n"));
+#ifdef TCL_COMPILE_DEBUG
+ NEXT_INST_F(1, 0, 0);
+#else
+ /*
+ * FALL THROUGH
+ */
+ pc++;
+#endif
+
+ case INST_FOREACH_END:
+ /* THIS INSTRUCTION IS ONLY CALLED AS A BREAK TARGET */
+ tmpPtr = OBJ_AT_TOS;
+ infoPtr = tmpPtr->internalRep.otherValuePtr;
+ numLists = infoPtr->numLists;
+ TRACE(("=> loop terminated\n"));
+ NEXT_INST_V(1, numLists+2, 0);
+
+ case INST_LMAP_COLLECT:
+ /*
+ * This instruction is only issued by lmap. The stack is:
+ * - result
+ * - infoPtr
+ * - loop counters
+ * - valLists
+ * - collecting obj (unshared)
+ * The instruction lappends the result to the collecting obj.
+ */
+
+ tmpPtr = OBJ_AT_DEPTH(1);
+ infoPtr = tmpPtr->internalRep.otherValuePtr;
+ numLists = infoPtr->numLists;
+ TRACE_APPEND(("=> appending to list at depth %d\n", 3 + numLists));
+
+ objPtr = OBJ_AT_DEPTH(3 + numLists);
+ Tcl_ListObjAppendElement(NULL, objPtr, OBJ_AT_TOS);
+ NEXT_INST_F(1, 1, 0);
}
case INST_BEGIN_CATCH4:
@@ -6008,7 +6975,8 @@ TEBCresume(
if (code < TCL_ERROR || code > TCL_CONTINUE) {
code = TCL_CONTINUE + 1;
}
- NEXT_INST_F(2*code -1, 1, 0);
+ TRACE(("\"%s\" => jump offset %d\n", O2S(OBJ_AT_TOS), 2*code-1));
+ NEXT_INST_F(2*code-1, 1, 0);
}
/*
@@ -6025,10 +6993,10 @@ TEBCresume(
case INST_DICT_VERIFY:
dictPtr = OBJ_AT_TOS;
- TRACE(("=> "));
+ TRACE(("\"%.30s\" => ", O2S(dictPtr)));
if (Tcl_DictObjSize(interp, dictPtr, &done) != TCL_OK) {
- TRACE_APPEND(("ERROR verifying dictionary nature of \"%s\": %s\n",
- O2S(OBJ_AT_DEPTH(opnd)), O2S(Tcl_GetObjResult(interp))));
+ TRACE_APPEND(("ERROR verifying dictionary nature of \"%.30s\": %s\n",
+ O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
goto gotError;
}
TRACE_APPEND(("OK\n"));
@@ -6037,6 +7005,7 @@ TEBCresume(
case INST_DICT_GET:
case INST_DICT_EXISTS: {
register Tcl_Interp *interp2 = interp;
+ register int found;
opnd = TclGetUInt4AtPtr(pc+1);
TRACE(("%u => ", opnd));
@@ -6049,10 +7018,11 @@ TEBCresume(
&OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
if (dictPtr == NULL) {
if (*pc == INST_DICT_EXISTS) {
- goto dictNotExists;
+ found = 0;
+ goto afterDictExists;
}
TRACE_WITH_OBJ((
- "ERROR tracing dictionary path into \"%s\": ",
+ "ERROR tracing dictionary path into \"%.30s\": ",
O2S(OBJ_AT_DEPTH(opnd))),
Tcl_GetObjResult(interp));
goto gotError;
@@ -6061,34 +7031,40 @@ TEBCresume(
if (Tcl_DictObjGet(interp2, dictPtr, OBJ_AT_TOS,
&objResultPtr) == TCL_OK) {
if (*pc == INST_DICT_EXISTS) {
- objResultPtr = TCONST(objResultPtr ? 1 : 0);
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(5, opnd+1, 1);
+ found = (objResultPtr ? 1 : 0);
+ goto afterDictExists;
}
- if (objResultPtr) {
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(5, opnd+1, 1);
+ if (!objResultPtr) {
+ Tcl_SetObjResult(interp, Tcl_ObjPrintf(
+ "key \"%s\" not known in dictionary",
+ TclGetString(OBJ_AT_TOS)));
+ DECACHE_STACK_INFO();
+ Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
+ TclGetString(OBJ_AT_TOS), NULL);
+ CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
+ goto gotError;
}
- DECACHE_STACK_INFO();
- Tcl_SetObjResult(interp, Tcl_ObjPrintf(
- "key \"%s\" not known in dictionary",
- TclGetString(OBJ_AT_TOS)));
- Tcl_SetErrorCode(interp, "TCL", "LOOKUP", "DICT",
- TclGetString(OBJ_AT_TOS), NULL);
- CACHE_STACK_INFO();
- TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
+ TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ NEXT_INST_V(5, opnd+1, 1);
+ } else if (*pc != INST_DICT_EXISTS) {
+ TRACE_APPEND(("ERROR reading leaf dictionary key \"%.30s\": %s",
+ O2S(dictPtr), O2S(Tcl_GetObjResult(interp))));
+ goto gotError;
} else {
- if (*pc == INST_DICT_EXISTS) {
- dictNotExists:
- objResultPtr = TCONST(0);
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
- NEXT_INST_V(5, opnd+1, 1);
- }
- TRACE_WITH_OBJ((
- "%u => ERROR reading leaf dictionary key \"%s\": ",
- opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
+ found = 0;
}
- goto gotError;
+ afterDictExists:
+ TRACE_APPEND(("%d\n", found));
+
+ /*
+ * The INST_DICT_EXISTS instruction is usually followed by a
+ * conditional jump, so we can take advantage of this to do some
+ * peephole optimization (note that we're careful to not close out
+ * someone doing something else).
+ */
+
+ JUMP_PEEPHOLE_V(found, 5, opnd+1);
}
case INST_DICT_SET:
@@ -6162,8 +7138,8 @@ TEBCresume(
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
- TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",
- opnd, opnd2), Tcl_GetObjResult(interp));
+ TRACE_APPEND(("ERROR updating dictionary: %s\n",
+ O2S(Tcl_GetObjResult(interp))));
goto checkForCatch;
}
@@ -6185,8 +7161,7 @@ TEBCresume(
CACHE_STACK_INFO();
TclDecrRefCount(dictPtr);
if (objResultPtr == NULL) {
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
}
@@ -6195,7 +7170,7 @@ TEBCresume(
NEXT_INST_V(10, cleanup, 0);
}
#endif
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_V(9, cleanup, 1);
case INST_DICT_APPEND:
@@ -6228,6 +7203,7 @@ TEBCresume(
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -6276,6 +7252,7 @@ TEBCresume(
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
+ TRACE_ERROR(interp);
goto gotError;
}
Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valuePtr);
@@ -6285,6 +7262,7 @@ TEBCresume(
if (allocateDict) {
TclDecrRefCount(dictPtr);
}
+ TRACE_ERROR(interp);
goto gotError;
}
@@ -6321,8 +7299,7 @@ TEBCresume(
CACHE_STACK_INFO();
TclDecrRefCount(dictPtr);
if (objResultPtr == NULL) {
- TRACE_APPEND(("ERROR: %.30s\n",
- O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
}
@@ -6342,6 +7319,7 @@ TEBCresume(
if (Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
&valuePtr, &done) != TCL_OK) {
ckfree(searchPtr);
+ TRACE_ERROR(interp);
goto gotError;
}
TclNewObj(statePtr);
@@ -6377,8 +7355,9 @@ TEBCresume(
PUSH_OBJECT(valuePtr);
PUSH_OBJECT(keyPtr);
}
+ TRACE_APPEND(("\"%.30s\" \"%.30s\" %d\n",
+ O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
-#ifndef TCL_COMPILE_DEBUG
/*
* The INST_DICT_FIRST and INST_DICT_NEXT instructsions are always
* followed by a conditional jump, so we can take advantage of this to
@@ -6386,37 +7365,17 @@ TEBCresume(
* out someone doing something else).
*/
- pc += 5;
- switch (*pc) {
- case INST_JUMP_FALSE1:
- NEXT_INST_F((done ? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
- case INST_JUMP_FALSE4:
- NEXT_INST_F((done ? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
- case INST_JUMP_TRUE1:
- NEXT_INST_F((done ? TclGetInt1AtPtr(pc+1) : 2), 0, 0);
- case INST_JUMP_TRUE4:
- NEXT_INST_F((done ? TclGetInt4AtPtr(pc+1) : 5), 0, 0);
- default:
- pc -= 5;
- /* fall through to non-debug handling */
- }
-#endif
-
- TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
- O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
- objResultPtr = TCONST(done);
- /* TODO: consider opt like INST_FOREACH_STEP4 */
- NEXT_INST_F(5, 0, 1);
+ JUMP_PEEPHOLE_F(done, 5, 0);
case INST_DICT_UPDATE_START:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
+ TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
- TRACE(("%u => ", opnd));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
@@ -6425,11 +7384,13 @@ TEBCresume(
TCL_LEAVE_ERR_MSG, opnd);
CACHE_STACK_INFO();
if (dictPtr == NULL) {
+ TRACE_ERROR(interp);
goto gotError;
}
}
if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
if (length != duiPtr->length) {
@@ -6438,6 +7399,7 @@ TEBCresume(
for (i=0 ; i<length ; i++) {
if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
&valuePtr) != TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
varPtr = LOCAL(duiPtr->varIndices[i]);
@@ -6453,21 +7415,23 @@ TEBCresume(
valuePtr, TCL_LEAVE_ERR_MSG,
duiPtr->varIndices[i]) == NULL) {
CACHE_STACK_INFO();
+ TRACE_ERROR(interp);
goto gotError;
}
CACHE_STACK_INFO();
}
+ TRACE_APPEND(("OK\n"));
NEXT_INST_F(9, 0, 0);
case INST_DICT_UPDATE_END:
opnd = TclGetUInt4AtPtr(pc+1);
opnd2 = TclGetUInt4AtPtr(pc+5);
+ TRACE(("%u => ", opnd));
varPtr = LOCAL(opnd);
duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
- TRACE(("%u => ", opnd));
if (TclIsVarDirectReadable(varPtr)) {
dictPtr = varPtr->value.objPtr;
} else {
@@ -6476,11 +7440,13 @@ TEBCresume(
CACHE_STACK_INFO();
}
if (dictPtr == NULL) {
+ TRACE_APPEND(("storage was unset\n"));
NEXT_INST_F(9, 1, 0);
}
if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
|| TclListObjGetElements(interp, OBJ_AT_TOS, &length,
&keyPtrPtr) != TCL_OK) {
+ TRACE_ERROR(interp);
goto gotError;
}
allocdict = Tcl_IsShared(dictPtr);
@@ -6526,26 +7492,27 @@ TEBCresume(
if (allocdict) {
TclDecrRefCount(dictPtr);
}
+ TRACE_ERROR(interp);
goto gotError;
}
}
+ TRACE_APPEND(("written back\n"));
NEXT_INST_F(9, 1, 0);
case INST_DICT_EXPAND:
dictPtr = OBJ_UNDER_TOS;
listPtr = OBJ_AT_TOS;
+ TRACE(("\"%.30s\" \"%.30s\" =>", O2S(dictPtr), O2S(listPtr)));
if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
- TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ",
- O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
objResultPtr = TclDictWithInit(interp, dictPtr, objc, objv);
if (objResultPtr == NULL) {
- TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ",
- O2S(dictPtr), O2S(listPtr)), Tcl_GetObjResult(interp));
+ TRACE_ERROR(interp);
goto gotError;
}
- TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
+ TRACE_APPEND(("\"%.30s\"\n", O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
case INST_DICT_RECOMBINE_STK:
@@ -6555,14 +7522,14 @@ TEBCresume(
TRACE(("\"%.30s\" \"%.30s\" \"%.30s\" => ",
O2S(varNamePtr), O2S(valuePtr), O2S(keysPtr)));
if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
TclDecrRefCount(keysPtr);
goto gotError;
}
varPtr = TclObjLookupVarEx(interp, varNamePtr, NULL,
TCL_LEAVE_ERR_MSG, "set", 1, 1, &arrayPtr);
if (varPtr == NULL) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
TclDecrRefCount(keysPtr);
goto gotError;
}
@@ -6572,7 +7539,7 @@ TEBCresume(
CACHE_STACK_INFO();
TclDecrRefCount(keysPtr);
if (result != TCL_OK) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("OK\n"));
@@ -6586,7 +7553,7 @@ TEBCresume(
TRACE(("%u <- \"%.30s\" \"%.30s\" => ", opnd, O2S(valuePtr),
O2S(keysPtr)));
if (TclListObjGetElements(interp, listPtr, &objc, &objv) != TCL_OK) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
while (TclIsVarLink(varPtr)) {
@@ -6597,7 +7564,7 @@ TEBCresume(
objc, objv, keysPtr);
CACHE_STACK_INFO();
if (result != TCL_OK) {
- TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
+ TRACE_ERROR(interp);
goto gotError;
}
TRACE_APPEND(("OK\n"));
@@ -6632,7 +7599,7 @@ TEBCresume(
*/
processExceptionReturn:
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
switch (*pc) {
case INST_INVOKE_STK1:
opnd = TclGetUInt1AtPtr(pc+1);
@@ -6689,14 +7656,14 @@ TEBCresume(
rangePtr->codeOffset, rangePtr->continueOffset));
NEXT_INST_F(0, 0, 0);
}
-#if TCL_COMPILE_DEBUG
+#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
objPtr = Tcl_GetObjResult(interp);
if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
- TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
+ TRACE_APPEND(("OTHER RETURN CODE %d, result=\"%.30s\"\n ",
result, O2S(objPtr)));
} else {
- TRACE_APPEND(("%s, result= \"%s\"\n",
+ TRACE_APPEND(("%s, result=\"%.30s\"\n",
StringForResultCode(result), O2S(objPtr)));
}
}
@@ -6709,8 +7676,8 @@ TEBCresume(
*/
divideByZero:
- DECACHE_STACK_INFO();
Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
+ DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
CACHE_STACK_INFO();
goto gotError;
@@ -6721,9 +7688,9 @@ TEBCresume(
*/
exponOfZero:
- DECACHE_STACK_INFO();
Tcl_SetObjResult(interp, Tcl_NewStringObj(
"exponentiation of zero by negative power", -1));
+ DECACHE_STACK_INFO();
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
"exponentiation of zero by negative power", NULL);
CACHE_STACK_INFO();
@@ -6751,7 +7718,7 @@ TEBCresume(
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
const unsigned char *pcBeg;
- bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg);
+ bytes = GetSrcInfoForPc(pc, codePtr, &length, &pcBeg, NULL);
DECACHE_STACK_INFO();
TclLogCommandInfo(interp, codePtr->source, bytes,
bytes ? length : 0, pcBeg, tosPtr);
@@ -6933,7 +7900,7 @@ TEBCresume(
}
codePtr->flags |= TCL_BYTECODE_RECOMPILE;
- bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL);
+ bytes = GetSrcInfoForPc(pc, codePtr, &length, NULL, NULL);
opnd = TclGetUInt4AtPtr(pc+1);
pc += (opnd-1);
PUSH_OBJECT(Tcl_NewStringObj(bytes, length));
@@ -6949,6 +7916,58 @@ TEBCresume(
#undef auxObjList
#undef catchTop
#undef TCONST
+
+static int
+FinalizeOONext(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallContext *contextPtr = data[1];
+
+ /*
+ * Reset the variable lookup frame.
+ */
+
+ iPtr->varFramePtr = data[0];
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = PTR2INT(data[2]);
+ contextPtr->skip = PTR2INT(data[3]);
+ contextPtr->oPtr->flags &= ~FILTER_HANDLING;
+ return result;
+}
+
+static int
+FinalizeOONextFilter(
+ ClientData data[],
+ Tcl_Interp *interp,
+ int result)
+{
+ Interp *iPtr = (Interp *) interp;
+ CallContext *contextPtr = data[1];
+
+ /*
+ * Reset the variable lookup frame.
+ */
+
+ iPtr->varFramePtr = data[0];
+
+ /*
+ * Restore the call chain context index as we've finished the inner invoke
+ * and want to operate in the outer context again.
+ */
+
+ contextPtr->index = PTR2INT(data[2]);
+ contextPtr->skip = PTR2INT(data[3]);
+ contextPtr->oPtr->flags |= FILTER_HANDLING;
+ return result;
+}
/*
*----------------------------------------------------------------------
@@ -7045,6 +8064,7 @@ ExecuteExtendedBinaryMathOp(
return constants[0];
}
}
+#ifndef TCL_WIDE_INT_IS_LONG
if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *)ptr1);
if (type2 != TCL_NUMBER_BIG) {
@@ -7089,6 +8109,7 @@ ExecuteExtendedBinaryMathOp(
mp_clear(&big2);
return NULL;
}
+#endif
Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
mp_init(&bigResult);
@@ -7118,9 +8139,11 @@ ExecuteExtendedBinaryMathOp(
case TCL_NUMBER_LONG:
invalid = (*((const long *)ptr2) < 0L);
break;
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
break;
+#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
invalid = (mp_cmp_d(&big2, 0) == MP_LT);
@@ -7200,9 +8223,11 @@ ExecuteExtendedBinaryMathOp(
case TCL_NUMBER_LONG:
zero = (*(const long *)ptr1 > 0L);
break;
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
break;
+#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
zero = (mp_cmp_d(&big1, 0) == MP_GT);
@@ -7219,6 +8244,7 @@ ExecuteExtendedBinaryMathOp(
}
shift = (int)(*(const long *)ptr2);
+#ifndef TCL_WIDE_INT_IS_LONG
/*
* Handle shifts within the native wide range.
*/
@@ -7233,6 +8259,7 @@ ExecuteExtendedBinaryMathOp(
}
WIDE_RESULT(w1 >> shift);
}
+#endif
}
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
@@ -7400,6 +8427,7 @@ ExecuteExtendedBinaryMathOp(
BIG_RESULT(&bigResult);
}
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
TclGetWideIntFromObj(NULL, valuePtr, &w1);
TclGetWideIntFromObj(NULL, value2Ptr, &w2);
@@ -7420,6 +8448,7 @@ ExecuteExtendedBinaryMathOp(
}
WIDE_RESULT(wResult);
}
+#endif
l1 = *((const long *)ptr1);
l2 = *((const long *)ptr2);
@@ -7476,11 +8505,13 @@ ExecuteExtendedBinaryMathOp(
negativeExponent = (l2 < 0);
oddExponent = (int) (l2 & 1);
break;
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
negativeExponent = (w2 < 0);
oddExponent = (int) (w2 & (Tcl_WideInt)1);
break;
+#endif
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
@@ -7570,9 +8601,11 @@ ExecuteExtendedBinaryMathOp(
if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
LONG_RESULT(1L << l2);
}
+#if !defined(TCL_WIDE_INT_IS_LONG)
if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1) {
WIDE_RESULT(((Tcl_WideInt) 1) << l2);
}
+#endif
goto overflowExpon;
}
if (l1 == -2) {
@@ -7585,9 +8618,11 @@ ExecuteExtendedBinaryMathOp(
if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
LONG_RESULT(signum * (1L << l2));
}
+#if !defined(TCL_WIDE_INT_IS_LONG)
if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
WIDE_RESULT(signum * (((Tcl_WideInt) 1) << l2));
}
+#endif
goto overflowExpon;
}
#if (LONG_MAX == 0x7fffffff)
@@ -7659,11 +8694,13 @@ ExecuteExtendedBinaryMathOp(
}
#endif
}
-#if (LONG_MAX > 0x7fffffff)
+#if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
if (type1 == TCL_NUMBER_LONG) {
w1 = l1;
+#ifndef TCL_WIDE_INT_IS_LONG
} else if (type1 == TCL_NUMBER_WIDE) {
w1 = *((const Tcl_WideInt *) ptr1);
+#endif
} else {
goto overflowExpon;
}
@@ -7863,7 +8900,9 @@ ExecuteExtendedBinaryMathOp(
switch (opcode) {
case INST_ADD:
wResult = w1 + w2;
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+#endif
{
/*
* Check for overflow.
@@ -7877,7 +8916,9 @@ ExecuteExtendedBinaryMathOp(
case INST_SUB:
wResult = w1 - w2;
+#ifndef TCL_WIDE_INT_IS_LONG
if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
+#endif
{
/*
* Must check for overflow. The macro tests for overflows
@@ -8001,10 +9042,12 @@ ExecuteExtendedUnaryMathOp(
switch (opcode) {
case INST_BITNOT:
+#ifndef TCL_WIDE_INT_IS_LONG
if (type == TCL_NUMBER_WIDE) {
w = *((const Tcl_WideInt *) ptr);
WIDE_RESULT(~w);
}
+#endif
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
/* ~a = - a - 1 */
mp_neg(&big, &big);
@@ -8021,6 +9064,7 @@ ExecuteExtendedUnaryMathOp(
}
TclBNInitBignumFromLong(&big, *(const long *) ptr);
break;
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w = *((const Tcl_WideInt *) ptr);
if (w != LLONG_MIN) {
@@ -8028,6 +9072,7 @@ ExecuteExtendedUnaryMathOp(
}
TclBNInitBignumFromWideInt(&big, w);
break;
+#endif
default:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
}
@@ -8071,7 +9116,9 @@ TclCompareTwoNumbers(
mp_int big1, big2;
double d1, d2, tmp;
long l1, l2;
+#ifndef TCL_WIDE_INT_IS_LONG
Tcl_WideInt w1, w2;
+#endif
(void) GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
(void) GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
@@ -8084,10 +9131,12 @@ TclCompareTwoNumbers(
l2 = *((const long *)ptr2);
longCompare:
return (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
w1 = (Tcl_WideInt)l1;
goto wideCompare;
+#endif
case TCL_NUMBER_DOUBLE:
d2 = *((const double *)ptr2);
d1 = (double) l1;
@@ -8134,6 +9183,7 @@ TclCompareTwoNumbers(
return compare;
}
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w1 = *((const Tcl_WideInt *)ptr1);
switch (type2) {
@@ -8170,6 +9220,7 @@ TclCompareTwoNumbers(
mp_clear(&big2);
return compare;
}
+#endif
case TCL_NUMBER_DOUBLE:
d1 = *((const double *)ptr1);
@@ -8193,6 +9244,7 @@ TclCompareTwoNumbers(
}
l1 = (long) d1;
goto longCompare;
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
w2 = *((const Tcl_WideInt *)ptr2);
d2 = (double) w2;
@@ -8208,6 +9260,7 @@ TclCompareTwoNumbers(
}
w1 = (Tcl_WideInt) d1;
goto wideCompare;
+#endif
case TCL_NUMBER_BIG:
if (TclIsInfinite(d1)) {
return (d1 > 0.0) ? MP_GT : MP_LT;
@@ -8235,7 +9288,9 @@ TclCompareTwoNumbers(
case TCL_NUMBER_BIG:
Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
switch (type2) {
+#ifndef TCL_WIDE_INT_IS_LONG
case TCL_NUMBER_WIDE:
+#endif
case TCL_NUMBER_LONG:
compare = mp_cmp_d(&big1, 0);
mp_clear(&big1);
@@ -8390,7 +9445,7 @@ ValidatePcAndStackTop(
if (checkStack &&
((stackTop < 0) || (stackTop > stackUpperBound))) {
int numChars;
- const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL);
+ const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars, NULL, NULL);
fprintf(stderr, "\nBad stack top %d at pc %u in TclNRExecuteByteCode (min 0, max %i)",
stackTop, relativePc, stackUpperBound);
@@ -8440,10 +9495,12 @@ IllegalExprOperandType(
ClientData ptr;
int type;
const unsigned char opcode = *pc;
- const char *description, *operator = operatorStrings[opcode - INST_LOR];
+ const char *description, *operator = "unknown";
if (opcode == INST_EXPON) {
operator = "**";
+ } else if (opcode <= INST_STR_NEQ) {
+ operator = operatorStrings[opcode - INST_LOR];
}
if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
@@ -8466,7 +9523,7 @@ IllegalExprOperandType(
/*
*----------------------------------------------------------------------
*
- * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd --
+ * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSourceFromFrame --
*
* Given a program counter value, finds the closest command in the
* bytecode code unit's CmdLocation array and returns information about
@@ -8487,16 +9544,26 @@ IllegalExprOperandType(
*----------------------------------------------------------------------
*/
-const char *
-TclGetSrcInfoForCmd(
- Interp *iPtr,
- int *lenPtr)
+Tcl_Obj *
+TclGetSourceFromFrame(
+ CmdFrame *cfPtr,
+ int objc,
+ Tcl_Obj *const objv[])
{
- CmdFrame *cfPtr = iPtr->cmdFramePtr;
- ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
-
- return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
- codePtr, lenPtr, NULL);
+ if (cfPtr == NULL) {
+ return Tcl_NewListObj(objc, objv);
+ }
+ if (cfPtr->cmdObj == NULL) {
+ if (cfPtr->cmd == NULL) {
+ ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
+
+ cfPtr->cmd = GetSrcInfoForPc((unsigned char *)
+ cfPtr->data.tebc.pc, codePtr, &cfPtr->len, NULL, NULL);
+ }
+ cfPtr->cmdObj = Tcl_NewStringObj(cfPtr->cmd, cfPtr->len);
+ Tcl_IncrRefCount(cfPtr->cmdObj);
+ }
+ return cfPtr->cmdObj;
}
void
@@ -8505,13 +9572,16 @@ TclGetSrcInfoForPc(
{
ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
- if (cfPtr->cmd.str.cmd == NULL) {
- cfPtr->cmd.str.cmd = GetSrcInfoForPc(
+ assert(cfPtr->type == TCL_LOCATION_BC);
+
+ if (cfPtr->cmd == NULL) {
+
+ cfPtr->cmd = GetSrcInfoForPc(
(unsigned char *) cfPtr->data.tebc.pc, codePtr,
- &cfPtr->cmd.str.len, NULL);
+ &cfPtr->len, NULL, NULL);
}
- if (cfPtr->cmd.str.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.
@@ -8528,7 +9598,7 @@ TclGetSrcInfoForPc(
return;
}
- srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
+ srcOffset = cfPtr->cmd - codePtr->source;
eclPtr = Tcl_GetHashValue(hePtr);
for (i=0; i < eclPtr->nuloc; i++) {
@@ -8568,9 +9638,12 @@ GetSrcInfoForPc(
int *lengthPtr, /* If non-NULL, the location where the length
* of the command's source should be stored.
* If NULL, no length is stored. */
- const unsigned char **pcBeg)/* If non-NULL, the bytecode location
+ const unsigned char **pcBeg,/* If non-NULL, the bytecode location
* where the current instruction starts.
* If NULL; no pointer is stored. */
+ int *cmdIdxPtr) /* If non-NULL, the location where the index
+ * of the command containing the pc should
+ * be stored. */
{
register int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
@@ -8580,6 +9653,7 @@ GetSrcInfoForPc(
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
+ int bestCmdIdx = -1;
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
if (pcBeg != NULL) *pcBeg = NULL;
@@ -8647,6 +9721,7 @@ GetSrcInfoForPc(
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;
+ bestCmdIdx = i;
}
}
}
@@ -8676,6 +9751,10 @@ GetSrcInfoForPc(
*lengthPtr = bestSrcLength;
}
+ if (cmdIdxPtr != NULL) {
+ *cmdIdxPtr = bestCmdIdx;
+ }
+
return (codePtr->source + bestSrcOffset);
}