sl@0: /* sl@0: * tclExecute.c -- sl@0: * sl@0: * This file contains procedures that execute byte-compiled Tcl sl@0: * commands. sl@0: * sl@0: * Copyright (c) 1996-1997 Sun Microsystems, Inc. sl@0: * Copyright (c) 1998-2000 by Scriptics Corporation. sl@0: * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. sl@0: * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved. sl@0: * sl@0: * See the file "license.terms" for information on usage and redistribution sl@0: * of this file, and for a DISCLAIMER OF ALL WARRANTIES. sl@0: * sl@0: * RCS: @(#) $Id: tclExecute.c,v 1.94.2.21 2007/03/13 16:26:32 dgp Exp $ sl@0: */ sl@0: sl@0: #include "tclInt.h" sl@0: #include "tclCompile.h" sl@0: #include "tclMath.h" sl@0: sl@0: /* sl@0: * The stuff below is a bit of a hack so that this file can be used sl@0: * in environments that include no UNIX, i.e. no errno. Just define sl@0: * errno here. sl@0: */ sl@0: sl@0: #ifndef TCL_GENERIC_ONLY sl@0: # include "tclPort.h" sl@0: #else /* TCL_GENERIC_ONLY */ sl@0: # ifndef NO_FLOAT_H sl@0: # include sl@0: # else /* NO_FLOAT_H */ sl@0: # ifndef NO_VALUES_H sl@0: # include sl@0: # endif /* !NO_VALUES_H */ sl@0: # endif /* !NO_FLOAT_H */ sl@0: # define NO_ERRNO_H sl@0: #endif /* !TCL_GENERIC_ONLY */ sl@0: sl@0: #ifdef NO_ERRNO_H sl@0: int errno; sl@0: # define EDOM 33 sl@0: # define ERANGE 34 sl@0: #endif sl@0: sl@0: /* sl@0: * Need DBL_MAX for IS_INF() macro... sl@0: */ sl@0: #ifndef DBL_MAX sl@0: # ifdef MAXDOUBLE sl@0: # define DBL_MAX MAXDOUBLE sl@0: # else /* !MAXDOUBLE */ sl@0: /* sl@0: * This value is from the Solaris headers, but doubles seem to be the sl@0: * same size everywhere. Long doubles aren't, but we don't use those. sl@0: */ sl@0: # define DBL_MAX 1.79769313486231570e+308 sl@0: # endif /* MAXDOUBLE */ sl@0: #endif /* !DBL_MAX */ sl@0: sl@0: /* sl@0: * Boolean flag indicating whether the Tcl bytecode interpreter has been sl@0: * initialized. sl@0: */ sl@0: sl@0: static int execInitialized = 0; sl@0: TCL_DECLARE_MUTEX(execMutex) sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: /* sl@0: * Variable that controls whether execution tracing is enabled and, if so, sl@0: * what level of tracing is desired: sl@0: * 0: no execution tracing sl@0: * 1: trace invocations of Tcl procs only sl@0: * 2: trace invocations of all (not compiled away) commands sl@0: * 3: display each instruction executed sl@0: * This variable is linked to the Tcl variable "tcl_traceExec". sl@0: */ sl@0: sl@0: int tclTraceExec = 0; sl@0: #endif sl@0: sl@0: /* sl@0: * Mapping from expression instruction opcodes to strings; used for error sl@0: * messages. Note that these entries must match the order and number of the sl@0: * expression opcodes (e.g., INST_LOR) in tclCompile.h. sl@0: */ sl@0: sl@0: static char *operatorStrings[] = { sl@0: "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>", sl@0: "+", "-", "*", "/", "%", "+", "-", "~", "!", sl@0: "BUILTIN FUNCTION", "FUNCTION", sl@0: "", "", "", "", "", "", "", "", "eq", "ne", sl@0: }; sl@0: sl@0: /* sl@0: * Mapping from Tcl result codes to strings; used for error and debugging sl@0: * messages. sl@0: */ sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: static char *resultStrings[] = { sl@0: "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE" sl@0: }; sl@0: #endif sl@0: sl@0: /* sl@0: * These are used by evalstats to monitor object usage in Tcl. sl@0: */ sl@0: sl@0: #ifdef TCL_COMPILE_STATS sl@0: long tclObjsAlloced = 0; sl@0: long tclObjsFreed = 0; sl@0: #define TCL_MAX_SHARED_OBJ_STATS 5 sl@0: long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 }; sl@0: #endif /* TCL_COMPILE_STATS */ sl@0: sl@0: /* sl@0: * Macros for testing floating-point values for certain special cases. Test sl@0: * for not-a-number by comparing a value against itself; test for infinity sl@0: * by comparing against the largest floating-point value. sl@0: */ sl@0: sl@0: #define IS_NAN(v) ((v) != (v)) sl@0: #define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX)) sl@0: sl@0: /* sl@0: * The new macro for ending an instruction; note that a sl@0: * reasonable C-optimiser will resolve all branches sl@0: * at compile time. (result) is always a constant; the macro sl@0: * NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is sl@0: * resolved at runtime for variable (nCleanup). sl@0: * sl@0: * ARGUMENTS: sl@0: * pcAdjustment: how much to increment pc sl@0: * nCleanup: how many objects to remove from the stack sl@0: * result: 0 indicates no object should be pushed on the sl@0: * stack; otherwise, push objResultPtr. If (result < 0), sl@0: * objResultPtr already has the correct reference count. sl@0: */ sl@0: sl@0: #define NEXT_INST_F(pcAdjustment, nCleanup, result) \ sl@0: if (nCleanup == 0) {\ sl@0: if (result != 0) {\ sl@0: if ((result) > 0) {\ sl@0: PUSH_OBJECT(objResultPtr);\ sl@0: } else {\ sl@0: stackPtr[++stackTop] = objResultPtr;\ sl@0: }\ sl@0: } \ sl@0: pc += (pcAdjustment);\ sl@0: goto cleanup0;\ sl@0: } else if (result != 0) {\ sl@0: if ((result) > 0) {\ sl@0: Tcl_IncrRefCount(objResultPtr);\ sl@0: }\ sl@0: pc += (pcAdjustment);\ sl@0: switch (nCleanup) {\ sl@0: case 1: goto cleanup1_pushObjResultPtr;\ sl@0: case 2: goto cleanup2_pushObjResultPtr;\ sl@0: default: panic("ERROR: bad usage of macro NEXT_INST_F");\ sl@0: }\ sl@0: } else {\ sl@0: pc += (pcAdjustment);\ sl@0: switch (nCleanup) {\ sl@0: case 1: goto cleanup1;\ sl@0: case 2: goto cleanup2;\ sl@0: default: panic("ERROR: bad usage of macro NEXT_INST_F");\ sl@0: }\ sl@0: } sl@0: sl@0: #define NEXT_INST_V(pcAdjustment, nCleanup, result) \ sl@0: pc += (pcAdjustment);\ sl@0: cleanup = (nCleanup);\ sl@0: if (result) {\ sl@0: if ((result) > 0) {\ sl@0: Tcl_IncrRefCount(objResultPtr);\ sl@0: }\ sl@0: goto cleanupV_pushObjResultPtr;\ sl@0: } else {\ sl@0: goto cleanupV;\ sl@0: } sl@0: sl@0: sl@0: /* sl@0: * Macros used to cache often-referenced Tcl evaluation stack information sl@0: * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO() sl@0: * pair must surround any call inside TclExecuteByteCode (and a few other sl@0: * procedures that use this scheme) that could result in a recursive call sl@0: * to TclExecuteByteCode. sl@0: */ sl@0: sl@0: #define CACHE_STACK_INFO() \ sl@0: stackPtr = eePtr->stackPtr; \ sl@0: stackTop = eePtr->stackTop sl@0: sl@0: #define DECACHE_STACK_INFO() \ sl@0: eePtr->stackTop = stackTop sl@0: sl@0: sl@0: /* sl@0: * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT sl@0: * increments the object's ref count since it makes the stack have another sl@0: * reference pointing to the object. However, POP_OBJECT does not decrement sl@0: * the ref count. This is because the stack may hold the only reference to sl@0: * the object, so the object would be destroyed if its ref count were sl@0: * decremented before the caller had a chance to, e.g., store it in a sl@0: * variable. It is the caller's responsibility to decrement the ref count sl@0: * when it is finished with an object. sl@0: * sl@0: * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT sl@0: * macro. The actual parameter might be an expression with side effects, sl@0: * and this ensures that it will be executed only once. sl@0: */ sl@0: sl@0: #define PUSH_OBJECT(objPtr) \ sl@0: Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr)) sl@0: sl@0: #define POP_OBJECT() \ sl@0: (stackPtr[stackTop--]) sl@0: sl@0: /* sl@0: * Macros used to trace instruction execution. The macros TRACE, sl@0: * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. sl@0: * O2S is only used in TRACE* calls to get a string from an object. sl@0: */ sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: # define TRACE(a) \ sl@0: if (traceInstructions) { \ sl@0: fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ sl@0: (unsigned int)(pc - codePtr->codeStart), \ sl@0: GetOpcodeName(pc)); \ sl@0: printf a; \ sl@0: } sl@0: # define TRACE_APPEND(a) \ sl@0: if (traceInstructions) { \ sl@0: printf a; \ sl@0: } sl@0: # define TRACE_WITH_OBJ(a, objPtr) \ sl@0: if (traceInstructions) { \ sl@0: fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \ sl@0: (unsigned int)(pc - codePtr->codeStart), \ sl@0: GetOpcodeName(pc)); \ sl@0: printf a; \ sl@0: TclPrintObject(stdout, objPtr, 30); \ sl@0: fprintf(stdout, "\n"); \ sl@0: } sl@0: # define O2S(objPtr) \ sl@0: (objPtr ? TclGetString(objPtr) : "") sl@0: #else /* !TCL_COMPILE_DEBUG */ sl@0: # define TRACE(a) sl@0: # define TRACE_APPEND(a) sl@0: # define TRACE_WITH_OBJ(a, objPtr) sl@0: # define O2S(objPtr) sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: sl@0: /* sl@0: * Macro to read a string containing either a wide or an int and sl@0: * decide which it is while decoding it at the same time. This sl@0: * enforces the policy that integer constants between LONG_MIN and sl@0: * LONG_MAX (inclusive) are represented by normal longs, and integer sl@0: * constants outside that range are represented by wide ints. sl@0: * sl@0: * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never sl@0: * generates an error message. sl@0: */ sl@0: #define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ sl@0: (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \ sl@0: if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ sl@0: && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ sl@0: (objPtr)->typePtr = &tclIntType; \ sl@0: (objPtr)->internalRep.longValue = (longVar) \ sl@0: = Tcl_WideAsLong(wideVar); \ sl@0: } sl@0: #define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \ sl@0: (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \ sl@0: &(wideVar)); \ sl@0: if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \ sl@0: && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \ sl@0: (objPtr)->typePtr = &tclIntType; \ sl@0: (objPtr)->internalRep.longValue = (longVar) \ sl@0: = Tcl_WideAsLong(wideVar); \ sl@0: } sl@0: /* sl@0: * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from sl@0: * an obj. sl@0: */ sl@0: #define FORCE_LONG(objPtr, longVar, wideVar) \ sl@0: if ((objPtr)->typePtr == &tclWideIntType) { \ sl@0: (longVar) = Tcl_WideAsLong(wideVar); \ sl@0: } sl@0: #define IS_INTEGER_TYPE(typePtr) \ sl@0: ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType) sl@0: #define IS_NUMERIC_TYPE(typePtr) \ sl@0: (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType) sl@0: sl@0: #define W0 Tcl_LongAsWide(0) sl@0: /* sl@0: * For tracing that uses wide values. sl@0: */ sl@0: #define LLD "%" TCL_LL_MODIFIER "d" sl@0: sl@0: #ifndef TCL_WIDE_INT_IS_LONG sl@0: /* sl@0: * Extract a double value from a general numeric object. sl@0: */ sl@0: #define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ sl@0: if ((typePtr) == &tclIntType) { \ sl@0: (doubleVar) = (double) (objPtr)->internalRep.longValue; \ sl@0: } else if ((typePtr) == &tclWideIntType) { \ sl@0: (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\ sl@0: } else { \ sl@0: (doubleVar) = (objPtr)->internalRep.doubleValue; \ sl@0: } sl@0: #else /* TCL_WIDE_INT_IS_LONG */ sl@0: #define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \ sl@0: if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \ sl@0: (doubleVar) = (double) (objPtr)->internalRep.longValue; \ sl@0: } else { \ sl@0: (doubleVar) = (objPtr)->internalRep.doubleValue; \ sl@0: } sl@0: #endif /* TCL_WIDE_INT_IS_LONG */ sl@0: sl@0: /* sl@0: * Declarations for local procedures to this file: sl@0: */ sl@0: sl@0: static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ByteCode *codePtr)); sl@0: static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, int objc, Tcl_Obj **objv)); sl@0: static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp, sl@0: ExecEnv *eePtr, ClientData clientData)); sl@0: #ifdef TCL_COMPILE_STATS sl@0: static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData, sl@0: Tcl_Interp *interp, int objc, sl@0: Tcl_Obj *CONST objv[])); sl@0: #endif /* TCL_COMPILE_STATS */ sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc)); sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc, sl@0: int catchOnly, ByteCode* codePtr)); sl@0: static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc, sl@0: ByteCode* codePtr, int *lengthPtr)); sl@0: static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr)); sl@0: static void IllegalExprOperandType _ANSI_ARGS_(( sl@0: Tcl_Interp *interp, unsigned char *pc, sl@0: Tcl_Obj *opndPtr)); sl@0: static void InitByteCodeExecution _ANSI_ARGS_(( sl@0: Tcl_Interp *interp)); sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr)); sl@0: static char * StringForResultCode _ANSI_ARGS_((int result)); sl@0: static void ValidatePcAndStackTop _ANSI_ARGS_(( sl@0: ByteCode *codePtr, unsigned char *pc, sl@0: int stackTop, int stackLowerBound)); sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp, sl@0: Tcl_Obj *objPtr)); sl@0: sl@0: /* sl@0: ========== Begin of math function wrappers ============= sl@0: The math function wrappers bellow are need to avoid the "Import relocation does not refer to code segment" error sl@0: message reported from ELF2E32 tool. sl@0: */ sl@0: sl@0: static double Tcl_acos(double x) sl@0: { sl@0: return acos(x); sl@0: } sl@0: sl@0: static double Tcl_asin(double x) sl@0: { sl@0: return asin(x); sl@0: } sl@0: sl@0: static double Tcl_atan(double x) sl@0: { sl@0: return atan(x); sl@0: } sl@0: sl@0: static double Tcl_atan2(double x, double y) sl@0: { sl@0: return atan2(x, y); sl@0: } sl@0: sl@0: static double Tcl_ceil(double num) sl@0: { sl@0: return ceil(num); sl@0: } sl@0: sl@0: static double Tcl_cos(double x) sl@0: { sl@0: return cos(x); sl@0: } sl@0: sl@0: static double Tcl_cosh(double x) sl@0: { sl@0: return cosh(x); sl@0: } sl@0: sl@0: static double Tcl_exp(double x) sl@0: { sl@0: return exp(x); sl@0: } sl@0: sl@0: static double Tcl_floor(double x) sl@0: { sl@0: return floor(x); sl@0: } sl@0: sl@0: static double Tcl_fmod(double numerator, double denominator) sl@0: { sl@0: return fmod(numerator, denominator); sl@0: } sl@0: sl@0: static double Tcl_hypot(double x, double y) sl@0: { sl@0: return hypot(x, y); sl@0: } sl@0: sl@0: static double Tcl_log(double x) sl@0: { sl@0: return log(x); sl@0: } sl@0: sl@0: static double Tcl_log10(double x) sl@0: { sl@0: return log10(x); sl@0: } sl@0: sl@0: static double Tcl_pow(double base, double exponent) sl@0: { sl@0: return pow(base, exponent); sl@0: } sl@0: sl@0: static double Tcl_sin(double x) sl@0: { sl@0: return sin(x); sl@0: } sl@0: sl@0: static double Tcl_sinh(double x) sl@0: { sl@0: return sinh(x); sl@0: } sl@0: sl@0: static double Tcl_sqrt(double x) sl@0: { sl@0: return sqrt(x); sl@0: } sl@0: sl@0: static double Tcl_tan(double x) sl@0: { sl@0: return tan(x); sl@0: } sl@0: sl@0: static double Tcl_tanh(double x) sl@0: { sl@0: return tanh(x); sl@0: } sl@0: sl@0: /* sl@0: ========== End of math function wrappers =============== sl@0: */ sl@0: sl@0: /* sl@0: * Table describing the built-in math functions. Entries in this table are sl@0: * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's sl@0: * operand byte. sl@0: */ sl@0: sl@0: BuiltinFunc tclBuiltinFuncTable[] = { sl@0: #ifndef TCL_NO_MATH sl@0: {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_acos}, sl@0: {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_asin}, sl@0: {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_atan}, sl@0: {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_atan2}, sl@0: {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_ceil}, sl@0: {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_cos}, sl@0: {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_cosh}, sl@0: {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_exp}, sl@0: {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_floor}, sl@0: {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_fmod}, sl@0: {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_hypot}, sl@0: {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_log}, sl@0: {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_log10}, sl@0: {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_pow}, sl@0: {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sin}, sl@0: {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sinh}, sl@0: {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sqrt}, sl@0: {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_tan}, sl@0: {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_tanh}, sl@0: #endif sl@0: {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0}, sl@0: {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0}, sl@0: {"int", 1, {TCL_EITHER}, ExprIntFunc, 0}, sl@0: {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */ sl@0: {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0}, sl@0: {"srand", 1, {TCL_INT}, ExprSrandFunc, 0}, sl@0: {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0}, sl@0: {0}, sl@0: }; sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * InitByteCodeExecution -- sl@0: * sl@0: * This procedure is called once to initialize the Tcl bytecode sl@0: * interpreter. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * This procedure initializes the array of instruction names. If sl@0: * compiling with the TCL_COMPILE_STATS flag, it initializes the sl@0: * array that counts the executions of each instruction and it sl@0: * creates the "evalstats" command. It also establishes the link sl@0: * between the Tcl "tcl_traceExec" and C "tclTraceExec" variables. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: InitByteCodeExecution(interp) sl@0: Tcl_Interp *interp; /* Interpreter for which the Tcl variable sl@0: * "tcl_traceExec" is linked to control sl@0: * instruction tracing. */ sl@0: { sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec, sl@0: TCL_LINK_INT) != TCL_OK) { sl@0: panic("InitByteCodeExecution: can't create link for tcl_traceExec variable"); sl@0: } sl@0: #endif sl@0: #ifdef TCL_COMPILE_STATS sl@0: Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, sl@0: (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL); sl@0: #endif /* TCL_COMPILE_STATS */ sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclCreateExecEnv -- sl@0: * sl@0: * This procedure creates a new execution environment for Tcl bytecode sl@0: * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv sl@0: * is typically created once for each Tcl interpreter (Interp sl@0: * structure) and recursively passed to TclExecuteByteCode to execute sl@0: * ByteCode sequences for nested commands. sl@0: * sl@0: * Results: sl@0: * A newly allocated ExecEnv is returned. This points to an empty sl@0: * evaluation stack of the standard initial size. sl@0: * sl@0: * Side effects: sl@0: * The bytecode interpreter is also initialized here, as this sl@0: * procedure will be called before any call to TclExecuteByteCode. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #define TCL_STACK_INITIAL_SIZE 2000 sl@0: sl@0: ExecEnv * sl@0: TclCreateExecEnv(interp) sl@0: Tcl_Interp *interp; /* Interpreter for which the execution sl@0: * environment is being created. */ sl@0: { sl@0: ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv)); sl@0: Tcl_Obj **stackPtr; sl@0: sl@0: stackPtr = (Tcl_Obj **) sl@0: ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *))); sl@0: sl@0: /* sl@0: * Use the bottom pointer to keep a reference count; the sl@0: * execution environment holds a reference. sl@0: */ sl@0: sl@0: stackPtr++; sl@0: eePtr->stackPtr = stackPtr; sl@0: stackPtr[-1] = (Tcl_Obj *) ((char *) 1); sl@0: sl@0: eePtr->stackTop = -1; sl@0: eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2); sl@0: sl@0: eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1); sl@0: Tcl_IncrRefCount(eePtr->errorInfo); sl@0: sl@0: eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1); sl@0: Tcl_IncrRefCount(eePtr->errorCode); sl@0: sl@0: Tcl_MutexLock(&execMutex); sl@0: if (!execInitialized) { sl@0: TclInitAuxDataTypeTable(); sl@0: InitByteCodeExecution(interp); sl@0: execInitialized = 1; sl@0: } sl@0: Tcl_MutexUnlock(&execMutex); sl@0: sl@0: return eePtr; sl@0: } sl@0: #undef TCL_STACK_INITIAL_SIZE sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclDeleteExecEnv -- sl@0: * sl@0: * Frees the storage for an ExecEnv. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Storage for an ExecEnv and its contained storage (e.g. the sl@0: * evaluation stack) is freed. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclDeleteExecEnv(eePtr) sl@0: ExecEnv *eePtr; /* Execution environment to free. */ sl@0: { sl@0: if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) { sl@0: ckfree((char *) (eePtr->stackPtr-1)); sl@0: } else { sl@0: panic("ERROR: freeing an execEnv whose stack is still in use.\n"); sl@0: } sl@0: TclDecrRefCount(eePtr->errorInfo); sl@0: TclDecrRefCount(eePtr->errorCode); sl@0: ckfree((char *) eePtr); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclFinalizeExecution -- sl@0: * sl@0: * Finalizes the execution environment setup so that it can be sl@0: * later reinitialized. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * After this call, the next time TclCreateExecEnv will be called sl@0: * it will call InitByteCodeExecution. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclFinalizeExecution() sl@0: { sl@0: Tcl_MutexLock(&execMutex); sl@0: execInitialized = 0; sl@0: Tcl_MutexUnlock(&execMutex); sl@0: TclFinalizeAuxDataTypeTable(); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GrowEvaluationStack -- sl@0: * sl@0: * This procedure grows a Tcl evaluation stack stored in an ExecEnv. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * The size of the evaluation stack is doubled. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: GrowEvaluationStack(eePtr) sl@0: register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation sl@0: * stack to enlarge. */ sl@0: { sl@0: /* sl@0: * The current Tcl stack elements are stored from eePtr->stackPtr[0] sl@0: * to eePtr->stackPtr[eePtr->stackEnd] (inclusive). sl@0: */ sl@0: sl@0: int currElems = (eePtr->stackEnd + 1); sl@0: int newElems = 2*currElems; sl@0: int currBytes = currElems * sizeof(Tcl_Obj *); sl@0: int newBytes = 2*currBytes; sl@0: Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes); sl@0: Tcl_Obj **oldStackPtr = eePtr->stackPtr; sl@0: sl@0: /* sl@0: * We keep the stack reference count as a (char *), as that sl@0: * works nicely as a portable pointer-sized counter. sl@0: */ sl@0: sl@0: char *refCount = (char *) oldStackPtr[-1]; sl@0: sl@0: /* sl@0: * Copy the existing stack items to the new stack space, free the old sl@0: * storage if appropriate, and record the refCount of the new stack sl@0: * held by the environment. sl@0: */ sl@0: sl@0: newStackPtr++; sl@0: memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr, sl@0: (size_t) currBytes); sl@0: sl@0: if (refCount == (char *) 1) { sl@0: ckfree((VOID *) (oldStackPtr-1)); sl@0: } else { sl@0: /* sl@0: * Remove the reference corresponding to the sl@0: * environment pointer. sl@0: */ sl@0: sl@0: oldStackPtr[-1] = (Tcl_Obj *) (refCount-1); sl@0: } sl@0: sl@0: eePtr->stackPtr = newStackPtr; sl@0: eePtr->stackEnd = (newElems - 2); /* index of last usable item */ sl@0: newStackPtr[-1] = (Tcl_Obj *) ((char *) 1); sl@0: } sl@0: sl@0: /* sl@0: *-------------------------------------------------------------- sl@0: * sl@0: * Tcl_ExprObj -- sl@0: * sl@0: * Evaluate an expression in a Tcl_Obj. sl@0: * sl@0: * Results: sl@0: * A standard Tcl object result. If the result is other than TCL_OK, sl@0: * then the interpreter's result contains an error message. If the sl@0: * result is TCL_OK, then a pointer to the expression's result value sl@0: * object is stored in resultPtrPtr. In that case, the object's ref sl@0: * count is incremented to reflect the reference returned to the sl@0: * caller; the caller is then responsible for the resulting object sl@0: * and must, for example, decrement the ref count when it is finished sl@0: * with the object. sl@0: * sl@0: * Side effects: sl@0: * Any side effects caused by subcommands in the expression, if any. sl@0: * The interpreter result is not modified unless there is an error. sl@0: * sl@0: *-------------------------------------------------------------- sl@0: */ sl@0: sl@0: EXPORT_C int sl@0: Tcl_ExprObj(interp, objPtr, resultPtrPtr) sl@0: Tcl_Interp *interp; /* Context in which to evaluate the sl@0: * expression. */ sl@0: register Tcl_Obj *objPtr; /* Points to Tcl object containing sl@0: * expression to evaluate. */ sl@0: Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression sl@0: * result is stored if no errors occur. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: CompileEnv compEnv; /* Compilation environment structure sl@0: * allocated in frame. */ sl@0: LiteralTable *localTablePtr = &(compEnv.localLitTable); sl@0: register ByteCode *codePtr = NULL; sl@0: /* Tcl Internal type of bytecode. sl@0: * Initialized to avoid compiler warning. */ sl@0: AuxData *auxDataPtr; sl@0: LiteralEntry *entryPtr; sl@0: Tcl_Obj *saveObjPtr; sl@0: char *string; sl@0: int length, i, result; sl@0: sl@0: /* sl@0: * First handle some common expressions specially. sl@0: */ sl@0: sl@0: string = Tcl_GetStringFromObj(objPtr, &length); sl@0: if (length == 1) { sl@0: if (*string == '0') { sl@0: *resultPtrPtr = Tcl_NewLongObj(0); sl@0: Tcl_IncrRefCount(*resultPtrPtr); sl@0: return TCL_OK; sl@0: } else if (*string == '1') { sl@0: *resultPtrPtr = Tcl_NewLongObj(1); sl@0: Tcl_IncrRefCount(*resultPtrPtr); sl@0: return TCL_OK; sl@0: } sl@0: } else if ((length == 2) && (*string == '!')) { sl@0: if (*(string+1) == '0') { sl@0: *resultPtrPtr = Tcl_NewLongObj(1); sl@0: Tcl_IncrRefCount(*resultPtrPtr); sl@0: return TCL_OK; sl@0: } else if (*(string+1) == '1') { sl@0: *resultPtrPtr = Tcl_NewLongObj(0); sl@0: Tcl_IncrRefCount(*resultPtrPtr); sl@0: return TCL_OK; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Get the ByteCode from the object. If it exists, make sure it hasn't sl@0: * been invalidated by, e.g., someone redefining a command with a sl@0: * compile procedure (this might make the compiled code wrong). If sl@0: * necessary, convert the object to be a ByteCode object and compile it. sl@0: * Also, if the code was compiled in/for a different interpreter, we sl@0: * recompile it. sl@0: * sl@0: * Precompiled expressions, however, are immutable and therefore sl@0: * they are not recompiled, even if the epoch has changed. sl@0: * sl@0: */ sl@0: sl@0: if (objPtr->typePtr == &tclByteCodeType) { sl@0: codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; sl@0: if (((Interp *) *codePtr->interpHandle != iPtr) sl@0: || (codePtr->compileEpoch != iPtr->compileEpoch)) { sl@0: if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { sl@0: if ((Interp *) *codePtr->interpHandle != iPtr) { sl@0: panic("Tcl_ExprObj: compiled expression jumped interps"); sl@0: } sl@0: codePtr->compileEpoch = iPtr->compileEpoch; sl@0: } else { sl@0: (*tclByteCodeType.freeIntRepProc)(objPtr); sl@0: objPtr->typePtr = (Tcl_ObjType *) NULL; sl@0: } sl@0: } sl@0: } sl@0: if (objPtr->typePtr != &tclByteCodeType) { sl@0: #ifndef TCL_TIP280 sl@0: TclInitCompileEnv(interp, &compEnv, string, length); sl@0: #else sl@0: /* TIP #280 : No invoker (yet) - Expression compilation */ sl@0: TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0); sl@0: #endif sl@0: result = TclCompileExpr(interp, string, length, &compEnv); sl@0: sl@0: /* sl@0: * Free the compilation environment's literal table bucket array if sl@0: * it was dynamically allocated. sl@0: */ sl@0: sl@0: if (localTablePtr->buckets != localTablePtr->staticBuckets) { sl@0: ckfree((char *) localTablePtr->buckets); sl@0: } sl@0: sl@0: if (result != TCL_OK) { sl@0: /* sl@0: * Compilation errors. Free storage allocated for compilation. sl@0: */ sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: TclVerifyLocalLiteralTable(&compEnv); sl@0: #endif /*TCL_COMPILE_DEBUG*/ sl@0: entryPtr = compEnv.literalArrayPtr; sl@0: for (i = 0; i < compEnv.literalArrayNext; i++) { sl@0: TclReleaseLiteral(interp, entryPtr->objPtr); sl@0: entryPtr++; sl@0: } sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: TclVerifyGlobalLiteralTable(iPtr); sl@0: #endif /*TCL_COMPILE_DEBUG*/ sl@0: sl@0: auxDataPtr = compEnv.auxDataArrayPtr; sl@0: for (i = 0; i < compEnv.auxDataArrayNext; i++) { sl@0: if (auxDataPtr->type->freeProc != NULL) { sl@0: auxDataPtr->type->freeProc(auxDataPtr->clientData); sl@0: } sl@0: auxDataPtr++; sl@0: } sl@0: TclFreeCompileEnv(&compEnv); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: * Successful compilation. If the expression yielded no sl@0: * instructions, push an zero object as the expression's result. sl@0: */ sl@0: sl@0: if (compEnv.codeNext == compEnv.codeStart) { sl@0: TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0), sl@0: &compEnv); sl@0: } sl@0: sl@0: /* sl@0: * Add a "done" instruction as the last instruction and change the sl@0: * object into a ByteCode object. Ownership of the literal objects sl@0: * and aux data items is given to the ByteCode object. sl@0: */ sl@0: sl@0: compEnv.numSrcBytes = iPtr->termOffset; sl@0: TclEmitOpcode(INST_DONE, &compEnv); sl@0: TclInitByteCodeObj(objPtr, &compEnv); sl@0: TclFreeCompileEnv(&compEnv); sl@0: codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: if (tclTraceCompile == 2) { sl@0: TclPrintByteCodeObj(interp, objPtr); sl@0: } sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: } sl@0: sl@0: /* sl@0: * Execute the expression after first saving the interpreter's result. sl@0: */ sl@0: sl@0: saveObjPtr = Tcl_GetObjResult(interp); sl@0: Tcl_IncrRefCount(saveObjPtr); sl@0: Tcl_ResetResult(interp); sl@0: sl@0: /* sl@0: * Increment the code's ref count while it is being executed. If sl@0: * afterwards no references to it remain, free the code. sl@0: */ sl@0: sl@0: codePtr->refCount++; sl@0: result = TclExecuteByteCode(interp, codePtr); sl@0: codePtr->refCount--; sl@0: if (codePtr->refCount <= 0) { sl@0: TclCleanupByteCode(codePtr); sl@0: objPtr->typePtr = NULL; sl@0: objPtr->internalRep.otherValuePtr = NULL; sl@0: } sl@0: sl@0: /* sl@0: * If the expression evaluated successfully, store a pointer to its sl@0: * value object in resultPtrPtr then restore the old interpreter result. sl@0: * We increment the object's ref count to reflect the reference that we sl@0: * are returning to the caller. We also decrement the ref count of the sl@0: * interpreter's result object after calling Tcl_SetResult since we sl@0: * next store into that field directly. sl@0: */ sl@0: sl@0: if (result == TCL_OK) { sl@0: *resultPtrPtr = iPtr->objResultPtr; sl@0: Tcl_IncrRefCount(iPtr->objResultPtr); sl@0: sl@0: Tcl_SetObjResult(interp, saveObjPtr); sl@0: } sl@0: TclDecrRefCount(saveObjPtr); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclCompEvalObj -- sl@0: * sl@0: * This procedure evaluates the script contained in a Tcl_Obj by sl@0: * first compiling it and then passing it to TclExecuteByteCode. sl@0: * sl@0: * Results: sl@0: * The return value is one of the return codes defined in tcl.h sl@0: * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object sl@0: * that either contains the result of executing the code or an sl@0: * error message. sl@0: * sl@0: * Side effects: sl@0: * Almost certainly, depending on the ByteCode's instructions. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: #ifndef TCL_TIP280 sl@0: TclCompEvalObj(interp, objPtr) sl@0: #else sl@0: TclCompEvalObj(interp, objPtr, invoker, word) sl@0: #endif sl@0: Tcl_Interp *interp; sl@0: Tcl_Obj *objPtr; sl@0: #ifdef TCL_TIP280 sl@0: CONST CmdFrame* invoker; /* Frame of the command doing the eval */ sl@0: int word; /* Index of the word which is in objPtr */ sl@0: #endif sl@0: { sl@0: register Interp *iPtr = (Interp *) interp; sl@0: register ByteCode* codePtr; /* Tcl Internal type of bytecode. */ sl@0: int oldCount = iPtr->cmdCount; /* Used to tell whether any commands sl@0: * at all were executed. */ sl@0: char *script; sl@0: int numSrcBytes; sl@0: int result; sl@0: Namespace *namespacePtr; sl@0: sl@0: sl@0: /* sl@0: * Check that the interpreter is ready to execute scripts sl@0: */ sl@0: sl@0: iPtr->numLevels++; sl@0: if (TclInterpReady(interp) == TCL_ERROR) { sl@0: iPtr->numLevels--; sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: if (iPtr->varFramePtr != NULL) { sl@0: namespacePtr = iPtr->varFramePtr->nsPtr; sl@0: } else { sl@0: namespacePtr = iPtr->globalNsPtr; sl@0: } sl@0: sl@0: /* sl@0: * If the object is not already of tclByteCodeType, compile it (and sl@0: * reset the compilation flags in the interpreter; this should be sl@0: * done after any compilation). sl@0: * Otherwise, check that it is "fresh" enough. sl@0: */ sl@0: sl@0: if (objPtr->typePtr != &tclByteCodeType) { sl@0: recompileObj: sl@0: iPtr->errorLine = 1; sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280. Remember the invoker for a moment in the interpreter sl@0: * structures so that the byte code compiler can pick it up when sl@0: * initializing the compilation environment, i.e. the extended sl@0: * location information. sl@0: */ sl@0: sl@0: iPtr->invokeCmdFramePtr = invoker; sl@0: iPtr->invokeWord = word; sl@0: #endif sl@0: result = tclByteCodeType.setFromAnyProc(interp, objPtr); sl@0: #ifdef TCL_TIP280 sl@0: iPtr->invokeCmdFramePtr = NULL; sl@0: #endif sl@0: sl@0: if (result != TCL_OK) { sl@0: iPtr->numLevels--; sl@0: return result; sl@0: } sl@0: codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; sl@0: } else { sl@0: /* sl@0: * Make sure the Bytecode hasn't been invalidated by, e.g., someone sl@0: * redefining a command with a compile procedure (this might make the sl@0: * compiled code wrong). sl@0: * The object needs to be recompiled if it was compiled in/for a sl@0: * different interpreter, or for a different namespace, or for the sl@0: * same namespace but with different name resolution rules. sl@0: * Precompiled objects, however, are immutable and therefore sl@0: * they are not recompiled, even if the epoch has changed. sl@0: * sl@0: * To be pedantically correct, we should also check that the sl@0: * originating procPtr is the same as the current context procPtr sl@0: * (assuming one exists at all - none for global level). This sl@0: * code is #def'ed out because [info body] was changed to never sl@0: * return a bytecode type object, which should obviate us from sl@0: * the extra checks here. sl@0: */ sl@0: codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; sl@0: if (((Interp *) *codePtr->interpHandle != iPtr) sl@0: || (codePtr->compileEpoch != iPtr->compileEpoch) sl@0: #ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */ sl@0: || (codePtr->procPtr != NULL && !(iPtr->varFramePtr && sl@0: iPtr->varFramePtr->procPtr == codePtr->procPtr)) sl@0: #endif sl@0: || (codePtr->nsPtr != namespacePtr) sl@0: || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) { sl@0: if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { sl@0: if ((Interp *) *codePtr->interpHandle != iPtr) { sl@0: panic("Tcl_EvalObj: compiled script jumped interps"); sl@0: } sl@0: codePtr->compileEpoch = iPtr->compileEpoch; sl@0: } else { sl@0: /* sl@0: * This byteCode is invalid: free it and recompile sl@0: */ sl@0: tclByteCodeType.freeIntRepProc(objPtr); sl@0: goto recompileObj; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Execute the commands. If the code was compiled from an empty string, sl@0: * don't bother executing the code. sl@0: */ sl@0: sl@0: numSrcBytes = codePtr->numSrcBytes; sl@0: if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) { sl@0: /* sl@0: * Increment the code's ref count while it is being executed. If sl@0: * afterwards no references to it remain, free the code. sl@0: */ sl@0: sl@0: codePtr->refCount++; sl@0: result = TclExecuteByteCode(interp, codePtr); sl@0: codePtr->refCount--; sl@0: if (codePtr->refCount <= 0) { sl@0: TclCleanupByteCode(codePtr); sl@0: } sl@0: } else { sl@0: result = TCL_OK; sl@0: } sl@0: iPtr->numLevels--; sl@0: sl@0: sl@0: /* sl@0: * If no commands at all were executed, check for asynchronous sl@0: * handlers so that they at least get one change to execute. sl@0: * This is needed to handle event loops written in Tcl with sl@0: * empty bodies. sl@0: */ sl@0: sl@0: if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) { sl@0: result = Tcl_AsyncInvoke(interp, result); sl@0: sl@0: sl@0: /* sl@0: * If an error occurred, record information about what was being sl@0: * executed when the error occurred. sl@0: */ sl@0: sl@0: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { sl@0: script = Tcl_GetStringFromObj(objPtr, &numSrcBytes); sl@0: Tcl_LogCommandInfo(interp, script, script, numSrcBytes); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's termOffset member to the offset of the sl@0: * character just after the last one executed. We approximate the offset sl@0: * of the last character executed by using the number of characters sl@0: * compiled. sl@0: */ sl@0: sl@0: iPtr->termOffset = numSrcBytes; sl@0: iPtr->flags &= ~ERR_ALREADY_LOGGED; sl@0: sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclExecuteByteCode -- sl@0: * sl@0: * This procedure executes the instructions of a ByteCode structure. sl@0: * It returns when a "done" instruction is executed or an error occurs. sl@0: * sl@0: * Results: sl@0: * The return value is one of the return codes defined in tcl.h sl@0: * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object sl@0: * that either contains the result of executing the code or an sl@0: * error message. sl@0: * sl@0: * Side effects: sl@0: * Almost certainly, depending on the ByteCode's instructions. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: TclExecuteByteCode(interp, codePtr) sl@0: Tcl_Interp *interp; /* Token for command interpreter. */ sl@0: ByteCode *codePtr; /* The bytecode sequence to interpret. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: ExecEnv *eePtr = iPtr->execEnvPtr; sl@0: /* Points to the execution environment. */ sl@0: register Tcl_Obj **stackPtr = eePtr->stackPtr; sl@0: /* Cached evaluation stack base pointer. */ sl@0: register int stackTop = eePtr->stackTop; sl@0: /* Cached top index of evaluation stack. */ sl@0: register unsigned char *pc = codePtr->codeStart; sl@0: /* The current program counter. */ sl@0: int opnd; /* Current instruction's operand byte(s). */ sl@0: int pcAdjustment; /* Hold pc adjustment after instruction. */ sl@0: int initStackTop = stackTop;/* Stack top at start of execution. */ sl@0: ExceptionRange *rangePtr; /* Points to closest loop or catch exception sl@0: * range enclosing the pc. Used by various sl@0: * instructions and processCatch to sl@0: * process break, continue, and errors. */ sl@0: int result = TCL_OK; /* Return code returned after execution. */ sl@0: int storeFlags; sl@0: Tcl_Obj *valuePtr, *value2Ptr, *objPtr; sl@0: char *bytes; sl@0: int length; sl@0: long i = 0; /* Init. avoids compiler warning. */ sl@0: Tcl_WideInt w; sl@0: register int cleanup; sl@0: Tcl_Obj *objResultPtr; sl@0: char *part1, *part2; sl@0: Var *varPtr, *arrayPtr; sl@0: CallFrame *varFramePtr = iPtr->varFramePtr; sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 : Structures for tracking lines */ sl@0: CmdFrame bcFrame; sl@0: #endif sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: int traceInstructions = (tclTraceExec == 3); sl@0: char cmdNameBuf[21]; sl@0: #endif sl@0: sl@0: /* sl@0: * This procedure uses a stack to hold information about catch commands. sl@0: * This information is the current operand stack top when starting to sl@0: * execute the code for each catch command. It starts out with stack- sl@0: * allocated space but uses dynamically-allocated storage if needed. sl@0: */ sl@0: sl@0: #define STATIC_CATCH_STACK_SIZE 4 sl@0: int (catchStackStorage[STATIC_CATCH_STACK_SIZE]); sl@0: int *catchStackPtr = catchStackStorage; sl@0: int catchTop = -1; sl@0: sl@0: #ifdef TCL_TIP280 sl@0: /* TIP #280 : Initialize the frame. Do not push it yet. */ sl@0: sl@0: bcFrame.type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) sl@0: ? TCL_LOCATION_PREBC sl@0: : TCL_LOCATION_BC); sl@0: bcFrame.level = (iPtr->cmdFramePtr == NULL ? sl@0: 1 : sl@0: iPtr->cmdFramePtr->level + 1); sl@0: bcFrame.framePtr = iPtr->framePtr; sl@0: bcFrame.nextPtr = iPtr->cmdFramePtr; sl@0: bcFrame.nline = 0; sl@0: bcFrame.line = NULL; sl@0: sl@0: bcFrame.data.tebc.codePtr = codePtr; sl@0: bcFrame.data.tebc.pc = NULL; sl@0: bcFrame.cmd.str.cmd = NULL; sl@0: bcFrame.cmd.str.len = 0; sl@0: #endif sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: if (tclTraceExec >= 2) { sl@0: PrintByteCodeInfo(codePtr); sl@0: fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop); sl@0: fflush(stdout); sl@0: } sl@0: opnd = 0; /* Init. avoids compiler warning. */ sl@0: #endif sl@0: sl@0: #ifdef TCL_COMPILE_STATS sl@0: iPtr->stats.numExecutions++; sl@0: #endif sl@0: sl@0: /* sl@0: * Make sure the catch stack is large enough to hold the maximum number sl@0: * of catch commands that could ever be executing at the same time. This sl@0: * will be no more than the exception range array's depth. sl@0: */ sl@0: sl@0: if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) { sl@0: catchStackPtr = (int *) sl@0: ckalloc(codePtr->maxExceptDepth * sizeof(int)); sl@0: } sl@0: sl@0: /* sl@0: * Make sure the stack has enough room to execute this ByteCode. sl@0: */ sl@0: sl@0: while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) { sl@0: GrowEvaluationStack(eePtr); sl@0: stackPtr = eePtr->stackPtr; sl@0: } sl@0: sl@0: /* sl@0: * Loop executing instructions until a "done" instruction, a sl@0: * TCL_RETURN, or some error. sl@0: */ sl@0: sl@0: goto cleanup0; sl@0: sl@0: sl@0: /* sl@0: * Targets for standard instruction endings; unrolled sl@0: * for speed in the most frequent cases (instructions that sl@0: * consume up to two stack elements). sl@0: * sl@0: * This used to be a "for(;;)" loop, with each instruction doing sl@0: * its own cleanup. sl@0: */ sl@0: sl@0: cleanupV_pushObjResultPtr: sl@0: switch (cleanup) { sl@0: case 0: sl@0: stackPtr[++stackTop] = (objResultPtr); sl@0: goto cleanup0; sl@0: default: sl@0: cleanup -= 2; sl@0: while (cleanup--) { sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: } sl@0: case 2: sl@0: cleanup2_pushObjResultPtr: sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: case 1: sl@0: cleanup1_pushObjResultPtr: sl@0: valuePtr = stackPtr[stackTop]; sl@0: TclDecrRefCount(valuePtr); sl@0: } sl@0: stackPtr[stackTop] = objResultPtr; sl@0: goto cleanup0; sl@0: sl@0: cleanupV: sl@0: switch (cleanup) { sl@0: default: sl@0: cleanup -= 2; sl@0: while (cleanup--) { sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: } sl@0: case 2: sl@0: cleanup2: sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: case 1: sl@0: cleanup1: sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: case 0: sl@0: /* sl@0: * We really want to do nothing now, but this is needed sl@0: * for some compilers (SunPro CC) sl@0: */ sl@0: break; sl@0: } sl@0: sl@0: cleanup0: sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop); sl@0: if (traceInstructions) { sl@0: fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop); sl@0: TclPrintInstruction(codePtr, pc); sl@0: fflush(stdout); sl@0: } sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: sl@0: #ifdef TCL_COMPILE_STATS sl@0: iPtr->stats.instructionCount[*pc]++; sl@0: #endif sl@0: switch (*pc) { sl@0: case INST_DONE: sl@0: if (stackTop <= initStackTop) { sl@0: stackTop--; sl@0: goto abnormalReturn; sl@0: } sl@0: sl@0: /* sl@0: * Set the interpreter's object result to point to the sl@0: * topmost object from the stack, and check for a possible sl@0: * [catch]. The stackTop's level and refCount will be handled sl@0: * by "processCatch" or "abnormalReturn". sl@0: */ sl@0: sl@0: valuePtr = stackPtr[stackTop]; sl@0: Tcl_SetObjResult(interp, valuePtr); sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: TRACE_WITH_OBJ(("=> return code=%d, result=", result), sl@0: iPtr->objResultPtr); sl@0: if (traceInstructions) { sl@0: fprintf(stdout, "\n"); sl@0: } sl@0: #endif sl@0: goto checkForCatch; sl@0: sl@0: case INST_PUSH1: sl@0: objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]; sl@0: TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr); sl@0: NEXT_INST_F(2, 0, 1); sl@0: sl@0: case INST_PUSH4: sl@0: objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)]; sl@0: TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr); sl@0: NEXT_INST_F(5, 0, 1); sl@0: sl@0: case INST_POP: sl@0: TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]); sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: NEXT_INST_F(1, 0, 0); sl@0: sl@0: case INST_DUP: sl@0: objResultPtr = stackPtr[stackTop]; sl@0: TRACE_WITH_OBJ(("=> "), objResultPtr); sl@0: NEXT_INST_F(1, 0, 1); sl@0: sl@0: case INST_OVER: sl@0: opnd = TclGetUInt4AtPtr( pc+1 ); sl@0: objResultPtr = stackPtr[ stackTop - opnd ]; sl@0: TRACE_WITH_OBJ(("=> "), objResultPtr); sl@0: NEXT_INST_F(5, 0, 1); sl@0: sl@0: case INST_CONCAT1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: { sl@0: int totalLen = 0; sl@0: sl@0: /* sl@0: * Peephole optimisation for appending an empty string. sl@0: * This enables replacing 'K $x [set x{}]' by '$x[set x{}]' sl@0: * for fastest execution. Avoid doing the optimisation for wide sl@0: * ints - a case where equal strings may refer to different values sl@0: * (see [Bug 1251791]). sl@0: */ sl@0: sl@0: if ((opnd == 2) && (stackPtr[stackTop-1]->typePtr != &tclWideIntType)) { sl@0: Tcl_GetStringFromObj(stackPtr[stackTop], &length); sl@0: if (length == 0) { sl@0: /* Just drop the top item from the stack */ sl@0: NEXT_INST_F(2, 1, 0); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Concatenate strings (with no separators) from the top sl@0: * opnd items on the stack starting with the deepest item. sl@0: * First, determine how many characters are needed. sl@0: */ sl@0: sl@0: for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { sl@0: bytes = Tcl_GetStringFromObj(stackPtr[i], &length); sl@0: if (bytes != NULL) { sl@0: totalLen += length; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Initialize the new append string object by appending the sl@0: * strings of the opnd stack objects. Also pop the objects. sl@0: */ sl@0: sl@0: TclNewObj(objResultPtr); sl@0: if (totalLen > 0) { sl@0: char *p = (char *) ckalloc((unsigned) (totalLen + 1)); sl@0: objResultPtr->bytes = p; sl@0: objResultPtr->length = totalLen; sl@0: for (i = (stackTop - (opnd-1)); i <= stackTop; i++) { sl@0: valuePtr = stackPtr[i]; sl@0: bytes = Tcl_GetStringFromObj(valuePtr, &length); sl@0: if (bytes != NULL) { sl@0: memcpy((VOID *) p, (VOID *) bytes, sl@0: (size_t) length); sl@0: p += length; sl@0: } sl@0: } sl@0: *p = '\0'; sl@0: } sl@0: sl@0: TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); sl@0: NEXT_INST_V(2, opnd, 1); sl@0: } sl@0: sl@0: case INST_INVOKE_STK4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: pcAdjustment = 5; sl@0: goto doInvocation; sl@0: sl@0: case INST_INVOKE_STK1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: sl@0: doInvocation: sl@0: { sl@0: int objc = opnd; /* The number of arguments. */ sl@0: Tcl_Obj **objv; /* The array of argument objects. */ sl@0: sl@0: /* sl@0: * We keep the stack reference count as a (char *), as that sl@0: * works nicely as a portable pointer-sized counter. sl@0: */ sl@0: sl@0: char **preservedStackRefCountPtr; sl@0: sl@0: /* sl@0: * Reference to memory block containing sl@0: * objv array (must be kept live throughout sl@0: * trace and command invokations.) sl@0: */ sl@0: sl@0: objv = &(stackPtr[stackTop - (objc-1)]); sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: if (tclTraceExec >= 2) { sl@0: if (traceInstructions) { sl@0: strncpy(cmdNameBuf, TclGetString(objv[0]), 20); sl@0: TRACE(("%u => call ", objc)); sl@0: } else { sl@0: fprintf(stdout, "%d: (%u) invoking ", sl@0: iPtr->numLevels, sl@0: (unsigned int)(pc - codePtr->codeStart)); sl@0: } sl@0: for (i = 0; i < objc; i++) { sl@0: TclPrintObject(stdout, objv[i], 15); sl@0: fprintf(stdout, " "); sl@0: } sl@0: fprintf(stdout, "\n"); sl@0: fflush(stdout); sl@0: } sl@0: #endif /*TCL_COMPILE_DEBUG*/ sl@0: sl@0: /* sl@0: * If trace procedures will be called, we need a sl@0: * command string to pass to TclEvalObjvInternal; note sl@0: * that a copy of the string will be made there to sl@0: * include the ending \0. sl@0: */ sl@0: sl@0: bytes = NULL; sl@0: length = 0; sl@0: if (iPtr->tracePtr != NULL) { sl@0: Trace *tracePtr, *nextTracePtr; sl@0: sl@0: for (tracePtr = iPtr->tracePtr; tracePtr != NULL; sl@0: tracePtr = nextTracePtr) { sl@0: nextTracePtr = tracePtr->nextPtr; sl@0: if (tracePtr->level == 0 || sl@0: iPtr->numLevels <= tracePtr->level) { sl@0: /* sl@0: * Traces will be called: get command string sl@0: */ sl@0: sl@0: bytes = GetSrcInfoForPc(pc, codePtr, &length); sl@0: break; sl@0: } sl@0: } sl@0: } else { sl@0: Command *cmdPtr; sl@0: cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]); sl@0: if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { sl@0: bytes = GetSrcInfoForPc(pc, codePtr, &length); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * A reference to part of the stack vector itself sl@0: * escapes our control: increase its refCount sl@0: * to stop it from being deallocated by a recursive sl@0: * call to ourselves. The extra variable is needed sl@0: * because all others are liable to change due to the sl@0: * trace procedures. sl@0: */ sl@0: sl@0: preservedStackRefCountPtr = (char **) (stackPtr-1); sl@0: ++*preservedStackRefCountPtr; sl@0: sl@0: /* sl@0: * Finally, let TclEvalObjvInternal handle the command. sl@0: * sl@0: * TIP #280 : Record the last piece of info needed by sl@0: * 'TclGetSrcInfoForPc', and push the frame. sl@0: */ sl@0: sl@0: #ifdef TCL_TIP280 sl@0: bcFrame.data.tebc.pc = pc; sl@0: iPtr->cmdFramePtr = &bcFrame; sl@0: #endif sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_ResetResult(interp); sl@0: result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0); sl@0: CACHE_STACK_INFO(); sl@0: #ifdef TCL_TIP280 sl@0: iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr; sl@0: #endif sl@0: sl@0: /* sl@0: * If the old stack is going to be released, it is sl@0: * safe to do so now, since no references to objv are sl@0: * going to be used from now on. sl@0: */ sl@0: sl@0: --*preservedStackRefCountPtr; sl@0: if (*preservedStackRefCountPtr == (char *) 0) { sl@0: ckfree((VOID *) preservedStackRefCountPtr); sl@0: } sl@0: sl@0: if (result == TCL_OK) { sl@0: /* sl@0: * Push the call's object result and continue execution sl@0: * with the next instruction. sl@0: */ sl@0: sl@0: TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=", sl@0: objc, cmdNameBuf), Tcl_GetObjResult(interp)); sl@0: sl@0: objResultPtr = Tcl_GetObjResult(interp); sl@0: sl@0: /* sl@0: * Reset the interp's result to avoid possible duplications sl@0: * of large objects [Bug 781585]. We do not call sl@0: * Tcl_ResetResult() to avoid any side effects caused by sl@0: * the resetting of errorInfo and errorCode [Bug 804681], sl@0: * which are not needed here. We chose instead to manipulate sl@0: * the interp's object result directly. sl@0: * sl@0: * Note that the result object is now in objResultPtr, it sl@0: * keeps the refCount it had in its role of iPtr->objResultPtr. sl@0: */ sl@0: { sl@0: Tcl_Obj *newObjResultPtr; sl@0: TclNewObj(newObjResultPtr); sl@0: Tcl_IncrRefCount(newObjResultPtr); sl@0: iPtr->objResultPtr = newObjResultPtr; sl@0: } sl@0: sl@0: NEXT_INST_V(pcAdjustment, opnd, -1); sl@0: } else { sl@0: cleanup = opnd; sl@0: goto processExceptionReturn; sl@0: } sl@0: } sl@0: sl@0: case INST_EVAL_STK: sl@0: /* sl@0: * Note to maintainers: it is important that INST_EVAL_STK sl@0: * pop its argument from the stack before jumping to sl@0: * checkForCatch! DO NOT OPTIMISE! sl@0: */ sl@0: sl@0: objPtr = stackPtr[stackTop]; sl@0: DECACHE_STACK_INFO(); sl@0: #ifndef TCL_TIP280 sl@0: result = TclCompEvalObj(interp, objPtr); sl@0: #else sl@0: /* TIP #280: The invoking context is left NULL for a dynamically sl@0: * constructed command. We cannot match its lines to the outer sl@0: * context. sl@0: */ sl@0: sl@0: result = TclCompEvalObj(interp, objPtr, NULL,0); sl@0: #endif sl@0: CACHE_STACK_INFO(); sl@0: if (result == TCL_OK) { sl@0: /* sl@0: * Normal return; push the eval's object result. sl@0: */ sl@0: sl@0: objResultPtr = Tcl_GetObjResult(interp); sl@0: TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), sl@0: Tcl_GetObjResult(interp)); sl@0: sl@0: /* sl@0: * Reset the interp's result to avoid possible duplications sl@0: * of large objects [Bug 781585]. We do not call sl@0: * Tcl_ResetResult() to avoid any side effects caused by sl@0: * the resetting of errorInfo and errorCode [Bug 804681], sl@0: * which are not needed here. We chose instead to manipulate sl@0: * the interp's object result directly. sl@0: * sl@0: * Note that the result object is now in objResultPtr, it sl@0: * keeps the refCount it had in its role of iPtr->objResultPtr. sl@0: */ sl@0: { sl@0: Tcl_Obj *newObjResultPtr; sl@0: TclNewObj(newObjResultPtr); sl@0: Tcl_IncrRefCount(newObjResultPtr); sl@0: iPtr->objResultPtr = newObjResultPtr; sl@0: } sl@0: sl@0: NEXT_INST_F(1, 1, -1); sl@0: } else { sl@0: cleanup = 1; sl@0: goto processExceptionReturn; sl@0: } sl@0: sl@0: case INST_EXPR_STK: sl@0: objPtr = stackPtr[stackTop]; sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_ResetResult(interp); sl@0: result = Tcl_ExprObj(interp, objPtr, &valuePtr); sl@0: CACHE_STACK_INFO(); sl@0: if (result != TCL_OK) { sl@0: TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", sl@0: O2S(objPtr)), Tcl_GetObjResult(interp)); sl@0: goto checkForCatch; sl@0: } sl@0: objResultPtr = valuePtr; sl@0: TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr); sl@0: NEXT_INST_F(1, 1, -1); /* already has right refct */ sl@0: sl@0: /* sl@0: * --------------------------------------------------------- sl@0: * Start of INST_LOAD instructions. sl@0: * sl@0: * WARNING: more 'goto' here than your doctor recommended! sl@0: * The different instructions set the value of some variables sl@0: * and then jump to somme common execution code. sl@0: */ sl@0: sl@0: case INST_LOAD_SCALAR1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: varPtr = &(varFramePtr->compiledLocals[opnd]); sl@0: part1 = varPtr->name; sl@0: while (TclIsVarLink(varPtr)) { sl@0: varPtr = varPtr->value.linkPtr; sl@0: } sl@0: TRACE(("%u => ", opnd)); sl@0: if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) sl@0: && (varPtr->tracePtr == NULL)) { sl@0: /* sl@0: * No errors, no traces: just get the value. sl@0: */ sl@0: objResultPtr = varPtr->value.objPtr; sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: NEXT_INST_F(2, 0, 1); sl@0: } sl@0: pcAdjustment = 2; sl@0: cleanup = 0; sl@0: arrayPtr = NULL; sl@0: part2 = NULL; sl@0: goto doCallPtrGetVar; sl@0: sl@0: case INST_LOAD_SCALAR4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: varPtr = &(varFramePtr->compiledLocals[opnd]); sl@0: part1 = varPtr->name; sl@0: while (TclIsVarLink(varPtr)) { sl@0: varPtr = varPtr->value.linkPtr; sl@0: } sl@0: TRACE(("%u => ", opnd)); sl@0: if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) sl@0: && (varPtr->tracePtr == NULL)) { sl@0: /* sl@0: * No errors, no traces: just get the value. sl@0: */ sl@0: objResultPtr = varPtr->value.objPtr; sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: NEXT_INST_F(5, 0, 1); sl@0: } sl@0: pcAdjustment = 5; sl@0: cleanup = 0; sl@0: arrayPtr = NULL; sl@0: part2 = NULL; sl@0: goto doCallPtrGetVar; sl@0: sl@0: case INST_LOAD_ARRAY_STK: sl@0: cleanup = 2; sl@0: part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */ sl@0: objPtr = stackPtr[stackTop-1]; /* array name */ sl@0: TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2)); sl@0: goto doLoadStk; sl@0: sl@0: case INST_LOAD_STK: sl@0: case INST_LOAD_SCALAR_STK: sl@0: cleanup = 1; sl@0: part2 = NULL; sl@0: objPtr = stackPtr[stackTop]; /* variable name */ sl@0: TRACE(("\"%.30s\" => ", O2S(objPtr))); sl@0: sl@0: doLoadStk: sl@0: part1 = TclGetString(objPtr); sl@0: varPtr = TclObjLookupVar(interp, objPtr, part2, sl@0: TCL_LEAVE_ERR_MSG, "read", sl@0: /*createPart1*/ 0, sl@0: /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) sl@0: && (varPtr->tracePtr == NULL) sl@0: && ((arrayPtr == NULL) sl@0: || (arrayPtr->tracePtr == NULL))) { sl@0: /* sl@0: * No errors, no traces: just get the value. sl@0: */ sl@0: objResultPtr = varPtr->value.objPtr; sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: NEXT_INST_V(1, cleanup, 1); sl@0: } sl@0: pcAdjustment = 1; sl@0: goto doCallPtrGetVar; sl@0: sl@0: case INST_LOAD_ARRAY4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: pcAdjustment = 5; sl@0: goto doLoadArray; sl@0: sl@0: case INST_LOAD_ARRAY1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: sl@0: doLoadArray: sl@0: part2 = TclGetString(stackPtr[stackTop]); sl@0: arrayPtr = &(varFramePtr->compiledLocals[opnd]); sl@0: part1 = arrayPtr->name; sl@0: while (TclIsVarLink(arrayPtr)) { sl@0: arrayPtr = arrayPtr->value.linkPtr; sl@0: } sl@0: TRACE(("%u \"%.30s\" => ", opnd, part2)); sl@0: varPtr = TclLookupArrayElement(interp, part1, part2, sl@0: TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); sl@0: if (varPtr == NULL) { sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr) sl@0: && (varPtr->tracePtr == NULL) sl@0: && ((arrayPtr == NULL) sl@0: || (arrayPtr->tracePtr == NULL))) { sl@0: /* sl@0: * No errors, no traces: just get the value. sl@0: */ sl@0: objResultPtr = varPtr->value.objPtr; sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: NEXT_INST_F(pcAdjustment, 1, 1); sl@0: } sl@0: cleanup = 1; sl@0: goto doCallPtrGetVar; sl@0: sl@0: doCallPtrGetVar: sl@0: /* sl@0: * There are either errors or the variable is traced: sl@0: * call TclPtrGetVar to process fully. sl@0: */ sl@0: sl@0: DECACHE_STACK_INFO(); sl@0: objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1, sl@0: part2, TCL_LEAVE_ERR_MSG); sl@0: CACHE_STACK_INFO(); sl@0: if (objResultPtr == NULL) { sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: NEXT_INST_V(pcAdjustment, cleanup, 1); sl@0: sl@0: /* sl@0: * End of INST_LOAD instructions. sl@0: * --------------------------------------------------------- sl@0: */ sl@0: sl@0: /* sl@0: * --------------------------------------------------------- sl@0: * Start of INST_STORE and related instructions. sl@0: * sl@0: * WARNING: more 'goto' here than your doctor recommended! sl@0: * The different instructions set the value of some variables sl@0: * and then jump to somme common execution code. sl@0: */ sl@0: sl@0: case INST_LAPPEND_STK: sl@0: valuePtr = stackPtr[stackTop]; /* value to append */ sl@0: part2 = NULL; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE sl@0: | TCL_LIST_ELEMENT | TCL_TRACE_READS); sl@0: goto doStoreStk; sl@0: sl@0: case INST_LAPPEND_ARRAY_STK: sl@0: valuePtr = stackPtr[stackTop]; /* value to append */ sl@0: part2 = TclGetString(stackPtr[stackTop - 1]); sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE sl@0: | TCL_LIST_ELEMENT | TCL_TRACE_READS); sl@0: goto doStoreStk; sl@0: sl@0: case INST_APPEND_STK: sl@0: valuePtr = stackPtr[stackTop]; /* value to append */ sl@0: part2 = NULL; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); sl@0: goto doStoreStk; sl@0: sl@0: case INST_APPEND_ARRAY_STK: sl@0: valuePtr = stackPtr[stackTop]; /* value to append */ sl@0: part2 = TclGetString(stackPtr[stackTop - 1]); sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); sl@0: goto doStoreStk; sl@0: sl@0: case INST_STORE_ARRAY_STK: sl@0: valuePtr = stackPtr[stackTop]; sl@0: part2 = TclGetString(stackPtr[stackTop - 1]); sl@0: storeFlags = TCL_LEAVE_ERR_MSG; sl@0: goto doStoreStk; sl@0: sl@0: case INST_STORE_STK: sl@0: case INST_STORE_SCALAR_STK: sl@0: valuePtr = stackPtr[stackTop]; sl@0: part2 = NULL; sl@0: storeFlags = TCL_LEAVE_ERR_MSG; sl@0: sl@0: doStoreStk: sl@0: objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */ sl@0: part1 = TclGetString(objPtr); sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: if (part2 == NULL) { sl@0: TRACE(("\"%.30s\" <- \"%.30s\" =>", sl@0: part1, O2S(valuePtr))); sl@0: } else { sl@0: TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ", sl@0: part1, part2, O2S(valuePtr))); sl@0: } sl@0: #endif sl@0: varPtr = TclObjLookupVar(interp, objPtr, part2, sl@0: TCL_LEAVE_ERR_MSG, "set", sl@0: /*createPart1*/ 1, sl@0: /*createPart2*/ 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: cleanup = ((part2 == NULL)? 2 : 3); sl@0: pcAdjustment = 1; sl@0: goto doCallPtrSetVar; sl@0: sl@0: case INST_LAPPEND_ARRAY4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: pcAdjustment = 5; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE sl@0: | TCL_LIST_ELEMENT | TCL_TRACE_READS); sl@0: goto doStoreArray; sl@0: sl@0: case INST_LAPPEND_ARRAY1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE sl@0: | TCL_LIST_ELEMENT | TCL_TRACE_READS); sl@0: goto doStoreArray; sl@0: sl@0: case INST_APPEND_ARRAY4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: pcAdjustment = 5; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); sl@0: goto doStoreArray; sl@0: sl@0: case INST_APPEND_ARRAY1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); sl@0: goto doStoreArray; sl@0: sl@0: case INST_STORE_ARRAY4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: pcAdjustment = 5; sl@0: storeFlags = TCL_LEAVE_ERR_MSG; sl@0: goto doStoreArray; sl@0: sl@0: case INST_STORE_ARRAY1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: storeFlags = TCL_LEAVE_ERR_MSG; sl@0: sl@0: doStoreArray: sl@0: valuePtr = stackPtr[stackTop]; sl@0: part2 = TclGetString(stackPtr[stackTop - 1]); sl@0: arrayPtr = &(varFramePtr->compiledLocals[opnd]); sl@0: part1 = arrayPtr->name; sl@0: TRACE(("%u \"%.30s\" <- \"%.30s\" => ", sl@0: opnd, part2, O2S(valuePtr))); sl@0: while (TclIsVarLink(arrayPtr)) { sl@0: arrayPtr = arrayPtr->value.linkPtr; sl@0: } sl@0: varPtr = TclLookupArrayElement(interp, part1, part2, sl@0: TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr); sl@0: if (varPtr == NULL) { sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: cleanup = 2; sl@0: goto doCallPtrSetVar; sl@0: sl@0: case INST_LAPPEND_SCALAR4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: pcAdjustment = 5; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE sl@0: | TCL_LIST_ELEMENT | TCL_TRACE_READS); sl@0: goto doStoreScalar; sl@0: sl@0: case INST_LAPPEND_SCALAR1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE sl@0: | TCL_LIST_ELEMENT | TCL_TRACE_READS); sl@0: goto doStoreScalar; sl@0: sl@0: case INST_APPEND_SCALAR4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: pcAdjustment = 5; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); sl@0: goto doStoreScalar; sl@0: sl@0: case INST_APPEND_SCALAR1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE); sl@0: goto doStoreScalar; sl@0: sl@0: case INST_STORE_SCALAR4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: pcAdjustment = 5; sl@0: storeFlags = TCL_LEAVE_ERR_MSG; sl@0: goto doStoreScalar; sl@0: sl@0: case INST_STORE_SCALAR1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: storeFlags = TCL_LEAVE_ERR_MSG; sl@0: sl@0: doStoreScalar: sl@0: valuePtr = stackPtr[stackTop]; sl@0: varPtr = &(varFramePtr->compiledLocals[opnd]); sl@0: part1 = varPtr->name; sl@0: TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr))); sl@0: while (TclIsVarLink(varPtr)) { sl@0: varPtr = varPtr->value.linkPtr; sl@0: } sl@0: cleanup = 1; sl@0: arrayPtr = NULL; sl@0: part2 = NULL; sl@0: sl@0: doCallPtrSetVar: sl@0: if ((storeFlags == TCL_LEAVE_ERR_MSG) sl@0: && !((varPtr->flags & VAR_IN_HASHTABLE) sl@0: && (varPtr->hPtr == NULL)) sl@0: && (varPtr->tracePtr == NULL) sl@0: && (TclIsVarScalar(varPtr) sl@0: || TclIsVarUndefined(varPtr)) sl@0: && ((arrayPtr == NULL) sl@0: || (arrayPtr->tracePtr == NULL))) { sl@0: /* sl@0: * No traces, no errors, plain 'set': we can safely inline. sl@0: * The value *will* be set to what's requested, so that sl@0: * the stack top remains pointing to the same Tcl_Obj. sl@0: */ sl@0: valuePtr = varPtr->value.objPtr; sl@0: objResultPtr = stackPtr[stackTop]; sl@0: if (valuePtr != objResultPtr) { sl@0: if (valuePtr != NULL) { sl@0: TclDecrRefCount(valuePtr); sl@0: } else { sl@0: TclSetVarScalar(varPtr); sl@0: TclClearVarUndefined(varPtr); sl@0: } sl@0: varPtr->value.objPtr = objResultPtr; sl@0: Tcl_IncrRefCount(objResultPtr); sl@0: } sl@0: #ifndef TCL_COMPILE_DEBUG sl@0: if (*(pc+pcAdjustment) == INST_POP) { sl@0: NEXT_INST_V((pcAdjustment+1), cleanup, 0); sl@0: } sl@0: #else sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: #endif sl@0: NEXT_INST_V(pcAdjustment, cleanup, 1); sl@0: } else { sl@0: DECACHE_STACK_INFO(); sl@0: objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr, sl@0: part1, part2, valuePtr, storeFlags); sl@0: CACHE_STACK_INFO(); sl@0: if (objResultPtr == NULL) { sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: #ifndef TCL_COMPILE_DEBUG sl@0: if (*(pc+pcAdjustment) == INST_POP) { sl@0: NEXT_INST_V((pcAdjustment+1), cleanup, 0); sl@0: } sl@0: #endif sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: NEXT_INST_V(pcAdjustment, cleanup, 1); sl@0: sl@0: sl@0: /* sl@0: * End of INST_STORE and related instructions. sl@0: * --------------------------------------------------------- sl@0: */ sl@0: sl@0: /* sl@0: * --------------------------------------------------------- sl@0: * Start of INST_INCR instructions. sl@0: * sl@0: * WARNING: more 'goto' here than your doctor recommended! sl@0: * The different instructions set the value of some variables sl@0: * and then jump to somme common execution code. sl@0: */ sl@0: sl@0: case INST_INCR_SCALAR1: sl@0: case INST_INCR_ARRAY1: sl@0: case INST_INCR_ARRAY_STK: sl@0: case INST_INCR_SCALAR_STK: sl@0: case INST_INCR_STK: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: valuePtr = stackPtr[stackTop]; sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: i = valuePtr->internalRep.longValue; sl@0: } else if (valuePtr->typePtr == &tclWideIntType) { sl@0: TclGetLongFromWide(i,valuePtr); sl@0: } else { sl@0: REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); sl@0: if (result != TCL_OK) { sl@0: TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ", sl@0: opnd, O2S(valuePtr)), Tcl_GetObjResult(interp)); sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_AddErrorInfo(interp, "\n (reading increment)"); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: FORCE_LONG(valuePtr, i, w); sl@0: } sl@0: stackTop--; sl@0: TclDecrRefCount(valuePtr); sl@0: switch (*pc) { sl@0: case INST_INCR_SCALAR1: sl@0: pcAdjustment = 2; sl@0: goto doIncrScalar; sl@0: case INST_INCR_ARRAY1: sl@0: pcAdjustment = 2; sl@0: goto doIncrArray; sl@0: default: sl@0: pcAdjustment = 1; sl@0: goto doIncrStk; sl@0: } sl@0: sl@0: case INST_INCR_ARRAY_STK_IMM: sl@0: case INST_INCR_SCALAR_STK_IMM: sl@0: case INST_INCR_STK_IMM: sl@0: i = TclGetInt1AtPtr(pc+1); sl@0: pcAdjustment = 2; sl@0: sl@0: doIncrStk: sl@0: if ((*pc == INST_INCR_ARRAY_STK_IMM) sl@0: || (*pc == INST_INCR_ARRAY_STK)) { sl@0: part2 = TclGetString(stackPtr[stackTop]); sl@0: objPtr = stackPtr[stackTop - 1]; sl@0: TRACE(("\"%.30s(%.30s)\" (by %ld) => ", sl@0: O2S(objPtr), part2, i)); sl@0: } else { sl@0: part2 = NULL; sl@0: objPtr = stackPtr[stackTop]; sl@0: TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i)); sl@0: } sl@0: part1 = TclGetString(objPtr); sl@0: sl@0: varPtr = TclObjLookupVar(interp, objPtr, part2, sl@0: TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr); sl@0: if (varPtr == NULL) { sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_AddObjErrorInfo(interp, sl@0: "\n (reading value of variable to increment)", -1); sl@0: CACHE_STACK_INFO(); sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: cleanup = ((part2 == NULL)? 1 : 2); sl@0: goto doIncrVar; sl@0: sl@0: case INST_INCR_ARRAY1_IMM: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: i = TclGetInt1AtPtr(pc+2); sl@0: pcAdjustment = 3; sl@0: sl@0: doIncrArray: sl@0: part2 = TclGetString(stackPtr[stackTop]); sl@0: arrayPtr = &(varFramePtr->compiledLocals[opnd]); sl@0: part1 = arrayPtr->name; sl@0: while (TclIsVarLink(arrayPtr)) { sl@0: arrayPtr = arrayPtr->value.linkPtr; sl@0: } sl@0: TRACE(("%u \"%.30s\" (by %ld) => ", sl@0: opnd, part2, i)); sl@0: varPtr = TclLookupArrayElement(interp, part1, part2, sl@0: TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr); sl@0: if (varPtr == NULL) { sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: cleanup = 1; sl@0: goto doIncrVar; sl@0: sl@0: case INST_INCR_SCALAR1_IMM: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: i = TclGetInt1AtPtr(pc+2); sl@0: pcAdjustment = 3; sl@0: sl@0: doIncrScalar: sl@0: varPtr = &(varFramePtr->compiledLocals[opnd]); sl@0: part1 = varPtr->name; sl@0: while (TclIsVarLink(varPtr)) { sl@0: varPtr = varPtr->value.linkPtr; sl@0: } sl@0: arrayPtr = NULL; sl@0: part2 = NULL; sl@0: cleanup = 0; sl@0: TRACE(("%u %ld => ", opnd, i)); sl@0: sl@0: sl@0: doIncrVar: sl@0: objPtr = varPtr->value.objPtr; sl@0: if (TclIsVarScalar(varPtr) sl@0: && !TclIsVarUndefined(varPtr) sl@0: && (varPtr->tracePtr == NULL) sl@0: && ((arrayPtr == NULL) sl@0: || (arrayPtr->tracePtr == NULL)) sl@0: && (objPtr->typePtr == &tclIntType)) { sl@0: /* sl@0: * No errors, no traces, the variable already has an sl@0: * integer value: inline processing. sl@0: */ sl@0: sl@0: i += objPtr->internalRep.longValue; sl@0: if (Tcl_IsShared(objPtr)) { sl@0: objResultPtr = Tcl_NewLongObj(i); sl@0: TclDecrRefCount(objPtr); sl@0: Tcl_IncrRefCount(objResultPtr); sl@0: varPtr->value.objPtr = objResultPtr; sl@0: } else { sl@0: Tcl_SetLongObj(objPtr, i); sl@0: objResultPtr = objPtr; sl@0: } sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: } else { sl@0: DECACHE_STACK_INFO(); sl@0: objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1, sl@0: part2, i, TCL_LEAVE_ERR_MSG); sl@0: CACHE_STACK_INFO(); sl@0: if (objResultPtr == NULL) { sl@0: TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp)))); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: TRACE_APPEND(("%.30s\n", O2S(objResultPtr))); sl@0: #ifndef TCL_COMPILE_DEBUG sl@0: if (*(pc+pcAdjustment) == INST_POP) { sl@0: NEXT_INST_V((pcAdjustment+1), cleanup, 0); sl@0: } sl@0: #endif sl@0: NEXT_INST_V(pcAdjustment, cleanup, 1); sl@0: sl@0: /* sl@0: * End of INST_INCR instructions. sl@0: * --------------------------------------------------------- sl@0: */ sl@0: sl@0: sl@0: case INST_JUMP1: sl@0: opnd = TclGetInt1AtPtr(pc+1); sl@0: TRACE(("%d => new pc %u\n", opnd, sl@0: (unsigned int)(pc + opnd - codePtr->codeStart))); sl@0: NEXT_INST_F(opnd, 0, 0); sl@0: sl@0: case INST_JUMP4: sl@0: opnd = TclGetInt4AtPtr(pc+1); sl@0: TRACE(("%d => new pc %u\n", opnd, sl@0: (unsigned int)(pc + opnd - codePtr->codeStart))); sl@0: NEXT_INST_F(opnd, 0, 0); sl@0: sl@0: case INST_JUMP_FALSE4: sl@0: opnd = 5; /* TRUE */ sl@0: pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */ sl@0: goto doJumpTrue; sl@0: sl@0: case INST_JUMP_TRUE4: sl@0: opnd = TclGetInt4AtPtr(pc+1); /* TRUE */ sl@0: pcAdjustment = 5; /* FALSE */ sl@0: goto doJumpTrue; sl@0: sl@0: case INST_JUMP_FALSE1: sl@0: opnd = 2; /* TRUE */ sl@0: pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */ sl@0: goto doJumpTrue; sl@0: sl@0: case INST_JUMP_TRUE1: sl@0: opnd = TclGetInt1AtPtr(pc+1); /* TRUE */ sl@0: pcAdjustment = 2; /* FALSE */ sl@0: sl@0: doJumpTrue: sl@0: { sl@0: int b; sl@0: sl@0: valuePtr = stackPtr[stackTop]; sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: b = (valuePtr->internalRep.longValue != 0); sl@0: } else if (valuePtr->typePtr == &tclDoubleType) { sl@0: b = (valuePtr->internalRep.doubleValue != 0.0); sl@0: } else if (valuePtr->typePtr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: b = (w != W0); sl@0: } else { sl@0: result = Tcl_GetBooleanFromObj(interp, valuePtr, &b); sl@0: if (result != TCL_OK) { sl@0: TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: #ifndef TCL_COMPILE_DEBUG sl@0: NEXT_INST_F((b? opnd : pcAdjustment), 1, 0); sl@0: #else sl@0: if (b) { sl@0: if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) { sl@0: TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr), sl@0: (unsigned int)(pc+opnd - codePtr->codeStart))); sl@0: } else { sl@0: TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr))); sl@0: } sl@0: NEXT_INST_F(opnd, 1, 0); sl@0: } else { sl@0: if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) { sl@0: TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr))); sl@0: } else { sl@0: opnd = pcAdjustment; sl@0: TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr), sl@0: (unsigned int)(pc + opnd - codePtr->codeStart))); sl@0: } sl@0: NEXT_INST_F(pcAdjustment, 1, 0); sl@0: } sl@0: #endif sl@0: } sl@0: sl@0: case INST_LOR: sl@0: case INST_LAND: sl@0: { sl@0: /* sl@0: * Operands must be boolean or numeric. No int->double sl@0: * conversions are performed. sl@0: */ sl@0: sl@0: int i1, i2; sl@0: int iResult; sl@0: char *s; sl@0: Tcl_ObjType *t1Ptr, *t2Ptr; sl@0: sl@0: value2Ptr = stackPtr[stackTop]; sl@0: valuePtr = stackPtr[stackTop - 1];; sl@0: t1Ptr = valuePtr->typePtr; sl@0: t2Ptr = value2Ptr->typePtr; sl@0: sl@0: if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) { sl@0: i1 = (valuePtr->internalRep.longValue != 0); sl@0: } else if (t1Ptr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: i1 = (w != W0); sl@0: } else if (t1Ptr == &tclDoubleType) { sl@0: i1 = (valuePtr->internalRep.doubleValue != 0.0); sl@0: } else { sl@0: s = Tcl_GetStringFromObj(valuePtr, &length); sl@0: if (TclLooksLikeInt(s, length)) { sl@0: GET_WIDE_OR_INT(result, valuePtr, i, w); sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: i1 = (i != 0); sl@0: } else { sl@0: i1 = (w != W0); sl@0: } sl@0: } else { sl@0: result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, sl@0: valuePtr, &i1); sl@0: i1 = (i1 != 0); sl@0: } sl@0: if (result != TCL_OK) { sl@0: TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr), sl@0: (t1Ptr? t1Ptr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, valuePtr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: sl@0: if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) { sl@0: i2 = (value2Ptr->internalRep.longValue != 0); sl@0: } else if (t2Ptr == &tclWideIntType) { sl@0: TclGetWide(w,value2Ptr); sl@0: i2 = (w != W0); sl@0: } else if (t2Ptr == &tclDoubleType) { sl@0: i2 = (value2Ptr->internalRep.doubleValue != 0.0); sl@0: } else { sl@0: s = Tcl_GetStringFromObj(value2Ptr, &length); sl@0: if (TclLooksLikeInt(s, length)) { sl@0: GET_WIDE_OR_INT(result, value2Ptr, i, w); sl@0: if (value2Ptr->typePtr == &tclIntType) { sl@0: i2 = (i != 0); sl@0: } else { sl@0: i2 = (w != W0); sl@0: } sl@0: } else { sl@0: result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2); sl@0: } sl@0: if (result != TCL_OK) { sl@0: TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr), sl@0: (t2Ptr? t2Ptr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, value2Ptr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Reuse the valuePtr object already on stack if possible. sl@0: */ sl@0: sl@0: if (*pc == INST_LOR) { sl@0: iResult = (i1 || i2); sl@0: } else { sl@0: iResult = (i1 && i2); sl@0: } sl@0: if (Tcl_IsShared(valuePtr)) { sl@0: objResultPtr = Tcl_NewLongObj(iResult); sl@0: TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); sl@0: NEXT_INST_F(1, 2, 1); sl@0: } else { /* reuse the valuePtr object */ sl@0: TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); sl@0: Tcl_SetLongObj(valuePtr, iResult); sl@0: NEXT_INST_F(1, 1, 0); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * --------------------------------------------------------- sl@0: * Start of INST_LIST and related instructions. sl@0: */ sl@0: sl@0: case INST_LIST: sl@0: /* sl@0: * Pop the opnd (objc) top stack elements into a new list obj sl@0: * and then decrement their ref counts. sl@0: */ sl@0: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)])); sl@0: TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr); sl@0: NEXT_INST_V(5, opnd, 1); sl@0: sl@0: case INST_LIST_LENGTH: sl@0: valuePtr = stackPtr[stackTop]; sl@0: sl@0: result = Tcl_ListObjLength(interp, valuePtr, &length); sl@0: if (result != TCL_OK) { sl@0: TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)), sl@0: Tcl_GetObjResult(interp)); sl@0: goto checkForCatch; sl@0: } sl@0: objResultPtr = Tcl_NewIntObj(length); sl@0: TRACE(("%.20s => %d\n", O2S(valuePtr), length)); sl@0: NEXT_INST_F(1, 1, 1); sl@0: sl@0: case INST_LIST_INDEX: sl@0: /*** lindex with objc == 3 ***/ sl@0: sl@0: /* sl@0: * Pop the two operands sl@0: */ sl@0: value2Ptr = stackPtr[stackTop]; sl@0: valuePtr = stackPtr[stackTop- 1]; sl@0: sl@0: /* sl@0: * Extract the desired list element sl@0: */ sl@0: objResultPtr = TclLindexList(interp, valuePtr, value2Ptr); sl@0: if (objResultPtr == NULL) { sl@0: TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)), sl@0: Tcl_GetObjResult(interp)); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: sl@0: /* sl@0: * Stash the list element on the stack sl@0: */ sl@0: TRACE(("%.20s %.20s => %s\n", sl@0: O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr))); sl@0: NEXT_INST_F(1, 2, -1); /* already has the correct refCount */ sl@0: sl@0: case INST_LIST_INDEX_MULTI: sl@0: { sl@0: /* sl@0: * 'lindex' with multiple index args: sl@0: * sl@0: * Determine the count of index args. sl@0: */ sl@0: sl@0: int numIdx; sl@0: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: numIdx = opnd-1; sl@0: sl@0: /* sl@0: * Do the 'lindex' operation. sl@0: */ sl@0: objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx], sl@0: numIdx, stackPtr + stackTop - numIdx + 1); sl@0: sl@0: /* sl@0: * Check for errors sl@0: */ sl@0: if (objResultPtr == NULL) { sl@0: TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: sl@0: /* sl@0: * Set result sl@0: */ sl@0: TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); sl@0: NEXT_INST_V(5, opnd, -1); sl@0: } sl@0: sl@0: case INST_LSET_FLAT: sl@0: { sl@0: /* sl@0: * Lset with 3, 5, or more args. Get the number sl@0: * of index args. sl@0: */ sl@0: int numIdx; sl@0: sl@0: opnd = TclGetUInt4AtPtr( pc + 1 ); sl@0: numIdx = opnd - 2; sl@0: sl@0: /* sl@0: * Get the old value of variable, and remove the stack ref. sl@0: * This is safe because the variable still references the sl@0: * object; the ref count will never go zero here. sl@0: */ sl@0: value2Ptr = POP_OBJECT(); sl@0: TclDecrRefCount(value2Ptr); /* This one should be done here */ sl@0: sl@0: /* sl@0: * Get the new element value. sl@0: */ sl@0: valuePtr = stackPtr[stackTop]; sl@0: sl@0: /* sl@0: * Compute the new variable value sl@0: */ sl@0: objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx, sl@0: stackPtr + stackTop - numIdx, valuePtr); sl@0: sl@0: sl@0: /* sl@0: * Check for errors sl@0: */ sl@0: if (objResultPtr == NULL) { sl@0: TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp)); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: sl@0: /* sl@0: * Set result sl@0: */ sl@0: TRACE(("%d => %s\n", opnd, O2S(objResultPtr))); sl@0: NEXT_INST_V(5, (numIdx+1), -1); sl@0: } sl@0: sl@0: case INST_LSET_LIST: sl@0: /* sl@0: * 'lset' with 4 args. sl@0: * sl@0: * Get the old value of variable, and remove the stack ref. sl@0: * This is safe because the variable still references the sl@0: * object; the ref count will never go zero here. sl@0: */ sl@0: objPtr = POP_OBJECT(); sl@0: TclDecrRefCount(objPtr); /* This one should be done here */ sl@0: sl@0: /* sl@0: * Get the new element value, and the index list sl@0: */ sl@0: valuePtr = stackPtr[stackTop]; sl@0: value2Ptr = stackPtr[stackTop - 1]; sl@0: sl@0: /* sl@0: * Compute the new variable value sl@0: */ sl@0: objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr); sl@0: sl@0: /* sl@0: * Check for errors sl@0: */ sl@0: if (objResultPtr == NULL) { sl@0: TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)), sl@0: Tcl_GetObjResult(interp)); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: sl@0: /* sl@0: * Set result sl@0: */ sl@0: TRACE(("=> %s\n", O2S(objResultPtr))); sl@0: NEXT_INST_F(1, 2, -1); sl@0: sl@0: /* sl@0: * End of INST_LIST and related instructions. sl@0: * --------------------------------------------------------- sl@0: */ sl@0: sl@0: case INST_STR_EQ: sl@0: case INST_STR_NEQ: sl@0: { sl@0: /* sl@0: * String (in)equality check sl@0: */ sl@0: int iResult; sl@0: sl@0: value2Ptr = stackPtr[stackTop]; sl@0: valuePtr = stackPtr[stackTop - 1]; sl@0: sl@0: if (valuePtr == value2Ptr) { sl@0: /* sl@0: * On the off-chance that the objects are the same, sl@0: * we don't really have to think hard about equality. sl@0: */ sl@0: iResult = (*pc == INST_STR_EQ); sl@0: } else { sl@0: char *s1, *s2; sl@0: int s1len, s2len; sl@0: sl@0: s1 = Tcl_GetStringFromObj(valuePtr, &s1len); sl@0: s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); sl@0: if (s1len == s2len) { sl@0: /* sl@0: * We only need to check (in)equality when sl@0: * we have equal length strings. sl@0: */ sl@0: if (*pc == INST_STR_NEQ) { sl@0: iResult = (strcmp(s1, s2) != 0); sl@0: } else { sl@0: /* INST_STR_EQ */ sl@0: iResult = (strcmp(s1, s2) == 0); sl@0: } sl@0: } else { sl@0: iResult = (*pc == INST_STR_NEQ); sl@0: } sl@0: } sl@0: sl@0: TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); sl@0: sl@0: /* sl@0: * Peep-hole optimisation: if you're about to jump, do jump sl@0: * from here. sl@0: */ sl@0: sl@0: pc++; sl@0: #ifndef TCL_COMPILE_DEBUG sl@0: switch (*pc) { sl@0: case INST_JUMP_FALSE1: sl@0: NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); sl@0: case INST_JUMP_TRUE1: sl@0: NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); sl@0: case INST_JUMP_FALSE4: sl@0: NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); sl@0: case INST_JUMP_TRUE4: sl@0: NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); sl@0: } sl@0: #endif sl@0: objResultPtr = Tcl_NewIntObj(iResult); sl@0: NEXT_INST_F(0, 2, 1); sl@0: } sl@0: sl@0: case INST_STR_CMP: sl@0: { sl@0: /* sl@0: * String compare sl@0: */ sl@0: CONST char *s1, *s2; sl@0: int s1len, s2len, iResult; sl@0: sl@0: value2Ptr = stackPtr[stackTop]; sl@0: valuePtr = stackPtr[stackTop - 1]; sl@0: sl@0: /* sl@0: * The comparison function should compare up to the sl@0: * minimum byte length only. sl@0: */ sl@0: if (valuePtr == value2Ptr) { sl@0: /* sl@0: * In the pure equality case, set lengths too for sl@0: * the checks below (or we could goto beyond it). sl@0: */ sl@0: iResult = s1len = s2len = 0; sl@0: } else if ((valuePtr->typePtr == &tclByteArrayType) sl@0: && (value2Ptr->typePtr == &tclByteArrayType)) { sl@0: s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len); sl@0: s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len); sl@0: iResult = memcmp(s1, s2, sl@0: (size_t) ((s1len < s2len) ? s1len : s2len)); sl@0: } else if (((valuePtr->typePtr == &tclStringType) sl@0: && (value2Ptr->typePtr == &tclStringType))) { sl@0: /* sl@0: * Do a unicode-specific comparison if both of the args are of sl@0: * String type. If the char length == byte length, we can do a sl@0: * memcmp. In benchmark testing this proved the most efficient sl@0: * check between the unicode and string comparison operations. sl@0: */ sl@0: sl@0: s1len = Tcl_GetCharLength(valuePtr); sl@0: s2len = Tcl_GetCharLength(value2Ptr); sl@0: if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) { sl@0: iResult = memcmp(valuePtr->bytes, value2Ptr->bytes, sl@0: (unsigned) ((s1len < s2len) ? s1len : s2len)); sl@0: } else { sl@0: iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr), sl@0: Tcl_GetUnicode(value2Ptr), sl@0: (unsigned) ((s1len < s2len) ? s1len : s2len)); sl@0: } sl@0: } else { sl@0: /* sl@0: * We can't do a simple memcmp in order to handle the sl@0: * special Tcl \xC0\x80 null encoding for utf-8. sl@0: */ sl@0: s1 = Tcl_GetStringFromObj(valuePtr, &s1len); sl@0: s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); sl@0: iResult = TclpUtfNcmp2(s1, s2, sl@0: (size_t) ((s1len < s2len) ? s1len : s2len)); sl@0: } sl@0: sl@0: /* sl@0: * Make sure only -1,0,1 is returned sl@0: */ sl@0: if (iResult == 0) { sl@0: iResult = s1len - s2len; sl@0: } sl@0: if (iResult < 0) { sl@0: iResult = -1; sl@0: } else if (iResult > 0) { sl@0: iResult = 1; sl@0: } sl@0: sl@0: objResultPtr = Tcl_NewIntObj(iResult); sl@0: TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult)); sl@0: NEXT_INST_F(1, 2, 1); sl@0: } sl@0: sl@0: case INST_STR_LEN: sl@0: { sl@0: int length1; sl@0: sl@0: valuePtr = stackPtr[stackTop]; sl@0: sl@0: if (valuePtr->typePtr == &tclByteArrayType) { sl@0: (void) Tcl_GetByteArrayFromObj(valuePtr, &length1); sl@0: } else { sl@0: length1 = Tcl_GetCharLength(valuePtr); sl@0: } sl@0: objResultPtr = Tcl_NewIntObj(length1); sl@0: TRACE(("%.20s => %d\n", O2S(valuePtr), length1)); sl@0: NEXT_INST_F(1, 1, 1); sl@0: } sl@0: sl@0: case INST_STR_INDEX: sl@0: { sl@0: /* sl@0: * String compare sl@0: */ sl@0: int index; sl@0: bytes = NULL; /* lint */ sl@0: sl@0: value2Ptr = stackPtr[stackTop]; sl@0: valuePtr = stackPtr[stackTop - 1]; sl@0: sl@0: /* sl@0: * If we have a ByteArray object, avoid indexing in the sl@0: * Utf string since the byte array contains one byte per sl@0: * character. Otherwise, use the Unicode string rep to sl@0: * get the index'th char. sl@0: */ sl@0: sl@0: if (valuePtr->typePtr == &tclByteArrayType) { sl@0: bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length); sl@0: } else { sl@0: /* sl@0: * Get Unicode char length to calulate what 'end' means. sl@0: */ sl@0: length = Tcl_GetCharLength(valuePtr); sl@0: } sl@0: sl@0: result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index); sl@0: if (result != TCL_OK) { sl@0: goto checkForCatch; sl@0: } sl@0: sl@0: if ((index >= 0) && (index < length)) { sl@0: if (valuePtr->typePtr == &tclByteArrayType) { sl@0: objResultPtr = Tcl_NewByteArrayObj((unsigned char *) sl@0: (&bytes[index]), 1); sl@0: } else if (valuePtr->bytes && length == valuePtr->length) { sl@0: objResultPtr = Tcl_NewStringObj((CONST char *) sl@0: (&valuePtr->bytes[index]), 1); sl@0: } else { sl@0: char buf[TCL_UTF_MAX]; sl@0: Tcl_UniChar ch; sl@0: sl@0: ch = Tcl_GetUniChar(valuePtr, index); sl@0: /* sl@0: * This could be: sl@0: * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1) sl@0: * but creating the object as a string seems to be sl@0: * faster in practical use. sl@0: */ sl@0: length = Tcl_UniCharToUtf(ch, buf); sl@0: objResultPtr = Tcl_NewStringObj(buf, length); sl@0: } sl@0: } else { sl@0: TclNewObj(objResultPtr); sl@0: } sl@0: sl@0: TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr), sl@0: O2S(objResultPtr))); sl@0: NEXT_INST_F(1, 2, 1); sl@0: } sl@0: sl@0: case INST_STR_MATCH: sl@0: { sl@0: int nocase, match; sl@0: sl@0: nocase = TclGetInt1AtPtr(pc+1); sl@0: valuePtr = stackPtr[stackTop]; /* String */ sl@0: value2Ptr = stackPtr[stackTop - 1]; /* Pattern */ sl@0: sl@0: /* sl@0: * Check that at least one of the objects is Unicode before sl@0: * promoting both. sl@0: */ sl@0: sl@0: if ((valuePtr->typePtr == &tclStringType) sl@0: || (value2Ptr->typePtr == &tclStringType)) { sl@0: Tcl_UniChar *ustring1, *ustring2; sl@0: int length1, length2; sl@0: sl@0: ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1); sl@0: ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2); sl@0: match = TclUniCharMatch(ustring1, length1, ustring2, length2, sl@0: nocase); sl@0: } else { sl@0: match = Tcl_StringCaseMatch(TclGetString(valuePtr), sl@0: TclGetString(value2Ptr), nocase); sl@0: } sl@0: sl@0: /* sl@0: * Reuse value2Ptr object already on stack if possible. sl@0: * Adjustment is 2 due to the nocase byte sl@0: */ sl@0: sl@0: TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match)); sl@0: if (Tcl_IsShared(value2Ptr)) { sl@0: objResultPtr = Tcl_NewIntObj(match); sl@0: NEXT_INST_F(2, 2, 1); sl@0: } else { /* reuse the valuePtr object */ sl@0: Tcl_SetIntObj(value2Ptr, match); sl@0: NEXT_INST_F(2, 1, 0); sl@0: } sl@0: } sl@0: sl@0: case INST_EQ: sl@0: case INST_NEQ: sl@0: case INST_LT: sl@0: case INST_GT: sl@0: case INST_LE: sl@0: case INST_GE: sl@0: { sl@0: /* sl@0: * Any type is allowed but the two operands must have the sl@0: * same type. We will compute value op value2. sl@0: */ sl@0: sl@0: Tcl_ObjType *t1Ptr, *t2Ptr; sl@0: char *s1 = NULL; /* Init. avoids compiler warning. */ sl@0: char *s2 = NULL; /* Init. avoids compiler warning. */ sl@0: long i2 = 0; /* Init. avoids compiler warning. */ sl@0: double d1 = 0.0; /* Init. avoids compiler warning. */ sl@0: double d2 = 0.0; /* Init. avoids compiler warning. */ sl@0: long iResult = 0; /* Init. avoids compiler warning. */ sl@0: sl@0: value2Ptr = stackPtr[stackTop]; sl@0: valuePtr = stackPtr[stackTop - 1]; sl@0: sl@0: /* sl@0: * Be careful in the equal-object case; 'NaN' isn't supposed sl@0: * to be equal to even itself. [Bug 761471] sl@0: */ sl@0: sl@0: t1Ptr = valuePtr->typePtr; sl@0: if (valuePtr == value2Ptr) { sl@0: /* sl@0: * If we are numeric already, we can proceed to the main sl@0: * equality check right now. Otherwise, we need to try to sl@0: * coerce to a numeric type so we can see if we've got a sl@0: * NaN but haven't parsed it as numeric. sl@0: */ sl@0: if (!IS_NUMERIC_TYPE(t1Ptr)) { sl@0: if (t1Ptr == &tclListType) { sl@0: int length; sl@0: /* sl@0: * Only a list of length 1 can be NaN or such sl@0: * things. sl@0: */ sl@0: (void) Tcl_ListObjLength(NULL, valuePtr, &length); sl@0: if (length == 1) { sl@0: goto mustConvertForNaNCheck; sl@0: } sl@0: } else { sl@0: /* sl@0: * Too bad, we'll have to compute the string and sl@0: * try the conversion sl@0: */ sl@0: sl@0: mustConvertForNaNCheck: sl@0: s1 = Tcl_GetStringFromObj(valuePtr, &length); sl@0: if (TclLooksLikeInt(s1, length)) { sl@0: GET_WIDE_OR_INT(iResult, valuePtr, i, w); sl@0: } else { sl@0: (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, sl@0: valuePtr, &d1); sl@0: } sl@0: t1Ptr = valuePtr->typePtr; sl@0: } sl@0: } sl@0: sl@0: switch (*pc) { sl@0: case INST_EQ: sl@0: case INST_LE: sl@0: case INST_GE: sl@0: iResult = !((t1Ptr == &tclDoubleType) sl@0: && IS_NAN(valuePtr->internalRep.doubleValue)); sl@0: break; sl@0: case INST_LT: sl@0: case INST_GT: sl@0: iResult = 0; sl@0: break; sl@0: case INST_NEQ: sl@0: iResult = ((t1Ptr == &tclDoubleType) sl@0: && IS_NAN(valuePtr->internalRep.doubleValue)); sl@0: break; sl@0: } sl@0: goto foundResult; sl@0: } sl@0: sl@0: t2Ptr = value2Ptr->typePtr; sl@0: sl@0: /* sl@0: * We only want to coerce numeric validation if neither type sl@0: * is NULL. A NULL type means the arg is essentially an empty sl@0: * object ("", {} or [list]). sl@0: */ sl@0: if (!( (!t1Ptr && !valuePtr->bytes) sl@0: || (valuePtr->bytes && !valuePtr->length) sl@0: || (!t2Ptr && !value2Ptr->bytes) sl@0: || (value2Ptr->bytes && !value2Ptr->length))) { sl@0: if (!IS_NUMERIC_TYPE(t1Ptr)) { sl@0: s1 = Tcl_GetStringFromObj(valuePtr, &length); sl@0: if (TclLooksLikeInt(s1, length)) { sl@0: GET_WIDE_OR_INT(iResult, valuePtr, i, w); sl@0: } else { sl@0: (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, sl@0: valuePtr, &d1); sl@0: } sl@0: t1Ptr = valuePtr->typePtr; sl@0: } sl@0: if (!IS_NUMERIC_TYPE(t2Ptr)) { sl@0: s2 = Tcl_GetStringFromObj(value2Ptr, &length); sl@0: if (TclLooksLikeInt(s2, length)) { sl@0: GET_WIDE_OR_INT(iResult, value2Ptr, i2, w); sl@0: } else { sl@0: (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, sl@0: value2Ptr, &d2); sl@0: } sl@0: t2Ptr = value2Ptr->typePtr; sl@0: } sl@0: } sl@0: if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) { sl@0: /* sl@0: * One operand is not numeric. Compare as strings. NOTE: sl@0: * strcmp is not correct for \x00 < \x01, but that is sl@0: * unlikely to occur here. We could use the TclUtfNCmp2 sl@0: * to handle this. sl@0: */ sl@0: int s1len, s2len; sl@0: s1 = Tcl_GetStringFromObj(valuePtr, &s1len); sl@0: s2 = Tcl_GetStringFromObj(value2Ptr, &s2len); sl@0: switch (*pc) { sl@0: case INST_EQ: sl@0: if (s1len == s2len) { sl@0: iResult = (strcmp(s1, s2) == 0); sl@0: } else { sl@0: iResult = 0; sl@0: } sl@0: break; sl@0: case INST_NEQ: sl@0: if (s1len == s2len) { sl@0: iResult = (strcmp(s1, s2) != 0); sl@0: } else { sl@0: iResult = 1; sl@0: } sl@0: break; sl@0: case INST_LT: sl@0: iResult = (strcmp(s1, s2) < 0); sl@0: break; sl@0: case INST_GT: sl@0: iResult = (strcmp(s1, s2) > 0); sl@0: break; sl@0: case INST_LE: sl@0: iResult = (strcmp(s1, s2) <= 0); sl@0: break; sl@0: case INST_GE: sl@0: iResult = (strcmp(s1, s2) >= 0); sl@0: break; sl@0: } sl@0: } else if ((t1Ptr == &tclDoubleType) sl@0: || (t2Ptr == &tclDoubleType)) { sl@0: /* sl@0: * Compare as doubles. sl@0: */ sl@0: if (t1Ptr == &tclDoubleType) { sl@0: d1 = valuePtr->internalRep.doubleValue; sl@0: GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr); sl@0: } else { /* t1Ptr is integer, t2Ptr is double */ sl@0: GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr); sl@0: d2 = value2Ptr->internalRep.doubleValue; sl@0: } sl@0: switch (*pc) { sl@0: case INST_EQ: sl@0: iResult = d1 == d2; sl@0: break; sl@0: case INST_NEQ: sl@0: iResult = d1 != d2; sl@0: break; sl@0: case INST_LT: sl@0: iResult = d1 < d2; sl@0: break; sl@0: case INST_GT: sl@0: iResult = d1 > d2; sl@0: break; sl@0: case INST_LE: sl@0: iResult = d1 <= d2; sl@0: break; sl@0: case INST_GE: sl@0: iResult = d1 >= d2; sl@0: break; sl@0: } sl@0: } else if ((t1Ptr == &tclWideIntType) sl@0: || (t2Ptr == &tclWideIntType)) { sl@0: Tcl_WideInt w2; sl@0: /* sl@0: * Compare as wide ints (neither are doubles) sl@0: */ sl@0: if (t1Ptr == &tclIntType) { sl@0: w = Tcl_LongAsWide(valuePtr->internalRep.longValue); sl@0: TclGetWide(w2,value2Ptr); sl@0: } else if (t2Ptr == &tclIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue); sl@0: } else { sl@0: TclGetWide(w,valuePtr); sl@0: TclGetWide(w2,value2Ptr); sl@0: } sl@0: switch (*pc) { sl@0: case INST_EQ: sl@0: iResult = w == w2; sl@0: break; sl@0: case INST_NEQ: sl@0: iResult = w != w2; sl@0: break; sl@0: case INST_LT: sl@0: iResult = w < w2; sl@0: break; sl@0: case INST_GT: sl@0: iResult = w > w2; sl@0: break; sl@0: case INST_LE: sl@0: iResult = w <= w2; sl@0: break; sl@0: case INST_GE: sl@0: iResult = w >= w2; sl@0: break; sl@0: } sl@0: } else { sl@0: /* sl@0: * Compare as ints. sl@0: */ sl@0: i = valuePtr->internalRep.longValue; sl@0: i2 = value2Ptr->internalRep.longValue; sl@0: switch (*pc) { sl@0: case INST_EQ: sl@0: iResult = i == i2; sl@0: break; sl@0: case INST_NEQ: sl@0: iResult = i != i2; sl@0: break; sl@0: case INST_LT: sl@0: iResult = i < i2; sl@0: break; sl@0: case INST_GT: sl@0: iResult = i > i2; sl@0: break; sl@0: case INST_LE: sl@0: iResult = i <= i2; sl@0: break; sl@0: case INST_GE: sl@0: iResult = i >= i2; sl@0: break; sl@0: } sl@0: } sl@0: sl@0: foundResult: sl@0: TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult)); sl@0: sl@0: /* sl@0: * Peep-hole optimisation: if you're about to jump, do jump sl@0: * from here. sl@0: */ sl@0: sl@0: pc++; sl@0: #ifndef TCL_COMPILE_DEBUG sl@0: switch (*pc) { sl@0: case INST_JUMP_FALSE1: sl@0: NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0); sl@0: case INST_JUMP_TRUE1: sl@0: NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0); sl@0: case INST_JUMP_FALSE4: sl@0: NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0); sl@0: case INST_JUMP_TRUE4: sl@0: NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0); sl@0: } sl@0: #endif sl@0: objResultPtr = Tcl_NewIntObj(iResult); sl@0: NEXT_INST_F(0, 2, 1); sl@0: } sl@0: sl@0: case INST_MOD: sl@0: case INST_LSHIFT: sl@0: case INST_RSHIFT: sl@0: case INST_BITOR: sl@0: case INST_BITXOR: sl@0: case INST_BITAND: sl@0: { sl@0: /* sl@0: * Only integers are allowed. We compute value op value2. sl@0: */ sl@0: sl@0: long i2 = 0, rem, negative; sl@0: long iResult = 0; /* Init. avoids compiler warning. */ sl@0: Tcl_WideInt w2, wResult = W0; sl@0: int doWide = 0; sl@0: sl@0: value2Ptr = stackPtr[stackTop]; sl@0: valuePtr = stackPtr[stackTop - 1]; sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: i = valuePtr->internalRep.longValue; sl@0: } else if (valuePtr->typePtr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: } else { /* try to convert to int */ sl@0: REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); sl@0: if (result != TCL_OK) { sl@0: TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", sl@0: O2S(valuePtr), O2S(value2Ptr), sl@0: (valuePtr->typePtr? sl@0: valuePtr->typePtr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, valuePtr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: if (value2Ptr->typePtr == &tclIntType) { sl@0: i2 = value2Ptr->internalRep.longValue; sl@0: } else if (value2Ptr->typePtr == &tclWideIntType) { sl@0: TclGetWide(w2,value2Ptr); sl@0: } else { sl@0: REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2); sl@0: if (result != TCL_OK) { sl@0: TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", sl@0: O2S(valuePtr), O2S(value2Ptr), sl@0: (value2Ptr->typePtr? sl@0: value2Ptr->typePtr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, value2Ptr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: sl@0: switch (*pc) { sl@0: case INST_MOD: sl@0: /* sl@0: * This code is tricky: C doesn't guarantee much about sl@0: * the quotient or remainder, but Tcl does. The sl@0: * remainder always has the same sign as the divisor and sl@0: * a smaller absolute value. sl@0: */ sl@0: if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) { sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2)); sl@0: } else { sl@0: TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); sl@0: } sl@0: goto divideByZero; sl@0: } sl@0: if (value2Ptr->typePtr == &tclIntType && i2 == 0) { sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); sl@0: } else { sl@0: TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2)); sl@0: } sl@0: goto divideByZero; sl@0: } sl@0: negative = 0; sl@0: if (valuePtr->typePtr == &tclWideIntType sl@0: || value2Ptr->typePtr == &tclWideIntType) { sl@0: Tcl_WideInt wRemainder; sl@0: /* sl@0: * Promote to wide sl@0: */ sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: w = Tcl_LongAsWide(i); sl@0: } else if (value2Ptr->typePtr == &tclIntType) { sl@0: w2 = Tcl_LongAsWide(i2); sl@0: } sl@0: if (w2 < 0) { sl@0: w2 = -w2; sl@0: w = -w; sl@0: negative = 1; sl@0: } sl@0: wRemainder = w % w2; sl@0: if (wRemainder < 0) { sl@0: wRemainder += w2; sl@0: } sl@0: if (negative) { sl@0: wRemainder = -wRemainder; sl@0: } sl@0: wResult = wRemainder; sl@0: doWide = 1; sl@0: break; sl@0: } sl@0: if (i2 < 0) { sl@0: i2 = -i2; sl@0: i = -i; sl@0: negative = 1; sl@0: } sl@0: rem = i % i2; sl@0: if (rem < 0) { sl@0: rem += i2; sl@0: } sl@0: if (negative) { sl@0: rem = -rem; sl@0: } sl@0: iResult = rem; sl@0: break; sl@0: case INST_LSHIFT: sl@0: /* sl@0: * Shifts are never usefully 64-bits wide! sl@0: */ sl@0: FORCE_LONG(value2Ptr, i2, w2); sl@0: if (valuePtr->typePtr == &tclWideIntType) { sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: w2 = Tcl_LongAsWide(i2); sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: wResult = w; sl@0: /* sl@0: * Shift in steps when the shift gets large to prevent sl@0: * annoying compiler/processor bugs. [Bug 868467] sl@0: */ sl@0: if (i2 >= 64) { sl@0: wResult = Tcl_LongAsWide(0); sl@0: } else if (i2 > 60) { sl@0: wResult = w << 30; sl@0: wResult <<= 30; sl@0: wResult <<= i2-60; sl@0: } else if (i2 > 30) { sl@0: wResult = w << 30; sl@0: wResult <<= i2-30; sl@0: } else { sl@0: wResult = w << i2; sl@0: } sl@0: doWide = 1; sl@0: break; sl@0: } sl@0: /* sl@0: * Shift in steps when the shift gets large to prevent sl@0: * annoying compiler/processor bugs. [Bug 868467] sl@0: */ sl@0: if (i2 >= 64) { sl@0: iResult = 0; sl@0: } else if (i2 > 60) { sl@0: iResult = i << 30; sl@0: iResult <<= 30; sl@0: iResult <<= i2-60; sl@0: } else if (i2 > 30) { sl@0: iResult = i << 30; sl@0: iResult <<= i2-30; sl@0: } else { sl@0: iResult = i << i2; sl@0: } sl@0: break; sl@0: case INST_RSHIFT: sl@0: /* sl@0: * The following code is a bit tricky: it ensures that sl@0: * right shifts propagate the sign bit even on machines sl@0: * where ">>" won't do it by default. sl@0: */ sl@0: /* sl@0: * Shifts are never usefully 64-bits wide! sl@0: */ sl@0: FORCE_LONG(value2Ptr, i2, w2); sl@0: if (valuePtr->typePtr == &tclWideIntType) { sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: w2 = Tcl_LongAsWide(i2); sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: if (w < 0) { sl@0: wResult = ~w; sl@0: } else { sl@0: wResult = w; sl@0: } sl@0: /* sl@0: * Shift in steps when the shift gets large to prevent sl@0: * annoying compiler/processor bugs. [Bug 868467] sl@0: */ sl@0: if (i2 >= 64) { sl@0: wResult = Tcl_LongAsWide(0); sl@0: } else if (i2 > 60) { sl@0: wResult >>= 30; sl@0: wResult >>= 30; sl@0: wResult >>= i2-60; sl@0: } else if (i2 > 30) { sl@0: wResult >>= 30; sl@0: wResult >>= i2-30; sl@0: } else { sl@0: wResult >>= i2; sl@0: } sl@0: if (w < 0) { sl@0: wResult = ~wResult; sl@0: } sl@0: doWide = 1; sl@0: break; sl@0: } sl@0: if (i < 0) { sl@0: iResult = ~i; sl@0: } else { sl@0: iResult = i; sl@0: } sl@0: /* sl@0: * Shift in steps when the shift gets large to prevent sl@0: * annoying compiler/processor bugs. [Bug 868467] sl@0: */ sl@0: if (i2 >= 64) { sl@0: iResult = 0; sl@0: } else if (i2 > 60) { sl@0: iResult >>= 30; sl@0: iResult >>= 30; sl@0: iResult >>= i2-60; sl@0: } else if (i2 > 30) { sl@0: iResult >>= 30; sl@0: iResult >>= i2-30; sl@0: } else { sl@0: iResult >>= i2; sl@0: } sl@0: if (i < 0) { sl@0: iResult = ~iResult; sl@0: } sl@0: break; sl@0: case INST_BITOR: sl@0: if (valuePtr->typePtr == &tclWideIntType sl@0: || value2Ptr->typePtr == &tclWideIntType) { sl@0: /* sl@0: * Promote to wide sl@0: */ sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: w = Tcl_LongAsWide(i); sl@0: } else if (value2Ptr->typePtr == &tclIntType) { sl@0: w2 = Tcl_LongAsWide(i2); sl@0: } sl@0: wResult = w | w2; sl@0: doWide = 1; sl@0: break; sl@0: } sl@0: iResult = i | i2; sl@0: break; sl@0: case INST_BITXOR: sl@0: if (valuePtr->typePtr == &tclWideIntType sl@0: || value2Ptr->typePtr == &tclWideIntType) { sl@0: /* sl@0: * Promote to wide sl@0: */ sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: w = Tcl_LongAsWide(i); sl@0: } else if (value2Ptr->typePtr == &tclIntType) { sl@0: w2 = Tcl_LongAsWide(i2); sl@0: } sl@0: wResult = w ^ w2; sl@0: doWide = 1; sl@0: break; sl@0: } sl@0: iResult = i ^ i2; sl@0: break; sl@0: case INST_BITAND: sl@0: if (valuePtr->typePtr == &tclWideIntType sl@0: || value2Ptr->typePtr == &tclWideIntType) { sl@0: /* sl@0: * Promote to wide sl@0: */ sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: w = Tcl_LongAsWide(i); sl@0: } else if (value2Ptr->typePtr == &tclIntType) { sl@0: w2 = Tcl_LongAsWide(i2); sl@0: } sl@0: wResult = w & w2; sl@0: doWide = 1; sl@0: break; sl@0: } sl@0: iResult = i & i2; sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * Reuse the valuePtr object already on stack if possible. sl@0: */ sl@0: sl@0: if (Tcl_IsShared(valuePtr)) { sl@0: if (doWide) { sl@0: objResultPtr = Tcl_NewWideIntObj(wResult); sl@0: TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); sl@0: } else { sl@0: objResultPtr = Tcl_NewLongObj(iResult); sl@0: TRACE(("%ld %ld => %ld\n", i, i2, iResult)); sl@0: } sl@0: NEXT_INST_F(1, 2, 1); sl@0: } else { /* reuse the valuePtr object */ sl@0: if (doWide) { sl@0: TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); sl@0: Tcl_SetWideIntObj(valuePtr, wResult); sl@0: } else { sl@0: TRACE(("%ld %ld => %ld\n", i, i2, iResult)); sl@0: Tcl_SetLongObj(valuePtr, iResult); sl@0: } sl@0: NEXT_INST_F(1, 1, 0); sl@0: } sl@0: } sl@0: sl@0: case INST_ADD: sl@0: case INST_SUB: sl@0: case INST_MULT: sl@0: case INST_DIV: sl@0: { sl@0: /* sl@0: * Operands must be numeric and ints get converted to floats sl@0: * if necessary. We compute value op value2. sl@0: */ sl@0: sl@0: Tcl_ObjType *t1Ptr, *t2Ptr; sl@0: long i2 = 0, quot, rem; /* Init. avoids compiler warning. */ sl@0: double d1, d2; sl@0: long iResult = 0; /* Init. avoids compiler warning. */ sl@0: double dResult = 0.0; /* Init. avoids compiler warning. */ sl@0: int doDouble = 0; /* 1 if doing floating arithmetic */ sl@0: Tcl_WideInt w2, wquot, wrem; sl@0: Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */ sl@0: int doWide = 0; /* 1 if doing wide arithmetic. */ sl@0: sl@0: value2Ptr = stackPtr[stackTop]; sl@0: valuePtr = stackPtr[stackTop - 1]; sl@0: t1Ptr = valuePtr->typePtr; sl@0: t2Ptr = value2Ptr->typePtr; sl@0: sl@0: if (t1Ptr == &tclIntType) { sl@0: i = valuePtr->internalRep.longValue; sl@0: } else if (t1Ptr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: } else if ((t1Ptr == &tclDoubleType) sl@0: && (valuePtr->bytes == NULL)) { sl@0: /* sl@0: * We can only use the internal rep directly if there is sl@0: * no string rep. Otherwise the string rep might actually sl@0: * look like an integer, which is preferred. sl@0: */ sl@0: sl@0: d1 = valuePtr->internalRep.doubleValue; sl@0: } else { sl@0: char *s = Tcl_GetStringFromObj(valuePtr, &length); sl@0: if (TclLooksLikeInt(s, length)) { sl@0: GET_WIDE_OR_INT(result, valuePtr, i, w); sl@0: } else { sl@0: result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, sl@0: valuePtr, &d1); sl@0: } sl@0: if (result != TCL_OK) { sl@0: TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", sl@0: s, O2S(valuePtr), sl@0: (valuePtr->typePtr? sl@0: valuePtr->typePtr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, valuePtr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: t1Ptr = valuePtr->typePtr; sl@0: } sl@0: sl@0: if (t2Ptr == &tclIntType) { sl@0: i2 = value2Ptr->internalRep.longValue; sl@0: } else if (t2Ptr == &tclWideIntType) { sl@0: TclGetWide(w2,value2Ptr); sl@0: } else if ((t2Ptr == &tclDoubleType) sl@0: && (value2Ptr->bytes == NULL)) { sl@0: /* sl@0: * We can only use the internal rep directly if there is sl@0: * no string rep. Otherwise the string rep might actually sl@0: * look like an integer, which is preferred. sl@0: */ sl@0: sl@0: d2 = value2Ptr->internalRep.doubleValue; sl@0: } else { sl@0: char *s = Tcl_GetStringFromObj(value2Ptr, &length); sl@0: if (TclLooksLikeInt(s, length)) { sl@0: GET_WIDE_OR_INT(result, value2Ptr, i2, w2); sl@0: } else { sl@0: result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, sl@0: value2Ptr, &d2); sl@0: } sl@0: if (result != TCL_OK) { sl@0: TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", sl@0: O2S(value2Ptr), s, sl@0: (value2Ptr->typePtr? sl@0: value2Ptr->typePtr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, value2Ptr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: t2Ptr = value2Ptr->typePtr; sl@0: } sl@0: sl@0: if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) { sl@0: /* sl@0: * Do double arithmetic. sl@0: */ sl@0: doDouble = 1; sl@0: if (t1Ptr == &tclIntType) { sl@0: d1 = i; /* promote value 1 to double */ sl@0: } else if (t2Ptr == &tclIntType) { sl@0: d2 = i2; /* promote value 2 to double */ sl@0: } else if (t1Ptr == &tclWideIntType) { sl@0: d1 = Tcl_WideAsDouble(w); sl@0: } else if (t2Ptr == &tclWideIntType) { sl@0: d2 = Tcl_WideAsDouble(w2); sl@0: } sl@0: switch (*pc) { sl@0: case INST_ADD: sl@0: dResult = d1 + d2; sl@0: break; sl@0: case INST_SUB: sl@0: dResult = d1 - d2; sl@0: break; sl@0: case INST_MULT: sl@0: dResult = d1 * d2; sl@0: break; sl@0: case INST_DIV: sl@0: if (d2 == 0.0) { sl@0: TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2)); sl@0: goto divideByZero; sl@0: } sl@0: dResult = d1 / d2; sl@0: break; sl@0: } sl@0: sl@0: /* sl@0: * Check now for IEEE floating-point error. sl@0: */ sl@0: sl@0: if (IS_NAN(dResult) || IS_INF(dResult)) { sl@0: TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n", sl@0: O2S(valuePtr), O2S(value2Ptr))); sl@0: DECACHE_STACK_INFO(); sl@0: TclExprFloatError(interp, dResult); sl@0: CACHE_STACK_INFO(); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: } else if ((t1Ptr == &tclWideIntType) sl@0: || (t2Ptr == &tclWideIntType)) { sl@0: /* sl@0: * Do wide integer arithmetic. sl@0: */ sl@0: doWide = 1; sl@0: if (t1Ptr == &tclIntType) { sl@0: w = Tcl_LongAsWide(i); sl@0: } else if (t2Ptr == &tclIntType) { sl@0: w2 = Tcl_LongAsWide(i2); sl@0: } sl@0: switch (*pc) { sl@0: case INST_ADD: sl@0: wResult = w + w2; sl@0: break; sl@0: case INST_SUB: sl@0: wResult = w - w2; sl@0: break; sl@0: case INST_MULT: sl@0: wResult = w * w2; sl@0: break; sl@0: case INST_DIV: sl@0: /* sl@0: * This code is tricky: C doesn't guarantee much sl@0: * about the quotient or remainder, but Tcl does. sl@0: * The remainder always has the same sign as the sl@0: * divisor and a smaller absolute value. sl@0: */ sl@0: if (w2 == W0) { sl@0: TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2)); sl@0: goto divideByZero; sl@0: } sl@0: if (w2 < 0) { sl@0: w2 = -w2; sl@0: w = -w; sl@0: } sl@0: wquot = w / w2; sl@0: wrem = w % w2; sl@0: if (wrem < W0) { sl@0: wquot -= 1; sl@0: } sl@0: wResult = wquot; sl@0: break; sl@0: } sl@0: } else { sl@0: /* sl@0: * Do integer arithmetic. sl@0: */ sl@0: switch (*pc) { sl@0: case INST_ADD: sl@0: iResult = i + i2; sl@0: break; sl@0: case INST_SUB: sl@0: iResult = i - i2; sl@0: break; sl@0: case INST_MULT: sl@0: iResult = i * i2; sl@0: break; sl@0: case INST_DIV: sl@0: /* sl@0: * This code is tricky: C doesn't guarantee much sl@0: * about the quotient or remainder, but Tcl does. sl@0: * The remainder always has the same sign as the sl@0: * divisor and a smaller absolute value. sl@0: */ sl@0: if (i2 == 0) { sl@0: TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2)); sl@0: goto divideByZero; sl@0: } sl@0: if (i2 < 0) { sl@0: i2 = -i2; sl@0: i = -i; sl@0: } sl@0: quot = i / i2; sl@0: rem = i % i2; sl@0: if (rem < 0) { sl@0: quot -= 1; sl@0: } sl@0: iResult = quot; sl@0: break; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Reuse the valuePtr object already on stack if possible. sl@0: */ sl@0: sl@0: if (Tcl_IsShared(valuePtr)) { sl@0: if (doDouble) { sl@0: objResultPtr = Tcl_NewDoubleObj(dResult); sl@0: TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); sl@0: } else if (doWide) { sl@0: objResultPtr = Tcl_NewWideIntObj(wResult); sl@0: TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); sl@0: } else { sl@0: objResultPtr = Tcl_NewLongObj(iResult); sl@0: TRACE(("%ld %ld => %ld\n", i, i2, iResult)); sl@0: } sl@0: NEXT_INST_F(1, 2, 1); sl@0: } else { /* reuse the valuePtr object */ sl@0: if (doDouble) { /* NB: stack top is off by 1 */ sl@0: TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult)); sl@0: Tcl_SetDoubleObj(valuePtr, dResult); sl@0: } else if (doWide) { sl@0: TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult)); sl@0: Tcl_SetWideIntObj(valuePtr, wResult); sl@0: } else { sl@0: TRACE(("%ld %ld => %ld\n", i, i2, iResult)); sl@0: Tcl_SetLongObj(valuePtr, iResult); sl@0: } sl@0: NEXT_INST_F(1, 1, 0); sl@0: } sl@0: } sl@0: sl@0: case INST_UPLUS: sl@0: { sl@0: /* sl@0: * Operand must be numeric. sl@0: */ sl@0: sl@0: double d; sl@0: Tcl_ObjType *tPtr; sl@0: sl@0: valuePtr = stackPtr[stackTop]; sl@0: tPtr = valuePtr->typePtr; sl@0: if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) sl@0: || (valuePtr->bytes != NULL))) { sl@0: char *s = Tcl_GetStringFromObj(valuePtr, &length); sl@0: if (TclLooksLikeInt(s, length)) { sl@0: GET_WIDE_OR_INT(result, valuePtr, i, w); sl@0: } else { sl@0: result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d); sl@0: } sl@0: if (result != TCL_OK) { sl@0: TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", sl@0: s, (tPtr? tPtr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, valuePtr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: tPtr = valuePtr->typePtr; sl@0: } sl@0: sl@0: /* sl@0: * Ensure that the operand's string rep is the same as the sl@0: * formatted version of its internal rep. This makes sure sl@0: * that "expr +000123" yields "83", not "000123". We sl@0: * implement this by _discarding_ the string rep since we sl@0: * know it will be regenerated, if needed later, by sl@0: * formatting the internal rep's value. sl@0: */ sl@0: sl@0: if (Tcl_IsShared(valuePtr)) { sl@0: if (tPtr == &tclIntType) { sl@0: i = valuePtr->internalRep.longValue; sl@0: objResultPtr = Tcl_NewLongObj(i); sl@0: } else if (tPtr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: objResultPtr = Tcl_NewWideIntObj(w); sl@0: } else { sl@0: d = valuePtr->internalRep.doubleValue; sl@0: objResultPtr = Tcl_NewDoubleObj(d); sl@0: } sl@0: TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr); sl@0: NEXT_INST_F(1, 1, 1); sl@0: } else { sl@0: Tcl_InvalidateStringRep(valuePtr); sl@0: TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr); sl@0: NEXT_INST_F(1, 0, 0); sl@0: } sl@0: } sl@0: sl@0: case INST_UMINUS: sl@0: case INST_LNOT: sl@0: { sl@0: /* sl@0: * The operand must be numeric or a boolean string as sl@0: * accepted by Tcl_GetBooleanFromObj(). If the operand sl@0: * object is unshared modify it directly, otherwise sl@0: * create a copy to modify: this is "copy on write". sl@0: * Free any old string representation since it is now sl@0: * invalid. sl@0: */ sl@0: sl@0: double d; sl@0: int boolvar; sl@0: Tcl_ObjType *tPtr; sl@0: sl@0: valuePtr = stackPtr[stackTop]; sl@0: tPtr = valuePtr->typePtr; sl@0: if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) sl@0: || (valuePtr->bytes != NULL))) { sl@0: if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { sl@0: valuePtr->typePtr = &tclIntType; sl@0: } else { sl@0: char *s = Tcl_GetStringFromObj(valuePtr, &length); sl@0: if (TclLooksLikeInt(s, length)) { sl@0: GET_WIDE_OR_INT(result, valuePtr, i, w); sl@0: } else { sl@0: result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, sl@0: valuePtr, &d); sl@0: } sl@0: if (result == TCL_ERROR && *pc == INST_LNOT) { sl@0: result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL, sl@0: valuePtr, &boolvar); sl@0: i = (long)boolvar; /* i is long, not int! */ sl@0: } sl@0: if (result != TCL_OK) { sl@0: TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", sl@0: s, (tPtr? tPtr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, valuePtr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: tPtr = valuePtr->typePtr; sl@0: } sl@0: sl@0: if (Tcl_IsShared(valuePtr)) { sl@0: /* sl@0: * Create a new object. sl@0: */ sl@0: if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { sl@0: i = valuePtr->internalRep.longValue; sl@0: objResultPtr = Tcl_NewLongObj( sl@0: (*pc == INST_UMINUS)? -i : !i); sl@0: TRACE_WITH_OBJ(("%ld => ", i), objResultPtr); sl@0: } else if (tPtr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: if (*pc == INST_UMINUS) { sl@0: objResultPtr = Tcl_NewWideIntObj(-w); sl@0: } else { sl@0: objResultPtr = Tcl_NewLongObj(w == W0); sl@0: } sl@0: TRACE_WITH_OBJ((LLD" => ", w), objResultPtr); sl@0: } else { sl@0: d = valuePtr->internalRep.doubleValue; sl@0: if (*pc == INST_UMINUS) { sl@0: objResultPtr = Tcl_NewDoubleObj(-d); sl@0: } else { sl@0: /* sl@0: * Should be able to use "!d", but apparently sl@0: * some compilers can't handle it. sl@0: */ sl@0: objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0); sl@0: } sl@0: TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr); sl@0: } sl@0: NEXT_INST_F(1, 1, 1); sl@0: } else { sl@0: /* sl@0: * valuePtr is unshared. Modify it directly. sl@0: */ sl@0: if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) { sl@0: i = valuePtr->internalRep.longValue; sl@0: Tcl_SetLongObj(valuePtr, sl@0: (*pc == INST_UMINUS)? -i : !i); sl@0: TRACE_WITH_OBJ(("%ld => ", i), valuePtr); sl@0: } else if (tPtr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: if (*pc == INST_UMINUS) { sl@0: Tcl_SetWideIntObj(valuePtr, -w); sl@0: } else { sl@0: Tcl_SetLongObj(valuePtr, w == W0); sl@0: } sl@0: TRACE_WITH_OBJ((LLD" => ", w), valuePtr); sl@0: } else { sl@0: d = valuePtr->internalRep.doubleValue; sl@0: if (*pc == INST_UMINUS) { sl@0: Tcl_SetDoubleObj(valuePtr, -d); sl@0: } else { sl@0: /* sl@0: * Should be able to use "!d", but apparently sl@0: * some compilers can't handle it. sl@0: */ sl@0: Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0); sl@0: } sl@0: TRACE_WITH_OBJ(("%.6g => ", d), valuePtr); sl@0: } sl@0: NEXT_INST_F(1, 0, 0); sl@0: } sl@0: } sl@0: sl@0: case INST_BITNOT: sl@0: { sl@0: /* sl@0: * The operand must be an integer. If the operand object is sl@0: * unshared modify it directly, otherwise modify a copy. sl@0: * Free any old string representation since it is now sl@0: * invalid. sl@0: */ sl@0: sl@0: Tcl_ObjType *tPtr; sl@0: sl@0: valuePtr = stackPtr[stackTop]; sl@0: tPtr = valuePtr->typePtr; sl@0: if (!IS_INTEGER_TYPE(tPtr)) { sl@0: REQUIRE_WIDE_OR_INT(result, valuePtr, i, w); sl@0: if (result != TCL_OK) { /* try to convert to double */ sl@0: TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", sl@0: O2S(valuePtr), (tPtr? tPtr->name : "null"))); sl@0: DECACHE_STACK_INFO(); sl@0: IllegalExprOperandType(interp, pc, valuePtr); sl@0: CACHE_STACK_INFO(); sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: sl@0: if (valuePtr->typePtr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: if (Tcl_IsShared(valuePtr)) { sl@0: objResultPtr = Tcl_NewWideIntObj(~w); sl@0: TRACE(("0x%llx => (%llu)\n", w, ~w)); sl@0: NEXT_INST_F(1, 1, 1); sl@0: } else { sl@0: /* sl@0: * valuePtr is unshared. Modify it directly. sl@0: */ sl@0: Tcl_SetWideIntObj(valuePtr, ~w); sl@0: TRACE(("0x%llx => (%llu)\n", w, ~w)); sl@0: NEXT_INST_F(1, 0, 0); sl@0: } sl@0: } else { sl@0: i = valuePtr->internalRep.longValue; sl@0: if (Tcl_IsShared(valuePtr)) { sl@0: objResultPtr = Tcl_NewLongObj(~i); sl@0: TRACE(("0x%lx => (%lu)\n", i, ~i)); sl@0: NEXT_INST_F(1, 1, 1); sl@0: } else { sl@0: /* sl@0: * valuePtr is unshared. Modify it directly. sl@0: */ sl@0: Tcl_SetLongObj(valuePtr, ~i); sl@0: TRACE(("0x%lx => (%lu)\n", i, ~i)); sl@0: NEXT_INST_F(1, 0, 0); sl@0: } sl@0: } sl@0: } sl@0: sl@0: case INST_CALL_BUILTIN_FUNC1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: { sl@0: /* sl@0: * Call one of the built-in Tcl math functions. sl@0: */ sl@0: sl@0: BuiltinFunc *mathFuncPtr; sl@0: sl@0: if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) { sl@0: TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd)); sl@0: panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd); sl@0: } sl@0: mathFuncPtr = &(tclBuiltinFuncTable[opnd]); sl@0: DECACHE_STACK_INFO(); sl@0: result = (*mathFuncPtr->proc)(interp, eePtr, sl@0: mathFuncPtr->clientData); sl@0: CACHE_STACK_INFO(); sl@0: if (result != TCL_OK) { sl@0: goto checkForCatch; sl@0: } sl@0: TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]); sl@0: } sl@0: NEXT_INST_F(2, 0, 0); sl@0: sl@0: case INST_CALL_FUNC1: sl@0: opnd = TclGetUInt1AtPtr(pc+1); sl@0: { sl@0: /* sl@0: * Call a non-builtin Tcl math function previously sl@0: * registered by a call to Tcl_CreateMathFunc. sl@0: */ sl@0: sl@0: int objc = opnd; /* Number of arguments. The function name sl@0: * is the 0-th argument. */ sl@0: Tcl_Obj **objv; /* The array of arguments. The function sl@0: * name is objv[0]. */ sl@0: sl@0: objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */ sl@0: DECACHE_STACK_INFO(); sl@0: result = ExprCallMathFunc(interp, eePtr, objc, objv); sl@0: CACHE_STACK_INFO(); sl@0: if (result != TCL_OK) { sl@0: goto checkForCatch; sl@0: } sl@0: TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]); sl@0: } sl@0: NEXT_INST_F(2, 0, 0); sl@0: sl@0: case INST_TRY_CVT_TO_NUMERIC: sl@0: { sl@0: /* sl@0: * Try to convert the topmost stack object to an int or sl@0: * double object. This is done in order to support Tcl's sl@0: * policy of interpreting operands if at all possible as sl@0: * first integers, else floating-point numbers. sl@0: */ sl@0: sl@0: double d; sl@0: char *s; sl@0: Tcl_ObjType *tPtr; sl@0: int converted, needNew; sl@0: sl@0: valuePtr = stackPtr[stackTop]; sl@0: tPtr = valuePtr->typePtr; sl@0: converted = 0; sl@0: if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType) sl@0: || (valuePtr->bytes != NULL))) { sl@0: if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) { sl@0: valuePtr->typePtr = &tclIntType; sl@0: converted = 1; sl@0: } else { sl@0: s = Tcl_GetStringFromObj(valuePtr, &length); sl@0: if (TclLooksLikeInt(s, length)) { sl@0: GET_WIDE_OR_INT(result, valuePtr, i, w); sl@0: } else { sl@0: result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, sl@0: valuePtr, &d); sl@0: } sl@0: if (result == TCL_OK) { sl@0: converted = 1; sl@0: } sl@0: result = TCL_OK; /* reset the result variable */ sl@0: } sl@0: tPtr = valuePtr->typePtr; sl@0: } sl@0: sl@0: /* sl@0: * Ensure that the topmost stack object, if numeric, has a sl@0: * string rep the same as the formatted version of its sl@0: * internal rep. This is used, e.g., to make sure that "expr sl@0: * {0001}" yields "1", not "0001". We implement this by sl@0: * _discarding_ the string rep since we know it will be sl@0: * regenerated, if needed later, by formatting the internal sl@0: * rep's value. Also check if there has been an IEEE sl@0: * floating point error. sl@0: */ sl@0: sl@0: objResultPtr = valuePtr; sl@0: needNew = 0; sl@0: if (IS_NUMERIC_TYPE(tPtr)) { sl@0: if (Tcl_IsShared(valuePtr)) { sl@0: if (valuePtr->bytes != NULL) { sl@0: /* sl@0: * We only need to make a copy of the object sl@0: * when it already had a string rep sl@0: */ sl@0: needNew = 1; sl@0: if (tPtr == &tclIntType) { sl@0: i = valuePtr->internalRep.longValue; sl@0: objResultPtr = Tcl_NewLongObj(i); sl@0: } else if (tPtr == &tclWideIntType) { sl@0: TclGetWide(w,valuePtr); sl@0: objResultPtr = Tcl_NewWideIntObj(w); sl@0: } else { sl@0: d = valuePtr->internalRep.doubleValue; sl@0: objResultPtr = Tcl_NewDoubleObj(d); sl@0: } sl@0: tPtr = objResultPtr->typePtr; sl@0: } sl@0: } else { sl@0: Tcl_InvalidateStringRep(valuePtr); sl@0: } sl@0: sl@0: if (tPtr == &tclDoubleType) { sl@0: d = objResultPtr->internalRep.doubleValue; sl@0: if (IS_NAN(d) || IS_INF(d)) { sl@0: TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n", sl@0: O2S(objResultPtr))); sl@0: DECACHE_STACK_INFO(); sl@0: TclExprFloatError(interp, d); sl@0: CACHE_STACK_INFO(); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: converted = converted; /* lint, converted not used. */ sl@0: TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr), sl@0: (converted? "converted" : "not converted"), sl@0: (needNew? "new Tcl_Obj" : "same Tcl_Obj"))); sl@0: } else { sl@0: TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr))); sl@0: } sl@0: if (needNew) { sl@0: NEXT_INST_F(1, 1, 1); sl@0: } else { sl@0: NEXT_INST_F(1, 0, 0); sl@0: } sl@0: } sl@0: sl@0: case INST_BREAK: sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_ResetResult(interp); sl@0: CACHE_STACK_INFO(); sl@0: result = TCL_BREAK; sl@0: cleanup = 0; sl@0: goto processExceptionReturn; sl@0: sl@0: case INST_CONTINUE: sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_ResetResult(interp); sl@0: CACHE_STACK_INFO(); sl@0: result = TCL_CONTINUE; sl@0: cleanup = 0; sl@0: goto processExceptionReturn; sl@0: sl@0: case INST_FOREACH_START4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: { sl@0: /* sl@0: * Initialize the temporary local var that holds the count sl@0: * of the number of iterations of the loop body to -1. sl@0: */ sl@0: sl@0: ForeachInfo *infoPtr = (ForeachInfo *) sl@0: codePtr->auxDataArrayPtr[opnd].clientData; sl@0: int iterTmpIndex = infoPtr->loopCtTemp; sl@0: Var *compiledLocals = iPtr->varFramePtr->compiledLocals; sl@0: Var *iterVarPtr = &(compiledLocals[iterTmpIndex]); sl@0: Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr; sl@0: sl@0: if (oldValuePtr == NULL) { sl@0: iterVarPtr->value.objPtr = Tcl_NewLongObj(-1); sl@0: Tcl_IncrRefCount(iterVarPtr->value.objPtr); sl@0: } else { sl@0: Tcl_SetLongObj(oldValuePtr, -1); sl@0: } sl@0: TclSetVarScalar(iterVarPtr); sl@0: TclClearVarUndefined(iterVarPtr); sl@0: TRACE(("%u => loop iter count temp %d\n", sl@0: opnd, iterTmpIndex)); sl@0: } sl@0: sl@0: #ifndef TCL_COMPILE_DEBUG sl@0: /* sl@0: * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 sl@0: * immediately after INST_FOREACH_START4 - let us just fall sl@0: * through instead of jumping back to the top. sl@0: */ sl@0: sl@0: pc += 5; sl@0: #else sl@0: NEXT_INST_F(5, 0, 0); sl@0: #endif sl@0: case INST_FOREACH_STEP4: sl@0: opnd = TclGetUInt4AtPtr(pc+1); sl@0: { sl@0: /* sl@0: * "Step" a foreach loop (i.e., begin its next iteration) by sl@0: * assigning the next value list element to each loop var. sl@0: */ sl@0: sl@0: ForeachInfo *infoPtr = (ForeachInfo *) sl@0: codePtr->auxDataArrayPtr[opnd].clientData; sl@0: ForeachVarList *varListPtr; sl@0: int numLists = infoPtr->numLists; sl@0: Var *compiledLocals = iPtr->varFramePtr->compiledLocals; sl@0: Tcl_Obj *listPtr; sl@0: Var *iterVarPtr, *listVarPtr; sl@0: int iterNum, listTmpIndex, listLen, numVars; sl@0: int varIndex, valIndex, continueLoop, j; sl@0: sl@0: /* sl@0: * Increment the temp holding the loop iteration number. sl@0: */ sl@0: sl@0: iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]); sl@0: valuePtr = iterVarPtr->value.objPtr; sl@0: iterNum = (valuePtr->internalRep.longValue + 1); sl@0: Tcl_SetLongObj(valuePtr, iterNum); sl@0: sl@0: /* sl@0: * Check whether all value lists are exhausted and we should sl@0: * stop the loop. sl@0: */ sl@0: sl@0: continueLoop = 0; sl@0: listTmpIndex = infoPtr->firstValueTemp; sl@0: for (i = 0; i < numLists; i++) { sl@0: varListPtr = infoPtr->varLists[i]; sl@0: numVars = varListPtr->numVars; sl@0: sl@0: listVarPtr = &(compiledLocals[listTmpIndex]); sl@0: listPtr = listVarPtr->value.objPtr; sl@0: result = Tcl_ListObjLength(interp, listPtr, &listLen); sl@0: if (result != TCL_OK) { sl@0: TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ", sl@0: opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp)); sl@0: goto checkForCatch; sl@0: } sl@0: if (listLen > (iterNum * numVars)) { sl@0: continueLoop = 1; sl@0: } sl@0: listTmpIndex++; sl@0: } sl@0: sl@0: /* sl@0: * If some var in some var list still has a remaining list sl@0: * element iterate one more time. Assign to var the next sl@0: * element from its value list. We already checked above sl@0: * that each list temp holds a valid list object. sl@0: */ sl@0: sl@0: if (continueLoop) { sl@0: listTmpIndex = infoPtr->firstValueTemp; sl@0: for (i = 0; i < numLists; i++) { sl@0: varListPtr = infoPtr->varLists[i]; sl@0: numVars = varListPtr->numVars; sl@0: sl@0: listVarPtr = &(compiledLocals[listTmpIndex]); sl@0: listPtr = listVarPtr->value.objPtr; sl@0: sl@0: valIndex = (iterNum * numVars); sl@0: for (j = 0; j < numVars; j++) { sl@0: Tcl_Obj **elements; sl@0: sl@0: /* sl@0: * The call to TclPtrSetVar might shimmer listPtr, sl@0: * so re-fetch pointers every iteration for safety. sl@0: * See test foreach-10.1. sl@0: */ sl@0: sl@0: Tcl_ListObjGetElements(NULL, listPtr, sl@0: &listLen, &elements); sl@0: if (valIndex >= listLen) { sl@0: TclNewObj(valuePtr); sl@0: } else { sl@0: valuePtr = elements[valIndex]; sl@0: } sl@0: sl@0: varIndex = varListPtr->varIndexes[j]; sl@0: varPtr = &(varFramePtr->compiledLocals[varIndex]); sl@0: part1 = varPtr->name; sl@0: while (TclIsVarLink(varPtr)) { sl@0: varPtr = varPtr->value.linkPtr; sl@0: } sl@0: if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL)) sl@0: && (varPtr->tracePtr == NULL) sl@0: && (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) { sl@0: value2Ptr = varPtr->value.objPtr; sl@0: if (valuePtr != value2Ptr) { sl@0: if (value2Ptr != NULL) { sl@0: TclDecrRefCount(value2Ptr); sl@0: } else { sl@0: TclSetVarScalar(varPtr); sl@0: TclClearVarUndefined(varPtr); sl@0: } sl@0: varPtr->value.objPtr = valuePtr; sl@0: Tcl_IncrRefCount(valuePtr); sl@0: } sl@0: } else { sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_IncrRefCount(valuePtr); sl@0: value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1, sl@0: NULL, valuePtr, TCL_LEAVE_ERR_MSG); sl@0: TclDecrRefCount(valuePtr); sl@0: CACHE_STACK_INFO(); sl@0: if (value2Ptr == NULL) { sl@0: TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ", sl@0: opnd, varIndex), sl@0: Tcl_GetObjResult(interp)); sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: } sl@0: } sl@0: valIndex++; sl@0: } sl@0: listTmpIndex++; sl@0: } sl@0: } sl@0: TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists, sl@0: iterNum, (continueLoop? "continue" : "exit"))); sl@0: sl@0: /* sl@0: * Run-time peep-hole optimisation: the compiler ALWAYS follows sl@0: * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that sl@0: * instruction and jump direct from here. sl@0: */ sl@0: sl@0: pc += 5; sl@0: if (*pc == INST_JUMP_FALSE1) { sl@0: NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0); sl@0: } else { sl@0: NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0); sl@0: } sl@0: } sl@0: sl@0: case INST_BEGIN_CATCH4: sl@0: /* sl@0: * Record start of the catch command with exception range index sl@0: * equal to the operand. Push the current stack depth onto the sl@0: * special catch stack. sl@0: */ sl@0: catchStackPtr[++catchTop] = stackTop; sl@0: TRACE(("%u => catchTop=%d, stackTop=%d\n", sl@0: TclGetUInt4AtPtr(pc+1), catchTop, stackTop)); sl@0: NEXT_INST_F(5, 0, 0); sl@0: sl@0: case INST_END_CATCH: sl@0: catchTop--; sl@0: result = TCL_OK; sl@0: TRACE(("=> catchTop=%d\n", catchTop)); sl@0: NEXT_INST_F(1, 0, 0); sl@0: sl@0: case INST_PUSH_RESULT: sl@0: objResultPtr = Tcl_GetObjResult(interp); sl@0: TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp)); sl@0: sl@0: /* sl@0: * See the comments at INST_INVOKE_STK sl@0: */ sl@0: { sl@0: Tcl_Obj *newObjResultPtr; sl@0: TclNewObj(newObjResultPtr); sl@0: Tcl_IncrRefCount(newObjResultPtr); sl@0: iPtr->objResultPtr = newObjResultPtr; sl@0: } sl@0: sl@0: NEXT_INST_F(1, 0, -1); sl@0: sl@0: case INST_PUSH_RETURN_CODE: sl@0: objResultPtr = Tcl_NewLongObj(result); sl@0: TRACE(("=> %u\n", result)); sl@0: NEXT_INST_F(1, 0, 1); sl@0: sl@0: default: sl@0: panic("TclExecuteByteCode: unrecognized opCode %u", *pc); sl@0: } /* end of switch on opCode */ sl@0: sl@0: /* sl@0: * Division by zero in an expression. Control only reaches this sl@0: * point by "goto divideByZero". sl@0: */ sl@0: sl@0: divideByZero: sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", sl@0: (char *) NULL); sl@0: CACHE_STACK_INFO(); sl@0: sl@0: result = TCL_ERROR; sl@0: goto checkForCatch; sl@0: sl@0: /* sl@0: * An external evaluation (INST_INVOKE or INST_EVAL) returned sl@0: * something different from TCL_OK, or else INST_BREAK or sl@0: * INST_CONTINUE were called. sl@0: */ sl@0: sl@0: processExceptionReturn: sl@0: #if TCL_COMPILE_DEBUG sl@0: switch (*pc) { sl@0: case INST_INVOKE_STK1: sl@0: case INST_INVOKE_STK4: sl@0: TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf)); sl@0: break; sl@0: case INST_EVAL_STK: sl@0: /* sl@0: * Note that the object at stacktop has to be used sl@0: * before doing the cleanup. sl@0: */ sl@0: sl@0: TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop]))); sl@0: break; sl@0: default: sl@0: TRACE(("=> ")); sl@0: } sl@0: #endif sl@0: if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) { sl@0: rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr); sl@0: if (rangePtr == NULL) { sl@0: TRACE_APPEND(("no encl. loop or catch, returning %s\n", sl@0: StringForResultCode(result))); sl@0: goto abnormalReturn; sl@0: } sl@0: if (rangePtr->type == CATCH_EXCEPTION_RANGE) { sl@0: TRACE_APPEND(("%s ...\n", StringForResultCode(result))); sl@0: goto processCatch; sl@0: } sl@0: while (cleanup--) { sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: } sl@0: if (result == TCL_BREAK) { sl@0: result = TCL_OK; sl@0: pc = (codePtr->codeStart + rangePtr->breakOffset); sl@0: TRACE_APPEND(("%s, range at %d, new pc %d\n", sl@0: StringForResultCode(result), sl@0: rangePtr->codeOffset, rangePtr->breakOffset)); sl@0: NEXT_INST_F(0, 0, 0); sl@0: } else { sl@0: if (rangePtr->continueOffset == -1) { sl@0: TRACE_APPEND(("%s, loop w/o continue, checking for catch\n", sl@0: StringForResultCode(result))); sl@0: goto checkForCatch; sl@0: } sl@0: result = TCL_OK; sl@0: pc = (codePtr->codeStart + rangePtr->continueOffset); sl@0: TRACE_APPEND(("%s, range at %d, new pc %d\n", sl@0: StringForResultCode(result), sl@0: rangePtr->codeOffset, rangePtr->continueOffset)); sl@0: NEXT_INST_F(0, 0, 0); sl@0: } sl@0: #if TCL_COMPILE_DEBUG sl@0: } else if (traceInstructions) { sl@0: if ((result != TCL_ERROR) && (result != TCL_RETURN)) { sl@0: objPtr = Tcl_GetObjResult(interp); sl@0: TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ", sl@0: result, O2S(objPtr))); sl@0: } else { sl@0: objPtr = Tcl_GetObjResult(interp); sl@0: TRACE_APPEND(("%s, result= \"%s\"\n", sl@0: StringForResultCode(result), O2S(objPtr))); sl@0: } sl@0: #endif sl@0: } sl@0: sl@0: /* sl@0: * Execution has generated an "exception" such as TCL_ERROR. If the sl@0: * exception is an error, record information about what was being sl@0: * executed when the error occurred. Find the closest enclosing sl@0: * catch range, if any. If no enclosing catch range is found, stop sl@0: * execution and return the "exception" code. sl@0: */ sl@0: sl@0: checkForCatch: sl@0: if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) { sl@0: bytes = GetSrcInfoForPc(pc, codePtr, &length); sl@0: if (bytes != NULL) { sl@0: DECACHE_STACK_INFO(); sl@0: Tcl_LogCommandInfo(interp, codePtr->source, bytes, length); sl@0: CACHE_STACK_INFO(); sl@0: iPtr->flags |= ERR_ALREADY_LOGGED; sl@0: } sl@0: } sl@0: if (catchTop == -1) { sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: if (traceInstructions) { sl@0: fprintf(stdout, " ... no enclosing catch, returning %s\n", sl@0: StringForResultCode(result)); sl@0: } sl@0: #endif sl@0: goto abnormalReturn; sl@0: } sl@0: rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr); sl@0: if (rangePtr == NULL) { sl@0: /* sl@0: * This is only possible when compiling a [catch] that sends its sl@0: * script to INST_EVAL. Cannot correct the compiler without sl@0: * breakingcompat with previous .tbc compiled scripts. sl@0: */ sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: if (traceInstructions) { sl@0: fprintf(stdout, " ... no enclosing catch, returning %s\n", sl@0: StringForResultCode(result)); sl@0: } sl@0: #endif sl@0: goto abnormalReturn; sl@0: } sl@0: sl@0: /* sl@0: * A catch exception range (rangePtr) was found to handle an sl@0: * "exception". It was found either by checkForCatch just above or sl@0: * by an instruction during break, continue, or error processing. sl@0: * Jump to its catchOffset after unwinding the operand stack to sl@0: * the depth it had when starting to execute the range's catch sl@0: * command. sl@0: */ sl@0: sl@0: processCatch: sl@0: while (stackTop > catchStackPtr[catchTop]) { sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: } sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: if (traceInstructions) { sl@0: fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n", sl@0: rangePtr->codeOffset, catchTop, catchStackPtr[catchTop], sl@0: (unsigned int)(rangePtr->catchOffset)); sl@0: } sl@0: #endif sl@0: pc = (codePtr->codeStart + rangePtr->catchOffset); sl@0: NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */ sl@0: sl@0: /* sl@0: * end of infinite loop dispatching on instructions. sl@0: */ sl@0: sl@0: /* sl@0: * Abnormal return code. Restore the stack to state it had when starting sl@0: * to execute the ByteCode. Panic if the stack is below the initial level. sl@0: */ sl@0: sl@0: abnormalReturn: sl@0: while (stackTop > initStackTop) { sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: } sl@0: if (stackTop < initStackTop) { sl@0: fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n", sl@0: (unsigned int)(pc - codePtr->codeStart), sl@0: (unsigned int) stackTop, sl@0: (unsigned int) initStackTop); sl@0: panic("TclExecuteByteCode execution failure: end stack top < start stack top"); sl@0: } sl@0: sl@0: /* sl@0: * Free the catch stack array if malloc'ed storage was used. sl@0: */ sl@0: sl@0: if (catchStackPtr != catchStackStorage) { sl@0: ckfree((char *) catchStackPtr); sl@0: } sl@0: eePtr->stackTop = initStackTop; sl@0: return result; sl@0: #undef STATIC_CATCH_STACK_SIZE sl@0: } sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * PrintByteCodeInfo -- sl@0: * sl@0: * This procedure prints a summary about a bytecode object to stdout. sl@0: * It is called by TclExecuteByteCode when starting to execute the sl@0: * bytecode object if tclTraceExec has the value 2 or more. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: PrintByteCodeInfo(codePtr) sl@0: register ByteCode *codePtr; /* The bytecode whose summary is printed sl@0: * to stdout. */ sl@0: { sl@0: Proc *procPtr = codePtr->procPtr; sl@0: Interp *iPtr = (Interp *) *codePtr->interpHandle; sl@0: sl@0: fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", sl@0: (unsigned int) codePtr, codePtr->refCount, sl@0: codePtr->compileEpoch, (unsigned int) iPtr, sl@0: iPtr->compileEpoch); sl@0: sl@0: fprintf(stdout, " Source: "); sl@0: TclPrintSource(stdout, codePtr->source, 60); sl@0: sl@0: fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", sl@0: codePtr->numCommands, codePtr->numSrcBytes, sl@0: codePtr->numCodeBytes, codePtr->numLitObjects, sl@0: codePtr->numAuxDataItems, codePtr->maxStackDepth, sl@0: #ifdef TCL_COMPILE_STATS sl@0: (codePtr->numSrcBytes? sl@0: ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); sl@0: #else sl@0: 0.0); sl@0: #endif sl@0: #ifdef TCL_COMPILE_STATS sl@0: fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", sl@0: codePtr->structureSize, sl@0: (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), sl@0: codePtr->numCodeBytes, sl@0: (codePtr->numLitObjects * sizeof(Tcl_Obj *)), sl@0: (codePtr->numExceptRanges * sizeof(ExceptionRange)), sl@0: (codePtr->numAuxDataItems * sizeof(AuxData)), sl@0: codePtr->numCmdLocBytes); sl@0: #endif /* TCL_COMPILE_STATS */ sl@0: if (procPtr != NULL) { sl@0: fprintf(stdout, sl@0: " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", sl@0: (unsigned int) procPtr, procPtr->refCount, sl@0: procPtr->numArgs, procPtr->numCompiledLocals); sl@0: } sl@0: } sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ValidatePcAndStackTop -- sl@0: * sl@0: * This procedure is called by TclExecuteByteCode when debugging to sl@0: * verify that the program counter and stack top are valid during sl@0: * execution. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * Prints a message to stderr and panics if either the pc or stack sl@0: * top are invalid. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: static void sl@0: ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound) sl@0: register ByteCode *codePtr; /* The bytecode whose summary is printed sl@0: * to stdout. */ sl@0: unsigned char *pc; /* Points to first byte of a bytecode sl@0: * instruction. The program counter. */ sl@0: int stackTop; /* Current stack top. Must be between sl@0: * stackLowerBound and stackUpperBound sl@0: * (inclusive). */ sl@0: int stackLowerBound; /* Smallest legal value for stackTop. */ sl@0: { sl@0: int stackUpperBound = stackLowerBound + codePtr->maxStackDepth; sl@0: /* Greatest legal value for stackTop. */ sl@0: unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart); sl@0: unsigned int codeStart = (unsigned int) codePtr->codeStart; sl@0: unsigned int codeEnd = (unsigned int) sl@0: (codePtr->codeStart + codePtr->numCodeBytes); sl@0: unsigned char opCode = *pc; sl@0: sl@0: if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) { sl@0: fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n", sl@0: (unsigned int) pc); sl@0: panic("TclExecuteByteCode execution failure: bad pc"); sl@0: } sl@0: if ((unsigned int) opCode > LAST_INST_OPCODE) { sl@0: fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n", sl@0: (unsigned int) opCode, relativePc); sl@0: panic("TclExecuteByteCode execution failure: bad opcode"); sl@0: } sl@0: if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) { sl@0: int numChars; sl@0: char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars); sl@0: char *ellipsis = ""; sl@0: sl@0: fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)", sl@0: stackTop, relativePc, stackLowerBound, stackUpperBound); sl@0: if (cmd != NULL) { sl@0: if (numChars > 100) { sl@0: numChars = 100; sl@0: ellipsis = "..."; sl@0: } sl@0: fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd, sl@0: ellipsis); sl@0: } else { sl@0: fprintf(stderr, "\n"); sl@0: } sl@0: panic("TclExecuteByteCode execution failure: bad stack top"); sl@0: } sl@0: } sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * IllegalExprOperandType -- sl@0: * sl@0: * Used by TclExecuteByteCode to add an error message to errorInfo sl@0: * when an illegal operand type is detected by an expression sl@0: * instruction. The argument opndPtr holds the operand object in error. sl@0: * sl@0: * Results: sl@0: * None. sl@0: * sl@0: * Side effects: sl@0: * An error message is appended to errorInfo. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static void sl@0: IllegalExprOperandType(interp, pc, opndPtr) sl@0: Tcl_Interp *interp; /* Interpreter to which error information sl@0: * pertains. */ sl@0: unsigned char *pc; /* Points to the instruction being executed sl@0: * when the illegal type was found. */ sl@0: Tcl_Obj *opndPtr; /* Points to the operand holding the value sl@0: * with the illegal type. */ sl@0: { sl@0: unsigned char opCode = *pc; sl@0: sl@0: Tcl_ResetResult(interp); sl@0: if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "can't use empty string as operand of \"", sl@0: operatorStrings[opCode - INST_LOR], "\"", (char *) NULL); sl@0: } else { sl@0: char *msg = "non-numeric string"; sl@0: char *s, *p; sl@0: int length; sl@0: int looksLikeInt = 0; sl@0: sl@0: s = Tcl_GetStringFromObj(opndPtr, &length); sl@0: p = s; sl@0: /* sl@0: * strtod() isn't at all consistent about detecting Inf and sl@0: * NaN between platforms. sl@0: */ sl@0: if (length == 3) { sl@0: if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') && sl@0: (s[2]=='n' || s[2]=='N')) { sl@0: msg = "non-numeric floating-point value"; sl@0: goto makeErrorMessage; sl@0: } sl@0: if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') && sl@0: (s[2]=='f' || s[2]=='F')) { sl@0: msg = "infinite floating-point value"; sl@0: goto makeErrorMessage; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * We cannot use TclLooksLikeInt here because it passes strings sl@0: * like "10;" [Bug 587140]. We'll accept as "looking like ints" sl@0: * for the present purposes any string that looks formally like sl@0: * a (decimal|octal|hex) integer. sl@0: */ sl@0: sl@0: while (length && isspace(UCHAR(*p))) { sl@0: length--; sl@0: p++; sl@0: } sl@0: if (length && ((*p == '+') || (*p == '-'))) { sl@0: length--; sl@0: p++; sl@0: } sl@0: if (length) { sl@0: if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) { sl@0: p += 2; sl@0: length -= 2; sl@0: looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p))); sl@0: if (looksLikeInt) { sl@0: length--; sl@0: p++; sl@0: while (length && isxdigit(UCHAR(*p))) { sl@0: length--; sl@0: p++; sl@0: } sl@0: } sl@0: } else { sl@0: looksLikeInt = (length && isdigit(UCHAR(*p))); sl@0: if (looksLikeInt) { sl@0: length--; sl@0: p++; sl@0: while (length && isdigit(UCHAR(*p))) { sl@0: length--; sl@0: p++; sl@0: } sl@0: } sl@0: } sl@0: while (length && isspace(UCHAR(*p))) { sl@0: length--; sl@0: p++; sl@0: } sl@0: looksLikeInt = !length; sl@0: } sl@0: if (looksLikeInt) { sl@0: /* sl@0: * If something that looks like an integer could not be sl@0: * converted, then it *must* be a bad octal or too large sl@0: * to represent [Bug 542588]. sl@0: */ sl@0: sl@0: if (TclCheckBadOctal(NULL, s)) { sl@0: msg = "invalid octal number"; sl@0: } else { sl@0: msg = "integer value too large to represent"; sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", sl@0: "integer value too large to represent", (char *) NULL); sl@0: } sl@0: } else { sl@0: /* sl@0: * See if the operand can be interpreted as a double in sl@0: * order to improve the error message. sl@0: */ sl@0: sl@0: double d; sl@0: sl@0: if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) { sl@0: msg = "floating-point value"; sl@0: } sl@0: } sl@0: makeErrorMessage: sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ", sl@0: msg, " as operand of \"", operatorStrings[opCode - INST_LOR], sl@0: "\"", (char *) NULL); sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclGetSrcInfoForPc, GetSrcInfoForPc -- sl@0: * sl@0: * Given a program counter value, finds the closest command in the sl@0: * bytecode code unit's CmdLocation array and returns information about sl@0: * that command's source: a pointer to its first byte and the number of sl@0: * characters. sl@0: * sl@0: * Results: sl@0: * If a command is found that encloses the program counter value, a sl@0: * pointer to the command's source is returned and the length of the sl@0: * source is stored at *lengthPtr. If multiple commands resulted in sl@0: * code at pc, information about the closest enclosing command is sl@0: * returned. If no matching command is found, NULL is returned and sl@0: * *lengthPtr is unchanged. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_TIP280 sl@0: void sl@0: TclGetSrcInfoForPc (cfPtr) sl@0: CmdFrame* cfPtr; sl@0: { sl@0: ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr; sl@0: sl@0: if (cfPtr->cmd.str.cmd == NULL) { sl@0: cfPtr->cmd.str.cmd = GetSrcInfoForPc((char*) cfPtr->data.tebc.pc, sl@0: codePtr, sl@0: &cfPtr->cmd.str.len); sl@0: } sl@0: sl@0: if (cfPtr->cmd.str.cmd != NULL) { sl@0: /* We now have the command. We can get the srcOffset back and sl@0: * from there find the list of word locations for this command sl@0: */ sl@0: sl@0: ExtCmdLoc* eclPtr; sl@0: ECL* locPtr = NULL; sl@0: int srcOffset; sl@0: sl@0: Interp* iPtr = (Interp*) *codePtr->interpHandle; sl@0: Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); sl@0: sl@0: if (!hePtr) return; sl@0: sl@0: srcOffset = cfPtr->cmd.str.cmd - codePtr->source; sl@0: eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); sl@0: sl@0: { sl@0: int i; sl@0: for (i=0; i < eclPtr->nuloc; i++) { sl@0: if (eclPtr->loc [i].srcOffset == srcOffset) { sl@0: locPtr = &(eclPtr->loc [i]); sl@0: break; sl@0: } sl@0: } sl@0: } sl@0: sl@0: if (locPtr == NULL) {Tcl_Panic ("LocSearch failure");} sl@0: sl@0: cfPtr->line = locPtr->line; sl@0: cfPtr->nline = locPtr->nline; sl@0: cfPtr->type = eclPtr->type; sl@0: sl@0: if (eclPtr->type == TCL_LOCATION_SOURCE) { sl@0: cfPtr->data.eval.path = eclPtr->path; sl@0: Tcl_IncrRefCount (cfPtr->data.eval.path); sl@0: } sl@0: /* Do not set cfPtr->data.eval.path NULL for non-SOURCE sl@0: * Needed for cfPtr->data.tebc.codePtr. sl@0: */ sl@0: } sl@0: } sl@0: #endif sl@0: sl@0: static char * sl@0: GetSrcInfoForPc(pc, codePtr, lengthPtr) sl@0: unsigned char *pc; /* The program counter value for which to sl@0: * return the closest command's source info. sl@0: * This points to a bytecode instruction sl@0: * in codePtr's code. */ sl@0: ByteCode *codePtr; /* The bytecode sequence in which to look sl@0: * up the command source for the pc. */ sl@0: int *lengthPtr; /* If non-NULL, the location where the sl@0: * length of the command's source should be sl@0: * stored. If NULL, no length is stored. */ sl@0: { sl@0: register int pcOffset = (pc - codePtr->codeStart); sl@0: int numCmds = codePtr->numCommands; sl@0: unsigned char *codeDeltaNext, *codeLengthNext; sl@0: unsigned char *srcDeltaNext, *srcLengthNext; sl@0: int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i; sl@0: int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */ sl@0: int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */ sl@0: int bestSrcLength = -1; /* Initialized to avoid compiler warning. */ sl@0: sl@0: if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) { sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * Decode the code and source offset and length for each command. The sl@0: * closest enclosing command is the last one whose code started before sl@0: * pcOffset. sl@0: */ sl@0: sl@0: codeDeltaNext = codePtr->codeDeltaStart; sl@0: codeLengthNext = codePtr->codeLengthStart; sl@0: srcDeltaNext = codePtr->srcDeltaStart; sl@0: srcLengthNext = codePtr->srcLengthStart; sl@0: codeOffset = srcOffset = 0; sl@0: for (i = 0; i < numCmds; i++) { sl@0: if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { sl@0: codeDeltaNext++; sl@0: delta = TclGetInt4AtPtr(codeDeltaNext); sl@0: codeDeltaNext += 4; sl@0: } else { sl@0: delta = TclGetInt1AtPtr(codeDeltaNext); sl@0: codeDeltaNext++; sl@0: } sl@0: codeOffset += delta; sl@0: sl@0: if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { sl@0: codeLengthNext++; sl@0: codeLen = TclGetInt4AtPtr(codeLengthNext); sl@0: codeLengthNext += 4; sl@0: } else { sl@0: codeLen = TclGetInt1AtPtr(codeLengthNext); sl@0: codeLengthNext++; sl@0: } sl@0: codeEnd = (codeOffset + codeLen - 1); sl@0: sl@0: if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { sl@0: srcDeltaNext++; sl@0: delta = TclGetInt4AtPtr(srcDeltaNext); sl@0: srcDeltaNext += 4; sl@0: } else { sl@0: delta = TclGetInt1AtPtr(srcDeltaNext); sl@0: srcDeltaNext++; sl@0: } sl@0: srcOffset += delta; sl@0: sl@0: if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { sl@0: srcLengthNext++; sl@0: srcLen = TclGetInt4AtPtr(srcLengthNext); sl@0: srcLengthNext += 4; sl@0: } else { sl@0: srcLen = TclGetInt1AtPtr(srcLengthNext); sl@0: srcLengthNext++; sl@0: } sl@0: sl@0: if (codeOffset > pcOffset) { /* best cmd already found */ sl@0: break; sl@0: } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */ sl@0: int dist = (pcOffset - codeOffset); sl@0: if (dist <= bestDist) { sl@0: bestDist = dist; sl@0: bestSrcOffset = srcOffset; sl@0: bestSrcLength = srcLen; sl@0: } sl@0: } sl@0: } sl@0: sl@0: if (bestDist == INT_MAX) { sl@0: return NULL; sl@0: } sl@0: sl@0: if (lengthPtr != NULL) { sl@0: *lengthPtr = bestSrcLength; sl@0: } sl@0: return (codePtr->source + bestSrcOffset); sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetExceptRangeForPc -- sl@0: * sl@0: * Given a program counter value, return the closest enclosing sl@0: * ExceptionRange. sl@0: * sl@0: * Results: sl@0: * In the normal case, catchOnly is 0 (false) and this procedure sl@0: * returns a pointer to the most closely enclosing ExceptionRange sl@0: * structure regardless of whether it is a loop or catch exception sl@0: * range. This is appropriate when processing a TCL_BREAK or sl@0: * TCL_CONTINUE, which will be "handled" either by a loop exception sl@0: * range or a closer catch range. If catchOnly is nonzero, this sl@0: * procedure ignores loop exception ranges and returns a pointer to the sl@0: * closest catch range. If no matching ExceptionRange is found that sl@0: * encloses pc, a NULL is returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static ExceptionRange * sl@0: GetExceptRangeForPc(pc, catchOnly, codePtr) sl@0: unsigned char *pc; /* The program counter value for which to sl@0: * search for a closest enclosing exception sl@0: * range. This points to a bytecode sl@0: * instruction in codePtr's code. */ sl@0: int catchOnly; /* If 0, consider either loop or catch sl@0: * ExceptionRanges in search. If nonzero sl@0: * consider only catch ranges (and ignore sl@0: * any closer loop ranges). */ sl@0: ByteCode* codePtr; /* Points to the ByteCode in which to search sl@0: * for the enclosing ExceptionRange. */ sl@0: { sl@0: ExceptionRange *rangeArrayPtr; sl@0: int numRanges = codePtr->numExceptRanges; sl@0: register ExceptionRange *rangePtr; sl@0: int pcOffset = (pc - codePtr->codeStart); sl@0: register int start; sl@0: sl@0: if (numRanges == 0) { sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: * This exploits peculiarities of our compiler: nested ranges sl@0: * are always *after* their containing ranges, so that by scanning sl@0: * backwards we are sure that the first matching range is indeed sl@0: * the deepest. sl@0: */ sl@0: sl@0: rangeArrayPtr = codePtr->exceptArrayPtr; sl@0: rangePtr = rangeArrayPtr + numRanges; sl@0: while (--rangePtr >= rangeArrayPtr) { sl@0: start = rangePtr->codeOffset; sl@0: if ((start <= pcOffset) && sl@0: (pcOffset < (start + rangePtr->numCodeBytes))) { sl@0: if ((!catchOnly) sl@0: || (rangePtr->type == CATCH_EXCEPTION_RANGE)) { sl@0: return rangePtr; sl@0: } sl@0: } sl@0: } sl@0: return NULL; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * GetOpcodeName -- sl@0: * sl@0: * This procedure is called by the TRACE and TRACE_WITH_OBJ macros sl@0: * used in TclExecuteByteCode when debugging. It returns the name of sl@0: * the bytecode instruction at a specified instruction pc. sl@0: * sl@0: * Results: sl@0: * A character string for the instruction. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: static char * sl@0: GetOpcodeName(pc) sl@0: unsigned char *pc; /* Points to the instruction whose name sl@0: * should be returned. */ sl@0: { sl@0: unsigned char opCode = *pc; sl@0: sl@0: return tclInstructionTable[opCode].name; sl@0: } sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * VerifyExprObjType -- sl@0: * sl@0: * This procedure is called by the math functions to verify that sl@0: * the object is either an int or double, coercing it if necessary. sl@0: * If an error occurs during conversion, an error message is left sl@0: * in the interpreter's result unless "interp" is NULL. sl@0: * sl@0: * Results: sl@0: * TCL_OK if it was int or double, TCL_ERROR otherwise sl@0: * sl@0: * Side effects: sl@0: * objPtr is ensured to be of tclIntType, tclWideIntType or sl@0: * tclDoubleType. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: VerifyExprObjType(interp, objPtr) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: Tcl_Obj *objPtr; /* Points to the object to type check. */ sl@0: { sl@0: if (IS_NUMERIC_TYPE(objPtr->typePtr)) { sl@0: return TCL_OK; sl@0: } else { sl@0: int length, result = TCL_OK; sl@0: char *s = Tcl_GetStringFromObj(objPtr, &length); sl@0: sl@0: if (TclLooksLikeInt(s, length)) { sl@0: long i; sl@0: Tcl_WideInt w; sl@0: GET_WIDE_OR_INT(result, objPtr, i, w); sl@0: } else { sl@0: double d; sl@0: result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d); sl@0: } sl@0: if ((result != TCL_OK) && (interp != NULL)) { sl@0: Tcl_ResetResult(interp); sl@0: if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "argument to math function was an invalid octal number", sl@0: -1); sl@0: } else { sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "argument to math function didn't have numeric value", sl@0: -1); sl@0: } sl@0: } sl@0: return result; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * Math Functions -- sl@0: * sl@0: * This page contains the procedures that implement all of the sl@0: * built-in math functions for expressions. sl@0: * sl@0: * Results: sl@0: * Each procedure returns TCL_OK if it succeeds and pushes an sl@0: * Tcl object holding the result. If it fails it returns TCL_ERROR sl@0: * and leaves an error message in the interpreter's result. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: ExprUnaryFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Contains the address of a procedure that sl@0: * takes one double argument and returns a sl@0: * double result. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: register Tcl_Obj *valuePtr; sl@0: double d, dResult; sl@0: int result; sl@0: sl@0: double (*func) _ANSI_ARGS_((double)) = sl@0: (double (*)_ANSI_ARGS_((double))) clientData; sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: result = TCL_OK; sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Pop the function's argument from the evaluation stack. Convert it sl@0: * to a double if necessary. sl@0: */ sl@0: sl@0: valuePtr = POP_OBJECT(); sl@0: sl@0: if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr); sl@0: sl@0: errno = 0; sl@0: dResult = (*func)(d); sl@0: if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { sl@0: TclExprFloatError(interp, dResult); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Push a Tcl object holding the result. sl@0: */ sl@0: sl@0: PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); sl@0: sl@0: /* sl@0: * Reflect the change to stackTop back in eePtr. sl@0: */ sl@0: sl@0: done: sl@0: TclDecrRefCount(valuePtr); sl@0: DECACHE_STACK_INFO(); sl@0: return result; sl@0: } sl@0: sl@0: static int sl@0: ExprBinaryFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Contains the address of a procedure that sl@0: * takes two double arguments and sl@0: * returns a double result. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: register Tcl_Obj *valuePtr, *value2Ptr; sl@0: double d1, d2, dResult; sl@0: int result; sl@0: sl@0: double (*func) _ANSI_ARGS_((double, double)) sl@0: = (double (*)_ANSI_ARGS_((double, double))) clientData; sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: result = TCL_OK; sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Pop the function's two arguments from the evaluation stack. Convert sl@0: * them to doubles if necessary. sl@0: */ sl@0: sl@0: value2Ptr = POP_OBJECT(); sl@0: valuePtr = POP_OBJECT(); sl@0: sl@0: if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) || sl@0: (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr); sl@0: GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr); sl@0: sl@0: errno = 0; sl@0: dResult = (*func)(d1, d2); sl@0: if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) { sl@0: TclExprFloatError(interp, dResult); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Push a Tcl object holding the result. sl@0: */ sl@0: sl@0: PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); sl@0: sl@0: /* sl@0: * Reflect the change to stackTop back in eePtr. sl@0: */ sl@0: sl@0: done: sl@0: TclDecrRefCount(valuePtr); sl@0: TclDecrRefCount(value2Ptr); sl@0: DECACHE_STACK_INFO(); sl@0: return result; sl@0: } sl@0: sl@0: static int sl@0: ExprAbsFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Ignored. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: register Tcl_Obj *valuePtr; sl@0: long i, iResult; sl@0: double d, dResult; sl@0: int result; sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: result = TCL_OK; sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Pop the argument from the evaluation stack. sl@0: */ sl@0: sl@0: valuePtr = POP_OBJECT(); sl@0: sl@0: if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Push a Tcl object with the result. sl@0: */ sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: i = valuePtr->internalRep.longValue; sl@0: if (i < 0) { sl@0: if (i == LONG_MIN) { sl@0: #ifdef TCL_WIDE_INT_IS_LONG sl@0: Tcl_SetObjResult(interp, Tcl_NewStringObj( sl@0: "integer value too large to represent", -1)); sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", sl@0: "integer value too large to represent", (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: #else sl@0: /* sl@0: * Special case: abs(MIN_INT) must promote to wide. sl@0: */ sl@0: sl@0: PUSH_OBJECT( Tcl_NewWideIntObj(-(Tcl_WideInt) i) ); sl@0: result = TCL_OK; sl@0: goto done; sl@0: #endif sl@0: sl@0: } sl@0: iResult = -i; sl@0: } else { sl@0: iResult = i; sl@0: } sl@0: PUSH_OBJECT(Tcl_NewLongObj(iResult)); sl@0: } else if (valuePtr->typePtr == &tclWideIntType) { sl@0: Tcl_WideInt wResult, w; sl@0: TclGetWide(w,valuePtr); sl@0: if (w < W0) { sl@0: wResult = -w; sl@0: if (wResult < 0) { sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "integer value too large to represent", -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", sl@0: "integer value too large to represent", (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: } else { sl@0: wResult = w; sl@0: } sl@0: PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); sl@0: } else { sl@0: d = valuePtr->internalRep.doubleValue; sl@0: if (d < 0.0) { sl@0: dResult = -d; sl@0: } else { sl@0: dResult = d; sl@0: } sl@0: if (IS_NAN(dResult) || IS_INF(dResult)) { sl@0: TclExprFloatError(interp, dResult); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); sl@0: } sl@0: sl@0: /* sl@0: * Reflect the change to stackTop back in eePtr. sl@0: */ sl@0: sl@0: done: sl@0: TclDecrRefCount(valuePtr); sl@0: DECACHE_STACK_INFO(); sl@0: return result; sl@0: } sl@0: sl@0: static int sl@0: ExprDoubleFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Ignored. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: register Tcl_Obj *valuePtr; sl@0: double dResult; sl@0: int result; sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: result = TCL_OK; sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Pop the argument from the evaluation stack. sl@0: */ sl@0: sl@0: valuePtr = POP_OBJECT(); sl@0: sl@0: if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr); sl@0: sl@0: /* sl@0: * Push a Tcl object with the result. sl@0: */ sl@0: sl@0: PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); sl@0: sl@0: /* sl@0: * Reflect the change to stackTop back in eePtr. sl@0: */ sl@0: sl@0: done: sl@0: TclDecrRefCount(valuePtr); sl@0: DECACHE_STACK_INFO(); sl@0: return result; sl@0: } sl@0: sl@0: static int sl@0: ExprIntFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Ignored. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: register Tcl_Obj *valuePtr; sl@0: long iResult; sl@0: double d; sl@0: int result; sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: result = TCL_OK; sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Pop the argument from the evaluation stack. sl@0: */ sl@0: sl@0: valuePtr = POP_OBJECT(); sl@0: sl@0: if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: iResult = valuePtr->internalRep.longValue; sl@0: } else if (valuePtr->typePtr == &tclWideIntType) { sl@0: TclGetLongFromWide(iResult,valuePtr); sl@0: } else { sl@0: d = valuePtr->internalRep.doubleValue; sl@0: if (d < 0.0) { sl@0: if (d < (double) (long) LONG_MIN) { sl@0: tooLarge: sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "integer value too large to represent", -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", sl@0: "integer value too large to represent", (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: } else { sl@0: if (d > (double) LONG_MAX) { sl@0: goto tooLarge; sl@0: } sl@0: } sl@0: if (IS_NAN(d) || IS_INF(d)) { sl@0: TclExprFloatError(interp, d); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: iResult = (long) d; sl@0: } sl@0: sl@0: /* sl@0: * Push a Tcl object with the result. sl@0: */ sl@0: sl@0: PUSH_OBJECT(Tcl_NewLongObj(iResult)); sl@0: sl@0: /* sl@0: * Reflect the change to stackTop back in eePtr. sl@0: */ sl@0: sl@0: done: sl@0: TclDecrRefCount(valuePtr); sl@0: DECACHE_STACK_INFO(); sl@0: return result; sl@0: } sl@0: sl@0: static int sl@0: ExprWideFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Ignored. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: register Tcl_Obj *valuePtr; sl@0: Tcl_WideInt wResult; sl@0: double d; sl@0: int result; sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: result = TCL_OK; sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Pop the argument from the evaluation stack. sl@0: */ sl@0: sl@0: valuePtr = POP_OBJECT(); sl@0: sl@0: if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: if (valuePtr->typePtr == &tclWideIntType) { sl@0: TclGetWide(wResult,valuePtr); sl@0: } else if (valuePtr->typePtr == &tclIntType) { sl@0: wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue); sl@0: } else { sl@0: d = valuePtr->internalRep.doubleValue; sl@0: if (d < 0.0) { sl@0: if (d < Tcl_WideAsDouble(LLONG_MIN)) { sl@0: tooLarge: sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "integer value too large to represent", -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", sl@0: "integer value too large to represent", (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: } else { sl@0: if (d > Tcl_WideAsDouble(LLONG_MAX)) { sl@0: goto tooLarge; sl@0: } sl@0: } sl@0: if (IS_NAN(d) || IS_INF(d)) { sl@0: TclExprFloatError(interp, d); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: wResult = Tcl_DoubleAsWide(d); sl@0: } sl@0: sl@0: /* sl@0: * Push a Tcl object with the result. sl@0: */ sl@0: sl@0: PUSH_OBJECT(Tcl_NewWideIntObj(wResult)); sl@0: sl@0: /* sl@0: * Reflect the change to stackTop back in eePtr. sl@0: */ sl@0: sl@0: done: sl@0: TclDecrRefCount(valuePtr); sl@0: DECACHE_STACK_INFO(); sl@0: return result; sl@0: } sl@0: sl@0: static int sl@0: ExprRandFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Ignored. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: Interp *iPtr = (Interp *) interp; sl@0: double dResult; sl@0: long tmp; /* Algorithm assumes at least 32 bits. sl@0: * Only long guarantees that. See below. */ sl@0: sl@0: if (!(iPtr->flags & RAND_SEED_INITIALIZED)) { sl@0: iPtr->flags |= RAND_SEED_INITIALIZED; sl@0: sl@0: /* sl@0: * Take into consideration the thread this interp is running in order sl@0: * to insure different seeds in different threads (bug #416643) sl@0: */ sl@0: sl@0: iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12); sl@0: sl@0: /* sl@0: * Make sure 1 <= randSeed <= (2^31) - 2. See below. sl@0: */ sl@0: sl@0: iPtr->randSeed &= (unsigned long) 0x7fffffff; sl@0: if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { sl@0: iPtr->randSeed ^= 123459876; sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Generate the random number using the linear congruential sl@0: * generator defined by the following recurrence: sl@0: * seed = ( IA * seed ) mod IM sl@0: * where IA is 16807 and IM is (2^31) - 1. The recurrence maps sl@0: * a seed in the range [1, IM - 1] to a new seed in that same range. sl@0: * The recurrence maps IM to 0, and maps 0 back to 0, so those two sl@0: * values must not be allowed as initial values of seed. sl@0: * sl@0: * In order to avoid potential problems with integer overflow, the sl@0: * recurrence is implemented in terms of additional constants sl@0: * IQ and IR such that sl@0: * IM = IA*IQ + IR sl@0: * None of the operations in the implementation overflows a 32-bit sl@0: * signed integer, and the C type long is guaranteed to be at least sl@0: * 32 bits wide. sl@0: * sl@0: * For more details on how this algorithm works, refer to the following sl@0: * papers: sl@0: * sl@0: * S.K. Park & K.W. Miller, "Random number generators: good ones sl@0: * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988 sl@0: * sl@0: * W.H. Press & S.A. Teukolsky, "Portable random number sl@0: * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992. sl@0: */ sl@0: sl@0: #define RAND_IA 16807 sl@0: #define RAND_IM 2147483647 sl@0: #define RAND_IQ 127773 sl@0: #define RAND_IR 2836 sl@0: #define RAND_MASK 123459876 sl@0: sl@0: tmp = iPtr->randSeed/RAND_IQ; sl@0: iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp; sl@0: if (iPtr->randSeed < 0) { sl@0: iPtr->randSeed += RAND_IM; sl@0: } sl@0: sl@0: /* sl@0: * Since the recurrence keeps seed values in the range [1, RAND_IM - 1], sl@0: * dividing by RAND_IM yields a double in the range (0, 1). sl@0: */ sl@0: sl@0: dResult = iPtr->randSeed * (1.0/RAND_IM); sl@0: sl@0: /* sl@0: * Push a Tcl object with the result. sl@0: */ sl@0: sl@0: PUSH_OBJECT(Tcl_NewDoubleObj(dResult)); sl@0: sl@0: /* sl@0: * Reflect the change to stackTop back in eePtr. sl@0: */ sl@0: sl@0: DECACHE_STACK_INFO(); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: static int sl@0: ExprRoundFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Ignored. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: Tcl_Obj *valuePtr, *resPtr; sl@0: double d, f, i; sl@0: int result; sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: result = TCL_OK; sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Pop the argument from the evaluation stack. sl@0: */ sl@0: sl@0: valuePtr = POP_OBJECT(); sl@0: sl@0: if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: if ((valuePtr->typePtr == &tclIntType) || sl@0: (valuePtr->typePtr == &tclWideIntType)) { sl@0: result = TCL_OK; sl@0: resPtr = valuePtr; sl@0: } else { sl@0: sl@0: /* sl@0: * Round the number to the nearest integer. I'd like to use round(), sl@0: * but it's C99 (or BSD), and not yet universal. sl@0: */ sl@0: sl@0: d = valuePtr->internalRep.doubleValue; sl@0: f = modf(d, &i); sl@0: if (d < 0.0) { sl@0: if (f <= -0.5) { sl@0: i += -1.0; sl@0: } sl@0: if (i <= Tcl_WideAsDouble(LLONG_MIN)) { sl@0: goto tooLarge; sl@0: } else if (i <= (double) LONG_MIN) { sl@0: resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); sl@0: } else { sl@0: resPtr = Tcl_NewLongObj((long) i); sl@0: } sl@0: } else { sl@0: if (f >= 0.5) { sl@0: i += 1.0; sl@0: } sl@0: if (i >= Tcl_WideAsDouble(LLONG_MAX)) { sl@0: goto tooLarge; sl@0: } else if (i >= (double) LONG_MAX) { sl@0: resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i)); sl@0: } else { sl@0: resPtr = Tcl_NewLongObj((long) i); sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Push the result object and free the argument Tcl_Obj. sl@0: */ sl@0: sl@0: PUSH_OBJECT(resPtr); sl@0: sl@0: done: sl@0: TclDecrRefCount(valuePtr); sl@0: DECACHE_STACK_INFO(); sl@0: return result; sl@0: sl@0: /* sl@0: * Error return: result cannot be represented as an integer. sl@0: */ sl@0: sl@0: tooLarge: sl@0: Tcl_ResetResult(interp); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), sl@0: "integer value too large to represent", -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW", sl@0: "integer value too large to represent", sl@0: (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: static int sl@0: ExprSrandFunc(interp, eePtr, clientData) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: ClientData clientData; /* Ignored. */ sl@0: { sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_Obj *valuePtr; sl@0: long i = 0; /* Initialized to avoid compiler warning. */ sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Pop the argument from the evaluation stack. Use the value sl@0: * to reset the random number seed. sl@0: */ sl@0: sl@0: valuePtr = POP_OBJECT(); sl@0: sl@0: if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { sl@0: goto badValue; sl@0: } sl@0: sl@0: if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) { sl@0: Tcl_WideInt w; sl@0: sl@0: if (Tcl_GetWideIntFromObj(interp, valuePtr, &w) != TCL_OK) { sl@0: badValue: sl@0: Tcl_AddErrorInfo(interp, "\n (argument to \"srand()\")"); sl@0: TclDecrRefCount(valuePtr); sl@0: DECACHE_STACK_INFO(); sl@0: return TCL_ERROR; sl@0: } sl@0: sl@0: i = Tcl_WideAsLong(w); sl@0: } sl@0: sl@0: /* sl@0: * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2. sl@0: * See comments in ExprRandFunc() for more details. sl@0: */ sl@0: sl@0: iPtr->flags |= RAND_SEED_INITIALIZED; sl@0: iPtr->randSeed = i; sl@0: iPtr->randSeed &= (unsigned long) 0x7fffffff; sl@0: if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) { sl@0: iPtr->randSeed ^= 123459876; sl@0: } sl@0: sl@0: /* sl@0: * To avoid duplicating the random number generation code we simply sl@0: * clean up our state and call the real random number function. That sl@0: * function will always succeed. sl@0: */ sl@0: sl@0: TclDecrRefCount(valuePtr); sl@0: DECACHE_STACK_INFO(); sl@0: sl@0: ExprRandFunc(interp, eePtr, clientData); sl@0: return TCL_OK; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * ExprCallMathFunc -- sl@0: * sl@0: * This procedure is invoked to call a non-builtin math function sl@0: * during the execution of an expression. sl@0: * sl@0: * Results: sl@0: * TCL_OK is returned if all went well and the function's value sl@0: * was computed successfully. If an error occurred, TCL_ERROR sl@0: * is returned and an error message is left in the interpreter's sl@0: * result. After a successful return this procedure pushes a Tcl object sl@0: * holding the result. sl@0: * sl@0: * Side effects: sl@0: * None, unless the called math function has side effects. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: ExprCallMathFunc(interp, eePtr, objc, objv) sl@0: Tcl_Interp *interp; /* The interpreter in which to execute the sl@0: * function. */ sl@0: ExecEnv *eePtr; /* Points to the environment for executing sl@0: * the function. */ sl@0: int objc; /* Number of arguments. The function name is sl@0: * the 0-th argument. */ sl@0: Tcl_Obj **objv; /* The array of arguments. The function name sl@0: * is objv[0]. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */ sl@0: register int stackTop; /* Cached top index of evaluation stack. */ sl@0: char *funcName; sl@0: Tcl_HashEntry *hPtr; sl@0: MathFunc *mathFuncPtr; /* Information about math function. */ sl@0: Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */ sl@0: Tcl_Value funcResult; /* Result of function call as Tcl_Value. */ sl@0: register Tcl_Obj *valuePtr; sl@0: long i; sl@0: double d; sl@0: int j, k, result; sl@0: sl@0: Tcl_ResetResult(interp); sl@0: sl@0: /* sl@0: * Set stackPtr and stackTop from eePtr. sl@0: */ sl@0: sl@0: CACHE_STACK_INFO(); sl@0: sl@0: /* sl@0: * Look up the MathFunc record for the function. sl@0: */ sl@0: sl@0: funcName = TclGetString(objv[0]); sl@0: hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName); sl@0: if (hPtr == NULL) { sl@0: Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), sl@0: "unknown math function \"", funcName, "\"", (char *) NULL); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr); sl@0: if (mathFuncPtr->numArgs != (objc-1)) { sl@0: panic("ExprCallMathFunc: expected number of args %d != actual number %d", sl@0: mathFuncPtr->numArgs, objc); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Collect the arguments for the function, if there are any, into the sl@0: * array "args". Note that args[0] will have the Tcl_Value that sl@0: * corresponds to objv[1]. sl@0: */ sl@0: sl@0: for (j = 1, k = 0; j < objc; j++, k++) { sl@0: valuePtr = objv[j]; sl@0: sl@0: if (VerifyExprObjType(interp, valuePtr) != TCL_OK) { sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Copy the object's numeric value to the argument record, sl@0: * converting it if necessary. sl@0: */ sl@0: sl@0: if (valuePtr->typePtr == &tclIntType) { sl@0: i = valuePtr->internalRep.longValue; sl@0: if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { sl@0: args[k].type = TCL_DOUBLE; sl@0: args[k].doubleValue = i; sl@0: } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { sl@0: args[k].type = TCL_WIDE_INT; sl@0: args[k].wideValue = Tcl_LongAsWide(i); sl@0: } else { sl@0: args[k].type = TCL_INT; sl@0: args[k].intValue = i; sl@0: } sl@0: } else if (valuePtr->typePtr == &tclWideIntType) { sl@0: Tcl_WideInt w; sl@0: TclGetWide(w,valuePtr); sl@0: if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) { sl@0: args[k].type = TCL_DOUBLE; sl@0: args[k].doubleValue = Tcl_WideAsDouble(w); sl@0: } else if (mathFuncPtr->argTypes[k] == TCL_INT) { sl@0: args[k].type = TCL_INT; sl@0: args[k].intValue = Tcl_WideAsLong(w); sl@0: } else { sl@0: args[k].type = TCL_WIDE_INT; sl@0: args[k].wideValue = w; sl@0: } sl@0: } else { sl@0: d = valuePtr->internalRep.doubleValue; sl@0: if (mathFuncPtr->argTypes[k] == TCL_INT) { sl@0: args[k].type = TCL_INT; sl@0: args[k].intValue = (long) d; sl@0: } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) { sl@0: args[k].type = TCL_WIDE_INT; sl@0: args[k].wideValue = Tcl_DoubleAsWide(d); sl@0: } else { sl@0: args[k].type = TCL_DOUBLE; sl@0: args[k].doubleValue = d; sl@0: } sl@0: } sl@0: } sl@0: sl@0: /* sl@0: * Invoke the function and copy its result back into valuePtr. sl@0: */ sl@0: sl@0: result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args, sl@0: &funcResult); sl@0: if (result != TCL_OK) { sl@0: goto done; sl@0: } sl@0: sl@0: /* sl@0: * Pop the objc top stack elements and decrement their ref counts. sl@0: */ sl@0: sl@0: k = (stackTop - (objc-1)); sl@0: while (stackTop >= k) { sl@0: valuePtr = POP_OBJECT(); sl@0: TclDecrRefCount(valuePtr); sl@0: } sl@0: sl@0: /* sl@0: * Push the call's object result. sl@0: */ sl@0: sl@0: if (funcResult.type == TCL_INT) { sl@0: PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue)); sl@0: } else if (funcResult.type == TCL_WIDE_INT) { sl@0: PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue)); sl@0: } else { sl@0: d = funcResult.doubleValue; sl@0: if (IS_NAN(d) || IS_INF(d)) { sl@0: TclExprFloatError(interp, d); sl@0: result = TCL_ERROR; sl@0: goto done; sl@0: } sl@0: PUSH_OBJECT(Tcl_NewDoubleObj(d)); sl@0: } sl@0: sl@0: /* sl@0: * Reflect the change to stackTop back in eePtr. sl@0: */ sl@0: sl@0: done: sl@0: DECACHE_STACK_INFO(); sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclExprFloatError -- sl@0: * sl@0: * This procedure is called when an error occurs during a sl@0: * floating-point operation. It reads errno and sets sl@0: * interp->objResultPtr accordingly. sl@0: * sl@0: * Results: sl@0: * interp->objResultPtr is set to hold an error message. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: void sl@0: TclExprFloatError(interp, value) sl@0: Tcl_Interp *interp; /* Where to store error message. */ sl@0: double value; /* Value returned after error; used to sl@0: * distinguish underflows from overflows. */ sl@0: { sl@0: char *s; sl@0: sl@0: Tcl_ResetResult(interp); sl@0: if ((errno == EDOM) || IS_NAN(value)) { sl@0: s = "domain error: argument not in valid range"; sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL); sl@0: } else if ((errno == ERANGE) || IS_INF(value)) { sl@0: if (value == 0.0) { sl@0: s = "floating-point value too small to represent"; sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL); sl@0: } else { sl@0: s = "floating-point value too large to represent"; sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL); sl@0: } sl@0: } else { sl@0: char msg[64 + TCL_INTEGER_SPACE]; sl@0: sl@0: sprintf(msg, "unknown floating-point error, errno = %d", errno); sl@0: Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1); sl@0: Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL); sl@0: } sl@0: } sl@0: sl@0: #ifdef TCL_COMPILE_STATS sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * TclLog2 -- sl@0: * sl@0: * Procedure used while collecting compilation statistics to determine sl@0: * the log base 2 of an integer. sl@0: * sl@0: * Results: sl@0: * Returns the log base 2 of the operand. If the argument is less sl@0: * than or equal to zero, a zero is returned. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: int sl@0: TclLog2(value) sl@0: register int value; /* The integer for which to compute the sl@0: * log base 2. */ sl@0: { sl@0: register int n = value; sl@0: register int result = 0; sl@0: sl@0: while (n > 1) { sl@0: n = n >> 1; sl@0: result++; sl@0: } sl@0: return result; sl@0: } sl@0: sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * EvalStatsCmd -- sl@0: * sl@0: * Implements the "evalstats" command that prints instruction execution sl@0: * counts to stdout. sl@0: * sl@0: * Results: sl@0: * Standard Tcl results. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static int sl@0: EvalStatsCmd(unused, interp, objc, objv) sl@0: ClientData unused; /* Unused. */ sl@0: Tcl_Interp *interp; /* The current interpreter. */ sl@0: int objc; /* The number of arguments. */ sl@0: Tcl_Obj *CONST objv[]; /* The argument strings. */ sl@0: { sl@0: Interp *iPtr = (Interp *) interp; sl@0: LiteralTable *globalTablePtr = &(iPtr->literalTable); sl@0: ByteCodeStats *statsPtr = &(iPtr->stats); sl@0: double totalCodeBytes, currentCodeBytes; sl@0: double totalLiteralBytes, currentLiteralBytes; sl@0: double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved; sl@0: double strBytesSharedMultX, strBytesSharedOnce; sl@0: double numInstructions, currentHeaderBytes; sl@0: long numCurrentByteCodes, numByteCodeLits; sl@0: long refCountSum, literalMgmtBytes, sum; sl@0: int numSharedMultX, numSharedOnce; sl@0: int decadeHigh, minSizeDecade, maxSizeDecade, length, i; sl@0: char *litTableStats; sl@0: LiteralEntry *entryPtr; sl@0: sl@0: numInstructions = 0.0; sl@0: for (i = 0; i < 256; i++) { sl@0: if (statsPtr->instructionCount[i] != 0) { sl@0: numInstructions += statsPtr->instructionCount[i]; sl@0: } sl@0: } sl@0: sl@0: totalLiteralBytes = sizeof(LiteralTable) sl@0: + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *) sl@0: + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)) sl@0: + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)) sl@0: + statsPtr->totalLitStringBytes; sl@0: totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes; sl@0: sl@0: numCurrentByteCodes = sl@0: statsPtr->numCompilations - statsPtr->numByteCodesFreed; sl@0: currentHeaderBytes = numCurrentByteCodes sl@0: * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))); sl@0: literalMgmtBytes = sizeof(LiteralTable) sl@0: + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)) sl@0: + (iPtr->literalTable.numEntries * sizeof(LiteralEntry)); sl@0: currentLiteralBytes = literalMgmtBytes sl@0: + iPtr->literalTable.numEntries * sizeof(Tcl_Obj) sl@0: + statsPtr->currentLitStringBytes; sl@0: currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes; sl@0: sl@0: /* sl@0: * Summary statistics, total and current source and ByteCode sizes. sl@0: */ sl@0: sl@0: fprintf(stdout, "\n----------------------------------------------------------------\n"); sl@0: fprintf(stdout, sl@0: "Compilation and execution statistics for interpreter 0x%x\n", sl@0: (unsigned int) iPtr); sl@0: sl@0: fprintf(stdout, "\nNumber ByteCodes executed %ld\n", sl@0: statsPtr->numExecutions); sl@0: fprintf(stdout, "Number ByteCodes compiled %ld\n", sl@0: statsPtr->numCompilations); sl@0: fprintf(stdout, " Mean executions/compile %.1f\n", sl@0: ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations)); sl@0: sl@0: fprintf(stdout, "\nInstructions executed %.0f\n", sl@0: numInstructions); sl@0: fprintf(stdout, " Mean inst/compile %.0f\n", sl@0: numInstructions / statsPtr->numCompilations); sl@0: fprintf(stdout, " Mean inst/execution %.0f\n", sl@0: numInstructions / statsPtr->numExecutions); sl@0: sl@0: fprintf(stdout, "\nTotal ByteCodes %ld\n", sl@0: statsPtr->numCompilations); sl@0: fprintf(stdout, " Source bytes %.6g\n", sl@0: statsPtr->totalSrcBytes); sl@0: fprintf(stdout, " Code bytes %.6g\n", sl@0: totalCodeBytes); sl@0: fprintf(stdout, " ByteCode bytes %.6g\n", sl@0: statsPtr->totalByteCodeBytes); sl@0: fprintf(stdout, " Literal bytes %.6g\n", sl@0: totalLiteralBytes); sl@0: fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n", sl@0: sizeof(LiteralTable), sl@0: iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), sl@0: statsPtr->numLiteralsCreated * sizeof(LiteralEntry), sl@0: statsPtr->numLiteralsCreated * sizeof(Tcl_Obj), sl@0: statsPtr->totalLitStringBytes); sl@0: fprintf(stdout, " Mean code/compile %.1f\n", sl@0: totalCodeBytes / statsPtr->numCompilations); sl@0: fprintf(stdout, " Mean code/source %.1f\n", sl@0: totalCodeBytes / statsPtr->totalSrcBytes); sl@0: sl@0: fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n", sl@0: numCurrentByteCodes); sl@0: fprintf(stdout, " Source bytes %.6g\n", sl@0: statsPtr->currentSrcBytes); sl@0: fprintf(stdout, " Code bytes %.6g\n", sl@0: currentCodeBytes); sl@0: fprintf(stdout, " ByteCode bytes %.6g\n", sl@0: statsPtr->currentByteCodeBytes); sl@0: fprintf(stdout, " Literal bytes %.6g\n", sl@0: currentLiteralBytes); sl@0: fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", sl@0: sizeof(LiteralTable), sl@0: iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), sl@0: iPtr->literalTable.numEntries * sizeof(LiteralEntry), sl@0: iPtr->literalTable.numEntries * sizeof(Tcl_Obj), sl@0: statsPtr->currentLitStringBytes); sl@0: fprintf(stdout, " Mean code/source %.1f\n", sl@0: currentCodeBytes / statsPtr->currentSrcBytes); sl@0: fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n", sl@0: (currentCodeBytes + statsPtr->currentSrcBytes), sl@0: (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0); sl@0: sl@0: /* sl@0: * Tcl_IsShared statistics check sl@0: * sl@0: * This gives the refcount of each obj as Tcl_IsShared was called sl@0: * for it. Shared objects must be duplicated before they can be sl@0: * modified. sl@0: */ sl@0: sl@0: numSharedMultX = 0; sl@0: fprintf(stdout, "\nTcl_IsShared object check (all objects):\n"); sl@0: fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n", sl@0: tclObjsShared[1]); sl@0: for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) { sl@0: fprintf(stdout, " refcount ==%d %ld\n", sl@0: i, tclObjsShared[i]); sl@0: numSharedMultX += tclObjsShared[i]; sl@0: } sl@0: fprintf(stdout, " refcount >=%d %ld\n", sl@0: i, tclObjsShared[0]); sl@0: numSharedMultX += tclObjsShared[0]; sl@0: fprintf(stdout, " Total shared objects %d\n", sl@0: numSharedMultX); sl@0: sl@0: /* sl@0: * Literal table statistics. sl@0: */ sl@0: sl@0: numByteCodeLits = 0; sl@0: refCountSum = 0; sl@0: numSharedMultX = 0; sl@0: numSharedOnce = 0; sl@0: objBytesIfUnshared = 0.0; sl@0: strBytesIfUnshared = 0.0; sl@0: strBytesSharedMultX = 0.0; sl@0: strBytesSharedOnce = 0.0; sl@0: for (i = 0; i < globalTablePtr->numBuckets; i++) { sl@0: for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL; sl@0: entryPtr = entryPtr->nextPtr) { sl@0: if (entryPtr->objPtr->typePtr == &tclByteCodeType) { sl@0: numByteCodeLits++; sl@0: } sl@0: (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length); sl@0: refCountSum += entryPtr->refCount; sl@0: objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj)); sl@0: strBytesIfUnshared += (entryPtr->refCount * (length+1)); sl@0: if (entryPtr->refCount > 1) { sl@0: numSharedMultX++; sl@0: strBytesSharedMultX += (length+1); sl@0: } else { sl@0: numSharedOnce++; sl@0: strBytesSharedOnce += (length+1); sl@0: } sl@0: } sl@0: } sl@0: sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared) sl@0: - currentLiteralBytes; sl@0: sl@0: fprintf(stdout, "\nTotal objects (all interps) %ld\n", sl@0: tclObjsAlloced); sl@0: fprintf(stdout, "Current objects %ld\n", sl@0: (tclObjsAlloced - tclObjsFreed)); sl@0: fprintf(stdout, "Total literal objects %ld\n", sl@0: statsPtr->numLiteralsCreated); sl@0: sl@0: fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n", sl@0: globalTablePtr->numEntries, sl@0: (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed)); sl@0: fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n", sl@0: numByteCodeLits, sl@0: (numByteCodeLits * 100.0) / globalTablePtr->numEntries); sl@0: fprintf(stdout, " Literals reused > 1x %d\n", sl@0: numSharedMultX); sl@0: fprintf(stdout, " Mean reference count %.2f\n", sl@0: ((double) refCountSum) / globalTablePtr->numEntries); sl@0: fprintf(stdout, " Mean len, str reused >1x %.2f\n", sl@0: (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0)); sl@0: fprintf(stdout, " Mean len, str used 1x %.2f\n", sl@0: (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0)); sl@0: fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n", sl@0: sharingBytesSaved, sl@0: (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared)); sl@0: fprintf(stdout, " Bytes with sharing %.6g\n", sl@0: currentLiteralBytes); sl@0: fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n", sl@0: sizeof(LiteralTable), sl@0: iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), sl@0: iPtr->literalTable.numEntries * sizeof(LiteralEntry), sl@0: iPtr->literalTable.numEntries * sizeof(Tcl_Obj), sl@0: statsPtr->currentLitStringBytes); sl@0: fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n", sl@0: (objBytesIfUnshared + strBytesIfUnshared), sl@0: objBytesIfUnshared, strBytesIfUnshared); sl@0: fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n", sl@0: (strBytesIfUnshared - statsPtr->currentLitStringBytes), sl@0: strBytesIfUnshared, statsPtr->currentLitStringBytes); sl@0: fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n", sl@0: literalMgmtBytes, sl@0: (literalMgmtBytes * 100.0) / currentLiteralBytes); sl@0: fprintf(stdout, " table %d + buckets %d + entries %d\n", sl@0: sizeof(LiteralTable), sl@0: iPtr->literalTable.numBuckets * sizeof(LiteralEntry *), sl@0: iPtr->literalTable.numEntries * sizeof(LiteralEntry)); sl@0: sl@0: /* sl@0: * Breakdown of current ByteCode space requirements. sl@0: */ sl@0: sl@0: fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n"); sl@0: fprintf(stdout, " Bytes Pct of Avg per\n"); sl@0: fprintf(stdout, " total ByteCode\n"); sl@0: fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n", sl@0: statsPtr->currentByteCodeBytes, sl@0: statsPtr->currentByteCodeBytes / numCurrentByteCodes); sl@0: fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n", sl@0: currentHeaderBytes, sl@0: ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes), sl@0: currentHeaderBytes / numCurrentByteCodes); sl@0: fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n", sl@0: statsPtr->currentInstBytes, sl@0: ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes), sl@0: statsPtr->currentInstBytes / numCurrentByteCodes); sl@0: fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n", sl@0: statsPtr->currentLitBytes, sl@0: ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes), sl@0: statsPtr->currentLitBytes / numCurrentByteCodes); sl@0: fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n", sl@0: statsPtr->currentExceptBytes, sl@0: ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes), sl@0: statsPtr->currentExceptBytes / numCurrentByteCodes); sl@0: fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n", sl@0: statsPtr->currentAuxBytes, sl@0: ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes), sl@0: statsPtr->currentAuxBytes / numCurrentByteCodes); sl@0: fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n", sl@0: statsPtr->currentCmdMapBytes, sl@0: ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes), sl@0: statsPtr->currentCmdMapBytes / numCurrentByteCodes); sl@0: sl@0: /* sl@0: * Detailed literal statistics. sl@0: */ sl@0: sl@0: fprintf(stdout, "\nLiteral string sizes:\n"); sl@0: fprintf(stdout, " Up to length Percentage\n"); sl@0: maxSizeDecade = 0; sl@0: for (i = 31; i >= 0; i--) { sl@0: if (statsPtr->literalCount[i] > 0) { sl@0: maxSizeDecade = i; sl@0: break; sl@0: } sl@0: } sl@0: sum = 0; sl@0: for (i = 0; i <= maxSizeDecade; i++) { sl@0: decadeHigh = (1 << (i+1)) - 1; sl@0: sum += statsPtr->literalCount[i]; sl@0: fprintf(stdout, " %10d %8.0f%%\n", sl@0: decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated); sl@0: } sl@0: sl@0: litTableStats = TclLiteralStats(globalTablePtr); sl@0: fprintf(stdout, "\nCurrent literal table statistics:\n%s\n", sl@0: litTableStats); sl@0: ckfree((char *) litTableStats); sl@0: sl@0: /* sl@0: * Source and ByteCode size distributions. sl@0: */ sl@0: sl@0: fprintf(stdout, "\nSource sizes:\n"); sl@0: fprintf(stdout, " Up to size Percentage\n"); sl@0: minSizeDecade = maxSizeDecade = 0; sl@0: for (i = 0; i < 31; i++) { sl@0: if (statsPtr->srcCount[i] > 0) { sl@0: minSizeDecade = i; sl@0: break; sl@0: } sl@0: } sl@0: for (i = 31; i >= 0; i--) { sl@0: if (statsPtr->srcCount[i] > 0) { sl@0: maxSizeDecade = i; sl@0: break; sl@0: } sl@0: } sl@0: sum = 0; sl@0: for (i = minSizeDecade; i <= maxSizeDecade; i++) { sl@0: decadeHigh = (1 << (i+1)) - 1; sl@0: sum += statsPtr->srcCount[i]; sl@0: fprintf(stdout, " %10d %8.0f%%\n", sl@0: decadeHigh, (sum * 100.0) / statsPtr->numCompilations); sl@0: } sl@0: sl@0: fprintf(stdout, "\nByteCode sizes:\n"); sl@0: fprintf(stdout, " Up to size Percentage\n"); sl@0: minSizeDecade = maxSizeDecade = 0; sl@0: for (i = 0; i < 31; i++) { sl@0: if (statsPtr->byteCodeCount[i] > 0) { sl@0: minSizeDecade = i; sl@0: break; sl@0: } sl@0: } sl@0: for (i = 31; i >= 0; i--) { sl@0: if (statsPtr->byteCodeCount[i] > 0) { sl@0: maxSizeDecade = i; sl@0: break; sl@0: } sl@0: } sl@0: sum = 0; sl@0: for (i = minSizeDecade; i <= maxSizeDecade; i++) { sl@0: decadeHigh = (1 << (i+1)) - 1; sl@0: sum += statsPtr->byteCodeCount[i]; sl@0: fprintf(stdout, " %10d %8.0f%%\n", sl@0: decadeHigh, (sum * 100.0) / statsPtr->numCompilations); sl@0: } sl@0: sl@0: fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n"); sl@0: fprintf(stdout, " Up to ms Percentage\n"); sl@0: minSizeDecade = maxSizeDecade = 0; sl@0: for (i = 0; i < 31; i++) { sl@0: if (statsPtr->lifetimeCount[i] > 0) { sl@0: minSizeDecade = i; sl@0: break; sl@0: } sl@0: } sl@0: for (i = 31; i >= 0; i--) { sl@0: if (statsPtr->lifetimeCount[i] > 0) { sl@0: maxSizeDecade = i; sl@0: break; sl@0: } sl@0: } sl@0: sum = 0; sl@0: for (i = minSizeDecade; i <= maxSizeDecade; i++) { sl@0: decadeHigh = (1 << (i+1)) - 1; sl@0: sum += statsPtr->lifetimeCount[i]; sl@0: fprintf(stdout, " %12.3f %8.0f%%\n", sl@0: decadeHigh / 1000.0, sl@0: (sum * 100.0) / statsPtr->numByteCodesFreed); sl@0: } sl@0: sl@0: /* sl@0: * Instruction counts. sl@0: */ sl@0: sl@0: fprintf(stdout, "\nInstruction counts:\n"); sl@0: for (i = 0; i <= LAST_INST_OPCODE; i++) { sl@0: if (statsPtr->instructionCount[i]) { sl@0: fprintf(stdout, "%20s %8ld %6.1f%%\n", sl@0: tclInstructionTable[i].name, sl@0: statsPtr->instructionCount[i], sl@0: (statsPtr->instructionCount[i]*100.0) / numInstructions); sl@0: } sl@0: } sl@0: sl@0: fprintf(stdout, "\nInstructions NEVER executed:\n"); sl@0: for (i = 0; i <= LAST_INST_OPCODE; i++) { sl@0: if (statsPtr->instructionCount[i] == 0) { sl@0: fprintf(stdout, "%20s\n", tclInstructionTable[i].name); sl@0: } sl@0: } sl@0: sl@0: #ifdef TCL_MEM_DEBUG sl@0: fprintf(stdout, "\nHeap Statistics:\n"); sl@0: TclDumpMemoryInfo(stdout); sl@0: #endif sl@0: fprintf(stdout, "\n----------------------------------------------------------------\n"); sl@0: return TCL_OK; sl@0: } sl@0: #endif /* TCL_COMPILE_STATS */ sl@0: sl@0: #ifdef TCL_COMPILE_DEBUG sl@0: /* sl@0: *---------------------------------------------------------------------- sl@0: * sl@0: * StringForResultCode -- sl@0: * sl@0: * Procedure that returns a human-readable string representing a sl@0: * Tcl result code such as TCL_ERROR. sl@0: * sl@0: * Results: sl@0: * If the result code is one of the standard Tcl return codes, the sl@0: * result is a string representing that code such as "TCL_ERROR". sl@0: * Otherwise, the result string is that code formatted as a sl@0: * sequence of decimal digit characters. Note that the resulting sl@0: * string must not be modified by the caller. sl@0: * sl@0: * Side effects: sl@0: * None. sl@0: * sl@0: *---------------------------------------------------------------------- sl@0: */ sl@0: sl@0: static char * sl@0: StringForResultCode(result) sl@0: int result; /* The Tcl result code for which to sl@0: * generate a string. */ sl@0: { sl@0: static char buf[TCL_INTEGER_SPACE]; sl@0: sl@0: if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) { sl@0: return resultStrings[result]; sl@0: } sl@0: TclFormatInt(buf, result); sl@0: return buf; sl@0: } sl@0: #endif /* TCL_COMPILE_DEBUG */ sl@0: sl@0: /* sl@0: * Local Variables: sl@0: * mode: c sl@0: * c-basic-offset: 4 sl@0: * fill-column: 78 sl@0: * End: sl@0: */ sl@0: