通讯编程

开发平台：

Visual C++

tclExecute.c：源码内容

/*
* tclExecute.c --
*
* This file contains procedures that execute byte-compiled Tcl
* commands.
*
*
* See the file "license.terms" for information on usage and redistribution
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
*
* RCS: @(#) $Id: tclExecute.c,v 1.94.2.22 2007/09/13 15:28:12 das Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
#ifndef TCL_NO_MATH
# include "tclMath.h"
#endif
/*
* The stuff below is a bit of a hack so that this file can be used
* in environments that include no UNIX, i.e. no errno. Just define
* errno here.
*/
#ifndef TCL_GENERIC_ONLY
# include "tclPort.h"
#else /* TCL_GENERIC_ONLY */
# ifndef NO_FLOAT_H
# include <float.h>
# else /* NO_FLOAT_H */
# ifndef NO_VALUES_H
# include <values.h>
# endif /* !NO_VALUES_H */
# endif /* !NO_FLOAT_H */
# define NO_ERRNO_H
#endif /* !TCL_GENERIC_ONLY */
#ifdef NO_ERRNO_H
int errno;
# define EDOM 33
# define ERANGE 34
#endif
/*
* Need DBL_MAX for IS_INF() macro...
*/
#ifndef DBL_MAX
# ifdef MAXDOUBLE
# define DBL_MAX MAXDOUBLE
# else /* !MAXDOUBLE */
/*
* This value is from the Solaris headers, but doubles seem to be the
* same size everywhere. Long doubles aren't, but we don't use those.
*/
# define DBL_MAX 1.79769313486231570e+308
# endif /* MAXDOUBLE */
#endif /* !DBL_MAX */
/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
* initialized.
*/
static int execInitialized = 0;
TCL_DECLARE_MUTEX(execMutex)
#ifdef TCL_COMPILE_DEBUG
/*
* Variable that controls whether execution tracing is enabled and, if so,
* what level of tracing is desired:
* 0: no execution tracing
* 1: trace invocations of Tcl procs only
* 2: trace invocations of all (not compiled away) commands
* 3: display each instruction executed
* This variable is linked to the Tcl variable "tcl_traceExec".
*/
int tclTraceExec = 0;
#endif
/*
* Mapping from expression instruction opcodes to strings; used for error
* messages. Note that these entries must match the order and number of the
* expression opcodes (e.g., INST_LOR) in tclCompile.h.
*/
static char *operatorStrings[] = {
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
"+", "-", "*", "/", "%", "+", "-", "~", "!",
"BUILTIN FUNCTION", "FUNCTION",
"", "", "", "", "", "", "", "", "eq", "ne",
};
/*
* Mapping from Tcl result codes to strings; used for error and debugging
* messages.
*/
#ifdef TCL_COMPILE_DEBUG
static char *resultStrings[] = {
"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
};
#endif
/*
* These are used by evalstats to monitor object usage in Tcl.
*/
#ifdef TCL_COMPILE_STATS
long tclObjsAlloced = 0;
long tclObjsFreed = 0;
#define TCL_MAX_SHARED_OBJ_STATS 5
long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
#endif /* TCL_COMPILE_STATS */
/*
* Macros for testing floating-point values for certain special cases. Test
* for not-a-number by comparing a value against itself; test for infinity
* by comparing against the largest floating-point value.
*/
#define IS_NAN(v) ((v) != (v))
#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
/*
* The new macro for ending an instruction; note that a
* reasonable C-optimiser will resolve all branches
* at compile time. (result) is always a constant; the macro
* NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
* resolved at runtime for variable (nCleanup).
*
* ARGUMENTS:
* pcAdjustment: how much to increment pc
* nCleanup: how many objects to remove from the stack
* result: 0 indicates no object should be pushed on the
* stack; otherwise, push objResultPtr. If (result < 0),
* objResultPtr already has the correct reference count.
*/
#define NEXT_INST_F(pcAdjustment, nCleanup, result)
if (nCleanup == 0) {
if (result != 0) {
if ((result) > 0) {
PUSH_OBJECT(objResultPtr);
} else {
stackPtr[++stackTop] = objResultPtr;
}
}
pc += (pcAdjustment);
goto cleanup0;
} else if (result != 0) {
if ((result) > 0) {
Tcl_IncrRefCount(objResultPtr);
}
pc += (pcAdjustment);
switch (nCleanup) {
case 1: goto cleanup1_pushObjResultPtr;
case 2: goto cleanup2_pushObjResultPtr;
default: panic("ERROR: bad usage of macro NEXT_INST_F");
}
} else {
pc += (pcAdjustment);
switch (nCleanup) {
case 1: goto cleanup1;
case 2: goto cleanup2;
default: panic("ERROR: bad usage of macro NEXT_INST_F");
}
}
#define NEXT_INST_V(pcAdjustment, nCleanup, result)
pc += (pcAdjustment);
cleanup = (nCleanup);
if (result) {
if ((result) > 0) {
Tcl_IncrRefCount(objResultPtr);
}
goto cleanupV_pushObjResultPtr;
} else {
goto cleanupV;
}
/*
* Macros used to cache often-referenced Tcl evaluation stack information
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
* pair must surround any call inside TclExecuteByteCode (and a few other
* procedures that use this scheme) that could result in a recursive call
* to TclExecuteByteCode.
*/
#define CACHE_STACK_INFO()
stackPtr = eePtr->stackPtr;
stackTop = eePtr->stackTop
#define DECACHE_STACK_INFO()
eePtr->stackTop = stackTop
/*
* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
* increments the object's ref count since it makes the stack have another
* reference pointing to the object. However, POP_OBJECT does not decrement
* the ref count. This is because the stack may hold the only reference to
* the object, so the object would be destroyed if its ref count were
* decremented before the caller had a chance to, e.g., store it in a
* variable. It is the caller's responsibility to decrement the ref count
* when it is finished with an object.
*
* WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
* macro. The actual parameter might be an expression with side effects,
* and this ensures that it will be executed only once.
*/
#define PUSH_OBJECT(objPtr)
Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
#define POP_OBJECT()
(stackPtr[stackTop--])
/*
* Macros used to trace instruction execution. The macros TRACE,
* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
* O2S is only used in TRACE* calls to get a string from an object.
*/
#ifdef TCL_COMPILE_DEBUG
# define TRACE(a)
if (traceInstructions) {
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop,
(unsigned int)(pc - codePtr->codeStart),
GetOpcodeName(pc));
printf a;
}
# define TRACE_APPEND(a)
if (traceInstructions) {
printf a;
}
# define TRACE_WITH_OBJ(a, objPtr)
if (traceInstructions) {
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop,
(unsigned int)(pc - codePtr->codeStart),
GetOpcodeName(pc));
printf a;
TclPrintObject(stdout, objPtr, 30);
fprintf(stdout, "n");
}
# define O2S(objPtr)
(objPtr ? TclGetString(objPtr) : "")
#else /* !TCL_COMPILE_DEBUG */
# define TRACE(a)
# define TRACE_APPEND(a)
# define TRACE_WITH_OBJ(a, objPtr)
# define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
/*
* DTrace instruction probe macros.
*/
#define TCL_DTRACE_INST_NEXT()
if (TCL_DTRACE_INST_DONE_ENABLED()) {
if (curInstName) {
TCL_DTRACE_INST_DONE(curInstName, stackTop - initStackTop,
stackPtr + stackTop);
}
curInstName = tclInstructionTable[*pc].name;
if (TCL_DTRACE_INST_START_ENABLED()) {
TCL_DTRACE_INST_START(curInstName, stackTop - initStackTop,
stackPtr + stackTop);
}
} else if (TCL_DTRACE_INST_START_ENABLED()) {
TCL_DTRACE_INST_START(tclInstructionTable[*pc].name,
stackTop - initStackTop, stackPtr + stackTop);
}
#define TCL_DTRACE_INST_LAST()
if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {
TCL_DTRACE_INST_DONE(curInstName, stackTop - initStackTop,
stackPtr + stackTop);
}
/*
* Macro to read a string containing either a wide or an int and
* decide which it is while decoding it at the same time. This
* enforces the policy that integer constants between LONG_MIN and
* LONG_MAX (inclusive) are represented by normal longs, and integer
* constants outside that range are represented by wide ints.
*
* GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
* generates an error message.
*/
#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar)
(resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar));
if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN)
&& (wideVar) <= Tcl_LongAsWide(LONG_MAX)) {
(objPtr)->typePtr = &tclIntType;
(objPtr)->internalRep.longValue = (longVar)
= Tcl_WideAsLong(wideVar);
}
#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar)
(resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr),
&(wideVar));
if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN)
&& (wideVar) <= Tcl_LongAsWide(LONG_MAX)) {
(objPtr)->typePtr = &tclIntType;
(objPtr)->internalRep.longValue = (longVar)
= Tcl_WideAsLong(wideVar);
}
/*
* Combined with REQUIRE_WIDE_OR_INT, this gets a long value from
* an obj.
*/
#define FORCE_LONG(objPtr, longVar, wideVar)
if ((objPtr)->typePtr == &tclWideIntType) {
(longVar) = Tcl_WideAsLong(wideVar);
}
#define IS_INTEGER_TYPE(typePtr)
((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
#define IS_NUMERIC_TYPE(typePtr)
(IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)
#define W0 Tcl_LongAsWide(0)
/*
* For tracing that uses wide values.
*/
#define LLD "%" TCL_LL_MODIFIER "d"
#ifndef TCL_WIDE_INT_IS_LONG
/*
* Extract a double value from a general numeric object.
*/
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr)
if ((typePtr) == &tclIntType) {
(doubleVar) = (double) (objPtr)->internalRep.longValue;
} else if ((typePtr) == &tclWideIntType) {
(doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);
} else {
(doubleVar) = (objPtr)->internalRep.doubleValue;
}
#else /* TCL_WIDE_INT_IS_LONG */
#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr)
if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) {
(doubleVar) = (double) (objPtr)->internalRep.longValue;
} else {
(doubleVar) = (objPtr)->internalRep.doubleValue;
}
#endif /* TCL_WIDE_INT_IS_LONG */
/*
* Declarations for local procedures to this file:
*/
static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
ByteCode *codePtr));
static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, int objc, Tcl_Obj **objv));
static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
ExecEnv *eePtr, ClientData clientData));
#ifdef TCL_COMPILE_STATS
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int objc,
Tcl_Obj *CONST objv[]));
#endif /* TCL_COMPILE_STATS */
#ifdef TCL_COMPILE_DEBUG
static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
#endif /* TCL_COMPILE_DEBUG */
static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
int catchOnly, ByteCode* codePtr));
static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
ByteCode* codePtr, int *lengthPtr));
static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
static void IllegalExprOperandType _ANSI_ARGS_((
Tcl_Interp *interp, unsigned char *pc,
Tcl_Obj *opndPtr));
static void InitByteCodeExecution _ANSI_ARGS_((
Tcl_Interp *interp));
#ifdef TCL_COMPILE_DEBUG
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
static char * StringForResultCode _ANSI_ARGS_((int result));
static void ValidatePcAndStackTop _ANSI_ARGS_((
ByteCode *codePtr, unsigned char *pc,
int stackTop, int stackLowerBound));
#endif /* TCL_COMPILE_DEBUG */
static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
/*
* Table describing the built-in math functions. Entries in this table are
* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
* operand byte.
*/
BuiltinFunc tclBuiltinFuncTable[] = {
#ifndef TCL_NO_MATH
{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
{"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
{"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
{"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
{"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
{"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
{"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
{"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
{"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
{"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
{"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
{"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
{"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
{"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
{"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
{"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
{"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
{"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
#endif
{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
{"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
{"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
{"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
{0},
};
/*
*----------------------------------------------------------------------
*
* InitByteCodeExecution --
*
* This procedure is called once to initialize the Tcl bytecode
* interpreter.
*
* Results:
* None.
*
* Side effects:
* This procedure initializes the array of instruction names. If
* compiling with the TCL_COMPILE_STATS flag, it initializes the
* array that counts the executions of each instruction and it
* creates the "evalstats" command. It also establishes the link
* between the Tcl "tcl_traceExec" and C "tclTraceExec" variables.
*
*----------------------------------------------------------------------
*/
static void
InitByteCodeExecution(interp)
Tcl_Interp *interp; /* Interpreter for which the Tcl variable
* "tcl_traceExec" is linked to control
* instruction tracing. */
{
#ifdef TCL_COMPILE_DEBUG
if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
#endif
#ifdef TCL_COMPILE_STATS
Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd,
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
#endif /* TCL_COMPILE_STATS */
}
/*
*----------------------------------------------------------------------
*
* TclCreateExecEnv --
*
* This procedure creates a new execution environment for Tcl bytecode
* execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
* is typically created once for each Tcl interpreter (Interp
* structure) and recursively passed to TclExecuteByteCode to execute
* ByteCode sequences for nested commands.
*
* Results:
* A newly allocated ExecEnv is returned. This points to an empty
* evaluation stack of the standard initial size.
*
* Side effects:
* The bytecode interpreter is also initialized here, as this
* procedure will be called before any call to TclExecuteByteCode.
*
*----------------------------------------------------------------------
*/
#define TCL_STACK_INITIAL_SIZE 2000
ExecEnv *
TclCreateExecEnv(interp)
Tcl_Interp *interp; /* Interpreter for which the execution
* environment is being created. */
{
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
Tcl_Obj **stackPtr;
stackPtr = (Tcl_Obj **)
ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
/*
* Use the bottom pointer to keep a reference count; the
* execution environment holds a reference.
*/
stackPtr++;
eePtr->stackPtr = stackPtr;
stackPtr[-1] = (Tcl_Obj *) ((char *) 1);
eePtr->stackTop = -1;
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2);
eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
Tcl_IncrRefCount(eePtr->errorInfo);
eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
Tcl_IncrRefCount(eePtr->errorCode);
Tcl_MutexLock(&execMutex);
if (!execInitialized) {
TclInitAuxDataTypeTable();
InitByteCodeExecution(interp);
execInitialized = 1;
}
Tcl_MutexUnlock(&execMutex);
return eePtr;
}
#undef TCL_STACK_INITIAL_SIZE
/*
*----------------------------------------------------------------------
*
* TclDeleteExecEnv --
*
* Frees the storage for an ExecEnv.
*
* Results:
* None.
*
* Side effects:
* Storage for an ExecEnv and its contained storage (e.g. the
* evaluation stack) is freed.
*
*----------------------------------------------------------------------
*/
void
TclDeleteExecEnv(eePtr)
ExecEnv *eePtr; /* Execution environment to free. */
{
if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
ckfree((char *) (eePtr->stackPtr-1));
} else {
panic("ERROR: freeing an execEnv whose stack is still in use.n");
}
TclDecrRefCount(eePtr->errorInfo);
TclDecrRefCount(eePtr->errorCode);
ckfree((char *) eePtr);
}
/*
*----------------------------------------------------------------------
*
* TclFinalizeExecution --
*
* Finalizes the execution environment setup so that it can be
* later reinitialized.
*
* Results:
* None.
*
* Side effects:
* After this call, the next time TclCreateExecEnv will be called
* it will call InitByteCodeExecution.
*
*----------------------------------------------------------------------
*/
void
TclFinalizeExecution()
{
Tcl_MutexLock(&execMutex);
execInitialized = 0;
Tcl_MutexUnlock(&execMutex);
TclFinalizeAuxDataTypeTable();
}
/*
*----------------------------------------------------------------------
*
* GrowEvaluationStack --
*
* This procedure grows a Tcl evaluation stack stored in an ExecEnv.
*
* Results:
* None.
*
* Side effects:
* The size of the evaluation stack is doubled.
*
*----------------------------------------------------------------------
*/
static void
GrowEvaluationStack(eePtr)
register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
* stack to enlarge. */
{
/*
* The current Tcl stack elements are stored from eePtr->stackPtr[0]
* to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
*/
int currElems = (eePtr->stackEnd + 1);
int newElems = 2*currElems;
int currBytes = currElems * sizeof(Tcl_Obj *);
int newBytes = 2*currBytes;
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
Tcl_Obj **oldStackPtr = eePtr->stackPtr;
/*
* We keep the stack reference count as a (char *), as that
* works nicely as a portable pointer-sized counter.
*/
char *refCount = (char *) oldStackPtr[-1];
/*
* Copy the existing stack items to the new stack space, free the old
* storage if appropriate, and record the refCount of the new stack
* held by the environment.
*/
newStackPtr++;
memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
(size_t) currBytes);
if (refCount == (char *) 1) {
ckfree((VOID *) (oldStackPtr-1));
} else {
/*
* Remove the reference corresponding to the
* environment pointer.
*/
oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
}
eePtr->stackPtr = newStackPtr;
eePtr->stackEnd = (newElems - 2); /* index of last usable item */
newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);
}
/*
*--------------------------------------------------------------
*
* Tcl_ExprObj --
*
* Evaluate an expression in a Tcl_Obj.
*
* Results:
* A standard Tcl object result. If the result is other than TCL_OK,
* then the interpreter's result contains an error message. If the
* result is TCL_OK, then a pointer to the expression's result value
* object is stored in resultPtrPtr. In that case, the object's ref
* count is incremented to reflect the reference returned to the
* caller; the caller is then responsible for the resulting object
* and must, for example, decrement the ref count when it is finished
* with the object.
*
* Side effects:
* Any side effects caused by subcommands in the expression, if any.
* The interpreter result is not modified unless there is an error.
*
*--------------------------------------------------------------
*/
int
Tcl_ExprObj(interp, objPtr, resultPtrPtr)
Tcl_Interp *interp; /* Context in which to evaluate the
* expression. */
register Tcl_Obj *objPtr; /* Points to Tcl object containing
* expression to evaluate. */
Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
* result is stored if no errors occur. */
{
Interp *iPtr = (Interp *) interp;
CompileEnv compEnv; /* Compilation environment structure
* allocated in frame. */
LiteralTable *localTablePtr = &(compEnv.localLitTable);
register ByteCode *codePtr = NULL;
/* Tcl Internal type of bytecode.
* Initialized to avoid compiler warning. */
AuxData *auxDataPtr;
LiteralEntry *entryPtr;
Tcl_Obj *saveObjPtr;
char *string;
int length, i, result;
/*
* First handle some common expressions specially.
*/
string = Tcl_GetStringFromObj(objPtr, &length);
if (length == 1) {
if (*string == '0') {
*resultPtrPtr = Tcl_NewLongObj(0);
Tcl_IncrRefCount(*resultPtrPtr);
return TCL_OK;
} else if (*string == '1') {
*resultPtrPtr = Tcl_NewLongObj(1);
Tcl_IncrRefCount(*resultPtrPtr);
return TCL_OK;
}
} else if ((length == 2) && (*string == '!')) {
if (*(string+1) == '0') {
*resultPtrPtr = Tcl_NewLongObj(1);
Tcl_IncrRefCount(*resultPtrPtr);
return TCL_OK;
} else if (*(string+1) == '1') {
*resultPtrPtr = Tcl_NewLongObj(0);
Tcl_IncrRefCount(*resultPtrPtr);
return TCL_OK;
}
}
/*
* Get the ByteCode from the object. If it exists, make sure it hasn't
* been invalidated by, e.g., someone redefining a command with a
* compile procedure (this might make the compiled code wrong). If
* necessary, convert the object to be a ByteCode object and compile it.
* Also, if the code was compiled in/for a different interpreter, we
* recompile it.
*
* Precompiled expressions, however, are immutable and therefore
* they are not recompiled, even if the epoch has changed.
*
*/
if (objPtr->typePtr == &tclByteCodeType) {
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)) {
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
panic("Tcl_ExprObj: compiled expression jumped interps");
}
codePtr->compileEpoch = iPtr->compileEpoch;
} else {
(*tclByteCodeType.freeIntRepProc)(objPtr);
objPtr->typePtr = (Tcl_ObjType *) NULL;
}
}
}
if (objPtr->typePtr != &tclByteCodeType) {
#ifndef TCL_TIP280
TclInitCompileEnv(interp, &compEnv, string, length);
#else
/* TIP #280 : No invoker (yet) - Expression compilation */
TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
#endif
result = TclCompileExpr(interp, string, length, &compEnv);
/*
* Free the compilation environment's literal table bucket array if
* it was dynamically allocated.
*/
if (localTablePtr->buckets != localTablePtr->staticBuckets) {
ckfree((char *) localTablePtr->buckets);
}
if (result != TCL_OK) {
/*
* Compilation errors. Free storage allocated for compilation.
*/
#ifdef TCL_COMPILE_DEBUG
TclVerifyLocalLiteralTable(&compEnv);
#endif /*TCL_COMPILE_DEBUG*/
entryPtr = compEnv.literalArrayPtr;
for (i = 0; i < compEnv.literalArrayNext; i++) {
TclReleaseLiteral(interp, entryPtr->objPtr);
entryPtr++;
}
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable(iPtr);
#endif /*TCL_COMPILE_DEBUG*/
auxDataPtr = compEnv.auxDataArrayPtr;
for (i = 0; i < compEnv.auxDataArrayNext; i++) {
if (auxDataPtr->type->freeProc != NULL) {
auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
auxDataPtr++;
}
TclFreeCompileEnv(&compEnv);
return result;
}
/*
* Successful compilation. If the expression yielded no
* instructions, push an zero object as the expression's result.
*/
if (compEnv.codeNext == compEnv.codeStart) {
TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
&compEnv);
}
/*
* Add a "done" instruction as the last instruction and change the
* object into a ByteCode object. Ownership of the literal objects
* and aux data items is given to the ByteCode object.
*/
compEnv.numSrcBytes = iPtr->termOffset;
TclEmitOpcode(INST_DONE, &compEnv);
TclInitByteCodeObj(objPtr, &compEnv);
TclFreeCompileEnv(&compEnv);
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile == 2) {
TclPrintByteCodeObj(interp, objPtr);
}
#endif /* TCL_COMPILE_DEBUG */
}
/*
* Execute the expression after first saving the interpreter's result.
*/
saveObjPtr = Tcl_GetObjResult(interp);
Tcl_IncrRefCount(saveObjPtr);
Tcl_ResetResult(interp);
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
codePtr->refCount++;
result = TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
objPtr->typePtr = NULL;
objPtr->internalRep.otherValuePtr = NULL;
}
/*
* If the expression evaluated successfully, store a pointer to its
* value object in resultPtrPtr then restore the old interpreter result.
* We increment the object's ref count to reflect the reference that we
* are returning to the caller. We also decrement the ref count of the
* interpreter's result object after calling Tcl_SetResult since we
* next store into that field directly.
*/
if (result == TCL_OK) {
*resultPtrPtr = iPtr->objResultPtr;
Tcl_IncrRefCount(iPtr->objResultPtr);
Tcl_SetObjResult(interp, saveObjPtr);
}
TclDecrRefCount(saveObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* TclCompEvalObj --
*
* This procedure evaluates the script contained in a Tcl_Obj by
* first compiling it and then passing it to TclExecuteByteCode.
*
* Results:
* The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
* that either contains the result of executing the code or an
* error message.
*
* Side effects:
* Almost certainly, depending on the ByteCode's instructions.
*
*----------------------------------------------------------------------
*/
int
#ifndef TCL_TIP280
TclCompEvalObj(interp, objPtr)
#else
TclCompEvalObj(interp, objPtr, invoker, word)
#endif
Tcl_Interp *interp;
Tcl_Obj *objPtr;
#ifdef TCL_TIP280
CONST CmdFrame* invoker; /* Frame of the command doing the eval */
int word; /* Index of the word which is in objPtr */
#endif
{
register Interp *iPtr = (Interp *) interp;
register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
* at all were executed. */
char *script;
int numSrcBytes;
int result;
Namespace *namespacePtr;
/*
* Check that the interpreter is ready to execute scripts
*/
iPtr->numLevels++;
if (TclInterpReady(interp) == TCL_ERROR) {
iPtr->numLevels--;
return TCL_ERROR;
}
if (iPtr->varFramePtr != NULL) {
namespacePtr = iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = iPtr->globalNsPtr;
}
/*
* If the object is not already of tclByteCodeType, compile it (and
* reset the compilation flags in the interpreter; this should be
* done after any compilation).
* Otherwise, check that it is "fresh" enough.
*/
if (objPtr->typePtr != &tclByteCodeType) {
recompileObj:
iPtr->errorLine = 1;
#ifdef TCL_TIP280
/* TIP #280. Remember the invoker for a moment in the interpreter
* structures so that the byte code compiler can pick it up when
* initializing the compilation environment, i.e. the extended
* location information.
*/
iPtr->invokeCmdFramePtr = invoker;
iPtr->invokeWord = word;
#endif
result = tclByteCodeType.setFromAnyProc(interp, objPtr);
#ifdef TCL_TIP280
iPtr->invokeCmdFramePtr = NULL;
#endif
if (result != TCL_OK) {
iPtr->numLevels--;
return result;
}
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
} else {
/*
* Make sure the Bytecode hasn't been invalidated by, e.g., someone
* redefining a command with a compile procedure (this might make the
* compiled code wrong).
* The object needs to be recompiled if it was compiled in/for a
* different interpreter, or for a different namespace, or for the
* same namespace but with different name resolution rules.
* Precompiled objects, however, are immutable and therefore
* they are not recompiled, even if the epoch has changed.
*
* To be pedantically correct, we should also check that the
* originating procPtr is the same as the current context procPtr
* (assuming one exists at all - none for global level). This
* code is #def'ed out because [info body] was changed to never
* return a bytecode type object, which should obviate us from
* the extra checks here.
*/
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)
#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
|| (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
iPtr->varFramePtr->procPtr == codePtr->procPtr))
#endif
|| (codePtr->nsPtr != namespacePtr)
|| (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
if ((Interp *) *codePtr->interpHandle != iPtr) {
panic("Tcl_EvalObj: compiled script jumped interps");
}
codePtr->compileEpoch = iPtr->compileEpoch;
} else {
/*
* This byteCode is invalid: free it and recompile
*/
tclByteCodeType.freeIntRepProc(objPtr);
goto recompileObj;
}
}
}
/*
* Execute the commands. If the code was compiled from an empty string,
* don't bother executing the code.
*/
numSrcBytes = codePtr->numSrcBytes;
if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
/*
* Increment the code's ref count while it is being executed. If
* afterwards no references to it remain, free the code.
*/
codePtr->refCount++;
result = TclExecuteByteCode(interp, codePtr);
codePtr->refCount--;
if (codePtr->refCount <= 0) {
TclCleanupByteCode(codePtr);
}
} else {
result = TCL_OK;
}
iPtr->numLevels--;
/*
* If no commands at all were executed, check for asynchronous
* handlers so that they at least get one change to execute.
* This is needed to handle event loops written in Tcl with
* empty bodies.
*/
if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
result = Tcl_AsyncInvoke(interp, result);
/*
* If an error occurred, record information about what was being
* executed when the error occurred.
*/
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
}
}
/*
* Set the interpreter's termOffset member to the offset of the
* character just after the last one executed. We approximate the offset
* of the last character executed by using the number of characters
* compiled.
*/
iPtr->termOffset = numSrcBytes;
iPtr->flags &= ~ERR_ALREADY_LOGGED;
return result;
}
/*
*----------------------------------------------------------------------
*
* TclExecuteByteCode --
*
* This procedure executes the instructions of a ByteCode structure.
* It returns when a "done" instruction is executed or an error occurs.
*
* Results:
* The return value is one of the return codes defined in tcl.h
* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
* that either contains the result of executing the code or an
* error message.
*
* Side effects:
* Almost certainly, depending on the ByteCode's instructions.
*
*----------------------------------------------------------------------
*/
static int
TclExecuteByteCode(interp, codePtr)
Tcl_Interp *interp; /* Token for command interpreter. */
ByteCode *codePtr; /* The bytecode sequence to interpret. */
{
Interp *iPtr = (Interp *) interp;
ExecEnv *eePtr = iPtr->execEnvPtr;
/* Points to the execution environment. */
register Tcl_Obj **stackPtr = eePtr->stackPtr;
/* Cached evaluation stack base pointer. */
register int stackTop = eePtr->stackTop;
/* Cached top index of evaluation stack. */
register unsigned char *pc = codePtr->codeStart;
/* The current program counter. */
int opnd; /* Current instruction's operand byte(s). */
int pcAdjustment; /* Hold pc adjustment after instruction. */
int initStackTop = stackTop;/* Stack top at start of execution. */
ExceptionRange *rangePtr; /* Points to closest loop or catch exception
* range enclosing the pc. Used by various
* instructions and processCatch to
* process break, continue, and errors. */
int result = TCL_OK; /* Return code returned after execution. */
int storeFlags;
Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
char *bytes;
int length;
long i = 0; /* Init. avoids compiler warning. */
Tcl_WideInt w;
register int cleanup;
Tcl_Obj *objResultPtr;
char *part1, *part2;
Var *varPtr, *arrayPtr;
CallFrame *varFramePtr = iPtr->varFramePtr;
#ifdef TCL_TIP280
/* TIP #280 : Structures for tracking lines */
CmdFrame bcFrame;
#endif
#ifdef TCL_COMPILE_DEBUG
int traceInstructions = (tclTraceExec == 3);
char cmdNameBuf[21];
#endif
char *curInstName = NULL;
/*
* This procedure uses a stack to hold information about catch commands.
* This information is the current operand stack top when starting to
* execute the code for each catch command. It starts out with stack-
* allocated space but uses dynamically-allocated storage if needed.
*/
#define STATIC_CATCH_STACK_SIZE 4
int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
int *catchStackPtr = catchStackStorage;
int catchTop = -1;
#ifdef TCL_TIP280
/* TIP #280 : Initialize the frame. Do not push it yet. */
bcFrame.type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
? TCL_LOCATION_PREBC
: TCL_LOCATION_BC);
bcFrame.level = (iPtr->cmdFramePtr == NULL ?
1 :
iPtr->cmdFramePtr->level + 1);
bcFrame.framePtr = iPtr->framePtr;
bcFrame.nextPtr = iPtr->cmdFramePtr;
bcFrame.nline = 0;
bcFrame.line = NULL;
bcFrame.data.tebc.codePtr = codePtr;
bcFrame.data.tebc.pc = NULL;
bcFrame.cmd.str.cmd = NULL;
bcFrame.cmd.str.len = 0;
#endif
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%dn", eePtr->stackTop);
fflush(stdout);
}
opnd = 0; /* Init. avoids compiler warning. */
#endif
#ifdef TCL_COMPILE_STATS
iPtr->stats.numExecutions++;
#endif
/*
* Make sure the catch stack is large enough to hold the maximum number
* of catch commands that could ever be executing at the same time. This
* will be no more than the exception range array's depth.
*/
if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
catchStackPtr = (int *)
ckalloc(codePtr->maxExceptDepth * sizeof(int));
}
/*
* Make sure the stack has enough room to execute this ByteCode.
*/
while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
GrowEvaluationStack(eePtr);
stackPtr = eePtr->stackPtr;
}
/*
* Loop executing instructions until a "done" instruction, a
* TCL_RETURN, or some error.
*/
goto cleanup0;
/*
* Targets for standard instruction endings; unrolled
* for speed in the most frequent cases (instructions that
* consume up to two stack elements).
*
* This used to be a "for(;;)" loop, with each instruction doing
* its own cleanup.
*/
cleanupV_pushObjResultPtr:
switch (cleanup) {
case 0:
stackPtr[++stackTop] = (objResultPtr);
goto cleanup0;
default:
cleanup -= 2;
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
case 2:
cleanup2_pushObjResultPtr:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 1:
cleanup1_pushObjResultPtr:
valuePtr = stackPtr[stackTop];
TclDecrRefCount(valuePtr);
}
stackPtr[stackTop] = objResultPtr;
goto cleanup0;
cleanupV:
switch (cleanup) {
default:
cleanup -= 2;
while (cleanup--) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
case 2:
cleanup2:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 1:
cleanup1:
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
case 0:
/*
* We really want to do nothing now, but this is needed
* for some compilers (SunPro CC)
*/
break;
}
cleanup0:
#ifdef TCL_COMPILE_DEBUG
ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
if (traceInstructions) {
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
TclPrintInstruction(codePtr, pc);
fflush(stdout);
}
#endif /* TCL_COMPILE_DEBUG */
#ifdef TCL_COMPILE_STATS
iPtr->stats.instructionCount[*pc]++;
#endif
TCL_DTRACE_INST_NEXT();
switch (*pc) {
case INST_DONE:
if (stackTop <= initStackTop) {
stackTop--;
goto abnormalReturn;
}
/*
* Set the interpreter's object result to point to the
* topmost object from the stack, and check for a possible
* [catch]. The stackTop's level and refCount will be handled
* by "processCatch" or "abnormalReturn".
*/
valuePtr = stackPtr[stackTop];
Tcl_SetObjResult(interp, valuePtr);
#ifdef TCL_COMPILE_DEBUG
TRACE_WITH_OBJ(("=> return code=%d, result=", result),
iPtr->objResultPtr);
if (traceInstructions) {
fprintf(stdout, "n");
}
#endif
goto checkForCatch;
case INST_PUSH1:
objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(2, 0, 1);
case INST_PUSH4:
objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_POP:
TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
NEXT_INST_F(1, 0, 0);
case INST_DUP:
objResultPtr = stackPtr[stackTop];
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(1, 0, 1);
case INST_OVER:
opnd = TclGetUInt4AtPtr( pc+1 );
objResultPtr = stackPtr[ stackTop - opnd ];
TRACE_WITH_OBJ(("=> "), objResultPtr);
NEXT_INST_F(5, 0, 1);
case INST_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
{
int totalLen = 0;
/*
* Peephole optimisation for appending an empty string.
* This enables replacing 'K $x [set x{}]' by '$x[set x{}]'
* for fastest execution. Avoid doing the optimisation for wide
* ints - a case where equal strings may refer to different values
* (see [Bug 1251791]).
*/
if ((opnd == 2) && (stackPtr[stackTop-1]->typePtr != &tclWideIntType)) {
Tcl_GetStringFromObj(stackPtr[stackTop], &length);
if (length == 0) {
/* Just drop the top item from the stack */
NEXT_INST_F(2, 1, 0);
}
}
/*
* Concatenate strings (with no separators) from the top
* opnd items on the stack starting with the deepest item.
* First, determine how many characters are needed.
*/
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
if (bytes != NULL) {
totalLen += length;
}
}
/*
* Initialize the new append string object by appending the
* strings of the opnd stack objects. Also pop the objects.
*/
TclNewObj(objResultPtr);
if (totalLen > 0) {
char *p = (char *) ckalloc((unsigned) (totalLen + 1));
objResultPtr->bytes = p;
objResultPtr->length = totalLen;
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
valuePtr = stackPtr[i];
bytes = Tcl_GetStringFromObj(valuePtr, &length);
if (bytes != NULL) {
memcpy((VOID *) p, (VOID *) bytes,
(size_t) length);
p += length;
}
}
*p = '';
}
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(2, opnd, 1);
}
case INST_INVOKE_STK4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doInvocation;
case INST_INVOKE_STK1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doInvocation:
{
int objc = opnd; /* The number of arguments. */
Tcl_Obj **objv; /* The array of argument objects. */
/*
* We keep the stack reference count as a (char *), as that
* works nicely as a portable pointer-sized counter.
*/
char **preservedStackRefCountPtr;
/*
* Reference to memory block containing
* objv array (must be kept live throughout
* trace and command invokations.)
*/
objv = &(stackPtr[stackTop - (objc-1)]);
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
if (traceInstructions) {
strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
TRACE(("%u => call ", objc));
} else {
fprintf(stdout, "%d: (%u) invoking ",
iPtr->numLevels,
(unsigned int)(pc - codePtr->codeStart));
}
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "n");
fflush(stdout);
}
#endif /*TCL_COMPILE_DEBUG*/
/*
* If trace procedures will be called, we need a
* command string to pass to TclEvalObjvInternal; note
* that a copy of the string will be made there to
* include the ending .
*/
bytes = NULL;
length = 0;
if (iPtr->tracePtr != NULL) {
Trace *tracePtr, *nextTracePtr;
for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
tracePtr = nextTracePtr) {
nextTracePtr = tracePtr->nextPtr;
if (tracePtr->level == 0 ||
iPtr->numLevels <= tracePtr->level) {
/*
* Traces will be called: get command string
*/
bytes = GetSrcInfoForPc(pc, codePtr, &length);
break;
}
}
} else {
Command *cmdPtr;
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
}
}
/*
* A reference to part of the stack vector itself
* escapes our control: increase its refCount
* to stop it from being deallocated by a recursive
* call to ourselves. The extra variable is needed
* because all others are liable to change due to the
* trace procedures.
*/
preservedStackRefCountPtr = (char **) (stackPtr-1);
++*preservedStackRefCountPtr;
/*
* Finally, let TclEvalObjvInternal handle the command.
*
* TIP #280 : Record the last piece of info needed by
* 'TclGetSrcInfoForPc', and push the frame.
*/
#ifdef TCL_TIP280
bcFrame.data.tebc.pc = pc;
iPtr->cmdFramePtr = &bcFrame;
#endif
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
CACHE_STACK_INFO();
#ifdef TCL_TIP280
iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
#endif
/*
* If the old stack is going to be released, it is
* safe to do so now, since no references to objv are
* going to be used from now on.
*/
--*preservedStackRefCountPtr;
if (*preservedStackRefCountPtr == (char *) 0) {
ckfree((VOID *) preservedStackRefCountPtr);
}
if (result == TCL_OK) {
/*
* 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.
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_V(pcAdjustment, opnd, -1);
} else {
cleanup = opnd;
goto processExceptionReturn;
}
}
case INST_EVAL_STK:
/*
* Note to maintainers: it is important that INST_EVAL_STK
* pop its argument from the stack before jumping to
* checkForCatch! DO NOT OPTIMISE!
*/
objPtr = stackPtr[stackTop];
DECACHE_STACK_INFO();
#ifndef TCL_TIP280
result = TclCompEvalObj(interp, objPtr);
#else
/* TIP #280: The invoking context is left NULL for a dynamically
* constructed command. We cannot match its lines to the outer
* context.
*/
result = TclCompEvalObj(interp, objPtr, NULL,0);
#endif
CACHE_STACK_INFO();
if (result == TCL_OK) {
/*
* Normal return; push the eval's object result.
*/
objResultPtr = Tcl_GetObjResult(interp);
TRACE_WITH_OBJ((""%.30s" => ", O2S(objPtr)),
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.
*/
{
Tcl_Obj *newObjResultPtr;
TclNewObj(newObjResultPtr);
Tcl_IncrRefCount(newObjResultPtr);
iPtr->objResultPtr = newObjResultPtr;
}
NEXT_INST_F(1, 1, -1);
} else {
cleanup = 1;
goto processExceptionReturn;
}
case INST_EXPR_STK:
objPtr = stackPtr[stackTop];
DECACHE_STACK_INFO();
Tcl_ResetResult(interp);
result = Tcl_ExprObj(interp, objPtr, &valuePtr);
CACHE_STACK_INFO();
if (result != TCL_OK) {
TRACE_WITH_OBJ((""%.30s" => ERROR: ",
O2S(objPtr)), Tcl_GetObjResult(interp));
goto checkForCatch;
}
objResultPtr = valuePtr;
TRACE_WITH_OBJ((""%.30s" => ", O2S(objPtr)), valuePtr);
NEXT_INST_F(1, 1, -1); /* already has right refct */
/*
* ---------------------------------------------------------
* Start of INST_LOAD instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_LOAD_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
NEXT_INST_F(2, 0, 1);
}
pcAdjustment = 2;
cleanup = 0;
arrayPtr = NULL;
part2 = NULL;
goto doCallPtrGetVar;
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
TRACE(("%u => ", opnd));
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
NEXT_INST_F(5, 0, 1);
}
pcAdjustment = 5;
cleanup = 0;
arrayPtr = NULL;
part2 = NULL;
goto doCallPtrGetVar;
case INST_LOAD_ARRAY_STK:
cleanup = 2;
part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */
objPtr = stackPtr[stackTop-1]; /* array name */
TRACE((""%.30s(%.30s)" => ", O2S(objPtr), part2));
goto doLoadStk;
case INST_LOAD_STK:
case INST_LOAD_SCALAR_STK:
cleanup = 1;
part2 = NULL;
objPtr = stackPtr[stackTop]; /* variable name */
TRACE((""%.30s" => ", O2S(objPtr)));
doLoadStk:
part1 = TclGetString(objPtr);
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "read",
/*createPart1*/ 0,
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
NEXT_INST_V(1, cleanup, 1);
}
pcAdjustment = 1;
goto doCallPtrGetVar;
case INST_LOAD_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doLoadArray;
case INST_LOAD_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadArray:
part2 = TclGetString(stackPtr[stackTop]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u "%.30s" => ", opnd, part2));
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No errors, no traces: just get the value.
*/
objResultPtr = varPtr->value.objPtr;
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
NEXT_INST_F(pcAdjustment, 1, 1);
}
cleanup = 1;
goto doCallPtrGetVar;
doCallPtrGetVar:
/*
* There are either errors or the variable is traced:
* call TclPtrGetVar to process fully.
*/
DECACHE_STACK_INFO();
objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1,
part2, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_LOAD instructions.
* ---------------------------------------------------------
*/
/*
* ---------------------------------------------------------
* Start of INST_STORE and related instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_LAPPEND_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreStk;
case INST_LAPPEND_ARRAY_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreStk;
case INST_APPEND_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = NULL;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreStk;
case INST_APPEND_ARRAY_STK:
valuePtr = stackPtr[stackTop]; /* value to append */
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreStk;
case INST_STORE_ARRAY_STK:
valuePtr = stackPtr[stackTop];
part2 = TclGetString(stackPtr[stackTop - 1]);
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreStk;
case INST_STORE_STK:
case INST_STORE_SCALAR_STK:
valuePtr = stackPtr[stackTop];
part2 = NULL;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreStk:
objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */
part1 = TclGetString(objPtr);
#ifdef TCL_COMPILE_DEBUG
if (part2 == NULL) {
TRACE((""%.30s" <- "%.30s" =>",
part1, O2S(valuePtr)));
} else {
TRACE((""%.30s(%.30s)" <- "%.30s" => ",
part1, part2, O2S(valuePtr)));
}
#endif
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "set",
/*createPart1*/ 1,
/*createPart2*/ 1, &arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = ((part2 == NULL)? 2 : 3);
pcAdjustment = 1;
goto doCallPtrSetVar;
case INST_LAPPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreArray;
case INST_LAPPEND_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreArray;
case INST_APPEND_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
case INST_APPEND_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreArray;
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreArray;
case INST_STORE_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreArray:
valuePtr = stackPtr[stackTop];
part2 = TclGetString(stackPtr[stackTop - 1]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
TRACE(("%u "%.30s" <- "%.30s" => ",
opnd, part2, O2S(valuePtr)));
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = 2;
goto doCallPtrSetVar;
case INST_LAPPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreScalar;
case INST_LAPPEND_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
| TCL_LIST_ELEMENT | TCL_TRACE_READS);
goto doStoreScalar;
case INST_APPEND_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
case INST_APPEND_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
goto doStoreScalar;
case INST_STORE_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
storeFlags = TCL_LEAVE_ERR_MSG;
goto doStoreScalar;
case INST_STORE_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
storeFlags = TCL_LEAVE_ERR_MSG;
doStoreScalar:
valuePtr = stackPtr[stackTop];
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
TRACE(("%u <- "%.30s" => ", opnd, O2S(valuePtr)));
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
cleanup = 1;
arrayPtr = NULL;
part2 = NULL;
doCallPtrSetVar:
if ((storeFlags == TCL_LEAVE_ERR_MSG)
&& !((varPtr->flags & VAR_IN_HASHTABLE)
&& (varPtr->hPtr == NULL))
&& (varPtr->tracePtr == NULL)
&& (TclIsVarScalar(varPtr)
|| TclIsVarUndefined(varPtr))
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))) {
/*
* No traces, no errors, plain 'set': we can safely inline.
* The value *will* be set to what's requested, so that
* the stack top remains pointing to the same Tcl_Obj.
*/
valuePtr = varPtr->value.objPtr;
objResultPtr = stackPtr[stackTop];
if (valuePtr != objResultPtr) {
if (valuePtr != NULL) {
TclDecrRefCount(valuePtr);
} else {
TclSetVarScalar(varPtr);
TclClearVarUndefined(varPtr);
}
varPtr->value.objPtr = objResultPtr;
Tcl_IncrRefCount(objResultPtr);
}
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#else
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
#endif
NEXT_INST_V(pcAdjustment, cleanup, 1);
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
part1, part2, valuePtr, storeFlags);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
}
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_STORE and related instructions.
* ---------------------------------------------------------
*/
/*
* ---------------------------------------------------------
* Start of INST_INCR instructions.
*
* WARNING: more 'goto' here than your doctor recommended!
* The different instructions set the value of some variables
* and then jump to somme common execution code.
*/
case INST_INCR_SCALAR1:
case INST_INCR_ARRAY1:
case INST_INCR_ARRAY_STK:
case INST_INCR_SCALAR_STK:
case INST_INCR_STK:
opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetLongFromWide(i,valuePtr);
} else {
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
DECACHE_STACK_INFO();
Tcl_AddErrorInfo(interp, "n (reading increment)");
CACHE_STACK_INFO();
goto checkForCatch;
}
FORCE_LONG(valuePtr, i, w);
}
stackTop--;
TclDecrRefCount(valuePtr);
switch (*pc) {
case INST_INCR_SCALAR1:
pcAdjustment = 2;
goto doIncrScalar;
case INST_INCR_ARRAY1:
pcAdjustment = 2;
goto doIncrArray;
default:
pcAdjustment = 1;
goto doIncrStk;
}
case INST_INCR_ARRAY_STK_IMM:
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
i = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doIncrStk:
if ((*pc == INST_INCR_ARRAY_STK_IMM)
|| (*pc == INST_INCR_ARRAY_STK)) {
part2 = TclGetString(stackPtr[stackTop]);
objPtr = stackPtr[stackTop - 1];
TRACE((""%.30s(%.30s)" (by %ld) => ",
O2S(objPtr), part2, i));
} else {
part2 = NULL;
objPtr = stackPtr[stackTop];
TRACE((""%.30s" (by %ld) => ", O2S(objPtr), i));
}
part1 = TclGetString(objPtr);
varPtr = TclObjLookupVar(interp, objPtr, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
if (varPtr == NULL) {
DECACHE_STACK_INFO();
Tcl_AddObjErrorInfo(interp,
"n (reading value of variable to increment)", -1);
CACHE_STACK_INFO();
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = ((part2 == NULL)? 1 : 2);
goto doIncrVar;
case INST_INCR_ARRAY1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
pcAdjustment = 3;
doIncrArray:
part2 = TclGetString(stackPtr[stackTop]);
arrayPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = arrayPtr->name;
while (TclIsVarLink(arrayPtr)) {
arrayPtr = arrayPtr->value.linkPtr;
}
TRACE(("%u "%.30s" (by %ld) => ",
opnd, part2, i));
varPtr = TclLookupArrayElement(interp, part1, part2,
TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
if (varPtr == NULL) {
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
cleanup = 1;
goto doIncrVar;
case INST_INCR_SCALAR1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
pcAdjustment = 3;
doIncrScalar:
varPtr = &(varFramePtr->compiledLocals[opnd]);
part1 = varPtr->name;
while (TclIsVarLink(varPtr)) {
varPtr = varPtr->value.linkPtr;
}
arrayPtr = NULL;
part2 = NULL;
cleanup = 0;
TRACE(("%u %ld => ", opnd, i));
doIncrVar:
objPtr = varPtr->value.objPtr;
if (TclIsVarScalar(varPtr)
&& !TclIsVarUndefined(varPtr)
&& (varPtr->tracePtr == NULL)
&& ((arrayPtr == NULL)
|| (arrayPtr->tracePtr == NULL))
&& (objPtr->typePtr == &tclIntType)) {
/*
* No errors, no traces, the variable already has an
* integer value: inline processing.
*/
i += objPtr->internalRep.longValue;
if (Tcl_IsShared(objPtr)) {
objResultPtr = Tcl_NewLongObj(i);
TclDecrRefCount(objPtr);
Tcl_IncrRefCount(objResultPtr);
varPtr->value.objPtr = objResultPtr;
} else {
Tcl_SetLongObj(objPtr, i);
objResultPtr = objPtr;
}
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
} else {
DECACHE_STACK_INFO();
objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1,
part2, i, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (objResultPtr == NULL) {
TRACE_APPEND(("ERROR: %.30sn", O2S(Tcl_GetObjResult(interp))));
result = TCL_ERROR;
goto checkForCatch;
}
}
TRACE_APPEND(("%.30sn", O2S(objResultPtr)));
#ifndef TCL_COMPILE_DEBUG
if (*(pc+pcAdjustment) == INST_POP) {
NEXT_INST_V((pcAdjustment+1), cleanup, 0);
}
#endif
NEXT_INST_V(pcAdjustment, cleanup, 1);
/*
* End of INST_INCR instructions.
* ---------------------------------------------------------
*/
case INST_JUMP1:
opnd = TclGetInt1AtPtr(pc+1);
TRACE(("%d => new pc %un", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("%d => new pc %un", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
NEXT_INST_F(opnd, 0, 0);
case INST_JUMP_FALSE4:
opnd = 5; /* TRUE */
pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */
goto doJumpTrue;
case INST_JUMP_TRUE4:
opnd = TclGetInt4AtPtr(pc+1); /* TRUE */
pcAdjustment = 5; /* FALSE */
goto doJumpTrue;
case INST_JUMP_FALSE1:
opnd = 2; /* TRUE */
pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */
goto doJumpTrue;
case INST_JUMP_TRUE1:
opnd = TclGetInt1AtPtr(pc+1); /* TRUE */
pcAdjustment = 2; /* FALSE */
doJumpTrue:
{
int b;
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclIntType) {
b = (valuePtr->internalRep.longValue != 0);
} else if (valuePtr->typePtr == &tclDoubleType) {
b = (valuePtr->internalRep.doubleValue != 0.0);
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
b = (w != W0);
} else {
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
goto checkForCatch;
}
}
#ifndef TCL_COMPILE_DEBUG
NEXT_INST_F((b? opnd : pcAdjustment), 1, 0);
#else
if (b) {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
TRACE(("%d => %.20s true, new pc %un", opnd, O2S(valuePtr),
(unsigned int)(pc+opnd - codePtr->codeStart)));
} else {
TRACE(("%d => %.20s truen", pcAdjustment, O2S(valuePtr)));
}
NEXT_INST_F(opnd, 1, 0);
} else {
if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
TRACE(("%d => %.20s falsen", opnd, O2S(valuePtr)));
} else {
opnd = pcAdjustment;
TRACE(("%d => %.20s false, new pc %un", opnd, O2S(valuePtr),
(unsigned int)(pc + opnd - codePtr->codeStart)));
}
NEXT_INST_F(pcAdjustment, 1, 0);
}
#endif
}
case INST_LOR:
case INST_LAND:
{
/*
* Operands must be boolean or numeric. No int->double
* conversions are performed.
*/
int i1, i2;
int iResult;
char *s;
Tcl_ObjType *t1Ptr, *t2Ptr;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];;
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
i1 = (valuePtr->internalRep.longValue != 0);
} else if (t1Ptr == &tclWideIntType) {
TclGetWide(w,valuePtr);
i1 = (w != W0);
} else if (t1Ptr == &tclDoubleType) {
i1 = (valuePtr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, valuePtr, i, w);
if (valuePtr->typePtr == &tclIntType) {
i1 = (i != 0);
} else {
i1 = (w != W0);
}
} else {
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
valuePtr, &i1);
i1 = (i1 != 0);
}
if (result != TCL_OK) {
TRACE((""%.20s" => ILLEGAL TYPE %s n", O2S(valuePtr),
(t1Ptr? t1Ptr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
i2 = (value2Ptr->internalRep.longValue != 0);
} else if (t2Ptr == &tclWideIntType) {
TclGetWide(w,value2Ptr);
i2 = (w != W0);
} else if (t2Ptr == &tclDoubleType) {
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
GET_WIDE_OR_INT(result, value2Ptr, i, w);
if (value2Ptr->typePtr == &tclIntType) {
i2 = (i != 0);
} else {
i2 = (w != W0);
}
} else {
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);
}
if (result != TCL_OK) {
TRACE((""%.20s" => ILLEGAL TYPE %s n", O2S(value2Ptr),
(t2Ptr? t2Ptr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (*pc == INST_LOR) {
iResult = (i1 || i2);
} else {
iResult = (i1 && i2);
}
if (Tcl_IsShared(valuePtr)) {
objResultPtr = Tcl_NewLongObj(iResult);
TRACE(("%.20s %.20s => %dn", O2S(valuePtr), O2S(value2Ptr), iResult));
NEXT_INST_F(1, 2, 1);
} else { /* reuse the valuePtr object */
TRACE(("%.20s %.20s => %dn", O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
NEXT_INST_F(1, 1, 0);
}
}
/*
* ---------------------------------------------------------
* Start of INST_LIST and related instructions.
*/
case INST_LIST:
/*
* Pop the opnd (objc) top stack elements into a new list obj
* and then decrement their ref counts.
*/
opnd = TclGetUInt4AtPtr(pc+1);
objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
NEXT_INST_V(5, opnd, 1);
case INST_LIST_LENGTH:
valuePtr = stackPtr[stackTop];
result = Tcl_ListObjLength(interp, valuePtr, &length);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
Tcl_GetObjResult(interp));
goto checkForCatch;
}
objResultPtr = Tcl_NewIntObj(length);
TRACE(("%.20s => %dn", O2S(valuePtr), length));
NEXT_INST_F(1, 1, 1);
case INST_LIST_INDEX:
/*** lindex with objc == 3 ***/
/*
* Pop the two operands
*/
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop- 1];
/*
* Extract the desired list element
*/
objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Stash the list element on the stack
*/
TRACE(("%.20s %.20s => %sn",
O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
case INST_LIST_INDEX_MULTI:
{
/*
* 'lindex' with multiple index args:
*
* Determine the count of index args.
*/
int numIdx;
opnd = TclGetUInt4AtPtr(pc+1);
numIdx = opnd-1;
/*
* Do the 'lindex' operation.
*/
objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
numIdx, stackPtr + stackTop - numIdx + 1);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("%d => %sn", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, opnd, -1);
}
case INST_LSET_FLAT:
{
/*
* Lset with 3, 5, or more args. Get the number
* of index args.
*/
int numIdx;
opnd = TclGetUInt4AtPtr( pc + 1 );
numIdx = opnd - 2;
/*
* Get the old value of variable, and remove the stack ref.
* This is safe because the variable still references the
* object; the ref count will never go zero here.
*/
value2Ptr = POP_OBJECT();
TclDecrRefCount(value2Ptr); /* This one should be done here */
/*
* Get the new element value.
*/
valuePtr = stackPtr[stackTop];
/*
* Compute the new variable value
*/
objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
stackPtr + stackTop - numIdx, valuePtr);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("%d => %sn", opnd, O2S(objResultPtr)));
NEXT_INST_V(5, (numIdx+1), -1);
}
case INST_LSET_LIST:
/*
* 'lset' with 4 args.
*
* Get the old value of variable, and remove the stack ref.
* This is safe because the variable still references the
* object; the ref count will never go zero here.
*/
objPtr = POP_OBJECT();
TclDecrRefCount(objPtr); /* This one should be done here */
/*
* Get the new element value, and the index list
*/
valuePtr = stackPtr[stackTop];
value2Ptr = stackPtr[stackTop - 1];
/*
* Compute the new variable value
*/
objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
/*
* Check for errors
*/
if (objResultPtr == NULL) {
TRACE_WITH_OBJ((""%.30s" => ERROR: ", O2S(value2Ptr)),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Set result
*/
TRACE(("=> %sn", O2S(objResultPtr)));
NEXT_INST_F(1, 2, -1);
/*
* End of INST_LIST and related instructions.
* ---------------------------------------------------------
*/
case INST_STR_EQ:
case INST_STR_NEQ:
{
/*
* String (in)equality check
*/
int iResult;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
if (valuePtr == value2Ptr) {
/*
* On the off-chance that the objects are the same,
* we don't really have to think hard about equality.
*/
iResult = (*pc == INST_STR_EQ);
} else {
char *s1, *s2;
int s1len, s2len;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
if (s1len == s2len) {
/*
* We only need to check (in)equality when
* we have equal length strings.
*/
if (*pc == INST_STR_NEQ) {
iResult = (strcmp(s1, s2) != 0);
} else {
/* INST_STR_EQ */
iResult = (strcmp(s1, s2) == 0);
}
} else {
iResult = (*pc == INST_STR_NEQ);
}
}
TRACE(("%.20s %.20s => %dn", O2S(valuePtr), O2S(value2Ptr), iResult));
/*
* Peep-hole optimisation: if you're about to jump, do jump
* from here.
*/
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 = Tcl_NewIntObj(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_STR_CMP:
{
/*
* String compare
*/
CONST char *s1, *s2;
int s1len, s2len, iResult;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* The comparison function should compare up to the
* minimum byte length only.
*/
if (valuePtr == value2Ptr) {
/*
* In the pure equality case, set lengths too for
* the checks below (or we could goto beyond it).
*/
iResult = s1len = s2len = 0;
} else if ((valuePtr->typePtr == &tclByteArrayType)
&& (value2Ptr->typePtr == &tclByteArrayType)) {
s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
iResult = memcmp(s1, s2,
(size_t) ((s1len < s2len) ? s1len : s2len));
} else if (((valuePtr->typePtr == &tclStringType)
&& (value2Ptr->typePtr == &tclStringType))) {
/*
* Do a unicode-specific comparison if both of the args are of
* String type. If the char length == byte length, we can do a
* memcmp. In benchmark testing this proved the most efficient
* check between the unicode and string comparison operations.
*/
s1len = Tcl_GetCharLength(valuePtr);
s2len = Tcl_GetCharLength(value2Ptr);
if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
(unsigned) ((s1len < s2len) ? s1len : s2len));
} else {
iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
Tcl_GetUnicode(value2Ptr),
(unsigned) ((s1len < s2len) ? s1len : s2len));
}
} else {
/*
* We can't do a simple memcmp in order to handle the
* special Tcl xC0x80 null encoding for utf-8.
*/
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
iResult = TclpUtfNcmp2(s1, s2,
(size_t) ((s1len < s2len) ? s1len : s2len));
}
/*
* Make sure only -1,0,1 is returned
*/
if (iResult == 0) {
iResult = s1len - s2len;
}
if (iResult < 0) {
iResult = -1;
} else if (iResult > 0) {
iResult = 1;
}
objResultPtr = Tcl_NewIntObj(iResult);
TRACE(("%.20s %.20s => %dn", O2S(valuePtr), O2S(value2Ptr), iResult));
NEXT_INST_F(1, 2, 1);
}
case INST_STR_LEN:
{
int length1;
valuePtr = stackPtr[stackTop];
if (valuePtr->typePtr == &tclByteArrayType) {
(void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
} else {
length1 = Tcl_GetCharLength(valuePtr);
}
objResultPtr = Tcl_NewIntObj(length1);
TRACE(("%.20s => %dn", O2S(valuePtr), length1));
NEXT_INST_F(1, 1, 1);
}
case INST_STR_INDEX:
{
/*
* String compare
*/
int index;
bytes = NULL; /* lint */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* If we have a ByteArray object, avoid indexing in the
* Utf string since the byte array contains one byte per
* character. Otherwise, use the Unicode string rep to
* get the index'th char.
*/
if (valuePtr->typePtr == &tclByteArrayType) {
bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
} else {
/*
* Get Unicode char length to calulate what 'end' means.
*/
length = Tcl_GetCharLength(valuePtr);
}
result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
if (result != TCL_OK) {
goto checkForCatch;
}
if ((index >= 0) && (index < length)) {
if (valuePtr->typePtr == &tclByteArrayType) {
objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
(&bytes[index]), 1);
} else if (valuePtr->bytes && length == valuePtr->length) {
objResultPtr = Tcl_NewStringObj((CONST char *)
(&valuePtr->bytes[index]), 1);
} else {
char buf[TCL_UTF_MAX];
Tcl_UniChar ch;
ch = Tcl_GetUniChar(valuePtr, index);
/*
* This could be:
* Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
* but creating the object as a string seems to be
* faster in practical use.
*/
length = Tcl_UniCharToUtf(ch, buf);
objResultPtr = Tcl_NewStringObj(buf, length);
}
} else {
TclNewObj(objResultPtr);
}
TRACE(("%.20s %.20s => %sn", O2S(valuePtr), O2S(value2Ptr),
O2S(objResultPtr)));
NEXT_INST_F(1, 2, 1);
}
case INST_STR_MATCH:
{
int nocase, match;
nocase = TclGetInt1AtPtr(pc+1);
valuePtr = stackPtr[stackTop]; /* String */
value2Ptr = stackPtr[stackTop - 1]; /* Pattern */
/*
* Check that at least one of the objects is Unicode before
* promoting both.
*/
if ((valuePtr->typePtr == &tclStringType)
|| (value2Ptr->typePtr == &tclStringType)) {
Tcl_UniChar *ustring1, *ustring2;
int length1, length2;
ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
match = TclUniCharMatch(ustring1, length1, ustring2, length2,
nocase);
} else {
match = Tcl_StringCaseMatch(TclGetString(valuePtr),
TclGetString(value2Ptr), nocase);
}
/*
* Reuse value2Ptr object already on stack if possible.
* Adjustment is 2 due to the nocase byte
*/
TRACE(("%.20s %.20s => %dn", O2S(valuePtr), O2S(value2Ptr), match));
if (Tcl_IsShared(value2Ptr)) {
objResultPtr = Tcl_NewIntObj(match);
NEXT_INST_F(2, 2, 1);
} else { /* reuse the valuePtr object */
Tcl_SetIntObj(value2Ptr, match);
NEXT_INST_F(2, 1, 0);
}
}
case INST_EQ:
case INST_NEQ:
case INST_LT:
case INST_GT:
case INST_LE:
case INST_GE:
{
/*
* Any type is allowed but the two operands must have the
* same type. We will compute value op value2.
*/
Tcl_ObjType *t1Ptr, *t2Ptr;
char *s1 = NULL; /* Init. avoids compiler warning. */
char *s2 = NULL; /* Init. avoids compiler warning. */
long i2 = 0; /* Init. avoids compiler warning. */
double d1 = 0.0; /* Init. avoids compiler warning. */
double d2 = 0.0; /* Init. avoids compiler warning. */
long iResult = 0; /* Init. avoids compiler warning. */
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
/*
* Be careful in the equal-object case; 'NaN' isn't supposed
* to be equal to even itself. [Bug 761471]
*/
t1Ptr = valuePtr->typePtr;
if (valuePtr == value2Ptr) {
/*
* If we are numeric already, we can proceed to the main
* equality check right now. Otherwise, we need to try to
* coerce to a numeric type so we can see if we've got a
* NaN but haven't parsed it as numeric.
*/
if (!IS_NUMERIC_TYPE(t1Ptr)) {
if (t1Ptr == &tclListType) {
int length;
/*
* Only a list of length 1 can be NaN or such
* things.
*/
(void) Tcl_ListObjLength(NULL, valuePtr, &length);
if (length == 1) {
goto mustConvertForNaNCheck;
}
} else {
/*
* Too bad, we'll have to compute the string and
* try the conversion
*/
mustConvertForNaNCheck:
s1 = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s1, length)) {
GET_WIDE_OR_INT(iResult, valuePtr, i, w);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
t1Ptr = valuePtr->typePtr;
}
}
switch (*pc) {
case INST_EQ:
case INST_LE:
case INST_GE:
iResult = !((t1Ptr == &tclDoubleType)
&& IS_NAN(valuePtr->internalRep.doubleValue));
break;
case INST_LT:
case INST_GT:
iResult = 0;
break;
case INST_NEQ:
iResult = ((t1Ptr == &tclDoubleType)
&& IS_NAN(valuePtr->internalRep.doubleValue));
break;
}
goto foundResult;
}
t2Ptr = value2Ptr->typePtr;
/*
* We only want to coerce numeric validation if neither type
* is NULL. A NULL type means the arg is essentially an empty
* object ("", {} or [list]).
*/
if (!( (!t1Ptr && !valuePtr->bytes)
|| (valuePtr->bytes && !valuePtr->length)
|| (!t2Ptr && !value2Ptr->bytes)
|| (value2Ptr->bytes && !value2Ptr->length))) {
if (!IS_NUMERIC_TYPE(t1Ptr)) {
s1 = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s1, length)) {
GET_WIDE_OR_INT(iResult, valuePtr, i, w);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
t1Ptr = valuePtr->typePtr;
}
if (!IS_NUMERIC_TYPE(t2Ptr)) {
s2 = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s2, length)) {
GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d2);
}
t2Ptr = value2Ptr->typePtr;
}
}
if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
/*
* One operand is not numeric. Compare as strings. NOTE:
* strcmp is not correct for x00 < x01, but that is
* unlikely to occur here. We could use the TclUtfNCmp2
* to handle this.
*/
int s1len, s2len;
s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
switch (*pc) {
case INST_EQ:
if (s1len == s2len) {
iResult = (strcmp(s1, s2) == 0);
} else {
iResult = 0;
}
break;
case INST_NEQ:
if (s1len == s2len) {
iResult = (strcmp(s1, s2) != 0);
} else {
iResult = 1;
}
break;
case INST_LT:
iResult = (strcmp(s1, s2) < 0);
break;
case INST_GT:
iResult = (strcmp(s1, s2) > 0);
break;
case INST_LE:
iResult = (strcmp(s1, s2) <= 0);
break;
case INST_GE:
iResult = (strcmp(s1, s2) >= 0);
break;
}
} else if ((t1Ptr == &tclDoubleType)
|| (t2Ptr == &tclDoubleType)) {
/*
* Compare as doubles.
*/
if (t1Ptr == &tclDoubleType) {
d1 = valuePtr->internalRep.doubleValue;
GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
} else { /* t1Ptr is integer, t2Ptr is double */
GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
d2 = value2Ptr->internalRep.doubleValue;
}
switch (*pc) {
case INST_EQ:
iResult = d1 == d2;
break;
case INST_NEQ:
iResult = d1 != d2;
break;
case INST_LT:
iResult = d1 < d2;
break;
case INST_GT:
iResult = d1 > d2;
break;
case INST_LE:
iResult = d1 <= d2;
break;
case INST_GE:
iResult = d1 >= d2;
break;
}
} else if ((t1Ptr == &tclWideIntType)
|| (t2Ptr == &tclWideIntType)) {
Tcl_WideInt w2;
/*
* Compare as wide ints (neither are doubles)
*/
if (t1Ptr == &tclIntType) {
w = Tcl_LongAsWide(valuePtr->internalRep.longValue);
TclGetWide(w2,value2Ptr);
} else if (t2Ptr == &tclIntType) {
TclGetWide(w,valuePtr);
w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
} else {
TclGetWide(w,valuePtr);
TclGetWide(w2,value2Ptr);
}
switch (*pc) {
case INST_EQ:
iResult = w == w2;
break;
case INST_NEQ:
iResult = w != w2;
break;
case INST_LT:
iResult = w < w2;
break;
case INST_GT:
iResult = w > w2;
break;
case INST_LE:
iResult = w <= w2;
break;
case INST_GE:
iResult = w >= w2;
break;
}
} else {
/*
* Compare as ints.
*/
i = valuePtr->internalRep.longValue;
i2 = value2Ptr->internalRep.longValue;
switch (*pc) {
case INST_EQ:
iResult = i == i2;
break;
case INST_NEQ:
iResult = i != i2;
break;
case INST_LT:
iResult = i < i2;
break;
case INST_GT:
iResult = i > i2;
break;
case INST_LE:
iResult = i <= i2;
break;
case INST_GE:
iResult = i >= i2;
break;
}
}
foundResult:
TRACE(("%.20s %.20s => %ldn", O2S(valuePtr), O2S(value2Ptr), iResult));
/*
* Peep-hole optimisation: if you're about to jump, do jump
* from here.
*/
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 = Tcl_NewIntObj(iResult);
NEXT_INST_F(0, 2, 1);
}
case INST_MOD:
case INST_LSHIFT:
case INST_RSHIFT:
case INST_BITOR:
case INST_BITXOR:
case INST_BITAND:
{
/*
* Only integers are allowed. We compute value op value2.
*/
long i2 = 0, rem, negative;
long iResult = 0; /* Init. avoids compiler warning. */
Tcl_WideInt w2, wResult = W0;
int doWide = 0;
value2Ptr = stackPtr[stackTop];
valuePtr = stackPtr[stackTop - 1];
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if (valuePtr->typePtr == &tclWideIntType) {
TclGetWide(w,valuePtr);
} else { /* try to convert to int */
REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %sn",
O2S(valuePtr), O2S(value2Ptr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, valuePtr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
if (value2Ptr->typePtr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
} else if (value2Ptr->typePtr == &tclWideIntType) {
TclGetWide(w2,value2Ptr);
} else {
REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %sn",
O2S(valuePtr), O2S(value2Ptr),
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
DECACHE_STACK_INFO();
IllegalExprOperandType(interp, pc, value2Ptr);
CACHE_STACK_INFO();
goto checkForCatch;
}
}
switch (*pc) {
case INST_MOD:
/*
* This code is tricky: C doesn't guarantee much about
* the quotient or remainder, but Tcl does. The
* remainder always has the same sign as the divisor and
* a smaller absolute value.
*/
if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
if (valuePtr->typePtr == &tclIntType) {
TRACE(("%ld "LLD" => DIVIDE BY ZEROn", i, w2));
} else {
TRACE((LLD" "LLD" => DIVIDE BY ZEROn", w, w2));
}
goto divideByZero;
}
if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
if (valuePtr->typePtr == &tclIntType) {
TRACE(("%ld %ld => DIVIDE BY ZEROn", i, i2));
} else {
TRACE((LLD" %ld => DIVIDE BY ZEROn", w, i2));
}
goto divideByZero;
}
negative = 0;
if (valuePtr->typePtr == &tclWideIntType
|| value2Ptr->typePtr == &tclWideIntType) {
Tcl_WideInt wRemainder;
/*
* Promote to wide
*/
if (valuePtr->typePtr == &tclIntType) {
w = Tcl_LongAsWide(i);
} else if (value2Ptr->typePtr == &tclIntType) {
w2 = Tcl_LongAsWide(i2);
}
if (w2 < 0) {
w2 = -w2;
w = -w;
negative = 1;
}
wRemainder = w % w2;
if (wRemainder < 0) {
wRemainder += w2;
}
if (negative) {
wRemainder = -wRemainder;
}
wResult = wRemainder;
doWide = 1;
break;
}
if (i2 < 0) {
i2 = -i2;
i = -i;
negative = 1;
}
rem = i % i2;
if (rem < 0) {
rem += i2;
}
if (negative) {
rem = -rem;
}
iResult = rem;
break;
case INST_LSHIFT:
/*
* Shifts are never usefully 64-bits wide!
*/
FORCE_LONG(value2Ptr, i2, w2);
if (valuePtr->typePtr == &tclWideIntType) {
#ifdef TCL_COMPILE_DEBUG
w2 = Tcl_LongAsWide(i2);
#endif /* TCL_COMPILE_DEBUG */
wResult = w;
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
wResult = Tcl_LongAsWide(0);
} else if (i2 > 60) {
wResult = w << 30;
wResult <<= 30;
wResult <<= i2-60;
} else if (i2 > 30) {
wResult = w << 30;
wResult <<= i2-30;
} else {
wResult = w << i2;
}
doWide = 1;
break;
}
/*
* Shift in steps when the shift gets large to prevent
* annoying compiler/processor bugs. [Bug 868467]
*/
if (i2 >= 64) {
iResult = 0;
} else if (i2 > 60) {
iResult = i << 30;
iResult <<= 30;
iResult <<= i2-60;
} else if (i2 > 30) {
iResult = i << 30;
iResult <<= i2-30;
} else {
iResult = i << i2;
}
break;
case INST_RSHIFT:
/*
* The following code is a bit tricky: it ensures that
* right shifts propagate the sign bit even on machines
* where ">>" won't do it by default.
*/