|
/* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $ */ |
|
|
|
|
|
/* |
|
|
* 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. |
|
|
* |
|
|
* RCS: @(#) $Id: tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $ |
|
|
*/ |
|
|
|
|
|
#include "tclInt.h" |
|
|
#include "tclCompile.h" |
|
|
|
|
|
#ifdef NO_FLOAT_H |
|
|
# include "../compat/float.h" |
|
|
#else |
|
|
# include <float.h> |
|
|
#endif |
|
|
#ifndef TCL_NO_MATH |
|
|
#include "tclMath.h" |
|
|
#endif |
|
|
|
|
|
/* |
|
|
* The stuff below is a bit of a hack so that this file can be used |
|
|
* in environments that include no UNIX, i.e. no errno. Just define |
|
|
* errno here. |
|
|
*/ |
|
|
|
|
|
#ifndef TCL_GENERIC_ONLY |
|
|
#include "tclPort.h" |
|
|
#else |
|
|
#define NO_ERRNO_H |
|
|
#endif |
|
|
|
|
|
#ifdef NO_ERRNO_H |
|
|
int errno; |
|
|
#define EDOM 33 |
|
|
#define ERANGE 34 |
|
|
#endif |
|
|
|
|
|
/* |
|
|
* Boolean flag indicating whether the Tcl bytecode interpreter has been |
|
|
* initialized. |
|
|
*/ |
|
|
|
|
|
static int execInitialized = 0; |
|
|
TCL_DECLARE_MUTEX(execMutex) |
|
|
|
|
|
/* |
|
|
* Variable that controls whether execution tracing is enabled and, if so, |
|
|
* what level of tracing is desired: |
|
|
* 0: no execution tracing |
|
|
* 1: trace invocations of Tcl procs only |
|
|
* 2: trace invocations of all (not compiled away) commands |
|
|
* 3: display each instruction executed |
|
|
* This variable is linked to the Tcl variable "tcl_traceExec". |
|
|
*/ |
|
|
|
|
|
int tclTraceExec = 0; |
|
|
|
|
|
typedef struct ThreadSpecificData { |
|
|
/* |
|
|
* The following global variable is use to signal matherr that Tcl |
|
|
* is responsible for the arithmetic, so errors can be handled in a |
|
|
* fashion appropriate for Tcl. Zero means no Tcl math is in |
|
|
* progress; non-zero means Tcl is doing math. |
|
|
*/ |
|
|
|
|
|
int mathInProgress; |
|
|
|
|
|
} ThreadSpecificData; |
|
|
|
|
|
static Tcl_ThreadDataKey dataKey; |
|
|
|
|
|
/* |
|
|
* The variable below serves no useful purpose except to generate |
|
|
* a reference to matherr, so that the Tcl version of matherr is |
|
|
* linked in rather than the system version. Without this reference |
|
|
* the need for matherr won't be discovered during linking until after |
|
|
* libtcl.a has been processed, so Tcl's version won't be used. |
|
|
*/ |
|
|
|
|
|
#ifdef NEED_MATHERR |
|
|
extern int matherr(); |
|
|
int (*tclMatherrPtr)() = matherr; |
|
|
#endif |
|
|
|
|
|
/* |
|
|
* Mapping from expression instruction opcodes to strings; used for error |
|
|
* messages. Note that these entries must match the order and number of the |
|
|
* expression opcodes (e.g., INST_LOR) in tclCompile.h. |
|
|
*/ |
|
|
|
|
|
static char *operatorStrings[] = { |
|
|
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", |
|
|
"+", "-", "*", "/", "%", "+", "-", "~", "!", |
|
|
"BUILTIN FUNCTION", "FUNCTION" |
|
|
}; |
|
|
|
|
|
/* |
|
|
* Mapping from Tcl result codes to strings; used for error and debugging |
|
|
* messages. |
|
|
*/ |
|
|
|
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
static char *resultStrings[] = { |
|
|
"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" |
|
|
}; |
|
|
#endif |
|
|
|
|
|
/* |
|
|
* Macros for testing floating-point values for certain special cases. Test |
|
|
* for not-a-number by comparing a value against itself; test for infinity |
|
|
* by comparing against the largest floating-point value. |
|
|
*/ |
|
|
|
|
|
#define IS_NAN(v) ((v) != (v)) |
|
|
#ifdef DBL_MAX |
|
|
# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) |
|
|
#else |
|
|
# define IS_INF(v) 0 |
|
|
#endif |
|
|
|
|
|
/* |
|
|
* Macro to adjust the program counter and restart the instruction execution |
|
|
* loop after each instruction is executed. |
|
|
*/ |
|
|
|
|
|
#define ADJUST_PC(instBytes) \ |
|
|
pc += (instBytes); \ |
|
|
continue |
|
|
|
|
|
/* |
|
|
* Macros used to cache often-referenced Tcl evaluation stack information |
|
|
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() |
|
|
* pair must surround any call inside TclExecuteByteCode (and a few other |
|
|
* procedures that use this scheme) that could result in a recursive call |
|
|
* to TclExecuteByteCode. |
|
|
*/ |
|
|
|
|
|
#define CACHE_STACK_INFO() \ |
|
|
stackPtr = eePtr->stackPtr; \ |
|
|
stackTop = eePtr->stackTop |
|
|
|
|
|
#define DECACHE_STACK_INFO() \ |
|
|
eePtr->stackTop = stackTop |
|
|
|
|
|
/* |
|
|
* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT |
|
|
* increments the object's ref count since it makes the stack have another |
|
|
* reference pointing to the object. However, POP_OBJECT does not decrement |
|
|
* the ref count. This is because the stack may hold the only reference to |
|
|
* the object, so the object would be destroyed if its ref count were |
|
|
* decremented before the caller had a chance to, e.g., store it in a |
|
|
* variable. It is the caller's responsibility to decrement the ref count |
|
|
* when it is finished with an object. |
|
|
* |
|
|
* WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT |
|
|
* macro. The actual parameter might be an expression with side effects, |
|
|
* and this ensures that it will be executed only once. |
|
|
*/ |
|
|
|
|
|
#define PUSH_OBJECT(objPtr) \ |
|
|
Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr)) |
|
|
|
|
|
#define POP_OBJECT() \ |
|
|
(stackPtr[stackTop--]) |
|
|
|
|
|
/* |
|
|
* Macros used to trace instruction execution. The macros TRACE, |
|
|
* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. |
|
|
* O2S is only used in TRACE* calls to get a string from an object. |
|
|
*/ |
|
|
|
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
#define TRACE(a) \ |
|
|
if (traceInstructions) { \ |
|
|
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ |
|
|
(unsigned int)(pc - codePtr->codeStart), \ |
|
|
GetOpcodeName(pc)); \ |
|
|
printf a; \ |
|
|
} |
|
|
#define TRACE_WITH_OBJ(a, objPtr) \ |
|
|
if (traceInstructions) { \ |
|
|
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ |
|
|
(unsigned int)(pc - codePtr->codeStart), \ |
|
|
GetOpcodeName(pc)); \ |
|
|
printf a; \ |
|
|
TclPrintObject(stdout, (objPtr), 30); \ |
|
|
fprintf(stdout, "\n"); \ |
|
|
} |
|
|
#define O2S(objPtr) \ |
|
|
Tcl_GetString(objPtr) |
|
|
#else |
|
|
#define TRACE(a) |
|
|
#define TRACE_WITH_OBJ(a, objPtr) |
|
|
#define O2S(objPtr) |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
|
|
|
/* |
|
|
* Declarations for local procedures to this file: |
|
|
*/ |
|
|
|
|
|
static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
Trace *tracePtr, Command *cmdPtr, |
|
|
char *command, int numChars, |
|
|
int objc, Tcl_Obj *objv[])); |
|
|
static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, |
|
|
Tcl_Obj *copyPtr)); |
|
|
static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, ClientData clientData)); |
|
|
static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, ClientData clientData)); |
|
|
static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, int objc, Tcl_Obj **objv)); |
|
|
static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, ClientData clientData)); |
|
|
static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, ClientData clientData)); |
|
|
static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, ClientData clientData)); |
|
|
static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, ClientData clientData)); |
|
|
static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, ClientData clientData)); |
|
|
static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
ExecEnv *eePtr, ClientData clientData)); |
|
|
#ifdef TCL_COMPILE_STATS |
|
|
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, |
|
|
Tcl_Interp *interp, int argc, char **argv)); |
|
|
#endif |
|
|
static void FreeCmdNameInternalRep _ANSI_ARGS_(( |
|
|
Tcl_Obj *objPtr)); |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); |
|
|
#endif |
|
|
static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, |
|
|
int catchOnly, ByteCode* codePtr)); |
|
|
static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, |
|
|
ByteCode* codePtr, int *lengthPtr)); |
|
|
static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); |
|
|
static void IllegalExprOperandType _ANSI_ARGS_(( |
|
|
Tcl_Interp *interp, unsigned char *pc, |
|
|
Tcl_Obj *opndPtr)); |
|
|
static void InitByteCodeExecution _ANSI_ARGS_(( |
|
|
Tcl_Interp *interp)); |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); |
|
|
#endif |
|
|
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
Tcl_Obj *objPtr)); |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
static char * StringForResultCode _ANSI_ARGS_((int result)); |
|
|
static void ValidatePcAndStackTop _ANSI_ARGS_(( |
|
|
ByteCode *codePtr, unsigned char *pc, |
|
|
int stackTop, int stackLowerBound, |
|
|
int stackUpperBound)); |
|
|
#endif |
|
|
static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, |
|
|
Tcl_Obj *objPtr)); |
|
|
|
|
|
/* |
|
|
* Table describing the built-in math functions. Entries in this table are |
|
|
* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's |
|
|
* operand byte. |
|
|
*/ |
|
|
|
|
|
BuiltinFunc builtinFuncTable[] = { |
|
|
#ifndef TCL_NO_MATH |
|
|
{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, |
|
|
{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, |
|
|
{"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan}, |
|
|
{"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2}, |
|
|
{"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil}, |
|
|
{"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos}, |
|
|
{"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh}, |
|
|
{"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp}, |
|
|
{"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor}, |
|
|
{"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod}, |
|
|
{"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot}, |
|
|
{"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log}, |
|
|
{"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10}, |
|
|
{"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow}, |
|
|
{"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin}, |
|
|
{"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh}, |
|
|
{"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt}, |
|
|
{"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan}, |
|
|
{"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh}, |
|
|
#endif |
|
|
{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, |
|
|
{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, |
|
|
{"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, |
|
|
{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */ |
|
|
{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, |
|
|
{"srand", 1, {TCL_INT}, ExprSrandFunc, 0}, |
|
|
{0}, |
|
|
}; |
|
|
|
|
|
/* |
|
|
* The structure below defines the command name Tcl object type by means of |
|
|
* procedures that can be invoked by generic object code. Objects of this |
|
|
* type cache the Command pointer that results from looking up command names |
|
|
* in the command hashtable. Such objects appear as the zeroth ("command |
|
|
* name") argument in a Tcl command. |
|
|
*/ |
|
|
|
|
|
Tcl_ObjType tclCmdNameType = { |
|
|
"cmdName", /* name */ |
|
|
FreeCmdNameInternalRep, /* freeIntRepProc */ |
|
|
DupCmdNameInternalRep, /* dupIntRepProc */ |
|
|
(Tcl_UpdateStringProc *) NULL, /* updateStringProc */ |
|
|
SetCmdNameFromAny /* setFromAnyProc */ |
|
|
}; |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* InitByteCodeExecution -- |
|
|
* |
|
|
* This procedure is called once to initialize the Tcl bytecode |
|
|
* interpreter. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* This procedure initializes the array of instruction names. If |
|
|
* compiling with the TCL_COMPILE_STATS flag, it initializes the |
|
|
* array that counts the executions of each instruction and it |
|
|
* creates the "evalstats" command. It also registers the command name |
|
|
* Tcl_ObjType. It also establishes the link between the Tcl |
|
|
* "tcl_traceExec" and C "tclTraceExec" variables. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static void |
|
|
InitByteCodeExecution(interp) |
|
|
Tcl_Interp *interp; /* Interpreter for which the Tcl variable |
|
|
* "tcl_traceExec" is linked to control |
|
|
* instruction tracing. */ |
|
|
{ |
|
|
Tcl_RegisterObjType(&tclCmdNameType); |
|
|
if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, |
|
|
TCL_LINK_INT) != TCL_OK) { |
|
|
panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); |
|
|
} |
|
|
|
|
|
#ifdef TCL_COMPILE_STATS |
|
|
Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd, |
|
|
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); |
|
|
#endif /* TCL_COMPILE_STATS */ |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* TclCreateExecEnv -- |
|
|
* |
|
|
* This procedure creates a new execution environment for Tcl bytecode |
|
|
* execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv |
|
|
* is typically created once for each Tcl interpreter (Interp |
|
|
* structure) and recursively passed to TclExecuteByteCode to execute |
|
|
* ByteCode sequences for nested commands. |
|
|
* |
|
|
* Results: |
|
|
* A newly allocated ExecEnv is returned. This points to an empty |
|
|
* evaluation stack of the standard initial size. |
|
|
* |
|
|
* Side effects: |
|
|
* The bytecode interpreter is also initialized here, as this |
|
|
* procedure will be called before any call to TclExecuteByteCode. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
#define TCL_STACK_INITIAL_SIZE 2000 |
|
|
|
|
|
ExecEnv * |
|
|
TclCreateExecEnv(interp) |
|
|
Tcl_Interp *interp; /* Interpreter for which the execution |
|
|
* environment is being created. */ |
|
|
{ |
|
|
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); |
|
|
|
|
|
eePtr->stackPtr = (Tcl_Obj **) |
|
|
ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); |
|
|
eePtr->stackTop = -1; |
|
|
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1); |
|
|
|
|
|
Tcl_MutexLock(&execMutex); |
|
|
if (!execInitialized) { |
|
|
TclInitAuxDataTypeTable(); |
|
|
InitByteCodeExecution(interp); |
|
|
execInitialized = 1; |
|
|
} |
|
|
Tcl_MutexUnlock(&execMutex); |
|
|
|
|
|
return eePtr; |
|
|
} |
|
|
#undef TCL_STACK_INITIAL_SIZE |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* TclDeleteExecEnv -- |
|
|
* |
|
|
* Frees the storage for an ExecEnv. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* Storage for an ExecEnv and its contained storage (e.g. the |
|
|
* evaluation stack) is freed. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
void |
|
|
TclDeleteExecEnv(eePtr) |
|
|
ExecEnv *eePtr; /* Execution environment to free. */ |
|
|
{ |
|
|
ckfree((char *) eePtr->stackPtr); |
|
|
ckfree((char *) eePtr); |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* TclFinalizeExecution -- |
|
|
* |
|
|
* Finalizes the execution environment setup so that it can be |
|
|
* later reinitialized. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* After this call, the next time TclCreateExecEnv will be called |
|
|
* it will call InitByteCodeExecution. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
void |
|
|
TclFinalizeExecution() |
|
|
{ |
|
|
Tcl_MutexLock(&execMutex); |
|
|
execInitialized = 0; |
|
|
Tcl_MutexUnlock(&execMutex); |
|
|
TclFinalizeAuxDataTypeTable(); |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* GrowEvaluationStack -- |
|
|
* |
|
|
* This procedure grows a Tcl evaluation stack stored in an ExecEnv. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* The size of the evaluation stack is doubled. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static void |
|
|
GrowEvaluationStack(eePtr) |
|
|
register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation |
|
|
* stack to enlarge. */ |
|
|
{ |
|
|
/* |
|
|
* The current Tcl stack elements are stored from eePtr->stackPtr[0] |
|
|
* to eePtr->stackPtr[eePtr->stackEnd] (inclusive). |
|
|
*/ |
|
|
|
|
|
int currElems = (eePtr->stackEnd + 1); |
|
|
int newElems = 2*currElems; |
|
|
int currBytes = currElems * sizeof(Tcl_Obj *); |
|
|
int newBytes = 2*currBytes; |
|
|
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); |
|
|
|
|
|
/* |
|
|
* 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 Tcl_Obj **stackPtr = eePtr->stackPtr; |
|
|
/* Cached evaluation stack base pointer. */ |
|
|
register int stackTop = eePtr->stackTop; |
|
|
/* Cached top index of evaluation stack. */ |
|
|
register unsigned char *pc = codePtr->codeStart; |
|
|
/* The current program counter. */ |
|
|
int opnd; /* Current instruction's operand byte. */ |
|
|
int pcAdjustment; /* Hold pc adjustment after instruction. */ |
|
|
int initStackTop = stackTop;/* Stack top at start of execution. */ |
|
|
ExceptionRange *rangePtr; /* Points to closest loop or catch exception |
|
|
* range enclosing the pc. Used by various |
|
|
* instructions and processCatch to |
|
|
* process break, continue, and errors. */ |
|
|
int result = TCL_OK; /* Return code returned after execution. */ |
|
|
int traceInstructions = (tclTraceExec == 3); |
|
|
Tcl_Obj *valuePtr, *value2Ptr, *objPtr; |
|
|
char *bytes; |
|
|
int length; |
|
|
long i; |
|
|
|
|
|
/* |
|
|
* This procedure uses a stack to hold information about catch commands. |
|
|
* This information is the current operand stack top when starting to |
|
|
* execute the code for each catch command. It starts out with stack- |
|
|
* allocated space but uses dynamically-allocated storage if needed. |
|
|
*/ |
|
|
|
|
|
#define STATIC_CATCH_STACK_SIZE 4 |
|
|
int (catchStackStorage[STATIC_CATCH_STACK_SIZE]); |
|
|
int *catchStackPtr = catchStackStorage; |
|
|
int catchTop = -1; |
|
|
|
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
if (tclTraceExec >= 2) { |
|
|
PrintByteCodeInfo(codePtr); |
|
|
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); |
|
|
fflush(stdout); |
|
|
} |
|
|
#endif |
|
|
|
|
|
#ifdef TCL_COMPILE_STATS |
|
|
iPtr->stats.numExecutions++; |
|
|
#endif |
|
|
|
|
|
/* |
|
|
* Make sure the catch stack is large enough to hold the maximum number |
|
|
* of catch commands that could ever be executing at the same time. This |
|
|
* will be no more than the exception range array's depth. |
|
|
*/ |
|
|
|
|
|
if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) { |
|
|
catchStackPtr = (int *) |
|
|
ckalloc(codePtr->maxExceptDepth * sizeof(int)); |
|
|
} |
|
|
|
|
|
/* |
|
|
* Make sure the stack has enough room to execute this ByteCode. |
|
|
*/ |
|
|
|
|
|
while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) { |
|
|
GrowEvaluationStack(eePtr); |
|
|
stackPtr = eePtr->stackPtr; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Loop executing instructions until a "done" instruction, a TCL_RETURN, |
|
|
* or some error. |
|
|
*/ |
|
|
|
|
|
for (;;) { |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop, |
|
|
eePtr->stackEnd); |
|
|
#else /* not TCL_COMPILE_DEBUG */ |
|
|
if (traceInstructions) { |
|
|
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop); |
|
|
TclPrintInstruction(codePtr, pc); |
|
|
fflush(stdout); |
|
|
} |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
|
|
|
#ifdef TCL_COMPILE_STATS |
|
|
iPtr->stats.instructionCount[*pc]++; |
|
|
#endif |
|
|
switch (*pc) { |
|
|
case INST_DONE: |
|
|
/* |
|
|
* Pop the topmost object from the stack, set the interpreter's |
|
|
* object result to point to it, and return. |
|
|
*/ |
|
|
valuePtr = POP_OBJECT(); |
|
|
Tcl_SetObjResult(interp, valuePtr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
if (stackTop != initStackTop) { |
|
|
fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n", |
|
|
(unsigned int)(pc - codePtr->codeStart), |
|
|
(unsigned int) stackTop, |
|
|
(unsigned int) initStackTop); |
|
|
panic("TclExecuteByteCode execution failure: end stack top != start stack top"); |
|
|
} |
|
|
TRACE_WITH_OBJ(("=> return code=%d, result=", result), |
|
|
iPtr->objResultPtr); |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
if (traceInstructions) { |
|
|
fprintf(stdout, "\n"); |
|
|
} |
|
|
#endif |
|
|
goto done; |
|
|
|
|
|
case INST_PUSH1: |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; |
|
|
PUSH_OBJECT(valuePtr); |
|
|
TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr); |
|
|
#else |
|
|
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
ADJUST_PC(2); |
|
|
|
|
|
case INST_PUSH4: |
|
|
valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; |
|
|
PUSH_OBJECT(valuePtr); |
|
|
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr); |
|
|
ADJUST_PC(5); |
|
|
|
|
|
case INST_POP: |
|
|
valuePtr = POP_OBJECT(); |
|
|
TRACE_WITH_OBJ(("=> discarding "), valuePtr); |
|
|
TclDecrRefCount(valuePtr); /* finished with pop'ed object. */ |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_DUP: |
|
|
valuePtr = stackPtr[stackTop]; |
|
|
PUSH_OBJECT(Tcl_DuplicateObj(valuePtr)); |
|
|
TRACE_WITH_OBJ(("=> "), valuePtr); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_CONCAT1: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
{ |
|
|
Tcl_Obj *concatObjPtr; |
|
|
int totalLen = 0; |
|
|
|
|
|
/* |
|
|
* Concatenate strings (with no separators) from the top |
|
|
* opnd items on the stack starting with the deepest item. |
|
|
* First, determine how many characters are needed. |
|
|
*/ |
|
|
|
|
|
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { |
|
|
bytes = Tcl_GetStringFromObj(stackPtr[i], &length); |
|
|
if (bytes != NULL) { |
|
|
totalLen += length; |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
* Initialize the new append string object by appending the |
|
|
* strings of the opnd stack objects. Also pop the objects. |
|
|
*/ |
|
|
|
|
|
TclNewObj(concatObjPtr); |
|
|
if (totalLen > 0) { |
|
|
char *p = (char *) ckalloc((unsigned) (totalLen + 1)); |
|
|
concatObjPtr->bytes = p; |
|
|
concatObjPtr->length = totalLen; |
|
|
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { |
|
|
valuePtr = stackPtr[i]; |
|
|
bytes = Tcl_GetStringFromObj(valuePtr, &length); |
|
|
if (bytes != NULL) { |
|
|
memcpy((VOID *) p, (VOID *) bytes, |
|
|
(size_t) length); |
|
|
p += length; |
|
|
} |
|
|
TclDecrRefCount(valuePtr); |
|
|
} |
|
|
*p = '\0'; |
|
|
} else { |
|
|
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { |
|
|
Tcl_DecrRefCount(stackPtr[i]); |
|
|
} |
|
|
} |
|
|
stackTop -= opnd; |
|
|
|
|
|
PUSH_OBJECT(concatObjPtr); |
|
|
TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr); |
|
|
ADJUST_PC(2); |
|
|
} |
|
|
|
|
|
case INST_INVOKE_STK4: |
|
|
opnd = TclGetUInt4AtPtr(pc+1); |
|
|
pcAdjustment = 5; |
|
|
goto doInvocation; |
|
|
|
|
|
case INST_INVOKE_STK1: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
pcAdjustment = 2; |
|
|
|
|
|
doInvocation: |
|
|
{ |
|
|
int objc = opnd; /* The number of arguments. */ |
|
|
Tcl_Obj **objv; /* The array of argument objects. */ |
|
|
Command *cmdPtr; /* Points to command's Command struct. */ |
|
|
int newPcOffset; /* New inst offset for break, continue. */ |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
int isUnknownCmd = 0; |
|
|
char cmdNameBuf[21]; |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
|
|
|
/* |
|
|
* If the interpreter was deleted, return an error. |
|
|
*/ |
|
|
|
|
|
if (iPtr->flags & DELETED) { |
|
|
Tcl_ResetResult(interp); |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
|
|
"attempt to call eval in deleted interpreter", -1); |
|
|
Tcl_SetErrorCode(interp, "CORE", "IDELETE", |
|
|
"attempt to call eval in deleted interpreter", |
|
|
(char *) NULL); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Find the procedure to execute this command. If the |
|
|
* command is not found, handle it with the "unknown" proc. |
|
|
*/ |
|
|
|
|
|
objv = &(stackPtr[stackTop - (objc-1)]); |
|
|
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); |
|
|
if (cmdPtr == NULL) { |
|
|
cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown", |
|
|
(Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); |
|
|
if (cmdPtr == NULL) { |
|
|
Tcl_ResetResult(interp); |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
|
|
"invalid command name \"", |
|
|
Tcl_GetString(objv[0]), "\"", |
|
|
(char *) NULL); |
|
|
TRACE(("%u => unknown proc not found: ", objc)); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
isUnknownCmd = 1; |
|
|
#endif /*TCL_COMPILE_DEBUG*/ |
|
|
stackTop++; /* need room for new inserted objv[0] */ |
|
|
for (i = objc-1; i >= 0; i--) { |
|
|
objv[i+1] = objv[i]; |
|
|
} |
|
|
objc++; |
|
|
objv[0] = Tcl_NewStringObj("unknown", -1); |
|
|
Tcl_IncrRefCount(objv[0]); |
|
|
} |
|
|
|
|
|
/* |
|
|
* Call any trace procedures. |
|
|
*/ |
|
|
|
|
|
if (iPtr->tracePtr != NULL) { |
|
|
Trace *tracePtr, *nextTracePtr; |
|
|
|
|
|
for (tracePtr = iPtr->tracePtr; tracePtr != NULL; |
|
|
tracePtr = nextTracePtr) { |
|
|
nextTracePtr = tracePtr->nextPtr; |
|
|
if (iPtr->numLevels <= tracePtr->level) { |
|
|
int numChars; |
|
|
char *cmd = GetSrcInfoForPc(pc, codePtr, |
|
|
&numChars); |
|
|
if (cmd != NULL) { |
|
|
DECACHE_STACK_INFO(); |
|
|
CallTraceProcedure(interp, tracePtr, cmdPtr, |
|
|
cmd, numChars, objc, objv); |
|
|
CACHE_STACK_INFO(); |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
* Finally, invoke the command's Tcl_ObjCmdProc. First reset |
|
|
* the interpreter's string and object results to their |
|
|
* default empty values since they could have gotten changed |
|
|
* by earlier invocations. |
|
|
*/ |
|
|
|
|
|
Tcl_ResetResult(interp); |
|
|
if (tclTraceExec >= 2) { |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
if (traceInstructions) { |
|
|
strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20); |
|
|
TRACE(("%u => call ", (isUnknownCmd? objc-1:objc))); |
|
|
} else { |
|
|
fprintf(stdout, "%d: (%u) invoking ", |
|
|
iPtr->numLevels, |
|
|
(unsigned int)(pc - codePtr->codeStart)); |
|
|
} |
|
|
for (i = 0; i < objc; i++) { |
|
|
TclPrintObject(stdout, objv[i], 15); |
|
|
fprintf(stdout, " "); |
|
|
} |
|
|
fprintf(stdout, "\n"); |
|
|
fflush(stdout); |
|
|
#else /* TCL_COMPILE_DEBUG */ |
|
|
fprintf(stdout, "%d: (%u) invoking %s\n", |
|
|
iPtr->numLevels, |
|
|
(unsigned int)(pc - codePtr->codeStart), |
|
|
Tcl_GetString(objv[0])); |
|
|
#endif /*TCL_COMPILE_DEBUG*/ |
|
|
} |
|
|
|
|
|
iPtr->cmdCount++; |
|
|
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. |
|
|
*/ |
|
|
|
|
|
for (i = 0; i < objc; i++) { |
|
|
valuePtr = stackPtr[stackTop]; |
|
|
TclDecrRefCount(valuePtr); |
|
|
stackTop--; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Process the result of the Tcl_ObjCmdProc call. |
|
|
*/ |
|
|
|
|
|
switch (result) { |
|
|
case TCL_OK: |
|
|
/* |
|
|
* Push the call's object result and continue execution |
|
|
* with the next instruction. |
|
|
*/ |
|
|
PUSH_OBJECT(Tcl_GetObjResult(interp)); |
|
|
TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=", |
|
|
objc, cmdNameBuf), Tcl_GetObjResult(interp)); |
|
|
ADJUST_PC(pcAdjustment); |
|
|
|
|
|
case TCL_BREAK: |
|
|
case TCL_CONTINUE: |
|
|
/* |
|
|
* The invoked command requested a break or continue. |
|
|
* Find the closest enclosing loop or catch exception |
|
|
* range, if any. If a loop is found, terminate its |
|
|
* execution or skip to its next iteration. If the |
|
|
* closest is a catch exception range, jump to its |
|
|
* catchOffset. If no enclosing range is found, stop |
|
|
* execution and return the TCL_BREAK or TCL_CONTINUE. |
|
|
*/ |
|
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, |
|
|
codePtr); |
|
|
if (rangePtr == NULL) { |
|
|
TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", |
|
|
objc, cmdNameBuf, |
|
|
StringForResultCode(result))); |
|
|
goto abnormalReturn; /* no catch exists to check */ |
|
|
} |
|
|
newPcOffset = 0; |
|
|
switch (rangePtr->type) { |
|
|
case LOOP_EXCEPTION_RANGE: |
|
|
if (result == TCL_BREAK) { |
|
|
newPcOffset = rangePtr->breakOffset; |
|
|
} else if (rangePtr->continueOffset == -1) { |
|
|
TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", |
|
|
objc, cmdNameBuf, |
|
|
StringForResultCode(result))); |
|
|
goto checkForCatch; |
|
|
} else { |
|
|
newPcOffset = rangePtr->continueOffset; |
|
|
} |
|
|
TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n", |
|
|
objc, cmdNameBuf, |
|
|
StringForResultCode(result), |
|
|
rangePtr->codeOffset, newPcOffset)); |
|
|
break; |
|
|
case CATCH_EXCEPTION_RANGE: |
|
|
TRACE(("%u => ... after \"%.20s\", %s...\n", |
|
|
objc, cmdNameBuf, |
|
|
StringForResultCode(result))); |
|
|
goto processCatch; /* it will use rangePtr */ |
|
|
default: |
|
|
panic("TclExecuteByteCode: bad ExceptionRange type\n"); |
|
|
} |
|
|
result = TCL_OK; |
|
|
pc = (codePtr->codeStart + newPcOffset); |
|
|
continue; /* restart outer instruction loop at pc */ |
|
|
|
|
|
case TCL_ERROR: |
|
|
/* |
|
|
* The invoked command returned an error. Look for an |
|
|
* enclosing catch exception range, if any. |
|
|
*/ |
|
|
TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ", |
|
|
objc, cmdNameBuf), Tcl_GetObjResult(interp)); |
|
|
goto checkForCatch; |
|
|
|
|
|
case TCL_RETURN: |
|
|
/* |
|
|
* The invoked command requested that the current |
|
|
* procedure stop execution and return. First check |
|
|
* for an enclosing catch exception range, if any. |
|
|
*/ |
|
|
TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n", |
|
|
objc, cmdNameBuf)); |
|
|
goto checkForCatch; |
|
|
|
|
|
default: |
|
|
TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ", |
|
|
objc, cmdNameBuf, result), |
|
|
Tcl_GetObjResult(interp)); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
|
|
|
case INST_EVAL_STK: |
|
|
objPtr = POP_OBJECT(); |
|
|
DECACHE_STACK_INFO(); |
|
|
result = Tcl_EvalObjEx(interp, objPtr, 0); |
|
|
CACHE_STACK_INFO(); |
|
|
if (result == TCL_OK) { |
|
|
/* |
|
|
* Normal return; push the eval's object result. |
|
|
*/ |
|
|
PUSH_OBJECT(Tcl_GetObjResult(interp)); |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
TclDecrRefCount(objPtr); |
|
|
ADJUST_PC(1); |
|
|
} else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) { |
|
|
/* |
|
|
* Find the closest enclosing loop or catch exception range, |
|
|
* if any. If a loop is found, terminate its execution or |
|
|
* skip to its next iteration. If the closest is a catch |
|
|
* exception range, jump to its catchOffset. If no enclosing |
|
|
* range is found, stop execution and return that same |
|
|
* TCL_BREAK or TCL_CONTINUE. |
|
|
*/ |
|
|
|
|
|
int newPcOffset = 0; /* Pc offset computed during break, |
|
|
* continue, error processing. Init. |
|
|
* to avoid compiler warning. */ |
|
|
|
|
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, |
|
|
codePtr); |
|
|
if (rangePtr == NULL) { |
|
|
TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n", |
|
|
O2S(objPtr), StringForResultCode(result))); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
goto abnormalReturn; /* no catch exists to check */ |
|
|
} |
|
|
switch (rangePtr->type) { |
|
|
case LOOP_EXCEPTION_RANGE: |
|
|
if (result == TCL_BREAK) { |
|
|
newPcOffset = rangePtr->breakOffset; |
|
|
} else if (rangePtr->continueOffset == -1) { |
|
|
TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n", |
|
|
O2S(objPtr), StringForResultCode(result))); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
goto checkForCatch; |
|
|
} else { |
|
|
newPcOffset = rangePtr->continueOffset; |
|
|
} |
|
|
result = TCL_OK; |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ", |
|
|
O2S(objPtr), StringForResultCode(result), |
|
|
rangePtr->codeOffset, newPcOffset), valuePtr); |
|
|
break; |
|
|
case CATCH_EXCEPTION_RANGE: |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => %s ", |
|
|
O2S(objPtr), StringForResultCode(result)), |
|
|
valuePtr); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
goto processCatch; /* it will use rangePtr */ |
|
|
default: |
|
|
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); |
|
|
} |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
pc = (codePtr->codeStart + newPcOffset); |
|
|
continue; /* restart outer instruction loop at pc */ |
|
|
} else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
|
|
|
case INST_EXPR_STK: |
|
|
objPtr = POP_OBJECT(); |
|
|
Tcl_ResetResult(interp); |
|
|
DECACHE_STACK_INFO(); |
|
|
result = Tcl_ExprObj(interp, objPtr, &valuePtr); |
|
|
CACHE_STACK_INFO(); |
|
|
if (result != TCL_OK) { |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", |
|
|
O2S(objPtr)), Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
stackPtr[++stackTop] = valuePtr; /* already has right refct */ |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); |
|
|
TclDecrRefCount(objPtr); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_LOAD_SCALAR1: |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
DECACHE_STACK_INFO(); |
|
|
valuePtr = TclGetIndexedScalar(interp, opnd, |
|
|
/*leaveErrorMsg*/ 1); |
|
|
CACHE_STACK_INFO(); |
|
|
if (valuePtr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u => ERROR: ", opnd), |
|
|
Tcl_GetObjResult(interp)); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(valuePtr); |
|
|
TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); |
|
|
#else /* TCL_COMPILE_DEBUG */ |
|
|
DECACHE_STACK_INFO(); |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1); |
|
|
CACHE_STACK_INFO(); |
|
|
if (valuePtr == NULL) { |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(valuePtr); |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
ADJUST_PC(2); |
|
|
|
|
|
case INST_LOAD_SCALAR4: |
|
|
opnd = TclGetUInt4AtPtr(pc+1); |
|
|
DECACHE_STACK_INFO(); |
|
|
valuePtr = TclGetIndexedScalar(interp, opnd, |
|
|
/*leaveErrorMsg*/ 1); |
|
|
CACHE_STACK_INFO(); |
|
|
if (valuePtr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u => ERROR: ", opnd), |
|
|
Tcl_GetObjResult(interp)); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(valuePtr); |
|
|
TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); |
|
|
ADJUST_PC(5); |
|
|
|
|
|
case INST_LOAD_SCALAR_STK: |
|
|
objPtr = POP_OBJECT(); /* scalar name */ |
|
|
DECACHE_STACK_INFO(); |
|
|
valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (valuePtr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(valuePtr); |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); |
|
|
TclDecrRefCount(objPtr); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_LOAD_ARRAY4: |
|
|
opnd = TclGetUInt4AtPtr(pc+1); |
|
|
pcAdjustment = 5; |
|
|
goto doLoadArray; |
|
|
|
|
|
case INST_LOAD_ARRAY1: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
pcAdjustment = 2; |
|
|
|
|
|
doLoadArray: |
|
|
{ |
|
|
Tcl_Obj *elemPtr = POP_OBJECT(); |
|
|
|
|
|
DECACHE_STACK_INFO(); |
|
|
valuePtr = TclGetElementOfIndexedArray(interp, opnd, |
|
|
elemPtr, /*leaveErrorMsg*/ 1); |
|
|
CACHE_STACK_INFO(); |
|
|
if (valuePtr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", |
|
|
opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(valuePtr); |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" => ", |
|
|
opnd, O2S(elemPtr)),valuePtr); |
|
|
TclDecrRefCount(elemPtr); |
|
|
} |
|
|
ADJUST_PC(pcAdjustment); |
|
|
|
|
|
case INST_LOAD_ARRAY_STK: |
|
|
{ |
|
|
Tcl_Obj *elemPtr = POP_OBJECT(); |
|
|
|
|
|
objPtr = POP_OBJECT(); /* array name */ |
|
|
DECACHE_STACK_INFO(); |
|
|
valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, |
|
|
TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (valuePtr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", |
|
|
O2S(objPtr), O2S(elemPtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(valuePtr); |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ", |
|
|
O2S(objPtr), O2S(elemPtr)), valuePtr); |
|
|
TclDecrRefCount(objPtr); |
|
|
TclDecrRefCount(elemPtr); |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_LOAD_STK: |
|
|
objPtr = POP_OBJECT(); /* variable name */ |
|
|
DECACHE_STACK_INFO(); |
|
|
valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (valuePtr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", |
|
|
O2S(objPtr)), Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(valuePtr); |
|
|
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); |
|
|
TclDecrRefCount(objPtr); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_STORE_SCALAR4: |
|
|
opnd = TclGetUInt4AtPtr(pc+1); |
|
|
pcAdjustment = 5; |
|
|
goto doStoreScalar; |
|
|
|
|
|
case INST_STORE_SCALAR1: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
pcAdjustment = 2; |
|
|
|
|
|
doStoreScalar: |
|
|
valuePtr = POP_OBJECT(); |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, |
|
|
/*leaveErrorMsg*/ 1); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", |
|
|
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("%u <- \"%.30s\" => ", |
|
|
opnd, O2S(valuePtr)), value2Ptr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
ADJUST_PC(pcAdjustment); |
|
|
|
|
|
case INST_STORE_SCALAR_STK: |
|
|
valuePtr = POP_OBJECT(); |
|
|
objPtr = POP_OBJECT(); /* scalar name */ |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, |
|
|
TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", |
|
|
O2S(objPtr), O2S(valuePtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", |
|
|
O2S(objPtr), O2S(valuePtr)), value2Ptr); |
|
|
TclDecrRefCount(objPtr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_STORE_ARRAY4: |
|
|
opnd = TclGetUInt4AtPtr(pc+1); |
|
|
pcAdjustment = 5; |
|
|
goto doStoreArray; |
|
|
|
|
|
case INST_STORE_ARRAY1: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
pcAdjustment = 2; |
|
|
|
|
|
doStoreArray: |
|
|
{ |
|
|
Tcl_Obj *elemPtr; |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
elemPtr = POP_OBJECT(); |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclSetElementOfIndexedArray(interp, opnd, |
|
|
elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", |
|
|
opnd, O2S(elemPtr), O2S(valuePtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ", |
|
|
opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); |
|
|
TclDecrRefCount(elemPtr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
} |
|
|
ADJUST_PC(pcAdjustment); |
|
|
|
|
|
case INST_STORE_ARRAY_STK: |
|
|
{ |
|
|
Tcl_Obj *elemPtr; |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
elemPtr = POP_OBJECT(); |
|
|
objPtr = POP_OBJECT(); /* array name */ |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, |
|
|
TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", |
|
|
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ", |
|
|
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), |
|
|
value2Ptr); |
|
|
TclDecrRefCount(objPtr); |
|
|
TclDecrRefCount(elemPtr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_STORE_STK: |
|
|
valuePtr = POP_OBJECT(); |
|
|
objPtr = POP_OBJECT(); /* variable name */ |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, |
|
|
TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", |
|
|
O2S(objPtr), O2S(valuePtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", |
|
|
O2S(objPtr), O2S(valuePtr)), value2Ptr); |
|
|
TclDecrRefCount(objPtr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_INCR_SCALAR1: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
valuePtr = POP_OBJECT(); |
|
|
if (valuePtr->typePtr != &tclIntType) { |
|
|
result = tclIntType.setFromAnyProc(interp, valuePtr); |
|
|
if (result != TCL_OK) { |
|
|
TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", |
|
|
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
i = valuePtr->internalRep.longValue; |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclIncrIndexedScalar(interp, opnd, i); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
ADJUST_PC(2); |
|
|
|
|
|
case INST_INCR_SCALAR_STK: |
|
|
case INST_INCR_STK: |
|
|
valuePtr = POP_OBJECT(); |
|
|
objPtr = POP_OBJECT(); /* scalar name */ |
|
|
if (valuePtr->typePtr != &tclIntType) { |
|
|
result = tclIntType.setFromAnyProc(interp, valuePtr); |
|
|
if (result != TCL_OK) { |
|
|
TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ", |
|
|
O2S(objPtr), O2S(valuePtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
i = valuePtr->internalRep.longValue; |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, |
|
|
TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ", |
|
|
O2S(objPtr), i), Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i), |
|
|
value2Ptr); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_INCR_ARRAY1: |
|
|
{ |
|
|
Tcl_Obj *elemPtr; |
|
|
|
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
valuePtr = POP_OBJECT(); |
|
|
elemPtr = POP_OBJECT(); |
|
|
if (valuePtr->typePtr != &tclIntType) { |
|
|
result = tclIntType.setFromAnyProc(interp, valuePtr); |
|
|
if (result != TCL_OK) { |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", |
|
|
opnd, O2S(elemPtr), O2S(valuePtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
i = valuePtr->internalRep.longValue; |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, |
|
|
elemPtr, i); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", |
|
|
opnd, O2S(elemPtr), i), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", |
|
|
opnd, O2S(elemPtr), i), value2Ptr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
} |
|
|
ADJUST_PC(2); |
|
|
|
|
|
case INST_INCR_ARRAY_STK: |
|
|
{ |
|
|
Tcl_Obj *elemPtr; |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
elemPtr = POP_OBJECT(); |
|
|
objPtr = POP_OBJECT(); /* array name */ |
|
|
if (valuePtr->typePtr != &tclIntType) { |
|
|
result = tclIntType.setFromAnyProc(interp, valuePtr); |
|
|
if (result != TCL_OK) { |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", |
|
|
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
i = valuePtr->internalRep.longValue; |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, |
|
|
TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", |
|
|
O2S(objPtr), O2S(elemPtr), i), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", |
|
|
O2S(objPtr), O2S(elemPtr), i), value2Ptr); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_INCR_SCALAR1_IMM: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
i = TclGetInt1AtPtr(pc+2); |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclIncrIndexedScalar(interp, opnd, i); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i), |
|
|
Tcl_GetObjResult(interp)); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr); |
|
|
ADJUST_PC(3); |
|
|
|
|
|
case INST_INCR_SCALAR_STK_IMM: |
|
|
case INST_INCR_STK_IMM: |
|
|
objPtr = POP_OBJECT(); /* variable name */ |
|
|
i = TclGetInt1AtPtr(pc+1); |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, |
|
|
TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ", |
|
|
O2S(objPtr), i), Tcl_GetObjResult(interp)); |
|
|
result = TCL_ERROR; |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i), |
|
|
value2Ptr); |
|
|
TclDecrRefCount(objPtr); |
|
|
ADJUST_PC(2); |
|
|
|
|
|
case INST_INCR_ARRAY1_IMM: |
|
|
{ |
|
|
Tcl_Obj *elemPtr; |
|
|
|
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
i = TclGetInt1AtPtr(pc+2); |
|
|
elemPtr = POP_OBJECT(); |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, |
|
|
elemPtr, i); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", |
|
|
opnd, O2S(elemPtr), i), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", |
|
|
opnd, O2S(elemPtr), i), value2Ptr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
} |
|
|
ADJUST_PC(3); |
|
|
|
|
|
case INST_INCR_ARRAY_STK_IMM: |
|
|
{ |
|
|
Tcl_Obj *elemPtr; |
|
|
|
|
|
i = TclGetInt1AtPtr(pc+1); |
|
|
elemPtr = POP_OBJECT(); |
|
|
objPtr = POP_OBJECT(); /* array name */ |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, |
|
|
TCL_LEAVE_ERR_MSG); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", |
|
|
O2S(objPtr), O2S(elemPtr), i), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
PUSH_OBJECT(value2Ptr); |
|
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", |
|
|
O2S(objPtr), O2S(elemPtr), i), value2Ptr); |
|
|
Tcl_DecrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(elemPtr); |
|
|
} |
|
|
ADJUST_PC(2); |
|
|
|
|
|
case INST_JUMP1: |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
opnd = TclGetInt1AtPtr(pc+1); |
|
|
TRACE(("%d => new pc %u\n", opnd, |
|
|
(unsigned int)(pc + opnd - codePtr->codeStart))); |
|
|
pc += opnd; |
|
|
#else |
|
|
pc += TclGetInt1AtPtr(pc+1); |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
continue; |
|
|
|
|
|
case INST_JUMP4: |
|
|
opnd = TclGetInt4AtPtr(pc+1); |
|
|
TRACE(("%d => new pc %u\n", opnd, |
|
|
(unsigned int)(pc + opnd - codePtr->codeStart))); |
|
|
ADJUST_PC(opnd); |
|
|
|
|
|
case INST_JUMP_TRUE4: |
|
|
opnd = TclGetInt4AtPtr(pc+1); |
|
|
pcAdjustment = 5; |
|
|
goto doJumpTrue; |
|
|
|
|
|
case INST_JUMP_TRUE1: |
|
|
opnd = TclGetInt1AtPtr(pc+1); |
|
|
pcAdjustment = 2; |
|
|
|
|
|
doJumpTrue: |
|
|
{ |
|
|
int b; |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
b = (valuePtr->internalRep.longValue != 0); |
|
|
} else if (valuePtr->typePtr == &tclDoubleType) { |
|
|
b = (valuePtr->internalRep.doubleValue != 0.0); |
|
|
} else { |
|
|
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); |
|
|
if (result != TCL_OK) { |
|
|
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
if (b) { |
|
|
TRACE(("%d => %.20s true, new pc %u\n", |
|
|
opnd, O2S(valuePtr), |
|
|
(unsigned int)(pc+opnd - codePtr->codeStart))); |
|
|
TclDecrRefCount(valuePtr); |
|
|
ADJUST_PC(opnd); |
|
|
} else { |
|
|
TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr))); |
|
|
TclDecrRefCount(valuePtr); |
|
|
ADJUST_PC(pcAdjustment); |
|
|
} |
|
|
} |
|
|
|
|
|
case INST_JUMP_FALSE4: |
|
|
opnd = TclGetInt4AtPtr(pc+1); |
|
|
pcAdjustment = 5; |
|
|
goto doJumpFalse; |
|
|
|
|
|
case INST_JUMP_FALSE1: |
|
|
opnd = TclGetInt1AtPtr(pc+1); |
|
|
pcAdjustment = 2; |
|
|
|
|
|
doJumpFalse: |
|
|
{ |
|
|
int b; |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
b = (valuePtr->internalRep.longValue != 0); |
|
|
} else if (valuePtr->typePtr == &tclDoubleType) { |
|
|
b = (valuePtr->internalRep.doubleValue != 0.0); |
|
|
} else { |
|
|
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); |
|
|
if (result != TCL_OK) { |
|
|
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), |
|
|
Tcl_GetObjResult(interp)); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
if (b) { |
|
|
TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr))); |
|
|
TclDecrRefCount(valuePtr); |
|
|
ADJUST_PC(pcAdjustment); |
|
|
} else { |
|
|
TRACE(("%d => %.20s false, new pc %u\n", |
|
|
opnd, O2S(valuePtr), |
|
|
(unsigned int)(pc + opnd - codePtr->codeStart))); |
|
|
TclDecrRefCount(valuePtr); |
|
|
ADJUST_PC(opnd); |
|
|
} |
|
|
} |
|
|
|
|
|
case INST_LOR: |
|
|
case INST_LAND: |
|
|
{ |
|
|
/* |
|
|
* Operands must be boolean or numeric. No int->double |
|
|
* conversions are performed. |
|
|
*/ |
|
|
|
|
|
int i1, i2; |
|
|
int iResult; |
|
|
char *s; |
|
|
Tcl_ObjType *t1Ptr, *t2Ptr; |
|
|
|
|
|
value2Ptr = POP_OBJECT(); |
|
|
valuePtr = POP_OBJECT(); |
|
|
t1Ptr = valuePtr->typePtr; |
|
|
t2Ptr = value2Ptr->typePtr; |
|
|
|
|
|
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { |
|
|
i1 = (valuePtr->internalRep.longValue != 0); |
|
|
} else if (t1Ptr == &tclDoubleType) { |
|
|
i1 = (valuePtr->internalRep.doubleValue != 0.0); |
|
|
} else { |
|
|
s = Tcl_GetStringFromObj(valuePtr, &length); |
|
|
if (TclLooksLikeInt(s, length)) { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i); |
|
|
i1 = (i != 0); |
|
|
} else { |
|
|
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i1); |
|
|
i1 = (i1 != 0); |
|
|
} |
|
|
if (result != TCL_OK) { |
|
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", |
|
|
O2S(valuePtr), |
|
|
(t1Ptr? t1Ptr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, valuePtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
|
|
|
if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { |
|
|
i2 = (value2Ptr->internalRep.longValue != 0); |
|
|
} else if (t2Ptr == &tclDoubleType) { |
|
|
i2 = (value2Ptr->internalRep.doubleValue != 0.0); |
|
|
} else { |
|
|
s = Tcl_GetStringFromObj(value2Ptr, &length); |
|
|
if (TclLooksLikeInt(s, length)) { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
value2Ptr, &i); |
|
|
i2 = (i != 0); |
|
|
} else { |
|
|
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, |
|
|
value2Ptr, &i2); |
|
|
} |
|
|
if (result != TCL_OK) { |
|
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", |
|
|
O2S(value2Ptr), |
|
|
(t2Ptr? t2Ptr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, value2Ptr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
* Reuse the valuePtr object already on stack if possible. |
|
|
*/ |
|
|
|
|
|
if (*pc == INST_LOR) { |
|
|
iResult = (i1 || i2); |
|
|
} else { |
|
|
iResult = (i1 && i2); |
|
|
} |
|
|
if (Tcl_IsShared(valuePtr)) { |
|
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
|
|
TRACE(("%.20s %.20s => %d\n", |
|
|
O2S(valuePtr), O2S(value2Ptr), iResult)); |
|
|
TclDecrRefCount(valuePtr); |
|
|
} else { /* reuse the valuePtr object */ |
|
|
TRACE(("%.20s %.20s => %d\n", |
|
|
O2S(valuePtr), O2S(value2Ptr), iResult)); |
|
|
Tcl_SetLongObj(valuePtr, iResult); |
|
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
|
|
} |
|
|
TclDecrRefCount(value2Ptr); |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_EQ: |
|
|
case INST_NEQ: |
|
|
case INST_LT: |
|
|
case INST_GT: |
|
|
case INST_LE: |
|
|
case INST_GE: |
|
|
{ |
|
|
/* |
|
|
* Any type is allowed but the two operands must have the |
|
|
* same type. We will compute value op value2. |
|
|
*/ |
|
|
|
|
|
Tcl_ObjType *t1Ptr, *t2Ptr; |
|
|
char *s1 = NULL; /* Init. avoids compiler warning. */ |
|
|
char *s2 = NULL; /* Init. avoids compiler warning. */ |
|
|
long i2 = 0; /* Init. avoids compiler warning. */ |
|
|
double d1 = 0.0; /* Init. avoids compiler warning. */ |
|
|
double d2 = 0.0; /* Init. avoids compiler warning. */ |
|
|
long iResult = 0; /* Init. avoids compiler warning. */ |
|
|
|
|
|
value2Ptr = POP_OBJECT(); |
|
|
valuePtr = POP_OBJECT(); |
|
|
t1Ptr = valuePtr->typePtr; |
|
|
t2Ptr = value2Ptr->typePtr; |
|
|
|
|
|
/* |
|
|
* We only want to coerce numeric validation if |
|
|
* neither type is NULL. A NULL type means the arg is |
|
|
* essentially an empty object ("", {} or [list]). |
|
|
*/ |
|
|
if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL)) |
|
|
|| (valuePtr->bytes && (valuePtr->length == 0))) |
|
|
|| (((t2Ptr == NULL) && (value2Ptr->bytes == NULL)) |
|
|
|| (value2Ptr->bytes && (value2Ptr->length == 0))))) { |
|
|
if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) { |
|
|
s1 = Tcl_GetStringFromObj(valuePtr, &length); |
|
|
if (TclLooksLikeInt(s1, length)) { |
|
|
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i); |
|
|
} else { |
|
|
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &d1); |
|
|
} |
|
|
t1Ptr = valuePtr->typePtr; |
|
|
} |
|
|
if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) { |
|
|
s2 = Tcl_GetStringFromObj(value2Ptr, &length); |
|
|
if (TclLooksLikeInt(s2, length)) { |
|
|
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
value2Ptr, &i2); |
|
|
} else { |
|
|
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
|
|
value2Ptr, &d2); |
|
|
} |
|
|
t2Ptr = value2Ptr->typePtr; |
|
|
} |
|
|
} |
|
|
if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) |
|
|
|| ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { |
|
|
/* |
|
|
* One operand is not numeric. Compare as strings. |
|
|
*/ |
|
|
int cmpValue; |
|
|
s1 = Tcl_GetString(valuePtr); |
|
|
s2 = Tcl_GetString(value2Ptr); |
|
|
cmpValue = strcmp(s1, s2); |
|
|
switch (*pc) { |
|
|
case INST_EQ: |
|
|
iResult = (cmpValue == 0); |
|
|
break; |
|
|
case INST_NEQ: |
|
|
iResult = (cmpValue != 0); |
|
|
break; |
|
|
case INST_LT: |
|
|
iResult = (cmpValue < 0); |
|
|
break; |
|
|
case INST_GT: |
|
|
iResult = (cmpValue > 0); |
|
|
break; |
|
|
case INST_LE: |
|
|
iResult = (cmpValue <= 0); |
|
|
break; |
|
|
case INST_GE: |
|
|
iResult = (cmpValue >= 0); |
|
|
break; |
|
|
} |
|
|
} else if ((t1Ptr == &tclDoubleType) |
|
|
|| (t2Ptr == &tclDoubleType)) { |
|
|
/* |
|
|
* Compare as doubles. |
|
|
*/ |
|
|
if (t1Ptr == &tclDoubleType) { |
|
|
d1 = valuePtr->internalRep.doubleValue; |
|
|
if (t2Ptr == &tclIntType) { |
|
|
d2 = value2Ptr->internalRep.longValue; |
|
|
} else { |
|
|
d2 = value2Ptr->internalRep.doubleValue; |
|
|
} |
|
|
} else { /* t1Ptr is int, t2Ptr is double */ |
|
|
d1 = valuePtr->internalRep.longValue; |
|
|
d2 = value2Ptr->internalRep.doubleValue; |
|
|
} |
|
|
switch (*pc) { |
|
|
case INST_EQ: |
|
|
iResult = d1 == d2; |
|
|
break; |
|
|
case INST_NEQ: |
|
|
iResult = d1 != d2; |
|
|
break; |
|
|
case INST_LT: |
|
|
iResult = d1 < d2; |
|
|
break; |
|
|
case INST_GT: |
|
|
iResult = d1 > d2; |
|
|
break; |
|
|
case INST_LE: |
|
|
iResult = d1 <= d2; |
|
|
break; |
|
|
case INST_GE: |
|
|
iResult = d1 >= d2; |
|
|
break; |
|
|
} |
|
|
} else { |
|
|
/* |
|
|
* Compare as ints. |
|
|
*/ |
|
|
i = valuePtr->internalRep.longValue; |
|
|
i2 = value2Ptr->internalRep.longValue; |
|
|
switch (*pc) { |
|
|
case INST_EQ: |
|
|
iResult = i == i2; |
|
|
break; |
|
|
case INST_NEQ: |
|
|
iResult = i != i2; |
|
|
break; |
|
|
case INST_LT: |
|
|
iResult = i < i2; |
|
|
break; |
|
|
case INST_GT: |
|
|
iResult = i > i2; |
|
|
break; |
|
|
case INST_LE: |
|
|
iResult = i <= i2; |
|
|
break; |
|
|
case INST_GE: |
|
|
iResult = i >= i2; |
|
|
break; |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
* Reuse the valuePtr object already on stack if possible. |
|
|
*/ |
|
|
|
|
|
if (Tcl_IsShared(valuePtr)) { |
|
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
|
|
TRACE(("%.20s %.20s => %ld\n", |
|
|
O2S(valuePtr), O2S(value2Ptr), iResult)); |
|
|
TclDecrRefCount(valuePtr); |
|
|
} else { /* reuse the valuePtr object */ |
|
|
TRACE(("%.20s %.20s => %ld\n", |
|
|
O2S(valuePtr), O2S(value2Ptr), iResult)); |
|
|
Tcl_SetLongObj(valuePtr, iResult); |
|
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
|
|
} |
|
|
TclDecrRefCount(value2Ptr); |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_MOD: |
|
|
case INST_LSHIFT: |
|
|
case INST_RSHIFT: |
|
|
case INST_BITOR: |
|
|
case INST_BITXOR: |
|
|
case INST_BITAND: |
|
|
{ |
|
|
/* |
|
|
* Only integers are allowed. We compute value op value2. |
|
|
*/ |
|
|
|
|
|
long i2, rem, negative; |
|
|
long iResult = 0; /* Init. avoids compiler warning. */ |
|
|
|
|
|
value2Ptr = POP_OBJECT(); |
|
|
valuePtr = POP_OBJECT(); |
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
} else { /* try to convert to int */ |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i); |
|
|
if (result != TCL_OK) { |
|
|
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", |
|
|
O2S(valuePtr), O2S(value2Ptr), |
|
|
(valuePtr->typePtr? |
|
|
valuePtr->typePtr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, valuePtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
if (value2Ptr->typePtr == &tclIntType) { |
|
|
i2 = value2Ptr->internalRep.longValue; |
|
|
} else { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
value2Ptr, &i2); |
|
|
if (result != TCL_OK) { |
|
|
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", |
|
|
O2S(valuePtr), O2S(value2Ptr), |
|
|
(value2Ptr->typePtr? |
|
|
value2Ptr->typePtr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, value2Ptr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
|
|
|
switch (*pc) { |
|
|
case INST_MOD: |
|
|
/* |
|
|
* This code is tricky: C doesn't guarantee much about |
|
|
* the quotient or remainder, but Tcl does. The |
|
|
* remainder always has the same sign as the divisor and |
|
|
* a smaller absolute value. |
|
|
*/ |
|
|
if (i2 == 0) { |
|
|
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto divideByZero; |
|
|
} |
|
|
negative = 0; |
|
|
if (i2 < 0) { |
|
|
i2 = -i2; |
|
|
i = -i; |
|
|
negative = 1; |
|
|
} |
|
|
rem = i % i2; |
|
|
if (rem < 0) { |
|
|
rem += i2; |
|
|
} |
|
|
if (negative) { |
|
|
rem = -rem; |
|
|
} |
|
|
iResult = rem; |
|
|
break; |
|
|
case INST_LSHIFT: |
|
|
iResult = i << i2; |
|
|
break; |
|
|
case INST_RSHIFT: |
|
|
/* |
|
|
* The following code is a bit tricky: it ensures that |
|
|
* right shifts propagate the sign bit even on machines |
|
|
* where ">>" won't do it by default. |
|
|
*/ |
|
|
if (i < 0) { |
|
|
iResult = ~((~i) >> i2); |
|
|
} else { |
|
|
iResult = i >> i2; |
|
|
} |
|
|
break; |
|
|
case INST_BITOR: |
|
|
iResult = i | i2; |
|
|
break; |
|
|
case INST_BITXOR: |
|
|
iResult = i ^ i2; |
|
|
break; |
|
|
case INST_BITAND: |
|
|
iResult = i & i2; |
|
|
break; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Reuse the valuePtr object already on stack if possible. |
|
|
*/ |
|
|
|
|
|
if (Tcl_IsShared(valuePtr)) { |
|
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
|
|
TRACE(("%ld %ld => %ld\n", i, i2, iResult)); |
|
|
TclDecrRefCount(valuePtr); |
|
|
} else { /* reuse the valuePtr object */ |
|
|
TRACE(("%ld %ld => %ld\n", i, i2, iResult)); |
|
|
Tcl_SetLongObj(valuePtr, iResult); |
|
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
|
|
} |
|
|
TclDecrRefCount(value2Ptr); |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_ADD: |
|
|
case INST_SUB: |
|
|
case INST_MULT: |
|
|
case INST_DIV: |
|
|
{ |
|
|
/* |
|
|
* Operands must be numeric and ints get converted to floats |
|
|
* if necessary. We compute value op value2. |
|
|
*/ |
|
|
|
|
|
Tcl_ObjType *t1Ptr, *t2Ptr; |
|
|
long i2, quot, rem; |
|
|
double d1, d2; |
|
|
long iResult = 0; /* Init. avoids compiler warning. */ |
|
|
double dResult = 0.0; /* Init. avoids compiler warning. */ |
|
|
int doDouble = 0; /* 1 if doing floating arithmetic */ |
|
|
|
|
|
value2Ptr = POP_OBJECT(); |
|
|
valuePtr = POP_OBJECT(); |
|
|
t1Ptr = valuePtr->typePtr; |
|
|
t2Ptr = value2Ptr->typePtr; |
|
|
|
|
|
if (t1Ptr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
} else if ((t1Ptr == &tclDoubleType) |
|
|
&& (valuePtr->bytes == NULL)) { |
|
|
/* |
|
|
* We can only use the internal rep directly if there is |
|
|
* no string rep. Otherwise the string rep might actually |
|
|
* look like an integer, which is preferred. |
|
|
*/ |
|
|
|
|
|
d1 = valuePtr->internalRep.doubleValue; |
|
|
} else { |
|
|
char *s = Tcl_GetStringFromObj(valuePtr, &length); |
|
|
if (TclLooksLikeInt(s, length)) { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i); |
|
|
} else { |
|
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &d1); |
|
|
} |
|
|
if (result != TCL_OK) { |
|
|
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", |
|
|
s, O2S(valuePtr), |
|
|
(valuePtr->typePtr? |
|
|
valuePtr->typePtr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, valuePtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
t1Ptr = valuePtr->typePtr; |
|
|
} |
|
|
|
|
|
if (t2Ptr == &tclIntType) { |
|
|
i2 = value2Ptr->internalRep.longValue; |
|
|
} else if ((t2Ptr == &tclDoubleType) |
|
|
&& (value2Ptr->bytes == NULL)) { |
|
|
/* |
|
|
* We can only use the internal rep directly if there is |
|
|
* no string rep. Otherwise the string rep might actually |
|
|
* look like an integer, which is preferred. |
|
|
*/ |
|
|
|
|
|
d2 = value2Ptr->internalRep.doubleValue; |
|
|
} else { |
|
|
char *s = Tcl_GetStringFromObj(value2Ptr, &length); |
|
|
if (TclLooksLikeInt(s, length)) { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
value2Ptr, &i2); |
|
|
} else { |
|
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
|
|
value2Ptr, &d2); |
|
|
} |
|
|
if (result != TCL_OK) { |
|
|
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", |
|
|
O2S(value2Ptr), s, |
|
|
(value2Ptr->typePtr? |
|
|
value2Ptr->typePtr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, value2Ptr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
t2Ptr = value2Ptr->typePtr; |
|
|
} |
|
|
|
|
|
if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { |
|
|
/* |
|
|
* Do double arithmetic. |
|
|
*/ |
|
|
doDouble = 1; |
|
|
if (t1Ptr == &tclIntType) { |
|
|
d1 = i; /* promote value 1 to double */ |
|
|
} else if (t2Ptr == &tclIntType) { |
|
|
d2 = i2; /* promote value 2 to double */ |
|
|
} |
|
|
switch (*pc) { |
|
|
case INST_ADD: |
|
|
dResult = d1 + d2; |
|
|
break; |
|
|
case INST_SUB: |
|
|
dResult = d1 - d2; |
|
|
break; |
|
|
case INST_MULT: |
|
|
dResult = d1 * d2; |
|
|
break; |
|
|
case INST_DIV: |
|
|
if (d2 == 0.0) { |
|
|
TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto divideByZero; |
|
|
} |
|
|
dResult = d1 / d2; |
|
|
break; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Check now for IEEE floating-point error. |
|
|
*/ |
|
|
|
|
|
if (IS_NAN(dResult) || IS_INF(dResult)) { |
|
|
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", |
|
|
O2S(valuePtr), O2S(value2Ptr))); |
|
|
TclExprFloatError(interp, dResult); |
|
|
result = TCL_ERROR; |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} else { |
|
|
/* |
|
|
* Do integer arithmetic. |
|
|
*/ |
|
|
switch (*pc) { |
|
|
case INST_ADD: |
|
|
iResult = i + i2; |
|
|
break; |
|
|
case INST_SUB: |
|
|
iResult = i - i2; |
|
|
break; |
|
|
case INST_MULT: |
|
|
iResult = i * i2; |
|
|
break; |
|
|
case INST_DIV: |
|
|
/* |
|
|
* This code is tricky: C doesn't guarantee much |
|
|
* about the quotient or remainder, but Tcl does. |
|
|
* The remainder always has the same sign as the |
|
|
* divisor and a smaller absolute value. |
|
|
*/ |
|
|
if (i2 == 0) { |
|
|
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
goto divideByZero; |
|
|
} |
|
|
if (i2 < 0) { |
|
|
i2 = -i2; |
|
|
i = -i; |
|
|
} |
|
|
quot = i / i2; |
|
|
rem = i % i2; |
|
|
if (rem < 0) { |
|
|
quot -= 1; |
|
|
} |
|
|
iResult = quot; |
|
|
break; |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
* Reuse the valuePtr object already on stack if possible. |
|
|
*/ |
|
|
|
|
|
if (Tcl_IsShared(valuePtr)) { |
|
|
if (doDouble) { |
|
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
|
|
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); |
|
|
} else { |
|
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
|
|
TRACE(("%ld %ld => %ld\n", i, i2, iResult)); |
|
|
} |
|
|
TclDecrRefCount(valuePtr); |
|
|
} else { /* reuse the valuePtr object */ |
|
|
if (doDouble) { /* NB: stack top is off by 1 */ |
|
|
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); |
|
|
Tcl_SetDoubleObj(valuePtr, dResult); |
|
|
} else { |
|
|
TRACE(("%ld %ld => %ld\n", i, i2, iResult)); |
|
|
Tcl_SetLongObj(valuePtr, iResult); |
|
|
} |
|
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
|
|
} |
|
|
TclDecrRefCount(value2Ptr); |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_UPLUS: |
|
|
{ |
|
|
/* |
|
|
* Operand must be numeric. |
|
|
*/ |
|
|
|
|
|
double d; |
|
|
Tcl_ObjType *tPtr; |
|
|
|
|
|
valuePtr = stackPtr[stackTop]; |
|
|
tPtr = valuePtr->typePtr; |
|
|
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) |
|
|
|| (valuePtr->bytes != NULL))) { |
|
|
char *s = Tcl_GetStringFromObj(valuePtr, &length); |
|
|
if (TclLooksLikeInt(s, length)) { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i); |
|
|
} else { |
|
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &d); |
|
|
} |
|
|
if (result != TCL_OK) { |
|
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", |
|
|
s, (tPtr? tPtr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
tPtr = valuePtr->typePtr; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Ensure that the operand's string rep is the same as the |
|
|
* formatted version of its internal rep. This makes sure |
|
|
* that "expr +000123" yields "83", not "000123". We |
|
|
* implement this by _discarding_ the string rep since we |
|
|
* know it will be regenerated, if needed later, by |
|
|
* formatting the internal rep's value. |
|
|
*/ |
|
|
|
|
|
if (Tcl_IsShared(valuePtr)) { |
|
|
if (tPtr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
objPtr = Tcl_NewLongObj(i); |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
objPtr = Tcl_NewDoubleObj(d); |
|
|
} |
|
|
Tcl_IncrRefCount(objPtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
valuePtr = objPtr; |
|
|
stackPtr[stackTop] = valuePtr; |
|
|
} else { |
|
|
Tcl_InvalidateStringRep(valuePtr); |
|
|
} |
|
|
TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_UMINUS: |
|
|
case INST_LNOT: |
|
|
{ |
|
|
/* |
|
|
* The operand must be numeric. 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) |
|
|
|| (valuePtr->bytes != NULL))) { |
|
|
if ((tPtr == &tclBooleanType) |
|
|
&& (valuePtr->bytes == NULL)) { |
|
|
valuePtr->typePtr = &tclIntType; |
|
|
} else { |
|
|
char *s = Tcl_GetStringFromObj(valuePtr, &length); |
|
|
if (TclLooksLikeInt(s, length)) { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i); |
|
|
} else { |
|
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &d); |
|
|
} |
|
|
if (result != TCL_OK) { |
|
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", |
|
|
s, (tPtr? tPtr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, valuePtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
tPtr = valuePtr->typePtr; |
|
|
} |
|
|
|
|
|
if (Tcl_IsShared(valuePtr)) { |
|
|
/* |
|
|
* Create a new object. |
|
|
*/ |
|
|
if (tPtr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
objPtr = Tcl_NewLongObj( |
|
|
(*pc == INST_UMINUS)? -i : !i); |
|
|
TRACE_WITH_OBJ(("%ld => ", i), objPtr); |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
if (*pc == INST_UMINUS) { |
|
|
objPtr = Tcl_NewDoubleObj(-d); |
|
|
} else { |
|
|
/* |
|
|
* Should be able to use "!d", but apparently |
|
|
* some compilers can't handle it. |
|
|
*/ |
|
|
objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); |
|
|
} |
|
|
TRACE_WITH_OBJ(("%.6g => ", d), objPtr); |
|
|
} |
|
|
PUSH_OBJECT(objPtr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
} else { |
|
|
/* |
|
|
* valuePtr is unshared. Modify it directly. |
|
|
*/ |
|
|
if (tPtr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
Tcl_SetLongObj(valuePtr, |
|
|
(*pc == INST_UMINUS)? -i : !i); |
|
|
TRACE_WITH_OBJ(("%ld => ", i), valuePtr); |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
if (*pc == INST_UMINUS) { |
|
|
Tcl_SetDoubleObj(valuePtr, -d); |
|
|
} else { |
|
|
/* |
|
|
* Should be able to use "!d", but apparently |
|
|
* some compilers can't handle it. |
|
|
*/ |
|
|
Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); |
|
|
} |
|
|
TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); |
|
|
} |
|
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
|
|
} |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_BITNOT: |
|
|
{ |
|
|
/* |
|
|
* The operand must be an integer. If the operand object is |
|
|
* unshared modify it directly, otherwise modify a copy. |
|
|
* Free any old string representation since it is now |
|
|
* invalid. |
|
|
*/ |
|
|
|
|
|
Tcl_ObjType *tPtr; |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
tPtr = valuePtr->typePtr; |
|
|
if (tPtr != &tclIntType) { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i); |
|
|
if (result != TCL_OK) { /* try to convert to double */ |
|
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", |
|
|
O2S(valuePtr), (tPtr? tPtr->name : "null"))); |
|
|
IllegalExprOperandType(interp, pc, valuePtr); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
|
|
|
i = valuePtr->internalRep.longValue; |
|
|
if (Tcl_IsShared(valuePtr)) { |
|
|
PUSH_OBJECT(Tcl_NewLongObj(~i)); |
|
|
TRACE(("0x%lx => (%lu)\n", i, ~i)); |
|
|
TclDecrRefCount(valuePtr); |
|
|
} else { |
|
|
/* |
|
|
* valuePtr is unshared. Modify it directly. |
|
|
*/ |
|
|
Tcl_SetLongObj(valuePtr, ~i); |
|
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
|
|
TRACE(("0x%lx => (%lu)\n", i, ~i)); |
|
|
} |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_CALL_BUILTIN_FUNC1: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
{ |
|
|
/* |
|
|
* Call one of the built-in Tcl math functions. |
|
|
*/ |
|
|
|
|
|
BuiltinFunc *mathFuncPtr; |
|
|
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
|
|
|
|
|
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { |
|
|
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); |
|
|
panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); |
|
|
} |
|
|
mathFuncPtr = &(builtinFuncTable[opnd]); |
|
|
DECACHE_STACK_INFO(); |
|
|
tsdPtr->mathInProgress++; |
|
|
result = (*mathFuncPtr->proc)(interp, eePtr, |
|
|
mathFuncPtr->clientData); |
|
|
tsdPtr->mathInProgress--; |
|
|
CACHE_STACK_INFO(); |
|
|
if (result != TCL_OK) { |
|
|
goto checkForCatch; |
|
|
} |
|
|
TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]); |
|
|
} |
|
|
ADJUST_PC(2); |
|
|
|
|
|
case INST_CALL_FUNC1: |
|
|
opnd = TclGetUInt1AtPtr(pc+1); |
|
|
{ |
|
|
/* |
|
|
* Call a non-builtin Tcl math function previously |
|
|
* registered by a call to Tcl_CreateMathFunc. |
|
|
*/ |
|
|
|
|
|
int objc = opnd; /* Number of arguments. The function name |
|
|
* is the 0-th argument. */ |
|
|
Tcl_Obj **objv; /* The array of arguments. The function |
|
|
* name is objv[0]. */ |
|
|
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
|
|
|
|
|
objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */ |
|
|
DECACHE_STACK_INFO(); |
|
|
tsdPtr->mathInProgress++; |
|
|
result = ExprCallMathFunc(interp, eePtr, objc, objv); |
|
|
tsdPtr->mathInProgress--; |
|
|
CACHE_STACK_INFO(); |
|
|
if (result != TCL_OK) { |
|
|
goto checkForCatch; |
|
|
} |
|
|
TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]); |
|
|
ADJUST_PC(2); |
|
|
} |
|
|
|
|
|
case INST_TRY_CVT_TO_NUMERIC: |
|
|
{ |
|
|
/* |
|
|
* Try to convert the topmost stack object to an int or |
|
|
* double object. This is done in order to support Tcl's |
|
|
* policy of interpreting operands if at all possible as |
|
|
* first integers, else floating-point numbers. |
|
|
*/ |
|
|
|
|
|
double d; |
|
|
char *s; |
|
|
Tcl_ObjType *tPtr; |
|
|
int converted, shared; |
|
|
|
|
|
valuePtr = stackPtr[stackTop]; |
|
|
tPtr = valuePtr->typePtr; |
|
|
converted = 0; |
|
|
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) |
|
|
|| (valuePtr->bytes != NULL))) { |
|
|
if ((tPtr == &tclBooleanType) |
|
|
&& (valuePtr->bytes == NULL)) { |
|
|
valuePtr->typePtr = &tclIntType; |
|
|
converted = 1; |
|
|
} else { |
|
|
s = Tcl_GetStringFromObj(valuePtr, &length); |
|
|
if (TclLooksLikeInt(s, length)) { |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &i); |
|
|
} else { |
|
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
|
|
valuePtr, &d); |
|
|
} |
|
|
if (result == TCL_OK) { |
|
|
converted = 1; |
|
|
} |
|
|
result = TCL_OK; /* reset the result variable */ |
|
|
} |
|
|
tPtr = valuePtr->typePtr; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Ensure that the topmost stack object, if numeric, has a |
|
|
* string rep the same as the formatted version of its |
|
|
* internal rep. This is used, e.g., to make sure that "expr |
|
|
* {0001}" yields "1", not "0001". We implement this by |
|
|
* _discarding_ the string rep since we know it will be |
|
|
* regenerated, if needed later, by formatting the internal |
|
|
* rep's value. Also check if there has been an IEEE |
|
|
* floating point error. |
|
|
*/ |
|
|
|
|
|
if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) { |
|
|
shared = 0; |
|
|
if (Tcl_IsShared(valuePtr)) { |
|
|
shared = 1; |
|
|
if (valuePtr->bytes != NULL) { |
|
|
/* |
|
|
* We only need to make a copy of the object |
|
|
* when it already had a string rep |
|
|
*/ |
|
|
if (tPtr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
objPtr = Tcl_NewLongObj(i); |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
objPtr = Tcl_NewDoubleObj(d); |
|
|
} |
|
|
Tcl_IncrRefCount(objPtr); |
|
|
TclDecrRefCount(valuePtr); |
|
|
valuePtr = objPtr; |
|
|
stackPtr[stackTop] = valuePtr; |
|
|
tPtr = valuePtr->typePtr; |
|
|
} |
|
|
} else { |
|
|
Tcl_InvalidateStringRep(valuePtr); |
|
|
} |
|
|
|
|
|
if (tPtr == &tclDoubleType) { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
if (IS_NAN(d) || IS_INF(d)) { |
|
|
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", |
|
|
O2S(valuePtr))); |
|
|
TclExprFloatError(interp, d); |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
} |
|
|
shared = shared; /* lint, shared not used. */ |
|
|
converted = converted; /* lint, converted not used. */ |
|
|
TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), |
|
|
(converted? "converted" : "not converted"), |
|
|
(shared? "shared" : "not shared"))); |
|
|
} else { |
|
|
TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); |
|
|
} |
|
|
} |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_BREAK: |
|
|
/* |
|
|
* First reset the interpreter's result. Then find the closest |
|
|
* enclosing loop or catch exception range, if any. If a loop is |
|
|
* found, terminate its execution. If the closest is a catch |
|
|
* exception range, jump to its catchOffset. If no enclosing |
|
|
* range is found, stop execution and return TCL_BREAK. |
|
|
*/ |
|
|
|
|
|
Tcl_ResetResult(interp); |
|
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); |
|
|
if (rangePtr == NULL) { |
|
|
TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n")); |
|
|
result = TCL_BREAK; |
|
|
goto abnormalReturn; /* no catch exists to check */ |
|
|
} |
|
|
switch (rangePtr->type) { |
|
|
case LOOP_EXCEPTION_RANGE: |
|
|
result = TCL_OK; |
|
|
TRACE(("=> range at %d, new pc %d\n", |
|
|
rangePtr->codeOffset, rangePtr->breakOffset)); |
|
|
break; |
|
|
case CATCH_EXCEPTION_RANGE: |
|
|
result = TCL_BREAK; |
|
|
TRACE(("=> ...\n")); |
|
|
goto processCatch; /* it will use rangePtr */ |
|
|
default: |
|
|
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); |
|
|
} |
|
|
pc = (codePtr->codeStart + rangePtr->breakOffset); |
|
|
continue; /* restart outer instruction loop at pc */ |
|
|
|
|
|
case INST_CONTINUE: |
|
|
/* |
|
|
* Find the closest enclosing loop or catch exception range, |
|
|
* if any. If a loop is found, skip to its next iteration. |
|
|
* If the closest is a catch exception range, jump to its |
|
|
* catchOffset. If no enclosing range is found, stop |
|
|
* execution and return TCL_CONTINUE. |
|
|
*/ |
|
|
|
|
|
Tcl_ResetResult(interp); |
|
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); |
|
|
if (rangePtr == NULL) { |
|
|
TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n")); |
|
|
result = TCL_CONTINUE; |
|
|
goto abnormalReturn; |
|
|
} |
|
|
switch (rangePtr->type) { |
|
|
case LOOP_EXCEPTION_RANGE: |
|
|
if (rangePtr->continueOffset == -1) { |
|
|
TRACE(("=> loop w/o continue, checking for catch\n")); |
|
|
goto checkForCatch; |
|
|
} else { |
|
|
result = TCL_OK; |
|
|
TRACE(("=> range at %d, new pc %d\n", |
|
|
rangePtr->codeOffset, rangePtr->continueOffset)); |
|
|
} |
|
|
break; |
|
|
case CATCH_EXCEPTION_RANGE: |
|
|
result = TCL_CONTINUE; |
|
|
TRACE(("=> ...\n")); |
|
|
goto processCatch; /* it will use rangePtr */ |
|
|
default: |
|
|
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); |
|
|
} |
|
|
pc = (codePtr->codeStart + rangePtr->continueOffset); |
|
|
continue; /* restart outer instruction loop at pc */ |
|
|
|
|
|
case INST_FOREACH_START4: |
|
|
opnd = TclGetUInt4AtPtr(pc+1); |
|
|
{ |
|
|
/* |
|
|
* Initialize the temporary local var that holds the count |
|
|
* of the number of iterations of the loop body to -1. |
|
|
*/ |
|
|
|
|
|
ForeachInfo *infoPtr = (ForeachInfo *) |
|
|
codePtr->auxDataArrayPtr[opnd].clientData; |
|
|
int iterTmpIndex = infoPtr->loopCtTemp; |
|
|
Var *compiledLocals = iPtr->varFramePtr->compiledLocals; |
|
|
Var *iterVarPtr = &(compiledLocals[iterTmpIndex]); |
|
|
Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr; |
|
|
|
|
|
if (oldValuePtr == NULL) { |
|
|
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); |
|
|
Tcl_IncrRefCount(iterVarPtr->value.objPtr); |
|
|
} else { |
|
|
Tcl_SetLongObj(oldValuePtr, -1); |
|
|
} |
|
|
TclSetVarScalar(iterVarPtr); |
|
|
TclClearVarUndefined(iterVarPtr); |
|
|
TRACE(("%u => loop iter count temp %d\n", |
|
|
opnd, iterTmpIndex)); |
|
|
} |
|
|
ADJUST_PC(5); |
|
|
|
|
|
case INST_FOREACH_STEP4: |
|
|
opnd = TclGetUInt4AtPtr(pc+1); |
|
|
{ |
|
|
/* |
|
|
* "Step" a foreach loop (i.e., begin its next iteration) by |
|
|
* assigning the next value list element to each loop var. |
|
|
*/ |
|
|
|
|
|
ForeachInfo *infoPtr = (ForeachInfo *) |
|
|
codePtr->auxDataArrayPtr[opnd].clientData; |
|
|
ForeachVarList *varListPtr; |
|
|
int numLists = infoPtr->numLists; |
|
|
Var *compiledLocals = iPtr->varFramePtr->compiledLocals; |
|
|
Tcl_Obj *listPtr; |
|
|
List *listRepPtr; |
|
|
Var *iterVarPtr, *listVarPtr; |
|
|
int iterNum, listTmpIndex, listLen, numVars; |
|
|
int varIndex, valIndex, continueLoop, j; |
|
|
|
|
|
/* |
|
|
* Increment the temp holding the loop iteration number. |
|
|
*/ |
|
|
|
|
|
iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); |
|
|
valuePtr = iterVarPtr->value.objPtr; |
|
|
iterNum = (valuePtr->internalRep.longValue + 1); |
|
|
Tcl_SetLongObj(valuePtr, iterNum); |
|
|
|
|
|
/* |
|
|
* Check whether all value lists are exhausted and we should |
|
|
* stop the loop. |
|
|
*/ |
|
|
|
|
|
continueLoop = 0; |
|
|
listTmpIndex = infoPtr->firstValueTemp; |
|
|
for (i = 0; i < numLists; i++) { |
|
|
varListPtr = infoPtr->varLists[i]; |
|
|
numVars = varListPtr->numVars; |
|
|
|
|
|
listVarPtr = &(compiledLocals[listTmpIndex]); |
|
|
listPtr = listVarPtr->value.objPtr; |
|
|
result = Tcl_ListObjLength(interp, listPtr, &listLen); |
|
|
if (result != TCL_OK) { |
|
|
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", |
|
|
opnd, i, O2S(listPtr)), |
|
|
Tcl_GetObjResult(interp)); |
|
|
goto checkForCatch; |
|
|
} |
|
|
if (listLen > (iterNum * numVars)) { |
|
|
continueLoop = 1; |
|
|
} |
|
|
listTmpIndex++; |
|
|
} |
|
|
|
|
|
/* |
|
|
* If some var in some var list still has a remaining list |
|
|
* element iterate one more time. Assign to var the next |
|
|
* element from its value list. We already checked above |
|
|
* that each list temp holds a valid list object. |
|
|
*/ |
|
|
|
|
|
if (continueLoop) { |
|
|
listTmpIndex = infoPtr->firstValueTemp; |
|
|
for (i = 0; i < numLists; i++) { |
|
|
varListPtr = infoPtr->varLists[i]; |
|
|
numVars = varListPtr->numVars; |
|
|
|
|
|
listVarPtr = &(compiledLocals[listTmpIndex]); |
|
|
listPtr = listVarPtr->value.objPtr; |
|
|
listRepPtr = (List *) listPtr->internalRep.otherValuePtr; |
|
|
listLen = listRepPtr->elemCount; |
|
|
|
|
|
valIndex = (iterNum * numVars); |
|
|
for (j = 0; j < numVars; j++) { |
|
|
int setEmptyStr = 0; |
|
|
if (valIndex >= listLen) { |
|
|
setEmptyStr = 1; |
|
|
valuePtr = Tcl_NewObj(); |
|
|
} else { |
|
|
valuePtr = listRepPtr->elements[valIndex]; |
|
|
} |
|
|
|
|
|
varIndex = varListPtr->varIndexes[j]; |
|
|
DECACHE_STACK_INFO(); |
|
|
value2Ptr = TclSetIndexedScalar(interp, |
|
|
varIndex, valuePtr, /*leaveErrorMsg*/ 1); |
|
|
CACHE_STACK_INFO(); |
|
|
if (value2Ptr == NULL) { |
|
|
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", |
|
|
opnd, varIndex), |
|
|
Tcl_GetObjResult(interp)); |
|
|
if (setEmptyStr) { |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
} |
|
|
result = TCL_ERROR; |
|
|
goto checkForCatch; |
|
|
} |
|
|
valIndex++; |
|
|
} |
|
|
listTmpIndex++; |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
* Push 1 if at least one value list had a remaining element |
|
|
* and the loop should continue. Otherwise push 0. |
|
|
*/ |
|
|
|
|
|
PUSH_OBJECT(Tcl_NewLongObj(continueLoop)); |
|
|
TRACE(("%u => %d lists, iter %d, %s loop\n", |
|
|
opnd, numLists, iterNum, |
|
|
(continueLoop? "continue" : "exit"))); |
|
|
} |
|
|
ADJUST_PC(5); |
|
|
|
|
|
case INST_BEGIN_CATCH4: |
|
|
/* |
|
|
* Record start of the catch command with exception range index |
|
|
* equal to the operand. Push the current stack depth onto the |
|
|
* special catch stack. |
|
|
*/ |
|
|
catchStackPtr[++catchTop] = stackTop; |
|
|
TRACE(("%u => catchTop=%d, stackTop=%d\n", |
|
|
TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); |
|
|
ADJUST_PC(5); |
|
|
|
|
|
case INST_END_CATCH: |
|
|
catchTop--; |
|
|
result = TCL_OK; |
|
|
TRACE(("=> catchTop=%d\n", catchTop)); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_PUSH_RESULT: |
|
|
PUSH_OBJECT(Tcl_GetObjResult(interp)); |
|
|
TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp)); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
case INST_PUSH_RETURN_CODE: |
|
|
PUSH_OBJECT(Tcl_NewLongObj(result)); |
|
|
TRACE(("=> %u\n", result)); |
|
|
ADJUST_PC(1); |
|
|
|
|
|
default: |
|
|
panic("TclExecuteByteCode: unrecognized opCode %u", *pc); |
|
|
} /* end of switch on opCode */ |
|
|
|
|
|
/* |
|
|
* Division by zero in an expression. Control only reaches this |
|
|
* point by "goto divideByZero". |
|
|
*/ |
|
|
|
|
|
divideByZero: |
|
|
Tcl_ResetResult(interp); |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1); |
|
|
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", |
|
|
(char *) NULL); |
|
|
result = TCL_ERROR; |
|
|
|
|
|
/* |
|
|
* Execution has generated an "exception" such as TCL_ERROR. If the |
|
|
* exception is an error, record information about what was being |
|
|
* executed when the error occurred. Find the closest enclosing |
|
|
* catch range, if any. If no enclosing catch range is found, stop |
|
|
* execution and return the "exception" code. |
|
|
*/ |
|
|
|
|
|
checkForCatch: |
|
|
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { |
|
|
bytes = GetSrcInfoForPc(pc, codePtr, &length); |
|
|
if (bytes != NULL) { |
|
|
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); |
|
|
iPtr->flags |= ERR_ALREADY_LOGGED; |
|
|
} |
|
|
} |
|
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); |
|
|
if (rangePtr == NULL) { |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
if (traceInstructions) { |
|
|
fprintf(stdout, " ... no enclosing catch, returning %s\n", |
|
|
StringForResultCode(result)); |
|
|
} |
|
|
#endif |
|
|
goto abnormalReturn; |
|
|
} |
|
|
|
|
|
/* |
|
|
* A catch exception range (rangePtr) was found to handle an |
|
|
* "exception". It was found either by checkForCatch just above or |
|
|
* by an instruction during break, continue, or error processing. |
|
|
* Jump to its catchOffset after unwinding the operand stack to |
|
|
* the depth it had when starting to execute the range's catch |
|
|
* command. |
|
|
*/ |
|
|
|
|
|
processCatch: |
|
|
while (stackTop > catchStackPtr[catchTop]) { |
|
|
valuePtr = POP_OBJECT(); |
|
|
TclDecrRefCount(valuePtr); |
|
|
} |
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
if (traceInstructions) { |
|
|
fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", |
|
|
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], |
|
|
(unsigned int)(rangePtr->catchOffset)); |
|
|
} |
|
|
#endif |
|
|
pc = (codePtr->codeStart + rangePtr->catchOffset); |
|
|
continue; /* restart the execution loop at pc */ |
|
|
} /* end of infinite loop dispatching on instructions */ |
|
|
|
|
|
/* |
|
|
* Abnormal return code. Restore the stack to state it had when starting |
|
|
* to execute the ByteCode. |
|
|
*/ |
|
|
|
|
|
abnormalReturn: |
|
|
while (stackTop > initStackTop) { |
|
|
valuePtr = POP_OBJECT(); |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
} |
|
|
|
|
|
/* |
|
|
* Free the catch stack array if malloc'ed storage was used. |
|
|
*/ |
|
|
|
|
|
done: |
|
|
if (catchStackPtr != catchStackStorage) { |
|
|
ckfree((char *) catchStackPtr); |
|
|
} |
|
|
eePtr->stackTop = initStackTop; |
|
|
return result; |
|
|
#undef STATIC_CATCH_STACK_SIZE |
|
|
} |
|
|
|
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* PrintByteCodeInfo -- |
|
|
* |
|
|
* This procedure prints a summary about a bytecode object to stdout. |
|
|
* It is called by TclExecuteByteCode when starting to execute the |
|
|
* bytecode object if tclTraceExec has the value 2 or more. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static void |
|
|
PrintByteCodeInfo(codePtr) |
|
|
register ByteCode *codePtr; /* The bytecode whose summary is printed |
|
|
* to stdout. */ |
|
|
{ |
|
|
Proc *procPtr = codePtr->procPtr; |
|
|
Interp *iPtr = (Interp *) *codePtr->interpHandle; |
|
|
|
|
|
fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", |
|
|
(unsigned int) codePtr, codePtr->refCount, |
|
|
codePtr->compileEpoch, (unsigned int) iPtr, |
|
|
iPtr->compileEpoch); |
|
|
|
|
|
fprintf(stdout, " Source: "); |
|
|
TclPrintSource(stdout, codePtr->source, 60); |
|
|
|
|
|
fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", |
|
|
codePtr->numCommands, codePtr->numSrcBytes, |
|
|
codePtr->numCodeBytes, codePtr->numLitObjects, |
|
|
codePtr->numAuxDataItems, codePtr->maxStackDepth, |
|
|
#ifdef TCL_COMPILE_STATS |
|
|
(codePtr->numSrcBytes? |
|
|
((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); |
|
|
#else |
|
|
0.0); |
|
|
#endif |
|
|
#ifdef TCL_COMPILE_STATS |
|
|
fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", |
|
|
codePtr->structureSize, |
|
|
(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), |
|
|
codePtr->numCodeBytes, |
|
|
(codePtr->numLitObjects * sizeof(Tcl_Obj *)), |
|
|
(codePtr->numExceptRanges * sizeof(ExceptionRange)), |
|
|
(codePtr->numAuxDataItems * sizeof(AuxData)), |
|
|
codePtr->numCmdLocBytes); |
|
|
#endif /* TCL_COMPILE_STATS */ |
|
|
if (procPtr != NULL) { |
|
|
fprintf(stdout, |
|
|
" Proc 0x%x, refCt %d, args %d, compiled locals %d\n", |
|
|
(unsigned int) procPtr, procPtr->refCount, |
|
|
procPtr->numArgs, procPtr->numCompiledLocals); |
|
|
} |
|
|
} |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* ValidatePcAndStackTop -- |
|
|
* |
|
|
* This procedure is called by TclExecuteByteCode when debugging to |
|
|
* verify that the program counter and stack top are valid during |
|
|
* execution. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* Prints a message to stderr and panics if either the pc or stack |
|
|
* top are invalid. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
static void |
|
|
ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, |
|
|
stackUpperBound) |
|
|
register ByteCode *codePtr; /* The bytecode whose summary is printed |
|
|
* to stdout. */ |
|
|
unsigned char *pc; /* Points to first byte of a bytecode |
|
|
* instruction. The program counter. */ |
|
|
int stackTop; /* Current stack top. Must be between |
|
|
* stackLowerBound and stackUpperBound |
|
|
* (inclusive). */ |
|
|
int stackLowerBound; /* Smallest legal value for stackTop. */ |
|
|
int stackUpperBound; /* Greatest legal value for stackTop. */ |
|
|
{ |
|
|
unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); |
|
|
unsigned int codeStart = (unsigned int) codePtr->codeStart; |
|
|
unsigned int codeEnd = (unsigned int) |
|
|
(codePtr->codeStart + codePtr->numCodeBytes); |
|
|
unsigned char opCode = *pc; |
|
|
|
|
|
if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) { |
|
|
fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n", |
|
|
(unsigned int) pc); |
|
|
panic("TclExecuteByteCode execution failure: bad pc"); |
|
|
} |
|
|
if ((unsigned int) opCode > LAST_INST_OPCODE) { |
|
|
fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", |
|
|
(unsigned int) opCode, relativePc); |
|
|
panic("TclExecuteByteCode execution failure: bad opcode"); |
|
|
} |
|
|
if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { |
|
|
int numChars; |
|
|
char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); |
|
|
char *ellipsis = ""; |
|
|
|
|
|
fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode", |
|
|
stackTop, relativePc); |
|
|
if (cmd != NULL) { |
|
|
if (numChars > 100) { |
|
|
numChars = 100; |
|
|
ellipsis = "..."; |
|
|
} |
|
|
fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd, |
|
|
ellipsis); |
|
|
} else { |
|
|
fprintf(stderr, "\n"); |
|
|
} |
|
|
panic("TclExecuteByteCode execution failure: bad stack top"); |
|
|
} |
|
|
} |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* IllegalExprOperandType -- |
|
|
* |
|
|
* Used by TclExecuteByteCode to add an error message to errorInfo |
|
|
* when an illegal operand type is detected by an expression |
|
|
* instruction. The argument opndPtr holds the operand object in error. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* An error message is appended to errorInfo. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static void |
|
|
IllegalExprOperandType(interp, pc, opndPtr) |
|
|
Tcl_Interp *interp; /* Interpreter to which error information |
|
|
* pertains. */ |
|
|
unsigned char *pc; /* Points to the instruction being executed |
|
|
* when the illegal type was found. */ |
|
|
Tcl_Obj *opndPtr; /* Points to the operand holding the value |
|
|
* with the illegal type. */ |
|
|
{ |
|
|
unsigned char opCode = *pc; |
|
|
|
|
|
Tcl_ResetResult(interp); |
|
|
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
|
|
"can't use empty string as operand of \"", |
|
|
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); |
|
|
} else { |
|
|
char *msg = "non-numeric string"; |
|
|
if (opndPtr->typePtr != &tclDoubleType) { |
|
|
/* |
|
|
* See if the operand can be interpreted as a double in order to |
|
|
* improve the error message. |
|
|
*/ |
|
|
|
|
|
char *s = Tcl_GetString(opndPtr); |
|
|
double d; |
|
|
|
|
|
if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) { |
|
|
/* |
|
|
* Make sure that what appears to be a double |
|
|
* (ie 08) isn't really a bad octal |
|
|
*/ |
|
|
if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) { |
|
|
msg = "invalid octal number"; |
|
|
} else { |
|
|
msg = "floating-point value"; |
|
|
} |
|
|
} |
|
|
} |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", |
|
|
msg, " as operand of \"", operatorStrings[opCode - INST_LOR], |
|
|
"\"", (char *) NULL); |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* CallTraceProcedure -- |
|
|
* |
|
|
* Invokes a trace procedure registered with an interpreter. These |
|
|
* procedures trace command execution. Currently this trace procedure |
|
|
* is called with the address of the string-based Tcl_CmdProc for the |
|
|
* command, not the Tcl_ObjCmdProc. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* Those side effects made by the trace procedure. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static void |
|
|
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) |
|
|
Tcl_Interp *interp; /* The current interpreter. */ |
|
|
register Trace *tracePtr; /* Describes the trace procedure to call. */ |
|
|
Command *cmdPtr; /* Points to command's Command struct. */ |
|
|
char *command; /* Points to the first character of the |
|
|
* command's source before substitutions. */ |
|
|
int numChars; /* The number of characters in the |
|
|
* command's source. */ |
|
|
register int objc; /* Number of arguments for the command. */ |
|
|
Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */ |
|
|
{ |
|
|
Interp *iPtr = (Interp *) interp; |
|
|
register char **argv; |
|
|
register int i; |
|
|
int length; |
|
|
char *p; |
|
|
|
|
|
/* |
|
|
* Get the string rep from the objv argument objects and place their |
|
|
* pointers in argv. First make sure argv is large enough to hold the |
|
|
* objc args plus 1 extra word for the zero end-of-argv word. |
|
|
*/ |
|
|
|
|
|
argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); |
|
|
for (i = 0; i < objc; i++) { |
|
|
argv[i] = Tcl_GetStringFromObj(objv[i], &length); |
|
|
} |
|
|
argv[objc] = 0; |
|
|
|
|
|
/* |
|
|
* Copy the command characters into a new string. |
|
|
*/ |
|
|
|
|
|
p = (char *) ckalloc((unsigned) (numChars + 1)); |
|
|
memcpy((VOID *) p, (VOID *) command, (size_t) numChars); |
|
|
p[numChars] = '\0'; |
|
|
|
|
|
/* |
|
|
* Call the trace procedure then free allocated storage. |
|
|
*/ |
|
|
|
|
|
(*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, |
|
|
p, cmdPtr->proc, cmdPtr->clientData, objc, argv); |
|
|
|
|
|
ckfree((char *) argv); |
|
|
ckfree((char *) p); |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* GetSrcInfoForPc -- |
|
|
* |
|
|
* Given a program counter value, finds the closest command in the |
|
|
* bytecode code unit's CmdLocation array and returns information about |
|
|
* that command's source: a pointer to its first byte and the number of |
|
|
* characters. |
|
|
* |
|
|
* Results: |
|
|
* If a command is found that encloses the program counter value, a |
|
|
* pointer to the command's source is returned and the length of the |
|
|
* source is stored at *lengthPtr. If multiple commands resulted in |
|
|
* code at pc, information about the closest enclosing command is |
|
|
* returned. If no matching command is found, NULL is returned and |
|
|
* *lengthPtr is unchanged. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static char * |
|
|
GetSrcInfoForPc(pc, codePtr, lengthPtr) |
|
|
unsigned char *pc; /* The program counter value for which to |
|
|
* return the closest command's source info. |
|
|
* This points to a bytecode instruction |
|
|
* in codePtr's code. */ |
|
|
ByteCode *codePtr; /* The bytecode sequence in which to look |
|
|
* up the command source for the pc. */ |
|
|
int *lengthPtr; /* If non-NULL, the location where the |
|
|
* length of the command's source should be |
|
|
* stored. If NULL, no length is stored. */ |
|
|
{ |
|
|
register int pcOffset = (pc - codePtr->codeStart); |
|
|
int numCmds = codePtr->numCommands; |
|
|
unsigned char *codeDeltaNext, *codeLengthNext; |
|
|
unsigned char *srcDeltaNext, *srcLengthNext; |
|
|
int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; |
|
|
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ |
|
|
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ |
|
|
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ |
|
|
|
|
|
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { |
|
|
return NULL; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Decode the code and source offset and length for each command. The |
|
|
* closest enclosing command is the last one whose code started before |
|
|
* pcOffset. |
|
|
*/ |
|
|
|
|
|
codeDeltaNext = codePtr->codeDeltaStart; |
|
|
codeLengthNext = codePtr->codeLengthStart; |
|
|
srcDeltaNext = codePtr->srcDeltaStart; |
|
|
srcLengthNext = codePtr->srcLengthStart; |
|
|
codeOffset = srcOffset = 0; |
|
|
for (i = 0; i < numCmds; i++) { |
|
|
if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { |
|
|
codeDeltaNext++; |
|
|
delta = TclGetInt4AtPtr(codeDeltaNext); |
|
|
codeDeltaNext += 4; |
|
|
} else { |
|
|
delta = TclGetInt1AtPtr(codeDeltaNext); |
|
|
codeDeltaNext++; |
|
|
} |
|
|
codeOffset += delta; |
|
|
|
|
|
if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { |
|
|
codeLengthNext++; |
|
|
codeLen = TclGetInt4AtPtr(codeLengthNext); |
|
|
codeLengthNext += 4; |
|
|
} else { |
|
|
codeLen = TclGetInt1AtPtr(codeLengthNext); |
|
|
codeLengthNext++; |
|
|
} |
|
|
codeEnd = (codeOffset + codeLen - 1); |
|
|
|
|
|
if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { |
|
|
srcDeltaNext++; |
|
|
delta = TclGetInt4AtPtr(srcDeltaNext); |
|
|
srcDeltaNext += 4; |
|
|
} else { |
|
|
delta = TclGetInt1AtPtr(srcDeltaNext); |
|
|
srcDeltaNext++; |
|
|
} |
|
|
srcOffset += delta; |
|
|
|
|
|
if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { |
|
|
srcLengthNext++; |
|
|
srcLen = TclGetInt4AtPtr(srcLengthNext); |
|
|
srcLengthNext += 4; |
|
|
} else { |
|
|
srcLen = TclGetInt1AtPtr(srcLengthNext); |
|
|
srcLengthNext++; |
|
|
} |
|
|
|
|
|
if (codeOffset > pcOffset) { /* best cmd already found */ |
|
|
break; |
|
|
} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ |
|
|
int dist = (pcOffset - codeOffset); |
|
|
if (dist <= bestDist) { |
|
|
bestDist = dist; |
|
|
bestSrcOffset = srcOffset; |
|
|
bestSrcLength = srcLen; |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
if (bestDist == INT_MAX) { |
|
|
return NULL; |
|
|
} |
|
|
|
|
|
if (lengthPtr != NULL) { |
|
|
*lengthPtr = bestSrcLength; |
|
|
} |
|
|
return (codePtr->source + bestSrcOffset); |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* GetExceptRangeForPc -- |
|
|
* |
|
|
* Given a program counter value, return the closest enclosing |
|
|
* ExceptionRange. |
|
|
* |
|
|
* Results: |
|
|
* In the normal case, catchOnly is 0 (false) and this procedure |
|
|
* returns a pointer to the most closely enclosing ExceptionRange |
|
|
* structure regardless of whether it is a loop or catch exception |
|
|
* range. This is appropriate when processing a TCL_BREAK or |
|
|
* TCL_CONTINUE, which will be "handled" either by a loop exception |
|
|
* range or a closer catch range. If catchOnly is nonzero, this |
|
|
* procedure ignores loop exception ranges and returns a pointer to the |
|
|
* closest catch range. If no matching ExceptionRange is found that |
|
|
* encloses pc, a NULL is returned. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static ExceptionRange * |
|
|
GetExceptRangeForPc(pc, catchOnly, codePtr) |
|
|
unsigned char *pc; /* The program counter value for which to |
|
|
* search for a closest enclosing exception |
|
|
* range. This points to a bytecode |
|
|
* instruction in codePtr's code. */ |
|
|
int catchOnly; /* If 0, consider either loop or catch |
|
|
* ExceptionRanges in search. If nonzero |
|
|
* consider only catch ranges (and ignore |
|
|
* any closer loop ranges). */ |
|
|
ByteCode* codePtr; /* Points to the ByteCode in which to search |
|
|
* for the enclosing ExceptionRange. */ |
|
|
{ |
|
|
ExceptionRange *rangeArrayPtr; |
|
|
int numRanges = codePtr->numExceptRanges; |
|
|
register ExceptionRange *rangePtr; |
|
|
int pcOffset = (pc - codePtr->codeStart); |
|
|
register int i, level; |
|
|
|
|
|
if (numRanges == 0) { |
|
|
return NULL; |
|
|
} |
|
|
rangeArrayPtr = codePtr->exceptArrayPtr; |
|
|
|
|
|
for (level = codePtr->maxExceptDepth; level >= 0; level--) { |
|
|
for (i = 0; i < numRanges; i++) { |
|
|
rangePtr = &(rangeArrayPtr[i]); |
|
|
if (rangePtr->nestingLevel == level) { |
|
|
int start = rangePtr->codeOffset; |
|
|
int end = (start + rangePtr->numCodeBytes); |
|
|
if ((start <= pcOffset) && (pcOffset < end)) { |
|
|
if ((!catchOnly) |
|
|
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) { |
|
|
return rangePtr; |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
} |
|
|
return NULL; |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* GetOpcodeName -- |
|
|
* |
|
|
* This procedure is called by the TRACE and TRACE_WITH_OBJ macros |
|
|
* used in TclExecuteByteCode when debugging. It returns the name of |
|
|
* the bytecode instruction at a specified instruction pc. |
|
|
* |
|
|
* Results: |
|
|
* A character string for the instruction. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
static char * |
|
|
GetOpcodeName(pc) |
|
|
unsigned char *pc; /* Points to the instruction whose name |
|
|
* should be returned. */ |
|
|
{ |
|
|
unsigned char opCode = *pc; |
|
|
|
|
|
return instructionTable[opCode].name; |
|
|
} |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* VerifyExprObjType -- |
|
|
* |
|
|
* This procedure is called by the math functions to verify that |
|
|
* the object is either an int or double, coercing it if necessary. |
|
|
* If an error occurs during conversion, an error message is left |
|
|
* in the interpreter's result unless "interp" is NULL. |
|
|
* |
|
|
* Results: |
|
|
* TCL_OK if it was int or double, TCL_ERROR otherwise |
|
|
* |
|
|
* Side effects: |
|
|
* objPtr is ensured to be either tclIntType of tclDoubleType. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static int |
|
|
VerifyExprObjType(interp, objPtr) |
|
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
|
|
* function. */ |
|
|
Tcl_Obj *objPtr; /* Points to the object to type check. */ |
|
|
{ |
|
|
if ((objPtr->typePtr == &tclIntType) || |
|
|
(objPtr->typePtr == &tclDoubleType)) { |
|
|
return TCL_OK; |
|
|
} else { |
|
|
int length, result = TCL_OK; |
|
|
char *s = Tcl_GetStringFromObj(objPtr, &length); |
|
|
|
|
|
if (TclLooksLikeInt(s, length)) { |
|
|
long i; |
|
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i); |
|
|
} else { |
|
|
double d; |
|
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); |
|
|
} |
|
|
if ((result != TCL_OK) && (interp != NULL)) { |
|
|
Tcl_ResetResult(interp); |
|
|
if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) { |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
|
|
"argument to math function was an invalid octal number", |
|
|
-1); |
|
|
} else { |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
|
|
"argument to math function didn't have numeric value", |
|
|
-1); |
|
|
} |
|
|
} |
|
|
return result; |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* Math Functions -- |
|
|
* |
|
|
* This page contains the procedures that implement all of the |
|
|
* built-in math functions for expressions. |
|
|
* |
|
|
* Results: |
|
|
* Each procedure returns TCL_OK if it succeeds and pushes an |
|
|
* Tcl object holding the result. If it fails it returns TCL_ERROR |
|
|
* and leaves an error message in the interpreter's result. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static int |
|
|
ExprUnaryFunc(interp, eePtr, clientData) |
|
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
|
|
* function. */ |
|
|
ExecEnv *eePtr; /* Points to the environment for executing |
|
|
* the function. */ |
|
|
ClientData clientData; /* Contains the address of a procedure that |
|
|
* takes one double argument and returns a |
|
|
* double result. */ |
|
|
{ |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
register Tcl_Obj *valuePtr; |
|
|
double d, dResult; |
|
|
int result; |
|
|
|
|
|
double (*func) _ANSI_ARGS_((double)) = |
|
|
(double (*)_ANSI_ARGS_((double))) clientData; |
|
|
|
|
|
/* |
|
|
* Set stackPtr and stackTop from eePtr. |
|
|
*/ |
|
|
|
|
|
result = TCL_OK; |
|
|
CACHE_STACK_INFO(); |
|
|
|
|
|
/* |
|
|
* Pop the function's argument from the evaluation stack. Convert it |
|
|
* to a double if necessary. |
|
|
*/ |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
|
|
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
d = (double) valuePtr->internalRep.longValue; |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
} |
|
|
|
|
|
errno = 0; |
|
|
dResult = (*func)(d); |
|
|
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { |
|
|
TclExprFloatError(interp, dResult); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Push a Tcl object holding the result. |
|
|
*/ |
|
|
|
|
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
|
|
|
|
|
/* |
|
|
* Reflect the change to stackTop back in eePtr. |
|
|
*/ |
|
|
|
|
|
done: |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
DECACHE_STACK_INFO(); |
|
|
return result; |
|
|
} |
|
|
|
|
|
static int |
|
|
ExprBinaryFunc(interp, eePtr, clientData) |
|
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
|
|
* function. */ |
|
|
ExecEnv *eePtr; /* Points to the environment for executing |
|
|
* the function. */ |
|
|
ClientData clientData; /* Contains the address of a procedure that |
|
|
* takes two double arguments and |
|
|
* returns a double result. */ |
|
|
{ |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
register Tcl_Obj *valuePtr, *value2Ptr; |
|
|
double d1, d2, dResult; |
|
|
int result; |
|
|
|
|
|
double (*func) _ANSI_ARGS_((double, double)) |
|
|
= (double (*)_ANSI_ARGS_((double, double))) clientData; |
|
|
|
|
|
/* |
|
|
* Set stackPtr and stackTop from eePtr. |
|
|
*/ |
|
|
|
|
|
result = TCL_OK; |
|
|
CACHE_STACK_INFO(); |
|
|
|
|
|
/* |
|
|
* Pop the function's two arguments from the evaluation stack. Convert |
|
|
* them to doubles if necessary. |
|
|
*/ |
|
|
|
|
|
value2Ptr = POP_OBJECT(); |
|
|
valuePtr = POP_OBJECT(); |
|
|
|
|
|
if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) || |
|
|
(VerifyExprObjType(interp, value2Ptr) != TCL_OK)) { |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
d1 = (double) valuePtr->internalRep.longValue; |
|
|
} else { |
|
|
d1 = valuePtr->internalRep.doubleValue; |
|
|
} |
|
|
|
|
|
if (value2Ptr->typePtr == &tclIntType) { |
|
|
d2 = (double) value2Ptr->internalRep.longValue; |
|
|
} else { |
|
|
d2 = value2Ptr->internalRep.doubleValue; |
|
|
} |
|
|
|
|
|
errno = 0; |
|
|
dResult = (*func)(d1, d2); |
|
|
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { |
|
|
TclExprFloatError(interp, dResult); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Push a Tcl object holding the result. |
|
|
*/ |
|
|
|
|
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
|
|
|
|
|
/* |
|
|
* Reflect the change to stackTop back in eePtr. |
|
|
*/ |
|
|
|
|
|
done: |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
Tcl_DecrRefCount(value2Ptr); |
|
|
DECACHE_STACK_INFO(); |
|
|
return result; |
|
|
} |
|
|
|
|
|
static int |
|
|
ExprAbsFunc(interp, eePtr, clientData) |
|
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
|
|
* function. */ |
|
|
ExecEnv *eePtr; /* Points to the environment for executing |
|
|
* the function. */ |
|
|
ClientData clientData; /* Ignored. */ |
|
|
{ |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
register Tcl_Obj *valuePtr; |
|
|
long i, iResult; |
|
|
double d, dResult; |
|
|
int result; |
|
|
|
|
|
/* |
|
|
* Set stackPtr and stackTop from eePtr. |
|
|
*/ |
|
|
|
|
|
result = TCL_OK; |
|
|
CACHE_STACK_INFO(); |
|
|
|
|
|
/* |
|
|
* Pop the argument from the evaluation stack. |
|
|
*/ |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
|
|
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Push a Tcl object with the result. |
|
|
*/ |
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
if (i < 0) { |
|
|
iResult = -i; |
|
|
if (iResult < 0) { |
|
|
Tcl_ResetResult(interp); |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
|
|
"integer value too large to represent", -1); |
|
|
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", |
|
|
"integer value too large to represent", (char *) NULL); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
} else { |
|
|
iResult = i; |
|
|
} |
|
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
if (d < 0.0) { |
|
|
dResult = -d; |
|
|
} else { |
|
|
dResult = d; |
|
|
} |
|
|
if (IS_NAN(dResult) || IS_INF(dResult)) { |
|
|
TclExprFloatError(interp, dResult); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
|
|
} |
|
|
|
|
|
/* |
|
|
* Reflect the change to stackTop back in eePtr. |
|
|
*/ |
|
|
|
|
|
done: |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
DECACHE_STACK_INFO(); |
|
|
return result; |
|
|
} |
|
|
|
|
|
static int |
|
|
ExprDoubleFunc(interp, eePtr, clientData) |
|
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
|
|
* function. */ |
|
|
ExecEnv *eePtr; /* Points to the environment for executing |
|
|
* the function. */ |
|
|
ClientData clientData; /* Ignored. */ |
|
|
{ |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
register Tcl_Obj *valuePtr; |
|
|
double dResult; |
|
|
int result; |
|
|
|
|
|
/* |
|
|
* Set stackPtr and stackTop from eePtr. |
|
|
*/ |
|
|
|
|
|
result = TCL_OK; |
|
|
CACHE_STACK_INFO(); |
|
|
|
|
|
/* |
|
|
* Pop the argument from the evaluation stack. |
|
|
*/ |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
|
|
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
dResult = (double) valuePtr->internalRep.longValue; |
|
|
} else { |
|
|
dResult = valuePtr->internalRep.doubleValue; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Push a Tcl object with the result. |
|
|
*/ |
|
|
|
|
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
|
|
|
|
|
/* |
|
|
* Reflect the change to stackTop back in eePtr. |
|
|
*/ |
|
|
|
|
|
done: |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
DECACHE_STACK_INFO(); |
|
|
return result; |
|
|
} |
|
|
|
|
|
static int |
|
|
ExprIntFunc(interp, eePtr, clientData) |
|
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
|
|
* function. */ |
|
|
ExecEnv *eePtr; /* Points to the environment for executing |
|
|
* the function. */ |
|
|
ClientData clientData; /* Ignored. */ |
|
|
{ |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
register Tcl_Obj *valuePtr; |
|
|
long iResult; |
|
|
double d; |
|
|
int result; |
|
|
|
|
|
/* |
|
|
* Set stackPtr and stackTop from eePtr. |
|
|
*/ |
|
|
|
|
|
result = TCL_OK; |
|
|
CACHE_STACK_INFO(); |
|
|
|
|
|
/* |
|
|
* Pop the argument from the evaluation stack. |
|
|
*/ |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
|
|
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
iResult = valuePtr->internalRep.longValue; |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
if (d < 0.0) { |
|
|
if (d < (double) (long) LONG_MIN) { |
|
|
tooLarge: |
|
|
Tcl_ResetResult(interp); |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
|
|
"integer value too large to represent", -1); |
|
|
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", |
|
|
"integer value too large to represent", (char *) NULL); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
} else { |
|
|
if (d > (double) LONG_MAX) { |
|
|
goto tooLarge; |
|
|
} |
|
|
} |
|
|
if (IS_NAN(d) || IS_INF(d)) { |
|
|
TclExprFloatError(interp, d); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
iResult = (long) d; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Push a Tcl object with the result. |
|
|
*/ |
|
|
|
|
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
|
|
|
|
|
/* |
|
|
* Reflect the change to stackTop back in eePtr. |
|
|
*/ |
|
|
|
|
|
done: |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
DECACHE_STACK_INFO(); |
|
|
return result; |
|
|
} |
|
|
|
|
|
static int |
|
|
ExprRandFunc(interp, eePtr, clientData) |
|
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
|
|
* function. */ |
|
|
ExecEnv *eePtr; /* Points to the environment for executing |
|
|
* the function. */ |
|
|
ClientData clientData; /* Ignored. */ |
|
|
{ |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
Interp *iPtr = (Interp *) interp; |
|
|
double dResult; |
|
|
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. */ |
|
|
{ |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
Tcl_Obj *valuePtr; |
|
|
long iResult; |
|
|
double d, temp; |
|
|
int result; |
|
|
|
|
|
/* |
|
|
* Set stackPtr and stackTop from eePtr. |
|
|
*/ |
|
|
|
|
|
result = TCL_OK; |
|
|
CACHE_STACK_INFO(); |
|
|
|
|
|
/* |
|
|
* Pop the argument from the evaluation stack. |
|
|
*/ |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
|
|
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
iResult = valuePtr->internalRep.longValue; |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
if (d < 0.0) { |
|
|
if (d <= (((double) (long) LONG_MIN) - 0.5)) { |
|
|
tooLarge: |
|
|
Tcl_ResetResult(interp); |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
|
|
"integer value too large to represent", -1); |
|
|
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", |
|
|
"integer value too large to represent", |
|
|
(char *) NULL); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
temp = (long) (d - 0.5); |
|
|
} else { |
|
|
if (d >= (((double) LONG_MAX + 0.5))) { |
|
|
goto tooLarge; |
|
|
} |
|
|
temp = (long) (d + 0.5); |
|
|
} |
|
|
if (IS_NAN(temp) || IS_INF(temp)) { |
|
|
TclExprFloatError(interp, temp); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
iResult = (long) temp; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Push a Tcl object with the result. |
|
|
*/ |
|
|
|
|
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
|
|
|
|
|
/* |
|
|
* Reflect the change to stackTop back in eePtr. |
|
|
*/ |
|
|
|
|
|
done: |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
DECACHE_STACK_INFO(); |
|
|
return result; |
|
|
} |
|
|
|
|
|
static int |
|
|
ExprSrandFunc(interp, eePtr, clientData) |
|
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
|
|
* function. */ |
|
|
ExecEnv *eePtr; /* Points to the environment for executing |
|
|
* the function. */ |
|
|
ClientData clientData; /* Ignored. */ |
|
|
{ |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
Interp *iPtr = (Interp *) interp; |
|
|
Tcl_Obj *valuePtr; |
|
|
long i = 0; /* Initialized to avoid compiler warning. */ |
|
|
int result; |
|
|
|
|
|
/* |
|
|
* Set stackPtr and stackTop from eePtr. |
|
|
*/ |
|
|
|
|
|
CACHE_STACK_INFO(); |
|
|
|
|
|
/* |
|
|
* Pop the argument from the evaluation stack. Use the value |
|
|
* to reset the random number seed. |
|
|
*/ |
|
|
|
|
|
valuePtr = POP_OBJECT(); |
|
|
|
|
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
|
|
result = TCL_ERROR; |
|
|
goto badValue; |
|
|
} |
|
|
|
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
} else { |
|
|
/* |
|
|
* At this point, the only other possible type is double |
|
|
*/ |
|
|
Tcl_ResetResult(interp); |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
|
|
"can't use floating-point value as argument to srand", |
|
|
(char *) NULL); |
|
|
badValue: |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
DECACHE_STACK_INFO(); |
|
|
return TCL_ERROR; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Reset the seed. |
|
|
*/ |
|
|
|
|
|
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; |
|
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
|
|
register int stackTop; /* Cached top index of evaluation stack. */ |
|
|
char *funcName; |
|
|
Tcl_HashEntry *hPtr; |
|
|
MathFunc *mathFuncPtr; /* Information about math function. */ |
|
|
Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ |
|
|
Tcl_Value funcResult; /* Result of function call as Tcl_Value. */ |
|
|
register Tcl_Obj *valuePtr; |
|
|
long i; |
|
|
double d; |
|
|
int j, k, result; |
|
|
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
|
|
|
|
|
Tcl_ResetResult(interp); |
|
|
|
|
|
/* |
|
|
* Set stackPtr and stackTop from eePtr. |
|
|
*/ |
|
|
|
|
|
CACHE_STACK_INFO(); |
|
|
|
|
|
/* |
|
|
* Look up the MathFunc record for the function. |
|
|
*/ |
|
|
|
|
|
funcName = Tcl_GetString(objv[0]); |
|
|
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); |
|
|
if (hPtr == NULL) { |
|
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
|
|
"unknown math function \"", funcName, "\"", (char *) NULL); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); |
|
|
if (mathFuncPtr->numArgs != (objc-1)) { |
|
|
panic("ExprCallMathFunc: expected number of args %d != actual number %d", |
|
|
mathFuncPtr->numArgs, objc); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Collect the arguments for the function, if there are any, into the |
|
|
* array "args". Note that args[0] will have the Tcl_Value that |
|
|
* corresponds to objv[1]. |
|
|
*/ |
|
|
|
|
|
for (j = 1, k = 0; j < objc; j++, k++) { |
|
|
valuePtr = objv[j]; |
|
|
|
|
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Copy the object's numeric value to the argument record, |
|
|
* converting it if necessary. |
|
|
*/ |
|
|
|
|
|
if (valuePtr->typePtr == &tclIntType) { |
|
|
i = valuePtr->internalRep.longValue; |
|
|
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { |
|
|
args[k].type = TCL_DOUBLE; |
|
|
args[k].doubleValue = i; |
|
|
} else { |
|
|
args[k].type = TCL_INT; |
|
|
args[k].intValue = i; |
|
|
} |
|
|
} else { |
|
|
d = valuePtr->internalRep.doubleValue; |
|
|
if (mathFuncPtr->argTypes[k] == TCL_INT) { |
|
|
args[k].type = TCL_INT; |
|
|
args[k].intValue = (long) d; |
|
|
} else { |
|
|
args[k].type = TCL_DOUBLE; |
|
|
args[k].doubleValue = d; |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
* Invoke the function and copy its result back into valuePtr. |
|
|
*/ |
|
|
|
|
|
tsdPtr->mathInProgress++; |
|
|
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, |
|
|
&funcResult); |
|
|
tsdPtr->mathInProgress--; |
|
|
if (result != TCL_OK) { |
|
|
goto done; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Pop the objc top stack elements and decrement their ref counts. |
|
|
*/ |
|
|
|
|
|
i = (stackTop - (objc-1)); |
|
|
while (i <= stackTop) { |
|
|
valuePtr = stackPtr[i]; |
|
|
Tcl_DecrRefCount(valuePtr); |
|
|
i++; |
|
|
} |
|
|
stackTop -= objc; |
|
|
|
|
|
/* |
|
|
* Push the call's object result. |
|
|
*/ |
|
|
|
|
|
if (funcResult.type == TCL_INT) { |
|
|
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue)); |
|
|
} else { |
|
|
d = funcResult.doubleValue; |
|
|
if (IS_NAN(d) || IS_INF(d)) { |
|
|
TclExprFloatError(interp, d); |
|
|
result = TCL_ERROR; |
|
|
goto done; |
|
|
} |
|
|
PUSH_OBJECT(Tcl_NewDoubleObj(d)); |
|
|
} |
|
|
|
|
|
/* |
|
|
* Reflect the change to stackTop back in eePtr. |
|
|
*/ |
|
|
|
|
|
done: |
|
|
DECACHE_STACK_INFO(); |
|
|
return result; |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* TclExprFloatError -- |
|
|
* |
|
|
* This procedure is called when an error occurs during a |
|
|
* floating-point operation. It reads errno and sets |
|
|
* interp->objResultPtr accordingly. |
|
|
* |
|
|
* Results: |
|
|
* interp->objResultPtr is set to hold an error message. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
void |
|
|
TclExprFloatError(interp, value) |
|
|
Tcl_Interp *interp; /* Where to store error message. */ |
|
|
double value; /* Value returned after error; used to |
|
|
* distinguish underflows from overflows. */ |
|
|
{ |
|
|
char *s; |
|
|
|
|
|
Tcl_ResetResult(interp); |
|
|
if ((errno == EDOM) || (value != value)) { |
|
|
s = "domain error: argument not in valid range"; |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
|
|
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); |
|
|
} else if ((errno == ERANGE) || IS_INF(value)) { |
|
|
if (value == 0.0) { |
|
|
s = "floating-point value too small to represent"; |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
|
|
Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); |
|
|
} else { |
|
|
s = "floating-point value too large to represent"; |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
|
|
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); |
|
|
} |
|
|
} else { |
|
|
char msg[64 + TCL_INTEGER_SPACE]; |
|
|
|
|
|
sprintf(msg, "unknown floating-point error, errno = %d", errno); |
|
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); |
|
|
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* TclMathInProgress -- |
|
|
* |
|
|
* This procedure is called to find out if Tcl is doing math |
|
|
* in this thread. |
|
|
* |
|
|
* Results: |
|
|
* 0 or 1. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
int |
|
|
TclMathInProgress() |
|
|
{ |
|
|
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
|
|
return tsdPtr->mathInProgress; |
|
|
} |
|
|
|
|
|
#ifdef TCL_COMPILE_STATS |
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* TclLog2 -- |
|
|
* |
|
|
* Procedure used while collecting compilation statistics to determine |
|
|
* the log base 2 of an integer. |
|
|
* |
|
|
* Results: |
|
|
* Returns the log base 2 of the operand. If the argument is less |
|
|
* than or equal to zero, a zero is returned. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
int |
|
|
TclLog2(value) |
|
|
register int value; /* The integer for which to compute the |
|
|
* log base 2. */ |
|
|
{ |
|
|
register int n = value; |
|
|
register int result = 0; |
|
|
|
|
|
while (n > 1) { |
|
|
n = n >> 1; |
|
|
result++; |
|
|
} |
|
|
return result; |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* EvalStatsCmd -- |
|
|
* |
|
|
* Implements the "evalstats" command that prints instruction execution |
|
|
* counts to stdout. |
|
|
* |
|
|
* Results: |
|
|
* Standard Tcl results. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static int |
|
|
EvalStatsCmd(unused, interp, argc, argv) |
|
|
ClientData unused; /* Unused. */ |
|
|
Tcl_Interp *interp; /* The current interpreter. */ |
|
|
int argc; /* The number of arguments. */ |
|
|
char **argv; /* The argument strings. */ |
|
|
{ |
|
|
Interp *iPtr = (Interp *) interp; |
|
|
LiteralTable *globalTablePtr = &(iPtr->literalTable); |
|
|
ByteCodeStats *statsPtr = &(iPtr->stats); |
|
|
double totalCodeBytes, currentCodeBytes; |
|
|
double totalLiteralBytes, currentLiteralBytes; |
|
|
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; |
|
|
double strBytesSharedMultX, strBytesSharedOnce; |
|
|
double numInstructions, currentHeaderBytes; |
|
|
long numCurrentByteCodes, numByteCodeLits; |
|
|
long refCountSum, literalMgmtBytes, sum; |
|
|
int numSharedMultX, numSharedOnce; |
|
|
int decadeHigh, minSizeDecade, maxSizeDecade, length, i; |
|
|
char *litTableStats; |
|
|
LiteralEntry *entryPtr; |
|
|
|
|
|
numInstructions = 0.0; |
|
|
for (i = 0; i < 256; i++) { |
|
|
if (statsPtr->instructionCount[i] != 0) { |
|
|
numInstructions += statsPtr->instructionCount[i]; |
|
|
} |
|
|
} |
|
|
|
|
|
totalLiteralBytes = sizeof(LiteralTable) |
|
|
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) |
|
|
+ (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) |
|
|
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) |
|
|
+ statsPtr->totalLitStringBytes; |
|
|
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; |
|
|
|
|
|
numCurrentByteCodes = |
|
|
statsPtr->numCompilations - statsPtr->numByteCodesFreed; |
|
|
currentHeaderBytes = numCurrentByteCodes |
|
|
* (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); |
|
|
literalMgmtBytes = sizeof(LiteralTable) |
|
|
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) |
|
|
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); |
|
|
currentLiteralBytes = literalMgmtBytes |
|
|
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj) |
|
|
+ statsPtr->currentLitStringBytes; |
|
|
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; |
|
|
|
|
|
/* |
|
|
* Summary statistics, total and current source and ByteCode sizes. |
|
|
*/ |
|
|
|
|
|
fprintf(stdout, "\n----------------------------------------------------------------\n"); |
|
|
fprintf(stdout, |
|
|
"Compilation and execution statistics for interpreter 0x%x\n", |
|
|
(unsigned int) iPtr); |
|
|
|
|
|
fprintf(stdout, "\nNumber ByteCodes executed %ld\n", |
|
|
statsPtr->numExecutions); |
|
|
fprintf(stdout, "Number ByteCodes compiled %ld\n", |
|
|
statsPtr->numCompilations); |
|
|
fprintf(stdout, " Mean executions/compile %.1f\n", |
|
|
((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); |
|
|
|
|
|
fprintf(stdout, "\nInstructions executed %.0f\n", |
|
|
numInstructions); |
|
|
fprintf(stdout, " Mean inst/compile %.0f\n", |
|
|
numInstructions / statsPtr->numCompilations); |
|
|
fprintf(stdout, " Mean inst/execution %.0f\n", |
|
|
numInstructions / statsPtr->numExecutions); |
|
|
|
|
|
fprintf(stdout, "\nTotal ByteCodes %ld\n", |
|
|
statsPtr->numCompilations); |
|
|
fprintf(stdout, " Source bytes %.6g\n", |
|
|
statsPtr->totalSrcBytes); |
|
|
fprintf(stdout, " Code bytes %.6g\n", |
|
|
totalCodeBytes); |
|
|
fprintf(stdout, " ByteCode bytes %.6g\n", |
|
|
statsPtr->totalByteCodeBytes); |
|
|
fprintf(stdout, " Literal bytes %.6g\n", |
|
|
totalLiteralBytes); |
|
|
fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n", |
|
|
sizeof(LiteralTable), |
|
|
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
|
|
statsPtr->numLiteralsCreated * sizeof(LiteralEntry), |
|
|
statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), |
|
|
statsPtr->totalLitStringBytes); |
|
|
fprintf(stdout, " Mean code/compile %.1f\n", |
|
|
totalCodeBytes / statsPtr->numCompilations); |
|
|
fprintf(stdout, " Mean code/source %.1f\n", |
|
|
totalCodeBytes / statsPtr->totalSrcBytes); |
|
|
|
|
|
fprintf(stdout, "\nCurrent ByteCodes %ld\n", |
|
|
numCurrentByteCodes); |
|
|
fprintf(stdout, " Source bytes %.6g\n", |
|
|
statsPtr->currentSrcBytes); |
|
|
fprintf(stdout, " Code bytes %.6g\n", |
|
|
currentCodeBytes); |
|
|
fprintf(stdout, " ByteCode bytes %.6g\n", |
|
|
statsPtr->currentByteCodeBytes); |
|
|
fprintf(stdout, " Literal bytes %.6g\n", |
|
|
currentLiteralBytes); |
|
|
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", |
|
|
sizeof(LiteralTable), |
|
|
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
|
|
iPtr->literalTable.numEntries * sizeof(LiteralEntry), |
|
|
iPtr->literalTable.numEntries * sizeof(Tcl_Obj), |
|
|
statsPtr->currentLitStringBytes); |
|
|
fprintf(stdout, " Mean code/source %.1f\n", |
|
|
currentCodeBytes / statsPtr->currentSrcBytes); |
|
|
fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", |
|
|
(currentCodeBytes + statsPtr->currentSrcBytes), |
|
|
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); |
|
|
|
|
|
/* |
|
|
* Literal table statistics. |
|
|
*/ |
|
|
|
|
|
numByteCodeLits = 0; |
|
|
refCountSum = 0; |
|
|
numSharedMultX = 0; |
|
|
numSharedOnce = 0; |
|
|
objBytesIfUnshared = 0.0; |
|
|
strBytesIfUnshared = 0.0; |
|
|
strBytesSharedMultX = 0.0; |
|
|
strBytesSharedOnce = 0.0; |
|
|
for (i = 0; i < globalTablePtr->numBuckets; i++) { |
|
|
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; |
|
|
entryPtr = entryPtr->nextPtr) { |
|
|
if (entryPtr->objPtr->typePtr == &tclByteCodeType) { |
|
|
numByteCodeLits++; |
|
|
} |
|
|
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); |
|
|
refCountSum += entryPtr->refCount; |
|
|
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); |
|
|
strBytesIfUnshared += (entryPtr->refCount * (length+1)); |
|
|
if (entryPtr->refCount > 1) { |
|
|
numSharedMultX++; |
|
|
strBytesSharedMultX += (length+1); |
|
|
} else { |
|
|
numSharedOnce++; |
|
|
strBytesSharedOnce += (length+1); |
|
|
} |
|
|
} |
|
|
} |
|
|
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) |
|
|
- currentLiteralBytes; |
|
|
|
|
|
fprintf(stdout, "\nTotal objects (all interps) %ld\n", |
|
|
tclObjsAlloced); |
|
|
fprintf(stdout, "Current objects %ld\n", |
|
|
(tclObjsAlloced - tclObjsFreed)); |
|
|
fprintf(stdout, "Total literal objects %ld\n", |
|
|
statsPtr->numLiteralsCreated); |
|
|
|
|
|
fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", |
|
|
globalTablePtr->numEntries, |
|
|
(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); |
|
|
fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", |
|
|
numByteCodeLits, |
|
|
(numByteCodeLits * 100.0) / globalTablePtr->numEntries); |
|
|
fprintf(stdout, " Literals reused > 1x %d\n", |
|
|
numSharedMultX); |
|
|
fprintf(stdout, " Mean reference count %.2f\n", |
|
|
((double) refCountSum) / globalTablePtr->numEntries); |
|
|
fprintf(stdout, " Mean len, str reused >1x %.2f\n", |
|
|
(numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0)); |
|
|
fprintf(stdout, " Mean len, str used 1x %.2f\n", |
|
|
(numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0)); |
|
|
fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", |
|
|
sharingBytesSaved, |
|
|
(sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared)); |
|
|
fprintf(stdout, " Bytes with sharing %.6g\n", |
|
|
currentLiteralBytes); |
|
|
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", |
|
|
sizeof(LiteralTable), |
|
|
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
|
|
iPtr->literalTable.numEntries * sizeof(LiteralEntry), |
|
|
iPtr->literalTable.numEntries * sizeof(Tcl_Obj), |
|
|
statsPtr->currentLitStringBytes); |
|
|
fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", |
|
|
(objBytesIfUnshared + strBytesIfUnshared), |
|
|
objBytesIfUnshared, strBytesIfUnshared); |
|
|
fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", |
|
|
(strBytesIfUnshared - statsPtr->currentLitStringBytes), |
|
|
strBytesIfUnshared, statsPtr->currentLitStringBytes); |
|
|
fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", |
|
|
literalMgmtBytes, |
|
|
(literalMgmtBytes * 100.0) / currentLiteralBytes); |
|
|
fprintf(stdout, " table %d + buckets %d + entries %d\n", |
|
|
sizeof(LiteralTable), |
|
|
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
|
|
iPtr->literalTable.numEntries * sizeof(LiteralEntry)); |
|
|
|
|
|
/* |
|
|
* Breakdown of current ByteCode space requirements. |
|
|
*/ |
|
|
|
|
|
fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); |
|
|
fprintf(stdout, " Bytes Pct of Avg per\n"); |
|
|
fprintf(stdout, " total ByteCode\n"); |
|
|
fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", |
|
|
statsPtr->currentByteCodeBytes, |
|
|
statsPtr->currentByteCodeBytes / numCurrentByteCodes); |
|
|
fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", |
|
|
currentHeaderBytes, |
|
|
((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes), |
|
|
currentHeaderBytes / numCurrentByteCodes); |
|
|
fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", |
|
|
statsPtr->currentInstBytes, |
|
|
((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes), |
|
|
statsPtr->currentInstBytes / numCurrentByteCodes); |
|
|
fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", |
|
|
statsPtr->currentLitBytes, |
|
|
((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes), |
|
|
statsPtr->currentLitBytes / numCurrentByteCodes); |
|
|
fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", |
|
|
statsPtr->currentExceptBytes, |
|
|
((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes), |
|
|
statsPtr->currentExceptBytes / numCurrentByteCodes); |
|
|
fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", |
|
|
statsPtr->currentAuxBytes, |
|
|
((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes), |
|
|
statsPtr->currentAuxBytes / numCurrentByteCodes); |
|
|
fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", |
|
|
statsPtr->currentCmdMapBytes, |
|
|
((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), |
|
|
statsPtr->currentCmdMapBytes / numCurrentByteCodes); |
|
|
|
|
|
/* |
|
|
* Detailed literal statistics. |
|
|
*/ |
|
|
|
|
|
fprintf(stdout, "\nLiteral string sizes:\n"); |
|
|
fprintf(stdout, " Up to length Percentage\n"); |
|
|
maxSizeDecade = 0; |
|
|
for (i = 31; i >= 0; i--) { |
|
|
if (statsPtr->literalCount[i] > 0) { |
|
|
maxSizeDecade = i; |
|
|
break; |
|
|
} |
|
|
} |
|
|
sum = 0; |
|
|
for (i = 0; i <= maxSizeDecade; i++) { |
|
|
decadeHigh = (1 << (i+1)) - 1; |
|
|
sum += statsPtr->literalCount[i]; |
|
|
fprintf(stdout, " %10d %8.0f%%\n", |
|
|
decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); |
|
|
} |
|
|
|
|
|
litTableStats = TclLiteralStats(globalTablePtr); |
|
|
fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", |
|
|
litTableStats); |
|
|
ckfree((char *) litTableStats); |
|
|
|
|
|
/* |
|
|
* Source and ByteCode size distributions. |
|
|
*/ |
|
|
|
|
|
fprintf(stdout, "\nSource sizes:\n"); |
|
|
fprintf(stdout, " Up to size Percentage\n"); |
|
|
minSizeDecade = maxSizeDecade = 0; |
|
|
for (i = 0; i < 31; i++) { |
|
|
if (statsPtr->srcCount[i] > 0) { |
|
|
minSizeDecade = i; |
|
|
break; |
|
|
} |
|
|
} |
|
|
for (i = 31; i >= 0; i--) { |
|
|
if (statsPtr->srcCount[i] > 0) { |
|
|
maxSizeDecade = i; |
|
|
break; |
|
|
} |
|
|
} |
|
|
sum = 0; |
|
|
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
|
|
decadeHigh = (1 << (i+1)) - 1; |
|
|
sum += statsPtr->srcCount[i]; |
|
|
fprintf(stdout, " %10d %8.0f%%\n", |
|
|
decadeHigh, (sum * 100.0) / statsPtr->numCompilations); |
|
|
} |
|
|
|
|
|
fprintf(stdout, "\nByteCode sizes:\n"); |
|
|
fprintf(stdout, " Up to size Percentage\n"); |
|
|
minSizeDecade = maxSizeDecade = 0; |
|
|
for (i = 0; i < 31; i++) { |
|
|
if (statsPtr->byteCodeCount[i] > 0) { |
|
|
minSizeDecade = i; |
|
|
break; |
|
|
} |
|
|
} |
|
|
for (i = 31; i >= 0; i--) { |
|
|
if (statsPtr->byteCodeCount[i] > 0) { |
|
|
maxSizeDecade = i; |
|
|
break; |
|
|
} |
|
|
} |
|
|
sum = 0; |
|
|
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
|
|
decadeHigh = (1 << (i+1)) - 1; |
|
|
sum += statsPtr->byteCodeCount[i]; |
|
|
fprintf(stdout, " %10d %8.0f%%\n", |
|
|
decadeHigh, (sum * 100.0) / statsPtr->numCompilations); |
|
|
} |
|
|
|
|
|
fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n"); |
|
|
fprintf(stdout, " Up to ms Percentage\n"); |
|
|
minSizeDecade = maxSizeDecade = 0; |
|
|
for (i = 0; i < 31; i++) { |
|
|
if (statsPtr->lifetimeCount[i] > 0) { |
|
|
minSizeDecade = i; |
|
|
break; |
|
|
} |
|
|
} |
|
|
for (i = 31; i >= 0; i--) { |
|
|
if (statsPtr->lifetimeCount[i] > 0) { |
|
|
maxSizeDecade = i; |
|
|
break; |
|
|
} |
|
|
} |
|
|
sum = 0; |
|
|
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
|
|
decadeHigh = (1 << (i+1)) - 1; |
|
|
sum += statsPtr->lifetimeCount[i]; |
|
|
fprintf(stdout, " %12.3f %8.0f%%\n", |
|
|
decadeHigh / 1000.0, |
|
|
(sum * 100.0) / statsPtr->numByteCodesFreed); |
|
|
} |
|
|
|
|
|
/* |
|
|
* Instruction counts. |
|
|
*/ |
|
|
|
|
|
fprintf(stdout, "\nInstruction counts:\n"); |
|
|
for (i = 0; i <= LAST_INST_OPCODE; i++) { |
|
|
if (statsPtr->instructionCount[i]) { |
|
|
fprintf(stdout, "%20s %8ld %6.1f%%\n", |
|
|
instructionTable[i].name, |
|
|
statsPtr->instructionCount[i], |
|
|
(statsPtr->instructionCount[i]*100.0) / numInstructions); |
|
|
} |
|
|
} |
|
|
|
|
|
fprintf(stdout, "\nInstructions NEVER executed:\n"); |
|
|
for (i = 0; i <= LAST_INST_OPCODE; i++) { |
|
|
if (statsPtr->instructionCount[i] == 0) { |
|
|
fprintf(stdout, "%20s\n", |
|
|
instructionTable[i].name); |
|
|
} |
|
|
} |
|
|
|
|
|
#ifdef TCL_MEM_DEBUG |
|
|
fprintf(stdout, "\nHeap Statistics:\n"); |
|
|
TclDumpMemoryInfo(stdout); |
|
|
#endif |
|
|
fprintf(stdout, "\n----------------------------------------------------------------\n"); |
|
|
return TCL_OK; |
|
|
} |
|
|
#endif /* TCL_COMPILE_STATS */ |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* Tcl_GetCommandFromObj -- |
|
|
* |
|
|
* Returns the command specified by the name in a Tcl_Obj. |
|
|
* |
|
|
* Results: |
|
|
* Returns a token for the command if it is found. Otherwise, if it |
|
|
* can't be found or there is an error, returns NULL. |
|
|
* |
|
|
* Side effects: |
|
|
* May update the internal representation for the object, caching |
|
|
* the command reference so that the next time this procedure is |
|
|
* called with the same object, the command can be found quickly. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
Tcl_Command |
|
|
Tcl_GetCommandFromObj(interp, objPtr) |
|
|
Tcl_Interp *interp; /* The interpreter in which to resolve the |
|
|
* command and to report errors. */ |
|
|
register Tcl_Obj *objPtr; /* The object containing the command's |
|
|
* name. If the name starts with "::", will |
|
|
* be looked up in global namespace. Else, |
|
|
* looked up first in the current namespace |
|
|
* if contextNsPtr is NULL, then in global |
|
|
* namespace. */ |
|
|
{ |
|
|
Interp *iPtr = (Interp *) interp; |
|
|
register ResolvedCmdName *resPtr; |
|
|
register Command *cmdPtr; |
|
|
Namespace *currNsPtr; |
|
|
int result; |
|
|
|
|
|
/* |
|
|
* Get the internal representation, converting to a command type if |
|
|
* needed. The internal representation is a ResolvedCmdName that points |
|
|
* to the actual command. |
|
|
*/ |
|
|
|
|
|
if (objPtr->typePtr != &tclCmdNameType) { |
|
|
result = tclCmdNameType.setFromAnyProc(interp, objPtr); |
|
|
if (result != TCL_OK) { |
|
|
return (Tcl_Command) NULL; |
|
|
} |
|
|
} |
|
|
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
|
|
|
|
|
/* |
|
|
* Get the current namespace. |
|
|
*/ |
|
|
|
|
|
if (iPtr->varFramePtr != NULL) { |
|
|
currNsPtr = iPtr->varFramePtr->nsPtr; |
|
|
} else { |
|
|
currNsPtr = iPtr->globalNsPtr; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Check the context namespace and the namespace epoch of the resolved |
|
|
* symbol to make sure that it is fresh. If not, then force another |
|
|
* conversion to the command type, to discard the old rep and create a |
|
|
* new one. Note that we verify that the namespace id of the context |
|
|
* namespace is the same as the one we cached; this insures that the |
|
|
* namespace wasn't deleted and a new one created at the same address |
|
|
* with the same command epoch. |
|
|
*/ |
|
|
|
|
|
cmdPtr = NULL; |
|
|
if ((resPtr != NULL) |
|
|
&& (resPtr->refNsPtr == currNsPtr) |
|
|
&& (resPtr->refNsId == currNsPtr->nsId) |
|
|
&& (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { |
|
|
cmdPtr = resPtr->cmdPtr; |
|
|
if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { |
|
|
cmdPtr = NULL; |
|
|
} |
|
|
} |
|
|
|
|
|
if (cmdPtr == NULL) { |
|
|
result = tclCmdNameType.setFromAnyProc(interp, objPtr); |
|
|
if (result != TCL_OK) { |
|
|
return (Tcl_Command) NULL; |
|
|
} |
|
|
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
|
|
if (resPtr != NULL) { |
|
|
cmdPtr = resPtr->cmdPtr; |
|
|
} |
|
|
} |
|
|
return (Tcl_Command) cmdPtr; |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* TclSetCmdNameObj -- |
|
|
* |
|
|
* Modify an object to be an CmdName object that refers to the argument |
|
|
* Command structure. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* The object's old internal rep is freed. It's string rep is not |
|
|
* changed. The refcount in the Command structure is incremented to |
|
|
* keep it from being freed if the command is later deleted until |
|
|
* TclExecuteByteCode has a chance to recognize that it was deleted. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
void |
|
|
TclSetCmdNameObj(interp, objPtr, cmdPtr) |
|
|
Tcl_Interp *interp; /* Points to interpreter containing command |
|
|
* that should be cached in objPtr. */ |
|
|
register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to |
|
|
* a CmdName object. */ |
|
|
Command *cmdPtr; /* Points to Command structure that the |
|
|
* CmdName object should refer to. */ |
|
|
{ |
|
|
Interp *iPtr = (Interp *) interp; |
|
|
register ResolvedCmdName *resPtr; |
|
|
Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
|
|
register Namespace *currNsPtr; |
|
|
|
|
|
if (oldTypePtr == &tclCmdNameType) { |
|
|
return; |
|
|
} |
|
|
|
|
|
/* |
|
|
* Get the current namespace. |
|
|
*/ |
|
|
|
|
|
if (iPtr->varFramePtr != NULL) { |
|
|
currNsPtr = iPtr->varFramePtr->nsPtr; |
|
|
} else { |
|
|
currNsPtr = iPtr->globalNsPtr; |
|
|
} |
|
|
|
|
|
cmdPtr->refCount++; |
|
|
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); |
|
|
resPtr->cmdPtr = cmdPtr; |
|
|
resPtr->refNsPtr = currNsPtr; |
|
|
resPtr->refNsId = currNsPtr->nsId; |
|
|
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; |
|
|
resPtr->cmdEpoch = cmdPtr->cmdEpoch; |
|
|
resPtr->refCount = 1; |
|
|
|
|
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
|
|
oldTypePtr->freeIntRepProc(objPtr); |
|
|
} |
|
|
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
|
|
objPtr->internalRep.twoPtrValue.ptr2 = NULL; |
|
|
objPtr->typePtr = &tclCmdNameType; |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* FreeCmdNameInternalRep -- |
|
|
* |
|
|
* Frees the resources associated with a cmdName object's internal |
|
|
* representation. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* Decrements the ref count of any cached ResolvedCmdName structure |
|
|
* pointed to by the cmdName's internal representation. If this is |
|
|
* the last use of the ResolvedCmdName, it is freed. This in turn |
|
|
* decrements the ref count of the Command structure pointed to by |
|
|
* the ResolvedSymbol, which may free the Command structure. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static void |
|
|
FreeCmdNameInternalRep(objPtr) |
|
|
register Tcl_Obj *objPtr; /* CmdName object with internal |
|
|
* representation to free. */ |
|
|
{ |
|
|
register ResolvedCmdName *resPtr = |
|
|
(ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
|
|
|
|
|
if (resPtr != NULL) { |
|
|
/* |
|
|
* Decrement the reference count of the ResolvedCmdName structure. |
|
|
* If there are no more uses, free the ResolvedCmdName structure. |
|
|
*/ |
|
|
|
|
|
resPtr->refCount--; |
|
|
if (resPtr->refCount == 0) { |
|
|
/* |
|
|
* Now free the cached command, unless it is still in its |
|
|
* hash table or if there are other references to it |
|
|
* from other cmdName objects. |
|
|
*/ |
|
|
|
|
|
Command *cmdPtr = resPtr->cmdPtr; |
|
|
TclCleanupCommand(cmdPtr); |
|
|
ckfree((char *) resPtr); |
|
|
} |
|
|
} |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* DupCmdNameInternalRep -- |
|
|
* |
|
|
* Initialize the internal representation of an cmdName Tcl_Obj to a |
|
|
* copy of the internal representation of an existing cmdName object. |
|
|
* |
|
|
* Results: |
|
|
* None. |
|
|
* |
|
|
* Side effects: |
|
|
* "copyPtr"s internal rep is set to point to the ResolvedCmdName |
|
|
* structure corresponding to "srcPtr"s internal rep. Increments the |
|
|
* ref count of the ResolvedCmdName structure pointed to by the |
|
|
* cmdName's internal representation. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static void |
|
|
DupCmdNameInternalRep(srcPtr, copyPtr) |
|
|
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ |
|
|
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ |
|
|
{ |
|
|
register ResolvedCmdName *resPtr = |
|
|
(ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; |
|
|
|
|
|
copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
|
|
copyPtr->internalRep.twoPtrValue.ptr2 = NULL; |
|
|
if (resPtr != NULL) { |
|
|
resPtr->refCount++; |
|
|
} |
|
|
copyPtr->typePtr = &tclCmdNameType; |
|
|
} |
|
|
|
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* SetCmdNameFromAny -- |
|
|
* |
|
|
* Generate an cmdName internal form for the Tcl object "objPtr". |
|
|
* |
|
|
* Results: |
|
|
* The return value is a standard Tcl result. The conversion always |
|
|
* succeeds and TCL_OK is returned. |
|
|
* |
|
|
* Side effects: |
|
|
* A pointer to a ResolvedCmdName structure that holds a cached pointer |
|
|
* to the command with a name that matches objPtr's string rep is |
|
|
* stored as objPtr's internal representation. This ResolvedCmdName |
|
|
* pointer will be NULL if no matching command was found. The ref count |
|
|
* of the cached Command's structure (if any) is also incremented. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static int |
|
|
SetCmdNameFromAny(interp, objPtr) |
|
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
|
|
register Tcl_Obj *objPtr; /* The object to convert. */ |
|
|
{ |
|
|
Interp *iPtr = (Interp *) interp; |
|
|
char *name; |
|
|
Tcl_Command cmd; |
|
|
register Command *cmdPtr; |
|
|
Namespace *currNsPtr; |
|
|
register ResolvedCmdName *resPtr; |
|
|
|
|
|
/* |
|
|
* Get "objPtr"s string representation. Make it up-to-date if necessary. |
|
|
*/ |
|
|
|
|
|
name = objPtr->bytes; |
|
|
if (name == NULL) { |
|
|
name = Tcl_GetString(objPtr); |
|
|
} |
|
|
|
|
|
/* |
|
|
* Find the Command structure, if any, that describes the command called |
|
|
* "name". Build a ResolvedCmdName that holds a cached pointer to this |
|
|
* Command, and bump the reference count in the referenced Command |
|
|
* structure. A Command structure will not be deleted as long as it is |
|
|
* referenced from a CmdName object. |
|
|
*/ |
|
|
|
|
|
cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, |
|
|
/*flags*/ 0); |
|
|
cmdPtr = (Command *) cmd; |
|
|
if (cmdPtr != NULL) { |
|
|
/* |
|
|
* Get the current namespace. |
|
|
*/ |
|
|
|
|
|
if (iPtr->varFramePtr != NULL) { |
|
|
currNsPtr = iPtr->varFramePtr->nsPtr; |
|
|
} else { |
|
|
currNsPtr = iPtr->globalNsPtr; |
|
|
} |
|
|
|
|
|
cmdPtr->refCount++; |
|
|
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); |
|
|
resPtr->cmdPtr = cmdPtr; |
|
|
resPtr->refNsPtr = currNsPtr; |
|
|
resPtr->refNsId = currNsPtr->nsId; |
|
|
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; |
|
|
resPtr->cmdEpoch = cmdPtr->cmdEpoch; |
|
|
resPtr->refCount = 1; |
|
|
} else { |
|
|
resPtr = NULL; /* no command named "name" was found */ |
|
|
} |
|
|
|
|
|
/* |
|
|
* Free the old internalRep before setting the new one. We do this as |
|
|
* late as possible to allow the conversion code, in particular |
|
|
* GetStringFromObj, to use that old internalRep. If no Command |
|
|
* structure was found, leave NULL as the cached value. |
|
|
*/ |
|
|
|
|
|
if ((objPtr->typePtr != NULL) |
|
|
&& (objPtr->typePtr->freeIntRepProc != NULL)) { |
|
|
objPtr->typePtr->freeIntRepProc(objPtr); |
|
|
} |
|
|
|
|
|
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
|
|
objPtr->internalRep.twoPtrValue.ptr2 = NULL; |
|
|
objPtr->typePtr = &tclCmdNameType; |
|
|
return TCL_OK; |
|
|
} |
|
|
|
|
|
#ifdef TCL_COMPILE_DEBUG |
|
|
/* |
|
|
*---------------------------------------------------------------------- |
|
|
* |
|
|
* StringForResultCode -- |
|
|
* |
|
|
* Procedure that returns a human-readable string representing a |
|
|
* Tcl result code such as TCL_ERROR. |
|
|
* |
|
|
* Results: |
|
|
* If the result code is one of the standard Tcl return codes, the |
|
|
* result is a string representing that code such as "TCL_ERROR". |
|
|
* Otherwise, the result string is that code formatted as a |
|
|
* sequence of decimal digit characters. Note that the resulting |
|
|
* string must not be modified by the caller. |
|
|
* |
|
|
* Side effects: |
|
|
* None. |
|
|
* |
|
|
*---------------------------------------------------------------------- |
|
|
*/ |
|
|
|
|
|
static char * |
|
|
StringForResultCode(result) |
|
|
int result; /* The Tcl result code for which to |
|
|
* generate a string. */ |
|
|
{ |
|
|
static char buf[TCL_INTEGER_SPACE]; |
|
|
|
|
|
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { |
|
|
return resultStrings[result]; |
|
|
} |
|
|
TclFormatInt(buf, result); |
|
|
return buf; |
|
|
} |
|
|
#endif /* TCL_COMPILE_DEBUG */ |
|
|
|
|
|
|
|
|
/* $History: tclexecute.c $ |
|
|
* |
|
|
* ***************** Version 1 ***************** |
|
|
* User: Dtashley Date: 1/02/01 Time: 1:31a |
|
|
* Created in $/IjuScripter, IjuConsole/Source/Tcl Base |
|
|
* Initial check-in. |
|
|
*/ |
|
|
|
|
|
/* End of TCLEXECUTE.C */ |
|
1 |
|
/* $Header$ */ |
2 |
|
/* |
3 |
|
* tclExecute.c -- |
4 |
|
* |
5 |
|
* This file contains procedures that execute byte-compiled Tcl |
6 |
|
* commands. |
7 |
|
* |
8 |
|
* Copyright (c) 1996-1997 Sun Microsystems, Inc. |
9 |
|
* |
10 |
|
* See the file "license.terms" for information on usage and redistribution |
11 |
|
* of this file, and for a DISCLAIMER OF ALL WARRANTIES. |
12 |
|
* |
13 |
|
* RCS: @(#) $Id: tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $ |
14 |
|
*/ |
15 |
|
|
16 |
|
#include "tclInt.h" |
17 |
|
#include "tclCompile.h" |
18 |
|
|
19 |
|
#ifdef NO_FLOAT_H |
20 |
|
# include "../compat/float.h" |
21 |
|
#else |
22 |
|
# include <float.h> |
23 |
|
#endif |
24 |
|
#ifndef TCL_NO_MATH |
25 |
|
#include "tclMath.h" |
26 |
|
#endif |
27 |
|
|
28 |
|
/* |
29 |
|
* The stuff below is a bit of a hack so that this file can be used |
30 |
|
* in environments that include no UNIX, i.e. no errno. Just define |
31 |
|
* errno here. |
32 |
|
*/ |
33 |
|
|
34 |
|
#ifndef TCL_GENERIC_ONLY |
35 |
|
#include "tclPort.h" |
36 |
|
#else |
37 |
|
#define NO_ERRNO_H |
38 |
|
#endif |
39 |
|
|
40 |
|
#ifdef NO_ERRNO_H |
41 |
|
int errno; |
42 |
|
#define EDOM 33 |
43 |
|
#define ERANGE 34 |
44 |
|
#endif |
45 |
|
|
46 |
|
/* |
47 |
|
* Boolean flag indicating whether the Tcl bytecode interpreter has been |
48 |
|
* initialized. |
49 |
|
*/ |
50 |
|
|
51 |
|
static int execInitialized = 0; |
52 |
|
TCL_DECLARE_MUTEX(execMutex) |
53 |
|
|
54 |
|
/* |
55 |
|
* Variable that controls whether execution tracing is enabled and, if so, |
56 |
|
* what level of tracing is desired: |
57 |
|
* 0: no execution tracing |
58 |
|
* 1: trace invocations of Tcl procs only |
59 |
|
* 2: trace invocations of all (not compiled away) commands |
60 |
|
* 3: display each instruction executed |
61 |
|
* This variable is linked to the Tcl variable "tcl_traceExec". |
62 |
|
*/ |
63 |
|
|
64 |
|
int tclTraceExec = 0; |
65 |
|
|
66 |
|
typedef struct ThreadSpecificData { |
67 |
|
/* |
68 |
|
* The following global variable is use to signal matherr that Tcl |
69 |
|
* is responsible for the arithmetic, so errors can be handled in a |
70 |
|
* fashion appropriate for Tcl. Zero means no Tcl math is in |
71 |
|
* progress; non-zero means Tcl is doing math. |
72 |
|
*/ |
73 |
|
|
74 |
|
int mathInProgress; |
75 |
|
|
76 |
|
} ThreadSpecificData; |
77 |
|
|
78 |
|
static Tcl_ThreadDataKey dataKey; |
79 |
|
|
80 |
|
/* |
81 |
|
* The variable below serves no useful purpose except to generate |
82 |
|
* a reference to matherr, so that the Tcl version of matherr is |
83 |
|
* linked in rather than the system version. Without this reference |
84 |
|
* the need for matherr won't be discovered during linking until after |
85 |
|
* libtcl.a has been processed, so Tcl's version won't be used. |
86 |
|
*/ |
87 |
|
|
88 |
|
#ifdef NEED_MATHERR |
89 |
|
extern int matherr(); |
90 |
|
int (*tclMatherrPtr)() = matherr; |
91 |
|
#endif |
92 |
|
|
93 |
|
/* |
94 |
|
* Mapping from expression instruction opcodes to strings; used for error |
95 |
|
* messages. Note that these entries must match the order and number of the |
96 |
|
* expression opcodes (e.g., INST_LOR) in tclCompile.h. |
97 |
|
*/ |
98 |
|
|
99 |
|
static char *operatorStrings[] = { |
100 |
|
"||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", |
101 |
|
"+", "-", "*", "/", "%", "+", "-", "~", "!", |
102 |
|
"BUILTIN FUNCTION", "FUNCTION" |
103 |
|
}; |
104 |
|
|
105 |
|
/* |
106 |
|
* Mapping from Tcl result codes to strings; used for error and debugging |
107 |
|
* messages. |
108 |
|
*/ |
109 |
|
|
110 |
|
#ifdef TCL_COMPILE_DEBUG |
111 |
|
static char *resultStrings[] = { |
112 |
|
"TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" |
113 |
|
}; |
114 |
|
#endif |
115 |
|
|
116 |
|
/* |
117 |
|
* Macros for testing floating-point values for certain special cases. Test |
118 |
|
* for not-a-number by comparing a value against itself; test for infinity |
119 |
|
* by comparing against the largest floating-point value. |
120 |
|
*/ |
121 |
|
|
122 |
|
#define IS_NAN(v) ((v) != (v)) |
123 |
|
#ifdef DBL_MAX |
124 |
|
# define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) |
125 |
|
#else |
126 |
|
# define IS_INF(v) 0 |
127 |
|
#endif |
128 |
|
|
129 |
|
/* |
130 |
|
* Macro to adjust the program counter and restart the instruction execution |
131 |
|
* loop after each instruction is executed. |
132 |
|
*/ |
133 |
|
|
134 |
|
#define ADJUST_PC(instBytes) \ |
135 |
|
pc += (instBytes); \ |
136 |
|
continue |
137 |
|
|
138 |
|
/* |
139 |
|
* Macros used to cache often-referenced Tcl evaluation stack information |
140 |
|
* in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() |
141 |
|
* pair must surround any call inside TclExecuteByteCode (and a few other |
142 |
|
* procedures that use this scheme) that could result in a recursive call |
143 |
|
* to TclExecuteByteCode. |
144 |
|
*/ |
145 |
|
|
146 |
|
#define CACHE_STACK_INFO() \ |
147 |
|
stackPtr = eePtr->stackPtr; \ |
148 |
|
stackTop = eePtr->stackTop |
149 |
|
|
150 |
|
#define DECACHE_STACK_INFO() \ |
151 |
|
eePtr->stackTop = stackTop |
152 |
|
|
153 |
|
/* |
154 |
|
* Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT |
155 |
|
* increments the object's ref count since it makes the stack have another |
156 |
|
* reference pointing to the object. However, POP_OBJECT does not decrement |
157 |
|
* the ref count. This is because the stack may hold the only reference to |
158 |
|
* the object, so the object would be destroyed if its ref count were |
159 |
|
* decremented before the caller had a chance to, e.g., store it in a |
160 |
|
* variable. It is the caller's responsibility to decrement the ref count |
161 |
|
* when it is finished with an object. |
162 |
|
* |
163 |
|
* WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT |
164 |
|
* macro. The actual parameter might be an expression with side effects, |
165 |
|
* and this ensures that it will be executed only once. |
166 |
|
*/ |
167 |
|
|
168 |
|
#define PUSH_OBJECT(objPtr) \ |
169 |
|
Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr)) |
170 |
|
|
171 |
|
#define POP_OBJECT() \ |
172 |
|
(stackPtr[stackTop--]) |
173 |
|
|
174 |
|
/* |
175 |
|
* Macros used to trace instruction execution. The macros TRACE, |
176 |
|
* TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. |
177 |
|
* O2S is only used in TRACE* calls to get a string from an object. |
178 |
|
*/ |
179 |
|
|
180 |
|
#ifdef TCL_COMPILE_DEBUG |
181 |
|
#define TRACE(a) \ |
182 |
|
if (traceInstructions) { \ |
183 |
|
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ |
184 |
|
(unsigned int)(pc - codePtr->codeStart), \ |
185 |
|
GetOpcodeName(pc)); \ |
186 |
|
printf a; \ |
187 |
|
} |
188 |
|
#define TRACE_WITH_OBJ(a, objPtr) \ |
189 |
|
if (traceInstructions) { \ |
190 |
|
fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ |
191 |
|
(unsigned int)(pc - codePtr->codeStart), \ |
192 |
|
GetOpcodeName(pc)); \ |
193 |
|
printf a; \ |
194 |
|
TclPrintObject(stdout, (objPtr), 30); \ |
195 |
|
fprintf(stdout, "\n"); \ |
196 |
|
} |
197 |
|
#define O2S(objPtr) \ |
198 |
|
Tcl_GetString(objPtr) |
199 |
|
#else |
200 |
|
#define TRACE(a) |
201 |
|
#define TRACE_WITH_OBJ(a, objPtr) |
202 |
|
#define O2S(objPtr) |
203 |
|
#endif /* TCL_COMPILE_DEBUG */ |
204 |
|
|
205 |
|
/* |
206 |
|
* Declarations for local procedures to this file: |
207 |
|
*/ |
208 |
|
|
209 |
|
static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp, |
210 |
|
Trace *tracePtr, Command *cmdPtr, |
211 |
|
char *command, int numChars, |
212 |
|
int objc, Tcl_Obj *objv[])); |
213 |
|
static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr, |
214 |
|
Tcl_Obj *copyPtr)); |
215 |
|
static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, |
216 |
|
ExecEnv *eePtr, ClientData clientData)); |
217 |
|
static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp, |
218 |
|
ExecEnv *eePtr, ClientData clientData)); |
219 |
|
static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp, |
220 |
|
ExecEnv *eePtr, int objc, Tcl_Obj **objv)); |
221 |
|
static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp, |
222 |
|
ExecEnv *eePtr, ClientData clientData)); |
223 |
|
static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp, |
224 |
|
ExecEnv *eePtr, ClientData clientData)); |
225 |
|
static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp, |
226 |
|
ExecEnv *eePtr, ClientData clientData)); |
227 |
|
static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp, |
228 |
|
ExecEnv *eePtr, ClientData clientData)); |
229 |
|
static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, |
230 |
|
ExecEnv *eePtr, ClientData clientData)); |
231 |
|
static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, |
232 |
|
ExecEnv *eePtr, ClientData clientData)); |
233 |
|
#ifdef TCL_COMPILE_STATS |
234 |
|
static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, |
235 |
|
Tcl_Interp *interp, int argc, char **argv)); |
236 |
|
#endif |
237 |
|
static void FreeCmdNameInternalRep _ANSI_ARGS_(( |
238 |
|
Tcl_Obj *objPtr)); |
239 |
|
#ifdef TCL_COMPILE_DEBUG |
240 |
|
static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); |
241 |
|
#endif |
242 |
|
static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, |
243 |
|
int catchOnly, ByteCode* codePtr)); |
244 |
|
static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, |
245 |
|
ByteCode* codePtr, int *lengthPtr)); |
246 |
|
static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); |
247 |
|
static void IllegalExprOperandType _ANSI_ARGS_(( |
248 |
|
Tcl_Interp *interp, unsigned char *pc, |
249 |
|
Tcl_Obj *opndPtr)); |
250 |
|
static void InitByteCodeExecution _ANSI_ARGS_(( |
251 |
|
Tcl_Interp *interp)); |
252 |
|
#ifdef TCL_COMPILE_DEBUG |
253 |
|
static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); |
254 |
|
#endif |
255 |
|
static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp, |
256 |
|
Tcl_Obj *objPtr)); |
257 |
|
#ifdef TCL_COMPILE_DEBUG |
258 |
|
static char * StringForResultCode _ANSI_ARGS_((int result)); |
259 |
|
static void ValidatePcAndStackTop _ANSI_ARGS_(( |
260 |
|
ByteCode *codePtr, unsigned char *pc, |
261 |
|
int stackTop, int stackLowerBound, |
262 |
|
int stackUpperBound)); |
263 |
|
#endif |
264 |
|
static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, |
265 |
|
Tcl_Obj *objPtr)); |
266 |
|
|
267 |
|
/* |
268 |
|
* Table describing the built-in math functions. Entries in this table are |
269 |
|
* indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's |
270 |
|
* operand byte. |
271 |
|
*/ |
272 |
|
|
273 |
|
BuiltinFunc builtinFuncTable[] = { |
274 |
|
#ifndef TCL_NO_MATH |
275 |
|
{"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos}, |
276 |
|
{"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin}, |
277 |
|
{"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan}, |
278 |
|
{"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2}, |
279 |
|
{"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil}, |
280 |
|
{"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos}, |
281 |
|
{"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh}, |
282 |
|
{"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp}, |
283 |
|
{"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor}, |
284 |
|
{"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod}, |
285 |
|
{"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot}, |
286 |
|
{"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log}, |
287 |
|
{"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10}, |
288 |
|
{"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow}, |
289 |
|
{"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin}, |
290 |
|
{"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh}, |
291 |
|
{"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt}, |
292 |
|
{"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan}, |
293 |
|
{"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh}, |
294 |
|
#endif |
295 |
|
{"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, |
296 |
|
{"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, |
297 |
|
{"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, |
298 |
|
{"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */ |
299 |
|
{"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, |
300 |
|
{"srand", 1, {TCL_INT}, ExprSrandFunc, 0}, |
301 |
|
{0}, |
302 |
|
}; |
303 |
|
|
304 |
|
/* |
305 |
|
* The structure below defines the command name Tcl object type by means of |
306 |
|
* procedures that can be invoked by generic object code. Objects of this |
307 |
|
* type cache the Command pointer that results from looking up command names |
308 |
|
* in the command hashtable. Such objects appear as the zeroth ("command |
309 |
|
* name") argument in a Tcl command. |
310 |
|
*/ |
311 |
|
|
312 |
|
Tcl_ObjType tclCmdNameType = { |
313 |
|
"cmdName", /* name */ |
314 |
|
FreeCmdNameInternalRep, /* freeIntRepProc */ |
315 |
|
DupCmdNameInternalRep, /* dupIntRepProc */ |
316 |
|
(Tcl_UpdateStringProc *) NULL, /* updateStringProc */ |
317 |
|
SetCmdNameFromAny /* setFromAnyProc */ |
318 |
|
}; |
319 |
|
|
320 |
|
/* |
321 |
|
*---------------------------------------------------------------------- |
322 |
|
* |
323 |
|
* InitByteCodeExecution -- |
324 |
|
* |
325 |
|
* This procedure is called once to initialize the Tcl bytecode |
326 |
|
* interpreter. |
327 |
|
* |
328 |
|
* Results: |
329 |
|
* None. |
330 |
|
* |
331 |
|
* Side effects: |
332 |
|
* This procedure initializes the array of instruction names. If |
333 |
|
* compiling with the TCL_COMPILE_STATS flag, it initializes the |
334 |
|
* array that counts the executions of each instruction and it |
335 |
|
* creates the "evalstats" command. It also registers the command name |
336 |
|
* Tcl_ObjType. It also establishes the link between the Tcl |
337 |
|
* "tcl_traceExec" and C "tclTraceExec" variables. |
338 |
|
* |
339 |
|
*---------------------------------------------------------------------- |
340 |
|
*/ |
341 |
|
|
342 |
|
static void |
343 |
|
InitByteCodeExecution(interp) |
344 |
|
Tcl_Interp *interp; /* Interpreter for which the Tcl variable |
345 |
|
* "tcl_traceExec" is linked to control |
346 |
|
* instruction tracing. */ |
347 |
|
{ |
348 |
|
Tcl_RegisterObjType(&tclCmdNameType); |
349 |
|
if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, |
350 |
|
TCL_LINK_INT) != TCL_OK) { |
351 |
|
panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); |
352 |
|
} |
353 |
|
|
354 |
|
#ifdef TCL_COMPILE_STATS |
355 |
|
Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd, |
356 |
|
(ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); |
357 |
|
#endif /* TCL_COMPILE_STATS */ |
358 |
|
} |
359 |
|
|
360 |
|
/* |
361 |
|
*---------------------------------------------------------------------- |
362 |
|
* |
363 |
|
* TclCreateExecEnv -- |
364 |
|
* |
365 |
|
* This procedure creates a new execution environment for Tcl bytecode |
366 |
|
* execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv |
367 |
|
* is typically created once for each Tcl interpreter (Interp |
368 |
|
* structure) and recursively passed to TclExecuteByteCode to execute |
369 |
|
* ByteCode sequences for nested commands. |
370 |
|
* |
371 |
|
* Results: |
372 |
|
* A newly allocated ExecEnv is returned. This points to an empty |
373 |
|
* evaluation stack of the standard initial size. |
374 |
|
* |
375 |
|
* Side effects: |
376 |
|
* The bytecode interpreter is also initialized here, as this |
377 |
|
* procedure will be called before any call to TclExecuteByteCode. |
378 |
|
* |
379 |
|
*---------------------------------------------------------------------- |
380 |
|
*/ |
381 |
|
|
382 |
|
#define TCL_STACK_INITIAL_SIZE 2000 |
383 |
|
|
384 |
|
ExecEnv * |
385 |
|
TclCreateExecEnv(interp) |
386 |
|
Tcl_Interp *interp; /* Interpreter for which the execution |
387 |
|
* environment is being created. */ |
388 |
|
{ |
389 |
|
ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); |
390 |
|
|
391 |
|
eePtr->stackPtr = (Tcl_Obj **) |
392 |
|
ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); |
393 |
|
eePtr->stackTop = -1; |
394 |
|
eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1); |
395 |
|
|
396 |
|
Tcl_MutexLock(&execMutex); |
397 |
|
if (!execInitialized) { |
398 |
|
TclInitAuxDataTypeTable(); |
399 |
|
InitByteCodeExecution(interp); |
400 |
|
execInitialized = 1; |
401 |
|
} |
402 |
|
Tcl_MutexUnlock(&execMutex); |
403 |
|
|
404 |
|
return eePtr; |
405 |
|
} |
406 |
|
#undef TCL_STACK_INITIAL_SIZE |
407 |
|
|
408 |
|
/* |
409 |
|
*---------------------------------------------------------------------- |
410 |
|
* |
411 |
|
* TclDeleteExecEnv -- |
412 |
|
* |
413 |
|
* Frees the storage for an ExecEnv. |
414 |
|
* |
415 |
|
* Results: |
416 |
|
* None. |
417 |
|
* |
418 |
|
* Side effects: |
419 |
|
* Storage for an ExecEnv and its contained storage (e.g. the |
420 |
|
* evaluation stack) is freed. |
421 |
|
* |
422 |
|
*---------------------------------------------------------------------- |
423 |
|
*/ |
424 |
|
|
425 |
|
void |
426 |
|
TclDeleteExecEnv(eePtr) |
427 |
|
ExecEnv *eePtr; /* Execution environment to free. */ |
428 |
|
{ |
429 |
|
ckfree((char *) eePtr->stackPtr); |
430 |
|
ckfree((char *) eePtr); |
431 |
|
} |
432 |
|
|
433 |
|
/* |
434 |
|
*---------------------------------------------------------------------- |
435 |
|
* |
436 |
|
* TclFinalizeExecution -- |
437 |
|
* |
438 |
|
* Finalizes the execution environment setup so that it can be |
439 |
|
* later reinitialized. |
440 |
|
* |
441 |
|
* Results: |
442 |
|
* None. |
443 |
|
* |
444 |
|
* Side effects: |
445 |
|
* After this call, the next time TclCreateExecEnv will be called |
446 |
|
* it will call InitByteCodeExecution. |
447 |
|
* |
448 |
|
*---------------------------------------------------------------------- |
449 |
|
*/ |
450 |
|
|
451 |
|
void |
452 |
|
TclFinalizeExecution() |
453 |
|
{ |
454 |
|
Tcl_MutexLock(&execMutex); |
455 |
|
execInitialized = 0; |
456 |
|
Tcl_MutexUnlock(&execMutex); |
457 |
|
TclFinalizeAuxDataTypeTable(); |
458 |
|
} |
459 |
|
|
460 |
|
/* |
461 |
|
*---------------------------------------------------------------------- |
462 |
|
* |
463 |
|
* GrowEvaluationStack -- |
464 |
|
* |
465 |
|
* This procedure grows a Tcl evaluation stack stored in an ExecEnv. |
466 |
|
* |
467 |
|
* Results: |
468 |
|
* None. |
469 |
|
* |
470 |
|
* Side effects: |
471 |
|
* The size of the evaluation stack is doubled. |
472 |
|
* |
473 |
|
*---------------------------------------------------------------------- |
474 |
|
*/ |
475 |
|
|
476 |
|
static void |
477 |
|
GrowEvaluationStack(eePtr) |
478 |
|
register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation |
479 |
|
* stack to enlarge. */ |
480 |
|
{ |
481 |
|
/* |
482 |
|
* The current Tcl stack elements are stored from eePtr->stackPtr[0] |
483 |
|
* to eePtr->stackPtr[eePtr->stackEnd] (inclusive). |
484 |
|
*/ |
485 |
|
|
486 |
|
int currElems = (eePtr->stackEnd + 1); |
487 |
|
int newElems = 2*currElems; |
488 |
|
int currBytes = currElems * sizeof(Tcl_Obj *); |
489 |
|
int newBytes = 2*currBytes; |
490 |
|
Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); |
491 |
|
|
492 |
|
/* |
493 |
|
* Copy the existing stack items to the new stack space, free the old |
494 |
|
* storage if appropriate, and mark new space as malloc'ed. |
495 |
|
*/ |
496 |
|
|
497 |
|
memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr, |
498 |
|
(size_t) currBytes); |
499 |
|
ckfree((char *) eePtr->stackPtr); |
500 |
|
eePtr->stackPtr = newStackPtr; |
501 |
|
eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */ |
502 |
|
} |
503 |
|
|
504 |
|
/* |
505 |
|
*---------------------------------------------------------------------- |
506 |
|
* |
507 |
|
* TclExecuteByteCode -- |
508 |
|
* |
509 |
|
* This procedure executes the instructions of a ByteCode structure. |
510 |
|
* It returns when a "done" instruction is executed or an error occurs. |
511 |
|
* |
512 |
|
* Results: |
513 |
|
* The return value is one of the return codes defined in tcl.h |
514 |
|
* (such as TCL_OK), and interp->objResultPtr refers to a Tcl object |
515 |
|
* that either contains the result of executing the code or an |
516 |
|
* error message. |
517 |
|
* |
518 |
|
* Side effects: |
519 |
|
* Almost certainly, depending on the ByteCode's instructions. |
520 |
|
* |
521 |
|
*---------------------------------------------------------------------- |
522 |
|
*/ |
523 |
|
|
524 |
|
int |
525 |
|
TclExecuteByteCode(interp, codePtr) |
526 |
|
Tcl_Interp *interp; /* Token for command interpreter. */ |
527 |
|
ByteCode *codePtr; /* The bytecode sequence to interpret. */ |
528 |
|
{ |
529 |
|
Interp *iPtr = (Interp *) interp; |
530 |
|
ExecEnv *eePtr = iPtr->execEnvPtr; |
531 |
|
/* Points to the execution environment. */ |
532 |
|
register Tcl_Obj **stackPtr = eePtr->stackPtr; |
533 |
|
/* Cached evaluation stack base pointer. */ |
534 |
|
register int stackTop = eePtr->stackTop; |
535 |
|
/* Cached top index of evaluation stack. */ |
536 |
|
register unsigned char *pc = codePtr->codeStart; |
537 |
|
/* The current program counter. */ |
538 |
|
int opnd; /* Current instruction's operand byte. */ |
539 |
|
int pcAdjustment; /* Hold pc adjustment after instruction. */ |
540 |
|
int initStackTop = stackTop;/* Stack top at start of execution. */ |
541 |
|
ExceptionRange *rangePtr; /* Points to closest loop or catch exception |
542 |
|
* range enclosing the pc. Used by various |
543 |
|
* instructions and processCatch to |
544 |
|
* process break, continue, and errors. */ |
545 |
|
int result = TCL_OK; /* Return code returned after execution. */ |
546 |
|
int traceInstructions = (tclTraceExec == 3); |
547 |
|
Tcl_Obj *valuePtr, *value2Ptr, *objPtr; |
548 |
|
char *bytes; |
549 |
|
int length; |
550 |
|
long i; |
551 |
|
|
552 |
|
/* |
553 |
|
* This procedure uses a stack to hold information about catch commands. |
554 |
|
* This information is the current operand stack top when starting to |
555 |
|
* execute the code for each catch command. It starts out with stack- |
556 |
|
* allocated space but uses dynamically-allocated storage if needed. |
557 |
|
*/ |
558 |
|
|
559 |
|
#define STATIC_CATCH_STACK_SIZE 4 |
560 |
|
int (catchStackStorage[STATIC_CATCH_STACK_SIZE]); |
561 |
|
int *catchStackPtr = catchStackStorage; |
562 |
|
int catchTop = -1; |
563 |
|
|
564 |
|
#ifdef TCL_COMPILE_DEBUG |
565 |
|
if (tclTraceExec >= 2) { |
566 |
|
PrintByteCodeInfo(codePtr); |
567 |
|
fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); |
568 |
|
fflush(stdout); |
569 |
|
} |
570 |
|
#endif |
571 |
|
|
572 |
|
#ifdef TCL_COMPILE_STATS |
573 |
|
iPtr->stats.numExecutions++; |
574 |
|
#endif |
575 |
|
|
576 |
|
/* |
577 |
|
* Make sure the catch stack is large enough to hold the maximum number |
578 |
|
* of catch commands that could ever be executing at the same time. This |
579 |
|
* will be no more than the exception range array's depth. |
580 |
|
*/ |
581 |
|
|
582 |
|
if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) { |
583 |
|
catchStackPtr = (int *) |
584 |
|
ckalloc(codePtr->maxExceptDepth * sizeof(int)); |
585 |
|
} |
586 |
|
|
587 |
|
/* |
588 |
|
* Make sure the stack has enough room to execute this ByteCode. |
589 |
|
*/ |
590 |
|
|
591 |
|
while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) { |
592 |
|
GrowEvaluationStack(eePtr); |
593 |
|
stackPtr = eePtr->stackPtr; |
594 |
|
} |
595 |
|
|
596 |
|
/* |
597 |
|
* Loop executing instructions until a "done" instruction, a TCL_RETURN, |
598 |
|
* or some error. |
599 |
|
*/ |
600 |
|
|
601 |
|
for (;;) { |
602 |
|
#ifdef TCL_COMPILE_DEBUG |
603 |
|
ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop, |
604 |
|
eePtr->stackEnd); |
605 |
|
#else /* not TCL_COMPILE_DEBUG */ |
606 |
|
if (traceInstructions) { |
607 |
|
fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop); |
608 |
|
TclPrintInstruction(codePtr, pc); |
609 |
|
fflush(stdout); |
610 |
|
} |
611 |
|
#endif /* TCL_COMPILE_DEBUG */ |
612 |
|
|
613 |
|
#ifdef TCL_COMPILE_STATS |
614 |
|
iPtr->stats.instructionCount[*pc]++; |
615 |
|
#endif |
616 |
|
switch (*pc) { |
617 |
|
case INST_DONE: |
618 |
|
/* |
619 |
|
* Pop the topmost object from the stack, set the interpreter's |
620 |
|
* object result to point to it, and return. |
621 |
|
*/ |
622 |
|
valuePtr = POP_OBJECT(); |
623 |
|
Tcl_SetObjResult(interp, valuePtr); |
624 |
|
TclDecrRefCount(valuePtr); |
625 |
|
if (stackTop != initStackTop) { |
626 |
|
fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n", |
627 |
|
(unsigned int)(pc - codePtr->codeStart), |
628 |
|
(unsigned int) stackTop, |
629 |
|
(unsigned int) initStackTop); |
630 |
|
panic("TclExecuteByteCode execution failure: end stack top != start stack top"); |
631 |
|
} |
632 |
|
TRACE_WITH_OBJ(("=> return code=%d, result=", result), |
633 |
|
iPtr->objResultPtr); |
634 |
|
#ifdef TCL_COMPILE_DEBUG |
635 |
|
if (traceInstructions) { |
636 |
|
fprintf(stdout, "\n"); |
637 |
|
} |
638 |
|
#endif |
639 |
|
goto done; |
640 |
|
|
641 |
|
case INST_PUSH1: |
642 |
|
#ifdef TCL_COMPILE_DEBUG |
643 |
|
valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; |
644 |
|
PUSH_OBJECT(valuePtr); |
645 |
|
TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr); |
646 |
|
#else |
647 |
|
PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]); |
648 |
|
#endif /* TCL_COMPILE_DEBUG */ |
649 |
|
ADJUST_PC(2); |
650 |
|
|
651 |
|
case INST_PUSH4: |
652 |
|
valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; |
653 |
|
PUSH_OBJECT(valuePtr); |
654 |
|
TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr); |
655 |
|
ADJUST_PC(5); |
656 |
|
|
657 |
|
case INST_POP: |
658 |
|
valuePtr = POP_OBJECT(); |
659 |
|
TRACE_WITH_OBJ(("=> discarding "), valuePtr); |
660 |
|
TclDecrRefCount(valuePtr); /* finished with pop'ed object. */ |
661 |
|
ADJUST_PC(1); |
662 |
|
|
663 |
|
case INST_DUP: |
664 |
|
valuePtr = stackPtr[stackTop]; |
665 |
|
PUSH_OBJECT(Tcl_DuplicateObj(valuePtr)); |
666 |
|
TRACE_WITH_OBJ(("=> "), valuePtr); |
667 |
|
ADJUST_PC(1); |
668 |
|
|
669 |
|
case INST_CONCAT1: |
670 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
671 |
|
{ |
672 |
|
Tcl_Obj *concatObjPtr; |
673 |
|
int totalLen = 0; |
674 |
|
|
675 |
|
/* |
676 |
|
* Concatenate strings (with no separators) from the top |
677 |
|
* opnd items on the stack starting with the deepest item. |
678 |
|
* First, determine how many characters are needed. |
679 |
|
*/ |
680 |
|
|
681 |
|
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { |
682 |
|
bytes = Tcl_GetStringFromObj(stackPtr[i], &length); |
683 |
|
if (bytes != NULL) { |
684 |
|
totalLen += length; |
685 |
|
} |
686 |
|
} |
687 |
|
|
688 |
|
/* |
689 |
|
* Initialize the new append string object by appending the |
690 |
|
* strings of the opnd stack objects. Also pop the objects. |
691 |
|
*/ |
692 |
|
|
693 |
|
TclNewObj(concatObjPtr); |
694 |
|
if (totalLen > 0) { |
695 |
|
char *p = (char *) ckalloc((unsigned) (totalLen + 1)); |
696 |
|
concatObjPtr->bytes = p; |
697 |
|
concatObjPtr->length = totalLen; |
698 |
|
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { |
699 |
|
valuePtr = stackPtr[i]; |
700 |
|
bytes = Tcl_GetStringFromObj(valuePtr, &length); |
701 |
|
if (bytes != NULL) { |
702 |
|
memcpy((VOID *) p, (VOID *) bytes, |
703 |
|
(size_t) length); |
704 |
|
p += length; |
705 |
|
} |
706 |
|
TclDecrRefCount(valuePtr); |
707 |
|
} |
708 |
|
*p = '\0'; |
709 |
|
} else { |
710 |
|
for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { |
711 |
|
Tcl_DecrRefCount(stackPtr[i]); |
712 |
|
} |
713 |
|
} |
714 |
|
stackTop -= opnd; |
715 |
|
|
716 |
|
PUSH_OBJECT(concatObjPtr); |
717 |
|
TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr); |
718 |
|
ADJUST_PC(2); |
719 |
|
} |
720 |
|
|
721 |
|
case INST_INVOKE_STK4: |
722 |
|
opnd = TclGetUInt4AtPtr(pc+1); |
723 |
|
pcAdjustment = 5; |
724 |
|
goto doInvocation; |
725 |
|
|
726 |
|
case INST_INVOKE_STK1: |
727 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
728 |
|
pcAdjustment = 2; |
729 |
|
|
730 |
|
doInvocation: |
731 |
|
{ |
732 |
|
int objc = opnd; /* The number of arguments. */ |
733 |
|
Tcl_Obj **objv; /* The array of argument objects. */ |
734 |
|
Command *cmdPtr; /* Points to command's Command struct. */ |
735 |
|
int newPcOffset; /* New inst offset for break, continue. */ |
736 |
|
#ifdef TCL_COMPILE_DEBUG |
737 |
|
int isUnknownCmd = 0; |
738 |
|
char cmdNameBuf[21]; |
739 |
|
#endif /* TCL_COMPILE_DEBUG */ |
740 |
|
|
741 |
|
/* |
742 |
|
* If the interpreter was deleted, return an error. |
743 |
|
*/ |
744 |
|
|
745 |
|
if (iPtr->flags & DELETED) { |
746 |
|
Tcl_ResetResult(interp); |
747 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
748 |
|
"attempt to call eval in deleted interpreter", -1); |
749 |
|
Tcl_SetErrorCode(interp, "CORE", "IDELETE", |
750 |
|
"attempt to call eval in deleted interpreter", |
751 |
|
(char *) NULL); |
752 |
|
result = TCL_ERROR; |
753 |
|
goto checkForCatch; |
754 |
|
} |
755 |
|
|
756 |
|
/* |
757 |
|
* Find the procedure to execute this command. If the |
758 |
|
* command is not found, handle it with the "unknown" proc. |
759 |
|
*/ |
760 |
|
|
761 |
|
objv = &(stackPtr[stackTop - (objc-1)]); |
762 |
|
cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); |
763 |
|
if (cmdPtr == NULL) { |
764 |
|
cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown", |
765 |
|
(Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY); |
766 |
|
if (cmdPtr == NULL) { |
767 |
|
Tcl_ResetResult(interp); |
768 |
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
769 |
|
"invalid command name \"", |
770 |
|
Tcl_GetString(objv[0]), "\"", |
771 |
|
(char *) NULL); |
772 |
|
TRACE(("%u => unknown proc not found: ", objc)); |
773 |
|
result = TCL_ERROR; |
774 |
|
goto checkForCatch; |
775 |
|
} |
776 |
|
#ifdef TCL_COMPILE_DEBUG |
777 |
|
isUnknownCmd = 1; |
778 |
|
#endif /*TCL_COMPILE_DEBUG*/ |
779 |
|
stackTop++; /* need room for new inserted objv[0] */ |
780 |
|
for (i = objc-1; i >= 0; i--) { |
781 |
|
objv[i+1] = objv[i]; |
782 |
|
} |
783 |
|
objc++; |
784 |
|
objv[0] = Tcl_NewStringObj("unknown", -1); |
785 |
|
Tcl_IncrRefCount(objv[0]); |
786 |
|
} |
787 |
|
|
788 |
|
/* |
789 |
|
* Call any trace procedures. |
790 |
|
*/ |
791 |
|
|
792 |
|
if (iPtr->tracePtr != NULL) { |
793 |
|
Trace *tracePtr, *nextTracePtr; |
794 |
|
|
795 |
|
for (tracePtr = iPtr->tracePtr; tracePtr != NULL; |
796 |
|
tracePtr = nextTracePtr) { |
797 |
|
nextTracePtr = tracePtr->nextPtr; |
798 |
|
if (iPtr->numLevels <= tracePtr->level) { |
799 |
|
int numChars; |
800 |
|
char *cmd = GetSrcInfoForPc(pc, codePtr, |
801 |
|
&numChars); |
802 |
|
if (cmd != NULL) { |
803 |
|
DECACHE_STACK_INFO(); |
804 |
|
CallTraceProcedure(interp, tracePtr, cmdPtr, |
805 |
|
cmd, numChars, objc, objv); |
806 |
|
CACHE_STACK_INFO(); |
807 |
|
} |
808 |
|
} |
809 |
|
} |
810 |
|
} |
811 |
|
|
812 |
|
/* |
813 |
|
* Finally, invoke the command's Tcl_ObjCmdProc. First reset |
814 |
|
* the interpreter's string and object results to their |
815 |
|
* default empty values since they could have gotten changed |
816 |
|
* by earlier invocations. |
817 |
|
*/ |
818 |
|
|
819 |
|
Tcl_ResetResult(interp); |
820 |
|
if (tclTraceExec >= 2) { |
821 |
|
#ifdef TCL_COMPILE_DEBUG |
822 |
|
if (traceInstructions) { |
823 |
|
strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20); |
824 |
|
TRACE(("%u => call ", (isUnknownCmd? objc-1:objc))); |
825 |
|
} else { |
826 |
|
fprintf(stdout, "%d: (%u) invoking ", |
827 |
|
iPtr->numLevels, |
828 |
|
(unsigned int)(pc - codePtr->codeStart)); |
829 |
|
} |
830 |
|
for (i = 0; i < objc; i++) { |
831 |
|
TclPrintObject(stdout, objv[i], 15); |
832 |
|
fprintf(stdout, " "); |
833 |
|
} |
834 |
|
fprintf(stdout, "\n"); |
835 |
|
fflush(stdout); |
836 |
|
#else /* TCL_COMPILE_DEBUG */ |
837 |
|
fprintf(stdout, "%d: (%u) invoking %s\n", |
838 |
|
iPtr->numLevels, |
839 |
|
(unsigned int)(pc - codePtr->codeStart), |
840 |
|
Tcl_GetString(objv[0])); |
841 |
|
#endif /*TCL_COMPILE_DEBUG*/ |
842 |
|
} |
843 |
|
|
844 |
|
iPtr->cmdCount++; |
845 |
|
DECACHE_STACK_INFO(); |
846 |
|
result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp, |
847 |
|
objc, objv); |
848 |
|
if (Tcl_AsyncReady()) { |
849 |
|
result = Tcl_AsyncInvoke(interp, result); |
850 |
|
} |
851 |
|
CACHE_STACK_INFO(); |
852 |
|
|
853 |
|
/* |
854 |
|
* If the interpreter has a non-empty string result, the |
855 |
|
* result object is either empty or stale because some |
856 |
|
* procedure set interp->result directly. If so, move the |
857 |
|
* string result to the result object, then reset the |
858 |
|
* string result. |
859 |
|
*/ |
860 |
|
|
861 |
|
if (*(iPtr->result) != 0) { |
862 |
|
(void) Tcl_GetObjResult(interp); |
863 |
|
} |
864 |
|
|
865 |
|
/* |
866 |
|
* Pop the objc top stack elements and decrement their ref |
867 |
|
* counts. |
868 |
|
*/ |
869 |
|
|
870 |
|
for (i = 0; i < objc; i++) { |
871 |
|
valuePtr = stackPtr[stackTop]; |
872 |
|
TclDecrRefCount(valuePtr); |
873 |
|
stackTop--; |
874 |
|
} |
875 |
|
|
876 |
|
/* |
877 |
|
* Process the result of the Tcl_ObjCmdProc call. |
878 |
|
*/ |
879 |
|
|
880 |
|
switch (result) { |
881 |
|
case TCL_OK: |
882 |
|
/* |
883 |
|
* Push the call's object result and continue execution |
884 |
|
* with the next instruction. |
885 |
|
*/ |
886 |
|
PUSH_OBJECT(Tcl_GetObjResult(interp)); |
887 |
|
TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=", |
888 |
|
objc, cmdNameBuf), Tcl_GetObjResult(interp)); |
889 |
|
ADJUST_PC(pcAdjustment); |
890 |
|
|
891 |
|
case TCL_BREAK: |
892 |
|
case TCL_CONTINUE: |
893 |
|
/* |
894 |
|
* The invoked command requested a break or continue. |
895 |
|
* Find the closest enclosing loop or catch exception |
896 |
|
* range, if any. If a loop is found, terminate its |
897 |
|
* execution or skip to its next iteration. If the |
898 |
|
* closest is a catch exception range, jump to its |
899 |
|
* catchOffset. If no enclosing range is found, stop |
900 |
|
* execution and return the TCL_BREAK or TCL_CONTINUE. |
901 |
|
*/ |
902 |
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, |
903 |
|
codePtr); |
904 |
|
if (rangePtr == NULL) { |
905 |
|
TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n", |
906 |
|
objc, cmdNameBuf, |
907 |
|
StringForResultCode(result))); |
908 |
|
goto abnormalReturn; /* no catch exists to check */ |
909 |
|
} |
910 |
|
newPcOffset = 0; |
911 |
|
switch (rangePtr->type) { |
912 |
|
case LOOP_EXCEPTION_RANGE: |
913 |
|
if (result == TCL_BREAK) { |
914 |
|
newPcOffset = rangePtr->breakOffset; |
915 |
|
} else if (rangePtr->continueOffset == -1) { |
916 |
|
TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n", |
917 |
|
objc, cmdNameBuf, |
918 |
|
StringForResultCode(result))); |
919 |
|
goto checkForCatch; |
920 |
|
} else { |
921 |
|
newPcOffset = rangePtr->continueOffset; |
922 |
|
} |
923 |
|
TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n", |
924 |
|
objc, cmdNameBuf, |
925 |
|
StringForResultCode(result), |
926 |
|
rangePtr->codeOffset, newPcOffset)); |
927 |
|
break; |
928 |
|
case CATCH_EXCEPTION_RANGE: |
929 |
|
TRACE(("%u => ... after \"%.20s\", %s...\n", |
930 |
|
objc, cmdNameBuf, |
931 |
|
StringForResultCode(result))); |
932 |
|
goto processCatch; /* it will use rangePtr */ |
933 |
|
default: |
934 |
|
panic("TclExecuteByteCode: bad ExceptionRange type\n"); |
935 |
|
} |
936 |
|
result = TCL_OK; |
937 |
|
pc = (codePtr->codeStart + newPcOffset); |
938 |
|
continue; /* restart outer instruction loop at pc */ |
939 |
|
|
940 |
|
case TCL_ERROR: |
941 |
|
/* |
942 |
|
* The invoked command returned an error. Look for an |
943 |
|
* enclosing catch exception range, if any. |
944 |
|
*/ |
945 |
|
TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ", |
946 |
|
objc, cmdNameBuf), Tcl_GetObjResult(interp)); |
947 |
|
goto checkForCatch; |
948 |
|
|
949 |
|
case TCL_RETURN: |
950 |
|
/* |
951 |
|
* The invoked command requested that the current |
952 |
|
* procedure stop execution and return. First check |
953 |
|
* for an enclosing catch exception range, if any. |
954 |
|
*/ |
955 |
|
TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n", |
956 |
|
objc, cmdNameBuf)); |
957 |
|
goto checkForCatch; |
958 |
|
|
959 |
|
default: |
960 |
|
TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ", |
961 |
|
objc, cmdNameBuf, result), |
962 |
|
Tcl_GetObjResult(interp)); |
963 |
|
goto checkForCatch; |
964 |
|
} |
965 |
|
} |
966 |
|
|
967 |
|
case INST_EVAL_STK: |
968 |
|
objPtr = POP_OBJECT(); |
969 |
|
DECACHE_STACK_INFO(); |
970 |
|
result = Tcl_EvalObjEx(interp, objPtr, 0); |
971 |
|
CACHE_STACK_INFO(); |
972 |
|
if (result == TCL_OK) { |
973 |
|
/* |
974 |
|
* Normal return; push the eval's object result. |
975 |
|
*/ |
976 |
|
PUSH_OBJECT(Tcl_GetObjResult(interp)); |
977 |
|
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), |
978 |
|
Tcl_GetObjResult(interp)); |
979 |
|
TclDecrRefCount(objPtr); |
980 |
|
ADJUST_PC(1); |
981 |
|
} else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) { |
982 |
|
/* |
983 |
|
* Find the closest enclosing loop or catch exception range, |
984 |
|
* if any. If a loop is found, terminate its execution or |
985 |
|
* skip to its next iteration. If the closest is a catch |
986 |
|
* exception range, jump to its catchOffset. If no enclosing |
987 |
|
* range is found, stop execution and return that same |
988 |
|
* TCL_BREAK or TCL_CONTINUE. |
989 |
|
*/ |
990 |
|
|
991 |
|
int newPcOffset = 0; /* Pc offset computed during break, |
992 |
|
* continue, error processing. Init. |
993 |
|
* to avoid compiler warning. */ |
994 |
|
|
995 |
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, |
996 |
|
codePtr); |
997 |
|
if (rangePtr == NULL) { |
998 |
|
TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n", |
999 |
|
O2S(objPtr), StringForResultCode(result))); |
1000 |
|
Tcl_DecrRefCount(objPtr); |
1001 |
|
goto abnormalReturn; /* no catch exists to check */ |
1002 |
|
} |
1003 |
|
switch (rangePtr->type) { |
1004 |
|
case LOOP_EXCEPTION_RANGE: |
1005 |
|
if (result == TCL_BREAK) { |
1006 |
|
newPcOffset = rangePtr->breakOffset; |
1007 |
|
} else if (rangePtr->continueOffset == -1) { |
1008 |
|
TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n", |
1009 |
|
O2S(objPtr), StringForResultCode(result))); |
1010 |
|
Tcl_DecrRefCount(objPtr); |
1011 |
|
goto checkForCatch; |
1012 |
|
} else { |
1013 |
|
newPcOffset = rangePtr->continueOffset; |
1014 |
|
} |
1015 |
|
result = TCL_OK; |
1016 |
|
TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ", |
1017 |
|
O2S(objPtr), StringForResultCode(result), |
1018 |
|
rangePtr->codeOffset, newPcOffset), valuePtr); |
1019 |
|
break; |
1020 |
|
case CATCH_EXCEPTION_RANGE: |
1021 |
|
TRACE_WITH_OBJ(("\"%.30s\" => %s ", |
1022 |
|
O2S(objPtr), StringForResultCode(result)), |
1023 |
|
valuePtr); |
1024 |
|
Tcl_DecrRefCount(objPtr); |
1025 |
|
goto processCatch; /* it will use rangePtr */ |
1026 |
|
default: |
1027 |
|
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); |
1028 |
|
} |
1029 |
|
Tcl_DecrRefCount(objPtr); |
1030 |
|
pc = (codePtr->codeStart + newPcOffset); |
1031 |
|
continue; /* restart outer instruction loop at pc */ |
1032 |
|
} else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */ |
1033 |
|
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), |
1034 |
|
Tcl_GetObjResult(interp)); |
1035 |
|
Tcl_DecrRefCount(objPtr); |
1036 |
|
goto checkForCatch; |
1037 |
|
} |
1038 |
|
|
1039 |
|
case INST_EXPR_STK: |
1040 |
|
objPtr = POP_OBJECT(); |
1041 |
|
Tcl_ResetResult(interp); |
1042 |
|
DECACHE_STACK_INFO(); |
1043 |
|
result = Tcl_ExprObj(interp, objPtr, &valuePtr); |
1044 |
|
CACHE_STACK_INFO(); |
1045 |
|
if (result != TCL_OK) { |
1046 |
|
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", |
1047 |
|
O2S(objPtr)), Tcl_GetObjResult(interp)); |
1048 |
|
Tcl_DecrRefCount(objPtr); |
1049 |
|
goto checkForCatch; |
1050 |
|
} |
1051 |
|
stackPtr[++stackTop] = valuePtr; /* already has right refct */ |
1052 |
|
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); |
1053 |
|
TclDecrRefCount(objPtr); |
1054 |
|
ADJUST_PC(1); |
1055 |
|
|
1056 |
|
case INST_LOAD_SCALAR1: |
1057 |
|
#ifdef TCL_COMPILE_DEBUG |
1058 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1059 |
|
DECACHE_STACK_INFO(); |
1060 |
|
valuePtr = TclGetIndexedScalar(interp, opnd, |
1061 |
|
/*leaveErrorMsg*/ 1); |
1062 |
|
CACHE_STACK_INFO(); |
1063 |
|
if (valuePtr == NULL) { |
1064 |
|
TRACE_WITH_OBJ(("%u => ERROR: ", opnd), |
1065 |
|
Tcl_GetObjResult(interp)); |
1066 |
|
result = TCL_ERROR; |
1067 |
|
goto checkForCatch; |
1068 |
|
} |
1069 |
|
PUSH_OBJECT(valuePtr); |
1070 |
|
TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); |
1071 |
|
#else /* TCL_COMPILE_DEBUG */ |
1072 |
|
DECACHE_STACK_INFO(); |
1073 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1074 |
|
valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1); |
1075 |
|
CACHE_STACK_INFO(); |
1076 |
|
if (valuePtr == NULL) { |
1077 |
|
result = TCL_ERROR; |
1078 |
|
goto checkForCatch; |
1079 |
|
} |
1080 |
|
PUSH_OBJECT(valuePtr); |
1081 |
|
#endif /* TCL_COMPILE_DEBUG */ |
1082 |
|
ADJUST_PC(2); |
1083 |
|
|
1084 |
|
case INST_LOAD_SCALAR4: |
1085 |
|
opnd = TclGetUInt4AtPtr(pc+1); |
1086 |
|
DECACHE_STACK_INFO(); |
1087 |
|
valuePtr = TclGetIndexedScalar(interp, opnd, |
1088 |
|
/*leaveErrorMsg*/ 1); |
1089 |
|
CACHE_STACK_INFO(); |
1090 |
|
if (valuePtr == NULL) { |
1091 |
|
TRACE_WITH_OBJ(("%u => ERROR: ", opnd), |
1092 |
|
Tcl_GetObjResult(interp)); |
1093 |
|
result = TCL_ERROR; |
1094 |
|
goto checkForCatch; |
1095 |
|
} |
1096 |
|
PUSH_OBJECT(valuePtr); |
1097 |
|
TRACE_WITH_OBJ(("%u => ", opnd), valuePtr); |
1098 |
|
ADJUST_PC(5); |
1099 |
|
|
1100 |
|
case INST_LOAD_SCALAR_STK: |
1101 |
|
objPtr = POP_OBJECT(); /* scalar name */ |
1102 |
|
DECACHE_STACK_INFO(); |
1103 |
|
valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); |
1104 |
|
CACHE_STACK_INFO(); |
1105 |
|
if (valuePtr == NULL) { |
1106 |
|
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)), |
1107 |
|
Tcl_GetObjResult(interp)); |
1108 |
|
Tcl_DecrRefCount(objPtr); |
1109 |
|
result = TCL_ERROR; |
1110 |
|
goto checkForCatch; |
1111 |
|
} |
1112 |
|
PUSH_OBJECT(valuePtr); |
1113 |
|
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); |
1114 |
|
TclDecrRefCount(objPtr); |
1115 |
|
ADJUST_PC(1); |
1116 |
|
|
1117 |
|
case INST_LOAD_ARRAY4: |
1118 |
|
opnd = TclGetUInt4AtPtr(pc+1); |
1119 |
|
pcAdjustment = 5; |
1120 |
|
goto doLoadArray; |
1121 |
|
|
1122 |
|
case INST_LOAD_ARRAY1: |
1123 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1124 |
|
pcAdjustment = 2; |
1125 |
|
|
1126 |
|
doLoadArray: |
1127 |
|
{ |
1128 |
|
Tcl_Obj *elemPtr = POP_OBJECT(); |
1129 |
|
|
1130 |
|
DECACHE_STACK_INFO(); |
1131 |
|
valuePtr = TclGetElementOfIndexedArray(interp, opnd, |
1132 |
|
elemPtr, /*leaveErrorMsg*/ 1); |
1133 |
|
CACHE_STACK_INFO(); |
1134 |
|
if (valuePtr == NULL) { |
1135 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ", |
1136 |
|
opnd, O2S(elemPtr)), Tcl_GetObjResult(interp)); |
1137 |
|
Tcl_DecrRefCount(elemPtr); |
1138 |
|
result = TCL_ERROR; |
1139 |
|
goto checkForCatch; |
1140 |
|
} |
1141 |
|
PUSH_OBJECT(valuePtr); |
1142 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" => ", |
1143 |
|
opnd, O2S(elemPtr)),valuePtr); |
1144 |
|
TclDecrRefCount(elemPtr); |
1145 |
|
} |
1146 |
|
ADJUST_PC(pcAdjustment); |
1147 |
|
|
1148 |
|
case INST_LOAD_ARRAY_STK: |
1149 |
|
{ |
1150 |
|
Tcl_Obj *elemPtr = POP_OBJECT(); |
1151 |
|
|
1152 |
|
objPtr = POP_OBJECT(); /* array name */ |
1153 |
|
DECACHE_STACK_INFO(); |
1154 |
|
valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr, |
1155 |
|
TCL_LEAVE_ERR_MSG); |
1156 |
|
CACHE_STACK_INFO(); |
1157 |
|
if (valuePtr == NULL) { |
1158 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ", |
1159 |
|
O2S(objPtr), O2S(elemPtr)), |
1160 |
|
Tcl_GetObjResult(interp)); |
1161 |
|
Tcl_DecrRefCount(objPtr); |
1162 |
|
Tcl_DecrRefCount(elemPtr); |
1163 |
|
result = TCL_ERROR; |
1164 |
|
goto checkForCatch; |
1165 |
|
} |
1166 |
|
PUSH_OBJECT(valuePtr); |
1167 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ", |
1168 |
|
O2S(objPtr), O2S(elemPtr)), valuePtr); |
1169 |
|
TclDecrRefCount(objPtr); |
1170 |
|
TclDecrRefCount(elemPtr); |
1171 |
|
} |
1172 |
|
ADJUST_PC(1); |
1173 |
|
|
1174 |
|
case INST_LOAD_STK: |
1175 |
|
objPtr = POP_OBJECT(); /* variable name */ |
1176 |
|
DECACHE_STACK_INFO(); |
1177 |
|
valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG); |
1178 |
|
CACHE_STACK_INFO(); |
1179 |
|
if (valuePtr == NULL) { |
1180 |
|
TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", |
1181 |
|
O2S(objPtr)), Tcl_GetObjResult(interp)); |
1182 |
|
Tcl_DecrRefCount(objPtr); |
1183 |
|
result = TCL_ERROR; |
1184 |
|
goto checkForCatch; |
1185 |
|
} |
1186 |
|
PUSH_OBJECT(valuePtr); |
1187 |
|
TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); |
1188 |
|
TclDecrRefCount(objPtr); |
1189 |
|
ADJUST_PC(1); |
1190 |
|
|
1191 |
|
case INST_STORE_SCALAR4: |
1192 |
|
opnd = TclGetUInt4AtPtr(pc+1); |
1193 |
|
pcAdjustment = 5; |
1194 |
|
goto doStoreScalar; |
1195 |
|
|
1196 |
|
case INST_STORE_SCALAR1: |
1197 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1198 |
|
pcAdjustment = 2; |
1199 |
|
|
1200 |
|
doStoreScalar: |
1201 |
|
valuePtr = POP_OBJECT(); |
1202 |
|
DECACHE_STACK_INFO(); |
1203 |
|
value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr, |
1204 |
|
/*leaveErrorMsg*/ 1); |
1205 |
|
CACHE_STACK_INFO(); |
1206 |
|
if (value2Ptr == NULL) { |
1207 |
|
TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ", |
1208 |
|
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); |
1209 |
|
Tcl_DecrRefCount(valuePtr); |
1210 |
|
result = TCL_ERROR; |
1211 |
|
goto checkForCatch; |
1212 |
|
} |
1213 |
|
PUSH_OBJECT(value2Ptr); |
1214 |
|
TRACE_WITH_OBJ(("%u <- \"%.30s\" => ", |
1215 |
|
opnd, O2S(valuePtr)), value2Ptr); |
1216 |
|
TclDecrRefCount(valuePtr); |
1217 |
|
ADJUST_PC(pcAdjustment); |
1218 |
|
|
1219 |
|
case INST_STORE_SCALAR_STK: |
1220 |
|
valuePtr = POP_OBJECT(); |
1221 |
|
objPtr = POP_OBJECT(); /* scalar name */ |
1222 |
|
DECACHE_STACK_INFO(); |
1223 |
|
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, |
1224 |
|
TCL_LEAVE_ERR_MSG); |
1225 |
|
CACHE_STACK_INFO(); |
1226 |
|
if (value2Ptr == NULL) { |
1227 |
|
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", |
1228 |
|
O2S(objPtr), O2S(valuePtr)), |
1229 |
|
Tcl_GetObjResult(interp)); |
1230 |
|
Tcl_DecrRefCount(objPtr); |
1231 |
|
Tcl_DecrRefCount(valuePtr); |
1232 |
|
result = TCL_ERROR; |
1233 |
|
goto checkForCatch; |
1234 |
|
} |
1235 |
|
PUSH_OBJECT(value2Ptr); |
1236 |
|
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", |
1237 |
|
O2S(objPtr), O2S(valuePtr)), value2Ptr); |
1238 |
|
TclDecrRefCount(objPtr); |
1239 |
|
TclDecrRefCount(valuePtr); |
1240 |
|
ADJUST_PC(1); |
1241 |
|
|
1242 |
|
case INST_STORE_ARRAY4: |
1243 |
|
opnd = TclGetUInt4AtPtr(pc+1); |
1244 |
|
pcAdjustment = 5; |
1245 |
|
goto doStoreArray; |
1246 |
|
|
1247 |
|
case INST_STORE_ARRAY1: |
1248 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1249 |
|
pcAdjustment = 2; |
1250 |
|
|
1251 |
|
doStoreArray: |
1252 |
|
{ |
1253 |
|
Tcl_Obj *elemPtr; |
1254 |
|
|
1255 |
|
valuePtr = POP_OBJECT(); |
1256 |
|
elemPtr = POP_OBJECT(); |
1257 |
|
DECACHE_STACK_INFO(); |
1258 |
|
value2Ptr = TclSetElementOfIndexedArray(interp, opnd, |
1259 |
|
elemPtr, valuePtr, TCL_LEAVE_ERR_MSG); |
1260 |
|
CACHE_STACK_INFO(); |
1261 |
|
if (value2Ptr == NULL) { |
1262 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ", |
1263 |
|
opnd, O2S(elemPtr), O2S(valuePtr)), |
1264 |
|
Tcl_GetObjResult(interp)); |
1265 |
|
Tcl_DecrRefCount(elemPtr); |
1266 |
|
Tcl_DecrRefCount(valuePtr); |
1267 |
|
result = TCL_ERROR; |
1268 |
|
goto checkForCatch; |
1269 |
|
} |
1270 |
|
PUSH_OBJECT(value2Ptr); |
1271 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ", |
1272 |
|
opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr); |
1273 |
|
TclDecrRefCount(elemPtr); |
1274 |
|
TclDecrRefCount(valuePtr); |
1275 |
|
} |
1276 |
|
ADJUST_PC(pcAdjustment); |
1277 |
|
|
1278 |
|
case INST_STORE_ARRAY_STK: |
1279 |
|
{ |
1280 |
|
Tcl_Obj *elemPtr; |
1281 |
|
|
1282 |
|
valuePtr = POP_OBJECT(); |
1283 |
|
elemPtr = POP_OBJECT(); |
1284 |
|
objPtr = POP_OBJECT(); /* array name */ |
1285 |
|
DECACHE_STACK_INFO(); |
1286 |
|
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr, |
1287 |
|
TCL_LEAVE_ERR_MSG); |
1288 |
|
CACHE_STACK_INFO(); |
1289 |
|
if (value2Ptr == NULL) { |
1290 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ", |
1291 |
|
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), |
1292 |
|
Tcl_GetObjResult(interp)); |
1293 |
|
Tcl_DecrRefCount(objPtr); |
1294 |
|
Tcl_DecrRefCount(elemPtr); |
1295 |
|
Tcl_DecrRefCount(valuePtr); |
1296 |
|
result = TCL_ERROR; |
1297 |
|
goto checkForCatch; |
1298 |
|
} |
1299 |
|
PUSH_OBJECT(value2Ptr); |
1300 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ", |
1301 |
|
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), |
1302 |
|
value2Ptr); |
1303 |
|
TclDecrRefCount(objPtr); |
1304 |
|
TclDecrRefCount(elemPtr); |
1305 |
|
TclDecrRefCount(valuePtr); |
1306 |
|
} |
1307 |
|
ADJUST_PC(1); |
1308 |
|
|
1309 |
|
case INST_STORE_STK: |
1310 |
|
valuePtr = POP_OBJECT(); |
1311 |
|
objPtr = POP_OBJECT(); /* variable name */ |
1312 |
|
DECACHE_STACK_INFO(); |
1313 |
|
value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr, |
1314 |
|
TCL_LEAVE_ERR_MSG); |
1315 |
|
CACHE_STACK_INFO(); |
1316 |
|
if (value2Ptr == NULL) { |
1317 |
|
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ", |
1318 |
|
O2S(objPtr), O2S(valuePtr)), |
1319 |
|
Tcl_GetObjResult(interp)); |
1320 |
|
Tcl_DecrRefCount(objPtr); |
1321 |
|
Tcl_DecrRefCount(valuePtr); |
1322 |
|
result = TCL_ERROR; |
1323 |
|
goto checkForCatch; |
1324 |
|
} |
1325 |
|
PUSH_OBJECT(value2Ptr); |
1326 |
|
TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ", |
1327 |
|
O2S(objPtr), O2S(valuePtr)), value2Ptr); |
1328 |
|
TclDecrRefCount(objPtr); |
1329 |
|
TclDecrRefCount(valuePtr); |
1330 |
|
ADJUST_PC(1); |
1331 |
|
|
1332 |
|
case INST_INCR_SCALAR1: |
1333 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1334 |
|
valuePtr = POP_OBJECT(); |
1335 |
|
if (valuePtr->typePtr != &tclIntType) { |
1336 |
|
result = tclIntType.setFromAnyProc(interp, valuePtr); |
1337 |
|
if (result != TCL_OK) { |
1338 |
|
TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", |
1339 |
|
opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); |
1340 |
|
Tcl_DecrRefCount(valuePtr); |
1341 |
|
goto checkForCatch; |
1342 |
|
} |
1343 |
|
} |
1344 |
|
i = valuePtr->internalRep.longValue; |
1345 |
|
DECACHE_STACK_INFO(); |
1346 |
|
value2Ptr = TclIncrIndexedScalar(interp, opnd, i); |
1347 |
|
CACHE_STACK_INFO(); |
1348 |
|
if (value2Ptr == NULL) { |
1349 |
|
TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i), |
1350 |
|
Tcl_GetObjResult(interp)); |
1351 |
|
Tcl_DecrRefCount(valuePtr); |
1352 |
|
result = TCL_ERROR; |
1353 |
|
goto checkForCatch; |
1354 |
|
} |
1355 |
|
PUSH_OBJECT(value2Ptr); |
1356 |
|
TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr); |
1357 |
|
TclDecrRefCount(valuePtr); |
1358 |
|
ADJUST_PC(2); |
1359 |
|
|
1360 |
|
case INST_INCR_SCALAR_STK: |
1361 |
|
case INST_INCR_STK: |
1362 |
|
valuePtr = POP_OBJECT(); |
1363 |
|
objPtr = POP_OBJECT(); /* scalar name */ |
1364 |
|
if (valuePtr->typePtr != &tclIntType) { |
1365 |
|
result = tclIntType.setFromAnyProc(interp, valuePtr); |
1366 |
|
if (result != TCL_OK) { |
1367 |
|
TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ", |
1368 |
|
O2S(objPtr), O2S(valuePtr)), |
1369 |
|
Tcl_GetObjResult(interp)); |
1370 |
|
Tcl_DecrRefCount(objPtr); |
1371 |
|
Tcl_DecrRefCount(valuePtr); |
1372 |
|
goto checkForCatch; |
1373 |
|
} |
1374 |
|
} |
1375 |
|
i = valuePtr->internalRep.longValue; |
1376 |
|
DECACHE_STACK_INFO(); |
1377 |
|
value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, |
1378 |
|
TCL_LEAVE_ERR_MSG); |
1379 |
|
CACHE_STACK_INFO(); |
1380 |
|
if (value2Ptr == NULL) { |
1381 |
|
TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ", |
1382 |
|
O2S(objPtr), i), Tcl_GetObjResult(interp)); |
1383 |
|
Tcl_DecrRefCount(objPtr); |
1384 |
|
Tcl_DecrRefCount(valuePtr); |
1385 |
|
result = TCL_ERROR; |
1386 |
|
goto checkForCatch; |
1387 |
|
} |
1388 |
|
PUSH_OBJECT(value2Ptr); |
1389 |
|
TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i), |
1390 |
|
value2Ptr); |
1391 |
|
Tcl_DecrRefCount(objPtr); |
1392 |
|
Tcl_DecrRefCount(valuePtr); |
1393 |
|
ADJUST_PC(1); |
1394 |
|
|
1395 |
|
case INST_INCR_ARRAY1: |
1396 |
|
{ |
1397 |
|
Tcl_Obj *elemPtr; |
1398 |
|
|
1399 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1400 |
|
valuePtr = POP_OBJECT(); |
1401 |
|
elemPtr = POP_OBJECT(); |
1402 |
|
if (valuePtr->typePtr != &tclIntType) { |
1403 |
|
result = tclIntType.setFromAnyProc(interp, valuePtr); |
1404 |
|
if (result != TCL_OK) { |
1405 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ", |
1406 |
|
opnd, O2S(elemPtr), O2S(valuePtr)), |
1407 |
|
Tcl_GetObjResult(interp)); |
1408 |
|
Tcl_DecrRefCount(elemPtr); |
1409 |
|
Tcl_DecrRefCount(valuePtr); |
1410 |
|
goto checkForCatch; |
1411 |
|
} |
1412 |
|
} |
1413 |
|
i = valuePtr->internalRep.longValue; |
1414 |
|
DECACHE_STACK_INFO(); |
1415 |
|
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, |
1416 |
|
elemPtr, i); |
1417 |
|
CACHE_STACK_INFO(); |
1418 |
|
if (value2Ptr == NULL) { |
1419 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", |
1420 |
|
opnd, O2S(elemPtr), i), |
1421 |
|
Tcl_GetObjResult(interp)); |
1422 |
|
Tcl_DecrRefCount(elemPtr); |
1423 |
|
Tcl_DecrRefCount(valuePtr); |
1424 |
|
result = TCL_ERROR; |
1425 |
|
goto checkForCatch; |
1426 |
|
} |
1427 |
|
PUSH_OBJECT(value2Ptr); |
1428 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", |
1429 |
|
opnd, O2S(elemPtr), i), value2Ptr); |
1430 |
|
Tcl_DecrRefCount(elemPtr); |
1431 |
|
Tcl_DecrRefCount(valuePtr); |
1432 |
|
} |
1433 |
|
ADJUST_PC(2); |
1434 |
|
|
1435 |
|
case INST_INCR_ARRAY_STK: |
1436 |
|
{ |
1437 |
|
Tcl_Obj *elemPtr; |
1438 |
|
|
1439 |
|
valuePtr = POP_OBJECT(); |
1440 |
|
elemPtr = POP_OBJECT(); |
1441 |
|
objPtr = POP_OBJECT(); /* array name */ |
1442 |
|
if (valuePtr->typePtr != &tclIntType) { |
1443 |
|
result = tclIntType.setFromAnyProc(interp, valuePtr); |
1444 |
|
if (result != TCL_OK) { |
1445 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ", |
1446 |
|
O2S(objPtr), O2S(elemPtr), O2S(valuePtr)), |
1447 |
|
Tcl_GetObjResult(interp)); |
1448 |
|
Tcl_DecrRefCount(objPtr); |
1449 |
|
Tcl_DecrRefCount(elemPtr); |
1450 |
|
Tcl_DecrRefCount(valuePtr); |
1451 |
|
goto checkForCatch; |
1452 |
|
} |
1453 |
|
} |
1454 |
|
i = valuePtr->internalRep.longValue; |
1455 |
|
DECACHE_STACK_INFO(); |
1456 |
|
value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, |
1457 |
|
TCL_LEAVE_ERR_MSG); |
1458 |
|
CACHE_STACK_INFO(); |
1459 |
|
if (value2Ptr == NULL) { |
1460 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", |
1461 |
|
O2S(objPtr), O2S(elemPtr), i), |
1462 |
|
Tcl_GetObjResult(interp)); |
1463 |
|
Tcl_DecrRefCount(objPtr); |
1464 |
|
Tcl_DecrRefCount(elemPtr); |
1465 |
|
Tcl_DecrRefCount(valuePtr); |
1466 |
|
result = TCL_ERROR; |
1467 |
|
goto checkForCatch; |
1468 |
|
} |
1469 |
|
PUSH_OBJECT(value2Ptr); |
1470 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", |
1471 |
|
O2S(objPtr), O2S(elemPtr), i), value2Ptr); |
1472 |
|
Tcl_DecrRefCount(objPtr); |
1473 |
|
Tcl_DecrRefCount(elemPtr); |
1474 |
|
Tcl_DecrRefCount(valuePtr); |
1475 |
|
} |
1476 |
|
ADJUST_PC(1); |
1477 |
|
|
1478 |
|
case INST_INCR_SCALAR1_IMM: |
1479 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1480 |
|
i = TclGetInt1AtPtr(pc+2); |
1481 |
|
DECACHE_STACK_INFO(); |
1482 |
|
value2Ptr = TclIncrIndexedScalar(interp, opnd, i); |
1483 |
|
CACHE_STACK_INFO(); |
1484 |
|
if (value2Ptr == NULL) { |
1485 |
|
TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i), |
1486 |
|
Tcl_GetObjResult(interp)); |
1487 |
|
result = TCL_ERROR; |
1488 |
|
goto checkForCatch; |
1489 |
|
} |
1490 |
|
PUSH_OBJECT(value2Ptr); |
1491 |
|
TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr); |
1492 |
|
ADJUST_PC(3); |
1493 |
|
|
1494 |
|
case INST_INCR_SCALAR_STK_IMM: |
1495 |
|
case INST_INCR_STK_IMM: |
1496 |
|
objPtr = POP_OBJECT(); /* variable name */ |
1497 |
|
i = TclGetInt1AtPtr(pc+1); |
1498 |
|
DECACHE_STACK_INFO(); |
1499 |
|
value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i, |
1500 |
|
TCL_LEAVE_ERR_MSG); |
1501 |
|
CACHE_STACK_INFO(); |
1502 |
|
if (value2Ptr == NULL) { |
1503 |
|
TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ", |
1504 |
|
O2S(objPtr), i), Tcl_GetObjResult(interp)); |
1505 |
|
result = TCL_ERROR; |
1506 |
|
Tcl_DecrRefCount(objPtr); |
1507 |
|
goto checkForCatch; |
1508 |
|
} |
1509 |
|
PUSH_OBJECT(value2Ptr); |
1510 |
|
TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i), |
1511 |
|
value2Ptr); |
1512 |
|
TclDecrRefCount(objPtr); |
1513 |
|
ADJUST_PC(2); |
1514 |
|
|
1515 |
|
case INST_INCR_ARRAY1_IMM: |
1516 |
|
{ |
1517 |
|
Tcl_Obj *elemPtr; |
1518 |
|
|
1519 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
1520 |
|
i = TclGetInt1AtPtr(pc+2); |
1521 |
|
elemPtr = POP_OBJECT(); |
1522 |
|
DECACHE_STACK_INFO(); |
1523 |
|
value2Ptr = TclIncrElementOfIndexedArray(interp, opnd, |
1524 |
|
elemPtr, i); |
1525 |
|
CACHE_STACK_INFO(); |
1526 |
|
if (value2Ptr == NULL) { |
1527 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ", |
1528 |
|
opnd, O2S(elemPtr), i), |
1529 |
|
Tcl_GetObjResult(interp)); |
1530 |
|
Tcl_DecrRefCount(elemPtr); |
1531 |
|
result = TCL_ERROR; |
1532 |
|
goto checkForCatch; |
1533 |
|
} |
1534 |
|
PUSH_OBJECT(value2Ptr); |
1535 |
|
TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ", |
1536 |
|
opnd, O2S(elemPtr), i), value2Ptr); |
1537 |
|
Tcl_DecrRefCount(elemPtr); |
1538 |
|
} |
1539 |
|
ADJUST_PC(3); |
1540 |
|
|
1541 |
|
case INST_INCR_ARRAY_STK_IMM: |
1542 |
|
{ |
1543 |
|
Tcl_Obj *elemPtr; |
1544 |
|
|
1545 |
|
i = TclGetInt1AtPtr(pc+1); |
1546 |
|
elemPtr = POP_OBJECT(); |
1547 |
|
objPtr = POP_OBJECT(); /* array name */ |
1548 |
|
DECACHE_STACK_INFO(); |
1549 |
|
value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i, |
1550 |
|
TCL_LEAVE_ERR_MSG); |
1551 |
|
CACHE_STACK_INFO(); |
1552 |
|
if (value2Ptr == NULL) { |
1553 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ", |
1554 |
|
O2S(objPtr), O2S(elemPtr), i), |
1555 |
|
Tcl_GetObjResult(interp)); |
1556 |
|
Tcl_DecrRefCount(objPtr); |
1557 |
|
Tcl_DecrRefCount(elemPtr); |
1558 |
|
result = TCL_ERROR; |
1559 |
|
goto checkForCatch; |
1560 |
|
} |
1561 |
|
PUSH_OBJECT(value2Ptr); |
1562 |
|
TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ", |
1563 |
|
O2S(objPtr), O2S(elemPtr), i), value2Ptr); |
1564 |
|
Tcl_DecrRefCount(objPtr); |
1565 |
|
Tcl_DecrRefCount(elemPtr); |
1566 |
|
} |
1567 |
|
ADJUST_PC(2); |
1568 |
|
|
1569 |
|
case INST_JUMP1: |
1570 |
|
#ifdef TCL_COMPILE_DEBUG |
1571 |
|
opnd = TclGetInt1AtPtr(pc+1); |
1572 |
|
TRACE(("%d => new pc %u\n", opnd, |
1573 |
|
(unsigned int)(pc + opnd - codePtr->codeStart))); |
1574 |
|
pc += opnd; |
1575 |
|
#else |
1576 |
|
pc += TclGetInt1AtPtr(pc+1); |
1577 |
|
#endif /* TCL_COMPILE_DEBUG */ |
1578 |
|
continue; |
1579 |
|
|
1580 |
|
case INST_JUMP4: |
1581 |
|
opnd = TclGetInt4AtPtr(pc+1); |
1582 |
|
TRACE(("%d => new pc %u\n", opnd, |
1583 |
|
(unsigned int)(pc + opnd - codePtr->codeStart))); |
1584 |
|
ADJUST_PC(opnd); |
1585 |
|
|
1586 |
|
case INST_JUMP_TRUE4: |
1587 |
|
opnd = TclGetInt4AtPtr(pc+1); |
1588 |
|
pcAdjustment = 5; |
1589 |
|
goto doJumpTrue; |
1590 |
|
|
1591 |
|
case INST_JUMP_TRUE1: |
1592 |
|
opnd = TclGetInt1AtPtr(pc+1); |
1593 |
|
pcAdjustment = 2; |
1594 |
|
|
1595 |
|
doJumpTrue: |
1596 |
|
{ |
1597 |
|
int b; |
1598 |
|
|
1599 |
|
valuePtr = POP_OBJECT(); |
1600 |
|
if (valuePtr->typePtr == &tclIntType) { |
1601 |
|
b = (valuePtr->internalRep.longValue != 0); |
1602 |
|
} else if (valuePtr->typePtr == &tclDoubleType) { |
1603 |
|
b = (valuePtr->internalRep.doubleValue != 0.0); |
1604 |
|
} else { |
1605 |
|
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); |
1606 |
|
if (result != TCL_OK) { |
1607 |
|
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), |
1608 |
|
Tcl_GetObjResult(interp)); |
1609 |
|
Tcl_DecrRefCount(valuePtr); |
1610 |
|
goto checkForCatch; |
1611 |
|
} |
1612 |
|
} |
1613 |
|
if (b) { |
1614 |
|
TRACE(("%d => %.20s true, new pc %u\n", |
1615 |
|
opnd, O2S(valuePtr), |
1616 |
|
(unsigned int)(pc+opnd - codePtr->codeStart))); |
1617 |
|
TclDecrRefCount(valuePtr); |
1618 |
|
ADJUST_PC(opnd); |
1619 |
|
} else { |
1620 |
|
TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr))); |
1621 |
|
TclDecrRefCount(valuePtr); |
1622 |
|
ADJUST_PC(pcAdjustment); |
1623 |
|
} |
1624 |
|
} |
1625 |
|
|
1626 |
|
case INST_JUMP_FALSE4: |
1627 |
|
opnd = TclGetInt4AtPtr(pc+1); |
1628 |
|
pcAdjustment = 5; |
1629 |
|
goto doJumpFalse; |
1630 |
|
|
1631 |
|
case INST_JUMP_FALSE1: |
1632 |
|
opnd = TclGetInt1AtPtr(pc+1); |
1633 |
|
pcAdjustment = 2; |
1634 |
|
|
1635 |
|
doJumpFalse: |
1636 |
|
{ |
1637 |
|
int b; |
1638 |
|
|
1639 |
|
valuePtr = POP_OBJECT(); |
1640 |
|
if (valuePtr->typePtr == &tclIntType) { |
1641 |
|
b = (valuePtr->internalRep.longValue != 0); |
1642 |
|
} else if (valuePtr->typePtr == &tclDoubleType) { |
1643 |
|
b = (valuePtr->internalRep.doubleValue != 0.0); |
1644 |
|
} else { |
1645 |
|
result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); |
1646 |
|
if (result != TCL_OK) { |
1647 |
|
TRACE_WITH_OBJ(("%d => ERROR: ", opnd), |
1648 |
|
Tcl_GetObjResult(interp)); |
1649 |
|
Tcl_DecrRefCount(valuePtr); |
1650 |
|
goto checkForCatch; |
1651 |
|
} |
1652 |
|
} |
1653 |
|
if (b) { |
1654 |
|
TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr))); |
1655 |
|
TclDecrRefCount(valuePtr); |
1656 |
|
ADJUST_PC(pcAdjustment); |
1657 |
|
} else { |
1658 |
|
TRACE(("%d => %.20s false, new pc %u\n", |
1659 |
|
opnd, O2S(valuePtr), |
1660 |
|
(unsigned int)(pc + opnd - codePtr->codeStart))); |
1661 |
|
TclDecrRefCount(valuePtr); |
1662 |
|
ADJUST_PC(opnd); |
1663 |
|
} |
1664 |
|
} |
1665 |
|
|
1666 |
|
case INST_LOR: |
1667 |
|
case INST_LAND: |
1668 |
|
{ |
1669 |
|
/* |
1670 |
|
* Operands must be boolean or numeric. No int->double |
1671 |
|
* conversions are performed. |
1672 |
|
*/ |
1673 |
|
|
1674 |
|
int i1, i2; |
1675 |
|
int iResult; |
1676 |
|
char *s; |
1677 |
|
Tcl_ObjType *t1Ptr, *t2Ptr; |
1678 |
|
|
1679 |
|
value2Ptr = POP_OBJECT(); |
1680 |
|
valuePtr = POP_OBJECT(); |
1681 |
|
t1Ptr = valuePtr->typePtr; |
1682 |
|
t2Ptr = value2Ptr->typePtr; |
1683 |
|
|
1684 |
|
if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { |
1685 |
|
i1 = (valuePtr->internalRep.longValue != 0); |
1686 |
|
} else if (t1Ptr == &tclDoubleType) { |
1687 |
|
i1 = (valuePtr->internalRep.doubleValue != 0.0); |
1688 |
|
} else { |
1689 |
|
s = Tcl_GetStringFromObj(valuePtr, &length); |
1690 |
|
if (TclLooksLikeInt(s, length)) { |
1691 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
1692 |
|
valuePtr, &i); |
1693 |
|
i1 = (i != 0); |
1694 |
|
} else { |
1695 |
|
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, |
1696 |
|
valuePtr, &i1); |
1697 |
|
i1 = (i1 != 0); |
1698 |
|
} |
1699 |
|
if (result != TCL_OK) { |
1700 |
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", |
1701 |
|
O2S(valuePtr), |
1702 |
|
(t1Ptr? t1Ptr->name : "null"))); |
1703 |
|
IllegalExprOperandType(interp, pc, valuePtr); |
1704 |
|
Tcl_DecrRefCount(valuePtr); |
1705 |
|
Tcl_DecrRefCount(value2Ptr); |
1706 |
|
goto checkForCatch; |
1707 |
|
} |
1708 |
|
} |
1709 |
|
|
1710 |
|
if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { |
1711 |
|
i2 = (value2Ptr->internalRep.longValue != 0); |
1712 |
|
} else if (t2Ptr == &tclDoubleType) { |
1713 |
|
i2 = (value2Ptr->internalRep.doubleValue != 0.0); |
1714 |
|
} else { |
1715 |
|
s = Tcl_GetStringFromObj(value2Ptr, &length); |
1716 |
|
if (TclLooksLikeInt(s, length)) { |
1717 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
1718 |
|
value2Ptr, &i); |
1719 |
|
i2 = (i != 0); |
1720 |
|
} else { |
1721 |
|
result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, |
1722 |
|
value2Ptr, &i2); |
1723 |
|
} |
1724 |
|
if (result != TCL_OK) { |
1725 |
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", |
1726 |
|
O2S(value2Ptr), |
1727 |
|
(t2Ptr? t2Ptr->name : "null"))); |
1728 |
|
IllegalExprOperandType(interp, pc, value2Ptr); |
1729 |
|
Tcl_DecrRefCount(valuePtr); |
1730 |
|
Tcl_DecrRefCount(value2Ptr); |
1731 |
|
goto checkForCatch; |
1732 |
|
} |
1733 |
|
} |
1734 |
|
|
1735 |
|
/* |
1736 |
|
* Reuse the valuePtr object already on stack if possible. |
1737 |
|
*/ |
1738 |
|
|
1739 |
|
if (*pc == INST_LOR) { |
1740 |
|
iResult = (i1 || i2); |
1741 |
|
} else { |
1742 |
|
iResult = (i1 && i2); |
1743 |
|
} |
1744 |
|
if (Tcl_IsShared(valuePtr)) { |
1745 |
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
1746 |
|
TRACE(("%.20s %.20s => %d\n", |
1747 |
|
O2S(valuePtr), O2S(value2Ptr), iResult)); |
1748 |
|
TclDecrRefCount(valuePtr); |
1749 |
|
} else { /* reuse the valuePtr object */ |
1750 |
|
TRACE(("%.20s %.20s => %d\n", |
1751 |
|
O2S(valuePtr), O2S(value2Ptr), iResult)); |
1752 |
|
Tcl_SetLongObj(valuePtr, iResult); |
1753 |
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
1754 |
|
} |
1755 |
|
TclDecrRefCount(value2Ptr); |
1756 |
|
} |
1757 |
|
ADJUST_PC(1); |
1758 |
|
|
1759 |
|
case INST_EQ: |
1760 |
|
case INST_NEQ: |
1761 |
|
case INST_LT: |
1762 |
|
case INST_GT: |
1763 |
|
case INST_LE: |
1764 |
|
case INST_GE: |
1765 |
|
{ |
1766 |
|
/* |
1767 |
|
* Any type is allowed but the two operands must have the |
1768 |
|
* same type. We will compute value op value2. |
1769 |
|
*/ |
1770 |
|
|
1771 |
|
Tcl_ObjType *t1Ptr, *t2Ptr; |
1772 |
|
char *s1 = NULL; /* Init. avoids compiler warning. */ |
1773 |
|
char *s2 = NULL; /* Init. avoids compiler warning. */ |
1774 |
|
long i2 = 0; /* Init. avoids compiler warning. */ |
1775 |
|
double d1 = 0.0; /* Init. avoids compiler warning. */ |
1776 |
|
double d2 = 0.0; /* Init. avoids compiler warning. */ |
1777 |
|
long iResult = 0; /* Init. avoids compiler warning. */ |
1778 |
|
|
1779 |
|
value2Ptr = POP_OBJECT(); |
1780 |
|
valuePtr = POP_OBJECT(); |
1781 |
|
t1Ptr = valuePtr->typePtr; |
1782 |
|
t2Ptr = value2Ptr->typePtr; |
1783 |
|
|
1784 |
|
/* |
1785 |
|
* We only want to coerce numeric validation if |
1786 |
|
* neither type is NULL. A NULL type means the arg is |
1787 |
|
* essentially an empty object ("", {} or [list]). |
1788 |
|
*/ |
1789 |
|
if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL)) |
1790 |
|
|| (valuePtr->bytes && (valuePtr->length == 0))) |
1791 |
|
|| (((t2Ptr == NULL) && (value2Ptr->bytes == NULL)) |
1792 |
|
|| (value2Ptr->bytes && (value2Ptr->length == 0))))) { |
1793 |
|
if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) { |
1794 |
|
s1 = Tcl_GetStringFromObj(valuePtr, &length); |
1795 |
|
if (TclLooksLikeInt(s1, length)) { |
1796 |
|
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
1797 |
|
valuePtr, &i); |
1798 |
|
} else { |
1799 |
|
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
1800 |
|
valuePtr, &d1); |
1801 |
|
} |
1802 |
|
t1Ptr = valuePtr->typePtr; |
1803 |
|
} |
1804 |
|
if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) { |
1805 |
|
s2 = Tcl_GetStringFromObj(value2Ptr, &length); |
1806 |
|
if (TclLooksLikeInt(s2, length)) { |
1807 |
|
(void) Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
1808 |
|
value2Ptr, &i2); |
1809 |
|
} else { |
1810 |
|
(void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
1811 |
|
value2Ptr, &d2); |
1812 |
|
} |
1813 |
|
t2Ptr = value2Ptr->typePtr; |
1814 |
|
} |
1815 |
|
} |
1816 |
|
if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) |
1817 |
|
|| ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) { |
1818 |
|
/* |
1819 |
|
* One operand is not numeric. Compare as strings. |
1820 |
|
*/ |
1821 |
|
int cmpValue; |
1822 |
|
s1 = Tcl_GetString(valuePtr); |
1823 |
|
s2 = Tcl_GetString(value2Ptr); |
1824 |
|
cmpValue = strcmp(s1, s2); |
1825 |
|
switch (*pc) { |
1826 |
|
case INST_EQ: |
1827 |
|
iResult = (cmpValue == 0); |
1828 |
|
break; |
1829 |
|
case INST_NEQ: |
1830 |
|
iResult = (cmpValue != 0); |
1831 |
|
break; |
1832 |
|
case INST_LT: |
1833 |
|
iResult = (cmpValue < 0); |
1834 |
|
break; |
1835 |
|
case INST_GT: |
1836 |
|
iResult = (cmpValue > 0); |
1837 |
|
break; |
1838 |
|
case INST_LE: |
1839 |
|
iResult = (cmpValue <= 0); |
1840 |
|
break; |
1841 |
|
case INST_GE: |
1842 |
|
iResult = (cmpValue >= 0); |
1843 |
|
break; |
1844 |
|
} |
1845 |
|
} else if ((t1Ptr == &tclDoubleType) |
1846 |
|
|| (t2Ptr == &tclDoubleType)) { |
1847 |
|
/* |
1848 |
|
* Compare as doubles. |
1849 |
|
*/ |
1850 |
|
if (t1Ptr == &tclDoubleType) { |
1851 |
|
d1 = valuePtr->internalRep.doubleValue; |
1852 |
|
if (t2Ptr == &tclIntType) { |
1853 |
|
d2 = value2Ptr->internalRep.longValue; |
1854 |
|
} else { |
1855 |
|
d2 = value2Ptr->internalRep.doubleValue; |
1856 |
|
} |
1857 |
|
} else { /* t1Ptr is int, t2Ptr is double */ |
1858 |
|
d1 = valuePtr->internalRep.longValue; |
1859 |
|
d2 = value2Ptr->internalRep.doubleValue; |
1860 |
|
} |
1861 |
|
switch (*pc) { |
1862 |
|
case INST_EQ: |
1863 |
|
iResult = d1 == d2; |
1864 |
|
break; |
1865 |
|
case INST_NEQ: |
1866 |
|
iResult = d1 != d2; |
1867 |
|
break; |
1868 |
|
case INST_LT: |
1869 |
|
iResult = d1 < d2; |
1870 |
|
break; |
1871 |
|
case INST_GT: |
1872 |
|
iResult = d1 > d2; |
1873 |
|
break; |
1874 |
|
case INST_LE: |
1875 |
|
iResult = d1 <= d2; |
1876 |
|
break; |
1877 |
|
case INST_GE: |
1878 |
|
iResult = d1 >= d2; |
1879 |
|
break; |
1880 |
|
} |
1881 |
|
} else { |
1882 |
|
/* |
1883 |
|
* Compare as ints. |
1884 |
|
*/ |
1885 |
|
i = valuePtr->internalRep.longValue; |
1886 |
|
i2 = value2Ptr->internalRep.longValue; |
1887 |
|
switch (*pc) { |
1888 |
|
case INST_EQ: |
1889 |
|
iResult = i == i2; |
1890 |
|
break; |
1891 |
|
case INST_NEQ: |
1892 |
|
iResult = i != i2; |
1893 |
|
break; |
1894 |
|
case INST_LT: |
1895 |
|
iResult = i < i2; |
1896 |
|
break; |
1897 |
|
case INST_GT: |
1898 |
|
iResult = i > i2; |
1899 |
|
break; |
1900 |
|
case INST_LE: |
1901 |
|
iResult = i <= i2; |
1902 |
|
break; |
1903 |
|
case INST_GE: |
1904 |
|
iResult = i >= i2; |
1905 |
|
break; |
1906 |
|
} |
1907 |
|
} |
1908 |
|
|
1909 |
|
/* |
1910 |
|
* Reuse the valuePtr object already on stack if possible. |
1911 |
|
*/ |
1912 |
|
|
1913 |
|
if (Tcl_IsShared(valuePtr)) { |
1914 |
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
1915 |
|
TRACE(("%.20s %.20s => %ld\n", |
1916 |
|
O2S(valuePtr), O2S(value2Ptr), iResult)); |
1917 |
|
TclDecrRefCount(valuePtr); |
1918 |
|
} else { /* reuse the valuePtr object */ |
1919 |
|
TRACE(("%.20s %.20s => %ld\n", |
1920 |
|
O2S(valuePtr), O2S(value2Ptr), iResult)); |
1921 |
|
Tcl_SetLongObj(valuePtr, iResult); |
1922 |
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
1923 |
|
} |
1924 |
|
TclDecrRefCount(value2Ptr); |
1925 |
|
} |
1926 |
|
ADJUST_PC(1); |
1927 |
|
|
1928 |
|
case INST_MOD: |
1929 |
|
case INST_LSHIFT: |
1930 |
|
case INST_RSHIFT: |
1931 |
|
case INST_BITOR: |
1932 |
|
case INST_BITXOR: |
1933 |
|
case INST_BITAND: |
1934 |
|
{ |
1935 |
|
/* |
1936 |
|
* Only integers are allowed. We compute value op value2. |
1937 |
|
*/ |
1938 |
|
|
1939 |
|
long i2, rem, negative; |
1940 |
|
long iResult = 0; /* Init. avoids compiler warning. */ |
1941 |
|
|
1942 |
|
value2Ptr = POP_OBJECT(); |
1943 |
|
valuePtr = POP_OBJECT(); |
1944 |
|
if (valuePtr->typePtr == &tclIntType) { |
1945 |
|
i = valuePtr->internalRep.longValue; |
1946 |
|
} else { /* try to convert to int */ |
1947 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
1948 |
|
valuePtr, &i); |
1949 |
|
if (result != TCL_OK) { |
1950 |
|
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", |
1951 |
|
O2S(valuePtr), O2S(value2Ptr), |
1952 |
|
(valuePtr->typePtr? |
1953 |
|
valuePtr->typePtr->name : "null"))); |
1954 |
|
IllegalExprOperandType(interp, pc, valuePtr); |
1955 |
|
Tcl_DecrRefCount(valuePtr); |
1956 |
|
Tcl_DecrRefCount(value2Ptr); |
1957 |
|
goto checkForCatch; |
1958 |
|
} |
1959 |
|
} |
1960 |
|
if (value2Ptr->typePtr == &tclIntType) { |
1961 |
|
i2 = value2Ptr->internalRep.longValue; |
1962 |
|
} else { |
1963 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
1964 |
|
value2Ptr, &i2); |
1965 |
|
if (result != TCL_OK) { |
1966 |
|
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", |
1967 |
|
O2S(valuePtr), O2S(value2Ptr), |
1968 |
|
(value2Ptr->typePtr? |
1969 |
|
value2Ptr->typePtr->name : "null"))); |
1970 |
|
IllegalExprOperandType(interp, pc, value2Ptr); |
1971 |
|
Tcl_DecrRefCount(valuePtr); |
1972 |
|
Tcl_DecrRefCount(value2Ptr); |
1973 |
|
goto checkForCatch; |
1974 |
|
} |
1975 |
|
} |
1976 |
|
|
1977 |
|
switch (*pc) { |
1978 |
|
case INST_MOD: |
1979 |
|
/* |
1980 |
|
* This code is tricky: C doesn't guarantee much about |
1981 |
|
* the quotient or remainder, but Tcl does. The |
1982 |
|
* remainder always has the same sign as the divisor and |
1983 |
|
* a smaller absolute value. |
1984 |
|
*/ |
1985 |
|
if (i2 == 0) { |
1986 |
|
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); |
1987 |
|
Tcl_DecrRefCount(valuePtr); |
1988 |
|
Tcl_DecrRefCount(value2Ptr); |
1989 |
|
goto divideByZero; |
1990 |
|
} |
1991 |
|
negative = 0; |
1992 |
|
if (i2 < 0) { |
1993 |
|
i2 = -i2; |
1994 |
|
i = -i; |
1995 |
|
negative = 1; |
1996 |
|
} |
1997 |
|
rem = i % i2; |
1998 |
|
if (rem < 0) { |
1999 |
|
rem += i2; |
2000 |
|
} |
2001 |
|
if (negative) { |
2002 |
|
rem = -rem; |
2003 |
|
} |
2004 |
|
iResult = rem; |
2005 |
|
break; |
2006 |
|
case INST_LSHIFT: |
2007 |
|
iResult = i << i2; |
2008 |
|
break; |
2009 |
|
case INST_RSHIFT: |
2010 |
|
/* |
2011 |
|
* The following code is a bit tricky: it ensures that |
2012 |
|
* right shifts propagate the sign bit even on machines |
2013 |
|
* where ">>" won't do it by default. |
2014 |
|
*/ |
2015 |
|
if (i < 0) { |
2016 |
|
iResult = ~((~i) >> i2); |
2017 |
|
} else { |
2018 |
|
iResult = i >> i2; |
2019 |
|
} |
2020 |
|
break; |
2021 |
|
case INST_BITOR: |
2022 |
|
iResult = i | i2; |
2023 |
|
break; |
2024 |
|
case INST_BITXOR: |
2025 |
|
iResult = i ^ i2; |
2026 |
|
break; |
2027 |
|
case INST_BITAND: |
2028 |
|
iResult = i & i2; |
2029 |
|
break; |
2030 |
|
} |
2031 |
|
|
2032 |
|
/* |
2033 |
|
* Reuse the valuePtr object already on stack if possible. |
2034 |
|
*/ |
2035 |
|
|
2036 |
|
if (Tcl_IsShared(valuePtr)) { |
2037 |
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
2038 |
|
TRACE(("%ld %ld => %ld\n", i, i2, iResult)); |
2039 |
|
TclDecrRefCount(valuePtr); |
2040 |
|
} else { /* reuse the valuePtr object */ |
2041 |
|
TRACE(("%ld %ld => %ld\n", i, i2, iResult)); |
2042 |
|
Tcl_SetLongObj(valuePtr, iResult); |
2043 |
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
2044 |
|
} |
2045 |
|
TclDecrRefCount(value2Ptr); |
2046 |
|
} |
2047 |
|
ADJUST_PC(1); |
2048 |
|
|
2049 |
|
case INST_ADD: |
2050 |
|
case INST_SUB: |
2051 |
|
case INST_MULT: |
2052 |
|
case INST_DIV: |
2053 |
|
{ |
2054 |
|
/* |
2055 |
|
* Operands must be numeric and ints get converted to floats |
2056 |
|
* if necessary. We compute value op value2. |
2057 |
|
*/ |
2058 |
|
|
2059 |
|
Tcl_ObjType *t1Ptr, *t2Ptr; |
2060 |
|
long i2, quot, rem; |
2061 |
|
double d1, d2; |
2062 |
|
long iResult = 0; /* Init. avoids compiler warning. */ |
2063 |
|
double dResult = 0.0; /* Init. avoids compiler warning. */ |
2064 |
|
int doDouble = 0; /* 1 if doing floating arithmetic */ |
2065 |
|
|
2066 |
|
value2Ptr = POP_OBJECT(); |
2067 |
|
valuePtr = POP_OBJECT(); |
2068 |
|
t1Ptr = valuePtr->typePtr; |
2069 |
|
t2Ptr = value2Ptr->typePtr; |
2070 |
|
|
2071 |
|
if (t1Ptr == &tclIntType) { |
2072 |
|
i = valuePtr->internalRep.longValue; |
2073 |
|
} else if ((t1Ptr == &tclDoubleType) |
2074 |
|
&& (valuePtr->bytes == NULL)) { |
2075 |
|
/* |
2076 |
|
* We can only use the internal rep directly if there is |
2077 |
|
* no string rep. Otherwise the string rep might actually |
2078 |
|
* look like an integer, which is preferred. |
2079 |
|
*/ |
2080 |
|
|
2081 |
|
d1 = valuePtr->internalRep.doubleValue; |
2082 |
|
} else { |
2083 |
|
char *s = Tcl_GetStringFromObj(valuePtr, &length); |
2084 |
|
if (TclLooksLikeInt(s, length)) { |
2085 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
2086 |
|
valuePtr, &i); |
2087 |
|
} else { |
2088 |
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
2089 |
|
valuePtr, &d1); |
2090 |
|
} |
2091 |
|
if (result != TCL_OK) { |
2092 |
|
TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", |
2093 |
|
s, O2S(valuePtr), |
2094 |
|
(valuePtr->typePtr? |
2095 |
|
valuePtr->typePtr->name : "null"))); |
2096 |
|
IllegalExprOperandType(interp, pc, valuePtr); |
2097 |
|
Tcl_DecrRefCount(valuePtr); |
2098 |
|
Tcl_DecrRefCount(value2Ptr); |
2099 |
|
goto checkForCatch; |
2100 |
|
} |
2101 |
|
t1Ptr = valuePtr->typePtr; |
2102 |
|
} |
2103 |
|
|
2104 |
|
if (t2Ptr == &tclIntType) { |
2105 |
|
i2 = value2Ptr->internalRep.longValue; |
2106 |
|
} else if ((t2Ptr == &tclDoubleType) |
2107 |
|
&& (value2Ptr->bytes == NULL)) { |
2108 |
|
/* |
2109 |
|
* We can only use the internal rep directly if there is |
2110 |
|
* no string rep. Otherwise the string rep might actually |
2111 |
|
* look like an integer, which is preferred. |
2112 |
|
*/ |
2113 |
|
|
2114 |
|
d2 = value2Ptr->internalRep.doubleValue; |
2115 |
|
} else { |
2116 |
|
char *s = Tcl_GetStringFromObj(value2Ptr, &length); |
2117 |
|
if (TclLooksLikeInt(s, length)) { |
2118 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
2119 |
|
value2Ptr, &i2); |
2120 |
|
} else { |
2121 |
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
2122 |
|
value2Ptr, &d2); |
2123 |
|
} |
2124 |
|
if (result != TCL_OK) { |
2125 |
|
TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", |
2126 |
|
O2S(value2Ptr), s, |
2127 |
|
(value2Ptr->typePtr? |
2128 |
|
value2Ptr->typePtr->name : "null"))); |
2129 |
|
IllegalExprOperandType(interp, pc, value2Ptr); |
2130 |
|
Tcl_DecrRefCount(valuePtr); |
2131 |
|
Tcl_DecrRefCount(value2Ptr); |
2132 |
|
goto checkForCatch; |
2133 |
|
} |
2134 |
|
t2Ptr = value2Ptr->typePtr; |
2135 |
|
} |
2136 |
|
|
2137 |
|
if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { |
2138 |
|
/* |
2139 |
|
* Do double arithmetic. |
2140 |
|
*/ |
2141 |
|
doDouble = 1; |
2142 |
|
if (t1Ptr == &tclIntType) { |
2143 |
|
d1 = i; /* promote value 1 to double */ |
2144 |
|
} else if (t2Ptr == &tclIntType) { |
2145 |
|
d2 = i2; /* promote value 2 to double */ |
2146 |
|
} |
2147 |
|
switch (*pc) { |
2148 |
|
case INST_ADD: |
2149 |
|
dResult = d1 + d2; |
2150 |
|
break; |
2151 |
|
case INST_SUB: |
2152 |
|
dResult = d1 - d2; |
2153 |
|
break; |
2154 |
|
case INST_MULT: |
2155 |
|
dResult = d1 * d2; |
2156 |
|
break; |
2157 |
|
case INST_DIV: |
2158 |
|
if (d2 == 0.0) { |
2159 |
|
TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); |
2160 |
|
Tcl_DecrRefCount(valuePtr); |
2161 |
|
Tcl_DecrRefCount(value2Ptr); |
2162 |
|
goto divideByZero; |
2163 |
|
} |
2164 |
|
dResult = d1 / d2; |
2165 |
|
break; |
2166 |
|
} |
2167 |
|
|
2168 |
|
/* |
2169 |
|
* Check now for IEEE floating-point error. |
2170 |
|
*/ |
2171 |
|
|
2172 |
|
if (IS_NAN(dResult) || IS_INF(dResult)) { |
2173 |
|
TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", |
2174 |
|
O2S(valuePtr), O2S(value2Ptr))); |
2175 |
|
TclExprFloatError(interp, dResult); |
2176 |
|
result = TCL_ERROR; |
2177 |
|
Tcl_DecrRefCount(valuePtr); |
2178 |
|
Tcl_DecrRefCount(value2Ptr); |
2179 |
|
goto checkForCatch; |
2180 |
|
} |
2181 |
|
} else { |
2182 |
|
/* |
2183 |
|
* Do integer arithmetic. |
2184 |
|
*/ |
2185 |
|
switch (*pc) { |
2186 |
|
case INST_ADD: |
2187 |
|
iResult = i + i2; |
2188 |
|
break; |
2189 |
|
case INST_SUB: |
2190 |
|
iResult = i - i2; |
2191 |
|
break; |
2192 |
|
case INST_MULT: |
2193 |
|
iResult = i * i2; |
2194 |
|
break; |
2195 |
|
case INST_DIV: |
2196 |
|
/* |
2197 |
|
* This code is tricky: C doesn't guarantee much |
2198 |
|
* about the quotient or remainder, but Tcl does. |
2199 |
|
* The remainder always has the same sign as the |
2200 |
|
* divisor and a smaller absolute value. |
2201 |
|
*/ |
2202 |
|
if (i2 == 0) { |
2203 |
|
TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); |
2204 |
|
Tcl_DecrRefCount(valuePtr); |
2205 |
|
Tcl_DecrRefCount(value2Ptr); |
2206 |
|
goto divideByZero; |
2207 |
|
} |
2208 |
|
if (i2 < 0) { |
2209 |
|
i2 = -i2; |
2210 |
|
i = -i; |
2211 |
|
} |
2212 |
|
quot = i / i2; |
2213 |
|
rem = i % i2; |
2214 |
|
if (rem < 0) { |
2215 |
|
quot -= 1; |
2216 |
|
} |
2217 |
|
iResult = quot; |
2218 |
|
break; |
2219 |
|
} |
2220 |
|
} |
2221 |
|
|
2222 |
|
/* |
2223 |
|
* Reuse the valuePtr object already on stack if possible. |
2224 |
|
*/ |
2225 |
|
|
2226 |
|
if (Tcl_IsShared(valuePtr)) { |
2227 |
|
if (doDouble) { |
2228 |
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
2229 |
|
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); |
2230 |
|
} else { |
2231 |
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
2232 |
|
TRACE(("%ld %ld => %ld\n", i, i2, iResult)); |
2233 |
|
} |
2234 |
|
TclDecrRefCount(valuePtr); |
2235 |
|
} else { /* reuse the valuePtr object */ |
2236 |
|
if (doDouble) { /* NB: stack top is off by 1 */ |
2237 |
|
TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); |
2238 |
|
Tcl_SetDoubleObj(valuePtr, dResult); |
2239 |
|
} else { |
2240 |
|
TRACE(("%ld %ld => %ld\n", i, i2, iResult)); |
2241 |
|
Tcl_SetLongObj(valuePtr, iResult); |
2242 |
|
} |
2243 |
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
2244 |
|
} |
2245 |
|
TclDecrRefCount(value2Ptr); |
2246 |
|
} |
2247 |
|
ADJUST_PC(1); |
2248 |
|
|
2249 |
|
case INST_UPLUS: |
2250 |
|
{ |
2251 |
|
/* |
2252 |
|
* Operand must be numeric. |
2253 |
|
*/ |
2254 |
|
|
2255 |
|
double d; |
2256 |
|
Tcl_ObjType *tPtr; |
2257 |
|
|
2258 |
|
valuePtr = stackPtr[stackTop]; |
2259 |
|
tPtr = valuePtr->typePtr; |
2260 |
|
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) |
2261 |
|
|| (valuePtr->bytes != NULL))) { |
2262 |
|
char *s = Tcl_GetStringFromObj(valuePtr, &length); |
2263 |
|
if (TclLooksLikeInt(s, length)) { |
2264 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
2265 |
|
valuePtr, &i); |
2266 |
|
} else { |
2267 |
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
2268 |
|
valuePtr, &d); |
2269 |
|
} |
2270 |
|
if (result != TCL_OK) { |
2271 |
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", |
2272 |
|
s, (tPtr? tPtr->name : "null"))); |
2273 |
|
IllegalExprOperandType(interp, pc, valuePtr); |
2274 |
|
goto checkForCatch; |
2275 |
|
} |
2276 |
|
tPtr = valuePtr->typePtr; |
2277 |
|
} |
2278 |
|
|
2279 |
|
/* |
2280 |
|
* Ensure that the operand's string rep is the same as the |
2281 |
|
* formatted version of its internal rep. This makes sure |
2282 |
|
* that "expr +000123" yields "83", not "000123". We |
2283 |
|
* implement this by _discarding_ the string rep since we |
2284 |
|
* know it will be regenerated, if needed later, by |
2285 |
|
* formatting the internal rep's value. |
2286 |
|
*/ |
2287 |
|
|
2288 |
|
if (Tcl_IsShared(valuePtr)) { |
2289 |
|
if (tPtr == &tclIntType) { |
2290 |
|
i = valuePtr->internalRep.longValue; |
2291 |
|
objPtr = Tcl_NewLongObj(i); |
2292 |
|
} else { |
2293 |
|
d = valuePtr->internalRep.doubleValue; |
2294 |
|
objPtr = Tcl_NewDoubleObj(d); |
2295 |
|
} |
2296 |
|
Tcl_IncrRefCount(objPtr); |
2297 |
|
Tcl_DecrRefCount(valuePtr); |
2298 |
|
valuePtr = objPtr; |
2299 |
|
stackPtr[stackTop] = valuePtr; |
2300 |
|
} else { |
2301 |
|
Tcl_InvalidateStringRep(valuePtr); |
2302 |
|
} |
2303 |
|
TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); |
2304 |
|
} |
2305 |
|
ADJUST_PC(1); |
2306 |
|
|
2307 |
|
case INST_UMINUS: |
2308 |
|
case INST_LNOT: |
2309 |
|
{ |
2310 |
|
/* |
2311 |
|
* The operand must be numeric. If the operand object is |
2312 |
|
* unshared modify it directly, otherwise create a copy to |
2313 |
|
* modify: this is "copy on write". free any old string |
2314 |
|
* representation since it is now invalid. |
2315 |
|
*/ |
2316 |
|
|
2317 |
|
double d; |
2318 |
|
Tcl_ObjType *tPtr; |
2319 |
|
|
2320 |
|
valuePtr = POP_OBJECT(); |
2321 |
|
tPtr = valuePtr->typePtr; |
2322 |
|
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) |
2323 |
|
|| (valuePtr->bytes != NULL))) { |
2324 |
|
if ((tPtr == &tclBooleanType) |
2325 |
|
&& (valuePtr->bytes == NULL)) { |
2326 |
|
valuePtr->typePtr = &tclIntType; |
2327 |
|
} else { |
2328 |
|
char *s = Tcl_GetStringFromObj(valuePtr, &length); |
2329 |
|
if (TclLooksLikeInt(s, length)) { |
2330 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
2331 |
|
valuePtr, &i); |
2332 |
|
} else { |
2333 |
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
2334 |
|
valuePtr, &d); |
2335 |
|
} |
2336 |
|
if (result != TCL_OK) { |
2337 |
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", |
2338 |
|
s, (tPtr? tPtr->name : "null"))); |
2339 |
|
IllegalExprOperandType(interp, pc, valuePtr); |
2340 |
|
Tcl_DecrRefCount(valuePtr); |
2341 |
|
goto checkForCatch; |
2342 |
|
} |
2343 |
|
} |
2344 |
|
tPtr = valuePtr->typePtr; |
2345 |
|
} |
2346 |
|
|
2347 |
|
if (Tcl_IsShared(valuePtr)) { |
2348 |
|
/* |
2349 |
|
* Create a new object. |
2350 |
|
*/ |
2351 |
|
if (tPtr == &tclIntType) { |
2352 |
|
i = valuePtr->internalRep.longValue; |
2353 |
|
objPtr = Tcl_NewLongObj( |
2354 |
|
(*pc == INST_UMINUS)? -i : !i); |
2355 |
|
TRACE_WITH_OBJ(("%ld => ", i), objPtr); |
2356 |
|
} else { |
2357 |
|
d = valuePtr->internalRep.doubleValue; |
2358 |
|
if (*pc == INST_UMINUS) { |
2359 |
|
objPtr = Tcl_NewDoubleObj(-d); |
2360 |
|
} else { |
2361 |
|
/* |
2362 |
|
* Should be able to use "!d", but apparently |
2363 |
|
* some compilers can't handle it. |
2364 |
|
*/ |
2365 |
|
objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); |
2366 |
|
} |
2367 |
|
TRACE_WITH_OBJ(("%.6g => ", d), objPtr); |
2368 |
|
} |
2369 |
|
PUSH_OBJECT(objPtr); |
2370 |
|
TclDecrRefCount(valuePtr); |
2371 |
|
} else { |
2372 |
|
/* |
2373 |
|
* valuePtr is unshared. Modify it directly. |
2374 |
|
*/ |
2375 |
|
if (tPtr == &tclIntType) { |
2376 |
|
i = valuePtr->internalRep.longValue; |
2377 |
|
Tcl_SetLongObj(valuePtr, |
2378 |
|
(*pc == INST_UMINUS)? -i : !i); |
2379 |
|
TRACE_WITH_OBJ(("%ld => ", i), valuePtr); |
2380 |
|
} else { |
2381 |
|
d = valuePtr->internalRep.doubleValue; |
2382 |
|
if (*pc == INST_UMINUS) { |
2383 |
|
Tcl_SetDoubleObj(valuePtr, -d); |
2384 |
|
} else { |
2385 |
|
/* |
2386 |
|
* Should be able to use "!d", but apparently |
2387 |
|
* some compilers can't handle it. |
2388 |
|
*/ |
2389 |
|
Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); |
2390 |
|
} |
2391 |
|
TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); |
2392 |
|
} |
2393 |
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
2394 |
|
} |
2395 |
|
} |
2396 |
|
ADJUST_PC(1); |
2397 |
|
|
2398 |
|
case INST_BITNOT: |
2399 |
|
{ |
2400 |
|
/* |
2401 |
|
* The operand must be an integer. If the operand object is |
2402 |
|
* unshared modify it directly, otherwise modify a copy. |
2403 |
|
* Free any old string representation since it is now |
2404 |
|
* invalid. |
2405 |
|
*/ |
2406 |
|
|
2407 |
|
Tcl_ObjType *tPtr; |
2408 |
|
|
2409 |
|
valuePtr = POP_OBJECT(); |
2410 |
|
tPtr = valuePtr->typePtr; |
2411 |
|
if (tPtr != &tclIntType) { |
2412 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
2413 |
|
valuePtr, &i); |
2414 |
|
if (result != TCL_OK) { /* try to convert to double */ |
2415 |
|
TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", |
2416 |
|
O2S(valuePtr), (tPtr? tPtr->name : "null"))); |
2417 |
|
IllegalExprOperandType(interp, pc, valuePtr); |
2418 |
|
Tcl_DecrRefCount(valuePtr); |
2419 |
|
goto checkForCatch; |
2420 |
|
} |
2421 |
|
} |
2422 |
|
|
2423 |
|
i = valuePtr->internalRep.longValue; |
2424 |
|
if (Tcl_IsShared(valuePtr)) { |
2425 |
|
PUSH_OBJECT(Tcl_NewLongObj(~i)); |
2426 |
|
TRACE(("0x%lx => (%lu)\n", i, ~i)); |
2427 |
|
TclDecrRefCount(valuePtr); |
2428 |
|
} else { |
2429 |
|
/* |
2430 |
|
* valuePtr is unshared. Modify it directly. |
2431 |
|
*/ |
2432 |
|
Tcl_SetLongObj(valuePtr, ~i); |
2433 |
|
++stackTop; /* valuePtr now on stk top has right r.c. */ |
2434 |
|
TRACE(("0x%lx => (%lu)\n", i, ~i)); |
2435 |
|
} |
2436 |
|
} |
2437 |
|
ADJUST_PC(1); |
2438 |
|
|
2439 |
|
case INST_CALL_BUILTIN_FUNC1: |
2440 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
2441 |
|
{ |
2442 |
|
/* |
2443 |
|
* Call one of the built-in Tcl math functions. |
2444 |
|
*/ |
2445 |
|
|
2446 |
|
BuiltinFunc *mathFuncPtr; |
2447 |
|
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
2448 |
|
|
2449 |
|
if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { |
2450 |
|
TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); |
2451 |
|
panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); |
2452 |
|
} |
2453 |
|
mathFuncPtr = &(builtinFuncTable[opnd]); |
2454 |
|
DECACHE_STACK_INFO(); |
2455 |
|
tsdPtr->mathInProgress++; |
2456 |
|
result = (*mathFuncPtr->proc)(interp, eePtr, |
2457 |
|
mathFuncPtr->clientData); |
2458 |
|
tsdPtr->mathInProgress--; |
2459 |
|
CACHE_STACK_INFO(); |
2460 |
|
if (result != TCL_OK) { |
2461 |
|
goto checkForCatch; |
2462 |
|
} |
2463 |
|
TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]); |
2464 |
|
} |
2465 |
|
ADJUST_PC(2); |
2466 |
|
|
2467 |
|
case INST_CALL_FUNC1: |
2468 |
|
opnd = TclGetUInt1AtPtr(pc+1); |
2469 |
|
{ |
2470 |
|
/* |
2471 |
|
* Call a non-builtin Tcl math function previously |
2472 |
|
* registered by a call to Tcl_CreateMathFunc. |
2473 |
|
*/ |
2474 |
|
|
2475 |
|
int objc = opnd; /* Number of arguments. The function name |
2476 |
|
* is the 0-th argument. */ |
2477 |
|
Tcl_Obj **objv; /* The array of arguments. The function |
2478 |
|
* name is objv[0]. */ |
2479 |
|
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
2480 |
|
|
2481 |
|
objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */ |
2482 |
|
DECACHE_STACK_INFO(); |
2483 |
|
tsdPtr->mathInProgress++; |
2484 |
|
result = ExprCallMathFunc(interp, eePtr, objc, objv); |
2485 |
|
tsdPtr->mathInProgress--; |
2486 |
|
CACHE_STACK_INFO(); |
2487 |
|
if (result != TCL_OK) { |
2488 |
|
goto checkForCatch; |
2489 |
|
} |
2490 |
|
TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]); |
2491 |
|
ADJUST_PC(2); |
2492 |
|
} |
2493 |
|
|
2494 |
|
case INST_TRY_CVT_TO_NUMERIC: |
2495 |
|
{ |
2496 |
|
/* |
2497 |
|
* Try to convert the topmost stack object to an int or |
2498 |
|
* double object. This is done in order to support Tcl's |
2499 |
|
* policy of interpreting operands if at all possible as |
2500 |
|
* first integers, else floating-point numbers. |
2501 |
|
*/ |
2502 |
|
|
2503 |
|
double d; |
2504 |
|
char *s; |
2505 |
|
Tcl_ObjType *tPtr; |
2506 |
|
int converted, shared; |
2507 |
|
|
2508 |
|
valuePtr = stackPtr[stackTop]; |
2509 |
|
tPtr = valuePtr->typePtr; |
2510 |
|
converted = 0; |
2511 |
|
if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType) |
2512 |
|
|| (valuePtr->bytes != NULL))) { |
2513 |
|
if ((tPtr == &tclBooleanType) |
2514 |
|
&& (valuePtr->bytes == NULL)) { |
2515 |
|
valuePtr->typePtr = &tclIntType; |
2516 |
|
converted = 1; |
2517 |
|
} else { |
2518 |
|
s = Tcl_GetStringFromObj(valuePtr, &length); |
2519 |
|
if (TclLooksLikeInt(s, length)) { |
2520 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, |
2521 |
|
valuePtr, &i); |
2522 |
|
} else { |
2523 |
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, |
2524 |
|
valuePtr, &d); |
2525 |
|
} |
2526 |
|
if (result == TCL_OK) { |
2527 |
|
converted = 1; |
2528 |
|
} |
2529 |
|
result = TCL_OK; /* reset the result variable */ |
2530 |
|
} |
2531 |
|
tPtr = valuePtr->typePtr; |
2532 |
|
} |
2533 |
|
|
2534 |
|
/* |
2535 |
|
* Ensure that the topmost stack object, if numeric, has a |
2536 |
|
* string rep the same as the formatted version of its |
2537 |
|
* internal rep. This is used, e.g., to make sure that "expr |
2538 |
|
* {0001}" yields "1", not "0001". We implement this by |
2539 |
|
* _discarding_ the string rep since we know it will be |
2540 |
|
* regenerated, if needed later, by formatting the internal |
2541 |
|
* rep's value. Also check if there has been an IEEE |
2542 |
|
* floating point error. |
2543 |
|
*/ |
2544 |
|
|
2545 |
|
if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) { |
2546 |
|
shared = 0; |
2547 |
|
if (Tcl_IsShared(valuePtr)) { |
2548 |
|
shared = 1; |
2549 |
|
if (valuePtr->bytes != NULL) { |
2550 |
|
/* |
2551 |
|
* We only need to make a copy of the object |
2552 |
|
* when it already had a string rep |
2553 |
|
*/ |
2554 |
|
if (tPtr == &tclIntType) { |
2555 |
|
i = valuePtr->internalRep.longValue; |
2556 |
|
objPtr = Tcl_NewLongObj(i); |
2557 |
|
} else { |
2558 |
|
d = valuePtr->internalRep.doubleValue; |
2559 |
|
objPtr = Tcl_NewDoubleObj(d); |
2560 |
|
} |
2561 |
|
Tcl_IncrRefCount(objPtr); |
2562 |
|
TclDecrRefCount(valuePtr); |
2563 |
|
valuePtr = objPtr; |
2564 |
|
stackPtr[stackTop] = valuePtr; |
2565 |
|
tPtr = valuePtr->typePtr; |
2566 |
|
} |
2567 |
|
} else { |
2568 |
|
Tcl_InvalidateStringRep(valuePtr); |
2569 |
|
} |
2570 |
|
|
2571 |
|
if (tPtr == &tclDoubleType) { |
2572 |
|
d = valuePtr->internalRep.doubleValue; |
2573 |
|
if (IS_NAN(d) || IS_INF(d)) { |
2574 |
|
TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", |
2575 |
|
O2S(valuePtr))); |
2576 |
|
TclExprFloatError(interp, d); |
2577 |
|
result = TCL_ERROR; |
2578 |
|
goto checkForCatch; |
2579 |
|
} |
2580 |
|
} |
2581 |
|
shared = shared; /* lint, shared not used. */ |
2582 |
|
converted = converted; /* lint, converted not used. */ |
2583 |
|
TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), |
2584 |
|
(converted? "converted" : "not converted"), |
2585 |
|
(shared? "shared" : "not shared"))); |
2586 |
|
} else { |
2587 |
|
TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); |
2588 |
|
} |
2589 |
|
} |
2590 |
|
ADJUST_PC(1); |
2591 |
|
|
2592 |
|
case INST_BREAK: |
2593 |
|
/* |
2594 |
|
* First reset the interpreter's result. Then find the closest |
2595 |
|
* enclosing loop or catch exception range, if any. If a loop is |
2596 |
|
* found, terminate its execution. If the closest is a catch |
2597 |
|
* exception range, jump to its catchOffset. If no enclosing |
2598 |
|
* range is found, stop execution and return TCL_BREAK. |
2599 |
|
*/ |
2600 |
|
|
2601 |
|
Tcl_ResetResult(interp); |
2602 |
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); |
2603 |
|
if (rangePtr == NULL) { |
2604 |
|
TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n")); |
2605 |
|
result = TCL_BREAK; |
2606 |
|
goto abnormalReturn; /* no catch exists to check */ |
2607 |
|
} |
2608 |
|
switch (rangePtr->type) { |
2609 |
|
case LOOP_EXCEPTION_RANGE: |
2610 |
|
result = TCL_OK; |
2611 |
|
TRACE(("=> range at %d, new pc %d\n", |
2612 |
|
rangePtr->codeOffset, rangePtr->breakOffset)); |
2613 |
|
break; |
2614 |
|
case CATCH_EXCEPTION_RANGE: |
2615 |
|
result = TCL_BREAK; |
2616 |
|
TRACE(("=> ...\n")); |
2617 |
|
goto processCatch; /* it will use rangePtr */ |
2618 |
|
default: |
2619 |
|
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); |
2620 |
|
} |
2621 |
|
pc = (codePtr->codeStart + rangePtr->breakOffset); |
2622 |
|
continue; /* restart outer instruction loop at pc */ |
2623 |
|
|
2624 |
|
case INST_CONTINUE: |
2625 |
|
/* |
2626 |
|
* Find the closest enclosing loop or catch exception range, |
2627 |
|
* if any. If a loop is found, skip to its next iteration. |
2628 |
|
* If the closest is a catch exception range, jump to its |
2629 |
|
* catchOffset. If no enclosing range is found, stop |
2630 |
|
* execution and return TCL_CONTINUE. |
2631 |
|
*/ |
2632 |
|
|
2633 |
|
Tcl_ResetResult(interp); |
2634 |
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); |
2635 |
|
if (rangePtr == NULL) { |
2636 |
|
TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n")); |
2637 |
|
result = TCL_CONTINUE; |
2638 |
|
goto abnormalReturn; |
2639 |
|
} |
2640 |
|
switch (rangePtr->type) { |
2641 |
|
case LOOP_EXCEPTION_RANGE: |
2642 |
|
if (rangePtr->continueOffset == -1) { |
2643 |
|
TRACE(("=> loop w/o continue, checking for catch\n")); |
2644 |
|
goto checkForCatch; |
2645 |
|
} else { |
2646 |
|
result = TCL_OK; |
2647 |
|
TRACE(("=> range at %d, new pc %d\n", |
2648 |
|
rangePtr->codeOffset, rangePtr->continueOffset)); |
2649 |
|
} |
2650 |
|
break; |
2651 |
|
case CATCH_EXCEPTION_RANGE: |
2652 |
|
result = TCL_CONTINUE; |
2653 |
|
TRACE(("=> ...\n")); |
2654 |
|
goto processCatch; /* it will use rangePtr */ |
2655 |
|
default: |
2656 |
|
panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type); |
2657 |
|
} |
2658 |
|
pc = (codePtr->codeStart + rangePtr->continueOffset); |
2659 |
|
continue; /* restart outer instruction loop at pc */ |
2660 |
|
|
2661 |
|
case INST_FOREACH_START4: |
2662 |
|
opnd = TclGetUInt4AtPtr(pc+1); |
2663 |
|
{ |
2664 |
|
/* |
2665 |
|
* Initialize the temporary local var that holds the count |
2666 |
|
* of the number of iterations of the loop body to -1. |
2667 |
|
*/ |
2668 |
|
|
2669 |
|
ForeachInfo *infoPtr = (ForeachInfo *) |
2670 |
|
codePtr->auxDataArrayPtr[opnd].clientData; |
2671 |
|
int iterTmpIndex = infoPtr->loopCtTemp; |
2672 |
|
Var *compiledLocals = iPtr->varFramePtr->compiledLocals; |
2673 |
|
Var *iterVarPtr = &(compiledLocals[iterTmpIndex]); |
2674 |
|
Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr; |
2675 |
|
|
2676 |
|
if (oldValuePtr == NULL) { |
2677 |
|
iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); |
2678 |
|
Tcl_IncrRefCount(iterVarPtr->value.objPtr); |
2679 |
|
} else { |
2680 |
|
Tcl_SetLongObj(oldValuePtr, -1); |
2681 |
|
} |
2682 |
|
TclSetVarScalar(iterVarPtr); |
2683 |
|
TclClearVarUndefined(iterVarPtr); |
2684 |
|
TRACE(("%u => loop iter count temp %d\n", |
2685 |
|
opnd, iterTmpIndex)); |
2686 |
|
} |
2687 |
|
ADJUST_PC(5); |
2688 |
|
|
2689 |
|
case INST_FOREACH_STEP4: |
2690 |
|
opnd = TclGetUInt4AtPtr(pc+1); |
2691 |
|
{ |
2692 |
|
/* |
2693 |
|
* "Step" a foreach loop (i.e., begin its next iteration) by |
2694 |
|
* assigning the next value list element to each loop var. |
2695 |
|
*/ |
2696 |
|
|
2697 |
|
ForeachInfo *infoPtr = (ForeachInfo *) |
2698 |
|
codePtr->auxDataArrayPtr[opnd].clientData; |
2699 |
|
ForeachVarList *varListPtr; |
2700 |
|
int numLists = infoPtr->numLists; |
2701 |
|
Var *compiledLocals = iPtr->varFramePtr->compiledLocals; |
2702 |
|
Tcl_Obj *listPtr; |
2703 |
|
List *listRepPtr; |
2704 |
|
Var *iterVarPtr, *listVarPtr; |
2705 |
|
int iterNum, listTmpIndex, listLen, numVars; |
2706 |
|
int varIndex, valIndex, continueLoop, j; |
2707 |
|
|
2708 |
|
/* |
2709 |
|
* Increment the temp holding the loop iteration number. |
2710 |
|
*/ |
2711 |
|
|
2712 |
|
iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); |
2713 |
|
valuePtr = iterVarPtr->value.objPtr; |
2714 |
|
iterNum = (valuePtr->internalRep.longValue + 1); |
2715 |
|
Tcl_SetLongObj(valuePtr, iterNum); |
2716 |
|
|
2717 |
|
/* |
2718 |
|
* Check whether all value lists are exhausted and we should |
2719 |
|
* stop the loop. |
2720 |
|
*/ |
2721 |
|
|
2722 |
|
continueLoop = 0; |
2723 |
|
listTmpIndex = infoPtr->firstValueTemp; |
2724 |
|
for (i = 0; i < numLists; i++) { |
2725 |
|
varListPtr = infoPtr->varLists[i]; |
2726 |
|
numVars = varListPtr->numVars; |
2727 |
|
|
2728 |
|
listVarPtr = &(compiledLocals[listTmpIndex]); |
2729 |
|
listPtr = listVarPtr->value.objPtr; |
2730 |
|
result = Tcl_ListObjLength(interp, listPtr, &listLen); |
2731 |
|
if (result != TCL_OK) { |
2732 |
|
TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", |
2733 |
|
opnd, i, O2S(listPtr)), |
2734 |
|
Tcl_GetObjResult(interp)); |
2735 |
|
goto checkForCatch; |
2736 |
|
} |
2737 |
|
if (listLen > (iterNum * numVars)) { |
2738 |
|
continueLoop = 1; |
2739 |
|
} |
2740 |
|
listTmpIndex++; |
2741 |
|
} |
2742 |
|
|
2743 |
|
/* |
2744 |
|
* If some var in some var list still has a remaining list |
2745 |
|
* element iterate one more time. Assign to var the next |
2746 |
|
* element from its value list. We already checked above |
2747 |
|
* that each list temp holds a valid list object. |
2748 |
|
*/ |
2749 |
|
|
2750 |
|
if (continueLoop) { |
2751 |
|
listTmpIndex = infoPtr->firstValueTemp; |
2752 |
|
for (i = 0; i < numLists; i++) { |
2753 |
|
varListPtr = infoPtr->varLists[i]; |
2754 |
|
numVars = varListPtr->numVars; |
2755 |
|
|
2756 |
|
listVarPtr = &(compiledLocals[listTmpIndex]); |
2757 |
|
listPtr = listVarPtr->value.objPtr; |
2758 |
|
listRepPtr = (List *) listPtr->internalRep.otherValuePtr; |
2759 |
|
listLen = listRepPtr->elemCount; |
2760 |
|
|
2761 |
|
valIndex = (iterNum * numVars); |
2762 |
|
for (j = 0; j < numVars; j++) { |
2763 |
|
int setEmptyStr = 0; |
2764 |
|
if (valIndex >= listLen) { |
2765 |
|
setEmptyStr = 1; |
2766 |
|
valuePtr = Tcl_NewObj(); |
2767 |
|
} else { |
2768 |
|
valuePtr = listRepPtr->elements[valIndex]; |
2769 |
|
} |
2770 |
|
|
2771 |
|
varIndex = varListPtr->varIndexes[j]; |
2772 |
|
DECACHE_STACK_INFO(); |
2773 |
|
value2Ptr = TclSetIndexedScalar(interp, |
2774 |
|
varIndex, valuePtr, /*leaveErrorMsg*/ 1); |
2775 |
|
CACHE_STACK_INFO(); |
2776 |
|
if (value2Ptr == NULL) { |
2777 |
|
TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", |
2778 |
|
opnd, varIndex), |
2779 |
|
Tcl_GetObjResult(interp)); |
2780 |
|
if (setEmptyStr) { |
2781 |
|
Tcl_DecrRefCount(valuePtr); |
2782 |
|
} |
2783 |
|
result = TCL_ERROR; |
2784 |
|
goto checkForCatch; |
2785 |
|
} |
2786 |
|
valIndex++; |
2787 |
|
} |
2788 |
|
listTmpIndex++; |
2789 |
|
} |
2790 |
|
} |
2791 |
|
|
2792 |
|
/* |
2793 |
|
* Push 1 if at least one value list had a remaining element |
2794 |
|
* and the loop should continue. Otherwise push 0. |
2795 |
|
*/ |
2796 |
|
|
2797 |
|
PUSH_OBJECT(Tcl_NewLongObj(continueLoop)); |
2798 |
|
TRACE(("%u => %d lists, iter %d, %s loop\n", |
2799 |
|
opnd, numLists, iterNum, |
2800 |
|
(continueLoop? "continue" : "exit"))); |
2801 |
|
} |
2802 |
|
ADJUST_PC(5); |
2803 |
|
|
2804 |
|
case INST_BEGIN_CATCH4: |
2805 |
|
/* |
2806 |
|
* Record start of the catch command with exception range index |
2807 |
|
* equal to the operand. Push the current stack depth onto the |
2808 |
|
* special catch stack. |
2809 |
|
*/ |
2810 |
|
catchStackPtr[++catchTop] = stackTop; |
2811 |
|
TRACE(("%u => catchTop=%d, stackTop=%d\n", |
2812 |
|
TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); |
2813 |
|
ADJUST_PC(5); |
2814 |
|
|
2815 |
|
case INST_END_CATCH: |
2816 |
|
catchTop--; |
2817 |
|
result = TCL_OK; |
2818 |
|
TRACE(("=> catchTop=%d\n", catchTop)); |
2819 |
|
ADJUST_PC(1); |
2820 |
|
|
2821 |
|
case INST_PUSH_RESULT: |
2822 |
|
PUSH_OBJECT(Tcl_GetObjResult(interp)); |
2823 |
|
TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp)); |
2824 |
|
ADJUST_PC(1); |
2825 |
|
|
2826 |
|
case INST_PUSH_RETURN_CODE: |
2827 |
|
PUSH_OBJECT(Tcl_NewLongObj(result)); |
2828 |
|
TRACE(("=> %u\n", result)); |
2829 |
|
ADJUST_PC(1); |
2830 |
|
|
2831 |
|
default: |
2832 |
|
panic("TclExecuteByteCode: unrecognized opCode %u", *pc); |
2833 |
|
} /* end of switch on opCode */ |
2834 |
|
|
2835 |
|
/* |
2836 |
|
* Division by zero in an expression. Control only reaches this |
2837 |
|
* point by "goto divideByZero". |
2838 |
|
*/ |
2839 |
|
|
2840 |
|
divideByZero: |
2841 |
|
Tcl_ResetResult(interp); |
2842 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1); |
2843 |
|
Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", |
2844 |
|
(char *) NULL); |
2845 |
|
result = TCL_ERROR; |
2846 |
|
|
2847 |
|
/* |
2848 |
|
* Execution has generated an "exception" such as TCL_ERROR. If the |
2849 |
|
* exception is an error, record information about what was being |
2850 |
|
* executed when the error occurred. Find the closest enclosing |
2851 |
|
* catch range, if any. If no enclosing catch range is found, stop |
2852 |
|
* execution and return the "exception" code. |
2853 |
|
*/ |
2854 |
|
|
2855 |
|
checkForCatch: |
2856 |
|
if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { |
2857 |
|
bytes = GetSrcInfoForPc(pc, codePtr, &length); |
2858 |
|
if (bytes != NULL) { |
2859 |
|
Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); |
2860 |
|
iPtr->flags |= ERR_ALREADY_LOGGED; |
2861 |
|
} |
2862 |
|
} |
2863 |
|
rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); |
2864 |
|
if (rangePtr == NULL) { |
2865 |
|
#ifdef TCL_COMPILE_DEBUG |
2866 |
|
if (traceInstructions) { |
2867 |
|
fprintf(stdout, " ... no enclosing catch, returning %s\n", |
2868 |
|
StringForResultCode(result)); |
2869 |
|
} |
2870 |
|
#endif |
2871 |
|
goto abnormalReturn; |
2872 |
|
} |
2873 |
|
|
2874 |
|
/* |
2875 |
|
* A catch exception range (rangePtr) was found to handle an |
2876 |
|
* "exception". It was found either by checkForCatch just above or |
2877 |
|
* by an instruction during break, continue, or error processing. |
2878 |
|
* Jump to its catchOffset after unwinding the operand stack to |
2879 |
|
* the depth it had when starting to execute the range's catch |
2880 |
|
* command. |
2881 |
|
*/ |
2882 |
|
|
2883 |
|
processCatch: |
2884 |
|
while (stackTop > catchStackPtr[catchTop]) { |
2885 |
|
valuePtr = POP_OBJECT(); |
2886 |
|
TclDecrRefCount(valuePtr); |
2887 |
|
} |
2888 |
|
#ifdef TCL_COMPILE_DEBUG |
2889 |
|
if (traceInstructions) { |
2890 |
|
fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", |
2891 |
|
rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], |
2892 |
|
(unsigned int)(rangePtr->catchOffset)); |
2893 |
|
} |
2894 |
|
#endif |
2895 |
|
pc = (codePtr->codeStart + rangePtr->catchOffset); |
2896 |
|
continue; /* restart the execution loop at pc */ |
2897 |
|
} /* end of infinite loop dispatching on instructions */ |
2898 |
|
|
2899 |
|
/* |
2900 |
|
* Abnormal return code. Restore the stack to state it had when starting |
2901 |
|
* to execute the ByteCode. |
2902 |
|
*/ |
2903 |
|
|
2904 |
|
abnormalReturn: |
2905 |
|
while (stackTop > initStackTop) { |
2906 |
|
valuePtr = POP_OBJECT(); |
2907 |
|
Tcl_DecrRefCount(valuePtr); |
2908 |
|
} |
2909 |
|
|
2910 |
|
/* |
2911 |
|
* Free the catch stack array if malloc'ed storage was used. |
2912 |
|
*/ |
2913 |
|
|
2914 |
|
done: |
2915 |
|
if (catchStackPtr != catchStackStorage) { |
2916 |
|
ckfree((char *) catchStackPtr); |
2917 |
|
} |
2918 |
|
eePtr->stackTop = initStackTop; |
2919 |
|
return result; |
2920 |
|
#undef STATIC_CATCH_STACK_SIZE |
2921 |
|
} |
2922 |
|
|
2923 |
|
#ifdef TCL_COMPILE_DEBUG |
2924 |
|
/* |
2925 |
|
*---------------------------------------------------------------------- |
2926 |
|
* |
2927 |
|
* PrintByteCodeInfo -- |
2928 |
|
* |
2929 |
|
* This procedure prints a summary about a bytecode object to stdout. |
2930 |
|
* It is called by TclExecuteByteCode when starting to execute the |
2931 |
|
* bytecode object if tclTraceExec has the value 2 or more. |
2932 |
|
* |
2933 |
|
* Results: |
2934 |
|
* None. |
2935 |
|
* |
2936 |
|
* Side effects: |
2937 |
|
* None. |
2938 |
|
* |
2939 |
|
*---------------------------------------------------------------------- |
2940 |
|
*/ |
2941 |
|
|
2942 |
|
static void |
2943 |
|
PrintByteCodeInfo(codePtr) |
2944 |
|
register ByteCode *codePtr; /* The bytecode whose summary is printed |
2945 |
|
* to stdout. */ |
2946 |
|
{ |
2947 |
|
Proc *procPtr = codePtr->procPtr; |
2948 |
|
Interp *iPtr = (Interp *) *codePtr->interpHandle; |
2949 |
|
|
2950 |
|
fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", |
2951 |
|
(unsigned int) codePtr, codePtr->refCount, |
2952 |
|
codePtr->compileEpoch, (unsigned int) iPtr, |
2953 |
|
iPtr->compileEpoch); |
2954 |
|
|
2955 |
|
fprintf(stdout, " Source: "); |
2956 |
|
TclPrintSource(stdout, codePtr->source, 60); |
2957 |
|
|
2958 |
|
fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", |
2959 |
|
codePtr->numCommands, codePtr->numSrcBytes, |
2960 |
|
codePtr->numCodeBytes, codePtr->numLitObjects, |
2961 |
|
codePtr->numAuxDataItems, codePtr->maxStackDepth, |
2962 |
|
#ifdef TCL_COMPILE_STATS |
2963 |
|
(codePtr->numSrcBytes? |
2964 |
|
((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); |
2965 |
|
#else |
2966 |
|
0.0); |
2967 |
|
#endif |
2968 |
|
#ifdef TCL_COMPILE_STATS |
2969 |
|
fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", |
2970 |
|
codePtr->structureSize, |
2971 |
|
(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), |
2972 |
|
codePtr->numCodeBytes, |
2973 |
|
(codePtr->numLitObjects * sizeof(Tcl_Obj *)), |
2974 |
|
(codePtr->numExceptRanges * sizeof(ExceptionRange)), |
2975 |
|
(codePtr->numAuxDataItems * sizeof(AuxData)), |
2976 |
|
codePtr->numCmdLocBytes); |
2977 |
|
#endif /* TCL_COMPILE_STATS */ |
2978 |
|
if (procPtr != NULL) { |
2979 |
|
fprintf(stdout, |
2980 |
|
" Proc 0x%x, refCt %d, args %d, compiled locals %d\n", |
2981 |
|
(unsigned int) procPtr, procPtr->refCount, |
2982 |
|
procPtr->numArgs, procPtr->numCompiledLocals); |
2983 |
|
} |
2984 |
|
} |
2985 |
|
#endif /* TCL_COMPILE_DEBUG */ |
2986 |
|
|
2987 |
|
/* |
2988 |
|
*---------------------------------------------------------------------- |
2989 |
|
* |
2990 |
|
* ValidatePcAndStackTop -- |
2991 |
|
* |
2992 |
|
* This procedure is called by TclExecuteByteCode when debugging to |
2993 |
|
* verify that the program counter and stack top are valid during |
2994 |
|
* execution. |
2995 |
|
* |
2996 |
|
* Results: |
2997 |
|
* None. |
2998 |
|
* |
2999 |
|
* Side effects: |
3000 |
|
* Prints a message to stderr and panics if either the pc or stack |
3001 |
|
* top are invalid. |
3002 |
|
* |
3003 |
|
*---------------------------------------------------------------------- |
3004 |
|
*/ |
3005 |
|
|
3006 |
|
#ifdef TCL_COMPILE_DEBUG |
3007 |
|
static void |
3008 |
|
ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound, |
3009 |
|
stackUpperBound) |
3010 |
|
register ByteCode *codePtr; /* The bytecode whose summary is printed |
3011 |
|
* to stdout. */ |
3012 |
|
unsigned char *pc; /* Points to first byte of a bytecode |
3013 |
|
* instruction. The program counter. */ |
3014 |
|
int stackTop; /* Current stack top. Must be between |
3015 |
|
* stackLowerBound and stackUpperBound |
3016 |
|
* (inclusive). */ |
3017 |
|
int stackLowerBound; /* Smallest legal value for stackTop. */ |
3018 |
|
int stackUpperBound; /* Greatest legal value for stackTop. */ |
3019 |
|
{ |
3020 |
|
unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); |
3021 |
|
unsigned int codeStart = (unsigned int) codePtr->codeStart; |
3022 |
|
unsigned int codeEnd = (unsigned int) |
3023 |
|
(codePtr->codeStart + codePtr->numCodeBytes); |
3024 |
|
unsigned char opCode = *pc; |
3025 |
|
|
3026 |
|
if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) { |
3027 |
|
fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n", |
3028 |
|
(unsigned int) pc); |
3029 |
|
panic("TclExecuteByteCode execution failure: bad pc"); |
3030 |
|
} |
3031 |
|
if ((unsigned int) opCode > LAST_INST_OPCODE) { |
3032 |
|
fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", |
3033 |
|
(unsigned int) opCode, relativePc); |
3034 |
|
panic("TclExecuteByteCode execution failure: bad opcode"); |
3035 |
|
} |
3036 |
|
if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { |
3037 |
|
int numChars; |
3038 |
|
char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); |
3039 |
|
char *ellipsis = ""; |
3040 |
|
|
3041 |
|
fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode", |
3042 |
|
stackTop, relativePc); |
3043 |
|
if (cmd != NULL) { |
3044 |
|
if (numChars > 100) { |
3045 |
|
numChars = 100; |
3046 |
|
ellipsis = "..."; |
3047 |
|
} |
3048 |
|
fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd, |
3049 |
|
ellipsis); |
3050 |
|
} else { |
3051 |
|
fprintf(stderr, "\n"); |
3052 |
|
} |
3053 |
|
panic("TclExecuteByteCode execution failure: bad stack top"); |
3054 |
|
} |
3055 |
|
} |
3056 |
|
#endif /* TCL_COMPILE_DEBUG */ |
3057 |
|
|
3058 |
|
/* |
3059 |
|
*---------------------------------------------------------------------- |
3060 |
|
* |
3061 |
|
* IllegalExprOperandType -- |
3062 |
|
* |
3063 |
|
* Used by TclExecuteByteCode to add an error message to errorInfo |
3064 |
|
* when an illegal operand type is detected by an expression |
3065 |
|
* instruction. The argument opndPtr holds the operand object in error. |
3066 |
|
* |
3067 |
|
* Results: |
3068 |
|
* None. |
3069 |
|
* |
3070 |
|
* Side effects: |
3071 |
|
* An error message is appended to errorInfo. |
3072 |
|
* |
3073 |
|
*---------------------------------------------------------------------- |
3074 |
|
*/ |
3075 |
|
|
3076 |
|
static void |
3077 |
|
IllegalExprOperandType(interp, pc, opndPtr) |
3078 |
|
Tcl_Interp *interp; /* Interpreter to which error information |
3079 |
|
* pertains. */ |
3080 |
|
unsigned char *pc; /* Points to the instruction being executed |
3081 |
|
* when the illegal type was found. */ |
3082 |
|
Tcl_Obj *opndPtr; /* Points to the operand holding the value |
3083 |
|
* with the illegal type. */ |
3084 |
|
{ |
3085 |
|
unsigned char opCode = *pc; |
3086 |
|
|
3087 |
|
Tcl_ResetResult(interp); |
3088 |
|
if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { |
3089 |
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
3090 |
|
"can't use empty string as operand of \"", |
3091 |
|
operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); |
3092 |
|
} else { |
3093 |
|
char *msg = "non-numeric string"; |
3094 |
|
if (opndPtr->typePtr != &tclDoubleType) { |
3095 |
|
/* |
3096 |
|
* See if the operand can be interpreted as a double in order to |
3097 |
|
* improve the error message. |
3098 |
|
*/ |
3099 |
|
|
3100 |
|
char *s = Tcl_GetString(opndPtr); |
3101 |
|
double d; |
3102 |
|
|
3103 |
|
if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) { |
3104 |
|
/* |
3105 |
|
* Make sure that what appears to be a double |
3106 |
|
* (ie 08) isn't really a bad octal |
3107 |
|
*/ |
3108 |
|
if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) { |
3109 |
|
msg = "invalid octal number"; |
3110 |
|
} else { |
3111 |
|
msg = "floating-point value"; |
3112 |
|
} |
3113 |
|
} |
3114 |
|
} |
3115 |
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", |
3116 |
|
msg, " as operand of \"", operatorStrings[opCode - INST_LOR], |
3117 |
|
"\"", (char *) NULL); |
3118 |
|
} |
3119 |
|
} |
3120 |
|
|
3121 |
|
/* |
3122 |
|
*---------------------------------------------------------------------- |
3123 |
|
* |
3124 |
|
* CallTraceProcedure -- |
3125 |
|
* |
3126 |
|
* Invokes a trace procedure registered with an interpreter. These |
3127 |
|
* procedures trace command execution. Currently this trace procedure |
3128 |
|
* is called with the address of the string-based Tcl_CmdProc for the |
3129 |
|
* command, not the Tcl_ObjCmdProc. |
3130 |
|
* |
3131 |
|
* Results: |
3132 |
|
* None. |
3133 |
|
* |
3134 |
|
* Side effects: |
3135 |
|
* Those side effects made by the trace procedure. |
3136 |
|
* |
3137 |
|
*---------------------------------------------------------------------- |
3138 |
|
*/ |
3139 |
|
|
3140 |
|
static void |
3141 |
|
CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv) |
3142 |
|
Tcl_Interp *interp; /* The current interpreter. */ |
3143 |
|
register Trace *tracePtr; /* Describes the trace procedure to call. */ |
3144 |
|
Command *cmdPtr; /* Points to command's Command struct. */ |
3145 |
|
char *command; /* Points to the first character of the |
3146 |
|
* command's source before substitutions. */ |
3147 |
|
int numChars; /* The number of characters in the |
3148 |
|
* command's source. */ |
3149 |
|
register int objc; /* Number of arguments for the command. */ |
3150 |
|
Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */ |
3151 |
|
{ |
3152 |
|
Interp *iPtr = (Interp *) interp; |
3153 |
|
register char **argv; |
3154 |
|
register int i; |
3155 |
|
int length; |
3156 |
|
char *p; |
3157 |
|
|
3158 |
|
/* |
3159 |
|
* Get the string rep from the objv argument objects and place their |
3160 |
|
* pointers in argv. First make sure argv is large enough to hold the |
3161 |
|
* objc args plus 1 extra word for the zero end-of-argv word. |
3162 |
|
*/ |
3163 |
|
|
3164 |
|
argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *)); |
3165 |
|
for (i = 0; i < objc; i++) { |
3166 |
|
argv[i] = Tcl_GetStringFromObj(objv[i], &length); |
3167 |
|
} |
3168 |
|
argv[objc] = 0; |
3169 |
|
|
3170 |
|
/* |
3171 |
|
* Copy the command characters into a new string. |
3172 |
|
*/ |
3173 |
|
|
3174 |
|
p = (char *) ckalloc((unsigned) (numChars + 1)); |
3175 |
|
memcpy((VOID *) p, (VOID *) command, (size_t) numChars); |
3176 |
|
p[numChars] = '\0'; |
3177 |
|
|
3178 |
|
/* |
3179 |
|
* Call the trace procedure then free allocated storage. |
3180 |
|
*/ |
3181 |
|
|
3182 |
|
(*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels, |
3183 |
|
p, cmdPtr->proc, cmdPtr->clientData, objc, argv); |
3184 |
|
|
3185 |
|
ckfree((char *) argv); |
3186 |
|
ckfree((char *) p); |
3187 |
|
} |
3188 |
|
|
3189 |
|
/* |
3190 |
|
*---------------------------------------------------------------------- |
3191 |
|
* |
3192 |
|
* GetSrcInfoForPc -- |
3193 |
|
* |
3194 |
|
* Given a program counter value, finds the closest command in the |
3195 |
|
* bytecode code unit's CmdLocation array and returns information about |
3196 |
|
* that command's source: a pointer to its first byte and the number of |
3197 |
|
* characters. |
3198 |
|
* |
3199 |
|
* Results: |
3200 |
|
* If a command is found that encloses the program counter value, a |
3201 |
|
* pointer to the command's source is returned and the length of the |
3202 |
|
* source is stored at *lengthPtr. If multiple commands resulted in |
3203 |
|
* code at pc, information about the closest enclosing command is |
3204 |
|
* returned. If no matching command is found, NULL is returned and |
3205 |
|
* *lengthPtr is unchanged. |
3206 |
|
* |
3207 |
|
* Side effects: |
3208 |
|
* None. |
3209 |
|
* |
3210 |
|
*---------------------------------------------------------------------- |
3211 |
|
*/ |
3212 |
|
|
3213 |
|
static char * |
3214 |
|
GetSrcInfoForPc(pc, codePtr, lengthPtr) |
3215 |
|
unsigned char *pc; /* The program counter value for which to |
3216 |
|
* return the closest command's source info. |
3217 |
|
* This points to a bytecode instruction |
3218 |
|
* in codePtr's code. */ |
3219 |
|
ByteCode *codePtr; /* The bytecode sequence in which to look |
3220 |
|
* up the command source for the pc. */ |
3221 |
|
int *lengthPtr; /* If non-NULL, the location where the |
3222 |
|
* length of the command's source should be |
3223 |
|
* stored. If NULL, no length is stored. */ |
3224 |
|
{ |
3225 |
|
register int pcOffset = (pc - codePtr->codeStart); |
3226 |
|
int numCmds = codePtr->numCommands; |
3227 |
|
unsigned char *codeDeltaNext, *codeLengthNext; |
3228 |
|
unsigned char *srcDeltaNext, *srcLengthNext; |
3229 |
|
int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; |
3230 |
|
int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ |
3231 |
|
int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ |
3232 |
|
int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ |
3233 |
|
|
3234 |
|
if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { |
3235 |
|
return NULL; |
3236 |
|
} |
3237 |
|
|
3238 |
|
/* |
3239 |
|
* Decode the code and source offset and length for each command. The |
3240 |
|
* closest enclosing command is the last one whose code started before |
3241 |
|
* pcOffset. |
3242 |
|
*/ |
3243 |
|
|
3244 |
|
codeDeltaNext = codePtr->codeDeltaStart; |
3245 |
|
codeLengthNext = codePtr->codeLengthStart; |
3246 |
|
srcDeltaNext = codePtr->srcDeltaStart; |
3247 |
|
srcLengthNext = codePtr->srcLengthStart; |
3248 |
|
codeOffset = srcOffset = 0; |
3249 |
|
for (i = 0; i < numCmds; i++) { |
3250 |
|
if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { |
3251 |
|
codeDeltaNext++; |
3252 |
|
delta = TclGetInt4AtPtr(codeDeltaNext); |
3253 |
|
codeDeltaNext += 4; |
3254 |
|
} else { |
3255 |
|
delta = TclGetInt1AtPtr(codeDeltaNext); |
3256 |
|
codeDeltaNext++; |
3257 |
|
} |
3258 |
|
codeOffset += delta; |
3259 |
|
|
3260 |
|
if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { |
3261 |
|
codeLengthNext++; |
3262 |
|
codeLen = TclGetInt4AtPtr(codeLengthNext); |
3263 |
|
codeLengthNext += 4; |
3264 |
|
} else { |
3265 |
|
codeLen = TclGetInt1AtPtr(codeLengthNext); |
3266 |
|
codeLengthNext++; |
3267 |
|
} |
3268 |
|
codeEnd = (codeOffset + codeLen - 1); |
3269 |
|
|
3270 |
|
if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { |
3271 |
|
srcDeltaNext++; |
3272 |
|
delta = TclGetInt4AtPtr(srcDeltaNext); |
3273 |
|
srcDeltaNext += 4; |
3274 |
|
} else { |
3275 |
|
delta = TclGetInt1AtPtr(srcDeltaNext); |
3276 |
|
srcDeltaNext++; |
3277 |
|
} |
3278 |
|
srcOffset += delta; |
3279 |
|
|
3280 |
|
if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { |
3281 |
|
srcLengthNext++; |
3282 |
|
srcLen = TclGetInt4AtPtr(srcLengthNext); |
3283 |
|
srcLengthNext += 4; |
3284 |
|
} else { |
3285 |
|
srcLen = TclGetInt1AtPtr(srcLengthNext); |
3286 |
|
srcLengthNext++; |
3287 |
|
} |
3288 |
|
|
3289 |
|
if (codeOffset > pcOffset) { /* best cmd already found */ |
3290 |
|
break; |
3291 |
|
} else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ |
3292 |
|
int dist = (pcOffset - codeOffset); |
3293 |
|
if (dist <= bestDist) { |
3294 |
|
bestDist = dist; |
3295 |
|
bestSrcOffset = srcOffset; |
3296 |
|
bestSrcLength = srcLen; |
3297 |
|
} |
3298 |
|
} |
3299 |
|
} |
3300 |
|
|
3301 |
|
if (bestDist == INT_MAX) { |
3302 |
|
return NULL; |
3303 |
|
} |
3304 |
|
|
3305 |
|
if (lengthPtr != NULL) { |
3306 |
|
*lengthPtr = bestSrcLength; |
3307 |
|
} |
3308 |
|
return (codePtr->source + bestSrcOffset); |
3309 |
|
} |
3310 |
|
|
3311 |
|
/* |
3312 |
|
*---------------------------------------------------------------------- |
3313 |
|
* |
3314 |
|
* GetExceptRangeForPc -- |
3315 |
|
* |
3316 |
|
* Given a program counter value, return the closest enclosing |
3317 |
|
* ExceptionRange. |
3318 |
|
* |
3319 |
|
* Results: |
3320 |
|
* In the normal case, catchOnly is 0 (false) and this procedure |
3321 |
|
* returns a pointer to the most closely enclosing ExceptionRange |
3322 |
|
* structure regardless of whether it is a loop or catch exception |
3323 |
|
* range. This is appropriate when processing a TCL_BREAK or |
3324 |
|
* TCL_CONTINUE, which will be "handled" either by a loop exception |
3325 |
|
* range or a closer catch range. If catchOnly is nonzero, this |
3326 |
|
* procedure ignores loop exception ranges and returns a pointer to the |
3327 |
|
* closest catch range. If no matching ExceptionRange is found that |
3328 |
|
* encloses pc, a NULL is returned. |
3329 |
|
* |
3330 |
|
* Side effects: |
3331 |
|
* None. |
3332 |
|
* |
3333 |
|
*---------------------------------------------------------------------- |
3334 |
|
*/ |
3335 |
|
|
3336 |
|
static ExceptionRange * |
3337 |
|
GetExceptRangeForPc(pc, catchOnly, codePtr) |
3338 |
|
unsigned char *pc; /* The program counter value for which to |
3339 |
|
* search for a closest enclosing exception |
3340 |
|
* range. This points to a bytecode |
3341 |
|
* instruction in codePtr's code. */ |
3342 |
|
int catchOnly; /* If 0, consider either loop or catch |
3343 |
|
* ExceptionRanges in search. If nonzero |
3344 |
|
* consider only catch ranges (and ignore |
3345 |
|
* any closer loop ranges). */ |
3346 |
|
ByteCode* codePtr; /* Points to the ByteCode in which to search |
3347 |
|
* for the enclosing ExceptionRange. */ |
3348 |
|
{ |
3349 |
|
ExceptionRange *rangeArrayPtr; |
3350 |
|
int numRanges = codePtr->numExceptRanges; |
3351 |
|
register ExceptionRange *rangePtr; |
3352 |
|
int pcOffset = (pc - codePtr->codeStart); |
3353 |
|
register int i, level; |
3354 |
|
|
3355 |
|
if (numRanges == 0) { |
3356 |
|
return NULL; |
3357 |
|
} |
3358 |
|
rangeArrayPtr = codePtr->exceptArrayPtr; |
3359 |
|
|
3360 |
|
for (level = codePtr->maxExceptDepth; level >= 0; level--) { |
3361 |
|
for (i = 0; i < numRanges; i++) { |
3362 |
|
rangePtr = &(rangeArrayPtr[i]); |
3363 |
|
if (rangePtr->nestingLevel == level) { |
3364 |
|
int start = rangePtr->codeOffset; |
3365 |
|
int end = (start + rangePtr->numCodeBytes); |
3366 |
|
if ((start <= pcOffset) && (pcOffset < end)) { |
3367 |
|
if ((!catchOnly) |
3368 |
|
|| (rangePtr->type == CATCH_EXCEPTION_RANGE)) { |
3369 |
|
return rangePtr; |
3370 |
|
} |
3371 |
|
} |
3372 |
|
} |
3373 |
|
} |
3374 |
|
} |
3375 |
|
return NULL; |
3376 |
|
} |
3377 |
|
|
3378 |
|
/* |
3379 |
|
*---------------------------------------------------------------------- |
3380 |
|
* |
3381 |
|
* GetOpcodeName -- |
3382 |
|
* |
3383 |
|
* This procedure is called by the TRACE and TRACE_WITH_OBJ macros |
3384 |
|
* used in TclExecuteByteCode when debugging. It returns the name of |
3385 |
|
* the bytecode instruction at a specified instruction pc. |
3386 |
|
* |
3387 |
|
* Results: |
3388 |
|
* A character string for the instruction. |
3389 |
|
* |
3390 |
|
* Side effects: |
3391 |
|
* None. |
3392 |
|
* |
3393 |
|
*---------------------------------------------------------------------- |
3394 |
|
*/ |
3395 |
|
|
3396 |
|
#ifdef TCL_COMPILE_DEBUG |
3397 |
|
static char * |
3398 |
|
GetOpcodeName(pc) |
3399 |
|
unsigned char *pc; /* Points to the instruction whose name |
3400 |
|
* should be returned. */ |
3401 |
|
{ |
3402 |
|
unsigned char opCode = *pc; |
3403 |
|
|
3404 |
|
return instructionTable[opCode].name; |
3405 |
|
} |
3406 |
|
#endif /* TCL_COMPILE_DEBUG */ |
3407 |
|
|
3408 |
|
/* |
3409 |
|
*---------------------------------------------------------------------- |
3410 |
|
* |
3411 |
|
* VerifyExprObjType -- |
3412 |
|
* |
3413 |
|
* This procedure is called by the math functions to verify that |
3414 |
|
* the object is either an int or double, coercing it if necessary. |
3415 |
|
* If an error occurs during conversion, an error message is left |
3416 |
|
* in the interpreter's result unless "interp" is NULL. |
3417 |
|
* |
3418 |
|
* Results: |
3419 |
|
* TCL_OK if it was int or double, TCL_ERROR otherwise |
3420 |
|
* |
3421 |
|
* Side effects: |
3422 |
|
* objPtr is ensured to be either tclIntType of tclDoubleType. |
3423 |
|
* |
3424 |
|
*---------------------------------------------------------------------- |
3425 |
|
*/ |
3426 |
|
|
3427 |
|
static int |
3428 |
|
VerifyExprObjType(interp, objPtr) |
3429 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
3430 |
|
* function. */ |
3431 |
|
Tcl_Obj *objPtr; /* Points to the object to type check. */ |
3432 |
|
{ |
3433 |
|
if ((objPtr->typePtr == &tclIntType) || |
3434 |
|
(objPtr->typePtr == &tclDoubleType)) { |
3435 |
|
return TCL_OK; |
3436 |
|
} else { |
3437 |
|
int length, result = TCL_OK; |
3438 |
|
char *s = Tcl_GetStringFromObj(objPtr, &length); |
3439 |
|
|
3440 |
|
if (TclLooksLikeInt(s, length)) { |
3441 |
|
long i; |
3442 |
|
result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i); |
3443 |
|
} else { |
3444 |
|
double d; |
3445 |
|
result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); |
3446 |
|
} |
3447 |
|
if ((result != TCL_OK) && (interp != NULL)) { |
3448 |
|
Tcl_ResetResult(interp); |
3449 |
|
if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) { |
3450 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
3451 |
|
"argument to math function was an invalid octal number", |
3452 |
|
-1); |
3453 |
|
} else { |
3454 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
3455 |
|
"argument to math function didn't have numeric value", |
3456 |
|
-1); |
3457 |
|
} |
3458 |
|
} |
3459 |
|
return result; |
3460 |
|
} |
3461 |
|
} |
3462 |
|
|
3463 |
|
/* |
3464 |
|
*---------------------------------------------------------------------- |
3465 |
|
* |
3466 |
|
* Math Functions -- |
3467 |
|
* |
3468 |
|
* This page contains the procedures that implement all of the |
3469 |
|
* built-in math functions for expressions. |
3470 |
|
* |
3471 |
|
* Results: |
3472 |
|
* Each procedure returns TCL_OK if it succeeds and pushes an |
3473 |
|
* Tcl object holding the result. If it fails it returns TCL_ERROR |
3474 |
|
* and leaves an error message in the interpreter's result. |
3475 |
|
* |
3476 |
|
* Side effects: |
3477 |
|
* None. |
3478 |
|
* |
3479 |
|
*---------------------------------------------------------------------- |
3480 |
|
*/ |
3481 |
|
|
3482 |
|
static int |
3483 |
|
ExprUnaryFunc(interp, eePtr, clientData) |
3484 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
3485 |
|
* function. */ |
3486 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
3487 |
|
* the function. */ |
3488 |
|
ClientData clientData; /* Contains the address of a procedure that |
3489 |
|
* takes one double argument and returns a |
3490 |
|
* double result. */ |
3491 |
|
{ |
3492 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
3493 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
3494 |
|
register Tcl_Obj *valuePtr; |
3495 |
|
double d, dResult; |
3496 |
|
int result; |
3497 |
|
|
3498 |
|
double (*func) _ANSI_ARGS_((double)) = |
3499 |
|
(double (*)_ANSI_ARGS_((double))) clientData; |
3500 |
|
|
3501 |
|
/* |
3502 |
|
* Set stackPtr and stackTop from eePtr. |
3503 |
|
*/ |
3504 |
|
|
3505 |
|
result = TCL_OK; |
3506 |
|
CACHE_STACK_INFO(); |
3507 |
|
|
3508 |
|
/* |
3509 |
|
* Pop the function's argument from the evaluation stack. Convert it |
3510 |
|
* to a double if necessary. |
3511 |
|
*/ |
3512 |
|
|
3513 |
|
valuePtr = POP_OBJECT(); |
3514 |
|
|
3515 |
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
3516 |
|
result = TCL_ERROR; |
3517 |
|
goto done; |
3518 |
|
} |
3519 |
|
|
3520 |
|
if (valuePtr->typePtr == &tclIntType) { |
3521 |
|
d = (double) valuePtr->internalRep.longValue; |
3522 |
|
} else { |
3523 |
|
d = valuePtr->internalRep.doubleValue; |
3524 |
|
} |
3525 |
|
|
3526 |
|
errno = 0; |
3527 |
|
dResult = (*func)(d); |
3528 |
|
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { |
3529 |
|
TclExprFloatError(interp, dResult); |
3530 |
|
result = TCL_ERROR; |
3531 |
|
goto done; |
3532 |
|
} |
3533 |
|
|
3534 |
|
/* |
3535 |
|
* Push a Tcl object holding the result. |
3536 |
|
*/ |
3537 |
|
|
3538 |
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
3539 |
|
|
3540 |
|
/* |
3541 |
|
* Reflect the change to stackTop back in eePtr. |
3542 |
|
*/ |
3543 |
|
|
3544 |
|
done: |
3545 |
|
Tcl_DecrRefCount(valuePtr); |
3546 |
|
DECACHE_STACK_INFO(); |
3547 |
|
return result; |
3548 |
|
} |
3549 |
|
|
3550 |
|
static int |
3551 |
|
ExprBinaryFunc(interp, eePtr, clientData) |
3552 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
3553 |
|
* function. */ |
3554 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
3555 |
|
* the function. */ |
3556 |
|
ClientData clientData; /* Contains the address of a procedure that |
3557 |
|
* takes two double arguments and |
3558 |
|
* returns a double result. */ |
3559 |
|
{ |
3560 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
3561 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
3562 |
|
register Tcl_Obj *valuePtr, *value2Ptr; |
3563 |
|
double d1, d2, dResult; |
3564 |
|
int result; |
3565 |
|
|
3566 |
|
double (*func) _ANSI_ARGS_((double, double)) |
3567 |
|
= (double (*)_ANSI_ARGS_((double, double))) clientData; |
3568 |
|
|
3569 |
|
/* |
3570 |
|
* Set stackPtr and stackTop from eePtr. |
3571 |
|
*/ |
3572 |
|
|
3573 |
|
result = TCL_OK; |
3574 |
|
CACHE_STACK_INFO(); |
3575 |
|
|
3576 |
|
/* |
3577 |
|
* Pop the function's two arguments from the evaluation stack. Convert |
3578 |
|
* them to doubles if necessary. |
3579 |
|
*/ |
3580 |
|
|
3581 |
|
value2Ptr = POP_OBJECT(); |
3582 |
|
valuePtr = POP_OBJECT(); |
3583 |
|
|
3584 |
|
if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) || |
3585 |
|
(VerifyExprObjType(interp, value2Ptr) != TCL_OK)) { |
3586 |
|
result = TCL_ERROR; |
3587 |
|
goto done; |
3588 |
|
} |
3589 |
|
|
3590 |
|
if (valuePtr->typePtr == &tclIntType) { |
3591 |
|
d1 = (double) valuePtr->internalRep.longValue; |
3592 |
|
} else { |
3593 |
|
d1 = valuePtr->internalRep.doubleValue; |
3594 |
|
} |
3595 |
|
|
3596 |
|
if (value2Ptr->typePtr == &tclIntType) { |
3597 |
|
d2 = (double) value2Ptr->internalRep.longValue; |
3598 |
|
} else { |
3599 |
|
d2 = value2Ptr->internalRep.doubleValue; |
3600 |
|
} |
3601 |
|
|
3602 |
|
errno = 0; |
3603 |
|
dResult = (*func)(d1, d2); |
3604 |
|
if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { |
3605 |
|
TclExprFloatError(interp, dResult); |
3606 |
|
result = TCL_ERROR; |
3607 |
|
goto done; |
3608 |
|
} |
3609 |
|
|
3610 |
|
/* |
3611 |
|
* Push a Tcl object holding the result. |
3612 |
|
*/ |
3613 |
|
|
3614 |
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
3615 |
|
|
3616 |
|
/* |
3617 |
|
* Reflect the change to stackTop back in eePtr. |
3618 |
|
*/ |
3619 |
|
|
3620 |
|
done: |
3621 |
|
Tcl_DecrRefCount(valuePtr); |
3622 |
|
Tcl_DecrRefCount(value2Ptr); |
3623 |
|
DECACHE_STACK_INFO(); |
3624 |
|
return result; |
3625 |
|
} |
3626 |
|
|
3627 |
|
static int |
3628 |
|
ExprAbsFunc(interp, eePtr, clientData) |
3629 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
3630 |
|
* function. */ |
3631 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
3632 |
|
* the function. */ |
3633 |
|
ClientData clientData; /* Ignored. */ |
3634 |
|
{ |
3635 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
3636 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
3637 |
|
register Tcl_Obj *valuePtr; |
3638 |
|
long i, iResult; |
3639 |
|
double d, dResult; |
3640 |
|
int result; |
3641 |
|
|
3642 |
|
/* |
3643 |
|
* Set stackPtr and stackTop from eePtr. |
3644 |
|
*/ |
3645 |
|
|
3646 |
|
result = TCL_OK; |
3647 |
|
CACHE_STACK_INFO(); |
3648 |
|
|
3649 |
|
/* |
3650 |
|
* Pop the argument from the evaluation stack. |
3651 |
|
*/ |
3652 |
|
|
3653 |
|
valuePtr = POP_OBJECT(); |
3654 |
|
|
3655 |
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
3656 |
|
result = TCL_ERROR; |
3657 |
|
goto done; |
3658 |
|
} |
3659 |
|
|
3660 |
|
/* |
3661 |
|
* Push a Tcl object with the result. |
3662 |
|
*/ |
3663 |
|
if (valuePtr->typePtr == &tclIntType) { |
3664 |
|
i = valuePtr->internalRep.longValue; |
3665 |
|
if (i < 0) { |
3666 |
|
iResult = -i; |
3667 |
|
if (iResult < 0) { |
3668 |
|
Tcl_ResetResult(interp); |
3669 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
3670 |
|
"integer value too large to represent", -1); |
3671 |
|
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", |
3672 |
|
"integer value too large to represent", (char *) NULL); |
3673 |
|
result = TCL_ERROR; |
3674 |
|
goto done; |
3675 |
|
} |
3676 |
|
} else { |
3677 |
|
iResult = i; |
3678 |
|
} |
3679 |
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
3680 |
|
} else { |
3681 |
|
d = valuePtr->internalRep.doubleValue; |
3682 |
|
if (d < 0.0) { |
3683 |
|
dResult = -d; |
3684 |
|
} else { |
3685 |
|
dResult = d; |
3686 |
|
} |
3687 |
|
if (IS_NAN(dResult) || IS_INF(dResult)) { |
3688 |
|
TclExprFloatError(interp, dResult); |
3689 |
|
result = TCL_ERROR; |
3690 |
|
goto done; |
3691 |
|
} |
3692 |
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
3693 |
|
} |
3694 |
|
|
3695 |
|
/* |
3696 |
|
* Reflect the change to stackTop back in eePtr. |
3697 |
|
*/ |
3698 |
|
|
3699 |
|
done: |
3700 |
|
Tcl_DecrRefCount(valuePtr); |
3701 |
|
DECACHE_STACK_INFO(); |
3702 |
|
return result; |
3703 |
|
} |
3704 |
|
|
3705 |
|
static int |
3706 |
|
ExprDoubleFunc(interp, eePtr, clientData) |
3707 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
3708 |
|
* function. */ |
3709 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
3710 |
|
* the function. */ |
3711 |
|
ClientData clientData; /* Ignored. */ |
3712 |
|
{ |
3713 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
3714 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
3715 |
|
register Tcl_Obj *valuePtr; |
3716 |
|
double dResult; |
3717 |
|
int result; |
3718 |
|
|
3719 |
|
/* |
3720 |
|
* Set stackPtr and stackTop from eePtr. |
3721 |
|
*/ |
3722 |
|
|
3723 |
|
result = TCL_OK; |
3724 |
|
CACHE_STACK_INFO(); |
3725 |
|
|
3726 |
|
/* |
3727 |
|
* Pop the argument from the evaluation stack. |
3728 |
|
*/ |
3729 |
|
|
3730 |
|
valuePtr = POP_OBJECT(); |
3731 |
|
|
3732 |
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
3733 |
|
result = TCL_ERROR; |
3734 |
|
goto done; |
3735 |
|
} |
3736 |
|
|
3737 |
|
if (valuePtr->typePtr == &tclIntType) { |
3738 |
|
dResult = (double) valuePtr->internalRep.longValue; |
3739 |
|
} else { |
3740 |
|
dResult = valuePtr->internalRep.doubleValue; |
3741 |
|
} |
3742 |
|
|
3743 |
|
/* |
3744 |
|
* Push a Tcl object with the result. |
3745 |
|
*/ |
3746 |
|
|
3747 |
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
3748 |
|
|
3749 |
|
/* |
3750 |
|
* Reflect the change to stackTop back in eePtr. |
3751 |
|
*/ |
3752 |
|
|
3753 |
|
done: |
3754 |
|
Tcl_DecrRefCount(valuePtr); |
3755 |
|
DECACHE_STACK_INFO(); |
3756 |
|
return result; |
3757 |
|
} |
3758 |
|
|
3759 |
|
static int |
3760 |
|
ExprIntFunc(interp, eePtr, clientData) |
3761 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
3762 |
|
* function. */ |
3763 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
3764 |
|
* the function. */ |
3765 |
|
ClientData clientData; /* Ignored. */ |
3766 |
|
{ |
3767 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
3768 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
3769 |
|
register Tcl_Obj *valuePtr; |
3770 |
|
long iResult; |
3771 |
|
double d; |
3772 |
|
int result; |
3773 |
|
|
3774 |
|
/* |
3775 |
|
* Set stackPtr and stackTop from eePtr. |
3776 |
|
*/ |
3777 |
|
|
3778 |
|
result = TCL_OK; |
3779 |
|
CACHE_STACK_INFO(); |
3780 |
|
|
3781 |
|
/* |
3782 |
|
* Pop the argument from the evaluation stack. |
3783 |
|
*/ |
3784 |
|
|
3785 |
|
valuePtr = POP_OBJECT(); |
3786 |
|
|
3787 |
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
3788 |
|
result = TCL_ERROR; |
3789 |
|
goto done; |
3790 |
|
} |
3791 |
|
|
3792 |
|
if (valuePtr->typePtr == &tclIntType) { |
3793 |
|
iResult = valuePtr->internalRep.longValue; |
3794 |
|
} else { |
3795 |
|
d = valuePtr->internalRep.doubleValue; |
3796 |
|
if (d < 0.0) { |
3797 |
|
if (d < (double) (long) LONG_MIN) { |
3798 |
|
tooLarge: |
3799 |
|
Tcl_ResetResult(interp); |
3800 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
3801 |
|
"integer value too large to represent", -1); |
3802 |
|
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", |
3803 |
|
"integer value too large to represent", (char *) NULL); |
3804 |
|
result = TCL_ERROR; |
3805 |
|
goto done; |
3806 |
|
} |
3807 |
|
} else { |
3808 |
|
if (d > (double) LONG_MAX) { |
3809 |
|
goto tooLarge; |
3810 |
|
} |
3811 |
|
} |
3812 |
|
if (IS_NAN(d) || IS_INF(d)) { |
3813 |
|
TclExprFloatError(interp, d); |
3814 |
|
result = TCL_ERROR; |
3815 |
|
goto done; |
3816 |
|
} |
3817 |
|
iResult = (long) d; |
3818 |
|
} |
3819 |
|
|
3820 |
|
/* |
3821 |
|
* Push a Tcl object with the result. |
3822 |
|
*/ |
3823 |
|
|
3824 |
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
3825 |
|
|
3826 |
|
/* |
3827 |
|
* Reflect the change to stackTop back in eePtr. |
3828 |
|
*/ |
3829 |
|
|
3830 |
|
done: |
3831 |
|
Tcl_DecrRefCount(valuePtr); |
3832 |
|
DECACHE_STACK_INFO(); |
3833 |
|
return result; |
3834 |
|
} |
3835 |
|
|
3836 |
|
static int |
3837 |
|
ExprRandFunc(interp, eePtr, clientData) |
3838 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
3839 |
|
* function. */ |
3840 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
3841 |
|
* the function. */ |
3842 |
|
ClientData clientData; /* Ignored. */ |
3843 |
|
{ |
3844 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
3845 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
3846 |
|
Interp *iPtr = (Interp *) interp; |
3847 |
|
double dResult; |
3848 |
|
int tmp; |
3849 |
|
|
3850 |
|
if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { |
3851 |
|
iPtr->flags |= RAND_SEED_INITIALIZED; |
3852 |
|
iPtr->randSeed = TclpGetClicks(); |
3853 |
|
} |
3854 |
|
|
3855 |
|
/* |
3856 |
|
* Set stackPtr and stackTop from eePtr. |
3857 |
|
*/ |
3858 |
|
|
3859 |
|
CACHE_STACK_INFO(); |
3860 |
|
|
3861 |
|
/* |
3862 |
|
* Generate the random number using the linear congruential |
3863 |
|
* generator defined by the following recurrence: |
3864 |
|
* seed = ( IA * seed ) mod IM |
3865 |
|
* where IA is 16807 and IM is (2^31) - 1. In order to avoid |
3866 |
|
* potential problems with integer overflow, the code uses |
3867 |
|
* additional constants IQ and IR such that |
3868 |
|
* IM = IA*IQ + IR |
3869 |
|
* For details on how this algorithm works, refer to the following |
3870 |
|
* papers: |
3871 |
|
* |
3872 |
|
* S.K. Park & K.W. Miller, "Random number generators: good ones |
3873 |
|
* are hard to find," Comm ACM 31(10):1192-1201, Oct 1988 |
3874 |
|
* |
3875 |
|
* W.H. Press & S.A. Teukolsky, "Portable random number |
3876 |
|
* generators," Computers in Physics 6(5):522-524, Sep/Oct 1992. |
3877 |
|
*/ |
3878 |
|
|
3879 |
|
#define RAND_IA 16807 |
3880 |
|
#define RAND_IM 2147483647 |
3881 |
|
#define RAND_IQ 127773 |
3882 |
|
#define RAND_IR 2836 |
3883 |
|
#define RAND_MASK 123459876 |
3884 |
|
|
3885 |
|
if (iPtr->randSeed == 0) { |
3886 |
|
/* |
3887 |
|
* Don't allow a 0 seed, since it breaks the generator. Shift |
3888 |
|
* it to some other value. |
3889 |
|
*/ |
3890 |
|
|
3891 |
|
iPtr->randSeed = 123459876; |
3892 |
|
} |
3893 |
|
tmp = iPtr->randSeed/RAND_IQ; |
3894 |
|
iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; |
3895 |
|
if (iPtr->randSeed < 0) { |
3896 |
|
iPtr->randSeed += RAND_IM; |
3897 |
|
} |
3898 |
|
|
3899 |
|
/* |
3900 |
|
* On 64-bit architectures we need to mask off the upper bits to |
3901 |
|
* ensure we only have a 32-bit range. The constant has the |
3902 |
|
* bizarre form below in order to make sure that it doesn't |
3903 |
|
* get sign-extended (the rules for sign extension are very |
3904 |
|
* concat, particularly on 64-bit machines). |
3905 |
|
*/ |
3906 |
|
|
3907 |
|
iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf); |
3908 |
|
dResult = iPtr->randSeed * (1.0/RAND_IM); |
3909 |
|
|
3910 |
|
/* |
3911 |
|
* Push a Tcl object with the result. |
3912 |
|
*/ |
3913 |
|
|
3914 |
|
PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); |
3915 |
|
|
3916 |
|
/* |
3917 |
|
* Reflect the change to stackTop back in eePtr. |
3918 |
|
*/ |
3919 |
|
|
3920 |
|
DECACHE_STACK_INFO(); |
3921 |
|
return TCL_OK; |
3922 |
|
} |
3923 |
|
|
3924 |
|
static int |
3925 |
|
ExprRoundFunc(interp, eePtr, clientData) |
3926 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
3927 |
|
* function. */ |
3928 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
3929 |
|
* the function. */ |
3930 |
|
ClientData clientData; /* Ignored. */ |
3931 |
|
{ |
3932 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
3933 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
3934 |
|
Tcl_Obj *valuePtr; |
3935 |
|
long iResult; |
3936 |
|
double d, temp; |
3937 |
|
int result; |
3938 |
|
|
3939 |
|
/* |
3940 |
|
* Set stackPtr and stackTop from eePtr. |
3941 |
|
*/ |
3942 |
|
|
3943 |
|
result = TCL_OK; |
3944 |
|
CACHE_STACK_INFO(); |
3945 |
|
|
3946 |
|
/* |
3947 |
|
* Pop the argument from the evaluation stack. |
3948 |
|
*/ |
3949 |
|
|
3950 |
|
valuePtr = POP_OBJECT(); |
3951 |
|
|
3952 |
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
3953 |
|
result = TCL_ERROR; |
3954 |
|
goto done; |
3955 |
|
} |
3956 |
|
|
3957 |
|
if (valuePtr->typePtr == &tclIntType) { |
3958 |
|
iResult = valuePtr->internalRep.longValue; |
3959 |
|
} else { |
3960 |
|
d = valuePtr->internalRep.doubleValue; |
3961 |
|
if (d < 0.0) { |
3962 |
|
if (d <= (((double) (long) LONG_MIN) - 0.5)) { |
3963 |
|
tooLarge: |
3964 |
|
Tcl_ResetResult(interp); |
3965 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), |
3966 |
|
"integer value too large to represent", -1); |
3967 |
|
Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", |
3968 |
|
"integer value too large to represent", |
3969 |
|
(char *) NULL); |
3970 |
|
result = TCL_ERROR; |
3971 |
|
goto done; |
3972 |
|
} |
3973 |
|
temp = (long) (d - 0.5); |
3974 |
|
} else { |
3975 |
|
if (d >= (((double) LONG_MAX + 0.5))) { |
3976 |
|
goto tooLarge; |
3977 |
|
} |
3978 |
|
temp = (long) (d + 0.5); |
3979 |
|
} |
3980 |
|
if (IS_NAN(temp) || IS_INF(temp)) { |
3981 |
|
TclExprFloatError(interp, temp); |
3982 |
|
result = TCL_ERROR; |
3983 |
|
goto done; |
3984 |
|
} |
3985 |
|
iResult = (long) temp; |
3986 |
|
} |
3987 |
|
|
3988 |
|
/* |
3989 |
|
* Push a Tcl object with the result. |
3990 |
|
*/ |
3991 |
|
|
3992 |
|
PUSH_OBJECT(Tcl_NewLongObj(iResult)); |
3993 |
|
|
3994 |
|
/* |
3995 |
|
* Reflect the change to stackTop back in eePtr. |
3996 |
|
*/ |
3997 |
|
|
3998 |
|
done: |
3999 |
|
Tcl_DecrRefCount(valuePtr); |
4000 |
|
DECACHE_STACK_INFO(); |
4001 |
|
return result; |
4002 |
|
} |
4003 |
|
|
4004 |
|
static int |
4005 |
|
ExprSrandFunc(interp, eePtr, clientData) |
4006 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
4007 |
|
* function. */ |
4008 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
4009 |
|
* the function. */ |
4010 |
|
ClientData clientData; /* Ignored. */ |
4011 |
|
{ |
4012 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
4013 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
4014 |
|
Interp *iPtr = (Interp *) interp; |
4015 |
|
Tcl_Obj *valuePtr; |
4016 |
|
long i = 0; /* Initialized to avoid compiler warning. */ |
4017 |
|
int result; |
4018 |
|
|
4019 |
|
/* |
4020 |
|
* Set stackPtr and stackTop from eePtr. |
4021 |
|
*/ |
4022 |
|
|
4023 |
|
CACHE_STACK_INFO(); |
4024 |
|
|
4025 |
|
/* |
4026 |
|
* Pop the argument from the evaluation stack. Use the value |
4027 |
|
* to reset the random number seed. |
4028 |
|
*/ |
4029 |
|
|
4030 |
|
valuePtr = POP_OBJECT(); |
4031 |
|
|
4032 |
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
4033 |
|
result = TCL_ERROR; |
4034 |
|
goto badValue; |
4035 |
|
} |
4036 |
|
|
4037 |
|
if (valuePtr->typePtr == &tclIntType) { |
4038 |
|
i = valuePtr->internalRep.longValue; |
4039 |
|
} else { |
4040 |
|
/* |
4041 |
|
* At this point, the only other possible type is double |
4042 |
|
*/ |
4043 |
|
Tcl_ResetResult(interp); |
4044 |
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
4045 |
|
"can't use floating-point value as argument to srand", |
4046 |
|
(char *) NULL); |
4047 |
|
badValue: |
4048 |
|
Tcl_DecrRefCount(valuePtr); |
4049 |
|
DECACHE_STACK_INFO(); |
4050 |
|
return TCL_ERROR; |
4051 |
|
} |
4052 |
|
|
4053 |
|
/* |
4054 |
|
* Reset the seed. |
4055 |
|
*/ |
4056 |
|
|
4057 |
|
iPtr->flags |= RAND_SEED_INITIALIZED; |
4058 |
|
iPtr->randSeed = i; |
4059 |
|
|
4060 |
|
/* |
4061 |
|
* To avoid duplicating the random number generation code we simply |
4062 |
|
* clean up our state and call the real random number function. That |
4063 |
|
* function will always succeed. |
4064 |
|
*/ |
4065 |
|
|
4066 |
|
Tcl_DecrRefCount(valuePtr); |
4067 |
|
DECACHE_STACK_INFO(); |
4068 |
|
|
4069 |
|
ExprRandFunc(interp, eePtr, clientData); |
4070 |
|
return TCL_OK; |
4071 |
|
} |
4072 |
|
|
4073 |
|
/* |
4074 |
|
*---------------------------------------------------------------------- |
4075 |
|
* |
4076 |
|
* ExprCallMathFunc -- |
4077 |
|
* |
4078 |
|
* This procedure is invoked to call a non-builtin math function |
4079 |
|
* during the execution of an expression. |
4080 |
|
* |
4081 |
|
* Results: |
4082 |
|
* TCL_OK is returned if all went well and the function's value |
4083 |
|
* was computed successfully. If an error occurred, TCL_ERROR |
4084 |
|
* is returned and an error message is left in the interpreter's |
4085 |
|
* result. After a successful return this procedure pushes a Tcl object |
4086 |
|
* holding the result. |
4087 |
|
* |
4088 |
|
* Side effects: |
4089 |
|
* None, unless the called math function has side effects. |
4090 |
|
* |
4091 |
|
*---------------------------------------------------------------------- |
4092 |
|
*/ |
4093 |
|
|
4094 |
|
static int |
4095 |
|
ExprCallMathFunc(interp, eePtr, objc, objv) |
4096 |
|
Tcl_Interp *interp; /* The interpreter in which to execute the |
4097 |
|
* function. */ |
4098 |
|
ExecEnv *eePtr; /* Points to the environment for executing |
4099 |
|
* the function. */ |
4100 |
|
int objc; /* Number of arguments. The function name is |
4101 |
|
* the 0-th argument. */ |
4102 |
|
Tcl_Obj **objv; /* The array of arguments. The function name |
4103 |
|
* is objv[0]. */ |
4104 |
|
{ |
4105 |
|
Interp *iPtr = (Interp *) interp; |
4106 |
|
Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ |
4107 |
|
register int stackTop; /* Cached top index of evaluation stack. */ |
4108 |
|
char *funcName; |
4109 |
|
Tcl_HashEntry *hPtr; |
4110 |
|
MathFunc *mathFuncPtr; /* Information about math function. */ |
4111 |
|
Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ |
4112 |
|
Tcl_Value funcResult; /* Result of function call as Tcl_Value. */ |
4113 |
|
register Tcl_Obj *valuePtr; |
4114 |
|
long i; |
4115 |
|
double d; |
4116 |
|
int j, k, result; |
4117 |
|
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
4118 |
|
|
4119 |
|
Tcl_ResetResult(interp); |
4120 |
|
|
4121 |
|
/* |
4122 |
|
* Set stackPtr and stackTop from eePtr. |
4123 |
|
*/ |
4124 |
|
|
4125 |
|
CACHE_STACK_INFO(); |
4126 |
|
|
4127 |
|
/* |
4128 |
|
* Look up the MathFunc record for the function. |
4129 |
|
*/ |
4130 |
|
|
4131 |
|
funcName = Tcl_GetString(objv[0]); |
4132 |
|
hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); |
4133 |
|
if (hPtr == NULL) { |
4134 |
|
Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), |
4135 |
|
"unknown math function \"", funcName, "\"", (char *) NULL); |
4136 |
|
result = TCL_ERROR; |
4137 |
|
goto done; |
4138 |
|
} |
4139 |
|
mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); |
4140 |
|
if (mathFuncPtr->numArgs != (objc-1)) { |
4141 |
|
panic("ExprCallMathFunc: expected number of args %d != actual number %d", |
4142 |
|
mathFuncPtr->numArgs, objc); |
4143 |
|
result = TCL_ERROR; |
4144 |
|
goto done; |
4145 |
|
} |
4146 |
|
|
4147 |
|
/* |
4148 |
|
* Collect the arguments for the function, if there are any, into the |
4149 |
|
* array "args". Note that args[0] will have the Tcl_Value that |
4150 |
|
* corresponds to objv[1]. |
4151 |
|
*/ |
4152 |
|
|
4153 |
|
for (j = 1, k = 0; j < objc; j++, k++) { |
4154 |
|
valuePtr = objv[j]; |
4155 |
|
|
4156 |
|
if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { |
4157 |
|
result = TCL_ERROR; |
4158 |
|
goto done; |
4159 |
|
} |
4160 |
|
|
4161 |
|
/* |
4162 |
|
* Copy the object's numeric value to the argument record, |
4163 |
|
* converting it if necessary. |
4164 |
|
*/ |
4165 |
|
|
4166 |
|
if (valuePtr->typePtr == &tclIntType) { |
4167 |
|
i = valuePtr->internalRep.longValue; |
4168 |
|
if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { |
4169 |
|
args[k].type = TCL_DOUBLE; |
4170 |
|
args[k].doubleValue = i; |
4171 |
|
} else { |
4172 |
|
args[k].type = TCL_INT; |
4173 |
|
args[k].intValue = i; |
4174 |
|
} |
4175 |
|
} else { |
4176 |
|
d = valuePtr->internalRep.doubleValue; |
4177 |
|
if (mathFuncPtr->argTypes[k] == TCL_INT) { |
4178 |
|
args[k].type = TCL_INT; |
4179 |
|
args[k].intValue = (long) d; |
4180 |
|
} else { |
4181 |
|
args[k].type = TCL_DOUBLE; |
4182 |
|
args[k].doubleValue = d; |
4183 |
|
} |
4184 |
|
} |
4185 |
|
} |
4186 |
|
|
4187 |
|
/* |
4188 |
|
* Invoke the function and copy its result back into valuePtr. |
4189 |
|
*/ |
4190 |
|
|
4191 |
|
tsdPtr->mathInProgress++; |
4192 |
|
result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, |
4193 |
|
&funcResult); |
4194 |
|
tsdPtr->mathInProgress--; |
4195 |
|
if (result != TCL_OK) { |
4196 |
|
goto done; |
4197 |
|
} |
4198 |
|
|
4199 |
|
/* |
4200 |
|
* Pop the objc top stack elements and decrement their ref counts. |
4201 |
|
*/ |
4202 |
|
|
4203 |
|
i = (stackTop - (objc-1)); |
4204 |
|
while (i <= stackTop) { |
4205 |
|
valuePtr = stackPtr[i]; |
4206 |
|
Tcl_DecrRefCount(valuePtr); |
4207 |
|
i++; |
4208 |
|
} |
4209 |
|
stackTop -= objc; |
4210 |
|
|
4211 |
|
/* |
4212 |
|
* Push the call's object result. |
4213 |
|
*/ |
4214 |
|
|
4215 |
|
if (funcResult.type == TCL_INT) { |
4216 |
|
PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue)); |
4217 |
|
} else { |
4218 |
|
d = funcResult.doubleValue; |
4219 |
|
if (IS_NAN(d) || IS_INF(d)) { |
4220 |
|
TclExprFloatError(interp, d); |
4221 |
|
result = TCL_ERROR; |
4222 |
|
goto done; |
4223 |
|
} |
4224 |
|
PUSH_OBJECT(Tcl_NewDoubleObj(d)); |
4225 |
|
} |
4226 |
|
|
4227 |
|
/* |
4228 |
|
* Reflect the change to stackTop back in eePtr. |
4229 |
|
*/ |
4230 |
|
|
4231 |
|
done: |
4232 |
|
DECACHE_STACK_INFO(); |
4233 |
|
return result; |
4234 |
|
} |
4235 |
|
|
4236 |
|
/* |
4237 |
|
*---------------------------------------------------------------------- |
4238 |
|
* |
4239 |
|
* TclExprFloatError -- |
4240 |
|
* |
4241 |
|
* This procedure is called when an error occurs during a |
4242 |
|
* floating-point operation. It reads errno and sets |
4243 |
|
* interp->objResultPtr accordingly. |
4244 |
|
* |
4245 |
|
* Results: |
4246 |
|
* interp->objResultPtr is set to hold an error message. |
4247 |
|
* |
4248 |
|
* Side effects: |
4249 |
|
* None. |
4250 |
|
* |
4251 |
|
*---------------------------------------------------------------------- |
4252 |
|
*/ |
4253 |
|
|
4254 |
|
void |
4255 |
|
TclExprFloatError(interp, value) |
4256 |
|
Tcl_Interp *interp; /* Where to store error message. */ |
4257 |
|
double value; /* Value returned after error; used to |
4258 |
|
* distinguish underflows from overflows. */ |
4259 |
|
{ |
4260 |
|
char *s; |
4261 |
|
|
4262 |
|
Tcl_ResetResult(interp); |
4263 |
|
if ((errno == EDOM) || (value != value)) { |
4264 |
|
s = "domain error: argument not in valid range"; |
4265 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
4266 |
|
Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); |
4267 |
|
} else if ((errno == ERANGE) || IS_INF(value)) { |
4268 |
|
if (value == 0.0) { |
4269 |
|
s = "floating-point value too small to represent"; |
4270 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
4271 |
|
Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); |
4272 |
|
} else { |
4273 |
|
s = "floating-point value too large to represent"; |
4274 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); |
4275 |
|
Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); |
4276 |
|
} |
4277 |
|
} else { |
4278 |
|
char msg[64 + TCL_INTEGER_SPACE]; |
4279 |
|
|
4280 |
|
sprintf(msg, "unknown floating-point error, errno = %d", errno); |
4281 |
|
Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); |
4282 |
|
Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); |
4283 |
|
} |
4284 |
|
} |
4285 |
|
|
4286 |
|
/* |
4287 |
|
*---------------------------------------------------------------------- |
4288 |
|
* |
4289 |
|
* TclMathInProgress -- |
4290 |
|
* |
4291 |
|
* This procedure is called to find out if Tcl is doing math |
4292 |
|
* in this thread. |
4293 |
|
* |
4294 |
|
* Results: |
4295 |
|
* 0 or 1. |
4296 |
|
* |
4297 |
|
* Side effects: |
4298 |
|
* None. |
4299 |
|
* |
4300 |
|
*---------------------------------------------------------------------- |
4301 |
|
*/ |
4302 |
|
|
4303 |
|
int |
4304 |
|
TclMathInProgress() |
4305 |
|
{ |
4306 |
|
ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey); |
4307 |
|
return tsdPtr->mathInProgress; |
4308 |
|
} |
4309 |
|
|
4310 |
|
#ifdef TCL_COMPILE_STATS |
4311 |
|
/* |
4312 |
|
*---------------------------------------------------------------------- |
4313 |
|
* |
4314 |
|
* TclLog2 -- |
4315 |
|
* |
4316 |
|
* Procedure used while collecting compilation statistics to determine |
4317 |
|
* the log base 2 of an integer. |
4318 |
|
* |
4319 |
|
* Results: |
4320 |
|
* Returns the log base 2 of the operand. If the argument is less |
4321 |
|
* than or equal to zero, a zero is returned. |
4322 |
|
* |
4323 |
|
* Side effects: |
4324 |
|
* None. |
4325 |
|
* |
4326 |
|
*---------------------------------------------------------------------- |
4327 |
|
*/ |
4328 |
|
|
4329 |
|
int |
4330 |
|
TclLog2(value) |
4331 |
|
register int value; /* The integer for which to compute the |
4332 |
|
* log base 2. */ |
4333 |
|
{ |
4334 |
|
register int n = value; |
4335 |
|
register int result = 0; |
4336 |
|
|
4337 |
|
while (n > 1) { |
4338 |
|
n = n >> 1; |
4339 |
|
result++; |
4340 |
|
} |
4341 |
|
return result; |
4342 |
|
} |
4343 |
|
|
4344 |
|
/* |
4345 |
|
*---------------------------------------------------------------------- |
4346 |
|
* |
4347 |
|
* EvalStatsCmd -- |
4348 |
|
* |
4349 |
|
* Implements the "evalstats" command that prints instruction execution |
4350 |
|
* counts to stdout. |
4351 |
|
* |
4352 |
|
* Results: |
4353 |
|
* Standard Tcl results. |
4354 |
|
* |
4355 |
|
* Side effects: |
4356 |
|
* None. |
4357 |
|
* |
4358 |
|
*---------------------------------------------------------------------- |
4359 |
|
*/ |
4360 |
|
|
4361 |
|
static int |
4362 |
|
EvalStatsCmd(unused, interp, argc, argv) |
4363 |
|
ClientData unused; /* Unused. */ |
4364 |
|
Tcl_Interp *interp; /* The current interpreter. */ |
4365 |
|
int argc; /* The number of arguments. */ |
4366 |
|
char **argv; /* The argument strings. */ |
4367 |
|
{ |
4368 |
|
Interp *iPtr = (Interp *) interp; |
4369 |
|
LiteralTable *globalTablePtr = &(iPtr->literalTable); |
4370 |
|
ByteCodeStats *statsPtr = &(iPtr->stats); |
4371 |
|
double totalCodeBytes, currentCodeBytes; |
4372 |
|
double totalLiteralBytes, currentLiteralBytes; |
4373 |
|
double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; |
4374 |
|
double strBytesSharedMultX, strBytesSharedOnce; |
4375 |
|
double numInstructions, currentHeaderBytes; |
4376 |
|
long numCurrentByteCodes, numByteCodeLits; |
4377 |
|
long refCountSum, literalMgmtBytes, sum; |
4378 |
|
int numSharedMultX, numSharedOnce; |
4379 |
|
int decadeHigh, minSizeDecade, maxSizeDecade, length, i; |
4380 |
|
char *litTableStats; |
4381 |
|
LiteralEntry *entryPtr; |
4382 |
|
|
4383 |
|
numInstructions = 0.0; |
4384 |
|
for (i = 0; i < 256; i++) { |
4385 |
|
if (statsPtr->instructionCount[i] != 0) { |
4386 |
|
numInstructions += statsPtr->instructionCount[i]; |
4387 |
|
} |
4388 |
|
} |
4389 |
|
|
4390 |
|
totalLiteralBytes = sizeof(LiteralTable) |
4391 |
|
+ iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) |
4392 |
|
+ (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) |
4393 |
|
+ (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) |
4394 |
|
+ statsPtr->totalLitStringBytes; |
4395 |
|
totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; |
4396 |
|
|
4397 |
|
numCurrentByteCodes = |
4398 |
|
statsPtr->numCompilations - statsPtr->numByteCodesFreed; |
4399 |
|
currentHeaderBytes = numCurrentByteCodes |
4400 |
|
* (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); |
4401 |
|
literalMgmtBytes = sizeof(LiteralTable) |
4402 |
|
+ (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) |
4403 |
|
+ (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); |
4404 |
|
currentLiteralBytes = literalMgmtBytes |
4405 |
|
+ iPtr->literalTable.numEntries * sizeof(Tcl_Obj) |
4406 |
|
+ statsPtr->currentLitStringBytes; |
4407 |
|
currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; |
4408 |
|
|
4409 |
|
/* |
4410 |
|
* Summary statistics, total and current source and ByteCode sizes. |
4411 |
|
*/ |
4412 |
|
|
4413 |
|
fprintf(stdout, "\n----------------------------------------------------------------\n"); |
4414 |
|
fprintf(stdout, |
4415 |
|
"Compilation and execution statistics for interpreter 0x%x\n", |
4416 |
|
(unsigned int) iPtr); |
4417 |
|
|
4418 |
|
fprintf(stdout, "\nNumber ByteCodes executed %ld\n", |
4419 |
|
statsPtr->numExecutions); |
4420 |
|
fprintf(stdout, "Number ByteCodes compiled %ld\n", |
4421 |
|
statsPtr->numCompilations); |
4422 |
|
fprintf(stdout, " Mean executions/compile %.1f\n", |
4423 |
|
((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); |
4424 |
|
|
4425 |
|
fprintf(stdout, "\nInstructions executed %.0f\n", |
4426 |
|
numInstructions); |
4427 |
|
fprintf(stdout, " Mean inst/compile %.0f\n", |
4428 |
|
numInstructions / statsPtr->numCompilations); |
4429 |
|
fprintf(stdout, " Mean inst/execution %.0f\n", |
4430 |
|
numInstructions / statsPtr->numExecutions); |
4431 |
|
|
4432 |
|
fprintf(stdout, "\nTotal ByteCodes %ld\n", |
4433 |
|
statsPtr->numCompilations); |
4434 |
|
fprintf(stdout, " Source bytes %.6g\n", |
4435 |
|
statsPtr->totalSrcBytes); |
4436 |
|
fprintf(stdout, " Code bytes %.6g\n", |
4437 |
|
totalCodeBytes); |
4438 |
|
fprintf(stdout, " ByteCode bytes %.6g\n", |
4439 |
|
statsPtr->totalByteCodeBytes); |
4440 |
|
fprintf(stdout, " Literal bytes %.6g\n", |
4441 |
|
totalLiteralBytes); |
4442 |
|
fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n", |
4443 |
|
sizeof(LiteralTable), |
4444 |
|
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
4445 |
|
statsPtr->numLiteralsCreated * sizeof(LiteralEntry), |
4446 |
|
statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), |
4447 |
|
statsPtr->totalLitStringBytes); |
4448 |
|
fprintf(stdout, " Mean code/compile %.1f\n", |
4449 |
|
totalCodeBytes / statsPtr->numCompilations); |
4450 |
|
fprintf(stdout, " Mean code/source %.1f\n", |
4451 |
|
totalCodeBytes / statsPtr->totalSrcBytes); |
4452 |
|
|
4453 |
|
fprintf(stdout, "\nCurrent ByteCodes %ld\n", |
4454 |
|
numCurrentByteCodes); |
4455 |
|
fprintf(stdout, " Source bytes %.6g\n", |
4456 |
|
statsPtr->currentSrcBytes); |
4457 |
|
fprintf(stdout, " Code bytes %.6g\n", |
4458 |
|
currentCodeBytes); |
4459 |
|
fprintf(stdout, " ByteCode bytes %.6g\n", |
4460 |
|
statsPtr->currentByteCodeBytes); |
4461 |
|
fprintf(stdout, " Literal bytes %.6g\n", |
4462 |
|
currentLiteralBytes); |
4463 |
|
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", |
4464 |
|
sizeof(LiteralTable), |
4465 |
|
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
4466 |
|
iPtr->literalTable.numEntries * sizeof(LiteralEntry), |
4467 |
|
iPtr->literalTable.numEntries * sizeof(Tcl_Obj), |
4468 |
|
statsPtr->currentLitStringBytes); |
4469 |
|
fprintf(stdout, " Mean code/source %.1f\n", |
4470 |
|
currentCodeBytes / statsPtr->currentSrcBytes); |
4471 |
|
fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", |
4472 |
|
(currentCodeBytes + statsPtr->currentSrcBytes), |
4473 |
|
(currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); |
4474 |
|
|
4475 |
|
/* |
4476 |
|
* Literal table statistics. |
4477 |
|
*/ |
4478 |
|
|
4479 |
|
numByteCodeLits = 0; |
4480 |
|
refCountSum = 0; |
4481 |
|
numSharedMultX = 0; |
4482 |
|
numSharedOnce = 0; |
4483 |
|
objBytesIfUnshared = 0.0; |
4484 |
|
strBytesIfUnshared = 0.0; |
4485 |
|
strBytesSharedMultX = 0.0; |
4486 |
|
strBytesSharedOnce = 0.0; |
4487 |
|
for (i = 0; i < globalTablePtr->numBuckets; i++) { |
4488 |
|
for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; |
4489 |
|
entryPtr = entryPtr->nextPtr) { |
4490 |
|
if (entryPtr->objPtr->typePtr == &tclByteCodeType) { |
4491 |
|
numByteCodeLits++; |
4492 |
|
} |
4493 |
|
(void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); |
4494 |
|
refCountSum += entryPtr->refCount; |
4495 |
|
objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); |
4496 |
|
strBytesIfUnshared += (entryPtr->refCount * (length+1)); |
4497 |
|
if (entryPtr->refCount > 1) { |
4498 |
|
numSharedMultX++; |
4499 |
|
strBytesSharedMultX += (length+1); |
4500 |
|
} else { |
4501 |
|
numSharedOnce++; |
4502 |
|
strBytesSharedOnce += (length+1); |
4503 |
|
} |
4504 |
|
} |
4505 |
|
} |
4506 |
|
sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) |
4507 |
|
- currentLiteralBytes; |
4508 |
|
|
4509 |
|
fprintf(stdout, "\nTotal objects (all interps) %ld\n", |
4510 |
|
tclObjsAlloced); |
4511 |
|
fprintf(stdout, "Current objects %ld\n", |
4512 |
|
(tclObjsAlloced - tclObjsFreed)); |
4513 |
|
fprintf(stdout, "Total literal objects %ld\n", |
4514 |
|
statsPtr->numLiteralsCreated); |
4515 |
|
|
4516 |
|
fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", |
4517 |
|
globalTablePtr->numEntries, |
4518 |
|
(globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); |
4519 |
|
fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", |
4520 |
|
numByteCodeLits, |
4521 |
|
(numByteCodeLits * 100.0) / globalTablePtr->numEntries); |
4522 |
|
fprintf(stdout, " Literals reused > 1x %d\n", |
4523 |
|
numSharedMultX); |
4524 |
|
fprintf(stdout, " Mean reference count %.2f\n", |
4525 |
|
((double) refCountSum) / globalTablePtr->numEntries); |
4526 |
|
fprintf(stdout, " Mean len, str reused >1x %.2f\n", |
4527 |
|
(numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0)); |
4528 |
|
fprintf(stdout, " Mean len, str used 1x %.2f\n", |
4529 |
|
(numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0)); |
4530 |
|
fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", |
4531 |
|
sharingBytesSaved, |
4532 |
|
(sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared)); |
4533 |
|
fprintf(stdout, " Bytes with sharing %.6g\n", |
4534 |
|
currentLiteralBytes); |
4535 |
|
fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", |
4536 |
|
sizeof(LiteralTable), |
4537 |
|
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
4538 |
|
iPtr->literalTable.numEntries * sizeof(LiteralEntry), |
4539 |
|
iPtr->literalTable.numEntries * sizeof(Tcl_Obj), |
4540 |
|
statsPtr->currentLitStringBytes); |
4541 |
|
fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", |
4542 |
|
(objBytesIfUnshared + strBytesIfUnshared), |
4543 |
|
objBytesIfUnshared, strBytesIfUnshared); |
4544 |
|
fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", |
4545 |
|
(strBytesIfUnshared - statsPtr->currentLitStringBytes), |
4546 |
|
strBytesIfUnshared, statsPtr->currentLitStringBytes); |
4547 |
|
fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", |
4548 |
|
literalMgmtBytes, |
4549 |
|
(literalMgmtBytes * 100.0) / currentLiteralBytes); |
4550 |
|
fprintf(stdout, " table %d + buckets %d + entries %d\n", |
4551 |
|
sizeof(LiteralTable), |
4552 |
|
iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), |
4553 |
|
iPtr->literalTable.numEntries * sizeof(LiteralEntry)); |
4554 |
|
|
4555 |
|
/* |
4556 |
|
* Breakdown of current ByteCode space requirements. |
4557 |
|
*/ |
4558 |
|
|
4559 |
|
fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); |
4560 |
|
fprintf(stdout, " Bytes Pct of Avg per\n"); |
4561 |
|
fprintf(stdout, " total ByteCode\n"); |
4562 |
|
fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", |
4563 |
|
statsPtr->currentByteCodeBytes, |
4564 |
|
statsPtr->currentByteCodeBytes / numCurrentByteCodes); |
4565 |
|
fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", |
4566 |
|
currentHeaderBytes, |
4567 |
|
((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4568 |
|
currentHeaderBytes / numCurrentByteCodes); |
4569 |
|
fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", |
4570 |
|
statsPtr->currentInstBytes, |
4571 |
|
((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4572 |
|
statsPtr->currentInstBytes / numCurrentByteCodes); |
4573 |
|
fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", |
4574 |
|
statsPtr->currentLitBytes, |
4575 |
|
((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4576 |
|
statsPtr->currentLitBytes / numCurrentByteCodes); |
4577 |
|
fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", |
4578 |
|
statsPtr->currentExceptBytes, |
4579 |
|
((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4580 |
|
statsPtr->currentExceptBytes / numCurrentByteCodes); |
4581 |
|
fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", |
4582 |
|
statsPtr->currentAuxBytes, |
4583 |
|
((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4584 |
|
statsPtr->currentAuxBytes / numCurrentByteCodes); |
4585 |
|
fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", |
4586 |
|
statsPtr->currentCmdMapBytes, |
4587 |
|
((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), |
4588 |
|
statsPtr->currentCmdMapBytes / numCurrentByteCodes); |
4589 |
|
|
4590 |
|
/* |
4591 |
|
* Detailed literal statistics. |
4592 |
|
*/ |
4593 |
|
|
4594 |
|
fprintf(stdout, "\nLiteral string sizes:\n"); |
4595 |
|
fprintf(stdout, " Up to length Percentage\n"); |
4596 |
|
maxSizeDecade = 0; |
4597 |
|
for (i = 31; i >= 0; i--) { |
4598 |
|
if (statsPtr->literalCount[i] > 0) { |
4599 |
|
maxSizeDecade = i; |
4600 |
|
break; |
4601 |
|
} |
4602 |
|
} |
4603 |
|
sum = 0; |
4604 |
|
for (i = 0; i <= maxSizeDecade; i++) { |
4605 |
|
decadeHigh = (1 << (i+1)) - 1; |
4606 |
|
sum += statsPtr->literalCount[i]; |
4607 |
|
fprintf(stdout, " %10d %8.0f%%\n", |
4608 |
|
decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); |
4609 |
|
} |
4610 |
|
|
4611 |
|
litTableStats = TclLiteralStats(globalTablePtr); |
4612 |
|
fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", |
4613 |
|
litTableStats); |
4614 |
|
ckfree((char *) litTableStats); |
4615 |
|
|
4616 |
|
/* |
4617 |
|
* Source and ByteCode size distributions. |
4618 |
|
*/ |
4619 |
|
|
4620 |
|
fprintf(stdout, "\nSource sizes:\n"); |
4621 |
|
fprintf(stdout, " Up to size Percentage\n"); |
4622 |
|
minSizeDecade = maxSizeDecade = 0; |
4623 |
|
for (i = 0; i < 31; i++) { |
4624 |
|
if (statsPtr->srcCount[i] > 0) { |
4625 |
|
minSizeDecade = i; |
4626 |
|
break; |
4627 |
|
} |
4628 |
|
} |
4629 |
|
for (i = 31; i >= 0; i--) { |
4630 |
|
if (statsPtr->srcCount[i] > 0) { |
4631 |
|
maxSizeDecade = i; |
4632 |
|
break; |
4633 |
|
} |
4634 |
|
} |
4635 |
|
sum = 0; |
4636 |
|
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
4637 |
|
decadeHigh = (1 << (i+1)) - 1; |
4638 |
|
sum += statsPtr->srcCount[i]; |
4639 |
|
fprintf(stdout, " %10d %8.0f%%\n", |
4640 |
|
decadeHigh, (sum * 100.0) / statsPtr->numCompilations); |
4641 |
|
} |
4642 |
|
|
4643 |
|
fprintf(stdout, "\nByteCode sizes:\n"); |
4644 |
|
fprintf(stdout, " Up to size Percentage\n"); |
4645 |
|
minSizeDecade = maxSizeDecade = 0; |
4646 |
|
for (i = 0; i < 31; i++) { |
4647 |
|
if (statsPtr->byteCodeCount[i] > 0) { |
4648 |
|
minSizeDecade = i; |
4649 |
|
break; |
4650 |
|
} |
4651 |
|
} |
4652 |
|
for (i = 31; i >= 0; i--) { |
4653 |
|
if (statsPtr->byteCodeCount[i] > 0) { |
4654 |
|
maxSizeDecade = i; |
4655 |
|
break; |
4656 |
|
} |
4657 |
|
} |
4658 |
|
sum = 0; |
4659 |
|
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
4660 |
|
decadeHigh = (1 << (i+1)) - 1; |
4661 |
|
sum += statsPtr->byteCodeCount[i]; |
4662 |
|
fprintf(stdout, " %10d %8.0f%%\n", |
4663 |
|
decadeHigh, (sum * 100.0) / statsPtr->numCompilations); |
4664 |
|
} |
4665 |
|
|
4666 |
|
fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n"); |
4667 |
|
fprintf(stdout, " Up to ms Percentage\n"); |
4668 |
|
minSizeDecade = maxSizeDecade = 0; |
4669 |
|
for (i = 0; i < 31; i++) { |
4670 |
|
if (statsPtr->lifetimeCount[i] > 0) { |
4671 |
|
minSizeDecade = i; |
4672 |
|
break; |
4673 |
|
} |
4674 |
|
} |
4675 |
|
for (i = 31; i >= 0; i--) { |
4676 |
|
if (statsPtr->lifetimeCount[i] > 0) { |
4677 |
|
maxSizeDecade = i; |
4678 |
|
break; |
4679 |
|
} |
4680 |
|
} |
4681 |
|
sum = 0; |
4682 |
|
for (i = minSizeDecade; i <= maxSizeDecade; i++) { |
4683 |
|
decadeHigh = (1 << (i+1)) - 1; |
4684 |
|
sum += statsPtr->lifetimeCount[i]; |
4685 |
|
fprintf(stdout, " %12.3f %8.0f%%\n", |
4686 |
|
decadeHigh / 1000.0, |
4687 |
|
(sum * 100.0) / statsPtr->numByteCodesFreed); |
4688 |
|
} |
4689 |
|
|
4690 |
|
/* |
4691 |
|
* Instruction counts. |
4692 |
|
*/ |
4693 |
|
|
4694 |
|
fprintf(stdout, "\nInstruction counts:\n"); |
4695 |
|
for (i = 0; i <= LAST_INST_OPCODE; i++) { |
4696 |
|
if (statsPtr->instructionCount[i]) { |
4697 |
|
fprintf(stdout, "%20s %8ld %6.1f%%\n", |
4698 |
|
instructionTable[i].name, |
4699 |
|
statsPtr->instructionCount[i], |
4700 |
|
(statsPtr->instructionCount[i]*100.0) / numInstructions); |
4701 |
|
} |
4702 |
|
} |
4703 |
|
|
4704 |
|
fprintf(stdout, "\nInstructions NEVER executed:\n"); |
4705 |
|
for (i = 0; i <= LAST_INST_OPCODE; i++) { |
4706 |
|
if (statsPtr->instructionCount[i] == 0) { |
4707 |
|
fprintf(stdout, "%20s\n", |
4708 |
|
instructionTable[i].name); |
4709 |
|
} |
4710 |
|
} |
4711 |
|
|
4712 |
|
#ifdef TCL_MEM_DEBUG |
4713 |
|
fprintf(stdout, "\nHeap Statistics:\n"); |
4714 |
|
TclDumpMemoryInfo(stdout); |
4715 |
|
#endif |
4716 |
|
fprintf(stdout, "\n----------------------------------------------------------------\n"); |
4717 |
|
return TCL_OK; |
4718 |
|
} |
4719 |
|
#endif /* TCL_COMPILE_STATS */ |
4720 |
|
|
4721 |
|
/* |
4722 |
|
*---------------------------------------------------------------------- |
4723 |
|
* |
4724 |
|
* Tcl_GetCommandFromObj -- |
4725 |
|
* |
4726 |
|
* Returns the command specified by the name in a Tcl_Obj. |
4727 |
|
* |
4728 |
|
* Results: |
4729 |
|
* Returns a token for the command if it is found. Otherwise, if it |
4730 |
|
* can't be found or there is an error, returns NULL. |
4731 |
|
* |
4732 |
|
* Side effects: |
4733 |
|
* May update the internal representation for the object, caching |
4734 |
|
* the command reference so that the next time this procedure is |
4735 |
|
* called with the same object, the command can be found quickly. |
4736 |
|
* |
4737 |
|
*---------------------------------------------------------------------- |
4738 |
|
*/ |
4739 |
|
|
4740 |
|
Tcl_Command |
4741 |
|
Tcl_GetCommandFromObj(interp, objPtr) |
4742 |
|
Tcl_Interp *interp; /* The interpreter in which to resolve the |
4743 |
|
* command and to report errors. */ |
4744 |
|
register Tcl_Obj *objPtr; /* The object containing the command's |
4745 |
|
* name. If the name starts with "::", will |
4746 |
|
* be looked up in global namespace. Else, |
4747 |
|
* looked up first in the current namespace |
4748 |
|
* if contextNsPtr is NULL, then in global |
4749 |
|
* namespace. */ |
4750 |
|
{ |
4751 |
|
Interp *iPtr = (Interp *) interp; |
4752 |
|
register ResolvedCmdName *resPtr; |
4753 |
|
register Command *cmdPtr; |
4754 |
|
Namespace *currNsPtr; |
4755 |
|
int result; |
4756 |
|
|
4757 |
|
/* |
4758 |
|
* Get the internal representation, converting to a command type if |
4759 |
|
* needed. The internal representation is a ResolvedCmdName that points |
4760 |
|
* to the actual command. |
4761 |
|
*/ |
4762 |
|
|
4763 |
|
if (objPtr->typePtr != &tclCmdNameType) { |
4764 |
|
result = tclCmdNameType.setFromAnyProc(interp, objPtr); |
4765 |
|
if (result != TCL_OK) { |
4766 |
|
return (Tcl_Command) NULL; |
4767 |
|
} |
4768 |
|
} |
4769 |
|
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
4770 |
|
|
4771 |
|
/* |
4772 |
|
* Get the current namespace. |
4773 |
|
*/ |
4774 |
|
|
4775 |
|
if (iPtr->varFramePtr != NULL) { |
4776 |
|
currNsPtr = iPtr->varFramePtr->nsPtr; |
4777 |
|
} else { |
4778 |
|
currNsPtr = iPtr->globalNsPtr; |
4779 |
|
} |
4780 |
|
|
4781 |
|
/* |
4782 |
|
* Check the context namespace and the namespace epoch of the resolved |
4783 |
|
* symbol to make sure that it is fresh. If not, then force another |
4784 |
|
* conversion to the command type, to discard the old rep and create a |
4785 |
|
* new one. Note that we verify that the namespace id of the context |
4786 |
|
* namespace is the same as the one we cached; this insures that the |
4787 |
|
* namespace wasn't deleted and a new one created at the same address |
4788 |
|
* with the same command epoch. |
4789 |
|
*/ |
4790 |
|
|
4791 |
|
cmdPtr = NULL; |
4792 |
|
if ((resPtr != NULL) |
4793 |
|
&& (resPtr->refNsPtr == currNsPtr) |
4794 |
|
&& (resPtr->refNsId == currNsPtr->nsId) |
4795 |
|
&& (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) { |
4796 |
|
cmdPtr = resPtr->cmdPtr; |
4797 |
|
if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) { |
4798 |
|
cmdPtr = NULL; |
4799 |
|
} |
4800 |
|
} |
4801 |
|
|
4802 |
|
if (cmdPtr == NULL) { |
4803 |
|
result = tclCmdNameType.setFromAnyProc(interp, objPtr); |
4804 |
|
if (result != TCL_OK) { |
4805 |
|
return (Tcl_Command) NULL; |
4806 |
|
} |
4807 |
|
resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
4808 |
|
if (resPtr != NULL) { |
4809 |
|
cmdPtr = resPtr->cmdPtr; |
4810 |
|
} |
4811 |
|
} |
4812 |
|
return (Tcl_Command) cmdPtr; |
4813 |
|
} |
4814 |
|
|
4815 |
|
/* |
4816 |
|
*---------------------------------------------------------------------- |
4817 |
|
* |
4818 |
|
* TclSetCmdNameObj -- |
4819 |
|
* |
4820 |
|
* Modify an object to be an CmdName object that refers to the argument |
4821 |
|
* Command structure. |
4822 |
|
* |
4823 |
|
* Results: |
4824 |
|
* None. |
4825 |
|
* |
4826 |
|
* Side effects: |
4827 |
|
* The object's old internal rep is freed. It's string rep is not |
4828 |
|
* changed. The refcount in the Command structure is incremented to |
4829 |
|
* keep it from being freed if the command is later deleted until |
4830 |
|
* TclExecuteByteCode has a chance to recognize that it was deleted. |
4831 |
|
* |
4832 |
|
*---------------------------------------------------------------------- |
4833 |
|
*/ |
4834 |
|
|
4835 |
|
void |
4836 |
|
TclSetCmdNameObj(interp, objPtr, cmdPtr) |
4837 |
|
Tcl_Interp *interp; /* Points to interpreter containing command |
4838 |
|
* that should be cached in objPtr. */ |
4839 |
|
register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to |
4840 |
|
* a CmdName object. */ |
4841 |
|
Command *cmdPtr; /* Points to Command structure that the |
4842 |
|
* CmdName object should refer to. */ |
4843 |
|
{ |
4844 |
|
Interp *iPtr = (Interp *) interp; |
4845 |
|
register ResolvedCmdName *resPtr; |
4846 |
|
Tcl_ObjType *oldTypePtr = objPtr->typePtr; |
4847 |
|
register Namespace *currNsPtr; |
4848 |
|
|
4849 |
|
if (oldTypePtr == &tclCmdNameType) { |
4850 |
|
return; |
4851 |
|
} |
4852 |
|
|
4853 |
|
/* |
4854 |
|
* Get the current namespace. |
4855 |
|
*/ |
4856 |
|
|
4857 |
|
if (iPtr->varFramePtr != NULL) { |
4858 |
|
currNsPtr = iPtr->varFramePtr->nsPtr; |
4859 |
|
} else { |
4860 |
|
currNsPtr = iPtr->globalNsPtr; |
4861 |
|
} |
4862 |
|
|
4863 |
|
cmdPtr->refCount++; |
4864 |
|
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); |
4865 |
|
resPtr->cmdPtr = cmdPtr; |
4866 |
|
resPtr->refNsPtr = currNsPtr; |
4867 |
|
resPtr->refNsId = currNsPtr->nsId; |
4868 |
|
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; |
4869 |
|
resPtr->cmdEpoch = cmdPtr->cmdEpoch; |
4870 |
|
resPtr->refCount = 1; |
4871 |
|
|
4872 |
|
if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) { |
4873 |
|
oldTypePtr->freeIntRepProc(objPtr); |
4874 |
|
} |
4875 |
|
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
4876 |
|
objPtr->internalRep.twoPtrValue.ptr2 = NULL; |
4877 |
|
objPtr->typePtr = &tclCmdNameType; |
4878 |
|
} |
4879 |
|
|
4880 |
|
/* |
4881 |
|
*---------------------------------------------------------------------- |
4882 |
|
* |
4883 |
|
* FreeCmdNameInternalRep -- |
4884 |
|
* |
4885 |
|
* Frees the resources associated with a cmdName object's internal |
4886 |
|
* representation. |
4887 |
|
* |
4888 |
|
* Results: |
4889 |
|
* None. |
4890 |
|
* |
4891 |
|
* Side effects: |
4892 |
|
* Decrements the ref count of any cached ResolvedCmdName structure |
4893 |
|
* pointed to by the cmdName's internal representation. If this is |
4894 |
|
* the last use of the ResolvedCmdName, it is freed. This in turn |
4895 |
|
* decrements the ref count of the Command structure pointed to by |
4896 |
|
* the ResolvedSymbol, which may free the Command structure. |
4897 |
|
* |
4898 |
|
*---------------------------------------------------------------------- |
4899 |
|
*/ |
4900 |
|
|
4901 |
|
static void |
4902 |
|
FreeCmdNameInternalRep(objPtr) |
4903 |
|
register Tcl_Obj *objPtr; /* CmdName object with internal |
4904 |
|
* representation to free. */ |
4905 |
|
{ |
4906 |
|
register ResolvedCmdName *resPtr = |
4907 |
|
(ResolvedCmdName *) objPtr->internalRep.otherValuePtr; |
4908 |
|
|
4909 |
|
if (resPtr != NULL) { |
4910 |
|
/* |
4911 |
|
* Decrement the reference count of the ResolvedCmdName structure. |
4912 |
|
* If there are no more uses, free the ResolvedCmdName structure. |
4913 |
|
*/ |
4914 |
|
|
4915 |
|
resPtr->refCount--; |
4916 |
|
if (resPtr->refCount == 0) { |
4917 |
|
/* |
4918 |
|
* Now free the cached command, unless it is still in its |
4919 |
|
* hash table or if there are other references to it |
4920 |
|
* from other cmdName objects. |
4921 |
|
*/ |
4922 |
|
|
4923 |
|
Command *cmdPtr = resPtr->cmdPtr; |
4924 |
|
TclCleanupCommand(cmdPtr); |
4925 |
|
ckfree((char *) resPtr); |
4926 |
|
} |
4927 |
|
} |
4928 |
|
} |
4929 |
|
|
4930 |
|
/* |
4931 |
|
*---------------------------------------------------------------------- |
4932 |
|
* |
4933 |
|
* DupCmdNameInternalRep -- |
4934 |
|
* |
4935 |
|
* Initialize the internal representation of an cmdName Tcl_Obj to a |
4936 |
|
* copy of the internal representation of an existing cmdName object. |
4937 |
|
* |
4938 |
|
* Results: |
4939 |
|
* None. |
4940 |
|
* |
4941 |
|
* Side effects: |
4942 |
|
* "copyPtr"s internal rep is set to point to the ResolvedCmdName |
4943 |
|
* structure corresponding to "srcPtr"s internal rep. Increments the |
4944 |
|
* ref count of the ResolvedCmdName structure pointed to by the |
4945 |
|
* cmdName's internal representation. |
4946 |
|
* |
4947 |
|
*---------------------------------------------------------------------- |
4948 |
|
*/ |
4949 |
|
|
4950 |
|
static void |
4951 |
|
DupCmdNameInternalRep(srcPtr, copyPtr) |
4952 |
|
Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ |
4953 |
|
register Tcl_Obj *copyPtr; /* Object with internal rep to set. */ |
4954 |
|
{ |
4955 |
|
register ResolvedCmdName *resPtr = |
4956 |
|
(ResolvedCmdName *) srcPtr->internalRep.otherValuePtr; |
4957 |
|
|
4958 |
|
copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
4959 |
|
copyPtr->internalRep.twoPtrValue.ptr2 = NULL; |
4960 |
|
if (resPtr != NULL) { |
4961 |
|
resPtr->refCount++; |
4962 |
|
} |
4963 |
|
copyPtr->typePtr = &tclCmdNameType; |
4964 |
|
} |
4965 |
|
|
4966 |
|
/* |
4967 |
|
*---------------------------------------------------------------------- |
4968 |
|
* |
4969 |
|
* SetCmdNameFromAny -- |
4970 |
|
* |
4971 |
|
* Generate an cmdName internal form for the Tcl object "objPtr". |
4972 |
|
* |
4973 |
|
* Results: |
4974 |
|
* The return value is a standard Tcl result. The conversion always |
4975 |
|
* succeeds and TCL_OK is returned. |
4976 |
|
* |
4977 |
|
* Side effects: |
4978 |
|
* A pointer to a ResolvedCmdName structure that holds a cached pointer |
4979 |
|
* to the command with a name that matches objPtr's string rep is |
4980 |
|
* stored as objPtr's internal representation. This ResolvedCmdName |
4981 |
|
* pointer will be NULL if no matching command was found. The ref count |
4982 |
|
* of the cached Command's structure (if any) is also incremented. |
4983 |
|
* |
4984 |
|
*---------------------------------------------------------------------- |
4985 |
|
*/ |
4986 |
|
|
4987 |
|
static int |
4988 |
|
SetCmdNameFromAny(interp, objPtr) |
4989 |
|
Tcl_Interp *interp; /* Used for error reporting if not NULL. */ |
4990 |
|
register Tcl_Obj *objPtr; /* The object to convert. */ |
4991 |
|
{ |
4992 |
|
Interp *iPtr = (Interp *) interp; |
4993 |
|
char *name; |
4994 |
|
Tcl_Command cmd; |
4995 |
|
register Command *cmdPtr; |
4996 |
|
Namespace *currNsPtr; |
4997 |
|
register ResolvedCmdName *resPtr; |
4998 |
|
|
4999 |
|
/* |
5000 |
|
* Get "objPtr"s string representation. Make it up-to-date if necessary. |
5001 |
|
*/ |
5002 |
|
|
5003 |
|
name = objPtr->bytes; |
5004 |
|
if (name == NULL) { |
5005 |
|
name = Tcl_GetString(objPtr); |
5006 |
|
} |
5007 |
|
|
5008 |
|
/* |
5009 |
|
* Find the Command structure, if any, that describes the command called |
5010 |
|
* "name". Build a ResolvedCmdName that holds a cached pointer to this |
5011 |
|
* Command, and bump the reference count in the referenced Command |
5012 |
|
* structure. A Command structure will not be deleted as long as it is |
5013 |
|
* referenced from a CmdName object. |
5014 |
|
*/ |
5015 |
|
|
5016 |
|
cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL, |
5017 |
|
/*flags*/ 0); |
5018 |
|
cmdPtr = (Command *) cmd; |
5019 |
|
if (cmdPtr != NULL) { |
5020 |
|
/* |
5021 |
|
* Get the current namespace. |
5022 |
|
*/ |
5023 |
|
|
5024 |
|
if (iPtr->varFramePtr != NULL) { |
5025 |
|
currNsPtr = iPtr->varFramePtr->nsPtr; |
5026 |
|
} else { |
5027 |
|
currNsPtr = iPtr->globalNsPtr; |
5028 |
|
} |
5029 |
|
|
5030 |
|
cmdPtr->refCount++; |
5031 |
|
resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName)); |
5032 |
|
resPtr->cmdPtr = cmdPtr; |
5033 |
|
resPtr->refNsPtr = currNsPtr; |
5034 |
|
resPtr->refNsId = currNsPtr->nsId; |
5035 |
|
resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch; |
5036 |
|
resPtr->cmdEpoch = cmdPtr->cmdEpoch; |
5037 |
|
resPtr->refCount = 1; |
5038 |
|
} else { |
5039 |
|
resPtr = NULL; /* no command named "name" was found */ |
5040 |
|
} |
5041 |
|
|
5042 |
|
/* |
5043 |
|
* Free the old internalRep before setting the new one. We do this as |
5044 |
|
* late as possible to allow the conversion code, in particular |
5045 |
|
* GetStringFromObj, to use that old internalRep. If no Command |
5046 |
|
* structure was found, leave NULL as the cached value. |
5047 |
|
*/ |
5048 |
|
|
5049 |
|
if ((objPtr->typePtr != NULL) |
5050 |
|
&& (objPtr->typePtr->freeIntRepProc != NULL)) { |
5051 |
|
objPtr->typePtr->freeIntRepProc(objPtr); |
5052 |
|
} |
5053 |
|
|
5054 |
|
objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr; |
5055 |
|
objPtr->internalRep.twoPtrValue.ptr2 = NULL; |
5056 |
|
objPtr->typePtr = &tclCmdNameType; |
5057 |
|
return TCL_OK; |
5058 |
|
} |
5059 |
|
|
5060 |
|
#ifdef TCL_COMPILE_DEBUG |
5061 |
|
/* |
5062 |
|
*---------------------------------------------------------------------- |
5063 |
|
* |
5064 |
|
* StringForResultCode -- |
5065 |
|
* |
5066 |
|
* Procedure that returns a human-readable string representing a |
5067 |
|
* Tcl result code such as TCL_ERROR. |
5068 |
|
* |
5069 |
|
* Results: |
5070 |
|
* If the result code is one of the standard Tcl return codes, the |
5071 |
|
* result is a string representing that code such as "TCL_ERROR". |
5072 |
|
* Otherwise, the result string is that code formatted as a |
5073 |
|
* sequence of decimal digit characters. Note that the resulting |
5074 |
|
* string must not be modified by the caller. |
5075 |
|
* |
5076 |
|
* Side effects: |
5077 |
|
* None. |
5078 |
|
* |
5079 |
|
*---------------------------------------------------------------------- |
5080 |
|
*/ |
5081 |
|
|
5082 |
|
static char * |
5083 |
|
StringForResultCode(result) |
5084 |
|
int result; /* The Tcl result code for which to |
5085 |
|
* generate a string. */ |
5086 |
|
{ |
5087 |
|
static char buf[TCL_INTEGER_SPACE]; |
5088 |
|
|
5089 |
|
if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { |
5090 |
|
return resultStrings[result]; |
5091 |
|
} |
5092 |
|
TclFormatInt(buf, result); |
5093 |
|
return buf; |
5094 |
|
} |
5095 |
|
#endif /* TCL_COMPILE_DEBUG */ |
5096 |
|
|
5097 |
|
/* End of tclexecute.c */ |