#define TCL_NO_RECURSE 1
/*
* tclExecute.c --
*
* This file contains procedures that execute byte-compiled Tcl
* commands.
*
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
* Copyright (c) 1998-2000 by Scriptics Corporation.
*
* 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.10.2.2.2.4 2002/07/19 17:28:21 andreas_kupries Exp $
*/
#include "tclInt.h"
#include "tclCompile.h"
#ifdef NO_FLOAT_H
# include "../compat/float.h"
#else
# include <float.h>
#endif
#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
#define NO_ERRNO_H
#endif
#ifdef NO_ERRNO_H
int errno;
#define EDOM 33
#define ERANGE 34
#endif
/*
* Boolean flag indicating whether the Tcl bytecode interpreter has been
* initialized.
*/
static int execInitialized = 0;
TCL_DECLARE_MUTEX(execMutex)
/*
* 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;
typedef struct ThreadSpecificData {
/*
* The following global variable is use to signal matherr that Tcl
* is responsible for the arithmetic, so errors can be handled in a
* fashion appropriate for Tcl. Zero means no Tcl math is in
* progress; non-zero means Tcl is doing math.
*/
int mathInProgress;
} ThreadSpecificData;
static Tcl_ThreadDataKey dataKey;
/*
* The variable below serves no useful purpose except to generate
* a reference to matherr, so that the Tcl version of matherr is
* linked in rather than the system version. Without this reference
* the need for matherr won't be discovered during linking until after
* libtcl.a has been processed, so Tcl's version won't be used.
*/
#ifdef NEED_MATHERR
extern int matherr();
int (*tclMatherrPtr)() = matherr;
#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"
};
/*
* 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))
#ifdef DBL_MAX
# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
#else
# define IS_INF(v) 0
#endif
/*
* Macro to adjust the program counter and restart the instruction execution
* loop after each instruction is executed.
*/
#define ADJUST_PC(instBytes) \
pc += (instBytes); \
continue
/*
* 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_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) \
Tcl_GetString(objPtr)
#else
#define TRACE(a)
#define TRACE_WITH_OBJ(a, objPtr)
#define O2S(objPtr)
#endif /* TCL_COMPILE_DEBUG */
/*
* Declarations for local procedures to this file:
*/
static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
Trace *tracePtr, Command *cmdPtr,
char *command, int numChars,
int objc, Tcl_Obj *objv[]));
static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
Tcl_Obj *copyPtr));
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));
#ifdef TCL_COMPILE_STATS
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
Tcl_Interp *interp, int argc, char **argv));
#endif
static void FreeCmdNameInternalRep _ANSI_ARGS_((
Tcl_Obj *objPtr));
#ifdef TCL_COMPILE_DEBUG
static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
#endif
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));
#endif
static void ProcessUnexpectedResult _ANSI_ARGS_((
Tcl_Interp *interp, int returnCode));
static int ProcessProcResultCode _ANSI_ARGS_((Tcl_Interp *interp,
char *procName, int nameLen, int returnCode));
static void RecordTracebackInfo _ANSI_ARGS_((
Tcl_Interp *interp, Tcl_Obj *objPtr,
int numSrcBytes));
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
#ifdef TCL_COMPILE_DEBUG
static char * StringForResultCode _ANSI_ARGS_((int result));
static void ValidatePcAndStackTop _ANSI_ARGS_((
ByteCode *codePtr, unsigned char *pc,
int stackTop, int stackLowerBound,
int stackUpperBound));
#endif
static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
Tcl_Obj *objPtr));
static int TclInterpReady _ANSI_ARGS_((Tcl_Interp *interp));
static int TclCompileByteCodesForEval _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr));
static int TclInterpPostEval _ANSI_ARGS_((Tcl_Interp *interp,
int evalFlags, int result, Tcl_Obj *objPtr, int numSrcBytes));
static int TclCompileByteCodesForExpr _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr));
static int PrepareProcFrameForExecution _ANSI_ARGS_((Tcl_Interp *interp,
CallFrame *framePtr, int objc, Tcl_Obj *CONST objv[0],
Var *compiledLocals));
int TclEvalByteCodeFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, int flags));
int TclExprByteCodeFromObj _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr, Tcl_Obj **resultPtrPtr));
/*
* 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 builtinFuncTable[] = {
#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},
{0},
};
/*
* The structure below defines the command name Tcl object type by means of
* procedures that can be invoked by generic object code. Objects of this
* type cache the Command pointer that results from looking up command names
* in the command hashtable. Such objects appear as the zeroth ("command
* name") argument in a Tcl command.
*/
Tcl_ObjType tclCmdNameType = {
"cmdName", /* name */
FreeCmdNameInternalRep, /* freeIntRepProc */
DupCmdNameInternalRep, /* dupIntRepProc */
(Tcl_UpdateStringProc *) NULL, /* updateStringProc */
SetCmdNameFromAny /* setFromAnyProc */
};
/*
*----------------------------------------------------------------------
*
* 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 registers the command name
* Tcl_ObjType. 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. */
{
Tcl_RegisterObjType(&tclCmdNameType);
if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
TCL_LINK_INT) != TCL_OK) {
panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
}
#ifdef TCL_COMPILE_STATS
Tcl_CreateCommand(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));
eePtr->stackPtr = (Tcl_Obj **)
ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
eePtr->stackTop = -1;
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
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. */
{
Tcl_EventuallyFree((ClientData)eePtr->stackPtr, TCL_DYNAMIC);
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 = newElems * sizeof(Tcl_Obj *);
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
/*
* Copy the existing stack items to the new stack space, free the old
* storage if appropriate, and mark new space as malloc'ed.
*/
memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
(size_t) currBytes);
Tcl_EventuallyFree((ClientData)eePtr->stackPtr, TCL_DYNAMIC);
eePtr->stackPtr = newStackPtr;
eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
}
/*********************************/
#if TCL_NO_RECURSE
/*
* Definitions for the internal return stack rs
*
* REMARK: this simple code assumes that pointers are at least
* as large as integers:
* sizeof(void *) >= sizeof(int)
* Are there any systems where this is not true?
*
* Furthermore, should sizeof(void *) > sizeof(int), this
* may cause a misalignment of the stack data ...
*/
typedef struct rsData {
Tcl_Obj *objPtr;
ByteCode *codePtr;
unsigned char *pc;
int initStackTop;
int catchTop;
} rsData;
#define RS_PUSH(callType) \
{ \
rsData *rsPtr = (rsData *) &stackPtr[stackTop + 1];\
\
rsPtr->codePtr = oldCodePtr;\
rsPtr->objPtr = objPtr;\
rsPtr->pc = pc;\
rsPtr->initStackTop = initStackTop;\
rsPtr->catchTop = catchTop;\
}\
stackTop += (sizeof(rsData) + 1);\
stackPtr[stackTop] = (Tcl_Obj *) (callType);\
currentDepth++;
#define RS_POP() \
stackTop -= sizeof(rsData);\
{ \
rsData *rsPtr = (rsData *) &stackPtr[stackTop + 1];\
\
codePtr = rsPtr->codePtr;\
objPtr = rsPtr->objPtr;\
pc = rsPtr->pc;\
initStackTop = rsPtr->initStackTop;\
catchTop = rsPtr->catchTop;\
catchStackPtr = (int *) &stackPtr[initStackTop - (codePtr->maxExceptDepth) + 1];\
}
#endif /* TCL_NO_RECURSE */
/*
*----------------------------------------------------------------------
*
* 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.
*
*----------------------------------------------------------------------
*/
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. */
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 traceInstructions = (tclTraceExec == 3);
Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
char *bytes;
int length;
long i;
int catchTop, *catchStackPtr;
/*
* 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 is set at the bottom of
* the bytecodes stack, its depth is the exception range array's depth.
*
* Make sure the stack has enough room to execute this ByteCode,
* holding the bytecodes catch stack, and storing the data for a
* possible internal recursion.
*
* REMARK: this simple code assumes that Tcl_Obj* and int* are the same
* size (can this ever be wrong?)
*/
#if TCL_NO_RECURSE
int currentDepth = 0;
ByteCode *oldCodePtr;
/*
* Jump back here for internal recursions
*/
startInternalRecursionHere:
pc = codePtr->codeStart;
result = TCL_OK;
length = stackTop + sizeof(rsData)
+ (codePtr->maxStackDepth + codePtr->maxExceptDepth + 3)*sizeof(Tcl_Obj *);
#else
length = stackTop + (codePtr->maxStackDepth + codePtr->maxExceptDepth)*sizeof(Tcl_Obj *);
#endif
while (length > eePtr->stackEnd) {
GrowEvaluationStack(eePtr);
stackPtr = eePtr->stackPtr;
}
catchStackPtr = (int *) &stackPtr[stackTop + 1];
catchTop = -1;
stackTop += (codePtr->maxExceptDepth);
initStackTop = stackTop;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceExec >= 2) {
PrintByteCodeInfo(codePtr);
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
fflush(stdout);
}
#endif
#ifdef TCL_COMPILE_STATS
iPtr->stats.numExecutions++;
#endif
/*
* Loop executing instructions until a "done" instruction, a TCL_RETURN,
* or some error.
*/
for (;;) {
#ifdef TCL_COMPILE_DEBUG
ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
eePtr->stackEnd);
#else /* not TCL_COMPILE_DEBUG */
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
switch (*pc) {
case INST_DONE:
/*
* Pop the topmost object from the stack, set the interpreter's
* object result to point to it, and return.
*/
valuePtr = POP_OBJECT();
Tcl_SetObjResult(interp, valuePtr);
TclDecrRefCount(valuePtr);
if (stackTop != initStackTop) {
/*
* if extra items in the stack, clean up the stack before return
*/
if (stackTop > initStackTop) goto abnormalReturn;
fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d < entry stack top %d\n",
(unsigned int)(pc - codePtr->codeStart),
(unsigned int) stackTop,
(unsigned int) initStackTop);
panic("TclExecuteByteCode execution failure: end stack top < start stack top");
}
TRACE_WITH_OBJ(("=> return code=%d, result=", result),
iPtr->objResultPtr);
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, "\n");
}
#endif
goto done;
case INST_PUSH1:
#ifdef TCL_COMPILE_DEBUG
valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
#else
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
#endif /* TCL_COMPILE_DEBUG */
ADJUST_PC(2);
case INST_PUSH4:
valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
ADJUST_PC(5);
case INST_POP:
valuePtr = POP_OBJECT();
TRACE_WITH_OBJ(("=> discarding "), valuePtr);
TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
ADJUST_PC(1);
case INST_DUP:
valuePtr = stackPtr[stackTop];
PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
TRACE_WITH_OBJ(("=> "), valuePtr);
ADJUST_PC(1);
case INST_CONCAT1:
opnd = TclGetUInt1AtPtr(pc+1);
{
Tcl_Obj *concatObjPtr;
int totalLen = 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(concatObjPtr);
if (totalLen > 0) {
char *p = (char *) ckalloc((unsigned) (totalLen + 1));
concatObjPtr->bytes = p;
concatObjPtr->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;
}
TclDecrRefCount(valuePtr);
}
*p = '\0';
} else {
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
Tcl_DecrRefCount(stackPtr[i]);
}
}
stackTop -= opnd;
PUSH_OBJECT(concatObjPtr);
TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
ADJUST_PC(2);
}
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. */
Command *cmdPtr; /* Points to command's Command struct. */
int newPcOffset; /* New inst offset for break, continue. */
Tcl_Obj **preservedStack;
/* Reference to memory block containing
* objv array (must be kept live throughout
* trace and command invokations.) */
#ifdef TCL_COMPILE_DEBUG
int isUnknownCmd = 0;
char cmdNameBuf[21];
#endif /* TCL_COMPILE_DEBUG */
/*
* If the interpreter was deleted, return an error.
*/
if (iPtr->flags & DELETED) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"attempt to call eval in deleted interpreter", -1);
Tcl_SetErrorCode(interp, "CORE", "IDELETE",
"attempt to call eval in deleted interpreter",
(char *) NULL);
result = TCL_ERROR;
goto checkForCatch;
}
/*
* Find the procedure to execute this command. If the
* command is not found, handle it with the "unknown" proc.
*/
objv = &(stackPtr[stackTop - (objc-1)]);
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
if (cmdPtr == NULL) {
cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
(Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
if (cmdPtr == NULL) {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"invalid command name \"",
Tcl_GetString(objv[0]), "\"",
(char *) NULL);
TRACE(("%u => unknown proc not found: ", objc));
result = TCL_ERROR;
goto checkForCatch;
}
#ifdef TCL_COMPILE_DEBUG
isUnknownCmd = 1;
#endif /*TCL_COMPILE_DEBUG*/
stackTop++; /* need room for new inserted objv[0] */
for (i = objc-1; i >= 0; i--) {
objv[i+1] = objv[i];
}
objc++;
objv[0] = Tcl_NewStringObj("unknown", -1);
Tcl_IncrRefCount(objv[0]);
}
/*
* Call any trace procedures.
*/
if (iPtr->tracePtr != NULL) {
Trace *tracePtr, *nextTracePtr;
for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
tracePtr = nextTracePtr) {
nextTracePtr = tracePtr->nextPtr;
if (iPtr->numLevels <= tracePtr->level) {
int numChars;
char *cmd = GetSrcInfoForPc(pc, codePtr,
&numChars);
if (cmd != NULL) {
DECACHE_STACK_INFO();
CallTraceProcedure(interp, tracePtr, cmdPtr,
cmd, numChars, objc, objv);
CACHE_STACK_INFO();
}
}
}
}
/*
* Finally, invoke the command's Tcl_ObjCmdProc. First reset
* the interpreter's string and object results to their
* default empty values since they could have gotten changed
* by earlier invocations.
*/
Tcl_ResetResult(interp);
if (tclTraceExec >= 2) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
TRACE(("%u => call ", (isUnknownCmd? objc-1: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);
#else /* TCL_COMPILE_DEBUG */
fprintf(stdout, "%d: (%u) invoking %s\n",
iPtr->numLevels,
(unsigned int)(pc - codePtr->codeStart),
Tcl_GetString(objv[0]));
#endif /*TCL_COMPILE_DEBUG*/
}
iPtr->cmdCount++;
#if TCL_NO_RECURSE
#define VAR_TO_POINTER (sizeof(Var)/sizeof(void *) + 1)
#define FRAME_TO_POINTER (sizeof(CallFrame)/sizeof(void *) + 1)
if ((*cmdPtr->objProc) == TclObjInterpProc) {
/*
* This is code "borrowed" from TclObjInterpProc
*/
Proc *procPtr = (Proc *) (cmdPtr->objClientData);
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame *framePtr;
Var *compiledLocals;
int localCt;
objPtr = procPtr->bodyPtr;
result = TclProcCompileProc(interp, procPtr, objPtr, nsPtr,
"body of proc", Tcl_GetString(objv[0]));
if (result != TCL_OK) {
goto earlyReturnFromPROC;
}
localCt = procPtr->numCompiledLocals;
/*
* make sure there is enough room in the stack
*/
length = stackTop + sizeof(rsData) +
+(FRAME_TO_POINTER +localCt*VAR_TO_POINTER + 7)*sizeof(Tcl_Obj *);
while (length > eePtr->stackEnd) {
GrowEvaluationStack(eePtr);
stackPtr = eePtr->stackPtr;
}
framePtr = (CallFrame *) &stackPtr[stackTop + 1];
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);
if (result != TCL_OK) {
goto earlyReturnFromPROC;
}
stackTop += FRAME_TO_POINTER;
framePtr->procPtr = procPtr;
compiledLocals = (Var *) &stackPtr[stackTop + 1];
stackTop += localCt * VAR_TO_POINTER;
stackPtr[++stackTop] = (Tcl_Obj *) objc;
stackPtr[++stackTop] = (Tcl_Obj *) procPtr;
result = PrepareProcFrameForExecution(interp, framePtr, objc, objv, compiledLocals);
if (result == TCL_ERROR) {
Tcl_PopCallFrame(interp);
stackTop -= (FRAME_TO_POINTER + (procPtr->numCompiledLocals)*VAR_TO_POINTER + 2);
goto earlyReturnFromPROC;
}
procPtr->refCount++;
Tcl_Preserve((ClientData) stackPtr);
preservedStack = stackPtr;
/*
* This is code borrowed from TclEvalByteCodeFromObj
*/
Tcl_ResetResult(interp);
result = TclInterpReady(interp);
if (result == TCL_ERROR) {
goto earlyReturnFromEvalBody;
}
oldCodePtr = codePtr;
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
stackPtr[++stackTop] = (Tcl_Obj *) preservedStack;
stackPtr[++stackTop] = (Tcl_Obj *) pcAdjustment;
stackPtr[++stackTop] = (Tcl_Obj *) codePtr->numSrcBytes;
stackPtr[++stackTop] = (Tcl_Obj *) iPtr->evalFlags;
iPtr->evalFlags = 0;
codePtr->refCount++;
iPtr->numLevels++;
RS_PUSH(0);
goto startInternalRecursionHere;
} else {
/*
* Command is not a proc
*/
Tcl_Preserve((ClientData)stackPtr);
preservedStack = stackPtr;
DECACHE_STACK_INFO();
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
objc, objv);
if (Tcl_AsyncReady()) {
result = Tcl_AsyncInvoke(interp, result);
}
CACHE_STACK_INFO();
Tcl_Release((ClientData) preservedStack);
/*
* If the interpreter has a non-empty string result, the
* result object is either empty or stale because some
* procedure set interp->result directly. If so, move the
* string result to the result object, then reset the
* string result.
*/
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
goto returnFromNON_PROC;
}
returnFromPROC:
if (--(codePtr->refCount) <= 0) {
TclCleanupByteCode(codePtr);
}
RS_POP();
{
int evalFlags = (int) stackPtr[stackTop--];
int numSrcBytes = (int) stackPtr[stackTop--];
result = TclInterpPostEval(interp, evalFlags, result, objPtr, numSrcBytes);
}
iPtr->numLevels--;
pcAdjustment = (int) stackPtr[stackTop--];
preservedStack = (Tcl_Obj **) stackPtr[stackTop--];
earlyReturnFromEvalBody:
{
Proc *procPtr;
procPtr = (Proc *) stackPtr[stackTop--];
objc = (int) stackPtr[stackTop--];
stackTop -= (FRAME_TO_POINTER + (procPtr->numCompiledLocals)*VAR_TO_POINTER);
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
if (result != TCL_OK) {
int nameLen;
char *procName;
objv = &stackPtr[stackTop - objc + 1];
procName = Tcl_GetStringFromObj(objv[0], &nameLen);
result = ProcessProcResultCode(interp, procName, nameLen, result);
}
}
Tcl_PopCallFrame(interp);
Tcl_Release((ClientData) preservedStack);
earlyReturnFromPROC:
if (Tcl_AsyncReady()) {
DECACHE_STACK_INFO();
result = Tcl_AsyncInvoke(interp, result);
CACHE_STACK_INFO();
}
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
returnFromNON_PROC:
#undef VAR_TO_POINTER
#undef FRAME_TO_POINTER
#else /* TCL_NO_RECURSE */
/*
* A reference to part of the stack vector itself
* escapes our control, so must use preserve/release
* 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.
*/
Tcl_Preserve((ClientData)stackPtr);
preservedStack = stackPtr;
DECACHE_STACK_INFO();
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
objc, objv);
if (Tcl_AsyncReady()) {
result = Tcl_AsyncInvoke(interp, result);
}
CACHE_STACK_INFO();
/*
* 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.
*/
Tcl_Release((ClientData)preservedStack);
/*
* If the interpreter has a non-empty string result, the
* result object is either empty or stale because some
* procedure set interp->result directly. If so, move the
* string result to the result object, then reset the
* string result.
*/
if (*(iPtr->result) != 0) {
(void) Tcl_GetObjResult(interp);
}
#endif
/*
* Pop the objc top stack elements and decrement their ref
* counts.
*/
for (i = 0; i < objc; i++) {
valuePtr = stackPtr[stackTop];
TclDecrRefCount(valuePtr);
stackTop--;
}
/*
* Process the result of the Tcl_ObjCmdProc call.
*/
switch (result) {
case TCL_OK:
/*
* Push the call's object result and continue execution
* with the next instruction.
*/
PUSH_OBJECT(Tcl_GetObjResult(interp));
TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
ADJUST_PC(pcAdjustment);
case TCL_BREAK:
case TCL_CONTINUE:
/*
* The invoked command requested a break or continue.
* Find the closest enclosing loop or catch exception
* range, if any. If a loop is found, terminate its
* execution or skip to its next iteration. If the
* closest is a catch exception range, jump to its
* catchOffset. If no enclosing range is found, stop
* execution and return the TCL_BREAK or TCL_CONTINUE.
*/
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
codePtr);
if (rangePtr == NULL) {
TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
objc, cmdNameBuf,
StringForResultCode(result)));
goto abnormalReturn; /* no catch exists to check */
}
newPcOffset = 0;
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
if (result == TCL_BREAK) {
newPcOffset = rangePtr->breakOffset;
} else if (rangePtr->continueOffset == -1) {
TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
objc, cmdNameBuf,
StringForResultCode(result)));
goto checkForCatch;
} else {
newPcOffset = rangePtr->continueOffset;
}
TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
objc, cmdNameBuf,
StringForResultCode(result),
rangePtr->codeOffset, newPcOffset));
break;
case CATCH_EXCEPTION_RANGE:
TRACE(("%u => ... after \"%.20s\", %s...\n",
objc, cmdNameBuf,
StringForResultCode(result)));
goto processCatch; /* it will use rangePtr */
default:
panic("TclExecuteByteCode: bad ExceptionRange type\n");
}
result = TCL_OK;
pc = (codePtr->codeStart + newPcOffset);
continue; /* restart outer instruction loop at pc */
case TCL_ERROR:
/*
* The invoked command returned an error. Look for an
* enclosing catch exception range, if any.
*/
TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
objc, cmdNameBuf), Tcl_GetObjResult(interp));
goto checkForCatch;
case TCL_RETURN:
/*
* The invoked command requested that the current
* procedure stop execution and return. First check
* for an enclosing catch exception range, if any.
*/
TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
objc, cmdNameBuf));
goto checkForCatch;
default:
TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
objc, cmdNameBuf, result),
Tcl_GetObjResult(interp));
goto checkForCatch;
}
}
case INST_EVAL_STK:
objPtr = POP_OBJECT();
#if TCL_NO_RECURSE
Tcl_ResetResult(interp);
result = ((TclInterpReady(interp) == TCL_ERROR) \
|| (TclCompileByteCodesForEval(interp, objPtr) == TCL_ERROR));
if (result == TCL_ERROR) {
Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
oldCodePtr = codePtr;
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
stackPtr[++stackTop] = (Tcl_Obj *) codePtr->numSrcBytes;
stackPtr[++stackTop] = (Tcl_Obj *) iPtr->evalFlags;
iPtr->evalFlags = 0;
stackPtr[++stackTop] = (Tcl_Obj *) iPtr->cmdCount;
codePtr->refCount++;
iPtr->numLevels++;
RS_PUSH(1);
goto startInternalRecursionHere;
returnFromEVAL:
if (--(codePtr->refCount) <= 0) {
TclCleanupByteCode(codePtr);
}
RS_POP();
{
int oldCount = (int) stackPtr[stackTop--];
if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
result = Tcl_AsyncInvoke(interp, result);
}
}
{
int evalFlags = (int) stackPtr[stackTop--];
int numSrcBytes = (int) stackPtr[stackTop--];
result = TclInterpPostEval(interp, evalFlags, result, objPtr, numSrcBytes);
}
iPtr->numLevels--;
#else
DECACHE_STACK_INFO();
result = TclEvalByteCodeFromObj(interp, objPtr, 0);
CACHE_STACK_INFO();
#endif
if (result == TCL_OK) {
/*
* Normal return; push the eval's object result.
*/
PUSH_OBJECT(Tcl_GetObjResult(interp));
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
Tcl_GetObjResult(interp));
TclDecrRefCount(objPtr);
ADJUST_PC(1);
} else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
/*
* Find the closest enclosing loop or catch exception range,
* if any. If a loop is found, terminate its execution or
* skip to its next iteration. If the closest is a catch
* exception range, jump to its catchOffset. If no enclosing
* range is found, stop execution and return that same
* TCL_BREAK or TCL_CONTINUE.
*/
int newPcOffset = 0; /* Pc offset computed during break,
* continue, error processing. Init.
* to avoid compiler warning. */
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
codePtr);
if (rangePtr == NULL) {
TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
O2S(objPtr), StringForResultCode(result)));
Tcl_DecrRefCount(objPtr);
goto abnormalReturn; /* no catch exists to check */
}
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
if (result == TCL_BREAK) {
newPcOffset = rangePtr->breakOffset;
} else if (rangePtr->continueOffset == -1) {
TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
O2S(objPtr), StringForResultCode(result)));
Tcl_DecrRefCount(objPtr);
goto checkForCatch;
} else {
newPcOffset = rangePtr->continueOffset;
}
result = TCL_OK;
TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ",
O2S(objPtr), StringForResultCode(result),
rangePtr->codeOffset, newPcOffset), valuePtr);
break;
case CATCH_EXCEPTION_RANGE:
TRACE_WITH_OBJ(("\"%.30s\" => %s ",
O2S(objPtr), StringForResultCode(result)),
valuePtr);
Tcl_DecrRefCount(objPtr);
goto processCatch; /* it will use rangePtr */
default:
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
}
Tcl_DecrRefCount(objPtr);
pc = (codePtr->codeStart + newPcOffset);
continue; /* restart outer instruction loop at pc */
} else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
case INST_EXPR_STK:
objPtr = POP_OBJECT();
Tcl_ResetResult(interp);
#if TCL_NO_RECURSE
/*
* This is the internal call; it mimics TclExprByteCodeFromObj
*/
result = TclCompileByteCodesForExpr(interp, objPtr);
if (result != TCL_OK) {
goto compErrorFromEXPR;
} else {
value2Ptr = Tcl_GetObjResult(interp);
PUSH_OBJECT(value2Ptr);
Tcl_ResetResult(interp);
oldCodePtr = codePtr;
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
codePtr->refCount++;
RS_PUSH(2);
goto startInternalRecursionHere;
}
returnFromEXPR:
if (--(codePtr->refCount) <= 0) {
TclCleanupByteCode(codePtr);
RS_POP();
objPtr->typePtr = NULL;
objPtr->internalRep.otherValuePtr = NULL;
} else {
RS_POP();
}
value2Ptr = POP_OBJECT();
valuePtr = Tcl_GetObjResult(interp);
if (result == TCL_OK) {
Tcl_IncrRefCount(valuePtr);
Tcl_SetObjResult(interp, value2Ptr);
}
TclDecrRefCount(value2Ptr);
compErrorFromEXPR:
#else
DECACHE_STACK_INFO();
result = TclExprByteCodeFromObj(interp, objPtr, &valuePtr);
CACHE_STACK_INFO();
#endif
if (result != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
O2S(objPtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
stackPtr[++stackTop] = valuePtr; /* already has right refct */
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
TclDecrRefCount(objPtr);
ADJUST_PC(1);
case INST_LOAD_SCALAR1:
#ifdef TCL_COMPILE_DEBUG
opnd = TclGetUInt1AtPtr(pc+1);
DECACHE_STACK_INFO();
valuePtr = TclGetIndexedScalar(interp, opnd,
/*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
#else /* TCL_COMPILE_DEBUG */
DECACHE_STACK_INFO();
opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
#endif /* TCL_COMPILE_DEBUG */
ADJUST_PC(2);
case INST_LOAD_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
DECACHE_STACK_INFO();
valuePtr = TclGetIndexedScalar(interp, opnd,
/*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
ADJUST_PC(5);
case INST_LOAD_SCALAR_STK:
objPtr = POP_OBJECT(); /* scalar name */
DECACHE_STACK_INFO();
valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
TclDecrRefCount(objPtr);
ADJUST_PC(1);
case INST_LOAD_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doLoadArray;
case INST_LOAD_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doLoadArray:
{
Tcl_Obj *elemPtr = POP_OBJECT();
DECACHE_STACK_INFO();
valuePtr = TclGetElementOfIndexedArray(interp, opnd,
elemPtr, /*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("%u \"%.30s\" => ",
opnd, O2S(elemPtr)),valuePtr);
TclDecrRefCount(elemPtr);
}
ADJUST_PC(pcAdjustment);
case INST_LOAD_ARRAY_STK:
{
Tcl_Obj *elemPtr = POP_OBJECT();
objPtr = POP_OBJECT(); /* array name */
DECACHE_STACK_INFO();
valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
O2S(objPtr), O2S(elemPtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
O2S(objPtr), O2S(elemPtr)), valuePtr);
TclDecrRefCount(objPtr);
TclDecrRefCount(elemPtr);
}
ADJUST_PC(1);
case INST_LOAD_STK:
objPtr = POP_OBJECT(); /* variable name */
DECACHE_STACK_INFO();
valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (valuePtr == NULL) {
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
O2S(objPtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(valuePtr);
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
TclDecrRefCount(objPtr);
ADJUST_PC(1);
case INST_STORE_SCALAR4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doStoreScalar;
case INST_STORE_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreScalar:
valuePtr = POP_OBJECT();
DECACHE_STACK_INFO();
value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
/*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
opnd, O2S(valuePtr)), value2Ptr);
TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
case INST_STORE_SCALAR_STK:
valuePtr = POP_OBJECT();
objPtr = POP_OBJECT(); /* scalar name */
DECACHE_STACK_INFO();
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
O2S(objPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
O2S(objPtr), O2S(valuePtr)), value2Ptr);
TclDecrRefCount(objPtr);
TclDecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_STORE_ARRAY4:
opnd = TclGetUInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doStoreArray;
case INST_STORE_ARRAY1:
opnd = TclGetUInt1AtPtr(pc+1);
pcAdjustment = 2;
doStoreArray:
{
Tcl_Obj *elemPtr;
valuePtr = POP_OBJECT();
elemPtr = POP_OBJECT();
DECACHE_STACK_INFO();
value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
opnd, O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
TclDecrRefCount(elemPtr);
TclDecrRefCount(valuePtr);
}
ADJUST_PC(pcAdjustment);
case INST_STORE_ARRAY_STK:
{
Tcl_Obj *elemPtr;
valuePtr = POP_OBJECT();
elemPtr = POP_OBJECT();
objPtr = POP_OBJECT(); /* array name */
DECACHE_STACK_INFO();
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
value2Ptr);
TclDecrRefCount(objPtr);
TclDecrRefCount(elemPtr);
TclDecrRefCount(valuePtr);
}
ADJUST_PC(1);
case INST_STORE_STK:
valuePtr = POP_OBJECT();
objPtr = POP_OBJECT(); /* variable name */
DECACHE_STACK_INFO();
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
O2S(objPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
O2S(objPtr), O2S(valuePtr)), value2Ptr);
TclDecrRefCount(objPtr);
TclDecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_INCR_SCALAR1:
opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = POP_OBJECT();
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
i = valuePtr->internalRep.longValue;
DECACHE_STACK_INFO();
value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
TclDecrRefCount(valuePtr);
ADJUST_PC(2);
case INST_INCR_SCALAR_STK:
case INST_INCR_STK:
valuePtr = POP_OBJECT();
objPtr = POP_OBJECT(); /* scalar name */
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
O2S(objPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
i = valuePtr->internalRep.longValue;
DECACHE_STACK_INFO();
value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
O2S(objPtr), i), Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
value2Ptr);
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
ADJUST_PC(1);
case INST_INCR_ARRAY1:
{
Tcl_Obj *elemPtr;
opnd = TclGetUInt1AtPtr(pc+1);
valuePtr = POP_OBJECT();
elemPtr = POP_OBJECT();
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
opnd, O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
i = valuePtr->internalRep.longValue;
DECACHE_STACK_INFO();
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
elemPtr, i);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
opnd, O2S(elemPtr), i),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
opnd, O2S(elemPtr), i), value2Ptr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
}
ADJUST_PC(2);
case INST_INCR_ARRAY_STK:
{
Tcl_Obj *elemPtr;
valuePtr = POP_OBJECT();
elemPtr = POP_OBJECT();
objPtr = POP_OBJECT(); /* array name */
if (valuePtr->typePtr != &tclIntType) {
result = tclIntType.setFromAnyProc(interp, valuePtr);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
i = valuePtr->internalRep.longValue;
DECACHE_STACK_INFO();
value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
O2S(objPtr), O2S(elemPtr), i),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
O2S(objPtr), O2S(elemPtr), i), value2Ptr);
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
Tcl_DecrRefCount(valuePtr);
}
ADJUST_PC(1);
case INST_INCR_SCALAR1_IMM:
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
DECACHE_STACK_INFO();
value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
Tcl_GetObjResult(interp));
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
ADJUST_PC(3);
case INST_INCR_SCALAR_STK_IMM:
case INST_INCR_STK_IMM:
objPtr = POP_OBJECT(); /* variable name */
i = TclGetInt1AtPtr(pc+1);
DECACHE_STACK_INFO();
value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
O2S(objPtr), i), Tcl_GetObjResult(interp));
result = TCL_ERROR;
Tcl_DecrRefCount(objPtr);
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),
value2Ptr);
TclDecrRefCount(objPtr);
ADJUST_PC(2);
case INST_INCR_ARRAY1_IMM:
{
Tcl_Obj *elemPtr;
opnd = TclGetUInt1AtPtr(pc+1);
i = TclGetInt1AtPtr(pc+2);
elemPtr = POP_OBJECT();
DECACHE_STACK_INFO();
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
elemPtr, i);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
opnd, O2S(elemPtr), i),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
opnd, O2S(elemPtr), i), value2Ptr);
Tcl_DecrRefCount(elemPtr);
}
ADJUST_PC(3);
case INST_INCR_ARRAY_STK_IMM:
{
Tcl_Obj *elemPtr;
i = TclGetInt1AtPtr(pc+1);
elemPtr = POP_OBJECT();
objPtr = POP_OBJECT(); /* array name */
DECACHE_STACK_INFO();
value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
TCL_LEAVE_ERR_MSG);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
O2S(objPtr), O2S(elemPtr), i),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
result = TCL_ERROR;
goto checkForCatch;
}
PUSH_OBJECT(value2Ptr);
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
O2S(objPtr), O2S(elemPtr), i), value2Ptr);
Tcl_DecrRefCount(objPtr);
Tcl_DecrRefCount(elemPtr);
}
ADJUST_PC(2);
case INST_JUMP1:
#ifdef TCL_COMPILE_DEBUG
opnd = TclGetInt1AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
pc += opnd;
#else
pc += TclGetInt1AtPtr(pc+1);
#endif /* TCL_COMPILE_DEBUG */
continue;
case INST_JUMP4:
opnd = TclGetInt4AtPtr(pc+1);
TRACE(("%d => new pc %u\n", opnd,
(unsigned int)(pc + opnd - codePtr->codeStart)));
ADJUST_PC(opnd);
case INST_JUMP_TRUE4:
opnd = TclGetInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doJumpTrue;
case INST_JUMP_TRUE1:
opnd = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doJumpTrue:
{
int b;
valuePtr = POP_OBJECT();
if (valuePtr->typePtr == &tclIntType) {
b = (valuePtr->internalRep.longValue != 0);
} else if (valuePtr->typePtr == &tclDoubleType) {
b = (valuePtr->internalRep.doubleValue != 0.0);
} else {
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
if (b) {
TRACE(("%d => %.20s true, new pc %u\n",
opnd, O2S(valuePtr),
(unsigned int)(pc+opnd - codePtr->codeStart)));
TclDecrRefCount(valuePtr);
ADJUST_PC(opnd);
} else {
TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
}
}
case INST_JUMP_FALSE4:
opnd = TclGetInt4AtPtr(pc+1);
pcAdjustment = 5;
goto doJumpFalse;
case INST_JUMP_FALSE1:
opnd = TclGetInt1AtPtr(pc+1);
pcAdjustment = 2;
doJumpFalse:
{
int b;
valuePtr = POP_OBJECT();
if (valuePtr->typePtr == &tclIntType) {
b = (valuePtr->internalRep.longValue != 0);
} else if (valuePtr->typePtr == &tclDoubleType) {
b = (valuePtr->internalRep.doubleValue != 0.0);
} else {
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
Tcl_GetObjResult(interp));
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
if (b) {
TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
TclDecrRefCount(valuePtr);
ADJUST_PC(pcAdjustment);
} else {
TRACE(("%d => %.20s false, new pc %u\n",
opnd, O2S(valuePtr),
(unsigned int)(pc + opnd - codePtr->codeStart)));
TclDecrRefCount(valuePtr);
ADJUST_PC(opnd);
}
}
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 = POP_OBJECT();
valuePtr = POP_OBJECT();
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
i1 = (valuePtr->internalRep.longValue != 0);
} else if (t1Ptr == &tclDoubleType) {
i1 = (valuePtr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
i1 = (i != 0);
} 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")));
IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
i2 = (value2Ptr->internalRep.longValue != 0);
} else if (t2Ptr == &tclDoubleType) {
i2 = (value2Ptr->internalRep.doubleValue != 0.0);
} else {
s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i);
i2 = (i != 0);
} 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")));
IllegalExprOperandType(interp, pc, value2Ptr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
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)) {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%.20s %.20s => %d\n",
O2S(valuePtr), O2S(value2Ptr), iResult));
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%.20s %.20s => %d\n",
O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
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 = POP_OBJECT();
valuePtr = POP_OBJECT();
t1Ptr = valuePtr->typePtr;
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 == NULL) && (valuePtr->bytes == NULL))
|| (valuePtr->bytes && (valuePtr->length == 0)))
|| (((t2Ptr == NULL) && (value2Ptr->bytes == NULL))
|| (value2Ptr->bytes && (value2Ptr->length == 0))))) {
if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
s1 = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s1, length)) {
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
t1Ptr = valuePtr->typePtr;
}
if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
s2 = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s2, length)) {
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
} else {
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d2);
}
t2Ptr = value2Ptr->typePtr;
}
}
if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType))
|| ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
/*
* One operand is not numeric. Compare as strings.
*/
int cmpValue;
s1 = Tcl_GetString(valuePtr);
s2 = Tcl_GetString(value2Ptr);
cmpValue = strcmp(s1, s2);
switch (*pc) {
case INST_EQ:
iResult = (cmpValue == 0);
break;
case INST_NEQ:
iResult = (cmpValue != 0);
break;
case INST_LT:
iResult = (cmpValue < 0);
break;
case INST_GT:
iResult = (cmpValue > 0);
break;
case INST_LE:
iResult = (cmpValue <= 0);
break;
case INST_GE:
iResult = (cmpValue >= 0);
break;
}
} else if ((t1Ptr == &tclDoubleType)
|| (t2Ptr == &tclDoubleType)) {
/*
* Compare as doubles.
*/
if (t1Ptr == &tclDoubleType) {
d1 = valuePtr->internalRep.doubleValue;
if (t2Ptr == &tclIntType) {
d2 = value2Ptr->internalRep.longValue;
} else {
d2 = value2Ptr->internalRep.doubleValue;
}
} else { /* t1Ptr is int, t2Ptr is double */
d1 = valuePtr->internalRep.longValue;
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 {
/*
* 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;
}
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%.20s %.20s => %ld\n",
O2S(valuePtr), O2S(value2Ptr), iResult));
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%.20s %.20s => %ld\n",
O2S(valuePtr), O2S(value2Ptr), iResult));
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
TclDecrRefCount(value2Ptr);
}
ADJUST_PC(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, rem, negative;
long iResult = 0; /* Init. avoids compiler warning. */
value2Ptr = POP_OBJECT();
valuePtr = POP_OBJECT();
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else { /* try to convert to int */
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
O2S(valuePtr), O2S(value2Ptr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
}
if (value2Ptr->typePtr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
} else {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(valuePtr), O2S(value2Ptr),
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, value2Ptr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
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 (i2 == 0) {
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
negative = 0;
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:
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.
*/
if (i < 0) {
iResult = ~((~i) >> i2);
} else {
iResult = i >> i2;
}
break;
case INST_BITOR:
iResult = i | i2;
break;
case INST_BITXOR:
iResult = i ^ i2;
break;
case INST_BITAND:
iResult = i & i2;
break;
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
++stackTop; /* valuePtr now on stk top has right r.c. */
}
TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
case INST_ADD:
case INST_SUB:
case INST_MULT:
case INST_DIV:
{
/*
* Operands must be numeric and ints get converted to floats
* if necessary. We compute value op value2.
*/
Tcl_ObjType *t1Ptr, *t2Ptr;
long i2, quot, rem;
double d1, d2;
long iResult = 0; /* Init. avoids compiler warning. */
double dResult = 0.0; /* Init. avoids compiler warning. */
int doDouble = 0; /* 1 if doing floating arithmetic */
value2Ptr = POP_OBJECT();
valuePtr = POP_OBJECT();
t1Ptr = valuePtr->typePtr;
t2Ptr = value2Ptr->typePtr;
if (t1Ptr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else if ((t1Ptr == &tclDoubleType)
&& (valuePtr->bytes == NULL)) {
/*
* We can only use the internal rep directly if there is
* no string rep. Otherwise the string rep might actually
* look like an integer, which is preferred.
*/
d1 = valuePtr->internalRep.doubleValue;
} else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d1);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
s, O2S(valuePtr),
(valuePtr->typePtr?
valuePtr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
t1Ptr = valuePtr->typePtr;
}
if (t2Ptr == &tclIntType) {
i2 = value2Ptr->internalRep.longValue;
} else if ((t2Ptr == &tclDoubleType)
&& (value2Ptr->bytes == NULL)) {
/*
* We can only use the internal rep directly if there is
* no string rep. Otherwise the string rep might actually
* look like an integer, which is preferred.
*/
d2 = value2Ptr->internalRep.doubleValue;
} else {
char *s = Tcl_GetStringFromObj(value2Ptr, &length);
if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
value2Ptr, &i2);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
value2Ptr, &d2);
}
if (result != TCL_OK) {
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
O2S(value2Ptr), s,
(value2Ptr->typePtr?
value2Ptr->typePtr->name : "null")));
IllegalExprOperandType(interp, pc, value2Ptr);
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
t2Ptr = value2Ptr->typePtr;
}
if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
/*
* Do double arithmetic.
*/
doDouble = 1;
if (t1Ptr == &tclIntType) {
d1 = i; /* promote value 1 to double */
} else if (t2Ptr == &tclIntType) {
d2 = i2; /* promote value 2 to double */
}
switch (*pc) {
case INST_ADD:
dResult = d1 + d2;
break;
case INST_SUB:
dResult = d1 - d2;
break;
case INST_MULT:
dResult = d1 * d2;
break;
case INST_DIV:
if (d2 == 0.0) {
TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
dResult = d1 / d2;
break;
}
/*
* Check now for IEEE floating-point error.
*/
if (IS_NAN(dResult) || IS_INF(dResult)) {
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
O2S(valuePtr), O2S(value2Ptr)));
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto checkForCatch;
}
} else {
/*
* Do integer arithmetic.
*/
switch (*pc) {
case INST_ADD:
iResult = i + i2;
break;
case INST_SUB:
iResult = i - i2;
break;
case INST_MULT:
iResult = i * i2;
break;
case INST_DIV:
/*
* 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 (i2 == 0) {
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
goto divideByZero;
}
if (i2 < 0) {
i2 = -i2;
i = -i;
}
quot = i / i2;
rem = i % i2;
if (rem < 0) {
quot -= 1;
}
iResult = quot;
break;
}
}
/*
* Reuse the valuePtr object already on stack if possible.
*/
if (Tcl_IsShared(valuePtr)) {
if (doDouble) {
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
} else {
PUSH_OBJECT(Tcl_NewLongObj(iResult));
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
}
TclDecrRefCount(valuePtr);
} else { /* reuse the valuePtr object */
if (doDouble) { /* NB: stack top is off by 1 */
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
Tcl_SetDoubleObj(valuePtr, dResult);
} else {
TRACE(("%ld %ld => %ld\n", i, i2, iResult));
Tcl_SetLongObj(valuePtr, iResult);
}
++stackTop; /* valuePtr now on stk top has right r.c. */
}
TclDecrRefCount(value2Ptr);
}
ADJUST_PC(1);
case INST_UPLUS:
{
/*
* Operand must be numeric.
*/
double d;
Tcl_ObjType *tPtr;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
s, (tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
goto checkForCatch;
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the operand's string rep is the same as the
* formatted version of its internal rep. This makes sure
* that "expr +000123" yields "83", not "000123". We
* implement this by _discarding_ the string rep since we
* know it will be regenerated, if needed later, by
* formatting the internal rep's value.
*/
if (Tcl_IsShared(valuePtr)) {
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objPtr = Tcl_NewLongObj(i);
} else {
d = valuePtr->internalRep.doubleValue;
objPtr = Tcl_NewDoubleObj(d);
}
Tcl_IncrRefCount(objPtr);
Tcl_DecrRefCount(valuePtr);
valuePtr = objPtr;
stackPtr[stackTop] = valuePtr;
} else {
Tcl_InvalidateStringRep(valuePtr);
}
TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
}
ADJUST_PC(1);
case INST_UMINUS:
case INST_LNOT:
{
/*
* The operand must be numeric or a boolean string as
* accepted by Tcl_GetBooleanFromObj(). If the operand
* object is unshared modify it directly, otherwise
* create a copy to modify: this is "copy on write".
* Free any old string representation since it is now
* invalid.
*/
double d;
int boolvar;
Tcl_ObjType *tPtr;
valuePtr = POP_OBJECT();
tPtr = valuePtr->typePtr;
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
if ((tPtr == &tclBooleanType)
&& (valuePtr->bytes == NULL)) {
valuePtr->typePtr = &tclIntType;
} else {
char *s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result == TCL_ERROR && *pc == INST_LNOT) {
result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
valuePtr, &boolvar);
i = (long)boolvar; /* i is long, not int! */
}
if (result != TCL_OK) {
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
s, (tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
tPtr = valuePtr->typePtr;
}
if (Tcl_IsShared(valuePtr)) {
/*
* Create a new object.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
objPtr = Tcl_NewLongObj(
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), objPtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
objPtr = Tcl_NewDoubleObj(-d);
} else {
/*
* Should be able to use "!d", but apparently
* some compilers can't handle it.
*/
objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
}
TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
}
PUSH_OBJECT(objPtr);
TclDecrRefCount(valuePtr);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
i = valuePtr->internalRep.longValue;
Tcl_SetLongObj(valuePtr,
(*pc == INST_UMINUS)? -i : !i);
TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
} else {
d = valuePtr->internalRep.doubleValue;
if (*pc == INST_UMINUS) {
Tcl_SetDoubleObj(valuePtr, -d);
} else {
/*
* Should be able to use "!d", but apparently
* some compilers can't handle it.
*/
Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
}
TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
}
++stackTop; /* valuePtr now on stk top has right r.c. */
}
}
ADJUST_PC(1);
case INST_BITNOT:
{
/*
* The operand must be an integer. If the operand object is
* unshared modify it directly, otherwise modify a copy.
* Free any old string representation since it is now
* invalid.
*/
Tcl_ObjType *tPtr;
valuePtr = POP_OBJECT();
tPtr = valuePtr->typePtr;
if (tPtr != &tclIntType) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
if (result != TCL_OK) { /* try to convert to double */
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
O2S(valuePtr), (tPtr? tPtr->name : "null")));
IllegalExprOperandType(interp, pc, valuePtr);
Tcl_DecrRefCount(valuePtr);
goto checkForCatch;
}
}
i = valuePtr->internalRep.longValue;
if (Tcl_IsShared(valuePtr)) {
PUSH_OBJECT(Tcl_NewLongObj(~i));
TRACE(("0x%lx => (%lu)\n", i, ~i));
TclDecrRefCount(valuePtr);
} else {
/*
* valuePtr is unshared. Modify it directly.
*/
Tcl_SetLongObj(valuePtr, ~i);
++stackTop; /* valuePtr now on stk top has right r.c. */
TRACE(("0x%lx => (%lu)\n", i, ~i));
}
}
ADJUST_PC(1);
case INST_CALL_BUILTIN_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call one of the built-in Tcl math functions.
*/
BuiltinFunc *mathFuncPtr;
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
}
mathFuncPtr = &(builtinFuncTable[opnd]);
DECACHE_STACK_INFO();
tsdPtr->mathInProgress++;
result = (*mathFuncPtr->proc)(interp, eePtr,
mathFuncPtr->clientData);
tsdPtr->mathInProgress--;
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
}
ADJUST_PC(2);
case INST_CALL_FUNC1:
opnd = TclGetUInt1AtPtr(pc+1);
{
/*
* Call a non-builtin Tcl math function previously
* registered by a call to Tcl_CreateMathFunc.
*/
int objc = opnd; /* Number of arguments. The function name
* is the 0-th argument. */
Tcl_Obj **objv; /* The array of arguments. The function
* name is objv[0]. */
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
DECACHE_STACK_INFO();
tsdPtr->mathInProgress++;
result = ExprCallMathFunc(interp, eePtr, objc, objv);
tsdPtr->mathInProgress--;
CACHE_STACK_INFO();
if (result != TCL_OK) {
goto checkForCatch;
}
TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
ADJUST_PC(2);
}
case INST_TRY_CVT_TO_NUMERIC:
{
/*
* Try to convert the topmost stack object to an int or
* double object. This is done in order to support Tcl's
* policy of interpreting operands if at all possible as
* first integers, else floating-point numbers.
*/
double d;
char *s;
Tcl_ObjType *tPtr;
int converted, shared;
valuePtr = stackPtr[stackTop];
tPtr = valuePtr->typePtr;
converted = 0;
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
|| (valuePtr->bytes != NULL))) {
if ((tPtr == &tclBooleanType)
&& (valuePtr->bytes == NULL)) {
valuePtr->typePtr = &tclIntType;
converted = 1;
} else {
s = Tcl_GetStringFromObj(valuePtr, &length);
if (TclLooksLikeInt(s, length)) {
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
valuePtr, &i);
} else {
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
valuePtr, &d);
}
if (result == TCL_OK) {
converted = 1;
}
result = TCL_OK; /* reset the result variable */
}
tPtr = valuePtr->typePtr;
}
/*
* Ensure that the topmost stack object, if numeric, has a
* string rep the same as the formatted version of its
* internal rep. This is used, e.g., to make sure that "expr
* {0001}" yields "1", not "0001". We implement this by
* _discarding_ the string rep since we know it will be
* regenerated, if needed later, by formatting the internal
* rep's value. Also check if there has been an IEEE
* floating point error.
*/
if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) {
shared = 0;
if (Tcl_IsShared(valuePtr)) {
shared = 1;
if (valuePtr->bytes != NULL) {
/*
* We only need to make a copy of the object
* when it already had a string rep
*/
if (tPtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
objPtr = Tcl_NewLongObj(i);
} else {
d = valuePtr->internalRep.doubleValue;
objPtr = Tcl_NewDoubleObj(d);
}
Tcl_IncrRefCount(objPtr);
TclDecrRefCount(valuePtr);
valuePtr = objPtr;
stackPtr[stackTop] = valuePtr;
tPtr = valuePtr->typePtr;
}
} else {
Tcl_InvalidateStringRep(valuePtr);
}
if (tPtr == &tclDoubleType) {
d = valuePtr->internalRep.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
O2S(valuePtr)));
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto checkForCatch;
}
}
shared = shared; /* lint, shared not used. */
converted = converted; /* lint, converted not used. */
TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
(converted? "converted" : "not converted"),
(shared? "shared" : "not shared")));
} else {
TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
}
}
ADJUST_PC(1);
case INST_BREAK:
/*
* First reset the interpreter's result. Then find the closest
* enclosing loop or catch exception range, if any. If a loop is
* found, terminate its execution. If the closest is a catch
* exception range, jump to its catchOffset. If no enclosing
* range is found, stop execution and return TCL_BREAK.
*/
Tcl_ResetResult(interp);
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
result = TCL_BREAK;
goto abnormalReturn; /* no catch exists to check */
}
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
result = TCL_OK;
TRACE(("=> range at %d, new pc %d\n",
rangePtr->codeOffset, rangePtr->breakOffset));
break;
case CATCH_EXCEPTION_RANGE:
result = TCL_BREAK;
TRACE(("=> ...\n"));
goto processCatch; /* it will use rangePtr */
default:
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
}
pc = (codePtr->codeStart + rangePtr->breakOffset);
continue; /* restart outer instruction loop at pc */
case INST_CONTINUE:
/*
* Find the closest enclosing loop or catch exception range,
* if any. If a loop is found, skip to its next iteration.
* If the closest is a catch exception range, jump to its
* catchOffset. If no enclosing range is found, stop
* execution and return TCL_CONTINUE.
*/
Tcl_ResetResult(interp);
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
if (rangePtr == NULL) {
TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
result = TCL_CONTINUE;
goto abnormalReturn;
}
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
if (rangePtr->continueOffset == -1) {
TRACE(("=> loop w/o continue, checking for catch\n"));
goto checkForCatch;
} else {
result = TCL_OK;
TRACE(("=> range at %d, new pc %d\n",
rangePtr->codeOffset, rangePtr->continueOffset));
}
break;
case CATCH_EXCEPTION_RANGE:
result = TCL_CONTINUE;
TRACE(("=> ...\n"));
goto processCatch; /* it will use rangePtr */
default:
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
}
pc = (codePtr->codeStart + rangePtr->continueOffset);
continue; /* restart outer instruction loop at pc */
case INST_FOREACH_START4:
opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* Initialize the temporary local var that holds the count
* of the number of iterations of the loop body to -1.
*/
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
int iterTmpIndex = infoPtr->loopCtTemp;
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
if (oldValuePtr == NULL) {
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
} else {
Tcl_SetLongObj(oldValuePtr, -1);
}
TclSetVarScalar(iterVarPtr);
TclClearVarUndefined(iterVarPtr);
TRACE(("%u => loop iter count temp %d\n",
opnd, iterTmpIndex));
}
ADJUST_PC(5);
case INST_FOREACH_STEP4:
opnd = TclGetUInt4AtPtr(pc+1);
{
/*
* "Step" a foreach loop (i.e., begin its next iteration) by
* assigning the next value list element to each loop var.
*/
ForeachInfo *infoPtr = (ForeachInfo *)
codePtr->auxDataArrayPtr[opnd].clientData;
ForeachVarList *varListPtr;
int numLists = infoPtr->numLists;
Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
Tcl_Obj *listPtr;
List *listRepPtr;
Var *iterVarPtr, *listVarPtr;
int iterNum, listTmpIndex, listLen, numVars;
int varIndex, valIndex, continueLoop, j;
/*
* Increment the temp holding the loop iteration number.
*/
iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
valuePtr = iterVarPtr->value.objPtr;
iterNum = (valuePtr->internalRep.longValue + 1);
Tcl_SetLongObj(valuePtr, iterNum);
/*
* Check whether all value lists are exhausted and we should
* stop the loop.
*/
continueLoop = 0;
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
result = Tcl_ListObjLength(interp, listPtr, &listLen);
if (result != TCL_OK) {
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
opnd, i, O2S(listPtr)),
Tcl_GetObjResult(interp));
goto checkForCatch;
}
if (listLen > (iterNum * numVars)) {
continueLoop = 1;
}
listTmpIndex++;
}
/*
* If some var in some var list still has a remaining list
* element iterate one more time. Assign to var the next
* element from its value list. We already checked above
* that each list temp holds a valid list object.
*/
if (continueLoop) {
listTmpIndex = infoPtr->firstValueTemp;
for (i = 0; i < numLists; i++) {
varListPtr = infoPtr->varLists[i];
numVars = varListPtr->numVars;
listVarPtr = &(compiledLocals[listTmpIndex]);
listPtr = listVarPtr->value.objPtr;
listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
listLen = listRepPtr->elemCount;
valIndex = (iterNum * numVars);
for (j = 0; j < numVars; j++) {
int setEmptyStr = 0;
if (valIndex >= listLen) {
setEmptyStr = 1;
valuePtr = Tcl_NewObj();
} else {
valuePtr = listRepPtr->elements[valIndex];
}
varIndex = varListPtr->varIndexes[j];
DECACHE_STACK_INFO();
value2Ptr = TclSetIndexedScalar(interp,
varIndex, valuePtr, /*leaveErrorMsg*/ 1);
CACHE_STACK_INFO();
if (value2Ptr == NULL) {
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
opnd, varIndex),
Tcl_GetObjResult(interp));
if (setEmptyStr) {
Tcl_DecrRefCount(valuePtr);
}
result = TCL_ERROR;
goto checkForCatch;
}
valIndex++;
}
listTmpIndex++;
}
}
/*
* Push 1 if at least one value list had a remaining element
* and the loop should continue. Otherwise push 0.
*/
PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
TRACE(("%u => %d lists, iter %d, %s loop\n",
opnd, numLists, iterNum,
(continueLoop? "continue" : "exit")));
}
ADJUST_PC(5);
case INST_BEGIN_CATCH4:
/*
* Record start of the catch command with exception range index
* equal to the operand. Push the current stack depth onto the
* special catch stack.
*/
catchStackPtr[++catchTop] = stackTop;
TRACE(("%u => catchTop=%d, stackTop=%d\n",
TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
ADJUST_PC(5);
case INST_END_CATCH:
catchTop--;
result = TCL_OK;
TRACE(("=> catchTop=%d\n", catchTop));
ADJUST_PC(1);
case INST_PUSH_RESULT:
PUSH_OBJECT(Tcl_GetObjResult(interp));
TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
ADJUST_PC(1);
case INST_PUSH_RETURN_CODE:
PUSH_OBJECT(Tcl_NewLongObj(result));
TRACE(("=> %u\n", result));
ADJUST_PC(1);
default:
panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
} /* end of switch on opCode */
/*
* Division by zero in an expression. Control only reaches this
* point by "goto divideByZero".
*/
divideByZero:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
(char *) NULL);
result = TCL_ERROR;
/*
* Execution has generated an "exception" such as TCL_ERROR. If the
* exception is an error, record information about what was being
* executed when the error occurred. Find the closest enclosing
* catch range, if any. If no enclosing catch range is found, stop
* execution and return the "exception" code.
*/
checkForCatch:
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
bytes = GetSrcInfoForPc(pc, codePtr, &length);
if (bytes != NULL) {
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
iPtr->flags |= ERR_ALREADY_LOGGED;
}
}
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
if (rangePtr == NULL) {
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... no enclosing catch, returning %s\n",
StringForResultCode(result));
}
#endif
goto abnormalReturn;
}
/*
* A catch exception range (rangePtr) was found to handle an
* "exception". It was found either by checkForCatch just above or
* by an instruction during break, continue, or error processing.
* Jump to its catchOffset after unwinding the operand stack to
* the depth it had when starting to execute the range's catch
* command.
*/
processCatch:
while (stackTop > catchStackPtr[catchTop]) {
valuePtr = POP_OBJECT();
TclDecrRefCount(valuePtr);
}
#ifdef TCL_COMPILE_DEBUG
if (traceInstructions) {
fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
(unsigned int)(rangePtr->catchOffset));
}
#endif
pc = (codePtr->codeStart + rangePtr->catchOffset);
continue; /* restart the execution loop at pc */
} /* end of infinite loop dispatching on instructions */
/*
* Abnormal return code. Restore the stack to state it had when starting
* to execute the ByteCode.
*/
abnormalReturn:
while (stackTop > initStackTop) {
valuePtr = POP_OBJECT();
Tcl_DecrRefCount(valuePtr);
}
/*
* Free the catch stack array if malloc'ed storage was used.
*/
done:
stackTop -= codePtr->maxExceptDepth;
#if TCL_NO_RECURSE
if (currentDepth--) {
/*
* An internal return
*/
int retCode = (int) stackPtr[stackTop--];
switch (retCode) {
case 0: goto returnFromPROC;
case 1: goto returnFromEVAL;
case 2: goto returnFromEXPR;
default:
fprintf(stderr, "ERROR: Internal return code is %i: this should never happen!\n", retCode );
panic("FATAL ERROR");
}
}
#endif
/*
* A real return
*/
eePtr->stackTop = stackTop;
return result;
}
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* PrintByteCodeInfo --
*
* This procedure prints a summary about a bytecode object to stdout.
* It is called by TclExecuteByteCode when starting to execute the
* bytecode object if tclTraceExec has the value 2 or more.
*
* Results:
* None.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static void
PrintByteCodeInfo(codePtr)
register ByteCode *codePtr; /* The bytecode whose summary is printed
* to stdout. */
{
Proc *procPtr = codePtr->procPtr;
Interp *iPtr = (Interp *) *codePtr->interpHandle;
fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
(unsigned int) codePtr, codePtr->refCount,
codePtr->compileEpoch, (unsigned int) iPtr,
iPtr->compileEpoch);
fprintf(stdout, " Source: ");
TclPrintSource(stdout, codePtr->source, 60);
fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
codePtr->numCommands, codePtr->numSrcBytes,
codePtr->numCodeBytes, codePtr->numLitObjects,
codePtr->numAuxDataItems, codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
(codePtr->numSrcBytes?
((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
#else
0.0);
#endif
#ifdef TCL_COMPILE_STATS
fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
codePtr->structureSize,
(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
codePtr->numCodeBytes,
(codePtr->numLitObjects * sizeof(Tcl_Obj *)),
(codePtr->numExceptRanges * sizeof(ExceptionRange)),
(codePtr->numAuxDataItems * sizeof(AuxData)),
codePtr->numCmdLocBytes);
#endif /* TCL_COMPILE_STATS */
if (procPtr != NULL) {
fprintf(stdout,
" Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
(unsigned int) procPtr, procPtr->refCount,
procPtr->numArgs, procPtr->numCompiledLocals);
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* ValidatePcAndStackTop --
*
* This procedure is called by TclExecuteByteCode when debugging to
* verify that the program counter and stack top are valid during
* execution.
*
* Results:
* None.
*
* Side effects:
* Prints a message to stderr and panics if either the pc or stack
* top are invalid.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
static void
ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound,
stackUpperBound)
register ByteCode *codePtr; /* The bytecode whose summary is printed
* to stdout. */
unsigned char *pc; /* Points to first byte of a bytecode
* instruction. The program counter. */
int stackTop; /* Current stack top. Must be between
* stackLowerBound and stackUpperBound
* (inclusive). */
int stackLowerBound; /* Smallest legal value for stackTop. */
int stackUpperBound; /* Greatest legal value for stackTop. */
{
unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
unsigned int codeStart = (unsigned int) codePtr->codeStart;
unsigned int codeEnd = (unsigned int)
(codePtr->codeStart + codePtr->numCodeBytes);
unsigned char opCode = *pc;
if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
(unsigned int) pc);
panic("TclExecuteByteCode execution failure: bad pc");
}
if ((unsigned int) opCode > LAST_INST_OPCODE) {
fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
(unsigned int) opCode, relativePc);
panic("TclExecuteByteCode execution failure: bad opcode");
}
if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
int numChars;
char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
char *ellipsis = "";
fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
stackTop, relativePc);
if (cmd != NULL) {
if (numChars > 100) {
numChars = 100;
ellipsis = "...";
}
fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
ellipsis);
} else {
fprintf(stderr, "\n");
}
panic("TclExecuteByteCode execution failure: bad stack top");
}
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* IllegalExprOperandType --
*
* Used by TclExecuteByteCode to add an error message to errorInfo
* when an illegal operand type is detected by an expression
* instruction. The argument opndPtr holds the operand object in error.
*
* Results:
* None.
*
* Side effects:
* An error message is appended to errorInfo.
*
*----------------------------------------------------------------------
*/
static void
IllegalExprOperandType(interp, pc, opndPtr)
Tcl_Interp *interp; /* Interpreter to which error information
* pertains. */
unsigned char *pc; /* Points to the instruction being executed
* when the illegal type was found. */
Tcl_Obj *opndPtr; /* Points to the operand holding the value
* with the illegal type. */
{
unsigned char opCode = *pc;
Tcl_ResetResult(interp);
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use empty string as operand of \"",
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
} else {
char *msg = "non-numeric string";
if (opndPtr->typePtr != &tclDoubleType) {
/*
* See if the operand can be interpreted as a double in order to
* improve the error message.
*/
char *s = Tcl_GetString(opndPtr);
double d;
if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
/*
* Make sure that what appears to be a double
* (ie 08) isn't really a bad octal
*/
if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) {
msg = "invalid octal number";
} else {
msg = "floating-point value";
}
}
}
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
"\"", (char *) NULL);
}
}
/*
*----------------------------------------------------------------------
*
* CallTraceProcedure --
*
* Invokes a trace procedure registered with an interpreter. These
* procedures trace command execution. Currently this trace procedure
* is called with the address of the string-based Tcl_CmdProc for the
* command, not the Tcl_ObjCmdProc.
*
* Results:
* None.
*
* Side effects:
* Those side effects made by the trace procedure.
*
*----------------------------------------------------------------------
*/
static void
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
Tcl_Interp *interp; /* The current interpreter. */
register Trace *tracePtr; /* Describes the trace procedure to call. */
Command *cmdPtr; /* Points to command's Command struct. */
char *command; /* Points to the first character of the
* command's source before substitutions. */
int numChars; /* The number of characters in the
* command's source. */
register int objc; /* Number of arguments for the command. */
Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */
{
Interp *iPtr = (Interp *) interp;
register char **argv;
register int i;
int length;
char *p;
/*
* Get the string rep from the objv argument objects and place their
* pointers in argv. First make sure argv is large enough to hold the
* objc args plus 1 extra word for the zero end-of-argv word.
*/
argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
for (i = 0; i < objc; i++) {
argv[i] = Tcl_GetStringFromObj(objv[i], &length);
}
argv[objc] = 0;
/*
* Copy the command characters into a new string.
*/
p = (char *) ckalloc((unsigned) (numChars + 1));
memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
p[numChars] = '\0';
/*
* Call the trace procedure then free allocated storage.
*/
(*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
ckfree((char *) argv);
ckfree((char *) p);
}
/*
*----------------------------------------------------------------------
*
* GetSrcInfoForPc --
*
* Given a program counter value, finds the closest command in the
* bytecode code unit's CmdLocation array and returns information about
* that command's source: a pointer to its first byte and the number of
* characters.
*
* Results:
* If a command is found that encloses the program counter value, a
* pointer to the command's source is returned and the length of the
* source is stored at *lengthPtr. If multiple commands resulted in
* code at pc, information about the closest enclosing command is
* returned. If no matching command is found, NULL is returned and
* *lengthPtr is unchanged.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static char *
GetSrcInfoForPc(pc, codePtr, lengthPtr)
unsigned char *pc; /* The program counter value for which to
* return the closest command's source info.
* This points to a bytecode instruction
* in codePtr's code. */
ByteCode *codePtr; /* The bytecode sequence in which to look
* up the command source for the pc. */
int *lengthPtr; /* If non-NULL, the location where the
* length of the command's source should be
* stored. If NULL, no length is stored. */
{
register int pcOffset = (pc - codePtr->codeStart);
int numCmds = codePtr->numCommands;
unsigned char *codeDeltaNext, *codeLengthNext;
unsigned char *srcDeltaNext, *srcLengthNext;
int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
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. */
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
return NULL;
}
/*
* Decode the code and source offset and length for each command. The
* closest enclosing command is the last one whose code started before
* pcOffset.
*/
codeDeltaNext = codePtr->codeDeltaStart;
codeLengthNext = codePtr->codeLengthStart;
srcDeltaNext = codePtr->srcDeltaStart;
srcLengthNext = codePtr->srcLengthStart;
codeOffset = srcOffset = 0;
for (i = 0; i < numCmds; i++) {
if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(codeDeltaNext);
codeDeltaNext++;
}
codeOffset += delta;
if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
codeLengthNext++;
codeLen = TclGetInt4AtPtr(codeLengthNext);
codeLengthNext += 4;
} else {
codeLen = TclGetInt1AtPtr(codeLengthNext);
codeLengthNext++;
}
codeEnd = (codeOffset + codeLen - 1);
if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
} else {
delta = TclGetInt1AtPtr(srcDeltaNext);
srcDeltaNext++;
}
srcOffset += delta;
if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
} else {
srcLen = TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;
}
if (codeOffset > pcOffset) { /* best cmd already found */
break;
} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
int dist = (pcOffset - codeOffset);
if (dist <= bestDist) {
bestDist = dist;
bestSrcOffset = srcOffset;
bestSrcLength = srcLen;
}
}
}
if (bestDist == INT_MAX) {
return NULL;
}
if (lengthPtr != NULL) {
*lengthPtr = bestSrcLength;
}
return (codePtr->source + bestSrcOffset);
}
/*
*----------------------------------------------------------------------
*
* GetExceptRangeForPc --
*
* Given a program counter value, return the closest enclosing
* ExceptionRange.
*
* Results:
* In the normal case, catchOnly is 0 (false) and this procedure
* returns a pointer to the most closely enclosing ExceptionRange
* structure regardless of whether it is a loop or catch exception
* range. This is appropriate when processing a TCL_BREAK or
* TCL_CONTINUE, which will be "handled" either by a loop exception
* range or a closer catch range. If catchOnly is nonzero, this
* procedure ignores loop exception ranges and returns a pointer to the
* closest catch range. If no matching ExceptionRange is found that
* encloses pc, a NULL is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static ExceptionRange *
GetExceptRangeForPc(pc, catchOnly, codePtr)
unsigned char *pc; /* The program counter value for which to
* search for a closest enclosing exception
* range. This points to a bytecode
* instruction in codePtr's code. */
int catchOnly; /* If 0, consider either loop or catch
* ExceptionRanges in search. If nonzero
* consider only catch ranges (and ignore
* any closer loop ranges). */
ByteCode* codePtr; /* Points to the ByteCode in which to search
* for the enclosing ExceptionRange. */
{
ExceptionRange *rangeArrayPtr;
int numRanges = codePtr->numExceptRanges;
register ExceptionRange *rangePtr;
int pcOffset = (pc - codePtr->codeStart);
register int i, level;
if (numRanges == 0) {
return NULL;
}
rangeArrayPtr = codePtr->exceptArrayPtr;
for (level = codePtr->maxExceptDepth; level >= 0; level--) {
for (i = 0; i < numRanges; i++) {
rangePtr = &(rangeArrayPtr[i]);
if (rangePtr->nestingLevel == level) {
int start = rangePtr->codeOffset;
int end = (start + rangePtr->numCodeBytes);
if ((start <= pcOffset) && (pcOffset < end)) {
if ((!catchOnly)
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
return rangePtr;
}
}
}
}
}
return NULL;
}
/*
*----------------------------------------------------------------------
*
* GetOpcodeName --
*
* This procedure is called by the TRACE and TRACE_WITH_OBJ macros
* used in TclExecuteByteCode when debugging. It returns the name of
* the bytecode instruction at a specified instruction pc.
*
* Results:
* A character string for the instruction.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
#ifdef TCL_COMPILE_DEBUG
static char *
GetOpcodeName(pc)
unsigned char *pc; /* Points to the instruction whose name
* should be returned. */
{
unsigned char opCode = *pc;
return instructionTable[opCode].name;
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* VerifyExprObjType --
*
* This procedure is called by the math functions to verify that
* the object is either an int or double, coercing it if necessary.
* If an error occurs during conversion, an error message is left
* in the interpreter's result unless "interp" is NULL.
*
* Results:
* TCL_OK if it was int or double, TCL_ERROR otherwise
*
* Side effects:
* objPtr is ensured to be either tclIntType of tclDoubleType.
*
*----------------------------------------------------------------------
*/
static int
VerifyExprObjType(interp, objPtr)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
Tcl_Obj *objPtr; /* Points to the object to type check. */
{
if ((objPtr->typePtr == &tclIntType) ||
(objPtr->typePtr == &tclDoubleType)) {
return TCL_OK;
} else {
int length, result = TCL_OK;
char *s = Tcl_GetStringFromObj(objPtr, &length);
if (TclLooksLikeInt(s, length)) {
long i;
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i);
} else {
double d;
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
}
if ((result != TCL_OK) && (interp != NULL)) {
Tcl_ResetResult(interp);
if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"argument to math function was an invalid octal number",
-1);
} else {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"argument to math function didn't have numeric value",
-1);
}
}
return result;
}
}
/*
*----------------------------------------------------------------------
*
* Math Functions --
*
* This page contains the procedures that implement all of the
* built-in math functions for expressions.
*
* Results:
* Each procedure returns TCL_OK if it succeeds and pushes an
* Tcl object holding the result. If it fails it returns TCL_ERROR
* and leaves an error message in the interpreter's result.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
ExprUnaryFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Contains the address of a procedure that
* takes one double argument and returns a
* double result. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
double d, dResult;
int result;
double (*func) _ANSI_ARGS_((double)) =
(double (*)_ANSI_ARGS_((double))) clientData;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the function's argument from the evaluation stack. Convert it
* to a double if necessary.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
d = (double) valuePtr->internalRep.longValue;
} else {
d = valuePtr->internalRep.doubleValue;
}
errno = 0;
dResult = (*func)(d);
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object holding the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprBinaryFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Contains the address of a procedure that
* takes two double arguments and
* returns a double result. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr, *value2Ptr;
double d1, d2, dResult;
int result;
double (*func) _ANSI_ARGS_((double, double))
= (double (*)_ANSI_ARGS_((double, double))) clientData;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the function's two arguments from the evaluation stack. Convert
* them to doubles if necessary.
*/
value2Ptr = POP_OBJECT();
valuePtr = POP_OBJECT();
if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
(VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
d1 = (double) valuePtr->internalRep.longValue;
} else {
d1 = valuePtr->internalRep.doubleValue;
}
if (value2Ptr->typePtr == &tclIntType) {
d2 = (double) value2Ptr->internalRep.longValue;
} else {
d2 = value2Ptr->internalRep.doubleValue;
}
errno = 0;
dResult = (*func)(d1, d2);
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object holding the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
Tcl_DecrRefCount(valuePtr);
Tcl_DecrRefCount(value2Ptr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprAbsFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
long i, iResult;
double d, dResult;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
/*
* Push a Tcl object with the result.
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (i < 0) {
iResult = -i;
if (iResult < 0) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
iResult = i;
}
PUSH_OBJECT(Tcl_NewLongObj(iResult));
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
dResult = -d;
} else {
dResult = d;
}
if (IS_NAN(dResult) || IS_INF(dResult)) {
TclExprFloatError(interp, dResult);
result = TCL_ERROR;
goto done;
}
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
}
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprDoubleFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
double dResult;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
dResult = (double) valuePtr->internalRep.longValue;
} else {
dResult = valuePtr->internalRep.doubleValue;
}
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprIntFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
register Tcl_Obj *valuePtr;
long iResult;
double d;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
iResult = valuePtr->internalRep.longValue;
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
if (d < (double) (long) LONG_MIN) {
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent", (char *) NULL);
result = TCL_ERROR;
goto done;
}
} else {
if (d > (double) LONG_MAX) {
goto tooLarge;
}
}
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
iResult = (long) d;
}
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewLongObj(iResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprRandFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
double dResult;
long tmp; /* Algorithm assumes at least 32 bits.
* Only long guarantees that. See below. */
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = TclpGetClicks();
/*
* Make sure 1 <= randSeed <= (2^31) - 2. See below.
*/
iPtr->randSeed &= (unsigned long) 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
}
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Generate the random number using the linear congruential
* generator defined by the following recurrence:
* seed = ( IA * seed ) mod IM
* where IA is 16807 and IM is (2^31) - 1. The recurrence maps
* a seed in the range [1, IM - 1] to a new seed in that same range.
* The recurrence maps IM to 0, and maps 0 back to 0, so those two
* values must not be allowed as initial values of seed.
*
* In order to avoid potential problems with integer overflow, the
* recurrence is implemented in terms of additional constants
* IQ and IR such that
* IM = IA*IQ + IR
* None of the operations in the implementation overflows a 32-bit
* signed integer, and the C type long is guaranteed to be at least
* 32 bits wide.
*
* For more details on how this algorithm works, refer to the following
* papers:
*
* S.K. Park & K.W. Miller, "Random number generators: good ones
* are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
*
* W.H. Press & S.A. Teukolsky, "Portable random number
* generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
*/
#define RAND_IA 16807
#define RAND_IM 2147483647
#define RAND_IQ 127773
#define RAND_IR 2836
#define RAND_MASK 123459876
tmp = iPtr->randSeed/RAND_IQ;
iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
if (iPtr->randSeed < 0) {
iPtr->randSeed += RAND_IM;
}
/*
* Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
* dividing by RAND_IM yields a double in the range (0, 1).
*/
dResult = iPtr->randSeed * (1.0/RAND_IM);
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
DECACHE_STACK_INFO();
return TCL_OK;
}
static int
ExprRoundFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Tcl_Obj *valuePtr;
long iResult;
double d, temp;
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
result = TCL_OK;
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
if (valuePtr->typePtr == &tclIntType) {
iResult = valuePtr->internalRep.longValue;
} else {
d = valuePtr->internalRep.doubleValue;
if (d < 0.0) {
if (d <= (((double) (long) LONG_MIN) - 0.5)) {
tooLarge:
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"integer value too large to represent", -1);
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
"integer value too large to represent",
(char *) NULL);
result = TCL_ERROR;
goto done;
}
temp = (long) (d - 0.5);
} else {
if (d >= (((double) LONG_MAX + 0.5))) {
goto tooLarge;
}
temp = (long) (d + 0.5);
}
if (IS_NAN(temp) || IS_INF(temp)) {
TclExprFloatError(interp, temp);
result = TCL_ERROR;
goto done;
}
iResult = (long) temp;
}
/*
* Push a Tcl object with the result.
*/
PUSH_OBJECT(Tcl_NewLongObj(iResult));
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return result;
}
static int
ExprSrandFunc(interp, eePtr, clientData)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
ClientData clientData; /* Ignored. */
{
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
Interp *iPtr = (Interp *) interp;
Tcl_Obj *valuePtr;
long i = 0; /* Initialized to avoid compiler warning. */
int result;
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Pop the argument from the evaluation stack. Use the value
* to reset the random number seed.
*/
valuePtr = POP_OBJECT();
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto badValue;
}
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
} else {
/*
* At this point, the only other possible type is double
*/
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"can't use floating-point value as argument to srand",
(char *) NULL);
badValue:
Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
return TCL_ERROR;
}
/*
* Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
* See comments in ExprRandFunc() for more details.
*/
iPtr->flags |= RAND_SEED_INITIALIZED;
iPtr->randSeed = i;
iPtr->randSeed &= (unsigned long) 0x7fffffff;
if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
iPtr->randSeed ^= 123459876;
}
/*
* To avoid duplicating the random number generation code we simply
* clean up our state and call the real random number function. That
* function will always succeed.
*/
Tcl_DecrRefCount(valuePtr);
DECACHE_STACK_INFO();
ExprRandFunc(interp, eePtr, clientData);
return TCL_OK;
}
/*
*----------------------------------------------------------------------
*
* ExprCallMathFunc --
*
* This procedure is invoked to call a non-builtin math function
* during the execution of an expression.
*
* Results:
* TCL_OK is returned if all went well and the function's value
* was computed successfully. If an error occurred, TCL_ERROR
* is returned and an error message is left in the interpreter's
* result. After a successful return this procedure pushes a Tcl object
* holding the result.
*
* Side effects:
* None, unless the called math function has side effects.
*
*----------------------------------------------------------------------
*/
static int
ExprCallMathFunc(interp, eePtr, objc, objv)
Tcl_Interp *interp; /* The interpreter in which to execute the
* function. */
ExecEnv *eePtr; /* Points to the environment for executing
* the function. */
int objc; /* Number of arguments. The function name is
* the 0-th argument. */
Tcl_Obj **objv; /* The array of arguments. The function name
* is objv[0]. */
{
Interp *iPtr = (Interp *) interp;
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
register int stackTop; /* Cached top index of evaluation stack. */
char *funcName;
Tcl_HashEntry *hPtr;
MathFunc *mathFuncPtr; /* Information about math function. */
Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
register Tcl_Obj *valuePtr;
long i;
double d;
int j, k, result;
ThreadSpecificData *tsdPtr;
tsdPtr = TCL_TSD_INIT(&dataKey);
Tcl_ResetResult(interp);
/*
* Set stackPtr and stackTop from eePtr.
*/
CACHE_STACK_INFO();
/*
* Look up the MathFunc record for the function.
*/
funcName = Tcl_GetString(objv[0]);
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
if (hPtr == NULL) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"unknown math function \"", funcName, "\"", (char *) NULL);
result = TCL_ERROR;
goto done;
}
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
if (mathFuncPtr->numArgs != (objc-1)) {
panic("ExprCallMathFunc: expected number of args %d != actual number %d",
mathFuncPtr->numArgs, objc);
result = TCL_ERROR;
goto done;
}
/*
* Collect the arguments for the function, if there are any, into the
* array "args". Note that args[0] will have the Tcl_Value that
* corresponds to objv[1].
*/
for (j = 1, k = 0; j < objc; j++, k++) {
valuePtr = objv[j];
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
result = TCL_ERROR;
goto done;
}
/*
* Copy the object's numeric value to the argument record,
* converting it if necessary.
*/
if (valuePtr->typePtr == &tclIntType) {
i = valuePtr->internalRep.longValue;
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = i;
} else {
args[k].type = TCL_INT;
args[k].intValue = i;
}
} else {
d = valuePtr->internalRep.doubleValue;
if (mathFuncPtr->argTypes[k] == TCL_INT) {
args[k].type = TCL_INT;
args[k].intValue = (long) d;
} else {
args[k].type = TCL_DOUBLE;
args[k].doubleValue = d;
}
}
}
/*
* Invoke the function and copy its result back into valuePtr.
*/
tsdPtr->mathInProgress++;
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
&funcResult);
tsdPtr->mathInProgress--;
if (result != TCL_OK) {
goto done;
}
/*
* Pop the objc top stack elements and decrement their ref counts.
*/
i = (stackTop - (objc-1));
while (i <= stackTop) {
valuePtr = stackPtr[i];
Tcl_DecrRefCount(valuePtr);
i++;
}
stackTop -= objc;
/*
* Push the call's object result.
*/
if (funcResult.type == TCL_INT) {
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
} else {
d = funcResult.doubleValue;
if (IS_NAN(d) || IS_INF(d)) {
TclExprFloatError(interp, d);
result = TCL_ERROR;
goto done;
}
PUSH_OBJECT(Tcl_NewDoubleObj(d));
}
/*
* Reflect the change to stackTop back in eePtr.
*/
done:
DECACHE_STACK_INFO();
return result;
}
/*
*----------------------------------------------------------------------
*
* TclExprFloatError --
*
* This procedure is called when an error occurs during a
* floating-point operation. It reads errno and sets
* interp->objResultPtr accordingly.
*
* Results:
* interp->objResultPtr is set to hold an error message.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
void
TclExprFloatError(interp, value)
Tcl_Interp *interp; /* Where to store error message. */
double value; /* Value returned after error; used to
* distinguish underflows from overflows. */
{
char *s;
Tcl_ResetResult(interp);
if ((errno == EDOM) || (value != value)) {
s = "domain error: argument not in valid range";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
} else if ((errno == ERANGE) || IS_INF(value)) {
if (value == 0.0) {
s = "floating-point value too small to represent";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
} else {
s = "floating-point value too large to represent";
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
}
} else {
char msg[64 + TCL_INTEGER_SPACE];
sprintf(msg, "unknown floating-point error, errno = %d", errno);
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
}
}
/*
*----------------------------------------------------------------------
*
* TclMathInProgress --
*
* This procedure is called to find out if Tcl is doing math
* in this thread.
*
* Results:
* 0 or 1.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclMathInProgress()
{
ThreadSpecificData *tsdPtr;
tsdPtr = TCL_TSD_INIT(&dataKey);
return tsdPtr->mathInProgress;
}
#ifdef TCL_COMPILE_STATS
/*
*----------------------------------------------------------------------
*
* TclLog2 --
*
* Procedure used while collecting compilation statistics to determine
* the log base 2 of an integer.
*
* Results:
* Returns the log base 2 of the operand. If the argument is less
* than or equal to zero, a zero is returned.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
int
TclLog2(value)
register int value; /* The integer for which to compute the
* log base 2. */
{
register int n = value;
register int result = 0;
while (n > 1) {
n = n >> 1;
result++;
}
return result;
}
/*
*----------------------------------------------------------------------
*
* EvalStatsCmd --
*
* Implements the "evalstats" command that prints instruction execution
* counts to stdout.
*
* Results:
* Standard Tcl results.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static int
EvalStatsCmd(unused, interp, argc, argv)
ClientData unused; /* Unused. */
Tcl_Interp *interp; /* The current interpreter. */
int argc; /* The number of arguments. */
char **argv; /* The argument strings. */
{
Interp *iPtr = (Interp *) interp;
LiteralTable *globalTablePtr = &(iPtr->literalTable);
ByteCodeStats *statsPtr = &(iPtr->stats);
double totalCodeBytes, currentCodeBytes;
double totalLiteralBytes, currentLiteralBytes;
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
double strBytesSharedMultX, strBytesSharedOnce;
double numInstructions, currentHeaderBytes;
long numCurrentByteCodes, numByteCodeLits;
long refCountSum, literalMgmtBytes, sum;
int numSharedMultX, numSharedOnce;
int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
char *litTableStats;
LiteralEntry *entryPtr;
numInstructions = 0.0;
for (i = 0; i < 256; i++) {
if (statsPtr->instructionCount[i] != 0) {
numInstructions += statsPtr->instructionCount[i];
}
}
totalLiteralBytes = sizeof(LiteralTable)
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
+ (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
+ statsPtr->totalLitStringBytes;
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
numCurrentByteCodes =
statsPtr->numCompilations - statsPtr->numByteCodesFreed;
currentHeaderBytes = numCurrentByteCodes
* (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
literalMgmtBytes = sizeof(LiteralTable)
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
currentLiteralBytes = literalMgmtBytes
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
+ statsPtr->currentLitStringBytes;
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
/*
* Summary statistics, total and current source and ByteCode sizes.
*/
fprintf(stdout, "\n----------------------------------------------------------------\n");
fprintf(stdout,
"Compilation and execution statistics for interpreter 0x%x\n",
(unsigned int) iPtr);
fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
statsPtr->numExecutions);
fprintf(stdout, "Number ByteCodes compiled %ld\n",
statsPtr->numCompilations);
fprintf(stdout, " Mean executions/compile %.1f\n",
((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
fprintf(stdout, "\nInstructions executed %.0f\n",
numInstructions);
fprintf(stdout, " Mean inst/compile %.0f\n",
numInstructions / statsPtr->numCompilations);
fprintf(stdout, " Mean inst/execution %.0f\n",
numInstructions / statsPtr->numExecutions);
fprintf(stdout, "\nTotal ByteCodes %ld\n",
statsPtr->numCompilations);
fprintf(stdout, " Source bytes %.6g\n",
statsPtr->totalSrcBytes);
fprintf(stdout, " Code bytes %.6g\n",
totalCodeBytes);
fprintf(stdout, " ByteCode bytes %.6g\n",
statsPtr->totalByteCodeBytes);
fprintf(stdout, " Literal bytes %.6g\n",
totalLiteralBytes);
fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
sizeof(LiteralTable),
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
statsPtr->totalLitStringBytes);
fprintf(stdout, " Mean code/compile %.1f\n",
totalCodeBytes / statsPtr->numCompilations);
fprintf(stdout, " Mean code/source %.1f\n",
totalCodeBytes / statsPtr->totalSrcBytes);
fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n",
numCurrentByteCodes);
fprintf(stdout, " Source bytes %.6g\n",
statsPtr->currentSrcBytes);
fprintf(stdout, " Code bytes %.6g\n",
currentCodeBytes);
fprintf(stdout, " ByteCode bytes %.6g\n",
statsPtr->currentByteCodeBytes);
fprintf(stdout, " Literal bytes %.6g\n",
currentLiteralBytes);
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
sizeof(LiteralTable),
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
iPtr->literalTable.numEntries * sizeof(LiteralEntry),
iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
statsPtr->currentLitStringBytes);
fprintf(stdout, " Mean code/source %.1f\n",
currentCodeBytes / statsPtr->currentSrcBytes);
fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
(currentCodeBytes + statsPtr->currentSrcBytes),
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
/*
* Tcl_IsShared statistics check
*
* This gives the refcount of each obj as Tcl_IsShared was called
* for it. Shared objects must be duplicated before they can be
* modified.
*/
numSharedMultX = 0;
fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n",
tclObjsShared[1]);
for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
fprintf(stdout, " refcount ==%d %ld\n",
i, tclObjsShared[i]);
numSharedMultX += tclObjsShared[i];
}
fprintf(stdout, " refcount >=%d %ld\n",
i, tclObjsShared[0]);
numSharedMultX += tclObjsShared[0];
fprintf(stdout, " Total shared objects %d\n",
numSharedMultX);
/*
* Literal table statistics.
*/
numByteCodeLits = 0;
refCountSum = 0;
numSharedMultX = 0;
numSharedOnce = 0;
objBytesIfUnshared = 0.0;
strBytesIfUnshared = 0.0;
strBytesSharedMultX = 0.0;
strBytesSharedOnce = 0.0;
for (i = 0; i < globalTablePtr->numBuckets; i++) {
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
entryPtr = entryPtr->nextPtr) {
if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
numByteCodeLits++;
}
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
refCountSum += entryPtr->refCount;
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
strBytesIfUnshared += (entryPtr->refCount * (length+1));
if (entryPtr->refCount > 1) {
numSharedMultX++;
strBytesSharedMultX += (length+1);
} else {
numSharedOnce++;
strBytesSharedOnce += (length+1);
}
}
}
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
- currentLiteralBytes;
fprintf(stdout, "\nTotal objects (all interps) %ld\n",
tclObjsAlloced);
fprintf(stdout, "Current objects %ld\n",
(tclObjsAlloced - tclObjsFreed));
fprintf(stdout, "Total literal objects %ld\n",
statsPtr->numLiteralsCreated);
fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
globalTablePtr->numEntries,
(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
numByteCodeLits,
(numByteCodeLits * 100.0) / globalTablePtr->numEntries);
fprintf(stdout, " Literals reused > 1x %d\n",
numSharedMultX);
fprintf(stdout, " Mean reference count %.2f\n",
((double) refCountSum) / globalTablePtr->numEntries);
fprintf(stdout, " Mean len, str reused >1x %.2f\n",
(numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
fprintf(stdout, " Mean len, str used 1x %.2f\n",
(numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
sharingBytesSaved,
(sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
fprintf(stdout, " Bytes with sharing %.6g\n",
currentLiteralBytes);
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
sizeof(LiteralTable),
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
iPtr->literalTable.numEntries * sizeof(LiteralEntry),
iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
statsPtr->currentLitStringBytes);
fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
(objBytesIfUnshared + strBytesIfUnshared),
objBytesIfUnshared, strBytesIfUnshared);
fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
(strBytesIfUnshared - statsPtr->currentLitStringBytes),
strBytesIfUnshared, statsPtr->currentLitStringBytes);
fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
literalMgmtBytes,
(literalMgmtBytes * 100.0) / currentLiteralBytes);
fprintf(stdout, " table %d + buckets %d + entries %d\n",
sizeof(LiteralTable),
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
iPtr->literalTable.numEntries * sizeof(LiteralEntry));
/*
* Breakdown of current ByteCode space requirements.
*/
fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
fprintf(stdout, " Bytes Pct of Avg per\n");
fprintf(stdout, " total ByteCode\n");
fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
statsPtr->currentByteCodeBytes,
statsPtr->currentByteCodeBytes / numCurrentByteCodes);
fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
currentHeaderBytes,
((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
currentHeaderBytes / numCurrentByteCodes);
fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
statsPtr->currentInstBytes,
((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentInstBytes / numCurrentByteCodes);
fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
statsPtr->currentLitBytes,
((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentLitBytes / numCurrentByteCodes);
fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
statsPtr->currentExceptBytes,
((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentExceptBytes / numCurrentByteCodes);
fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
statsPtr->currentAuxBytes,
((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentAuxBytes / numCurrentByteCodes);
fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
statsPtr->currentCmdMapBytes,
((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
statsPtr->currentCmdMapBytes / numCurrentByteCodes);
/*
* Detailed literal statistics.
*/
fprintf(stdout, "\nLiteral string sizes:\n");
fprintf(stdout, " Up to length Percentage\n");
maxSizeDecade = 0;
for (i = 31; i >= 0; i--) {
if (statsPtr->literalCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = 0; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->literalCount[i];
fprintf(stdout, " %10d %8.0f%%\n",
decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
}
litTableStats = TclLiteralStats(globalTablePtr);
fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
litTableStats);
ckfree((char *) litTableStats);
/*
* Source and ByteCode size distributions.
*/
fprintf(stdout, "\nSource sizes:\n");
fprintf(stdout, " Up to size Percentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->srcCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->srcCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->srcCount[i];
fprintf(stdout, " %10d %8.0f%%\n",
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
}
fprintf(stdout, "\nByteCode sizes:\n");
fprintf(stdout, " Up to size Percentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->byteCodeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->byteCodeCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->byteCodeCount[i];
fprintf(stdout, " %10d %8.0f%%\n",
decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
}
fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
fprintf(stdout, " Up to ms Percentage\n");
minSizeDecade = maxSizeDecade = 0;
for (i = 0; i < 31; i++) {
if (statsPtr->lifetimeCount[i] > 0) {
minSizeDecade = i;
break;
}
}
for (i = 31; i >= 0; i--) {
if (statsPtr->lifetimeCount[i] > 0) {
maxSizeDecade = i;
break;
}
}
sum = 0;
for (i = minSizeDecade; i <= maxSizeDecade; i++) {
decadeHigh = (1 << (i+1)) - 1;
sum += statsPtr->lifetimeCount[i];
fprintf(stdout, " %12.3f %8.0f%%\n",
decadeHigh / 1000.0,
(sum * 100.0) / statsPtr->numByteCodesFreed);
}
/*
* Instruction counts.
*/
fprintf(stdout, "\nInstruction counts:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i]) {
fprintf(stdout, "%20s %8ld %6.1f%%\n",
instructionTable[i].name,
statsPtr->instructionCount[i],
(statsPtr->instructionCount[i]*100.0) / numInstructions);
}
}
fprintf(stdout, "\nInstructions NEVER executed:\n");
for (i = 0; i <= LAST_INST_OPCODE; i++) {
if (statsPtr->instructionCount[i] == 0) {
fprintf(stdout, "%20s\n",
instructionTable[i].name);
}
}
#ifdef TCL_MEM_DEBUG
fprintf(stdout, "\nHeap Statistics:\n");
TclDumpMemoryInfo(stdout);
#endif
fprintf(stdout, "\n----------------------------------------------------------------\n");
return TCL_OK;
}
#endif /* TCL_COMPILE_STATS */
/*
*----------------------------------------------------------------------
*
* Tcl_GetCommandFromObj --
*
* Returns the command specified by the name in a Tcl_Obj.
*
* Results:
* Returns a token for the command if it is found. Otherwise, if it
* can't be found or there is an error, returns NULL.
*
* Side effects:
* May update the internal representation for the object, caching
* the command reference so that the next time this procedure is
* called with the same object, the command can be found quickly.
*
*----------------------------------------------------------------------
*/
Tcl_Command
Tcl_GetCommandFromObj(interp, objPtr)
Tcl_Interp *interp; /* The interpreter in which to resolve the
* command and to report errors. */
register Tcl_Obj *objPtr; /* The object containing the command's
* name. If the name starts with "::", will
* be looked up in global namespace. Else,
* looked up first in the current namespace
* if contextNsPtr is NULL, then in global
* namespace. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
register Command *cmdPtr;
Namespace *currNsPtr;
int result;
/*
* Get the internal representation, converting to a command type if
* needed. The internal representation is a ResolvedCmdName that points
* to the actual command.
*/
if (objPtr->typePtr != &tclCmdNameType) {
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
return (Tcl_Command) NULL;
}
}
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
/*
* Get the current namespace.
*/
if (iPtr->varFramePtr != NULL) {
currNsPtr = iPtr->varFramePtr->nsPtr;
} else {
currNsPtr = iPtr->globalNsPtr;
}
/*
* Check the context namespace and the namespace epoch of the resolved
* symbol to make sure that it is fresh. If not, then force another
* conversion to the command type, to discard the old rep and create a
* new one. Note that we verify that the namespace id of the context
* namespace is the same as the one we cached; this insures that the
* namespace wasn't deleted and a new one created at the same address
* with the same command epoch.
*/
cmdPtr = NULL;
if ((resPtr != NULL)
&& (resPtr->refNsPtr == currNsPtr)
&& (resPtr->refNsId == currNsPtr->nsId)
&& (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
cmdPtr = resPtr->cmdPtr;
if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
cmdPtr = NULL;
}
}
if (cmdPtr == NULL) {
result = tclCmdNameType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
return (Tcl_Command) NULL;
}
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
if (resPtr != NULL) {
cmdPtr = resPtr->cmdPtr;
}
}
return (Tcl_Command) cmdPtr;
}
/*
*----------------------------------------------------------------------
*
* TclSetCmdNameObj --
*
* Modify an object to be an CmdName object that refers to the argument
* Command structure.
*
* Results:
* None.
*
* Side effects:
* The object's old internal rep is freed. It's string rep is not
* changed. The refcount in the Command structure is incremented to
* keep it from being freed if the command is later deleted until
* TclExecuteByteCode has a chance to recognize that it was deleted.
*
*----------------------------------------------------------------------
*/
void
TclSetCmdNameObj(interp, objPtr, cmdPtr)
Tcl_Interp *interp; /* Points to interpreter containing command
* that should be cached in objPtr. */
register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
* a CmdName object. */
Command *cmdPtr; /* Points to Command structure that the
* CmdName object should refer to. */
{
Interp *iPtr = (Interp *) interp;
register ResolvedCmdName *resPtr;
Tcl_ObjType *oldTypePtr = objPtr->typePtr;
register Namespace *currNsPtr;
if (oldTypePtr == &tclCmdNameType) {
return;
}
/*
* Get the current namespace.
*/
if (iPtr->varFramePtr != NULL) {
currNsPtr = iPtr->varFramePtr->nsPtr;
} else {
currNsPtr = iPtr->globalNsPtr;
}
cmdPtr->refCount++;
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
oldTypePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
}
/*
*----------------------------------------------------------------------
*
* FreeCmdNameInternalRep --
*
* Frees the resources associated with a cmdName object's internal
* representation.
*
* Results:
* None.
*
* Side effects:
* Decrements the ref count of any cached ResolvedCmdName structure
* pointed to by the cmdName's internal representation. If this is
* the last use of the ResolvedCmdName, it is freed. This in turn
* decrements the ref count of the Command structure pointed to by
* the ResolvedSymbol, which may free the Command structure.
*
*----------------------------------------------------------------------
*/
static void
FreeCmdNameInternalRep(objPtr)
register Tcl_Obj *objPtr; /* CmdName object with internal
* representation to free. */
{
register ResolvedCmdName *resPtr =
(ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
if (resPtr != NULL) {
/*
* Decrement the reference count of the ResolvedCmdName structure.
* If there are no more uses, free the ResolvedCmdName structure.
*/
resPtr->refCount--;
if (resPtr->refCount == 0) {
/*
* Now free the cached command, unless it is still in its
* hash table or if there are other references to it
* from other cmdName objects.
*/
Command *cmdPtr = resPtr->cmdPtr;
TclCleanupCommand(cmdPtr);
ckfree((char *) resPtr);
}
}
}
/*
*----------------------------------------------------------------------
*
* DupCmdNameInternalRep --
*
* Initialize the internal representation of an cmdName Tcl_Obj to a
* copy of the internal representation of an existing cmdName object.
*
* Results:
* None.
*
* Side effects:
* "copyPtr"s internal rep is set to point to the ResolvedCmdName
* structure corresponding to "srcPtr"s internal rep. Increments the
* ref count of the ResolvedCmdName structure pointed to by the
* cmdName's internal representation.
*
*----------------------------------------------------------------------
*/
static void
DupCmdNameInternalRep(srcPtr, copyPtr)
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
{
register ResolvedCmdName *resPtr =
(ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
if (resPtr != NULL) {
resPtr->refCount++;
}
copyPtr->typePtr = &tclCmdNameType;
}
/*
*----------------------------------------------------------------------
*
* SetCmdNameFromAny --
*
* Generate an cmdName internal form for the Tcl object "objPtr".
*
* Results:
* The return value is a standard Tcl result. The conversion always
* succeeds and TCL_OK is returned.
*
* Side effects:
* A pointer to a ResolvedCmdName structure that holds a cached pointer
* to the command with a name that matches objPtr's string rep is
* stored as objPtr's internal representation. This ResolvedCmdName
* pointer will be NULL if no matching command was found. The ref count
* of the cached Command's structure (if any) is also incremented.
*
*----------------------------------------------------------------------
*/
static int
SetCmdNameFromAny(interp, objPtr)
Tcl_Interp *interp; /* Used for error reporting if not NULL. */
register Tcl_Obj *objPtr; /* The object to convert. */
{
Interp *iPtr = (Interp *) interp;
char *name;
Tcl_Command cmd;
register Command *cmdPtr;
Namespace *currNsPtr;
register ResolvedCmdName *resPtr;
/*
* Get "objPtr"s string representation. Make it up-to-date if necessary.
*/
name = objPtr->bytes;
if (name == NULL) {
name = Tcl_GetString(objPtr);
}
/*
* Find the Command structure, if any, that describes the command called
* "name". Build a ResolvedCmdName that holds a cached pointer to this
* Command, and bump the reference count in the referenced Command
* structure. A Command structure will not be deleted as long as it is
* referenced from a CmdName object.
*/
cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
/*flags*/ 0);
cmdPtr = (Command *) cmd;
if (cmdPtr != NULL) {
/*
* Get the current namespace.
*/
if (iPtr->varFramePtr != NULL) {
currNsPtr = iPtr->varFramePtr->nsPtr;
} else {
currNsPtr = iPtr->globalNsPtr;
}
cmdPtr->refCount++;
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
resPtr->cmdPtr = cmdPtr;
resPtr->refNsPtr = currNsPtr;
resPtr->refNsId = currNsPtr->nsId;
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
resPtr->cmdEpoch = cmdPtr->cmdEpoch;
resPtr->refCount = 1;
} else {
resPtr = NULL; /* no command named "name" was found */
}
/*
* Free the old internalRep before setting the new one. We do this as
* late as possible to allow the conversion code, in particular
* GetStringFromObj, to use that old internalRep. If no Command
* structure was found, leave NULL as the cached value.
*/
if ((objPtr->typePtr != NULL)
&& (objPtr->typePtr->freeIntRepProc != NULL)) {
objPtr->typePtr->freeIntRepProc(objPtr);
}
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
objPtr->internalRep.twoPtrValue.ptr2 = NULL;
objPtr->typePtr = &tclCmdNameType;
return TCL_OK;
}
#ifdef TCL_COMPILE_DEBUG
/*
*----------------------------------------------------------------------
*
* StringForResultCode --
*
* Procedure that returns a human-readable string representing a
* Tcl result code such as TCL_ERROR.
*
* Results:
* If the result code is one of the standard Tcl return codes, the
* result is a string representing that code such as "TCL_ERROR".
* Otherwise, the result string is that code formatted as a
* sequence of decimal digit characters. Note that the resulting
* string must not be modified by the caller.
*
* Side effects:
* None.
*
*----------------------------------------------------------------------
*/
static char *
StringForResultCode(result)
int result; /* The Tcl result code for which to
* generate a string. */
{
static char buf[TCL_INTEGER_SPACE];
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
return resultStrings[result];
}
TclFormatInt(buf, result);
return buf;
}
#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
* ProcessUnexpectedResult --
*
* Procedure called by Tcl_EvalObj to set the interpreter's result
* value to an appropriate error message when the code it evaluates
* returns an unexpected result code (not TCL_OK and not TCL_ERROR) to
* the topmost evaluation level.
*
* Results:
* None.
*
* Side effects:
* The interpreter result is set to an error message appropriate to
* the result code.
*
*----------------------------------------------------------------------
*/
static void
ProcessUnexpectedResult(interp, returnCode)
Tcl_Interp *interp; /* The interpreter in which the unexpected
* result code was returned. */
int returnCode; /* The unexpected result code. */
{
Tcl_ResetResult(interp);
if (returnCode == TCL_BREAK) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"invoked \"break\" outside of a loop", -1);
} else if (returnCode == TCL_CONTINUE) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"invoked \"continue\" outside of a loop", -1);
} else {
STRING (30 + TCL_INTEGER_SPACE, buf);
NEWSTR (30 + TCL_INTEGER_SPACE, buf);
sprintf(buf, "command returned bad code: %d", returnCode);
Tcl_SetResult(interp, buf, TCL_VOLATILE);
RELTEMP (buf);
}
}
/*
*----------------------------------------------------------------------
*
* RecordTracebackInfo --
*
* Procedure called by Tcl_EvalObj to record information about what was
* being executed when the error occurred.
*
* Results:
* None.
*
* Side effects:
* Appends information about the script being evaluated to the
* interpreter's "errorInfo" variable.
*
*----------------------------------------------------------------------
*/
static void
RecordTracebackInfo(interp, objPtr, numSrcBytes)
Tcl_Interp *interp; /* The interpreter in which the error
* occurred. */
Tcl_Obj *objPtr; /* Points to object containing script whose
* evaluation resulted in an error. */
int numSrcBytes; /* Number of bytes compiled in script. */
{
Interp *iPtr = (Interp *) interp;
STRING (200, buf);
char *ellipsis, *bytes;
int length;
NEWSTR (200, buf);
/*
* Decide how much of the command to print in the error message
* (up to a certain number of bytes).
*/
bytes = Tcl_GetStringFromObj(objPtr, &length);
length = TclMin(numSrcBytes, length);
ellipsis = "";
if (length > 150) {
length = 150;
ellipsis = " ...";
}
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
sprintf(buf, "\n while executing\n\"%.*s%s\"",
length, bytes, ellipsis);
} else {
sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
length, bytes, ellipsis);
}
Tcl_AddObjErrorInfo(interp, buf, -1);
RELTEMP (buf);
}
/*
* Recently imported stuff ...
*/
static int
TclInterpReady(interp)
Tcl_Interp *interp;
{
register Interp *iPtr = (Interp *) interp;
/*
* Check depth of nested calls to Tcl_Eval: if this gets too large,
* it's probably because of an infinite loop somewhere.
*/
if ((iPtr->numLevels + 1) > iPtr->maxNestingDepth) {
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
return TCL_ERROR;
}
/*
* On the Mac, we will never reach the default recursion limit before
* blowing the stack. So we need to do a check here.
*/
if (TclpCheckStackSpace() == 0) {
/*NOTREACHED*/
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"too many nested calls to Tcl_EvalObj (infinite loop?)", -1);
return TCL_ERROR;
}
/*
* If the interpreter has been deleted, return an error.
*/
if (iPtr->flags & DELETED) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"attempt to call eval in deleted interpreter", -1);
Tcl_SetErrorCode(interp, "CORE", "IDELETE",
"attempt to call eval in deleted interpreter",
(char *) NULL);
return TCL_ERROR;
}
return TCL_OK;
}
static int
TclCompileByteCodesForEval(interp, objPtr)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
{
register Interp *iPtr = (Interp *) interp;
ByteCode *codePtr;
Namespace *namespacePtr;
int result;
/*
* 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,
* or for a different namespace, or for the same namespace but
* with different name resolution rules, we recompile it.
*
* 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.
*/
if (iPtr->varFramePtr != NULL) {
namespacePtr = iPtr->varFramePtr->nsPtr;
} else {
namespacePtr = iPtr->globalNsPtr;
}
if (objPtr->typePtr == &tclByteCodeType) {
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 {
tclByteCodeType.freeIntRepProc(objPtr);
}
}
}
if (objPtr->typePtr != &tclByteCodeType) {
iPtr->errorLine = 1;
result = tclByteCodeType.setFromAnyProc(interp, objPtr);
if (result != TCL_OK) {
return result;
}
} else {
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
if (((Interp *) *codePtr->interpHandle != iPtr)
|| (codePtr->compileEpoch != iPtr->compileEpoch)) {
(*tclByteCodeType.freeIntRepProc)(objPtr);
iPtr->errorLine = 1;
result = (*tclByteCodeType.setFromAnyProc)(interp, objPtr);
if (result != TCL_OK) {
iPtr->numLevels--;
return result;
}
}
}
return TCL_OK;
}
static int
TclInterpPostEval(interp, evalFlags, result, objPtr, numSrcBytes)
Tcl_Interp *interp;
int evalFlags;
int result;
Tcl_Obj *objPtr;
int numSrcBytes;
{
register Interp *iPtr = (Interp *) interp;
/*
* Update the interpreter's evaluation level count. If we will be
* again at the top level, process any unusual return code returned
* by the evaluated code.
*/
if (iPtr->numLevels == 1) {
if (result == TCL_RETURN) {
result = TclUpdateReturnInfo(iPtr);
}
if ((result != TCL_OK) && (result != TCL_ERROR)
&& ((evalFlags & TCL_ALLOW_EXCEPTIONS) == 0)) {
ProcessUnexpectedResult(interp, result);
result = TCL_ERROR;
}
}
/*
* If an error occurred, record information about what was being
* executed when the error occurred.
*/
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
RecordTracebackInfo(interp, objPtr, 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;
}
int
TclEvalByteCodeFromObj(interp, objPtr, flags)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
int flags;
{
register Interp *iPtr = (Interp *) interp;
int evalFlags; /* Interp->evalFlags value when the
* procedure was called. */
register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
* at all were executed. */
int numSrcBytes;
int result;
CallFrame *savedVarFramePtr; /* Saves old copy of iPtr->varFramePtr
* in case TCL_EVAL_GLOBAL was set. */
Tcl_IncrRefCount(objPtr);
/*
* Reset both the interpreter's string and object results and clear out
* any error information. This makes sure that we return an empty
* result if there are no commands in the command string.
*/
Tcl_ResetResult(interp);
/*
* Check that the interpreter is ready to execute scripts
*/
if (TclInterpReady(interp) == TCL_ERROR) {
TclDecrRefCount(objPtr);
return TCL_ERROR;
}
/*
* Take care of the TCL_EVAL_GLOBAL case.
*/
savedVarFramePtr = iPtr->varFramePtr;
if (flags & TCL_EVAL_GLOBAL) {
iPtr->varFramePtr = NULL;
}
/*
* Get the ByteCode from the object.
*/
result = TclCompileByteCodesForEval(interp, objPtr);
if (result == TCL_ERROR) {
goto done;
}
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
/*
* Extract then reset the compilation flags in the interpreter.
* Resetting the flags must be done after any compilation.
*/
evalFlags = iPtr->evalFlags;
iPtr->evalFlags = 0;
/*
* Execute the commands. If the code was compiled from an empty string,
* don't bother executing the code.
*/
iPtr->numLevels++;
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;
}
/*
* 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);
}
/*
* Update the interpreter's state
*/
result = TclInterpPostEval(interp, evalFlags, result, objPtr, numSrcBytes);
iPtr->numLevels--;
done:
TclDecrRefCount(objPtr);
iPtr->varFramePtr = savedVarFramePtr;
return result;
}
static int
TclCompileByteCodesForExpr(interp, objPtr)
Tcl_Interp *interp;
Tcl_Obj *objPtr;
{
Interp *iPtr = (Interp *) interp;
TEMP (CompileEnv) compEnv; /* Compilation environment structure
* allocated in frame. */
LiteralTable *localTablePtr;
register ByteCode *codePtr = NULL;
/* Tcl Internal type of bytecode.
* Initialized to avoid compiler warning. */
AuxData *auxDataPtr;
LiteralEntry *entryPtr;
char *string;
int length, i, result;
NEWTEMP(CompileEnv,compEnv);
localTablePtr = &(ITEM(compEnv,localLitTable));
string = Tcl_GetStringFromObj(objPtr, &length);
/*
* 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) {
TclInitCompileEnv(interp, REF(compEnv), string, length);
result = TclCompileExpr(interp, string, length, REF(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(REF(compEnv));
#endif /*TCL_COMPILE_DEBUG*/
entryPtr = ITEM(compEnv,literalArrayPtr);
for (i = 0; i < ITEM(compEnv,literalArrayNext); i++) {
TclReleaseLiteral(interp, entryPtr->objPtr);
entryPtr++;
}
#ifdef TCL_COMPILE_DEBUG
TclVerifyGlobalLiteralTable(iPtr);
#endif /*TCL_COMPILE_DEBUG*/
auxDataPtr = ITEM(compEnv,auxDataArrayPtr);
for (i = 0; i < ITEM(compEnv,auxDataArrayNext); i++) {
if (auxDataPtr->type->freeProc != NULL) {
auxDataPtr->type->freeProc(auxDataPtr->clientData);
}
auxDataPtr++;
}
TclFreeCompileEnv(REF(compEnv));
RELTEMP(compEnv);
return result;
}
/*
* Successful compilation. If the expression yielded no
* instructions, push an zero object as the expression's result.
*/
if (ITEM(compEnv,codeNext) == ITEM(compEnv,codeStart)) {
TclEmitPush(TclRegisterLiteral(REF(compEnv), "0", 1, /*onHeap*/ 0),
REF(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.
*/
ITEM(compEnv,numSrcBytes) = iPtr->termOffset;
TclEmitOpcode(INST_DONE, REF(compEnv));
TclInitByteCodeObj(objPtr, REF(compEnv));
TclFreeCompileEnv(REF(compEnv));
RELTEMP(compEnv);
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
#ifdef TCL_COMPILE_DEBUG
if (tclTraceCompile == 2) {
TclPrintByteCodeObj(interp, objPtr);
}
#endif /* TCL_COMPILE_DEBUG */
} else {
RELTEMP(compEnv);
}
return TCL_OK;
}
int
TclExprByteCodeFromObj(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;
register ByteCode *codePtr = NULL;
/* Tcl Internal type of bytecode.
* Initialized to avoid compiler warning. */
Tcl_Obj *saveObjPtr;
int result;
/*
* Get the ByteCode from the object.
*/
result = TclCompileByteCodesForExpr(interp, objPtr);
if (result != TCL_OK) {
return result;
}
codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
/*
* 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);
}
Tcl_DecrRefCount(saveObjPtr);
return result;
}
/*
*----------------------------------------------------------------------
*
* TclObjInterpProc --
*
* When a Tcl procedure gets invoked during bytecode evaluation, this
* object-based routine gets invoked to interpret the procedure.
*
* Results:
* A standard Tcl object result value.
*
* Side effects:
* Depends on the commands in the procedure.
*
*----------------------------------------------------------------------
*/
static int
PrepareProcFrameForExecution (interp, framePtr, objc, objv, compiledLocals)
Tcl_Interp *interp;
CallFrame *framePtr;
int objc;
Tcl_Obj *CONST objv[0];
Var *compiledLocals;
{
register Proc *procPtr = framePtr->procPtr;
register Var *varPtr;
register CompiledLocal *localPtr;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
int numArgs, argCt, i, nameLen;
char *procName;
framePtr->objc = objc;
framePtr->objv = objv; /* ref counts for args are incremented below */
framePtr->numCompiledLocals = procPtr->numCompiledLocals;
framePtr->compiledLocals = compiledLocals;
/*
* Initialize and resolve compiled variable references.
*/
TclInitCompiledLocals(interp, framePtr, nsPtr);
/*
* Match and assign the call's actual parameters to the procedure's
* formal arguments. The formal arguments are described by the first
* numArgs entries in both the Proc structure's local variable list and
* the call frame's local variable array.
*/
numArgs = procPtr->numArgs;
varPtr = framePtr->compiledLocals;
localPtr = procPtr->firstLocalPtr;
argCt = objc;
for (i = 1, argCt -= 1; i <= numArgs; i++, argCt--) {
if (!TclIsVarArgument(localPtr)) {
panic("TclObjInterpProc: local variable %s is not argument but should be",
localPtr->name);
return TCL_ERROR;
}
if (TclIsVarTemporary(localPtr)) {
panic("TclObjInterpProc: local variable %d is temporary but should be an argument", i);
return TCL_ERROR;
}
/*
* Handle the special case of the last formal being "args". When
* it occurs, assign it a list consisting of all the remaining
* actual arguments.
*/
if ((i == numArgs) && ((localPtr->name[0] == 'a')
&& (strcmp(localPtr->name, "args") == 0))) {
Tcl_Obj *listPtr = Tcl_NewListObj(argCt, &(objv[i]));
varPtr->value.objPtr = listPtr;
Tcl_IncrRefCount(listPtr); /* local var is a reference */
varPtr->flags &= ~VAR_UNDEFINED;
argCt = 0;
break; /* done processing args */
} else if (argCt > 0) {
Tcl_Obj *objPtr = objv[i];
varPtr->value.objPtr = objPtr;
varPtr->flags &= ~VAR_UNDEFINED;
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else if (localPtr->defValuePtr != NULL) {
Tcl_Obj *objPtr = localPtr->defValuePtr;
varPtr->value.objPtr = objPtr;
varPtr->flags &= ~VAR_UNDEFINED;
Tcl_IncrRefCount(objPtr); /* since the local variable now has
* another reference to object. */
} else {
Tcl_ResetResult(interp);
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"no value given for parameter \"", localPtr->name,
"\" to \"", Tcl_GetString(objv[0]), "\"", (char *) NULL);
return TCL_ERROR;
}
varPtr++;
localPtr = localPtr->nextPtr;
}
if (argCt > 0) {
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
"called \"", Tcl_GetString(objv[0]),
"\" with too many arguments", (char *) NULL);
return TCL_ERROR;
}
/*
* Invoke the commands in the procedure's body.
*/
if (tclTraceExec >= 1) {
#ifdef TCL_COMPILE_DEBUG
fprintf(stdout, "Calling proc ");
for (i = 0; i < objc; i++) {
TclPrintObject(stdout, objv[i], 15);
fprintf(stdout, " ");
}
fprintf(stdout, "\n");
#else /* TCL_COMPILE_DEBUG */
procName = Tcl_GetStringFromObj(objv[0], &nameLen);
fprintf(stdout, "Calling proc %.*s\n", nameLen, procName);
#endif /*TCL_COMPILE_DEBUG*/
fflush(stdout);
}
return TCL_OK;
}
int
TclObjInterpProc(clientData, interp, objc, objv)
ClientData clientData; /* Record describing procedure to be
* interpreted. */
register Tcl_Interp *interp; /* Interpreter in which procedure was
* invoked. */
int objc; /* Count of number of arguments to this
* procedure. */
Tcl_Obj *CONST objv[]; /* Argument value objects. */
{
Interp *iPtr = (Interp *) interp;
register Proc *procPtr = (Proc *) clientData;
Namespace *nsPtr = procPtr->cmdPtr->nsPtr;
CallFrame frame;
register CallFrame *framePtr = &frame;
char *procName;
int nameLen, localCt, result;
/*
* This procedure generates an array "compiledLocals" that holds the
* storage for local variables. It starts out with stack-allocated space
* but uses dynamically-allocated storage if needed.
*/
#define NUM_LOCALS TCL_PROC_STATIC_CLOCALS
Var localStorage[NUM_LOCALS];
Var *compiledLocals = localStorage;
/*
* Get the procedure's name.
*/
procName = Tcl_GetStringFromObj(objv[0], &nameLen);
/*
* If necessary, compile the procedure's body. The compiler will
* allocate frame slots for the procedure's non-argument local
* variables. Note that compiling the body might increase
* procPtr->numCompiledLocals if new local variables are found
* while compiling.
*/
result = TclProcCompileProc(interp, procPtr, procPtr->bodyPtr, nsPtr,
"body of proc", procName);
if (result != TCL_OK) {
return result;
}
/*
* Set up and push a new call frame for the new procedure invocation.
* This call frame will execute in the proc's namespace, which might
* be different than the current namespace. The proc's namespace is
* that of its command, which can change if the command is renamed
* from one namespace to another.
*/
result = Tcl_PushCallFrame(interp, (Tcl_CallFrame *) framePtr,
(Tcl_Namespace *) nsPtr, /*isProcCallFrame*/ 1);
if (result != TCL_OK) {
return result;
}
framePtr->procPtr = procPtr;
/*
* Create the "compiledLocals" array. Make sure it is large enough to
* hold all the procedure's compiled local variables, including its
* formal parameters.
*/
localCt = procPtr->numCompiledLocals;
if (localCt > NUM_LOCALS) {
compiledLocals = (Var *) ckalloc((unsigned) localCt * sizeof(Var));
}
result = PrepareProcFrameForExecution(interp, framePtr, objc, objv, compiledLocals);
if (result == TCL_ERROR) {
goto procDone;
}
iPtr->returnCode = TCL_OK;
procPtr->refCount++;
result = Tcl_EvalObjEx(interp, procPtr->bodyPtr, 0);
procPtr->refCount--;
if (procPtr->refCount <= 0) {
TclProcCleanupProc(procPtr);
}
if (result != TCL_OK) {
result = ProcessProcResultCode(interp, procName, nameLen, result);
}
/*
* Pop and free the call frame for this procedure invocation, then
* free the compiledLocals array if malloc'ed storage was used.
*/
procDone:
Tcl_PopCallFrame(interp);
if (compiledLocals != localStorage) {
ckfree((char *) compiledLocals);
}
return result;
#undef NUM_LOCALS
}
/*
*----------------------------------------------------------------------
*
* ProcessProcResultCode --
*
* Procedure called by TclObjInterpProc to process a return code other
* than TCL_OK returned by a Tcl procedure.
*
* Results:
* Depending on the argument return code, the result returned is
* another return code and the interpreter's result is set to a value
* to supplement that return code.
*
* Side effects:
* If the result returned is TCL_ERROR, traceback information about
* the procedure just executed is appended to the interpreter's
* "errorInfo" variable.
*
*----------------------------------------------------------------------
*/
static int
ProcessProcResultCode(interp, procName, nameLen, returnCode)
Tcl_Interp *interp; /* The interpreter in which the procedure
* was called and returned returnCode. */
char *procName; /* Name of the procedure. Used for error
* messages and trace information. */
int nameLen; /* Number of bytes in procedure's name. */
int returnCode; /* The unexpected result code. */
{
Interp *iPtr = (Interp *) interp;
if (returnCode == TCL_RETURN) {
returnCode = TclUpdateReturnInfo(iPtr);
} else if (returnCode == TCL_ERROR) {
char msg[100 + TCL_INTEGER_SPACE];
char *ellipsis = "";
int numChars = nameLen;
if (numChars > 60) {
numChars = 60;
ellipsis = "...";
}
sprintf(msg, "\n (procedure \"%.*s%s\" line %d)",
numChars, procName, ellipsis, iPtr->errorLine);
Tcl_AddObjErrorInfo(interp, msg, -1);
} else if (returnCode == TCL_BREAK) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"invoked \"break\" outside of a loop", -1);
returnCode = TCL_ERROR;
} else if (returnCode == TCL_CONTINUE) {
Tcl_ResetResult(interp);
Tcl_AppendToObj(Tcl_GetObjResult(interp),
"invoked \"continue\" outside of a loop", -1);
returnCode = TCL_ERROR;
}
return returnCode;
}