4930 lines
144 KiB
C
4930 lines
144 KiB
C
/*
|
||
* tclExecute.c --
|
||
*
|
||
* This file contains procedures that execute byte-compiled Tcl
|
||
* commands.
|
||
*
|
||
* Copyright (c) 1996-1997 Sun Microsystems, Inc.
|
||
*
|
||
* See the file "license.terms" for information on usage and redistribution
|
||
* of this file, and for a DISCLAIMER OF ALL WARRANTIES.
|
||
*
|
||
* SCCS: @(#) tclExecute.c 1.102 97/11/06 11:36:35
|
||
*/
|
||
|
||
#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;
|
||
|
||
/*
|
||
* 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;
|
||
|
||
/*
|
||
* 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 tcl_MathInProgress = 0;
|
||
|
||
/*
|
||
* 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
|
||
|
||
/*
|
||
* Array of instruction names.
|
||
*/
|
||
|
||
static char *opName[256];
|
||
|
||
/*
|
||
* 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 /* TCL_COMPILE_DEBUG */
|
||
|
||
/*
|
||
* The following are statistics-related variables that record information
|
||
* about the bytecode compiler and interpreter's operation. This includes
|
||
* an array that records for each instruction how often it is executed.
|
||
*/
|
||
|
||
#ifdef TCL_COMPILE_STATS
|
||
static long numExecutions = 0;
|
||
static int instructionCount[256];
|
||
#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.
|
||
*/
|
||
|
||
#define STK_ITEM(offset) (stackPtr[stackTop + (offset)])
|
||
#define STK_OBJECT(offset) (STK_ITEM(offset).o)
|
||
#define STK_INT(offset) (STK_ITEM(offset).i)
|
||
#define STK_POINTER(offset) (STK_ITEM(offset).p)
|
||
|
||
/*
|
||
* 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].o = (objPtr))
|
||
|
||
#define POP_OBJECT() \
|
||
(stackPtr[stackTop--].o)
|
||
|
||
/*
|
||
* 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.
|
||
*
|
||
* NOTE THAT CLIENTS OF O2S ARE LIKELY TO FAIL IF THE OBJECT'S
|
||
* STRING REP CONTAINS NULLS.
|
||
*/
|
||
|
||
#ifdef TCL_COMPILE_DEBUG
|
||
|
||
#define O2S(objPtr) \
|
||
Tcl_GetStringFromObj((objPtr), &length)
|
||
|
||
#ifdef TCL_COMPILE_STATS
|
||
#define TRACE(a) \
|
||
if (traceInstructions) { \
|
||
fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \
|
||
stackTop, (tclObjsAlloced - tclObjsFreed), \
|
||
(unsigned int)(pc - codePtr->codeStart)); \
|
||
printf a; \
|
||
fflush(stdout); \
|
||
}
|
||
#define TRACE_WITH_OBJ(a, objPtr) \
|
||
if (traceInstructions) { \
|
||
fprintf(stdout, "%d: %d,%ld (%u) ", iPtr->numLevels, \
|
||
stackTop, (tclObjsAlloced - tclObjsFreed), \
|
||
(unsigned int)(pc - codePtr->codeStart)); \
|
||
printf a; \
|
||
bytes = Tcl_GetStringFromObj((objPtr), &length); \
|
||
TclPrintSource(stdout, bytes, TclMin(length, 30)); \
|
||
fprintf(stdout, "\n"); \
|
||
fflush(stdout); \
|
||
}
|
||
#else /* not TCL_COMPILE_STATS */
|
||
#define TRACE(a) \
|
||
if (traceInstructions) { \
|
||
fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \
|
||
(unsigned int)(pc - codePtr->codeStart)); \
|
||
printf a; \
|
||
fflush(stdout); \
|
||
}
|
||
#define TRACE_WITH_OBJ(a, objPtr) \
|
||
if (traceInstructions) { \
|
||
fprintf(stdout, "%d: %d (%u) ", iPtr->numLevels, stackTop, \
|
||
(unsigned int)(pc - codePtr->codeStart)); \
|
||
printf a; \
|
||
bytes = Tcl_GetStringFromObj((objPtr), &length); \
|
||
TclPrintSource(stdout, bytes, TclMin(length, 30)); \
|
||
fprintf(stdout, "\n"); \
|
||
fflush(stdout); \
|
||
}
|
||
#endif /* TCL_COMPILE_STATS */
|
||
|
||
#else /* not TCL_COMPILE_DEBUG */
|
||
|
||
#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 /* TCL_COMPILE_STATS */
|
||
static void FreeCmdNameInternalRep _ANSI_ARGS_((
|
||
Tcl_Obj *objPtr));
|
||
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 int opCode,
|
||
Tcl_Obj *opndPtr));
|
||
static void InitByteCodeExecution _ANSI_ARGS_((
|
||
Tcl_Interp *interp));
|
||
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
|
||
static void RecordTracebackInfo _ANSI_ARGS_((Tcl_Interp *interp,
|
||
unsigned char *pc, ByteCode *codePtr));
|
||
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
|
||
Tcl_Obj *objPtr));
|
||
#ifdef TCL_COMPILE_DEBUG
|
||
static char * StringForResultCode _ANSI_ARGS_((int result));
|
||
#endif /* TCL_COMPILE_DEBUG */
|
||
static void UpdateStringOfCmdName _ANSI_ARGS_((Tcl_Obj *objPtr));
|
||
#ifdef TCL_COMPILE_DEBUG
|
||
static void ValidatePcAndStackTop _ANSI_ARGS_((
|
||
ByteCode *codePtr, unsigned char *pc,
|
||
int stackTop, int stackLowerBound,
|
||
int stackUpperBound));
|
||
#endif /* TCL_COMPILE_DEBUG */
|
||
|
||
/*
|
||
* 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 */
|
||
UpdateStringOfCmdName, /* 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. */
|
||
{
|
||
int i;
|
||
|
||
Tcl_RegisterObjType(&tclCmdNameType);
|
||
|
||
(VOID *) memset(opName, 0, sizeof(opName));
|
||
for (i = 0; instructionTable[i].name != NULL; i++) {
|
||
opName[i] = instructionTable[i].name;
|
||
}
|
||
|
||
#ifdef TCL_COMPILE_STATS
|
||
(VOID *) memset(instructionCount, 0, sizeof(instructionCount));
|
||
(VOID *) memset(tclByteCodeCount, 0, sizeof(tclByteCodeCount));
|
||
(VOID *) memset(tclSourceCount, 0, sizeof(tclSourceCount));
|
||
|
||
Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
|
||
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
|
||
#endif /* TCL_COMPILE_STATS */
|
||
|
||
if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
|
||
TCL_LINK_INT) != TCL_OK) {
|
||
panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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 = (StackItem *)
|
||
ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(StackItem)));
|
||
eePtr->stackTop = -1;
|
||
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
|
||
|
||
if (!execInitialized) {
|
||
InitByteCodeExecution(interp);
|
||
execInitialized = 1;
|
||
}
|
||
|
||
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. */
|
||
{
|
||
ckfree((char *) eePtr->stackPtr);
|
||
ckfree((char *) eePtr);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclFinalizeExecEnv --
|
||
*
|
||
* 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
|
||
TclFinalizeExecEnv()
|
||
{
|
||
execInitialized = 0;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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(StackItem);
|
||
int newBytes = 2*currBytes;
|
||
StackItem *newStackPtr = (StackItem *) 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);
|
||
ckfree((char *) eePtr->stackPtr);
|
||
eePtr->stackPtr = newStackPtr;
|
||
eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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 StackItem *stackPtr = eePtr->stackPtr;
|
||
/* Cached evaluation stack base pointer. */
|
||
register int stackTop = eePtr->stackTop;
|
||
/* Cached top index of evaluation stack. */
|
||
Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
|
||
/* Points to the ByteCode's object array. */
|
||
unsigned char *pc = codePtr->codeStart;
|
||
/* The current program counter. */
|
||
unsigned char opCode; /* The current instruction code. */
|
||
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, *namePtr, *objPtr;
|
||
char *bytes;
|
||
int length;
|
||
long i;
|
||
Tcl_DString command; /* Used for debugging. If tclTraceExec >= 2
|
||
* holds a string representing the last
|
||
* command invoked. */
|
||
|
||
/*
|
||
* This procedure uses a stack to hold information about catch commands.
|
||
* This information is the current operand stack top when starting to
|
||
* execute the code for each catch command. It starts out with stack-
|
||
* allocated space but uses dynamically-allocated storage if needed.
|
||
*/
|
||
|
||
#define STATIC_CATCH_STACK_SIZE 5
|
||
int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
|
||
int *catchStackPtr = catchStackStorage;
|
||
int catchTop = -1;
|
||
|
||
/*
|
||
* THIS PROC FAILS IF AN OBJECT'S STRING REP HAS A NULL BYTE.
|
||
*/
|
||
|
||
if (tclTraceExec >= 2) {
|
||
PrintByteCodeInfo(codePtr);
|
||
#ifdef TCL_COMPILE_STATS
|
||
fprintf(stdout, " Starting stack top=%d, system objects=%ld\n",
|
||
eePtr->stackTop, (tclObjsAlloced - tclObjsFreed));
|
||
#else
|
||
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
|
||
#endif /* TCL_COMPILE_STATS */
|
||
fflush(stdout);
|
||
}
|
||
|
||
#ifdef TCL_COMPILE_STATS
|
||
numExecutions++;
|
||
#endif /* TCL_COMPILE_STATS */
|
||
|
||
/*
|
||
* Make sure the catch stack is large enough to hold the maximum number
|
||
* of catch commands that could ever be executing at the same time. This
|
||
* will be no more than the exception range array's depth.
|
||
*/
|
||
|
||
if (codePtr->maxExcRangeDepth > STATIC_CATCH_STACK_SIZE) {
|
||
catchStackPtr = (int *)
|
||
ckalloc(codePtr->maxExcRangeDepth * sizeof(int));
|
||
}
|
||
|
||
/*
|
||
* Make sure the stack has enough room to execute this ByteCode.
|
||
*/
|
||
|
||
while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
|
||
GrowEvaluationStack(eePtr);
|
||
stackPtr = eePtr->stackPtr;
|
||
}
|
||
|
||
/*
|
||
* Initialize the buffer that holds a string containing the name and
|
||
* arguments for the last invoked command.
|
||
*/
|
||
|
||
Tcl_DStringInit(&command);
|
||
|
||
/*
|
||
* 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) {
|
||
#ifdef TCL_COMPILE_STATS
|
||
fprintf(stdout, "%d: %d,%ld ", iPtr->numLevels, stackTop,
|
||
(tclObjsAlloced - tclObjsFreed));
|
||
#else /* TCL_COMPILE_STATS */
|
||
fprintf(stdout, "%d: %d ", iPtr->numLevels, stackTop);
|
||
#endif /* TCL_COMPILE_STATS */
|
||
TclPrintInstruction(codePtr, pc);
|
||
fflush(stdout);
|
||
}
|
||
#endif /* TCL_COMPILE_DEBUG */
|
||
|
||
opCode = *pc;
|
||
#ifdef TCL_COMPILE_STATS
|
||
instructionCount[opCode]++;
|
||
#endif /* TCL_COMPILE_STATS */
|
||
|
||
switch (opCode) {
|
||
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) {
|
||
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);
|
||
fprintf(stderr, " Source: ");
|
||
TclPrintSource(stderr, codePtr->source, 150);
|
||
panic("TclExecuteByteCode execution failure: end stack top != start stack top");
|
||
}
|
||
TRACE_WITH_OBJ(("done => return code=%d, result is ", result),
|
||
iPtr->objResultPtr);
|
||
goto done;
|
||
|
||
case INST_PUSH1:
|
||
valuePtr = objArrayPtr[TclGetUInt1AtPtr(pc+1)];
|
||
PUSH_OBJECT(valuePtr);
|
||
TRACE_WITH_OBJ(("push1 %u => ", TclGetUInt1AtPtr(pc+1)),
|
||
valuePtr);
|
||
ADJUST_PC(2);
|
||
|
||
case INST_PUSH4:
|
||
valuePtr = objArrayPtr[TclGetUInt4AtPtr(pc+1)];
|
||
PUSH_OBJECT(valuePtr);
|
||
TRACE_WITH_OBJ(("push4 %u => ", TclGetUInt4AtPtr(pc+1)),
|
||
valuePtr);
|
||
ADJUST_PC(5);
|
||
|
||
case INST_POP:
|
||
valuePtr = POP_OBJECT();
|
||
TRACE_WITH_OBJ(("pop => discarding "), valuePtr);
|
||
TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
|
||
ADJUST_PC(1);
|
||
|
||
case INST_DUP:
|
||
valuePtr = stackPtr[stackTop].o;
|
||
PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
|
||
TRACE_WITH_OBJ(("dup => "), 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++) {
|
||
valuePtr = stackPtr[i].o;
|
||
bytes = TclGetStringFromObj(valuePtr, &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].o;
|
||
bytes = TclGetStringFromObj(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++) {
|
||
valuePtr = stackPtr[i].o;
|
||
Tcl_DecrRefCount(valuePtr);
|
||
}
|
||
}
|
||
stackTop -= opnd;
|
||
|
||
PUSH_OBJECT(concatObjPtr);
|
||
TRACE_WITH_OBJ(("concat %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:
|
||
{
|
||
char *cmdName;
|
||
Command *cmdPtr; /* Points to command's Command struct. */
|
||
int objc = opnd; /* The number of arguments. */
|
||
Tcl_Obj **objv; /* The array of argument objects. */
|
||
Tcl_Obj *objv0Ptr; /* Holds objv[0], the command name. */
|
||
int newPcOffset = 0;
|
||
/* Instruction offset computed during
|
||
* break, continue, error processing.
|
||
* Init. to avoid compiler warning. */
|
||
Tcl_Command cmd;
|
||
#ifdef TCL_COMPILE_DEBUG
|
||
int isUnknownCmd = 0;
|
||
char cmdNameBuf[30];
|
||
#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;
|
||
}
|
||
|
||
objv = &(stackPtr[stackTop - (objc-1)].o);
|
||
objv0Ptr = objv[0];
|
||
cmdName = TclGetStringFromObj(objv0Ptr, (int *) NULL);
|
||
|
||
/*
|
||
* Find the procedure to execute this command. If there
|
||
* isn't one, then see if there is a command "unknown". If
|
||
* so, invoke it, passing it the original command words as
|
||
* arguments.
|
||
*
|
||
* We convert the objv[0] object to be a CmdName object.
|
||
* This caches a pointer to the Command structure for the
|
||
* command; this pointer is held in a ResolvedCmdName
|
||
* structure the object's internal rep. points to.
|
||
*/
|
||
|
||
cmd = Tcl_GetCommandFromObj(interp, objv0Ptr);
|
||
cmdPtr = (Command *) cmd;
|
||
|
||
/*
|
||
* If the command is still not found, handle it with the
|
||
* "unknown" proc.
|
||
*/
|
||
|
||
if (cmdPtr == NULL) {
|
||
cmd = Tcl_FindCommand(interp, "unknown",
|
||
(Tcl_Namespace *) NULL, /*flags*/ TCL_GLOBAL_ONLY);
|
||
if (cmd == (Tcl_Command) NULL) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
|
||
"invalid command name \"", cmdName, "\"",
|
||
(char *) NULL);
|
||
TRACE(("%s %u => unknown proc not found: ",
|
||
opName[opCode], objc));
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
cmdPtr = (Command *) cmd;
|
||
#ifdef TCL_COMPILE_DEBUG
|
||
isUnknownCmd = 1;
|
||
#endif /*TCL_COMPILE_DEBUG*/
|
||
stackTop++; /* need room for new inserted objv[0] */
|
||
for (i = objc; 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) {
|
||
char buffer[50];
|
||
|
||
sprintf(buffer, "%d: (%u) invoking ", iPtr->numLevels,
|
||
(unsigned int)(pc - codePtr->codeStart));
|
||
Tcl_DStringAppend(&command, buffer, -1);
|
||
|
||
#ifdef TCL_COMPILE_DEBUG
|
||
if (traceInstructions) { /* tclTraceExec == 3 */
|
||
strncpy(cmdNameBuf, cmdName, 20);
|
||
TRACE(("%s %u => call ", opName[opCode],
|
||
(isUnknownCmd? objc-1 : objc)));
|
||
} else {
|
||
fprintf(stdout, "%s", buffer);
|
||
}
|
||
#else /* TCL_COMPILE_DEBUG */
|
||
fprintf(stdout, "%s", buffer);
|
||
#endif /*TCL_COMPILE_DEBUG*/
|
||
|
||
for (i = 0; i < objc; i++) {
|
||
bytes = TclGetStringFromObj(objv[i], &length);
|
||
TclPrintSource(stdout, bytes, TclMin(length, 15));
|
||
fprintf(stdout, " ");
|
||
|
||
sprintf(buffer, "\"%.*s\" ", TclMin(length, 15), bytes);
|
||
Tcl_DStringAppend(&command, buffer, -1);
|
||
}
|
||
fprintf(stdout, "\n");
|
||
fflush(stdout);
|
||
|
||
Tcl_DStringFree(&command);
|
||
}
|
||
|
||
iPtr->cmdCount++;
|
||
DECACHE_STACK_INFO();
|
||
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
|
||
objc, objv);
|
||
if (Tcl_AsyncReady()) {
|
||
result = Tcl_AsyncInvoke(interp, result);
|
||
}
|
||
CACHE_STACK_INFO();
|
||
|
||
/*
|
||
* 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);
|
||
}
|
||
|
||
/*
|
||
* Pop the objc top stack elements and decrement their ref
|
||
* counts.
|
||
*/
|
||
|
||
i = (stackTop - (objc-1));
|
||
while (i <= stackTop) {
|
||
valuePtr = stackPtr[i].o;
|
||
TclDecrRefCount(valuePtr);
|
||
i++;
|
||
}
|
||
stackTop -= objc;
|
||
|
||
/*
|
||
* 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(("%s %u => ...after \"%.20s\", result=",
|
||
opName[opCode], 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 = TclGetExceptionRangeForPc(pc,
|
||
/*catchOnly*/ 0, codePtr);
|
||
if (rangePtr == NULL) {
|
||
TRACE(("%s %u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
|
||
opName[opCode], objc, cmdNameBuf,
|
||
StringForResultCode(result)));
|
||
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(("%s %u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
|
||
opName[opCode], objc, cmdNameBuf,
|
||
StringForResultCode(result)));
|
||
goto checkForCatch;
|
||
} else {
|
||
newPcOffset = rangePtr->continueOffset;
|
||
}
|
||
TRACE(("%s %u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
|
||
opName[opCode], objc, cmdNameBuf,
|
||
StringForResultCode(result),
|
||
rangePtr->codeOffset, newPcOffset));
|
||
break;
|
||
case CATCH_EXCEPTION_RANGE:
|
||
TRACE(("%s %u => ... after \"%.20s\", %s...\n",
|
||
opName[opCode], objc, cmdNameBuf,
|
||
StringForResultCode(result)));
|
||
goto processCatch; /* it will use rangePtr */
|
||
default:
|
||
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
|
||
}
|
||
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(("%s %u => ... after \"%.20s\", TCL_ERROR ",
|
||
opName[opCode], 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(("%s %u => ... after \"%.20s\", TCL_RETURN\n",
|
||
opName[opCode], objc, cmdNameBuf));
|
||
goto checkForCatch;
|
||
|
||
default:
|
||
TRACE_WITH_OBJ(("%s %u => ... after \"%.20s\", OTHER RETURN CODE %d ",
|
||
opName[opCode], objc, cmdNameBuf, result),
|
||
Tcl_GetObjResult(interp));
|
||
goto checkForCatch;
|
||
} /* end of switch on result from invoke instruction */
|
||
}
|
||
|
||
case INST_EVAL_STK:
|
||
objPtr = POP_OBJECT();
|
||
DECACHE_STACK_INFO();
|
||
result = Tcl_EvalObj(interp, objPtr);
|
||
CACHE_STACK_INFO();
|
||
if (result == TCL_OK) {
|
||
/*
|
||
* Normal return; push the eval's object result.
|
||
*/
|
||
|
||
PUSH_OBJECT(Tcl_GetObjResult(interp));
|
||
TRACE_WITH_OBJ(("evalStk \"%.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 = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0,
|
||
codePtr);
|
||
if (rangePtr == NULL) {
|
||
TRACE(("evalStk \"%.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(("evalStk \"%.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(("evalStk \"%.30s\" => %s, range at %d, new pc %d ",
|
||
O2S(objPtr), StringForResultCode(result),
|
||
rangePtr->codeOffset, newPcOffset), valuePtr);
|
||
break;
|
||
case CATCH_EXCEPTION_RANGE:
|
||
TRACE_WITH_OBJ(("evalStk \"%.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(("evalStk \"%.30s\" => ERROR: ", O2S(objPtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(objPtr);
|
||
goto checkForCatch;
|
||
}
|
||
|
||
case INST_EXPR_STK:
|
||
objPtr = POP_OBJECT();
|
||
Tcl_ResetResult(interp);
|
||
DECACHE_STACK_INFO();
|
||
result = Tcl_ExprObj(interp, objPtr, &valuePtr);
|
||
CACHE_STACK_INFO();
|
||
if (result != TCL_OK) {
|
||
TRACE_WITH_OBJ(("exprStk \"%.30s\" => ERROR: ",
|
||
O2S(objPtr)), Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(objPtr);
|
||
goto checkForCatch;
|
||
}
|
||
stackPtr[++stackTop].o = valuePtr; /* already has right refct */
|
||
TRACE_WITH_OBJ(("exprStk \"%.30s\" => ", O2S(objPtr)), valuePtr);
|
||
TclDecrRefCount(objPtr);
|
||
ADJUST_PC(1);
|
||
|
||
case INST_LOAD_SCALAR4:
|
||
opnd = TclGetInt4AtPtr(pc+1);
|
||
pcAdjustment = 5;
|
||
goto doLoadScalar;
|
||
|
||
case INST_LOAD_SCALAR1:
|
||
opnd = TclGetUInt1AtPtr(pc+1);
|
||
pcAdjustment = 2;
|
||
|
||
doLoadScalar:
|
||
DECACHE_STACK_INFO();
|
||
valuePtr = TclGetIndexedScalar(interp, opnd,
|
||
/*leaveErrorMsg*/ 1);
|
||
CACHE_STACK_INFO();
|
||
if (valuePtr == NULL) {
|
||
TRACE_WITH_OBJ(("%s %u => ERROR: ", opName[opCode], opnd),
|
||
Tcl_GetObjResult(interp));
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(valuePtr);
|
||
TRACE_WITH_OBJ(("%s %u => ", opName[opCode], opnd), valuePtr);
|
||
ADJUST_PC(pcAdjustment);
|
||
|
||
case INST_LOAD_SCALAR_STK:
|
||
namePtr = POP_OBJECT();
|
||
DECACHE_STACK_INFO();
|
||
valuePtr = Tcl_ObjGetVar2(interp, namePtr, (Tcl_Obj *) NULL,
|
||
TCL_LEAVE_ERR_MSG);
|
||
CACHE_STACK_INFO();
|
||
if (valuePtr == NULL) {
|
||
TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ERROR: ",
|
||
O2S(namePtr)), Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(valuePtr);
|
||
TRACE_WITH_OBJ(("loadScalarStk \"%.30s\" => ",
|
||
O2S(namePtr)), valuePtr);
|
||
TclDecrRefCount(namePtr);
|
||
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(("%s %u \"%.30s\" => ERROR: ",
|
||
opName[opCode], opnd, O2S(elemPtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(elemPtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(valuePtr);
|
||
TRACE_WITH_OBJ(("%s %u \"%.30s\" => ",
|
||
opName[opCode], opnd, O2S(elemPtr)), valuePtr);
|
||
TclDecrRefCount(elemPtr);
|
||
}
|
||
ADJUST_PC(pcAdjustment);
|
||
|
||
case INST_LOAD_ARRAY_STK:
|
||
{
|
||
Tcl_Obj *elemPtr = POP_OBJECT();
|
||
|
||
namePtr = POP_OBJECT();
|
||
DECACHE_STACK_INFO();
|
||
valuePtr = Tcl_ObjGetVar2(interp, namePtr, elemPtr,
|
||
TCL_LEAVE_ERR_MSG);
|
||
CACHE_STACK_INFO();
|
||
if (valuePtr == NULL) {
|
||
TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ERROR: ",
|
||
O2S(namePtr), O2S(elemPtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(elemPtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(valuePtr);
|
||
TRACE_WITH_OBJ(("loadArrayStk \"%.30s(%.30s)\" => ",
|
||
O2S(namePtr), O2S(elemPtr)), valuePtr);
|
||
TclDecrRefCount(namePtr);
|
||
TclDecrRefCount(elemPtr);
|
||
}
|
||
ADJUST_PC(1);
|
||
|
||
case INST_LOAD_STK:
|
||
namePtr = POP_OBJECT();
|
||
DECACHE_STACK_INFO();
|
||
valuePtr = Tcl_ObjGetVar2(interp, namePtr, NULL,
|
||
TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG);
|
||
CACHE_STACK_INFO();
|
||
if (valuePtr == NULL) {
|
||
TRACE_WITH_OBJ(("loadStk \"%.30s\" => ERROR: ",
|
||
O2S(namePtr)), Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(valuePtr);
|
||
TRACE_WITH_OBJ(("loadStk \"%.30s\" => ", O2S(namePtr)),
|
||
valuePtr);
|
||
TclDecrRefCount(namePtr);
|
||
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(("%s %u <- \"%.30s\" => ERROR: ",
|
||
opName[opCode], opnd, O2S(valuePtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(valuePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("%s %u <- \"%.30s\" => ",
|
||
opName[opCode], opnd, O2S(valuePtr)), value2Ptr);
|
||
TclDecrRefCount(valuePtr);
|
||
ADJUST_PC(pcAdjustment);
|
||
|
||
case INST_STORE_SCALAR_STK:
|
||
valuePtr = POP_OBJECT();
|
||
namePtr = POP_OBJECT();
|
||
DECACHE_STACK_INFO();
|
||
value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr,
|
||
TCL_LEAVE_ERR_MSG);
|
||
CACHE_STACK_INFO();
|
||
if (value2Ptr == NULL) {
|
||
TRACE_WITH_OBJ(
|
||
("storeScalarStk \"%.30s\" <- \"%.30s\" => ERROR: ",
|
||
O2S(namePtr), O2S(valuePtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(
|
||
("storeScalarStk \"%.30s\" <- \"%.30s\" => ",
|
||
O2S(namePtr),
|
||
O2S(valuePtr)),
|
||
value2Ptr);
|
||
TclDecrRefCount(namePtr);
|
||
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(
|
||
("%s %u \"%.30s\" <- \"%.30s\" => ERROR: ",
|
||
opName[opCode], 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(("%s %u \"%.30s\" <- \"%.30s\" => ",
|
||
opName[opCode], 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();
|
||
namePtr = POP_OBJECT();
|
||
DECACHE_STACK_INFO();
|
||
value2Ptr = Tcl_ObjSetVar2(interp, namePtr, elemPtr,
|
||
valuePtr, TCL_LEAVE_ERR_MSG);
|
||
CACHE_STACK_INFO();
|
||
if (value2Ptr == NULL) {
|
||
TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
|
||
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(elemPtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("storeArrayStk \"%.30s(%.30s)\" <- \"%.30s\" => ",
|
||
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
|
||
value2Ptr);
|
||
TclDecrRefCount(namePtr);
|
||
TclDecrRefCount(elemPtr);
|
||
TclDecrRefCount(valuePtr);
|
||
}
|
||
ADJUST_PC(1);
|
||
|
||
case INST_STORE_STK:
|
||
valuePtr = POP_OBJECT();
|
||
namePtr = POP_OBJECT();
|
||
DECACHE_STACK_INFO();
|
||
value2Ptr = Tcl_ObjSetVar2(interp, namePtr, NULL, valuePtr,
|
||
TCL_PARSE_PART1|TCL_LEAVE_ERR_MSG);
|
||
CACHE_STACK_INFO();
|
||
if (value2Ptr == NULL) {
|
||
TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ERROR: ",
|
||
O2S(namePtr), O2S(valuePtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("storeStk \"%.30s\" <- \"%.30s\" => ",
|
||
O2S(namePtr), O2S(valuePtr)), value2Ptr);
|
||
TclDecrRefCount(namePtr);
|
||
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(("incrScalar1 %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(("incrScalar1 %u (by %ld) => ERROR: ",
|
||
opnd, i), Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(valuePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("incrScalar1 %u (by %ld) => ", opnd, i),
|
||
value2Ptr);
|
||
TclDecrRefCount(valuePtr);
|
||
ADJUST_PC(2);
|
||
|
||
case INST_INCR_SCALAR_STK:
|
||
case INST_INCR_STK:
|
||
valuePtr = POP_OBJECT();
|
||
namePtr = POP_OBJECT();
|
||
if (valuePtr->typePtr != &tclIntType) {
|
||
result = tclIntType.setFromAnyProc(interp, valuePtr);
|
||
if (result != TCL_OK) {
|
||
TRACE_WITH_OBJ(("%s \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
|
||
opName[opCode], O2S(namePtr), O2S(valuePtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
goto checkForCatch;
|
||
}
|
||
}
|
||
i = valuePtr->internalRep.longValue;
|
||
DECACHE_STACK_INFO();
|
||
value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i,
|
||
/*part1NotParsed*/ (opCode == INST_INCR_STK));
|
||
CACHE_STACK_INFO();
|
||
if (value2Ptr == NULL) {
|
||
TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ERROR: ",
|
||
opName[opCode], O2S(namePtr), i),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("%s \"%.30s\" (by %ld) => ",
|
||
opName[opCode], O2S(namePtr), i), value2Ptr);
|
||
Tcl_DecrRefCount(namePtr);
|
||
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(("incrArray1 %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(("incrArray1 %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(("incrArray1 %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();
|
||
namePtr = POP_OBJECT();
|
||
if (valuePtr->typePtr != &tclIntType) {
|
||
result = tclIntType.setFromAnyProc(interp, valuePtr);
|
||
if (result != TCL_OK) {
|
||
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
|
||
O2S(namePtr), O2S(elemPtr), O2S(valuePtr)),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(elemPtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
goto checkForCatch;
|
||
}
|
||
}
|
||
i = valuePtr->internalRep.longValue;
|
||
DECACHE_STACK_INFO();
|
||
value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i,
|
||
/*part1NotParsed*/ 0);
|
||
CACHE_STACK_INFO();
|
||
if (value2Ptr == NULL) {
|
||
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ERROR: ",
|
||
O2S(namePtr), O2S(elemPtr), i),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(elemPtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("incrArrayStk \"%.30s(%.30s)\" (by %ld) => ",
|
||
O2S(namePtr), O2S(elemPtr), i), value2Ptr);
|
||
Tcl_DecrRefCount(namePtr);
|
||
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(("incrScalar1Imm %u %ld => ERROR: ",
|
||
opnd, i), Tcl_GetObjResult(interp));
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("incrScalar1Imm %u %ld => ", opnd, i),
|
||
value2Ptr);
|
||
ADJUST_PC(3);
|
||
|
||
case INST_INCR_SCALAR_STK_IMM:
|
||
case INST_INCR_STK_IMM:
|
||
namePtr = POP_OBJECT();
|
||
i = TclGetInt1AtPtr(pc+1);
|
||
DECACHE_STACK_INFO();
|
||
value2Ptr = TclIncrVar2(interp, namePtr, (Tcl_Obj *) NULL, i,
|
||
/*part1NotParsed*/ (opCode == INST_INCR_STK_IMM));
|
||
CACHE_STACK_INFO();
|
||
if (value2Ptr == NULL) {
|
||
TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ERROR: ",
|
||
opName[opCode], O2S(namePtr), i),
|
||
Tcl_GetObjResult(interp));
|
||
result = TCL_ERROR;
|
||
Tcl_DecrRefCount(namePtr);
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("%s \"%.30s\" %ld => ",
|
||
opName[opCode], O2S(namePtr), i), value2Ptr);
|
||
TclDecrRefCount(namePtr);
|
||
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(("incrArray1Imm %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(("incrArray1Imm %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();
|
||
namePtr = POP_OBJECT();
|
||
DECACHE_STACK_INFO();
|
||
value2Ptr = TclIncrVar2(interp, namePtr, elemPtr, i,
|
||
/*part1NotParsed*/ 0);
|
||
CACHE_STACK_INFO();
|
||
if (value2Ptr == NULL) {
|
||
TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ERROR: ",
|
||
O2S(namePtr), O2S(elemPtr), i),
|
||
Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(elemPtr);
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
PUSH_OBJECT(value2Ptr);
|
||
TRACE_WITH_OBJ(("incrArrayStkImm \"%.30s(%.30s)\" (by %ld) => ",
|
||
O2S(namePtr), O2S(elemPtr), i), value2Ptr);
|
||
Tcl_DecrRefCount(namePtr);
|
||
Tcl_DecrRefCount(elemPtr);
|
||
}
|
||
ADJUST_PC(2);
|
||
|
||
case INST_JUMP1:
|
||
opnd = TclGetInt1AtPtr(pc+1);
|
||
TRACE(("jump1 %d => new pc %u\n", opnd,
|
||
(unsigned int)(pc + opnd - codePtr->codeStart)));
|
||
ADJUST_PC(opnd);
|
||
|
||
case INST_JUMP4:
|
||
opnd = TclGetInt4AtPtr(pc+1);
|
||
TRACE(("jump4 %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(("%s %d => ERROR: ", opName[opCode],
|
||
opnd), Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(valuePtr);
|
||
goto checkForCatch;
|
||
}
|
||
}
|
||
if (b) {
|
||
TRACE(("%s %d => %.20s true, new pc %u\n",
|
||
opName[opCode], opnd, O2S(valuePtr),
|
||
(unsigned int)(pc+opnd - codePtr->codeStart)));
|
||
TclDecrRefCount(valuePtr);
|
||
ADJUST_PC(opnd);
|
||
} else {
|
||
TRACE(("%s %d => %.20s false\n", opName[opCode], 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(("%s %d => ERROR: ", opName[opCode],
|
||
opnd), Tcl_GetObjResult(interp));
|
||
Tcl_DecrRefCount(valuePtr);
|
||
goto checkForCatch;
|
||
}
|
||
}
|
||
if (b) {
|
||
TRACE(("%s %d => %.20s true\n", opName[opCode], opnd,
|
||
O2S(valuePtr)));
|
||
TclDecrRefCount(valuePtr);
|
||
ADJUST_PC(pcAdjustment);
|
||
} else {
|
||
TRACE(("%s %d => %.20s false, new pc %u\n",
|
||
opName[opCode], 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 { /* FAILS IF NULL STRING REP */
|
||
s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
if (TclLooksLikeInt(s)) {
|
||
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(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
|
||
opName[opCode], O2S(valuePtr),
|
||
(t1Ptr? t1Ptr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, 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 { /* FAILS IF NULL STRING REP */
|
||
s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL);
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
||
value2Ptr, &i);
|
||
i2 = (i != 0);
|
||
} else {
|
||
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
|
||
value2Ptr, &i2);
|
||
i2 = (i2 != 0);
|
||
}
|
||
if (result != TCL_OK) {
|
||
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
|
||
opName[opCode], O2S(value2Ptr),
|
||
(t2Ptr? t2Ptr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, value2Ptr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
Tcl_DecrRefCount(value2Ptr);
|
||
goto checkForCatch;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Reuse the valuePtr object already on stack if possible.
|
||
*/
|
||
|
||
if (opCode == INST_LOR) {
|
||
iResult = (i1 || i2);
|
||
} else {
|
||
iResult = (i1 && i2);
|
||
}
|
||
if (Tcl_IsShared(valuePtr)) {
|
||
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
||
TRACE(("%s %.20s %.20s => %d\n", opName[opCode],
|
||
O2S(valuePtr), O2S(value2Ptr), iResult));
|
||
TclDecrRefCount(valuePtr);
|
||
} else { /* reuse the valuePtr object */
|
||
TRACE(("%s %.20s %.20s => %d\n",
|
||
opName[opCode], /* NB: stack top is off by 1 */
|
||
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;
|
||
|
||
if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
|
||
s1 = Tcl_GetStringFromObj(valuePtr, &length);
|
||
if (TclLooksLikeInt(s1)) { /* FAILS IF NULLS */
|
||
(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)) { /* FAILS IF NULLS */
|
||
(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.
|
||
* THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS.
|
||
*/
|
||
int cmpValue;
|
||
s1 = TclGetStringFromObj(valuePtr, &length);
|
||
s2 = TclGetStringFromObj(value2Ptr, &length);
|
||
cmpValue = strcmp(s1, s2);
|
||
switch (opCode) {
|
||
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 (opCode) {
|
||
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 (opCode) {
|
||
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(("%s %.20s %.20s => %ld\n", opName[opCode],
|
||
O2S(valuePtr), O2S(value2Ptr), iResult));
|
||
TclDecrRefCount(valuePtr);
|
||
} else { /* reuse the valuePtr object */
|
||
TRACE(("%s %.20s %.20s => %ld\n",
|
||
opName[opCode], /* NB: stack top is off by 1 */
|
||
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(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n",
|
||
opName[opCode], O2S(valuePtr), O2S(value2Ptr),
|
||
(valuePtr->typePtr?
|
||
valuePtr->typePtr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, 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(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n",
|
||
opName[opCode], O2S(valuePtr), O2S(value2Ptr),
|
||
(value2Ptr->typePtr?
|
||
value2Ptr->typePtr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, value2Ptr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
Tcl_DecrRefCount(value2Ptr);
|
||
goto checkForCatch;
|
||
}
|
||
}
|
||
|
||
switch (opCode) {
|
||
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(("mod %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(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
|
||
iResult));
|
||
TclDecrRefCount(valuePtr);
|
||
} else { /* reuse the valuePtr object */
|
||
TRACE(("%s %ld %ld => %ld\n", opName[opCode], i, i2,
|
||
iResult)); /* NB: stack top is off by 1 */
|
||
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) {
|
||
d1 = valuePtr->internalRep.doubleValue;
|
||
} else { /* try to convert; FAILS IF NULLS */
|
||
char *s = Tcl_GetStringFromObj(valuePtr, &length);
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
||
valuePtr, &i);
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
||
valuePtr, &d1);
|
||
}
|
||
if (result != TCL_OK) {
|
||
TRACE(("%s %.20s %.20s => ILLEGAL 1st TYPE %s\n",
|
||
opName[opCode], s, O2S(value2Ptr),
|
||
(valuePtr->typePtr?
|
||
valuePtr->typePtr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, valuePtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
Tcl_DecrRefCount(value2Ptr);
|
||
goto checkForCatch;
|
||
}
|
||
t1Ptr = valuePtr->typePtr;
|
||
}
|
||
|
||
if (t2Ptr == &tclIntType) {
|
||
i2 = value2Ptr->internalRep.longValue;
|
||
} else if (t2Ptr == &tclDoubleType) {
|
||
d2 = value2Ptr->internalRep.doubleValue;
|
||
} else { /* try to convert; FAILS IF NULLS */
|
||
char *s = Tcl_GetStringFromObj(value2Ptr, &length);
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
||
value2Ptr, &i2);
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
||
value2Ptr, &d2);
|
||
}
|
||
if (result != TCL_OK) {
|
||
TRACE(("%s %.20s %.20s => ILLEGAL 2nd TYPE %s\n",
|
||
opName[opCode], O2S(valuePtr), s,
|
||
(value2Ptr->typePtr?
|
||
value2Ptr->typePtr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, 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 (opCode) {
|
||
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(("div %.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(("%s %.20s %.20s => IEEE FLOATING PT ERROR\n",
|
||
opName[opCode], O2S(valuePtr), O2S(value2Ptr)));
|
||
TclExprFloatError(interp, dResult);
|
||
result = TCL_ERROR;
|
||
Tcl_DecrRefCount(valuePtr);
|
||
Tcl_DecrRefCount(value2Ptr);
|
||
goto checkForCatch;
|
||
}
|
||
} else {
|
||
/*
|
||
* Do integer arithmetic.
|
||
*/
|
||
switch (opCode) {
|
||
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(("div %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(("%s %.6g %.6g => %.6g\n", opName[opCode],
|
||
d1, d2, dResult));
|
||
} else {
|
||
PUSH_OBJECT(Tcl_NewLongObj(iResult));
|
||
TRACE(("%s %ld %ld => %ld\n", opName[opCode],
|
||
i, i2, iResult));
|
||
}
|
||
TclDecrRefCount(valuePtr);
|
||
} else { /* reuse the valuePtr object */
|
||
if (doDouble) { /* NB: stack top is off by 1 */
|
||
TRACE(("%s %.6g %.6g => %.6g\n", opName[opCode],
|
||
d1, d2, dResult));
|
||
Tcl_SetDoubleObj(valuePtr, dResult);
|
||
} else {
|
||
TRACE(("%s %ld %ld => %ld\n", opName[opCode],
|
||
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].o;
|
||
tPtr = valuePtr->typePtr;
|
||
if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
|
||
char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
||
valuePtr, &i);
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
||
valuePtr, &d);
|
||
}
|
||
if (result != TCL_OK) {
|
||
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s \n",
|
||
opName[opCode], s,
|
||
(tPtr? tPtr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, valuePtr);
|
||
goto checkForCatch;
|
||
}
|
||
}
|
||
TRACE_WITH_OBJ(("uplus %s => ", O2S(valuePtr)), valuePtr);
|
||
}
|
||
ADJUST_PC(1);
|
||
|
||
case INST_UMINUS:
|
||
case INST_LNOT:
|
||
{
|
||
/*
|
||
* The operand must be numeric. 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;
|
||
Tcl_ObjType *tPtr;
|
||
|
||
valuePtr = POP_OBJECT();
|
||
tPtr = valuePtr->typePtr;
|
||
if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
|
||
char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
|
||
valuePtr, &i);
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
||
valuePtr, &d);
|
||
}
|
||
if (result != TCL_OK) {
|
||
TRACE(("%s \"%.20s\" => ILLEGAL TYPE %s\n",
|
||
opName[opCode], s,
|
||
(tPtr? tPtr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, valuePtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
goto checkForCatch;
|
||
}
|
||
tPtr = valuePtr->typePtr;
|
||
}
|
||
|
||
if (Tcl_IsShared(valuePtr)) {
|
||
/*
|
||
* Create a new object.
|
||
*/
|
||
if (tPtr == &tclIntType) {
|
||
i = valuePtr->internalRep.longValue;
|
||
objPtr = Tcl_NewLongObj(
|
||
(opCode == INST_UMINUS)? -i : !i);
|
||
TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i),
|
||
objPtr); /* NB: stack top is off by 1 */
|
||
} else {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
if (opCode == 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(("%s %.6g => ", opName[opCode], d),
|
||
objPtr); /* NB: stack top is off by 1 */
|
||
}
|
||
PUSH_OBJECT(objPtr);
|
||
TclDecrRefCount(valuePtr);
|
||
} else {
|
||
/*
|
||
* valuePtr is unshared. Modify it directly.
|
||
*/
|
||
if (tPtr == &tclIntType) {
|
||
i = valuePtr->internalRep.longValue;
|
||
Tcl_SetLongObj(valuePtr,
|
||
(opCode == INST_UMINUS)? -i : !i);
|
||
TRACE_WITH_OBJ(("%s %ld => ", opName[opCode], i),
|
||
valuePtr); /* NB: stack top is off by 1 */
|
||
} else {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
if (opCode == 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(("%s %.6g => ", opName[opCode], d),
|
||
valuePtr); /* NB: stack top is off by 1 */
|
||
}
|
||
++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(("bitnot \"%.20s\" => ILLEGAL TYPE %s\n",
|
||
O2S(valuePtr), (tPtr? tPtr->name : "null")));
|
||
IllegalExprOperandType(interp, opCode, valuePtr);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
goto checkForCatch;
|
||
}
|
||
}
|
||
|
||
i = valuePtr->internalRep.longValue;
|
||
if (Tcl_IsShared(valuePtr)) {
|
||
PUSH_OBJECT(Tcl_NewLongObj(~i));
|
||
TRACE(("bitnot 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(("bitnot 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;
|
||
|
||
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();
|
||
tcl_MathInProgress++;
|
||
result = (*mathFuncPtr->proc)(interp, eePtr,
|
||
mathFuncPtr->clientData);
|
||
tcl_MathInProgress--;
|
||
CACHE_STACK_INFO();
|
||
if (result != TCL_OK) {
|
||
goto checkForCatch;
|
||
}
|
||
TRACE_WITH_OBJ(("callBuiltinFunc1 %d => ", opnd),
|
||
stackPtr[stackTop].o);
|
||
}
|
||
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]. */
|
||
|
||
objv = &(stackPtr[stackTop - (objc-1)].o); /* "objv[0]" */
|
||
DECACHE_STACK_INFO();
|
||
tcl_MathInProgress++;
|
||
result = ExprCallMathFunc(interp, eePtr, objc, objv);
|
||
tcl_MathInProgress--;
|
||
CACHE_STACK_INFO();
|
||
if (result != TCL_OK) {
|
||
goto checkForCatch;
|
||
}
|
||
TRACE_WITH_OBJ(("callFunc1 %d => ", objc),
|
||
stackPtr[stackTop].o);
|
||
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].o;
|
||
tPtr = valuePtr->typePtr;
|
||
converted = 0;
|
||
if ((tPtr != &tclIntType) && (tPtr != &tclDoubleType)) {
|
||
s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
if (TclLooksLikeInt(s)) { /* FAILS IF NULLS */
|
||
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 (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;
|
||
tPtr = valuePtr->typePtr;
|
||
} else {
|
||
Tcl_InvalidateStringRep(valuePtr);
|
||
}
|
||
stackPtr[stackTop].o = valuePtr;
|
||
|
||
if (tPtr == &tclDoubleType) {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
if (IS_NAN(d) || IS_INF(d)) {
|
||
TRACE(("tryCvtToNumeric \"%.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(("tryCvtToNumeric \"%.20s\" => numeric, %s, %s\n",
|
||
O2S(valuePtr),
|
||
(converted? "converted" : "not converted"),
|
||
(shared? "shared" : "not shared")));
|
||
} else {
|
||
TRACE(("tryCvtToNumeric \"%.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 = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0,
|
||
codePtr);
|
||
if (rangePtr == NULL) {
|
||
TRACE(("break => 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(("break => range at %d, new pc %d\n",
|
||
rangePtr->codeOffset, rangePtr->breakOffset));
|
||
break;
|
||
case CATCH_EXCEPTION_RANGE:
|
||
result = TCL_BREAK;
|
||
TRACE(("break => ...\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 = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 0,
|
||
codePtr);
|
||
if (rangePtr == NULL) {
|
||
TRACE(("continue => 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(("continue => loop w/o continue, checking for catch\n"));
|
||
goto checkForCatch;
|
||
} else {
|
||
result = TCL_OK;
|
||
TRACE(("continue => range at %d, new pc %d\n",
|
||
rangePtr->codeOffset, rangePtr->continueOffset));
|
||
}
|
||
break;
|
||
case CATCH_EXCEPTION_RANGE:
|
||
result = TCL_CONTINUE;
|
||
TRACE(("continue => ...\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->loopIterNumTmp;
|
||
CallFrame *varFramePtr = iPtr->varFramePtr;
|
||
Var *compiledLocals = varFramePtr->compiledLocals;
|
||
Var *iterVarPtr;
|
||
Tcl_Obj *oldValuePtr;
|
||
|
||
iterVarPtr = &(compiledLocals[iterTmpIndex]);
|
||
oldValuePtr = iterVarPtr->value.objPtr;
|
||
if (oldValuePtr == NULL) {
|
||
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
|
||
Tcl_IncrRefCount(iterVarPtr->value.objPtr);
|
||
if (oldValuePtr != NULL) {
|
||
Tcl_DecrRefCount(oldValuePtr);
|
||
}
|
||
} else {
|
||
Tcl_SetLongObj(oldValuePtr, -1);
|
||
}
|
||
TclSetVarScalar(iterVarPtr);
|
||
TclClearVarUndefined(iterVarPtr);
|
||
TRACE(("foreach_start4 %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;
|
||
int iterTmpIndex = infoPtr->loopIterNumTmp;
|
||
CallFrame *varFramePtr = iPtr->varFramePtr;
|
||
Var *compiledLocals = varFramePtr->compiledLocals;
|
||
int iterNum, listTmpIndex, listLen, numVars;
|
||
int varIndex, valIndex, j;
|
||
Tcl_Obj *listPtr, *elemPtr, *oldValuePtr;
|
||
List *listRepPtr;
|
||
Var *iterVarPtr, *listVarPtr;
|
||
int continueLoop = 0;
|
||
|
||
/*
|
||
* Increment the temp holding the loop iteration number.
|
||
*/
|
||
|
||
iterVarPtr = &(compiledLocals[iterTmpIndex]);
|
||
oldValuePtr = iterVarPtr->value.objPtr;
|
||
iterNum = (oldValuePtr->internalRep.longValue + 1);
|
||
Tcl_SetLongObj(oldValuePtr, iterNum);
|
||
|
||
/*
|
||
* Check whether all value lists are exhausted and we should
|
||
* stop the loop.
|
||
*/
|
||
|
||
listTmpIndex = infoPtr->firstListTmp;
|
||
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(("foreach_step4 %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->firstListTmp;
|
||
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;
|
||
elemPtr = Tcl_NewObj();
|
||
} else {
|
||
elemPtr = listRepPtr->elements[valIndex];
|
||
}
|
||
|
||
varIndex = varListPtr->varIndexes[j];
|
||
DECACHE_STACK_INFO();
|
||
value2Ptr = TclSetIndexedScalar(interp,
|
||
varIndex, elemPtr, /*leaveErrorMsg*/ 1);
|
||
CACHE_STACK_INFO();
|
||
if (value2Ptr == NULL) {
|
||
TRACE_WITH_OBJ(("foreach_step4 %u => ERROR init. index temp %d: ",
|
||
opnd, varIndex),
|
||
Tcl_GetObjResult(interp));
|
||
if (setEmptyStr) {
|
||
Tcl_DecrRefCount(elemPtr); /* unneeded */
|
||
}
|
||
result = TCL_ERROR;
|
||
goto checkForCatch;
|
||
}
|
||
valIndex++;
|
||
}
|
||
listTmpIndex++;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Now push a "1" object if at least one value list had a
|
||
* remaining element and the loop should continue.
|
||
* Otherwise push "0".
|
||
*/
|
||
|
||
PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
|
||
TRACE(("foreach_step4 %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(("beginCatch4 %u => catchTop=%d, stackTop=%d\n",
|
||
TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
|
||
ADJUST_PC(5);
|
||
|
||
case INST_END_CATCH:
|
||
catchTop--;
|
||
result = TCL_OK;
|
||
TRACE(("endCatch => catchTop=%d\n", catchTop));
|
||
ADJUST_PC(1);
|
||
|
||
case INST_PUSH_RESULT:
|
||
PUSH_OBJECT(Tcl_GetObjResult(interp));
|
||
TRACE_WITH_OBJ(("pushResult => "), Tcl_GetObjResult(interp));
|
||
ADJUST_PC(1);
|
||
|
||
case INST_PUSH_RETURN_CODE:
|
||
PUSH_OBJECT(Tcl_NewLongObj(result));
|
||
TRACE(("pushReturnCode => %u\n", result));
|
||
ADJUST_PC(1);
|
||
|
||
default:
|
||
TRACE(("UNRECOGNIZED INSTRUCTION %u\n", opCode));
|
||
panic("TclExecuteByteCode: unrecognized opCode %u", opCode);
|
||
} /* 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)) {
|
||
RecordTracebackInfo(interp, pc, codePtr);
|
||
}
|
||
rangePtr = TclGetExceptionRangeForPc(pc, /*catchOnly*/ 1, codePtr);
|
||
if (rangePtr == NULL) {
|
||
TRACE((" ... no enclosing catch, returning %s\n",
|
||
StringForResultCode(result)));
|
||
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);
|
||
}
|
||
TRACE((" ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
|
||
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
|
||
(unsigned int)(rangePtr->catchOffset)));
|
||
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:
|
||
if (catchStackPtr != catchStackStorage) {
|
||
ckfree((char *) catchStackPtr);
|
||
}
|
||
eePtr->stackTop = initStackTop;
|
||
return result;
|
||
#undef STATIC_CATCH_STACK_SIZE
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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;
|
||
int numCmds = codePtr->numCommands;
|
||
int numObjs = codePtr->numObjects;
|
||
int objBytes, i;
|
||
|
||
objBytes = (numObjs * sizeof(Tcl_Obj));
|
||
for (i = 0; i < numObjs; i++) {
|
||
Tcl_Obj *litObjPtr = codePtr->objArrayPtr[i];
|
||
if (litObjPtr->bytes != NULL) {
|
||
objBytes += litObjPtr->length;
|
||
}
|
||
}
|
||
|
||
fprintf(stdout, "\nExecuting ByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x(epoch %u)\n",
|
||
(unsigned int) codePtr, codePtr->refCount,
|
||
codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
|
||
codePtr->iPtr->compileEpoch);
|
||
|
||
fprintf(stdout, " Source: ");
|
||
TclPrintSource(stdout, codePtr->source, 70);
|
||
|
||
fprintf(stdout, "\n Cmds %d, chars %d, inst %u, objs %u, aux %d, stk depth %u, code/src %.2fn",
|
||
numCmds, codePtr->numSrcChars, codePtr->numCodeBytes, numObjs,
|
||
codePtr->numAuxDataItems, codePtr->maxStackDepth,
|
||
(codePtr->numSrcChars?
|
||
((float)codePtr->totalSize)/((float)codePtr->numSrcChars) : 0.0));
|
||
|
||
fprintf(stdout, " Code %d = %d(header)+%d(inst)+%d(objs)+%d(exc)+%d(aux)+%d(cmd map)\n",
|
||
codePtr->totalSize, sizeof(ByteCode), codePtr->numCodeBytes,
|
||
objBytes, (codePtr->numExcRanges * sizeof(ExceptionRange)),
|
||
(codePtr->numAuxDataItems * sizeof(AuxData)),
|
||
codePtr->numCmdLocBytes);
|
||
|
||
if (procPtr != NULL) {
|
||
fprintf(stdout,
|
||
" Proc 0x%x, ref ct %d, args %d, compiled locals %d\n",
|
||
(unsigned int) procPtr, procPtr->refCount,
|
||
procPtr->numArgs, procPtr->numCompiledLocals);
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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 opCode holds the failing instruction's
|
||
* opcode and opndPtr holds the operand object in error.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* An error message is appended to errorInfo.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
IllegalExprOperandType(interp, opCode, opndPtr)
|
||
Tcl_Interp *interp; /* Interpreter to which error information
|
||
* pertains. */
|
||
unsigned int opCode; /* The instruction opcode being executed
|
||
* when the illegal type was found. */
|
||
Tcl_Obj *opndPtr; /* Points to the operand holding the value
|
||
* with the illegal type. */
|
||
{
|
||
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 {
|
||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
|
||
((opndPtr->typePtr == &tclDoubleType) ?
|
||
"floating-point value" : "non-numeric string"),
|
||
" 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.
|
||
* THIS FAILS IF AN OBJECT'S STRING REP CONTAINS NULLS.
|
||
*/
|
||
|
||
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);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* RecordTracebackInfo --
|
||
*
|
||
* Procedure called by TclExecuteByteCode to record information
|
||
* about what was being executed when the error occurred.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Appends information about the command being executed to the
|
||
* "errorInfo" variable. Sets the errorLine field in the interpreter
|
||
* to the line number of that command. Sets the ERR_ALREADY_LOGGED
|
||
* bit in the interpreter's execution flags.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
RecordTracebackInfo(interp, pc, codePtr)
|
||
Tcl_Interp *interp; /* The interpreter in which the error
|
||
* occurred. */
|
||
unsigned char *pc; /* The program counter value where the error * occurred. This points to a bytecode
|
||
* instruction in codePtr's code. */
|
||
ByteCode *codePtr; /* The bytecode sequence being executed. */
|
||
{
|
||
register Interp *iPtr = (Interp *) interp;
|
||
char *cmd, *ellipsis;
|
||
char buf[200];
|
||
register char *p;
|
||
int numChars;
|
||
|
||
/*
|
||
* Record the command in errorInfo (up to a certain number of
|
||
* characters, or up to the first newline).
|
||
*/
|
||
|
||
iPtr->errorLine = 1;
|
||
cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
|
||
if (cmd != NULL) {
|
||
for (p = codePtr->source; p != cmd; p++) {
|
||
if (*p == '\n') {
|
||
iPtr->errorLine++;
|
||
}
|
||
}
|
||
for ( ; (isspace(UCHAR(*p)) || (*p == ';')); p++) {
|
||
if (*p == '\n') {
|
||
iPtr->errorLine++;
|
||
}
|
||
}
|
||
|
||
ellipsis = "";
|
||
if (numChars > 150) {
|
||
numChars = 150;
|
||
ellipsis = "...";
|
||
}
|
||
if (!(iPtr->flags & ERR_IN_PROGRESS)) {
|
||
sprintf(buf, "\n while executing\n\"%.*s%s\"",
|
||
numChars, cmd, ellipsis);
|
||
} else {
|
||
sprintf(buf, "\n invoked from within\n\"%.*s%s\"",
|
||
numChars, cmd, ellipsis);
|
||
}
|
||
Tcl_AddObjErrorInfo(interp, buf, -1);
|
||
iPtr->flags |= ERR_ALREADY_LOGGED;
|
||
}
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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);
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* TclGetExceptionRangeForPc --
|
||
*
|
||
* Procedure that given a program counter value, returns the closest
|
||
* enclosing ExceptionRange that matches the kind requested.
|
||
*
|
||
* 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 (true), 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.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
ExceptionRange *
|
||
TclGetExceptionRangeForPc(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. Otherwise
|
||
* 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 = codePtr->excRangeArrayPtr;
|
||
int numRanges = codePtr->numExcRanges;
|
||
register ExceptionRange *rangePtr;
|
||
int codeOffset = (pc - codePtr->codeStart);
|
||
register int i, level;
|
||
|
||
for (level = codePtr->maxExcRangeDepth; 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 <= codeOffset) && (codeOffset < end)) {
|
||
if ((!catchOnly)
|
||
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
|
||
return rangePtr;
|
||
}
|
||
}
|
||
}
|
||
}
|
||
}
|
||
return NULL;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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. */
|
||
{
|
||
StackItem *stackPtr; /* Cached evaluation stack base pointer. */
|
||
register int stackTop; /* Cached top index of evaluation stack. */
|
||
register Tcl_Obj *valuePtr;
|
||
Tcl_ObjType *tPtr;
|
||
double d, dResult;
|
||
long i;
|
||
int result = TCL_OK;
|
||
|
||
double (*func) _ANSI_ARGS_((double)) =
|
||
(double (*)_ANSI_ARGS_((double))) clientData;
|
||
|
||
/*
|
||
* Set stackPtr and stackTop from eePtr.
|
||
*/
|
||
|
||
CACHE_STACK_INFO();
|
||
|
||
/*
|
||
* Pop the function's argument from the evaluation stack. Convert it
|
||
* to a double if necessary.
|
||
*/
|
||
|
||
valuePtr = POP_OBJECT();
|
||
tPtr = valuePtr->typePtr;
|
||
|
||
if (tPtr == &tclIntType) {
|
||
d = (double) valuePtr->internalRep.longValue;
|
||
} else if (tPtr == &tclDoubleType) {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
} else { /* FAILS IF STRING REP HAS NULLS */
|
||
char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
|
||
d = (double) valuePtr->internalRep.longValue;
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
|
||
}
|
||
if (result != TCL_OK) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||
"argument to math function didn't have numeric value", -1);
|
||
goto done;
|
||
}
|
||
}
|
||
|
||
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. */
|
||
{
|
||
StackItem *stackPtr; /* Cached evaluation stack base pointer. */
|
||
register int stackTop; /* Cached top index of evaluation stack. */
|
||
register Tcl_Obj *valuePtr, *value2Ptr;
|
||
Tcl_ObjType *tPtr;
|
||
double d1, d2, dResult;
|
||
long i;
|
||
char *s;
|
||
int result = TCL_OK;
|
||
|
||
double (*func) _ANSI_ARGS_((double, double))
|
||
= (double (*)_ANSI_ARGS_((double, double))) clientData;
|
||
|
||
/*
|
||
* Set stackPtr and stackTop from eePtr.
|
||
*/
|
||
|
||
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();
|
||
|
||
tPtr = valuePtr->typePtr;
|
||
if (tPtr == &tclIntType) {
|
||
d1 = (double) valuePtr->internalRep.longValue;
|
||
} else if (tPtr == &tclDoubleType) {
|
||
d1 = valuePtr->internalRep.doubleValue;
|
||
} else { /* FAILS IF STRING REP HAS NULLS */
|
||
s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
|
||
d1 = (double) valuePtr->internalRep.longValue;
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d1);
|
||
}
|
||
if (result != TCL_OK) {
|
||
badArg:
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||
"argument to math function didn't have numeric value", -1);
|
||
goto done;
|
||
}
|
||
}
|
||
|
||
tPtr = value2Ptr->typePtr;
|
||
if (tPtr == &tclIntType) {
|
||
d2 = value2Ptr->internalRep.longValue;
|
||
} else if (tPtr == &tclDoubleType) {
|
||
d2 = value2Ptr->internalRep.doubleValue;
|
||
} else { /* FAILS IF STRING REP HAS NULLS */
|
||
s = Tcl_GetStringFromObj(value2Ptr, (int *) NULL);
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, value2Ptr, &i);
|
||
d2 = (double) value2Ptr->internalRep.longValue;
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, value2Ptr, &d2);
|
||
}
|
||
if (result != TCL_OK) {
|
||
goto badArg;
|
||
}
|
||
}
|
||
|
||
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. */
|
||
{
|
||
StackItem *stackPtr; /* Cached evaluation stack base pointer. */
|
||
register int stackTop; /* Cached top index of evaluation stack. */
|
||
register Tcl_Obj *valuePtr;
|
||
Tcl_ObjType *tPtr;
|
||
long i, iResult;
|
||
double d, dResult;
|
||
int result = TCL_OK;
|
||
|
||
/*
|
||
* Set stackPtr and stackTop from eePtr.
|
||
*/
|
||
|
||
CACHE_STACK_INFO();
|
||
|
||
/*
|
||
* Pop the argument from the evaluation stack.
|
||
*/
|
||
|
||
valuePtr = POP_OBJECT();
|
||
tPtr = valuePtr->typePtr;
|
||
|
||
if (tPtr == &tclIntType) {
|
||
i = valuePtr->internalRep.longValue;
|
||
} else if (tPtr == &tclDoubleType) {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
} else { /* FAILS IF STRING REP HAS NULLS */
|
||
char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
|
||
}
|
||
if (result != TCL_OK) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||
"argument to math function didn't have numeric value", -1);
|
||
goto done;
|
||
}
|
||
tPtr = valuePtr->typePtr;
|
||
}
|
||
|
||
/*
|
||
* Push a Tcl object with the result.
|
||
*/
|
||
|
||
if (tPtr == &tclIntType) {
|
||
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 {
|
||
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. */
|
||
{
|
||
StackItem *stackPtr; /* Cached evaluation stack base pointer. */
|
||
register int stackTop; /* Cached top index of evaluation stack. */
|
||
register Tcl_Obj *valuePtr;
|
||
double dResult;
|
||
long i;
|
||
int result = TCL_OK;
|
||
|
||
/*
|
||
* Set stackPtr and stackTop from eePtr.
|
||
*/
|
||
|
||
CACHE_STACK_INFO();
|
||
|
||
/*
|
||
* Pop the argument from the evaluation stack.
|
||
*/
|
||
|
||
valuePtr = POP_OBJECT();
|
||
if (valuePtr->typePtr == &tclIntType) {
|
||
dResult = (double) valuePtr->internalRep.longValue;
|
||
} else if (valuePtr->typePtr == &tclDoubleType) {
|
||
dResult = valuePtr->internalRep.doubleValue;
|
||
} else { /* FAILS IF STRING REP HAS NULLS */
|
||
char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
|
||
dResult = (double) valuePtr->internalRep.longValue;
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr,
|
||
&dResult);
|
||
}
|
||
if (result != TCL_OK) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||
"argument to math function didn't have numeric value", -1);
|
||
goto done;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* 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. */
|
||
{
|
||
StackItem *stackPtr; /* Cached evaluation stack base pointer. */
|
||
register int stackTop; /* Cached top index of evaluation stack. */
|
||
register Tcl_Obj *valuePtr;
|
||
Tcl_ObjType *tPtr;
|
||
long i = 0; /* Initialized to avoid compiler warning. */
|
||
long iResult;
|
||
double d;
|
||
int result = TCL_OK;
|
||
|
||
/*
|
||
* Set stackPtr and stackTop from eePtr.
|
||
*/
|
||
|
||
CACHE_STACK_INFO();
|
||
|
||
/*
|
||
* Pop the argument from the evaluation stack.
|
||
*/
|
||
|
||
valuePtr = POP_OBJECT();
|
||
tPtr = valuePtr->typePtr;
|
||
|
||
if (tPtr == &tclIntType) {
|
||
i = valuePtr->internalRep.longValue;
|
||
} else if (tPtr == &tclDoubleType) {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
} else { /* FAILS IF STRING REP HAS NULLS */
|
||
char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
|
||
}
|
||
if (result != TCL_OK) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||
"argument to math function didn't have numeric value", -1);
|
||
goto done;
|
||
}
|
||
tPtr = valuePtr->typePtr;
|
||
}
|
||
|
||
/*
|
||
* Push a Tcl object with the result.
|
||
*/
|
||
|
||
if (tPtr == &tclIntType) {
|
||
iResult = i;
|
||
} else {
|
||
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_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. */
|
||
{
|
||
StackItem *stackPtr; /* Cached evaluation stack base pointer. */
|
||
register int stackTop; /* Cached top index of evaluation stack. */
|
||
Interp *iPtr = (Interp *) interp;
|
||
double dResult;
|
||
int tmp;
|
||
|
||
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
|
||
iPtr->flags |= RAND_SEED_INITIALIZED;
|
||
iPtr->randSeed = TclpGetClicks();
|
||
}
|
||
|
||
/*
|
||
* 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. In order to avoid
|
||
* potential problems with integer overflow, the code uses
|
||
* additional constants IQ and IR such that
|
||
* IM = IA*IQ + IR
|
||
* For 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
|
||
|
||
if (iPtr->randSeed == 0) {
|
||
/*
|
||
* Don't allow a 0 seed, since it breaks the generator. Shift
|
||
* it to some other value.
|
||
*/
|
||
|
||
iPtr->randSeed = 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;
|
||
}
|
||
|
||
/*
|
||
* On 64-bit architectures we need to mask off the upper bits to
|
||
* ensure we only have a 32-bit range. The constant has the
|
||
* bizarre form below in order to make sure that it doesn't
|
||
* get sign-extended (the rules for sign extension are very
|
||
* concat, particularly on 64-bit machines).
|
||
*/
|
||
|
||
iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
|
||
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. */
|
||
{
|
||
StackItem *stackPtr; /* Cached evaluation stack base pointer. */
|
||
register int stackTop; /* Cached top index of evaluation stack. */
|
||
Tcl_Obj *valuePtr;
|
||
Tcl_ObjType *tPtr;
|
||
long i = 0; /* Initialized to avoid compiler warning. */
|
||
long iResult;
|
||
double d, temp;
|
||
int result = TCL_OK;
|
||
|
||
/*
|
||
* Set stackPtr and stackTop from eePtr.
|
||
*/
|
||
|
||
CACHE_STACK_INFO();
|
||
|
||
/*
|
||
* Pop the argument from the evaluation stack.
|
||
*/
|
||
|
||
valuePtr = POP_OBJECT();
|
||
tPtr = valuePtr->typePtr;
|
||
|
||
if (tPtr == &tclIntType) {
|
||
i = valuePtr->internalRep.longValue;
|
||
} else if (tPtr == &tclDoubleType) {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
} else { /* FAILS IF STRING REP HAS NULLS */
|
||
char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
|
||
}
|
||
if (result != TCL_OK) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||
"argument to math function didn't have numeric value", -1);
|
||
goto done;
|
||
}
|
||
tPtr = valuePtr->typePtr;
|
||
}
|
||
|
||
/*
|
||
* Push a Tcl object with the result.
|
||
*/
|
||
|
||
if (tPtr == &tclIntType) {
|
||
iResult = i;
|
||
} else {
|
||
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_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. */
|
||
{
|
||
StackItem *stackPtr; /* Cached evaluation stack base pointer. */
|
||
register int stackTop; /* Cached top index of evaluation stack. */
|
||
Interp *iPtr = (Interp *) interp;
|
||
Tcl_Obj *valuePtr;
|
||
Tcl_ObjType *tPtr;
|
||
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();
|
||
tPtr = valuePtr->typePtr;
|
||
|
||
if (tPtr == &tclIntType) {
|
||
i = valuePtr->internalRep.longValue;
|
||
} else { /* FAILS IF STRING REP HAS NULLS */
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
|
||
if (result != TCL_OK) {
|
||
Tcl_ResetResult(interp);
|
||
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
|
||
((tPtr == &tclDoubleType)? "floating-point value" : "non-numeric string"),
|
||
" as argument to srand", (char *) NULL);
|
||
Tcl_DecrRefCount(valuePtr);
|
||
DECACHE_STACK_INFO();
|
||
return result;
|
||
}
|
||
}
|
||
|
||
/*
|
||
* Reset the seed.
|
||
*/
|
||
|
||
iPtr->flags |= RAND_SEED_INITIALIZED;
|
||
iPtr->randSeed = i;
|
||
|
||
/*
|
||
* 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;
|
||
StackItem *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;
|
||
Tcl_ObjType *tPtr;
|
||
long i;
|
||
double d;
|
||
int j, k, result;
|
||
|
||
Tcl_ResetResult(interp);
|
||
|
||
/*
|
||
* Set stackPtr and stackTop from eePtr.
|
||
*/
|
||
|
||
CACHE_STACK_INFO();
|
||
|
||
/*
|
||
* Look up the MathFunc record for the function.
|
||
* THIS FAILS IF THE OBJECT'S STRING REP CONTAINS NULLS.
|
||
*/
|
||
|
||
funcName = Tcl_GetStringFromObj(objv[0], (int *) NULL);
|
||
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];
|
||
tPtr = valuePtr->typePtr;
|
||
|
||
if (tPtr == &tclIntType) {
|
||
i = valuePtr->internalRep.longValue;
|
||
} else if (tPtr == &tclDoubleType) {
|
||
d = valuePtr->internalRep.doubleValue;
|
||
} else {
|
||
/*
|
||
* Try to convert to int first then double.
|
||
* FAILS IF STRING REP HAS NULLS.
|
||
*/
|
||
|
||
char *s = Tcl_GetStringFromObj(valuePtr, (int *) NULL);
|
||
|
||
if (TclLooksLikeInt(s)) {
|
||
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, valuePtr, &i);
|
||
} else {
|
||
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
|
||
valuePtr, &d);
|
||
}
|
||
if (result != TCL_OK) {
|
||
Tcl_AppendToObj(Tcl_GetObjResult(interp),
|
||
"argument to math function didn't have numeric value", -1);
|
||
goto done;
|
||
}
|
||
tPtr = valuePtr->typePtr;
|
||
}
|
||
|
||
/*
|
||
* Copy the object's numeric value to the argument record,
|
||
* converting it if necessary.
|
||
*/
|
||
|
||
if (tPtr == &tclIntType) {
|
||
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 {
|
||
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.
|
||
*/
|
||
|
||
tcl_MathInProgress++;
|
||
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
|
||
&funcResult);
|
||
tcl_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].o;
|
||
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 { /* FAILS IF STRING REP CONTAINS NULLS */
|
||
char msg[100];
|
||
|
||
sprintf(msg, "unknown floating-point error, errno = %d", errno);
|
||
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
|
||
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
|
||
}
|
||
}
|
||
|
||
#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. */
|
||
{
|
||
register double total = 0.0;
|
||
register int i;
|
||
int maxSizeDecade = 0;
|
||
double totalHeaderBytes = (tclNumCompilations * sizeof(ByteCode));
|
||
|
||
for (i = 0; i < 256; i++) {
|
||
if (instructionCount[i] != 0) {
|
||
total += instructionCount[i];
|
||
}
|
||
}
|
||
|
||
for (i = 31; i >= 0; i--) {
|
||
if ((tclSourceCount[i] > 0) && (tclByteCodeCount[i] > 0)) {
|
||
maxSizeDecade = i;
|
||
break;
|
||
}
|
||
}
|
||
|
||
fprintf(stdout, "\nNumber of compilations %ld\n",
|
||
tclNumCompilations);
|
||
fprintf(stdout, "Number of executions %ld\n",
|
||
numExecutions);
|
||
fprintf(stdout, "Average executions/compilation %.0f\n",
|
||
((float) numExecutions/tclNumCompilations));
|
||
|
||
fprintf(stdout, "\nInstructions executed %.0f\n",
|
||
total);
|
||
fprintf(stdout, "Average instructions/compile %.0f\n",
|
||
total/tclNumCompilations);
|
||
fprintf(stdout, "Average instructions/execution %.0f\n",
|
||
total/numExecutions);
|
||
|
||
fprintf(stdout, "\nTotal source bytes %.6g\n",
|
||
tclTotalSourceBytes);
|
||
fprintf(stdout, "Total code bytes %.6g\n",
|
||
tclTotalCodeBytes);
|
||
fprintf(stdout, "Average code/compilation %.0f\n",
|
||
tclTotalCodeBytes/tclNumCompilations);
|
||
fprintf(stdout, "Average code/source %.2f\n",
|
||
tclTotalCodeBytes/tclTotalSourceBytes);
|
||
fprintf(stdout, "Current source bytes %.6g\n",
|
||
tclCurrentSourceBytes);
|
||
fprintf(stdout, "Current code bytes %.6g\n",
|
||
tclCurrentCodeBytes);
|
||
fprintf(stdout, "Current code/source %.2f\n",
|
||
tclCurrentCodeBytes/tclCurrentSourceBytes);
|
||
|
||
fprintf(stdout, "\nTotal objects allocated %ld\n",
|
||
tclObjsAlloced);
|
||
fprintf(stdout, "Total objects freed %ld\n",
|
||
tclObjsFreed);
|
||
fprintf(stdout, "Current objects: %ld\n",
|
||
(tclObjsAlloced - tclObjsFreed));
|
||
|
||
fprintf(stdout, "\nBreakdown of code byte requirements:\n");
|
||
fprintf(stdout, " Total bytes Pct of Avg per\n");
|
||
fprintf(stdout, " all code compile\n");
|
||
fprintf(stdout, "Total code %12.6g 100%% %8.2f\n",
|
||
tclTotalCodeBytes, tclTotalCodeBytes/tclNumCompilations);
|
||
fprintf(stdout, "Header %12.6g %8.2f%% %8.2f\n",
|
||
totalHeaderBytes,
|
||
((totalHeaderBytes * 100.0) / tclTotalCodeBytes),
|
||
totalHeaderBytes/tclNumCompilations);
|
||
fprintf(stdout, "Instructions %12.6g %8.2f%% %8.2f\n",
|
||
tclTotalInstBytes,
|
||
((tclTotalInstBytes * 100.0) / tclTotalCodeBytes),
|
||
tclTotalInstBytes/tclNumCompilations);
|
||
fprintf(stdout, "Objects %12.6g %8.2f%% %8.2f\n",
|
||
tclTotalObjBytes,
|
||
((tclTotalObjBytes * 100.0) / tclTotalCodeBytes),
|
||
tclTotalObjBytes/tclNumCompilations);
|
||
fprintf(stdout, "Exception table %12.6g %8.2f%% %8.2f\n",
|
||
tclTotalExceptBytes,
|
||
((tclTotalExceptBytes * 100.0) / tclTotalCodeBytes),
|
||
tclTotalExceptBytes/tclNumCompilations);
|
||
fprintf(stdout, "Auxiliary data %12.6g %8.2f%% %8.2f\n",
|
||
tclTotalAuxBytes,
|
||
((tclTotalAuxBytes * 100.0) / tclTotalCodeBytes),
|
||
tclTotalAuxBytes/tclNumCompilations);
|
||
fprintf(stdout, "Command map %12.6g %8.2f%% %8.2f\n",
|
||
tclTotalCmdMapBytes,
|
||
((tclTotalCmdMapBytes * 100.0) / tclTotalCodeBytes),
|
||
tclTotalCmdMapBytes/tclNumCompilations);
|
||
|
||
fprintf(stdout, "\nSource and ByteCode size distributions:\n");
|
||
fprintf(stdout, " binary decade source code\n");
|
||
for (i = 0; i <= maxSizeDecade; i++) {
|
||
int decadeLow, decadeHigh;
|
||
|
||
if (i == 0) {
|
||
decadeLow = 0;
|
||
} else {
|
||
decadeLow = 1 << i;
|
||
}
|
||
decadeHigh = (1 << (i+1)) - 1;
|
||
fprintf(stdout, " %6d -%6d %6d %6d\n",
|
||
decadeLow, decadeHigh,
|
||
tclSourceCount[i], tclByteCodeCount[i]);
|
||
}
|
||
|
||
fprintf(stdout, "\nInstruction counts:\n");
|
||
for (i = 0; i < 256; i++) {
|
||
if (instructionCount[i]) {
|
||
fprintf(stdout, "%20s %8d %6.2f%%\n",
|
||
opName[i], instructionCount[i],
|
||
(instructionCount[i] * 100.0)/total);
|
||
}
|
||
}
|
||
|
||
#ifdef TCL_MEM_DEBUG
|
||
fprintf(stdout, "\nHeap Statistics:\n");
|
||
TclDumpMemoryInfo(stdout);
|
||
#endif /* TCL_MEM_DEBUG */
|
||
|
||
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;
|
||
}
|
||
}
|
||
|
||
if (cmdPtr == NULL) {
|
||
return (Tcl_Command) NULL;
|
||
}
|
||
return (Tcl_Command) cmdPtr;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* 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_GetStringFromObj(objPtr, (int *) NULL);
|
||
}
|
||
|
||
/*
|
||
* 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;
|
||
}
|
||
|
||
/*
|
||
*----------------------------------------------------------------------
|
||
*
|
||
* UpdateStringOfCmdName --
|
||
*
|
||
* Update the string representation for an cmdName object.
|
||
*
|
||
* Results:
|
||
* None.
|
||
*
|
||
* Side effects:
|
||
* Generates a panic.
|
||
*
|
||
*----------------------------------------------------------------------
|
||
*/
|
||
|
||
static void
|
||
UpdateStringOfCmdName(objPtr)
|
||
Tcl_Obj *objPtr; /* CmdName obj to update string rep. */
|
||
{
|
||
/*
|
||
* This procedure is never invoked since the internal representation of
|
||
* a cmdName object is never modified.
|
||
*/
|
||
|
||
panic("UpdateStringOfCmdName should never be invoked");
|
||
}
|
||
|
||
#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[20];
|
||
|
||
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
|
||
return resultStrings[result];
|
||
}
|
||
TclFormatInt(buf, result);
|
||
return buf;
|
||
}
|
||
#endif /* TCL_COMPILE_DEBUG */
|