os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclExecute.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclExecute.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,6565 @@
1.4 +/*
1.5 + * tclExecute.c --
1.6 + *
1.7 + * This file contains procedures that execute byte-compiled Tcl
1.8 + * commands.
1.9 + *
1.10 + * Copyright (c) 1996-1997 Sun Microsystems, Inc.
1.11 + * Copyright (c) 1998-2000 by Scriptics Corporation.
1.12 + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
1.13 + * Portions Copyright (c) 2007-2008 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * RCS: @(#) $Id: tclExecute.c,v 1.94.2.21 2007/03/13 16:26:32 dgp Exp $
1.19 + */
1.20 +
1.21 +#include "tclInt.h"
1.22 +#include "tclCompile.h"
1.23 +#include "tclMath.h"
1.24 +
1.25 +/*
1.26 + * The stuff below is a bit of a hack so that this file can be used
1.27 + * in environments that include no UNIX, i.e. no errno. Just define
1.28 + * errno here.
1.29 + */
1.30 +
1.31 +#ifndef TCL_GENERIC_ONLY
1.32 +# include "tclPort.h"
1.33 +#else /* TCL_GENERIC_ONLY */
1.34 +# ifndef NO_FLOAT_H
1.35 +# include <float.h>
1.36 +# else /* NO_FLOAT_H */
1.37 +# ifndef NO_VALUES_H
1.38 +# include <values.h>
1.39 +# endif /* !NO_VALUES_H */
1.40 +# endif /* !NO_FLOAT_H */
1.41 +# define NO_ERRNO_H
1.42 +#endif /* !TCL_GENERIC_ONLY */
1.43 +
1.44 +#ifdef NO_ERRNO_H
1.45 +int errno;
1.46 +# define EDOM 33
1.47 +# define ERANGE 34
1.48 +#endif
1.49 +
1.50 +/*
1.51 + * Need DBL_MAX for IS_INF() macro...
1.52 + */
1.53 +#ifndef DBL_MAX
1.54 +# ifdef MAXDOUBLE
1.55 +# define DBL_MAX MAXDOUBLE
1.56 +# else /* !MAXDOUBLE */
1.57 +/*
1.58 + * This value is from the Solaris headers, but doubles seem to be the
1.59 + * same size everywhere. Long doubles aren't, but we don't use those.
1.60 + */
1.61 +# define DBL_MAX 1.79769313486231570e+308
1.62 +# endif /* MAXDOUBLE */
1.63 +#endif /* !DBL_MAX */
1.64 +
1.65 +/*
1.66 + * Boolean flag indicating whether the Tcl bytecode interpreter has been
1.67 + * initialized.
1.68 + */
1.69 +
1.70 +static int execInitialized = 0;
1.71 +TCL_DECLARE_MUTEX(execMutex)
1.72 +
1.73 +#ifdef TCL_COMPILE_DEBUG
1.74 +/*
1.75 + * Variable that controls whether execution tracing is enabled and, if so,
1.76 + * what level of tracing is desired:
1.77 + * 0: no execution tracing
1.78 + * 1: trace invocations of Tcl procs only
1.79 + * 2: trace invocations of all (not compiled away) commands
1.80 + * 3: display each instruction executed
1.81 + * This variable is linked to the Tcl variable "tcl_traceExec".
1.82 + */
1.83 +
1.84 +int tclTraceExec = 0;
1.85 +#endif
1.86 +
1.87 +/*
1.88 + * Mapping from expression instruction opcodes to strings; used for error
1.89 + * messages. Note that these entries must match the order and number of the
1.90 + * expression opcodes (e.g., INST_LOR) in tclCompile.h.
1.91 + */
1.92 +
1.93 +static char *operatorStrings[] = {
1.94 + "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
1.95 + "+", "-", "*", "/", "%", "+", "-", "~", "!",
1.96 + "BUILTIN FUNCTION", "FUNCTION",
1.97 + "", "", "", "", "", "", "", "", "eq", "ne",
1.98 +};
1.99 +
1.100 +/*
1.101 + * Mapping from Tcl result codes to strings; used for error and debugging
1.102 + * messages.
1.103 + */
1.104 +
1.105 +#ifdef TCL_COMPILE_DEBUG
1.106 +static char *resultStrings[] = {
1.107 + "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
1.108 +};
1.109 +#endif
1.110 +
1.111 +/*
1.112 + * These are used by evalstats to monitor object usage in Tcl.
1.113 + */
1.114 +
1.115 +#ifdef TCL_COMPILE_STATS
1.116 +long tclObjsAlloced = 0;
1.117 +long tclObjsFreed = 0;
1.118 +#define TCL_MAX_SHARED_OBJ_STATS 5
1.119 +long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
1.120 +#endif /* TCL_COMPILE_STATS */
1.121 +
1.122 +/*
1.123 + * Macros for testing floating-point values for certain special cases. Test
1.124 + * for not-a-number by comparing a value against itself; test for infinity
1.125 + * by comparing against the largest floating-point value.
1.126 + */
1.127 +
1.128 +#define IS_NAN(v) ((v) != (v))
1.129 +#define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
1.130 +
1.131 +/*
1.132 + * The new macro for ending an instruction; note that a
1.133 + * reasonable C-optimiser will resolve all branches
1.134 + * at compile time. (result) is always a constant; the macro
1.135 + * NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
1.136 + * resolved at runtime for variable (nCleanup).
1.137 + *
1.138 + * ARGUMENTS:
1.139 + * pcAdjustment: how much to increment pc
1.140 + * nCleanup: how many objects to remove from the stack
1.141 + * result: 0 indicates no object should be pushed on the
1.142 + * stack; otherwise, push objResultPtr. If (result < 0),
1.143 + * objResultPtr already has the correct reference count.
1.144 + */
1.145 +
1.146 +#define NEXT_INST_F(pcAdjustment, nCleanup, result) \
1.147 + if (nCleanup == 0) {\
1.148 + if (result != 0) {\
1.149 + if ((result) > 0) {\
1.150 + PUSH_OBJECT(objResultPtr);\
1.151 + } else {\
1.152 + stackPtr[++stackTop] = objResultPtr;\
1.153 + }\
1.154 + } \
1.155 + pc += (pcAdjustment);\
1.156 + goto cleanup0;\
1.157 + } else if (result != 0) {\
1.158 + if ((result) > 0) {\
1.159 + Tcl_IncrRefCount(objResultPtr);\
1.160 + }\
1.161 + pc += (pcAdjustment);\
1.162 + switch (nCleanup) {\
1.163 + case 1: goto cleanup1_pushObjResultPtr;\
1.164 + case 2: goto cleanup2_pushObjResultPtr;\
1.165 + default: panic("ERROR: bad usage of macro NEXT_INST_F");\
1.166 + }\
1.167 + } else {\
1.168 + pc += (pcAdjustment);\
1.169 + switch (nCleanup) {\
1.170 + case 1: goto cleanup1;\
1.171 + case 2: goto cleanup2;\
1.172 + default: panic("ERROR: bad usage of macro NEXT_INST_F");\
1.173 + }\
1.174 + }
1.175 +
1.176 +#define NEXT_INST_V(pcAdjustment, nCleanup, result) \
1.177 + pc += (pcAdjustment);\
1.178 + cleanup = (nCleanup);\
1.179 + if (result) {\
1.180 + if ((result) > 0) {\
1.181 + Tcl_IncrRefCount(objResultPtr);\
1.182 + }\
1.183 + goto cleanupV_pushObjResultPtr;\
1.184 + } else {\
1.185 + goto cleanupV;\
1.186 + }
1.187 +
1.188 +
1.189 +/*
1.190 + * Macros used to cache often-referenced Tcl evaluation stack information
1.191 + * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
1.192 + * pair must surround any call inside TclExecuteByteCode (and a few other
1.193 + * procedures that use this scheme) that could result in a recursive call
1.194 + * to TclExecuteByteCode.
1.195 + */
1.196 +
1.197 +#define CACHE_STACK_INFO() \
1.198 + stackPtr = eePtr->stackPtr; \
1.199 + stackTop = eePtr->stackTop
1.200 +
1.201 +#define DECACHE_STACK_INFO() \
1.202 + eePtr->stackTop = stackTop
1.203 +
1.204 +
1.205 +/*
1.206 + * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
1.207 + * increments the object's ref count since it makes the stack have another
1.208 + * reference pointing to the object. However, POP_OBJECT does not decrement
1.209 + * the ref count. This is because the stack may hold the only reference to
1.210 + * the object, so the object would be destroyed if its ref count were
1.211 + * decremented before the caller had a chance to, e.g., store it in a
1.212 + * variable. It is the caller's responsibility to decrement the ref count
1.213 + * when it is finished with an object.
1.214 + *
1.215 + * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
1.216 + * macro. The actual parameter might be an expression with side effects,
1.217 + * and this ensures that it will be executed only once.
1.218 + */
1.219 +
1.220 +#define PUSH_OBJECT(objPtr) \
1.221 + Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
1.222 +
1.223 +#define POP_OBJECT() \
1.224 + (stackPtr[stackTop--])
1.225 +
1.226 +/*
1.227 + * Macros used to trace instruction execution. The macros TRACE,
1.228 + * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
1.229 + * O2S is only used in TRACE* calls to get a string from an object.
1.230 + */
1.231 +
1.232 +#ifdef TCL_COMPILE_DEBUG
1.233 +# define TRACE(a) \
1.234 + if (traceInstructions) { \
1.235 + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
1.236 + (unsigned int)(pc - codePtr->codeStart), \
1.237 + GetOpcodeName(pc)); \
1.238 + printf a; \
1.239 + }
1.240 +# define TRACE_APPEND(a) \
1.241 + if (traceInstructions) { \
1.242 + printf a; \
1.243 + }
1.244 +# define TRACE_WITH_OBJ(a, objPtr) \
1.245 + if (traceInstructions) { \
1.246 + fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
1.247 + (unsigned int)(pc - codePtr->codeStart), \
1.248 + GetOpcodeName(pc)); \
1.249 + printf a; \
1.250 + TclPrintObject(stdout, objPtr, 30); \
1.251 + fprintf(stdout, "\n"); \
1.252 + }
1.253 +# define O2S(objPtr) \
1.254 + (objPtr ? TclGetString(objPtr) : "")
1.255 +#else /* !TCL_COMPILE_DEBUG */
1.256 +# define TRACE(a)
1.257 +# define TRACE_APPEND(a)
1.258 +# define TRACE_WITH_OBJ(a, objPtr)
1.259 +# define O2S(objPtr)
1.260 +#endif /* TCL_COMPILE_DEBUG */
1.261 +
1.262 +/*
1.263 + * Macro to read a string containing either a wide or an int and
1.264 + * decide which it is while decoding it at the same time. This
1.265 + * enforces the policy that integer constants between LONG_MIN and
1.266 + * LONG_MAX (inclusive) are represented by normal longs, and integer
1.267 + * constants outside that range are represented by wide ints.
1.268 + *
1.269 + * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
1.270 + * generates an error message.
1.271 + */
1.272 +#define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
1.273 + (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \
1.274 + if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
1.275 + && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
1.276 + (objPtr)->typePtr = &tclIntType; \
1.277 + (objPtr)->internalRep.longValue = (longVar) \
1.278 + = Tcl_WideAsLong(wideVar); \
1.279 + }
1.280 +#define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
1.281 + (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \
1.282 + &(wideVar)); \
1.283 + if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
1.284 + && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
1.285 + (objPtr)->typePtr = &tclIntType; \
1.286 + (objPtr)->internalRep.longValue = (longVar) \
1.287 + = Tcl_WideAsLong(wideVar); \
1.288 + }
1.289 +/*
1.290 + * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from
1.291 + * an obj.
1.292 + */
1.293 +#define FORCE_LONG(objPtr, longVar, wideVar) \
1.294 + if ((objPtr)->typePtr == &tclWideIntType) { \
1.295 + (longVar) = Tcl_WideAsLong(wideVar); \
1.296 + }
1.297 +#define IS_INTEGER_TYPE(typePtr) \
1.298 + ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
1.299 +#define IS_NUMERIC_TYPE(typePtr) \
1.300 + (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)
1.301 +
1.302 +#define W0 Tcl_LongAsWide(0)
1.303 +/*
1.304 + * For tracing that uses wide values.
1.305 + */
1.306 +#define LLD "%" TCL_LL_MODIFIER "d"
1.307 +
1.308 +#ifndef TCL_WIDE_INT_IS_LONG
1.309 +/*
1.310 + * Extract a double value from a general numeric object.
1.311 + */
1.312 +#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
1.313 + if ((typePtr) == &tclIntType) { \
1.314 + (doubleVar) = (double) (objPtr)->internalRep.longValue; \
1.315 + } else if ((typePtr) == &tclWideIntType) { \
1.316 + (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\
1.317 + } else { \
1.318 + (doubleVar) = (objPtr)->internalRep.doubleValue; \
1.319 + }
1.320 +#else /* TCL_WIDE_INT_IS_LONG */
1.321 +#define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
1.322 + if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \
1.323 + (doubleVar) = (double) (objPtr)->internalRep.longValue; \
1.324 + } else { \
1.325 + (doubleVar) = (objPtr)->internalRep.doubleValue; \
1.326 + }
1.327 +#endif /* TCL_WIDE_INT_IS_LONG */
1.328 +
1.329 +/*
1.330 + * Declarations for local procedures to this file:
1.331 + */
1.332 +
1.333 +static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
1.334 + ByteCode *codePtr));
1.335 +static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.336 + ExecEnv *eePtr, ClientData clientData));
1.337 +static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.338 + ExecEnv *eePtr, ClientData clientData));
1.339 +static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.340 + ExecEnv *eePtr, int objc, Tcl_Obj **objv));
1.341 +static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.342 + ExecEnv *eePtr, ClientData clientData));
1.343 +static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.344 + ExecEnv *eePtr, ClientData clientData));
1.345 +static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.346 + ExecEnv *eePtr, ClientData clientData));
1.347 +static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.348 + ExecEnv *eePtr, ClientData clientData));
1.349 +static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.350 + ExecEnv *eePtr, ClientData clientData));
1.351 +static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.352 + ExecEnv *eePtr, ClientData clientData));
1.353 +static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
1.354 + ExecEnv *eePtr, ClientData clientData));
1.355 +#ifdef TCL_COMPILE_STATS
1.356 +static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
1.357 + Tcl_Interp *interp, int objc,
1.358 + Tcl_Obj *CONST objv[]));
1.359 +#endif /* TCL_COMPILE_STATS */
1.360 +#ifdef TCL_COMPILE_DEBUG
1.361 +static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
1.362 +#endif /* TCL_COMPILE_DEBUG */
1.363 +static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
1.364 + int catchOnly, ByteCode* codePtr));
1.365 +static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
1.366 + ByteCode* codePtr, int *lengthPtr));
1.367 +static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
1.368 +static void IllegalExprOperandType _ANSI_ARGS_((
1.369 + Tcl_Interp *interp, unsigned char *pc,
1.370 + Tcl_Obj *opndPtr));
1.371 +static void InitByteCodeExecution _ANSI_ARGS_((
1.372 + Tcl_Interp *interp));
1.373 +#ifdef TCL_COMPILE_DEBUG
1.374 +static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
1.375 +static char * StringForResultCode _ANSI_ARGS_((int result));
1.376 +static void ValidatePcAndStackTop _ANSI_ARGS_((
1.377 + ByteCode *codePtr, unsigned char *pc,
1.378 + int stackTop, int stackLowerBound));
1.379 +#endif /* TCL_COMPILE_DEBUG */
1.380 +static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
1.381 + Tcl_Obj *objPtr));
1.382 +
1.383 +/*
1.384 +========== Begin of math function wrappers =============
1.385 +The math function wrappers bellow are need to avoid the "Import relocation does not refer to code segment" error
1.386 +message reported from ELF2E32 tool.
1.387 +*/
1.388 +
1.389 +static double Tcl_acos(double x)
1.390 + {
1.391 + return acos(x);
1.392 + }
1.393 +
1.394 +static double Tcl_asin(double x)
1.395 + {
1.396 + return asin(x);
1.397 + }
1.398 +
1.399 +static double Tcl_atan(double x)
1.400 + {
1.401 + return atan(x);
1.402 + }
1.403 +
1.404 +static double Tcl_atan2(double x, double y)
1.405 + {
1.406 + return atan2(x, y);
1.407 + }
1.408 +
1.409 +static double Tcl_ceil(double num)
1.410 + {
1.411 + return ceil(num);
1.412 + }
1.413 +
1.414 +static double Tcl_cos(double x)
1.415 + {
1.416 + return cos(x);
1.417 + }
1.418 +
1.419 +static double Tcl_cosh(double x)
1.420 + {
1.421 + return cosh(x);
1.422 + }
1.423 +
1.424 +static double Tcl_exp(double x)
1.425 + {
1.426 + return exp(x);
1.427 + }
1.428 +
1.429 +static double Tcl_floor(double x)
1.430 + {
1.431 + return floor(x);
1.432 + }
1.433 +
1.434 +static double Tcl_fmod(double numerator, double denominator)
1.435 + {
1.436 + return fmod(numerator, denominator);
1.437 + }
1.438 +
1.439 +static double Tcl_hypot(double x, double y)
1.440 + {
1.441 + return hypot(x, y);
1.442 + }
1.443 +
1.444 +static double Tcl_log(double x)
1.445 + {
1.446 + return log(x);
1.447 + }
1.448 +
1.449 +static double Tcl_log10(double x)
1.450 + {
1.451 + return log10(x);
1.452 + }
1.453 +
1.454 +static double Tcl_pow(double base, double exponent)
1.455 + {
1.456 + return pow(base, exponent);
1.457 + }
1.458 +
1.459 +static double Tcl_sin(double x)
1.460 + {
1.461 + return sin(x);
1.462 + }
1.463 +
1.464 +static double Tcl_sinh(double x)
1.465 + {
1.466 + return sinh(x);
1.467 + }
1.468 +
1.469 +static double Tcl_sqrt(double x)
1.470 + {
1.471 + return sqrt(x);
1.472 + }
1.473 +
1.474 +static double Tcl_tan(double x)
1.475 + {
1.476 + return tan(x);
1.477 + }
1.478 +
1.479 +static double Tcl_tanh(double x)
1.480 + {
1.481 + return tanh(x);
1.482 + }
1.483 +
1.484 +/*
1.485 +========== End of math function wrappers ===============
1.486 +*/
1.487 +
1.488 +/*
1.489 + * Table describing the built-in math functions. Entries in this table are
1.490 + * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
1.491 + * operand byte.
1.492 + */
1.493 +
1.494 +BuiltinFunc tclBuiltinFuncTable[] = {
1.495 +#ifndef TCL_NO_MATH
1.496 + {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_acos},
1.497 + {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_asin},
1.498 + {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_atan},
1.499 + {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_atan2},
1.500 + {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_ceil},
1.501 + {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_cos},
1.502 + {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_cosh},
1.503 + {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_exp},
1.504 + {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_floor},
1.505 + {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_fmod},
1.506 + {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_hypot},
1.507 + {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_log},
1.508 + {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_log10},
1.509 + {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) Tcl_pow},
1.510 + {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sin},
1.511 + {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sinh},
1.512 + {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_sqrt},
1.513 + {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_tan},
1.514 + {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) Tcl_tanh},
1.515 +#endif
1.516 + {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
1.517 + {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
1.518 + {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
1.519 + {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
1.520 + {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
1.521 + {"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
1.522 + {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
1.523 + {0},
1.524 +};
1.525 +
1.526 +/*
1.527 + *----------------------------------------------------------------------
1.528 + *
1.529 + * InitByteCodeExecution --
1.530 + *
1.531 + * This procedure is called once to initialize the Tcl bytecode
1.532 + * interpreter.
1.533 + *
1.534 + * Results:
1.535 + * None.
1.536 + *
1.537 + * Side effects:
1.538 + * This procedure initializes the array of instruction names. If
1.539 + * compiling with the TCL_COMPILE_STATS flag, it initializes the
1.540 + * array that counts the executions of each instruction and it
1.541 + * creates the "evalstats" command. It also establishes the link
1.542 + * between the Tcl "tcl_traceExec" and C "tclTraceExec" variables.
1.543 + *
1.544 + *----------------------------------------------------------------------
1.545 + */
1.546 +
1.547 +static void
1.548 +InitByteCodeExecution(interp)
1.549 + Tcl_Interp *interp; /* Interpreter for which the Tcl variable
1.550 + * "tcl_traceExec" is linked to control
1.551 + * instruction tracing. */
1.552 +{
1.553 +#ifdef TCL_COMPILE_DEBUG
1.554 + if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
1.555 + TCL_LINK_INT) != TCL_OK) {
1.556 + panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
1.557 + }
1.558 +#endif
1.559 +#ifdef TCL_COMPILE_STATS
1.560 + Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd,
1.561 + (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
1.562 +#endif /* TCL_COMPILE_STATS */
1.563 +}
1.564 +
1.565 +/*
1.566 + *----------------------------------------------------------------------
1.567 + *
1.568 + * TclCreateExecEnv --
1.569 + *
1.570 + * This procedure creates a new execution environment for Tcl bytecode
1.571 + * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
1.572 + * is typically created once for each Tcl interpreter (Interp
1.573 + * structure) and recursively passed to TclExecuteByteCode to execute
1.574 + * ByteCode sequences for nested commands.
1.575 + *
1.576 + * Results:
1.577 + * A newly allocated ExecEnv is returned. This points to an empty
1.578 + * evaluation stack of the standard initial size.
1.579 + *
1.580 + * Side effects:
1.581 + * The bytecode interpreter is also initialized here, as this
1.582 + * procedure will be called before any call to TclExecuteByteCode.
1.583 + *
1.584 + *----------------------------------------------------------------------
1.585 + */
1.586 +
1.587 +#define TCL_STACK_INITIAL_SIZE 2000
1.588 +
1.589 +ExecEnv *
1.590 +TclCreateExecEnv(interp)
1.591 + Tcl_Interp *interp; /* Interpreter for which the execution
1.592 + * environment is being created. */
1.593 +{
1.594 + ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
1.595 + Tcl_Obj **stackPtr;
1.596 +
1.597 + stackPtr = (Tcl_Obj **)
1.598 + ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
1.599 +
1.600 + /*
1.601 + * Use the bottom pointer to keep a reference count; the
1.602 + * execution environment holds a reference.
1.603 + */
1.604 +
1.605 + stackPtr++;
1.606 + eePtr->stackPtr = stackPtr;
1.607 + stackPtr[-1] = (Tcl_Obj *) ((char *) 1);
1.608 +
1.609 + eePtr->stackTop = -1;
1.610 + eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2);
1.611 +
1.612 + eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
1.613 + Tcl_IncrRefCount(eePtr->errorInfo);
1.614 +
1.615 + eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
1.616 + Tcl_IncrRefCount(eePtr->errorCode);
1.617 +
1.618 + Tcl_MutexLock(&execMutex);
1.619 + if (!execInitialized) {
1.620 + TclInitAuxDataTypeTable();
1.621 + InitByteCodeExecution(interp);
1.622 + execInitialized = 1;
1.623 + }
1.624 + Tcl_MutexUnlock(&execMutex);
1.625 +
1.626 + return eePtr;
1.627 +}
1.628 +#undef TCL_STACK_INITIAL_SIZE
1.629 +
1.630 +/*
1.631 + *----------------------------------------------------------------------
1.632 + *
1.633 + * TclDeleteExecEnv --
1.634 + *
1.635 + * Frees the storage for an ExecEnv.
1.636 + *
1.637 + * Results:
1.638 + * None.
1.639 + *
1.640 + * Side effects:
1.641 + * Storage for an ExecEnv and its contained storage (e.g. the
1.642 + * evaluation stack) is freed.
1.643 + *
1.644 + *----------------------------------------------------------------------
1.645 + */
1.646 +
1.647 +void
1.648 +TclDeleteExecEnv(eePtr)
1.649 + ExecEnv *eePtr; /* Execution environment to free. */
1.650 +{
1.651 + if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
1.652 + ckfree((char *) (eePtr->stackPtr-1));
1.653 + } else {
1.654 + panic("ERROR: freeing an execEnv whose stack is still in use.\n");
1.655 + }
1.656 + TclDecrRefCount(eePtr->errorInfo);
1.657 + TclDecrRefCount(eePtr->errorCode);
1.658 + ckfree((char *) eePtr);
1.659 +}
1.660 +
1.661 +/*
1.662 + *----------------------------------------------------------------------
1.663 + *
1.664 + * TclFinalizeExecution --
1.665 + *
1.666 + * Finalizes the execution environment setup so that it can be
1.667 + * later reinitialized.
1.668 + *
1.669 + * Results:
1.670 + * None.
1.671 + *
1.672 + * Side effects:
1.673 + * After this call, the next time TclCreateExecEnv will be called
1.674 + * it will call InitByteCodeExecution.
1.675 + *
1.676 + *----------------------------------------------------------------------
1.677 + */
1.678 +
1.679 +void
1.680 +TclFinalizeExecution()
1.681 +{
1.682 + Tcl_MutexLock(&execMutex);
1.683 + execInitialized = 0;
1.684 + Tcl_MutexUnlock(&execMutex);
1.685 + TclFinalizeAuxDataTypeTable();
1.686 +}
1.687 +
1.688 +/*
1.689 + *----------------------------------------------------------------------
1.690 + *
1.691 + * GrowEvaluationStack --
1.692 + *
1.693 + * This procedure grows a Tcl evaluation stack stored in an ExecEnv.
1.694 + *
1.695 + * Results:
1.696 + * None.
1.697 + *
1.698 + * Side effects:
1.699 + * The size of the evaluation stack is doubled.
1.700 + *
1.701 + *----------------------------------------------------------------------
1.702 + */
1.703 +
1.704 +static void
1.705 +GrowEvaluationStack(eePtr)
1.706 + register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
1.707 + * stack to enlarge. */
1.708 +{
1.709 + /*
1.710 + * The current Tcl stack elements are stored from eePtr->stackPtr[0]
1.711 + * to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
1.712 + */
1.713 +
1.714 + int currElems = (eePtr->stackEnd + 1);
1.715 + int newElems = 2*currElems;
1.716 + int currBytes = currElems * sizeof(Tcl_Obj *);
1.717 + int newBytes = 2*currBytes;
1.718 + Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
1.719 + Tcl_Obj **oldStackPtr = eePtr->stackPtr;
1.720 +
1.721 + /*
1.722 + * We keep the stack reference count as a (char *), as that
1.723 + * works nicely as a portable pointer-sized counter.
1.724 + */
1.725 +
1.726 + char *refCount = (char *) oldStackPtr[-1];
1.727 +
1.728 + /*
1.729 + * Copy the existing stack items to the new stack space, free the old
1.730 + * storage if appropriate, and record the refCount of the new stack
1.731 + * held by the environment.
1.732 + */
1.733 +
1.734 + newStackPtr++;
1.735 + memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
1.736 + (size_t) currBytes);
1.737 +
1.738 + if (refCount == (char *) 1) {
1.739 + ckfree((VOID *) (oldStackPtr-1));
1.740 + } else {
1.741 + /*
1.742 + * Remove the reference corresponding to the
1.743 + * environment pointer.
1.744 + */
1.745 +
1.746 + oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
1.747 + }
1.748 +
1.749 + eePtr->stackPtr = newStackPtr;
1.750 + eePtr->stackEnd = (newElems - 2); /* index of last usable item */
1.751 + newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);
1.752 +}
1.753 +
1.754 +/*
1.755 + *--------------------------------------------------------------
1.756 + *
1.757 + * Tcl_ExprObj --
1.758 + *
1.759 + * Evaluate an expression in a Tcl_Obj.
1.760 + *
1.761 + * Results:
1.762 + * A standard Tcl object result. If the result is other than TCL_OK,
1.763 + * then the interpreter's result contains an error message. If the
1.764 + * result is TCL_OK, then a pointer to the expression's result value
1.765 + * object is stored in resultPtrPtr. In that case, the object's ref
1.766 + * count is incremented to reflect the reference returned to the
1.767 + * caller; the caller is then responsible for the resulting object
1.768 + * and must, for example, decrement the ref count when it is finished
1.769 + * with the object.
1.770 + *
1.771 + * Side effects:
1.772 + * Any side effects caused by subcommands in the expression, if any.
1.773 + * The interpreter result is not modified unless there is an error.
1.774 + *
1.775 + *--------------------------------------------------------------
1.776 + */
1.777 +
1.778 +EXPORT_C int
1.779 +Tcl_ExprObj(interp, objPtr, resultPtrPtr)
1.780 + Tcl_Interp *interp; /* Context in which to evaluate the
1.781 + * expression. */
1.782 + register Tcl_Obj *objPtr; /* Points to Tcl object containing
1.783 + * expression to evaluate. */
1.784 + Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
1.785 + * result is stored if no errors occur. */
1.786 +{
1.787 + Interp *iPtr = (Interp *) interp;
1.788 + CompileEnv compEnv; /* Compilation environment structure
1.789 + * allocated in frame. */
1.790 + LiteralTable *localTablePtr = &(compEnv.localLitTable);
1.791 + register ByteCode *codePtr = NULL;
1.792 + /* Tcl Internal type of bytecode.
1.793 + * Initialized to avoid compiler warning. */
1.794 + AuxData *auxDataPtr;
1.795 + LiteralEntry *entryPtr;
1.796 + Tcl_Obj *saveObjPtr;
1.797 + char *string;
1.798 + int length, i, result;
1.799 +
1.800 + /*
1.801 + * First handle some common expressions specially.
1.802 + */
1.803 +
1.804 + string = Tcl_GetStringFromObj(objPtr, &length);
1.805 + if (length == 1) {
1.806 + if (*string == '0') {
1.807 + *resultPtrPtr = Tcl_NewLongObj(0);
1.808 + Tcl_IncrRefCount(*resultPtrPtr);
1.809 + return TCL_OK;
1.810 + } else if (*string == '1') {
1.811 + *resultPtrPtr = Tcl_NewLongObj(1);
1.812 + Tcl_IncrRefCount(*resultPtrPtr);
1.813 + return TCL_OK;
1.814 + }
1.815 + } else if ((length == 2) && (*string == '!')) {
1.816 + if (*(string+1) == '0') {
1.817 + *resultPtrPtr = Tcl_NewLongObj(1);
1.818 + Tcl_IncrRefCount(*resultPtrPtr);
1.819 + return TCL_OK;
1.820 + } else if (*(string+1) == '1') {
1.821 + *resultPtrPtr = Tcl_NewLongObj(0);
1.822 + Tcl_IncrRefCount(*resultPtrPtr);
1.823 + return TCL_OK;
1.824 + }
1.825 + }
1.826 +
1.827 + /*
1.828 + * Get the ByteCode from the object. If it exists, make sure it hasn't
1.829 + * been invalidated by, e.g., someone redefining a command with a
1.830 + * compile procedure (this might make the compiled code wrong). If
1.831 + * necessary, convert the object to be a ByteCode object and compile it.
1.832 + * Also, if the code was compiled in/for a different interpreter, we
1.833 + * recompile it.
1.834 + *
1.835 + * Precompiled expressions, however, are immutable and therefore
1.836 + * they are not recompiled, even if the epoch has changed.
1.837 + *
1.838 + */
1.839 +
1.840 + if (objPtr->typePtr == &tclByteCodeType) {
1.841 + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
1.842 + if (((Interp *) *codePtr->interpHandle != iPtr)
1.843 + || (codePtr->compileEpoch != iPtr->compileEpoch)) {
1.844 + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1.845 + if ((Interp *) *codePtr->interpHandle != iPtr) {
1.846 + panic("Tcl_ExprObj: compiled expression jumped interps");
1.847 + }
1.848 + codePtr->compileEpoch = iPtr->compileEpoch;
1.849 + } else {
1.850 + (*tclByteCodeType.freeIntRepProc)(objPtr);
1.851 + objPtr->typePtr = (Tcl_ObjType *) NULL;
1.852 + }
1.853 + }
1.854 + }
1.855 + if (objPtr->typePtr != &tclByteCodeType) {
1.856 +#ifndef TCL_TIP280
1.857 + TclInitCompileEnv(interp, &compEnv, string, length);
1.858 +#else
1.859 + /* TIP #280 : No invoker (yet) - Expression compilation */
1.860 + TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
1.861 +#endif
1.862 + result = TclCompileExpr(interp, string, length, &compEnv);
1.863 +
1.864 + /*
1.865 + * Free the compilation environment's literal table bucket array if
1.866 + * it was dynamically allocated.
1.867 + */
1.868 +
1.869 + if (localTablePtr->buckets != localTablePtr->staticBuckets) {
1.870 + ckfree((char *) localTablePtr->buckets);
1.871 + }
1.872 +
1.873 + if (result != TCL_OK) {
1.874 + /*
1.875 + * Compilation errors. Free storage allocated for compilation.
1.876 + */
1.877 +
1.878 +#ifdef TCL_COMPILE_DEBUG
1.879 + TclVerifyLocalLiteralTable(&compEnv);
1.880 +#endif /*TCL_COMPILE_DEBUG*/
1.881 + entryPtr = compEnv.literalArrayPtr;
1.882 + for (i = 0; i < compEnv.literalArrayNext; i++) {
1.883 + TclReleaseLiteral(interp, entryPtr->objPtr);
1.884 + entryPtr++;
1.885 + }
1.886 +#ifdef TCL_COMPILE_DEBUG
1.887 + TclVerifyGlobalLiteralTable(iPtr);
1.888 +#endif /*TCL_COMPILE_DEBUG*/
1.889 +
1.890 + auxDataPtr = compEnv.auxDataArrayPtr;
1.891 + for (i = 0; i < compEnv.auxDataArrayNext; i++) {
1.892 + if (auxDataPtr->type->freeProc != NULL) {
1.893 + auxDataPtr->type->freeProc(auxDataPtr->clientData);
1.894 + }
1.895 + auxDataPtr++;
1.896 + }
1.897 + TclFreeCompileEnv(&compEnv);
1.898 + return result;
1.899 + }
1.900 +
1.901 + /*
1.902 + * Successful compilation. If the expression yielded no
1.903 + * instructions, push an zero object as the expression's result.
1.904 + */
1.905 +
1.906 + if (compEnv.codeNext == compEnv.codeStart) {
1.907 + TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
1.908 + &compEnv);
1.909 + }
1.910 +
1.911 + /*
1.912 + * Add a "done" instruction as the last instruction and change the
1.913 + * object into a ByteCode object. Ownership of the literal objects
1.914 + * and aux data items is given to the ByteCode object.
1.915 + */
1.916 +
1.917 + compEnv.numSrcBytes = iPtr->termOffset;
1.918 + TclEmitOpcode(INST_DONE, &compEnv);
1.919 + TclInitByteCodeObj(objPtr, &compEnv);
1.920 + TclFreeCompileEnv(&compEnv);
1.921 + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
1.922 +#ifdef TCL_COMPILE_DEBUG
1.923 + if (tclTraceCompile == 2) {
1.924 + TclPrintByteCodeObj(interp, objPtr);
1.925 + }
1.926 +#endif /* TCL_COMPILE_DEBUG */
1.927 + }
1.928 +
1.929 + /*
1.930 + * Execute the expression after first saving the interpreter's result.
1.931 + */
1.932 +
1.933 + saveObjPtr = Tcl_GetObjResult(interp);
1.934 + Tcl_IncrRefCount(saveObjPtr);
1.935 + Tcl_ResetResult(interp);
1.936 +
1.937 + /*
1.938 + * Increment the code's ref count while it is being executed. If
1.939 + * afterwards no references to it remain, free the code.
1.940 + */
1.941 +
1.942 + codePtr->refCount++;
1.943 + result = TclExecuteByteCode(interp, codePtr);
1.944 + codePtr->refCount--;
1.945 + if (codePtr->refCount <= 0) {
1.946 + TclCleanupByteCode(codePtr);
1.947 + objPtr->typePtr = NULL;
1.948 + objPtr->internalRep.otherValuePtr = NULL;
1.949 + }
1.950 +
1.951 + /*
1.952 + * If the expression evaluated successfully, store a pointer to its
1.953 + * value object in resultPtrPtr then restore the old interpreter result.
1.954 + * We increment the object's ref count to reflect the reference that we
1.955 + * are returning to the caller. We also decrement the ref count of the
1.956 + * interpreter's result object after calling Tcl_SetResult since we
1.957 + * next store into that field directly.
1.958 + */
1.959 +
1.960 + if (result == TCL_OK) {
1.961 + *resultPtrPtr = iPtr->objResultPtr;
1.962 + Tcl_IncrRefCount(iPtr->objResultPtr);
1.963 +
1.964 + Tcl_SetObjResult(interp, saveObjPtr);
1.965 + }
1.966 + TclDecrRefCount(saveObjPtr);
1.967 + return result;
1.968 +}
1.969 +
1.970 +/*
1.971 + *----------------------------------------------------------------------
1.972 + *
1.973 + * TclCompEvalObj --
1.974 + *
1.975 + * This procedure evaluates the script contained in a Tcl_Obj by
1.976 + * first compiling it and then passing it to TclExecuteByteCode.
1.977 + *
1.978 + * Results:
1.979 + * The return value is one of the return codes defined in tcl.h
1.980 + * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
1.981 + * that either contains the result of executing the code or an
1.982 + * error message.
1.983 + *
1.984 + * Side effects:
1.985 + * Almost certainly, depending on the ByteCode's instructions.
1.986 + *
1.987 + *----------------------------------------------------------------------
1.988 + */
1.989 +
1.990 +int
1.991 +#ifndef TCL_TIP280
1.992 +TclCompEvalObj(interp, objPtr)
1.993 +#else
1.994 +TclCompEvalObj(interp, objPtr, invoker, word)
1.995 +#endif
1.996 + Tcl_Interp *interp;
1.997 + Tcl_Obj *objPtr;
1.998 +#ifdef TCL_TIP280
1.999 + CONST CmdFrame* invoker; /* Frame of the command doing the eval */
1.1000 + int word; /* Index of the word which is in objPtr */
1.1001 +#endif
1.1002 +{
1.1003 + register Interp *iPtr = (Interp *) interp;
1.1004 + register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
1.1005 + int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
1.1006 + * at all were executed. */
1.1007 + char *script;
1.1008 + int numSrcBytes;
1.1009 + int result;
1.1010 + Namespace *namespacePtr;
1.1011 +
1.1012 +
1.1013 + /*
1.1014 + * Check that the interpreter is ready to execute scripts
1.1015 + */
1.1016 +
1.1017 + iPtr->numLevels++;
1.1018 + if (TclInterpReady(interp) == TCL_ERROR) {
1.1019 + iPtr->numLevels--;
1.1020 + return TCL_ERROR;
1.1021 + }
1.1022 +
1.1023 + if (iPtr->varFramePtr != NULL) {
1.1024 + namespacePtr = iPtr->varFramePtr->nsPtr;
1.1025 + } else {
1.1026 + namespacePtr = iPtr->globalNsPtr;
1.1027 + }
1.1028 +
1.1029 + /*
1.1030 + * If the object is not already of tclByteCodeType, compile it (and
1.1031 + * reset the compilation flags in the interpreter; this should be
1.1032 + * done after any compilation).
1.1033 + * Otherwise, check that it is "fresh" enough.
1.1034 + */
1.1035 +
1.1036 + if (objPtr->typePtr != &tclByteCodeType) {
1.1037 + recompileObj:
1.1038 + iPtr->errorLine = 1;
1.1039 +
1.1040 +#ifdef TCL_TIP280
1.1041 + /* TIP #280. Remember the invoker for a moment in the interpreter
1.1042 + * structures so that the byte code compiler can pick it up when
1.1043 + * initializing the compilation environment, i.e. the extended
1.1044 + * location information.
1.1045 + */
1.1046 +
1.1047 + iPtr->invokeCmdFramePtr = invoker;
1.1048 + iPtr->invokeWord = word;
1.1049 +#endif
1.1050 + result = tclByteCodeType.setFromAnyProc(interp, objPtr);
1.1051 +#ifdef TCL_TIP280
1.1052 + iPtr->invokeCmdFramePtr = NULL;
1.1053 +#endif
1.1054 +
1.1055 + if (result != TCL_OK) {
1.1056 + iPtr->numLevels--;
1.1057 + return result;
1.1058 + }
1.1059 + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
1.1060 + } else {
1.1061 + /*
1.1062 + * Make sure the Bytecode hasn't been invalidated by, e.g., someone
1.1063 + * redefining a command with a compile procedure (this might make the
1.1064 + * compiled code wrong).
1.1065 + * The object needs to be recompiled if it was compiled in/for a
1.1066 + * different interpreter, or for a different namespace, or for the
1.1067 + * same namespace but with different name resolution rules.
1.1068 + * Precompiled objects, however, are immutable and therefore
1.1069 + * they are not recompiled, even if the epoch has changed.
1.1070 + *
1.1071 + * To be pedantically correct, we should also check that the
1.1072 + * originating procPtr is the same as the current context procPtr
1.1073 + * (assuming one exists at all - none for global level). This
1.1074 + * code is #def'ed out because [info body] was changed to never
1.1075 + * return a bytecode type object, which should obviate us from
1.1076 + * the extra checks here.
1.1077 + */
1.1078 + codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
1.1079 + if (((Interp *) *codePtr->interpHandle != iPtr)
1.1080 + || (codePtr->compileEpoch != iPtr->compileEpoch)
1.1081 +#ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
1.1082 + || (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
1.1083 + iPtr->varFramePtr->procPtr == codePtr->procPtr))
1.1084 +#endif
1.1085 + || (codePtr->nsPtr != namespacePtr)
1.1086 + || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
1.1087 + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1.1088 + if ((Interp *) *codePtr->interpHandle != iPtr) {
1.1089 + panic("Tcl_EvalObj: compiled script jumped interps");
1.1090 + }
1.1091 + codePtr->compileEpoch = iPtr->compileEpoch;
1.1092 + } else {
1.1093 + /*
1.1094 + * This byteCode is invalid: free it and recompile
1.1095 + */
1.1096 + tclByteCodeType.freeIntRepProc(objPtr);
1.1097 + goto recompileObj;
1.1098 + }
1.1099 + }
1.1100 + }
1.1101 +
1.1102 + /*
1.1103 + * Execute the commands. If the code was compiled from an empty string,
1.1104 + * don't bother executing the code.
1.1105 + */
1.1106 +
1.1107 + numSrcBytes = codePtr->numSrcBytes;
1.1108 + if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
1.1109 + /*
1.1110 + * Increment the code's ref count while it is being executed. If
1.1111 + * afterwards no references to it remain, free the code.
1.1112 + */
1.1113 +
1.1114 + codePtr->refCount++;
1.1115 + result = TclExecuteByteCode(interp, codePtr);
1.1116 + codePtr->refCount--;
1.1117 + if (codePtr->refCount <= 0) {
1.1118 + TclCleanupByteCode(codePtr);
1.1119 + }
1.1120 + } else {
1.1121 + result = TCL_OK;
1.1122 + }
1.1123 + iPtr->numLevels--;
1.1124 +
1.1125 +
1.1126 + /*
1.1127 + * If no commands at all were executed, check for asynchronous
1.1128 + * handlers so that they at least get one change to execute.
1.1129 + * This is needed to handle event loops written in Tcl with
1.1130 + * empty bodies.
1.1131 + */
1.1132 +
1.1133 + if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
1.1134 + result = Tcl_AsyncInvoke(interp, result);
1.1135 +
1.1136 +
1.1137 + /*
1.1138 + * If an error occurred, record information about what was being
1.1139 + * executed when the error occurred.
1.1140 + */
1.1141 +
1.1142 + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
1.1143 + script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
1.1144 + Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
1.1145 + }
1.1146 + }
1.1147 +
1.1148 + /*
1.1149 + * Set the interpreter's termOffset member to the offset of the
1.1150 + * character just after the last one executed. We approximate the offset
1.1151 + * of the last character executed by using the number of characters
1.1152 + * compiled.
1.1153 + */
1.1154 +
1.1155 + iPtr->termOffset = numSrcBytes;
1.1156 + iPtr->flags &= ~ERR_ALREADY_LOGGED;
1.1157 +
1.1158 + return result;
1.1159 +}
1.1160 +
1.1161 +/*
1.1162 + *----------------------------------------------------------------------
1.1163 + *
1.1164 + * TclExecuteByteCode --
1.1165 + *
1.1166 + * This procedure executes the instructions of a ByteCode structure.
1.1167 + * It returns when a "done" instruction is executed or an error occurs.
1.1168 + *
1.1169 + * Results:
1.1170 + * The return value is one of the return codes defined in tcl.h
1.1171 + * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
1.1172 + * that either contains the result of executing the code or an
1.1173 + * error message.
1.1174 + *
1.1175 + * Side effects:
1.1176 + * Almost certainly, depending on the ByteCode's instructions.
1.1177 + *
1.1178 + *----------------------------------------------------------------------
1.1179 + */
1.1180 +
1.1181 +static int
1.1182 +TclExecuteByteCode(interp, codePtr)
1.1183 + Tcl_Interp *interp; /* Token for command interpreter. */
1.1184 + ByteCode *codePtr; /* The bytecode sequence to interpret. */
1.1185 +{
1.1186 + Interp *iPtr = (Interp *) interp;
1.1187 + ExecEnv *eePtr = iPtr->execEnvPtr;
1.1188 + /* Points to the execution environment. */
1.1189 + register Tcl_Obj **stackPtr = eePtr->stackPtr;
1.1190 + /* Cached evaluation stack base pointer. */
1.1191 + register int stackTop = eePtr->stackTop;
1.1192 + /* Cached top index of evaluation stack. */
1.1193 + register unsigned char *pc = codePtr->codeStart;
1.1194 + /* The current program counter. */
1.1195 + int opnd; /* Current instruction's operand byte(s). */
1.1196 + int pcAdjustment; /* Hold pc adjustment after instruction. */
1.1197 + int initStackTop = stackTop;/* Stack top at start of execution. */
1.1198 + ExceptionRange *rangePtr; /* Points to closest loop or catch exception
1.1199 + * range enclosing the pc. Used by various
1.1200 + * instructions and processCatch to
1.1201 + * process break, continue, and errors. */
1.1202 + int result = TCL_OK; /* Return code returned after execution. */
1.1203 + int storeFlags;
1.1204 + Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
1.1205 + char *bytes;
1.1206 + int length;
1.1207 + long i = 0; /* Init. avoids compiler warning. */
1.1208 + Tcl_WideInt w;
1.1209 + register int cleanup;
1.1210 + Tcl_Obj *objResultPtr;
1.1211 + char *part1, *part2;
1.1212 + Var *varPtr, *arrayPtr;
1.1213 + CallFrame *varFramePtr = iPtr->varFramePtr;
1.1214 +
1.1215 +#ifdef TCL_TIP280
1.1216 + /* TIP #280 : Structures for tracking lines */
1.1217 + CmdFrame bcFrame;
1.1218 +#endif
1.1219 +
1.1220 +#ifdef TCL_COMPILE_DEBUG
1.1221 + int traceInstructions = (tclTraceExec == 3);
1.1222 + char cmdNameBuf[21];
1.1223 +#endif
1.1224 +
1.1225 + /*
1.1226 + * This procedure uses a stack to hold information about catch commands.
1.1227 + * This information is the current operand stack top when starting to
1.1228 + * execute the code for each catch command. It starts out with stack-
1.1229 + * allocated space but uses dynamically-allocated storage if needed.
1.1230 + */
1.1231 +
1.1232 +#define STATIC_CATCH_STACK_SIZE 4
1.1233 + int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
1.1234 + int *catchStackPtr = catchStackStorage;
1.1235 + int catchTop = -1;
1.1236 +
1.1237 +#ifdef TCL_TIP280
1.1238 + /* TIP #280 : Initialize the frame. Do not push it yet. */
1.1239 +
1.1240 + bcFrame.type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
1.1241 + ? TCL_LOCATION_PREBC
1.1242 + : TCL_LOCATION_BC);
1.1243 + bcFrame.level = (iPtr->cmdFramePtr == NULL ?
1.1244 + 1 :
1.1245 + iPtr->cmdFramePtr->level + 1);
1.1246 + bcFrame.framePtr = iPtr->framePtr;
1.1247 + bcFrame.nextPtr = iPtr->cmdFramePtr;
1.1248 + bcFrame.nline = 0;
1.1249 + bcFrame.line = NULL;
1.1250 +
1.1251 + bcFrame.data.tebc.codePtr = codePtr;
1.1252 + bcFrame.data.tebc.pc = NULL;
1.1253 + bcFrame.cmd.str.cmd = NULL;
1.1254 + bcFrame.cmd.str.len = 0;
1.1255 +#endif
1.1256 +
1.1257 +#ifdef TCL_COMPILE_DEBUG
1.1258 + if (tclTraceExec >= 2) {
1.1259 + PrintByteCodeInfo(codePtr);
1.1260 + fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
1.1261 + fflush(stdout);
1.1262 + }
1.1263 + opnd = 0; /* Init. avoids compiler warning. */
1.1264 +#endif
1.1265 +
1.1266 +#ifdef TCL_COMPILE_STATS
1.1267 + iPtr->stats.numExecutions++;
1.1268 +#endif
1.1269 +
1.1270 + /*
1.1271 + * Make sure the catch stack is large enough to hold the maximum number
1.1272 + * of catch commands that could ever be executing at the same time. This
1.1273 + * will be no more than the exception range array's depth.
1.1274 + */
1.1275 +
1.1276 + if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
1.1277 + catchStackPtr = (int *)
1.1278 + ckalloc(codePtr->maxExceptDepth * sizeof(int));
1.1279 + }
1.1280 +
1.1281 + /*
1.1282 + * Make sure the stack has enough room to execute this ByteCode.
1.1283 + */
1.1284 +
1.1285 + while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
1.1286 + GrowEvaluationStack(eePtr);
1.1287 + stackPtr = eePtr->stackPtr;
1.1288 + }
1.1289 +
1.1290 + /*
1.1291 + * Loop executing instructions until a "done" instruction, a
1.1292 + * TCL_RETURN, or some error.
1.1293 + */
1.1294 +
1.1295 + goto cleanup0;
1.1296 +
1.1297 +
1.1298 + /*
1.1299 + * Targets for standard instruction endings; unrolled
1.1300 + * for speed in the most frequent cases (instructions that
1.1301 + * consume up to two stack elements).
1.1302 + *
1.1303 + * This used to be a "for(;;)" loop, with each instruction doing
1.1304 + * its own cleanup.
1.1305 + */
1.1306 +
1.1307 + cleanupV_pushObjResultPtr:
1.1308 + switch (cleanup) {
1.1309 + case 0:
1.1310 + stackPtr[++stackTop] = (objResultPtr);
1.1311 + goto cleanup0;
1.1312 + default:
1.1313 + cleanup -= 2;
1.1314 + while (cleanup--) {
1.1315 + valuePtr = POP_OBJECT();
1.1316 + TclDecrRefCount(valuePtr);
1.1317 + }
1.1318 + case 2:
1.1319 + cleanup2_pushObjResultPtr:
1.1320 + valuePtr = POP_OBJECT();
1.1321 + TclDecrRefCount(valuePtr);
1.1322 + case 1:
1.1323 + cleanup1_pushObjResultPtr:
1.1324 + valuePtr = stackPtr[stackTop];
1.1325 + TclDecrRefCount(valuePtr);
1.1326 + }
1.1327 + stackPtr[stackTop] = objResultPtr;
1.1328 + goto cleanup0;
1.1329 +
1.1330 + cleanupV:
1.1331 + switch (cleanup) {
1.1332 + default:
1.1333 + cleanup -= 2;
1.1334 + while (cleanup--) {
1.1335 + valuePtr = POP_OBJECT();
1.1336 + TclDecrRefCount(valuePtr);
1.1337 + }
1.1338 + case 2:
1.1339 + cleanup2:
1.1340 + valuePtr = POP_OBJECT();
1.1341 + TclDecrRefCount(valuePtr);
1.1342 + case 1:
1.1343 + cleanup1:
1.1344 + valuePtr = POP_OBJECT();
1.1345 + TclDecrRefCount(valuePtr);
1.1346 + case 0:
1.1347 + /*
1.1348 + * We really want to do nothing now, but this is needed
1.1349 + * for some compilers (SunPro CC)
1.1350 + */
1.1351 + break;
1.1352 + }
1.1353 +
1.1354 + cleanup0:
1.1355 +
1.1356 +#ifdef TCL_COMPILE_DEBUG
1.1357 + ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
1.1358 + if (traceInstructions) {
1.1359 + fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
1.1360 + TclPrintInstruction(codePtr, pc);
1.1361 + fflush(stdout);
1.1362 + }
1.1363 +#endif /* TCL_COMPILE_DEBUG */
1.1364 +
1.1365 +#ifdef TCL_COMPILE_STATS
1.1366 + iPtr->stats.instructionCount[*pc]++;
1.1367 +#endif
1.1368 + switch (*pc) {
1.1369 + case INST_DONE:
1.1370 + if (stackTop <= initStackTop) {
1.1371 + stackTop--;
1.1372 + goto abnormalReturn;
1.1373 + }
1.1374 +
1.1375 + /*
1.1376 + * Set the interpreter's object result to point to the
1.1377 + * topmost object from the stack, and check for a possible
1.1378 + * [catch]. The stackTop's level and refCount will be handled
1.1379 + * by "processCatch" or "abnormalReturn".
1.1380 + */
1.1381 +
1.1382 + valuePtr = stackPtr[stackTop];
1.1383 + Tcl_SetObjResult(interp, valuePtr);
1.1384 +#ifdef TCL_COMPILE_DEBUG
1.1385 + TRACE_WITH_OBJ(("=> return code=%d, result=", result),
1.1386 + iPtr->objResultPtr);
1.1387 + if (traceInstructions) {
1.1388 + fprintf(stdout, "\n");
1.1389 + }
1.1390 +#endif
1.1391 + goto checkForCatch;
1.1392 +
1.1393 + case INST_PUSH1:
1.1394 + objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
1.1395 + TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);
1.1396 + NEXT_INST_F(2, 0, 1);
1.1397 +
1.1398 + case INST_PUSH4:
1.1399 + objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
1.1400 + TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
1.1401 + NEXT_INST_F(5, 0, 1);
1.1402 +
1.1403 + case INST_POP:
1.1404 + TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
1.1405 + valuePtr = POP_OBJECT();
1.1406 + TclDecrRefCount(valuePtr);
1.1407 + NEXT_INST_F(1, 0, 0);
1.1408 +
1.1409 + case INST_DUP:
1.1410 + objResultPtr = stackPtr[stackTop];
1.1411 + TRACE_WITH_OBJ(("=> "), objResultPtr);
1.1412 + NEXT_INST_F(1, 0, 1);
1.1413 +
1.1414 + case INST_OVER:
1.1415 + opnd = TclGetUInt4AtPtr( pc+1 );
1.1416 + objResultPtr = stackPtr[ stackTop - opnd ];
1.1417 + TRACE_WITH_OBJ(("=> "), objResultPtr);
1.1418 + NEXT_INST_F(5, 0, 1);
1.1419 +
1.1420 + case INST_CONCAT1:
1.1421 + opnd = TclGetUInt1AtPtr(pc+1);
1.1422 + {
1.1423 + int totalLen = 0;
1.1424 +
1.1425 + /*
1.1426 + * Peephole optimisation for appending an empty string.
1.1427 + * This enables replacing 'K $x [set x{}]' by '$x[set x{}]'
1.1428 + * for fastest execution. Avoid doing the optimisation for wide
1.1429 + * ints - a case where equal strings may refer to different values
1.1430 + * (see [Bug 1251791]).
1.1431 + */
1.1432 +
1.1433 + if ((opnd == 2) && (stackPtr[stackTop-1]->typePtr != &tclWideIntType)) {
1.1434 + Tcl_GetStringFromObj(stackPtr[stackTop], &length);
1.1435 + if (length == 0) {
1.1436 + /* Just drop the top item from the stack */
1.1437 + NEXT_INST_F(2, 1, 0);
1.1438 + }
1.1439 + }
1.1440 +
1.1441 + /*
1.1442 + * Concatenate strings (with no separators) from the top
1.1443 + * opnd items on the stack starting with the deepest item.
1.1444 + * First, determine how many characters are needed.
1.1445 + */
1.1446 +
1.1447 + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
1.1448 + bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
1.1449 + if (bytes != NULL) {
1.1450 + totalLen += length;
1.1451 + }
1.1452 + }
1.1453 +
1.1454 + /*
1.1455 + * Initialize the new append string object by appending the
1.1456 + * strings of the opnd stack objects. Also pop the objects.
1.1457 + */
1.1458 +
1.1459 + TclNewObj(objResultPtr);
1.1460 + if (totalLen > 0) {
1.1461 + char *p = (char *) ckalloc((unsigned) (totalLen + 1));
1.1462 + objResultPtr->bytes = p;
1.1463 + objResultPtr->length = totalLen;
1.1464 + for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
1.1465 + valuePtr = stackPtr[i];
1.1466 + bytes = Tcl_GetStringFromObj(valuePtr, &length);
1.1467 + if (bytes != NULL) {
1.1468 + memcpy((VOID *) p, (VOID *) bytes,
1.1469 + (size_t) length);
1.1470 + p += length;
1.1471 + }
1.1472 + }
1.1473 + *p = '\0';
1.1474 + }
1.1475 +
1.1476 + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
1.1477 + NEXT_INST_V(2, opnd, 1);
1.1478 + }
1.1479 +
1.1480 + case INST_INVOKE_STK4:
1.1481 + opnd = TclGetUInt4AtPtr(pc+1);
1.1482 + pcAdjustment = 5;
1.1483 + goto doInvocation;
1.1484 +
1.1485 + case INST_INVOKE_STK1:
1.1486 + opnd = TclGetUInt1AtPtr(pc+1);
1.1487 + pcAdjustment = 2;
1.1488 +
1.1489 + doInvocation:
1.1490 + {
1.1491 + int objc = opnd; /* The number of arguments. */
1.1492 + Tcl_Obj **objv; /* The array of argument objects. */
1.1493 +
1.1494 + /*
1.1495 + * We keep the stack reference count as a (char *), as that
1.1496 + * works nicely as a portable pointer-sized counter.
1.1497 + */
1.1498 +
1.1499 + char **preservedStackRefCountPtr;
1.1500 +
1.1501 + /*
1.1502 + * Reference to memory block containing
1.1503 + * objv array (must be kept live throughout
1.1504 + * trace and command invokations.)
1.1505 + */
1.1506 +
1.1507 + objv = &(stackPtr[stackTop - (objc-1)]);
1.1508 +
1.1509 +#ifdef TCL_COMPILE_DEBUG
1.1510 + if (tclTraceExec >= 2) {
1.1511 + if (traceInstructions) {
1.1512 + strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
1.1513 + TRACE(("%u => call ", objc));
1.1514 + } else {
1.1515 + fprintf(stdout, "%d: (%u) invoking ",
1.1516 + iPtr->numLevels,
1.1517 + (unsigned int)(pc - codePtr->codeStart));
1.1518 + }
1.1519 + for (i = 0; i < objc; i++) {
1.1520 + TclPrintObject(stdout, objv[i], 15);
1.1521 + fprintf(stdout, " ");
1.1522 + }
1.1523 + fprintf(stdout, "\n");
1.1524 + fflush(stdout);
1.1525 + }
1.1526 +#endif /*TCL_COMPILE_DEBUG*/
1.1527 +
1.1528 + /*
1.1529 + * If trace procedures will be called, we need a
1.1530 + * command string to pass to TclEvalObjvInternal; note
1.1531 + * that a copy of the string will be made there to
1.1532 + * include the ending \0.
1.1533 + */
1.1534 +
1.1535 + bytes = NULL;
1.1536 + length = 0;
1.1537 + if (iPtr->tracePtr != NULL) {
1.1538 + Trace *tracePtr, *nextTracePtr;
1.1539 +
1.1540 + for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
1.1541 + tracePtr = nextTracePtr) {
1.1542 + nextTracePtr = tracePtr->nextPtr;
1.1543 + if (tracePtr->level == 0 ||
1.1544 + iPtr->numLevels <= tracePtr->level) {
1.1545 + /*
1.1546 + * Traces will be called: get command string
1.1547 + */
1.1548 +
1.1549 + bytes = GetSrcInfoForPc(pc, codePtr, &length);
1.1550 + break;
1.1551 + }
1.1552 + }
1.1553 + } else {
1.1554 + Command *cmdPtr;
1.1555 + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
1.1556 + if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
1.1557 + bytes = GetSrcInfoForPc(pc, codePtr, &length);
1.1558 + }
1.1559 + }
1.1560 +
1.1561 + /*
1.1562 + * A reference to part of the stack vector itself
1.1563 + * escapes our control: increase its refCount
1.1564 + * to stop it from being deallocated by a recursive
1.1565 + * call to ourselves. The extra variable is needed
1.1566 + * because all others are liable to change due to the
1.1567 + * trace procedures.
1.1568 + */
1.1569 +
1.1570 + preservedStackRefCountPtr = (char **) (stackPtr-1);
1.1571 + ++*preservedStackRefCountPtr;
1.1572 +
1.1573 + /*
1.1574 + * Finally, let TclEvalObjvInternal handle the command.
1.1575 + *
1.1576 + * TIP #280 : Record the last piece of info needed by
1.1577 + * 'TclGetSrcInfoForPc', and push the frame.
1.1578 + */
1.1579 +
1.1580 +#ifdef TCL_TIP280
1.1581 + bcFrame.data.tebc.pc = pc;
1.1582 + iPtr->cmdFramePtr = &bcFrame;
1.1583 +#endif
1.1584 + DECACHE_STACK_INFO();
1.1585 + Tcl_ResetResult(interp);
1.1586 + result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
1.1587 + CACHE_STACK_INFO();
1.1588 +#ifdef TCL_TIP280
1.1589 + iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
1.1590 +#endif
1.1591 +
1.1592 + /*
1.1593 + * If the old stack is going to be released, it is
1.1594 + * safe to do so now, since no references to objv are
1.1595 + * going to be used from now on.
1.1596 + */
1.1597 +
1.1598 + --*preservedStackRefCountPtr;
1.1599 + if (*preservedStackRefCountPtr == (char *) 0) {
1.1600 + ckfree((VOID *) preservedStackRefCountPtr);
1.1601 + }
1.1602 +
1.1603 + if (result == TCL_OK) {
1.1604 + /*
1.1605 + * Push the call's object result and continue execution
1.1606 + * with the next instruction.
1.1607 + */
1.1608 +
1.1609 + TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
1.1610 + objc, cmdNameBuf), Tcl_GetObjResult(interp));
1.1611 +
1.1612 + objResultPtr = Tcl_GetObjResult(interp);
1.1613 +
1.1614 + /*
1.1615 + * Reset the interp's result to avoid possible duplications
1.1616 + * of large objects [Bug 781585]. We do not call
1.1617 + * Tcl_ResetResult() to avoid any side effects caused by
1.1618 + * the resetting of errorInfo and errorCode [Bug 804681],
1.1619 + * which are not needed here. We chose instead to manipulate
1.1620 + * the interp's object result directly.
1.1621 + *
1.1622 + * Note that the result object is now in objResultPtr, it
1.1623 + * keeps the refCount it had in its role of iPtr->objResultPtr.
1.1624 + */
1.1625 + {
1.1626 + Tcl_Obj *newObjResultPtr;
1.1627 + TclNewObj(newObjResultPtr);
1.1628 + Tcl_IncrRefCount(newObjResultPtr);
1.1629 + iPtr->objResultPtr = newObjResultPtr;
1.1630 + }
1.1631 +
1.1632 + NEXT_INST_V(pcAdjustment, opnd, -1);
1.1633 + } else {
1.1634 + cleanup = opnd;
1.1635 + goto processExceptionReturn;
1.1636 + }
1.1637 + }
1.1638 +
1.1639 + case INST_EVAL_STK:
1.1640 + /*
1.1641 + * Note to maintainers: it is important that INST_EVAL_STK
1.1642 + * pop its argument from the stack before jumping to
1.1643 + * checkForCatch! DO NOT OPTIMISE!
1.1644 + */
1.1645 +
1.1646 + objPtr = stackPtr[stackTop];
1.1647 + DECACHE_STACK_INFO();
1.1648 +#ifndef TCL_TIP280
1.1649 + result = TclCompEvalObj(interp, objPtr);
1.1650 +#else
1.1651 + /* TIP #280: The invoking context is left NULL for a dynamically
1.1652 + * constructed command. We cannot match its lines to the outer
1.1653 + * context.
1.1654 + */
1.1655 +
1.1656 + result = TclCompEvalObj(interp, objPtr, NULL,0);
1.1657 +#endif
1.1658 + CACHE_STACK_INFO();
1.1659 + if (result == TCL_OK) {
1.1660 + /*
1.1661 + * Normal return; push the eval's object result.
1.1662 + */
1.1663 +
1.1664 + objResultPtr = Tcl_GetObjResult(interp);
1.1665 + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
1.1666 + Tcl_GetObjResult(interp));
1.1667 +
1.1668 + /*
1.1669 + * Reset the interp's result to avoid possible duplications
1.1670 + * of large objects [Bug 781585]. We do not call
1.1671 + * Tcl_ResetResult() to avoid any side effects caused by
1.1672 + * the resetting of errorInfo and errorCode [Bug 804681],
1.1673 + * which are not needed here. We chose instead to manipulate
1.1674 + * the interp's object result directly.
1.1675 + *
1.1676 + * Note that the result object is now in objResultPtr, it
1.1677 + * keeps the refCount it had in its role of iPtr->objResultPtr.
1.1678 + */
1.1679 + {
1.1680 + Tcl_Obj *newObjResultPtr;
1.1681 + TclNewObj(newObjResultPtr);
1.1682 + Tcl_IncrRefCount(newObjResultPtr);
1.1683 + iPtr->objResultPtr = newObjResultPtr;
1.1684 + }
1.1685 +
1.1686 + NEXT_INST_F(1, 1, -1);
1.1687 + } else {
1.1688 + cleanup = 1;
1.1689 + goto processExceptionReturn;
1.1690 + }
1.1691 +
1.1692 + case INST_EXPR_STK:
1.1693 + objPtr = stackPtr[stackTop];
1.1694 + DECACHE_STACK_INFO();
1.1695 + Tcl_ResetResult(interp);
1.1696 + result = Tcl_ExprObj(interp, objPtr, &valuePtr);
1.1697 + CACHE_STACK_INFO();
1.1698 + if (result != TCL_OK) {
1.1699 + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1.1700 + O2S(objPtr)), Tcl_GetObjResult(interp));
1.1701 + goto checkForCatch;
1.1702 + }
1.1703 + objResultPtr = valuePtr;
1.1704 + TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1.1705 + NEXT_INST_F(1, 1, -1); /* already has right refct */
1.1706 +
1.1707 + /*
1.1708 + * ---------------------------------------------------------
1.1709 + * Start of INST_LOAD instructions.
1.1710 + *
1.1711 + * WARNING: more 'goto' here than your doctor recommended!
1.1712 + * The different instructions set the value of some variables
1.1713 + * and then jump to somme common execution code.
1.1714 + */
1.1715 +
1.1716 + case INST_LOAD_SCALAR1:
1.1717 + opnd = TclGetUInt1AtPtr(pc+1);
1.1718 + varPtr = &(varFramePtr->compiledLocals[opnd]);
1.1719 + part1 = varPtr->name;
1.1720 + while (TclIsVarLink(varPtr)) {
1.1721 + varPtr = varPtr->value.linkPtr;
1.1722 + }
1.1723 + TRACE(("%u => ", opnd));
1.1724 + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
1.1725 + && (varPtr->tracePtr == NULL)) {
1.1726 + /*
1.1727 + * No errors, no traces: just get the value.
1.1728 + */
1.1729 + objResultPtr = varPtr->value.objPtr;
1.1730 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.1731 + NEXT_INST_F(2, 0, 1);
1.1732 + }
1.1733 + pcAdjustment = 2;
1.1734 + cleanup = 0;
1.1735 + arrayPtr = NULL;
1.1736 + part2 = NULL;
1.1737 + goto doCallPtrGetVar;
1.1738 +
1.1739 + case INST_LOAD_SCALAR4:
1.1740 + opnd = TclGetUInt4AtPtr(pc+1);
1.1741 + varPtr = &(varFramePtr->compiledLocals[opnd]);
1.1742 + part1 = varPtr->name;
1.1743 + while (TclIsVarLink(varPtr)) {
1.1744 + varPtr = varPtr->value.linkPtr;
1.1745 + }
1.1746 + TRACE(("%u => ", opnd));
1.1747 + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
1.1748 + && (varPtr->tracePtr == NULL)) {
1.1749 + /*
1.1750 + * No errors, no traces: just get the value.
1.1751 + */
1.1752 + objResultPtr = varPtr->value.objPtr;
1.1753 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.1754 + NEXT_INST_F(5, 0, 1);
1.1755 + }
1.1756 + pcAdjustment = 5;
1.1757 + cleanup = 0;
1.1758 + arrayPtr = NULL;
1.1759 + part2 = NULL;
1.1760 + goto doCallPtrGetVar;
1.1761 +
1.1762 + case INST_LOAD_ARRAY_STK:
1.1763 + cleanup = 2;
1.1764 + part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */
1.1765 + objPtr = stackPtr[stackTop-1]; /* array name */
1.1766 + TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
1.1767 + goto doLoadStk;
1.1768 +
1.1769 + case INST_LOAD_STK:
1.1770 + case INST_LOAD_SCALAR_STK:
1.1771 + cleanup = 1;
1.1772 + part2 = NULL;
1.1773 + objPtr = stackPtr[stackTop]; /* variable name */
1.1774 + TRACE(("\"%.30s\" => ", O2S(objPtr)));
1.1775 +
1.1776 + doLoadStk:
1.1777 + part1 = TclGetString(objPtr);
1.1778 + varPtr = TclObjLookupVar(interp, objPtr, part2,
1.1779 + TCL_LEAVE_ERR_MSG, "read",
1.1780 + /*createPart1*/ 0,
1.1781 + /*createPart2*/ 1, &arrayPtr);
1.1782 + if (varPtr == NULL) {
1.1783 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.1784 + result = TCL_ERROR;
1.1785 + goto checkForCatch;
1.1786 + }
1.1787 + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
1.1788 + && (varPtr->tracePtr == NULL)
1.1789 + && ((arrayPtr == NULL)
1.1790 + || (arrayPtr->tracePtr == NULL))) {
1.1791 + /*
1.1792 + * No errors, no traces: just get the value.
1.1793 + */
1.1794 + objResultPtr = varPtr->value.objPtr;
1.1795 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.1796 + NEXT_INST_V(1, cleanup, 1);
1.1797 + }
1.1798 + pcAdjustment = 1;
1.1799 + goto doCallPtrGetVar;
1.1800 +
1.1801 + case INST_LOAD_ARRAY4:
1.1802 + opnd = TclGetUInt4AtPtr(pc+1);
1.1803 + pcAdjustment = 5;
1.1804 + goto doLoadArray;
1.1805 +
1.1806 + case INST_LOAD_ARRAY1:
1.1807 + opnd = TclGetUInt1AtPtr(pc+1);
1.1808 + pcAdjustment = 2;
1.1809 +
1.1810 + doLoadArray:
1.1811 + part2 = TclGetString(stackPtr[stackTop]);
1.1812 + arrayPtr = &(varFramePtr->compiledLocals[opnd]);
1.1813 + part1 = arrayPtr->name;
1.1814 + while (TclIsVarLink(arrayPtr)) {
1.1815 + arrayPtr = arrayPtr->value.linkPtr;
1.1816 + }
1.1817 + TRACE(("%u \"%.30s\" => ", opnd, part2));
1.1818 + varPtr = TclLookupArrayElement(interp, part1, part2,
1.1819 + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
1.1820 + if (varPtr == NULL) {
1.1821 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.1822 + result = TCL_ERROR;
1.1823 + goto checkForCatch;
1.1824 + }
1.1825 + if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
1.1826 + && (varPtr->tracePtr == NULL)
1.1827 + && ((arrayPtr == NULL)
1.1828 + || (arrayPtr->tracePtr == NULL))) {
1.1829 + /*
1.1830 + * No errors, no traces: just get the value.
1.1831 + */
1.1832 + objResultPtr = varPtr->value.objPtr;
1.1833 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.1834 + NEXT_INST_F(pcAdjustment, 1, 1);
1.1835 + }
1.1836 + cleanup = 1;
1.1837 + goto doCallPtrGetVar;
1.1838 +
1.1839 + doCallPtrGetVar:
1.1840 + /*
1.1841 + * There are either errors or the variable is traced:
1.1842 + * call TclPtrGetVar to process fully.
1.1843 + */
1.1844 +
1.1845 + DECACHE_STACK_INFO();
1.1846 + objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1,
1.1847 + part2, TCL_LEAVE_ERR_MSG);
1.1848 + CACHE_STACK_INFO();
1.1849 + if (objResultPtr == NULL) {
1.1850 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.1851 + result = TCL_ERROR;
1.1852 + goto checkForCatch;
1.1853 + }
1.1854 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.1855 + NEXT_INST_V(pcAdjustment, cleanup, 1);
1.1856 +
1.1857 + /*
1.1858 + * End of INST_LOAD instructions.
1.1859 + * ---------------------------------------------------------
1.1860 + */
1.1861 +
1.1862 + /*
1.1863 + * ---------------------------------------------------------
1.1864 + * Start of INST_STORE and related instructions.
1.1865 + *
1.1866 + * WARNING: more 'goto' here than your doctor recommended!
1.1867 + * The different instructions set the value of some variables
1.1868 + * and then jump to somme common execution code.
1.1869 + */
1.1870 +
1.1871 + case INST_LAPPEND_STK:
1.1872 + valuePtr = stackPtr[stackTop]; /* value to append */
1.1873 + part2 = NULL;
1.1874 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1.1875 + | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1.1876 + goto doStoreStk;
1.1877 +
1.1878 + case INST_LAPPEND_ARRAY_STK:
1.1879 + valuePtr = stackPtr[stackTop]; /* value to append */
1.1880 + part2 = TclGetString(stackPtr[stackTop - 1]);
1.1881 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1.1882 + | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1.1883 + goto doStoreStk;
1.1884 +
1.1885 + case INST_APPEND_STK:
1.1886 + valuePtr = stackPtr[stackTop]; /* value to append */
1.1887 + part2 = NULL;
1.1888 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1.1889 + goto doStoreStk;
1.1890 +
1.1891 + case INST_APPEND_ARRAY_STK:
1.1892 + valuePtr = stackPtr[stackTop]; /* value to append */
1.1893 + part2 = TclGetString(stackPtr[stackTop - 1]);
1.1894 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1.1895 + goto doStoreStk;
1.1896 +
1.1897 + case INST_STORE_ARRAY_STK:
1.1898 + valuePtr = stackPtr[stackTop];
1.1899 + part2 = TclGetString(stackPtr[stackTop - 1]);
1.1900 + storeFlags = TCL_LEAVE_ERR_MSG;
1.1901 + goto doStoreStk;
1.1902 +
1.1903 + case INST_STORE_STK:
1.1904 + case INST_STORE_SCALAR_STK:
1.1905 + valuePtr = stackPtr[stackTop];
1.1906 + part2 = NULL;
1.1907 + storeFlags = TCL_LEAVE_ERR_MSG;
1.1908 +
1.1909 + doStoreStk:
1.1910 + objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */
1.1911 + part1 = TclGetString(objPtr);
1.1912 +#ifdef TCL_COMPILE_DEBUG
1.1913 + if (part2 == NULL) {
1.1914 + TRACE(("\"%.30s\" <- \"%.30s\" =>",
1.1915 + part1, O2S(valuePtr)));
1.1916 + } else {
1.1917 + TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
1.1918 + part1, part2, O2S(valuePtr)));
1.1919 + }
1.1920 +#endif
1.1921 + varPtr = TclObjLookupVar(interp, objPtr, part2,
1.1922 + TCL_LEAVE_ERR_MSG, "set",
1.1923 + /*createPart1*/ 1,
1.1924 + /*createPart2*/ 1, &arrayPtr);
1.1925 + if (varPtr == NULL) {
1.1926 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.1927 + result = TCL_ERROR;
1.1928 + goto checkForCatch;
1.1929 + }
1.1930 + cleanup = ((part2 == NULL)? 2 : 3);
1.1931 + pcAdjustment = 1;
1.1932 + goto doCallPtrSetVar;
1.1933 +
1.1934 + case INST_LAPPEND_ARRAY4:
1.1935 + opnd = TclGetUInt4AtPtr(pc+1);
1.1936 + pcAdjustment = 5;
1.1937 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1.1938 + | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1.1939 + goto doStoreArray;
1.1940 +
1.1941 + case INST_LAPPEND_ARRAY1:
1.1942 + opnd = TclGetUInt1AtPtr(pc+1);
1.1943 + pcAdjustment = 2;
1.1944 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1.1945 + | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1.1946 + goto doStoreArray;
1.1947 +
1.1948 + case INST_APPEND_ARRAY4:
1.1949 + opnd = TclGetUInt4AtPtr(pc+1);
1.1950 + pcAdjustment = 5;
1.1951 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1.1952 + goto doStoreArray;
1.1953 +
1.1954 + case INST_APPEND_ARRAY1:
1.1955 + opnd = TclGetUInt1AtPtr(pc+1);
1.1956 + pcAdjustment = 2;
1.1957 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1.1958 + goto doStoreArray;
1.1959 +
1.1960 + case INST_STORE_ARRAY4:
1.1961 + opnd = TclGetUInt4AtPtr(pc+1);
1.1962 + pcAdjustment = 5;
1.1963 + storeFlags = TCL_LEAVE_ERR_MSG;
1.1964 + goto doStoreArray;
1.1965 +
1.1966 + case INST_STORE_ARRAY1:
1.1967 + opnd = TclGetUInt1AtPtr(pc+1);
1.1968 + pcAdjustment = 2;
1.1969 + storeFlags = TCL_LEAVE_ERR_MSG;
1.1970 +
1.1971 + doStoreArray:
1.1972 + valuePtr = stackPtr[stackTop];
1.1973 + part2 = TclGetString(stackPtr[stackTop - 1]);
1.1974 + arrayPtr = &(varFramePtr->compiledLocals[opnd]);
1.1975 + part1 = arrayPtr->name;
1.1976 + TRACE(("%u \"%.30s\" <- \"%.30s\" => ",
1.1977 + opnd, part2, O2S(valuePtr)));
1.1978 + while (TclIsVarLink(arrayPtr)) {
1.1979 + arrayPtr = arrayPtr->value.linkPtr;
1.1980 + }
1.1981 + varPtr = TclLookupArrayElement(interp, part1, part2,
1.1982 + TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
1.1983 + if (varPtr == NULL) {
1.1984 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.1985 + result = TCL_ERROR;
1.1986 + goto checkForCatch;
1.1987 + }
1.1988 + cleanup = 2;
1.1989 + goto doCallPtrSetVar;
1.1990 +
1.1991 + case INST_LAPPEND_SCALAR4:
1.1992 + opnd = TclGetUInt4AtPtr(pc+1);
1.1993 + pcAdjustment = 5;
1.1994 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1.1995 + | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1.1996 + goto doStoreScalar;
1.1997 +
1.1998 + case INST_LAPPEND_SCALAR1:
1.1999 + opnd = TclGetUInt1AtPtr(pc+1);
1.2000 + pcAdjustment = 2;
1.2001 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1.2002 + | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1.2003 + goto doStoreScalar;
1.2004 +
1.2005 + case INST_APPEND_SCALAR4:
1.2006 + opnd = TclGetUInt4AtPtr(pc+1);
1.2007 + pcAdjustment = 5;
1.2008 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1.2009 + goto doStoreScalar;
1.2010 +
1.2011 + case INST_APPEND_SCALAR1:
1.2012 + opnd = TclGetUInt1AtPtr(pc+1);
1.2013 + pcAdjustment = 2;
1.2014 + storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1.2015 + goto doStoreScalar;
1.2016 +
1.2017 + case INST_STORE_SCALAR4:
1.2018 + opnd = TclGetUInt4AtPtr(pc+1);
1.2019 + pcAdjustment = 5;
1.2020 + storeFlags = TCL_LEAVE_ERR_MSG;
1.2021 + goto doStoreScalar;
1.2022 +
1.2023 + case INST_STORE_SCALAR1:
1.2024 + opnd = TclGetUInt1AtPtr(pc+1);
1.2025 + pcAdjustment = 2;
1.2026 + storeFlags = TCL_LEAVE_ERR_MSG;
1.2027 +
1.2028 + doStoreScalar:
1.2029 + valuePtr = stackPtr[stackTop];
1.2030 + varPtr = &(varFramePtr->compiledLocals[opnd]);
1.2031 + part1 = varPtr->name;
1.2032 + TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
1.2033 + while (TclIsVarLink(varPtr)) {
1.2034 + varPtr = varPtr->value.linkPtr;
1.2035 + }
1.2036 + cleanup = 1;
1.2037 + arrayPtr = NULL;
1.2038 + part2 = NULL;
1.2039 +
1.2040 + doCallPtrSetVar:
1.2041 + if ((storeFlags == TCL_LEAVE_ERR_MSG)
1.2042 + && !((varPtr->flags & VAR_IN_HASHTABLE)
1.2043 + && (varPtr->hPtr == NULL))
1.2044 + && (varPtr->tracePtr == NULL)
1.2045 + && (TclIsVarScalar(varPtr)
1.2046 + || TclIsVarUndefined(varPtr))
1.2047 + && ((arrayPtr == NULL)
1.2048 + || (arrayPtr->tracePtr == NULL))) {
1.2049 + /*
1.2050 + * No traces, no errors, plain 'set': we can safely inline.
1.2051 + * The value *will* be set to what's requested, so that
1.2052 + * the stack top remains pointing to the same Tcl_Obj.
1.2053 + */
1.2054 + valuePtr = varPtr->value.objPtr;
1.2055 + objResultPtr = stackPtr[stackTop];
1.2056 + if (valuePtr != objResultPtr) {
1.2057 + if (valuePtr != NULL) {
1.2058 + TclDecrRefCount(valuePtr);
1.2059 + } else {
1.2060 + TclSetVarScalar(varPtr);
1.2061 + TclClearVarUndefined(varPtr);
1.2062 + }
1.2063 + varPtr->value.objPtr = objResultPtr;
1.2064 + Tcl_IncrRefCount(objResultPtr);
1.2065 + }
1.2066 +#ifndef TCL_COMPILE_DEBUG
1.2067 + if (*(pc+pcAdjustment) == INST_POP) {
1.2068 + NEXT_INST_V((pcAdjustment+1), cleanup, 0);
1.2069 + }
1.2070 +#else
1.2071 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.2072 +#endif
1.2073 + NEXT_INST_V(pcAdjustment, cleanup, 1);
1.2074 + } else {
1.2075 + DECACHE_STACK_INFO();
1.2076 + objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
1.2077 + part1, part2, valuePtr, storeFlags);
1.2078 + CACHE_STACK_INFO();
1.2079 + if (objResultPtr == NULL) {
1.2080 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.2081 + result = TCL_ERROR;
1.2082 + goto checkForCatch;
1.2083 + }
1.2084 + }
1.2085 +#ifndef TCL_COMPILE_DEBUG
1.2086 + if (*(pc+pcAdjustment) == INST_POP) {
1.2087 + NEXT_INST_V((pcAdjustment+1), cleanup, 0);
1.2088 + }
1.2089 +#endif
1.2090 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.2091 + NEXT_INST_V(pcAdjustment, cleanup, 1);
1.2092 +
1.2093 +
1.2094 + /*
1.2095 + * End of INST_STORE and related instructions.
1.2096 + * ---------------------------------------------------------
1.2097 + */
1.2098 +
1.2099 + /*
1.2100 + * ---------------------------------------------------------
1.2101 + * Start of INST_INCR instructions.
1.2102 + *
1.2103 + * WARNING: more 'goto' here than your doctor recommended!
1.2104 + * The different instructions set the value of some variables
1.2105 + * and then jump to somme common execution code.
1.2106 + */
1.2107 +
1.2108 + case INST_INCR_SCALAR1:
1.2109 + case INST_INCR_ARRAY1:
1.2110 + case INST_INCR_ARRAY_STK:
1.2111 + case INST_INCR_SCALAR_STK:
1.2112 + case INST_INCR_STK:
1.2113 + opnd = TclGetUInt1AtPtr(pc+1);
1.2114 + valuePtr = stackPtr[stackTop];
1.2115 + if (valuePtr->typePtr == &tclIntType) {
1.2116 + i = valuePtr->internalRep.longValue;
1.2117 + } else if (valuePtr->typePtr == &tclWideIntType) {
1.2118 + TclGetLongFromWide(i,valuePtr);
1.2119 + } else {
1.2120 + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
1.2121 + if (result != TCL_OK) {
1.2122 + TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
1.2123 + opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1.2124 + DECACHE_STACK_INFO();
1.2125 + Tcl_AddErrorInfo(interp, "\n (reading increment)");
1.2126 + CACHE_STACK_INFO();
1.2127 + goto checkForCatch;
1.2128 + }
1.2129 + FORCE_LONG(valuePtr, i, w);
1.2130 + }
1.2131 + stackTop--;
1.2132 + TclDecrRefCount(valuePtr);
1.2133 + switch (*pc) {
1.2134 + case INST_INCR_SCALAR1:
1.2135 + pcAdjustment = 2;
1.2136 + goto doIncrScalar;
1.2137 + case INST_INCR_ARRAY1:
1.2138 + pcAdjustment = 2;
1.2139 + goto doIncrArray;
1.2140 + default:
1.2141 + pcAdjustment = 1;
1.2142 + goto doIncrStk;
1.2143 + }
1.2144 +
1.2145 + case INST_INCR_ARRAY_STK_IMM:
1.2146 + case INST_INCR_SCALAR_STK_IMM:
1.2147 + case INST_INCR_STK_IMM:
1.2148 + i = TclGetInt1AtPtr(pc+1);
1.2149 + pcAdjustment = 2;
1.2150 +
1.2151 + doIncrStk:
1.2152 + if ((*pc == INST_INCR_ARRAY_STK_IMM)
1.2153 + || (*pc == INST_INCR_ARRAY_STK)) {
1.2154 + part2 = TclGetString(stackPtr[stackTop]);
1.2155 + objPtr = stackPtr[stackTop - 1];
1.2156 + TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
1.2157 + O2S(objPtr), part2, i));
1.2158 + } else {
1.2159 + part2 = NULL;
1.2160 + objPtr = stackPtr[stackTop];
1.2161 + TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
1.2162 + }
1.2163 + part1 = TclGetString(objPtr);
1.2164 +
1.2165 + varPtr = TclObjLookupVar(interp, objPtr, part2,
1.2166 + TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
1.2167 + if (varPtr == NULL) {
1.2168 + DECACHE_STACK_INFO();
1.2169 + Tcl_AddObjErrorInfo(interp,
1.2170 + "\n (reading value of variable to increment)", -1);
1.2171 + CACHE_STACK_INFO();
1.2172 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.2173 + result = TCL_ERROR;
1.2174 + goto checkForCatch;
1.2175 + }
1.2176 + cleanup = ((part2 == NULL)? 1 : 2);
1.2177 + goto doIncrVar;
1.2178 +
1.2179 + case INST_INCR_ARRAY1_IMM:
1.2180 + opnd = TclGetUInt1AtPtr(pc+1);
1.2181 + i = TclGetInt1AtPtr(pc+2);
1.2182 + pcAdjustment = 3;
1.2183 +
1.2184 + doIncrArray:
1.2185 + part2 = TclGetString(stackPtr[stackTop]);
1.2186 + arrayPtr = &(varFramePtr->compiledLocals[opnd]);
1.2187 + part1 = arrayPtr->name;
1.2188 + while (TclIsVarLink(arrayPtr)) {
1.2189 + arrayPtr = arrayPtr->value.linkPtr;
1.2190 + }
1.2191 + TRACE(("%u \"%.30s\" (by %ld) => ",
1.2192 + opnd, part2, i));
1.2193 + varPtr = TclLookupArrayElement(interp, part1, part2,
1.2194 + TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
1.2195 + if (varPtr == NULL) {
1.2196 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.2197 + result = TCL_ERROR;
1.2198 + goto checkForCatch;
1.2199 + }
1.2200 + cleanup = 1;
1.2201 + goto doIncrVar;
1.2202 +
1.2203 + case INST_INCR_SCALAR1_IMM:
1.2204 + opnd = TclGetUInt1AtPtr(pc+1);
1.2205 + i = TclGetInt1AtPtr(pc+2);
1.2206 + pcAdjustment = 3;
1.2207 +
1.2208 + doIncrScalar:
1.2209 + varPtr = &(varFramePtr->compiledLocals[opnd]);
1.2210 + part1 = varPtr->name;
1.2211 + while (TclIsVarLink(varPtr)) {
1.2212 + varPtr = varPtr->value.linkPtr;
1.2213 + }
1.2214 + arrayPtr = NULL;
1.2215 + part2 = NULL;
1.2216 + cleanup = 0;
1.2217 + TRACE(("%u %ld => ", opnd, i));
1.2218 +
1.2219 +
1.2220 + doIncrVar:
1.2221 + objPtr = varPtr->value.objPtr;
1.2222 + if (TclIsVarScalar(varPtr)
1.2223 + && !TclIsVarUndefined(varPtr)
1.2224 + && (varPtr->tracePtr == NULL)
1.2225 + && ((arrayPtr == NULL)
1.2226 + || (arrayPtr->tracePtr == NULL))
1.2227 + && (objPtr->typePtr == &tclIntType)) {
1.2228 + /*
1.2229 + * No errors, no traces, the variable already has an
1.2230 + * integer value: inline processing.
1.2231 + */
1.2232 +
1.2233 + i += objPtr->internalRep.longValue;
1.2234 + if (Tcl_IsShared(objPtr)) {
1.2235 + objResultPtr = Tcl_NewLongObj(i);
1.2236 + TclDecrRefCount(objPtr);
1.2237 + Tcl_IncrRefCount(objResultPtr);
1.2238 + varPtr->value.objPtr = objResultPtr;
1.2239 + } else {
1.2240 + Tcl_SetLongObj(objPtr, i);
1.2241 + objResultPtr = objPtr;
1.2242 + }
1.2243 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.2244 + } else {
1.2245 + DECACHE_STACK_INFO();
1.2246 + objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1,
1.2247 + part2, i, TCL_LEAVE_ERR_MSG);
1.2248 + CACHE_STACK_INFO();
1.2249 + if (objResultPtr == NULL) {
1.2250 + TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1.2251 + result = TCL_ERROR;
1.2252 + goto checkForCatch;
1.2253 + }
1.2254 + }
1.2255 + TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1.2256 +#ifndef TCL_COMPILE_DEBUG
1.2257 + if (*(pc+pcAdjustment) == INST_POP) {
1.2258 + NEXT_INST_V((pcAdjustment+1), cleanup, 0);
1.2259 + }
1.2260 +#endif
1.2261 + NEXT_INST_V(pcAdjustment, cleanup, 1);
1.2262 +
1.2263 + /*
1.2264 + * End of INST_INCR instructions.
1.2265 + * ---------------------------------------------------------
1.2266 + */
1.2267 +
1.2268 +
1.2269 + case INST_JUMP1:
1.2270 + opnd = TclGetInt1AtPtr(pc+1);
1.2271 + TRACE(("%d => new pc %u\n", opnd,
1.2272 + (unsigned int)(pc + opnd - codePtr->codeStart)));
1.2273 + NEXT_INST_F(opnd, 0, 0);
1.2274 +
1.2275 + case INST_JUMP4:
1.2276 + opnd = TclGetInt4AtPtr(pc+1);
1.2277 + TRACE(("%d => new pc %u\n", opnd,
1.2278 + (unsigned int)(pc + opnd - codePtr->codeStart)));
1.2279 + NEXT_INST_F(opnd, 0, 0);
1.2280 +
1.2281 + case INST_JUMP_FALSE4:
1.2282 + opnd = 5; /* TRUE */
1.2283 + pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */
1.2284 + goto doJumpTrue;
1.2285 +
1.2286 + case INST_JUMP_TRUE4:
1.2287 + opnd = TclGetInt4AtPtr(pc+1); /* TRUE */
1.2288 + pcAdjustment = 5; /* FALSE */
1.2289 + goto doJumpTrue;
1.2290 +
1.2291 + case INST_JUMP_FALSE1:
1.2292 + opnd = 2; /* TRUE */
1.2293 + pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */
1.2294 + goto doJumpTrue;
1.2295 +
1.2296 + case INST_JUMP_TRUE1:
1.2297 + opnd = TclGetInt1AtPtr(pc+1); /* TRUE */
1.2298 + pcAdjustment = 2; /* FALSE */
1.2299 +
1.2300 + doJumpTrue:
1.2301 + {
1.2302 + int b;
1.2303 +
1.2304 + valuePtr = stackPtr[stackTop];
1.2305 + if (valuePtr->typePtr == &tclIntType) {
1.2306 + b = (valuePtr->internalRep.longValue != 0);
1.2307 + } else if (valuePtr->typePtr == &tclDoubleType) {
1.2308 + b = (valuePtr->internalRep.doubleValue != 0.0);
1.2309 + } else if (valuePtr->typePtr == &tclWideIntType) {
1.2310 + TclGetWide(w,valuePtr);
1.2311 + b = (w != W0);
1.2312 + } else {
1.2313 + result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1.2314 + if (result != TCL_OK) {
1.2315 + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
1.2316 + goto checkForCatch;
1.2317 + }
1.2318 + }
1.2319 +#ifndef TCL_COMPILE_DEBUG
1.2320 + NEXT_INST_F((b? opnd : pcAdjustment), 1, 0);
1.2321 +#else
1.2322 + if (b) {
1.2323 + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
1.2324 + TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr),
1.2325 + (unsigned int)(pc+opnd - codePtr->codeStart)));
1.2326 + } else {
1.2327 + TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr)));
1.2328 + }
1.2329 + NEXT_INST_F(opnd, 1, 0);
1.2330 + } else {
1.2331 + if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
1.2332 + TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
1.2333 + } else {
1.2334 + opnd = pcAdjustment;
1.2335 + TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr),
1.2336 + (unsigned int)(pc + opnd - codePtr->codeStart)));
1.2337 + }
1.2338 + NEXT_INST_F(pcAdjustment, 1, 0);
1.2339 + }
1.2340 +#endif
1.2341 + }
1.2342 +
1.2343 + case INST_LOR:
1.2344 + case INST_LAND:
1.2345 + {
1.2346 + /*
1.2347 + * Operands must be boolean or numeric. No int->double
1.2348 + * conversions are performed.
1.2349 + */
1.2350 +
1.2351 + int i1, i2;
1.2352 + int iResult;
1.2353 + char *s;
1.2354 + Tcl_ObjType *t1Ptr, *t2Ptr;
1.2355 +
1.2356 + value2Ptr = stackPtr[stackTop];
1.2357 + valuePtr = stackPtr[stackTop - 1];;
1.2358 + t1Ptr = valuePtr->typePtr;
1.2359 + t2Ptr = value2Ptr->typePtr;
1.2360 +
1.2361 + if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
1.2362 + i1 = (valuePtr->internalRep.longValue != 0);
1.2363 + } else if (t1Ptr == &tclWideIntType) {
1.2364 + TclGetWide(w,valuePtr);
1.2365 + i1 = (w != W0);
1.2366 + } else if (t1Ptr == &tclDoubleType) {
1.2367 + i1 = (valuePtr->internalRep.doubleValue != 0.0);
1.2368 + } else {
1.2369 + s = Tcl_GetStringFromObj(valuePtr, &length);
1.2370 + if (TclLooksLikeInt(s, length)) {
1.2371 + GET_WIDE_OR_INT(result, valuePtr, i, w);
1.2372 + if (valuePtr->typePtr == &tclIntType) {
1.2373 + i1 = (i != 0);
1.2374 + } else {
1.2375 + i1 = (w != W0);
1.2376 + }
1.2377 + } else {
1.2378 + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1.2379 + valuePtr, &i1);
1.2380 + i1 = (i1 != 0);
1.2381 + }
1.2382 + if (result != TCL_OK) {
1.2383 + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
1.2384 + (t1Ptr? t1Ptr->name : "null")));
1.2385 + DECACHE_STACK_INFO();
1.2386 + IllegalExprOperandType(interp, pc, valuePtr);
1.2387 + CACHE_STACK_INFO();
1.2388 + goto checkForCatch;
1.2389 + }
1.2390 + }
1.2391 +
1.2392 + if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
1.2393 + i2 = (value2Ptr->internalRep.longValue != 0);
1.2394 + } else if (t2Ptr == &tclWideIntType) {
1.2395 + TclGetWide(w,value2Ptr);
1.2396 + i2 = (w != W0);
1.2397 + } else if (t2Ptr == &tclDoubleType) {
1.2398 + i2 = (value2Ptr->internalRep.doubleValue != 0.0);
1.2399 + } else {
1.2400 + s = Tcl_GetStringFromObj(value2Ptr, &length);
1.2401 + if (TclLooksLikeInt(s, length)) {
1.2402 + GET_WIDE_OR_INT(result, value2Ptr, i, w);
1.2403 + if (value2Ptr->typePtr == &tclIntType) {
1.2404 + i2 = (i != 0);
1.2405 + } else {
1.2406 + i2 = (w != W0);
1.2407 + }
1.2408 + } else {
1.2409 + result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);
1.2410 + }
1.2411 + if (result != TCL_OK) {
1.2412 + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
1.2413 + (t2Ptr? t2Ptr->name : "null")));
1.2414 + DECACHE_STACK_INFO();
1.2415 + IllegalExprOperandType(interp, pc, value2Ptr);
1.2416 + CACHE_STACK_INFO();
1.2417 + goto checkForCatch;
1.2418 + }
1.2419 + }
1.2420 +
1.2421 + /*
1.2422 + * Reuse the valuePtr object already on stack if possible.
1.2423 + */
1.2424 +
1.2425 + if (*pc == INST_LOR) {
1.2426 + iResult = (i1 || i2);
1.2427 + } else {
1.2428 + iResult = (i1 && i2);
1.2429 + }
1.2430 + if (Tcl_IsShared(valuePtr)) {
1.2431 + objResultPtr = Tcl_NewLongObj(iResult);
1.2432 + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
1.2433 + NEXT_INST_F(1, 2, 1);
1.2434 + } else { /* reuse the valuePtr object */
1.2435 + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
1.2436 + Tcl_SetLongObj(valuePtr, iResult);
1.2437 + NEXT_INST_F(1, 1, 0);
1.2438 + }
1.2439 + }
1.2440 +
1.2441 + /*
1.2442 + * ---------------------------------------------------------
1.2443 + * Start of INST_LIST and related instructions.
1.2444 + */
1.2445 +
1.2446 + case INST_LIST:
1.2447 + /*
1.2448 + * Pop the opnd (objc) top stack elements into a new list obj
1.2449 + * and then decrement their ref counts.
1.2450 + */
1.2451 +
1.2452 + opnd = TclGetUInt4AtPtr(pc+1);
1.2453 + objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
1.2454 + TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
1.2455 + NEXT_INST_V(5, opnd, 1);
1.2456 +
1.2457 + case INST_LIST_LENGTH:
1.2458 + valuePtr = stackPtr[stackTop];
1.2459 +
1.2460 + result = Tcl_ListObjLength(interp, valuePtr, &length);
1.2461 + if (result != TCL_OK) {
1.2462 + TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
1.2463 + Tcl_GetObjResult(interp));
1.2464 + goto checkForCatch;
1.2465 + }
1.2466 + objResultPtr = Tcl_NewIntObj(length);
1.2467 + TRACE(("%.20s => %d\n", O2S(valuePtr), length));
1.2468 + NEXT_INST_F(1, 1, 1);
1.2469 +
1.2470 + case INST_LIST_INDEX:
1.2471 + /*** lindex with objc == 3 ***/
1.2472 +
1.2473 + /*
1.2474 + * Pop the two operands
1.2475 + */
1.2476 + value2Ptr = stackPtr[stackTop];
1.2477 + valuePtr = stackPtr[stackTop- 1];
1.2478 +
1.2479 + /*
1.2480 + * Extract the desired list element
1.2481 + */
1.2482 + objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
1.2483 + if (objResultPtr == NULL) {
1.2484 + TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
1.2485 + Tcl_GetObjResult(interp));
1.2486 + result = TCL_ERROR;
1.2487 + goto checkForCatch;
1.2488 + }
1.2489 +
1.2490 + /*
1.2491 + * Stash the list element on the stack
1.2492 + */
1.2493 + TRACE(("%.20s %.20s => %s\n",
1.2494 + O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
1.2495 + NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
1.2496 +
1.2497 + case INST_LIST_INDEX_MULTI:
1.2498 + {
1.2499 + /*
1.2500 + * 'lindex' with multiple index args:
1.2501 + *
1.2502 + * Determine the count of index args.
1.2503 + */
1.2504 +
1.2505 + int numIdx;
1.2506 +
1.2507 + opnd = TclGetUInt4AtPtr(pc+1);
1.2508 + numIdx = opnd-1;
1.2509 +
1.2510 + /*
1.2511 + * Do the 'lindex' operation.
1.2512 + */
1.2513 + objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
1.2514 + numIdx, stackPtr + stackTop - numIdx + 1);
1.2515 +
1.2516 + /*
1.2517 + * Check for errors
1.2518 + */
1.2519 + if (objResultPtr == NULL) {
1.2520 + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
1.2521 + result = TCL_ERROR;
1.2522 + goto checkForCatch;
1.2523 + }
1.2524 +
1.2525 + /*
1.2526 + * Set result
1.2527 + */
1.2528 + TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
1.2529 + NEXT_INST_V(5, opnd, -1);
1.2530 + }
1.2531 +
1.2532 + case INST_LSET_FLAT:
1.2533 + {
1.2534 + /*
1.2535 + * Lset with 3, 5, or more args. Get the number
1.2536 + * of index args.
1.2537 + */
1.2538 + int numIdx;
1.2539 +
1.2540 + opnd = TclGetUInt4AtPtr( pc + 1 );
1.2541 + numIdx = opnd - 2;
1.2542 +
1.2543 + /*
1.2544 + * Get the old value of variable, and remove the stack ref.
1.2545 + * This is safe because the variable still references the
1.2546 + * object; the ref count will never go zero here.
1.2547 + */
1.2548 + value2Ptr = POP_OBJECT();
1.2549 + TclDecrRefCount(value2Ptr); /* This one should be done here */
1.2550 +
1.2551 + /*
1.2552 + * Get the new element value.
1.2553 + */
1.2554 + valuePtr = stackPtr[stackTop];
1.2555 +
1.2556 + /*
1.2557 + * Compute the new variable value
1.2558 + */
1.2559 + objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
1.2560 + stackPtr + stackTop - numIdx, valuePtr);
1.2561 +
1.2562 +
1.2563 + /*
1.2564 + * Check for errors
1.2565 + */
1.2566 + if (objResultPtr == NULL) {
1.2567 + TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
1.2568 + result = TCL_ERROR;
1.2569 + goto checkForCatch;
1.2570 + }
1.2571 +
1.2572 + /*
1.2573 + * Set result
1.2574 + */
1.2575 + TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
1.2576 + NEXT_INST_V(5, (numIdx+1), -1);
1.2577 + }
1.2578 +
1.2579 + case INST_LSET_LIST:
1.2580 + /*
1.2581 + * 'lset' with 4 args.
1.2582 + *
1.2583 + * Get the old value of variable, and remove the stack ref.
1.2584 + * This is safe because the variable still references the
1.2585 + * object; the ref count will never go zero here.
1.2586 + */
1.2587 + objPtr = POP_OBJECT();
1.2588 + TclDecrRefCount(objPtr); /* This one should be done here */
1.2589 +
1.2590 + /*
1.2591 + * Get the new element value, and the index list
1.2592 + */
1.2593 + valuePtr = stackPtr[stackTop];
1.2594 + value2Ptr = stackPtr[stackTop - 1];
1.2595 +
1.2596 + /*
1.2597 + * Compute the new variable value
1.2598 + */
1.2599 + objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
1.2600 +
1.2601 + /*
1.2602 + * Check for errors
1.2603 + */
1.2604 + if (objResultPtr == NULL) {
1.2605 + TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
1.2606 + Tcl_GetObjResult(interp));
1.2607 + result = TCL_ERROR;
1.2608 + goto checkForCatch;
1.2609 + }
1.2610 +
1.2611 + /*
1.2612 + * Set result
1.2613 + */
1.2614 + TRACE(("=> %s\n", O2S(objResultPtr)));
1.2615 + NEXT_INST_F(1, 2, -1);
1.2616 +
1.2617 + /*
1.2618 + * End of INST_LIST and related instructions.
1.2619 + * ---------------------------------------------------------
1.2620 + */
1.2621 +
1.2622 + case INST_STR_EQ:
1.2623 + case INST_STR_NEQ:
1.2624 + {
1.2625 + /*
1.2626 + * String (in)equality check
1.2627 + */
1.2628 + int iResult;
1.2629 +
1.2630 + value2Ptr = stackPtr[stackTop];
1.2631 + valuePtr = stackPtr[stackTop - 1];
1.2632 +
1.2633 + if (valuePtr == value2Ptr) {
1.2634 + /*
1.2635 + * On the off-chance that the objects are the same,
1.2636 + * we don't really have to think hard about equality.
1.2637 + */
1.2638 + iResult = (*pc == INST_STR_EQ);
1.2639 + } else {
1.2640 + char *s1, *s2;
1.2641 + int s1len, s2len;
1.2642 +
1.2643 + s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
1.2644 + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
1.2645 + if (s1len == s2len) {
1.2646 + /*
1.2647 + * We only need to check (in)equality when
1.2648 + * we have equal length strings.
1.2649 + */
1.2650 + if (*pc == INST_STR_NEQ) {
1.2651 + iResult = (strcmp(s1, s2) != 0);
1.2652 + } else {
1.2653 + /* INST_STR_EQ */
1.2654 + iResult = (strcmp(s1, s2) == 0);
1.2655 + }
1.2656 + } else {
1.2657 + iResult = (*pc == INST_STR_NEQ);
1.2658 + }
1.2659 + }
1.2660 +
1.2661 + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
1.2662 +
1.2663 + /*
1.2664 + * Peep-hole optimisation: if you're about to jump, do jump
1.2665 + * from here.
1.2666 + */
1.2667 +
1.2668 + pc++;
1.2669 +#ifndef TCL_COMPILE_DEBUG
1.2670 + switch (*pc) {
1.2671 + case INST_JUMP_FALSE1:
1.2672 + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
1.2673 + case INST_JUMP_TRUE1:
1.2674 + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
1.2675 + case INST_JUMP_FALSE4:
1.2676 + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
1.2677 + case INST_JUMP_TRUE4:
1.2678 + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
1.2679 + }
1.2680 +#endif
1.2681 + objResultPtr = Tcl_NewIntObj(iResult);
1.2682 + NEXT_INST_F(0, 2, 1);
1.2683 + }
1.2684 +
1.2685 + case INST_STR_CMP:
1.2686 + {
1.2687 + /*
1.2688 + * String compare
1.2689 + */
1.2690 + CONST char *s1, *s2;
1.2691 + int s1len, s2len, iResult;
1.2692 +
1.2693 + value2Ptr = stackPtr[stackTop];
1.2694 + valuePtr = stackPtr[stackTop - 1];
1.2695 +
1.2696 + /*
1.2697 + * The comparison function should compare up to the
1.2698 + * minimum byte length only.
1.2699 + */
1.2700 + if (valuePtr == value2Ptr) {
1.2701 + /*
1.2702 + * In the pure equality case, set lengths too for
1.2703 + * the checks below (or we could goto beyond it).
1.2704 + */
1.2705 + iResult = s1len = s2len = 0;
1.2706 + } else if ((valuePtr->typePtr == &tclByteArrayType)
1.2707 + && (value2Ptr->typePtr == &tclByteArrayType)) {
1.2708 + s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
1.2709 + s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
1.2710 + iResult = memcmp(s1, s2,
1.2711 + (size_t) ((s1len < s2len) ? s1len : s2len));
1.2712 + } else if (((valuePtr->typePtr == &tclStringType)
1.2713 + && (value2Ptr->typePtr == &tclStringType))) {
1.2714 + /*
1.2715 + * Do a unicode-specific comparison if both of the args are of
1.2716 + * String type. If the char length == byte length, we can do a
1.2717 + * memcmp. In benchmark testing this proved the most efficient
1.2718 + * check between the unicode and string comparison operations.
1.2719 + */
1.2720 +
1.2721 + s1len = Tcl_GetCharLength(valuePtr);
1.2722 + s2len = Tcl_GetCharLength(value2Ptr);
1.2723 + if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
1.2724 + iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
1.2725 + (unsigned) ((s1len < s2len) ? s1len : s2len));
1.2726 + } else {
1.2727 + iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
1.2728 + Tcl_GetUnicode(value2Ptr),
1.2729 + (unsigned) ((s1len < s2len) ? s1len : s2len));
1.2730 + }
1.2731 + } else {
1.2732 + /*
1.2733 + * We can't do a simple memcmp in order to handle the
1.2734 + * special Tcl \xC0\x80 null encoding for utf-8.
1.2735 + */
1.2736 + s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
1.2737 + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
1.2738 + iResult = TclpUtfNcmp2(s1, s2,
1.2739 + (size_t) ((s1len < s2len) ? s1len : s2len));
1.2740 + }
1.2741 +
1.2742 + /*
1.2743 + * Make sure only -1,0,1 is returned
1.2744 + */
1.2745 + if (iResult == 0) {
1.2746 + iResult = s1len - s2len;
1.2747 + }
1.2748 + if (iResult < 0) {
1.2749 + iResult = -1;
1.2750 + } else if (iResult > 0) {
1.2751 + iResult = 1;
1.2752 + }
1.2753 +
1.2754 + objResultPtr = Tcl_NewIntObj(iResult);
1.2755 + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
1.2756 + NEXT_INST_F(1, 2, 1);
1.2757 + }
1.2758 +
1.2759 + case INST_STR_LEN:
1.2760 + {
1.2761 + int length1;
1.2762 +
1.2763 + valuePtr = stackPtr[stackTop];
1.2764 +
1.2765 + if (valuePtr->typePtr == &tclByteArrayType) {
1.2766 + (void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
1.2767 + } else {
1.2768 + length1 = Tcl_GetCharLength(valuePtr);
1.2769 + }
1.2770 + objResultPtr = Tcl_NewIntObj(length1);
1.2771 + TRACE(("%.20s => %d\n", O2S(valuePtr), length1));
1.2772 + NEXT_INST_F(1, 1, 1);
1.2773 + }
1.2774 +
1.2775 + case INST_STR_INDEX:
1.2776 + {
1.2777 + /*
1.2778 + * String compare
1.2779 + */
1.2780 + int index;
1.2781 + bytes = NULL; /* lint */
1.2782 +
1.2783 + value2Ptr = stackPtr[stackTop];
1.2784 + valuePtr = stackPtr[stackTop - 1];
1.2785 +
1.2786 + /*
1.2787 + * If we have a ByteArray object, avoid indexing in the
1.2788 + * Utf string since the byte array contains one byte per
1.2789 + * character. Otherwise, use the Unicode string rep to
1.2790 + * get the index'th char.
1.2791 + */
1.2792 +
1.2793 + if (valuePtr->typePtr == &tclByteArrayType) {
1.2794 + bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
1.2795 + } else {
1.2796 + /*
1.2797 + * Get Unicode char length to calulate what 'end' means.
1.2798 + */
1.2799 + length = Tcl_GetCharLength(valuePtr);
1.2800 + }
1.2801 +
1.2802 + result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
1.2803 + if (result != TCL_OK) {
1.2804 + goto checkForCatch;
1.2805 + }
1.2806 +
1.2807 + if ((index >= 0) && (index < length)) {
1.2808 + if (valuePtr->typePtr == &tclByteArrayType) {
1.2809 + objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
1.2810 + (&bytes[index]), 1);
1.2811 + } else if (valuePtr->bytes && length == valuePtr->length) {
1.2812 + objResultPtr = Tcl_NewStringObj((CONST char *)
1.2813 + (&valuePtr->bytes[index]), 1);
1.2814 + } else {
1.2815 + char buf[TCL_UTF_MAX];
1.2816 + Tcl_UniChar ch;
1.2817 +
1.2818 + ch = Tcl_GetUniChar(valuePtr, index);
1.2819 + /*
1.2820 + * This could be:
1.2821 + * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
1.2822 + * but creating the object as a string seems to be
1.2823 + * faster in practical use.
1.2824 + */
1.2825 + length = Tcl_UniCharToUtf(ch, buf);
1.2826 + objResultPtr = Tcl_NewStringObj(buf, length);
1.2827 + }
1.2828 + } else {
1.2829 + TclNewObj(objResultPtr);
1.2830 + }
1.2831 +
1.2832 + TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
1.2833 + O2S(objResultPtr)));
1.2834 + NEXT_INST_F(1, 2, 1);
1.2835 + }
1.2836 +
1.2837 + case INST_STR_MATCH:
1.2838 + {
1.2839 + int nocase, match;
1.2840 +
1.2841 + nocase = TclGetInt1AtPtr(pc+1);
1.2842 + valuePtr = stackPtr[stackTop]; /* String */
1.2843 + value2Ptr = stackPtr[stackTop - 1]; /* Pattern */
1.2844 +
1.2845 + /*
1.2846 + * Check that at least one of the objects is Unicode before
1.2847 + * promoting both.
1.2848 + */
1.2849 +
1.2850 + if ((valuePtr->typePtr == &tclStringType)
1.2851 + || (value2Ptr->typePtr == &tclStringType)) {
1.2852 + Tcl_UniChar *ustring1, *ustring2;
1.2853 + int length1, length2;
1.2854 +
1.2855 + ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
1.2856 + ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
1.2857 + match = TclUniCharMatch(ustring1, length1, ustring2, length2,
1.2858 + nocase);
1.2859 + } else {
1.2860 + match = Tcl_StringCaseMatch(TclGetString(valuePtr),
1.2861 + TclGetString(value2Ptr), nocase);
1.2862 + }
1.2863 +
1.2864 + /*
1.2865 + * Reuse value2Ptr object already on stack if possible.
1.2866 + * Adjustment is 2 due to the nocase byte
1.2867 + */
1.2868 +
1.2869 + TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
1.2870 + if (Tcl_IsShared(value2Ptr)) {
1.2871 + objResultPtr = Tcl_NewIntObj(match);
1.2872 + NEXT_INST_F(2, 2, 1);
1.2873 + } else { /* reuse the valuePtr object */
1.2874 + Tcl_SetIntObj(value2Ptr, match);
1.2875 + NEXT_INST_F(2, 1, 0);
1.2876 + }
1.2877 + }
1.2878 +
1.2879 + case INST_EQ:
1.2880 + case INST_NEQ:
1.2881 + case INST_LT:
1.2882 + case INST_GT:
1.2883 + case INST_LE:
1.2884 + case INST_GE:
1.2885 + {
1.2886 + /*
1.2887 + * Any type is allowed but the two operands must have the
1.2888 + * same type. We will compute value op value2.
1.2889 + */
1.2890 +
1.2891 + Tcl_ObjType *t1Ptr, *t2Ptr;
1.2892 + char *s1 = NULL; /* Init. avoids compiler warning. */
1.2893 + char *s2 = NULL; /* Init. avoids compiler warning. */
1.2894 + long i2 = 0; /* Init. avoids compiler warning. */
1.2895 + double d1 = 0.0; /* Init. avoids compiler warning. */
1.2896 + double d2 = 0.0; /* Init. avoids compiler warning. */
1.2897 + long iResult = 0; /* Init. avoids compiler warning. */
1.2898 +
1.2899 + value2Ptr = stackPtr[stackTop];
1.2900 + valuePtr = stackPtr[stackTop - 1];
1.2901 +
1.2902 + /*
1.2903 + * Be careful in the equal-object case; 'NaN' isn't supposed
1.2904 + * to be equal to even itself. [Bug 761471]
1.2905 + */
1.2906 +
1.2907 + t1Ptr = valuePtr->typePtr;
1.2908 + if (valuePtr == value2Ptr) {
1.2909 + /*
1.2910 + * If we are numeric already, we can proceed to the main
1.2911 + * equality check right now. Otherwise, we need to try to
1.2912 + * coerce to a numeric type so we can see if we've got a
1.2913 + * NaN but haven't parsed it as numeric.
1.2914 + */
1.2915 + if (!IS_NUMERIC_TYPE(t1Ptr)) {
1.2916 + if (t1Ptr == &tclListType) {
1.2917 + int length;
1.2918 + /*
1.2919 + * Only a list of length 1 can be NaN or such
1.2920 + * things.
1.2921 + */
1.2922 + (void) Tcl_ListObjLength(NULL, valuePtr, &length);
1.2923 + if (length == 1) {
1.2924 + goto mustConvertForNaNCheck;
1.2925 + }
1.2926 + } else {
1.2927 + /*
1.2928 + * Too bad, we'll have to compute the string and
1.2929 + * try the conversion
1.2930 + */
1.2931 +
1.2932 + mustConvertForNaNCheck:
1.2933 + s1 = Tcl_GetStringFromObj(valuePtr, &length);
1.2934 + if (TclLooksLikeInt(s1, length)) {
1.2935 + GET_WIDE_OR_INT(iResult, valuePtr, i, w);
1.2936 + } else {
1.2937 + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1.2938 + valuePtr, &d1);
1.2939 + }
1.2940 + t1Ptr = valuePtr->typePtr;
1.2941 + }
1.2942 + }
1.2943 +
1.2944 + switch (*pc) {
1.2945 + case INST_EQ:
1.2946 + case INST_LE:
1.2947 + case INST_GE:
1.2948 + iResult = !((t1Ptr == &tclDoubleType)
1.2949 + && IS_NAN(valuePtr->internalRep.doubleValue));
1.2950 + break;
1.2951 + case INST_LT:
1.2952 + case INST_GT:
1.2953 + iResult = 0;
1.2954 + break;
1.2955 + case INST_NEQ:
1.2956 + iResult = ((t1Ptr == &tclDoubleType)
1.2957 + && IS_NAN(valuePtr->internalRep.doubleValue));
1.2958 + break;
1.2959 + }
1.2960 + goto foundResult;
1.2961 + }
1.2962 +
1.2963 + t2Ptr = value2Ptr->typePtr;
1.2964 +
1.2965 + /*
1.2966 + * We only want to coerce numeric validation if neither type
1.2967 + * is NULL. A NULL type means the arg is essentially an empty
1.2968 + * object ("", {} or [list]).
1.2969 + */
1.2970 + if (!( (!t1Ptr && !valuePtr->bytes)
1.2971 + || (valuePtr->bytes && !valuePtr->length)
1.2972 + || (!t2Ptr && !value2Ptr->bytes)
1.2973 + || (value2Ptr->bytes && !value2Ptr->length))) {
1.2974 + if (!IS_NUMERIC_TYPE(t1Ptr)) {
1.2975 + s1 = Tcl_GetStringFromObj(valuePtr, &length);
1.2976 + if (TclLooksLikeInt(s1, length)) {
1.2977 + GET_WIDE_OR_INT(iResult, valuePtr, i, w);
1.2978 + } else {
1.2979 + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1.2980 + valuePtr, &d1);
1.2981 + }
1.2982 + t1Ptr = valuePtr->typePtr;
1.2983 + }
1.2984 + if (!IS_NUMERIC_TYPE(t2Ptr)) {
1.2985 + s2 = Tcl_GetStringFromObj(value2Ptr, &length);
1.2986 + if (TclLooksLikeInt(s2, length)) {
1.2987 + GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
1.2988 + } else {
1.2989 + (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1.2990 + value2Ptr, &d2);
1.2991 + }
1.2992 + t2Ptr = value2Ptr->typePtr;
1.2993 + }
1.2994 + }
1.2995 + if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
1.2996 + /*
1.2997 + * One operand is not numeric. Compare as strings. NOTE:
1.2998 + * strcmp is not correct for \x00 < \x01, but that is
1.2999 + * unlikely to occur here. We could use the TclUtfNCmp2
1.3000 + * to handle this.
1.3001 + */
1.3002 + int s1len, s2len;
1.3003 + s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
1.3004 + s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
1.3005 + switch (*pc) {
1.3006 + case INST_EQ:
1.3007 + if (s1len == s2len) {
1.3008 + iResult = (strcmp(s1, s2) == 0);
1.3009 + } else {
1.3010 + iResult = 0;
1.3011 + }
1.3012 + break;
1.3013 + case INST_NEQ:
1.3014 + if (s1len == s2len) {
1.3015 + iResult = (strcmp(s1, s2) != 0);
1.3016 + } else {
1.3017 + iResult = 1;
1.3018 + }
1.3019 + break;
1.3020 + case INST_LT:
1.3021 + iResult = (strcmp(s1, s2) < 0);
1.3022 + break;
1.3023 + case INST_GT:
1.3024 + iResult = (strcmp(s1, s2) > 0);
1.3025 + break;
1.3026 + case INST_LE:
1.3027 + iResult = (strcmp(s1, s2) <= 0);
1.3028 + break;
1.3029 + case INST_GE:
1.3030 + iResult = (strcmp(s1, s2) >= 0);
1.3031 + break;
1.3032 + }
1.3033 + } else if ((t1Ptr == &tclDoubleType)
1.3034 + || (t2Ptr == &tclDoubleType)) {
1.3035 + /*
1.3036 + * Compare as doubles.
1.3037 + */
1.3038 + if (t1Ptr == &tclDoubleType) {
1.3039 + d1 = valuePtr->internalRep.doubleValue;
1.3040 + GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
1.3041 + } else { /* t1Ptr is integer, t2Ptr is double */
1.3042 + GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
1.3043 + d2 = value2Ptr->internalRep.doubleValue;
1.3044 + }
1.3045 + switch (*pc) {
1.3046 + case INST_EQ:
1.3047 + iResult = d1 == d2;
1.3048 + break;
1.3049 + case INST_NEQ:
1.3050 + iResult = d1 != d2;
1.3051 + break;
1.3052 + case INST_LT:
1.3053 + iResult = d1 < d2;
1.3054 + break;
1.3055 + case INST_GT:
1.3056 + iResult = d1 > d2;
1.3057 + break;
1.3058 + case INST_LE:
1.3059 + iResult = d1 <= d2;
1.3060 + break;
1.3061 + case INST_GE:
1.3062 + iResult = d1 >= d2;
1.3063 + break;
1.3064 + }
1.3065 + } else if ((t1Ptr == &tclWideIntType)
1.3066 + || (t2Ptr == &tclWideIntType)) {
1.3067 + Tcl_WideInt w2;
1.3068 + /*
1.3069 + * Compare as wide ints (neither are doubles)
1.3070 + */
1.3071 + if (t1Ptr == &tclIntType) {
1.3072 + w = Tcl_LongAsWide(valuePtr->internalRep.longValue);
1.3073 + TclGetWide(w2,value2Ptr);
1.3074 + } else if (t2Ptr == &tclIntType) {
1.3075 + TclGetWide(w,valuePtr);
1.3076 + w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
1.3077 + } else {
1.3078 + TclGetWide(w,valuePtr);
1.3079 + TclGetWide(w2,value2Ptr);
1.3080 + }
1.3081 + switch (*pc) {
1.3082 + case INST_EQ:
1.3083 + iResult = w == w2;
1.3084 + break;
1.3085 + case INST_NEQ:
1.3086 + iResult = w != w2;
1.3087 + break;
1.3088 + case INST_LT:
1.3089 + iResult = w < w2;
1.3090 + break;
1.3091 + case INST_GT:
1.3092 + iResult = w > w2;
1.3093 + break;
1.3094 + case INST_LE:
1.3095 + iResult = w <= w2;
1.3096 + break;
1.3097 + case INST_GE:
1.3098 + iResult = w >= w2;
1.3099 + break;
1.3100 + }
1.3101 + } else {
1.3102 + /*
1.3103 + * Compare as ints.
1.3104 + */
1.3105 + i = valuePtr->internalRep.longValue;
1.3106 + i2 = value2Ptr->internalRep.longValue;
1.3107 + switch (*pc) {
1.3108 + case INST_EQ:
1.3109 + iResult = i == i2;
1.3110 + break;
1.3111 + case INST_NEQ:
1.3112 + iResult = i != i2;
1.3113 + break;
1.3114 + case INST_LT:
1.3115 + iResult = i < i2;
1.3116 + break;
1.3117 + case INST_GT:
1.3118 + iResult = i > i2;
1.3119 + break;
1.3120 + case INST_LE:
1.3121 + iResult = i <= i2;
1.3122 + break;
1.3123 + case INST_GE:
1.3124 + iResult = i >= i2;
1.3125 + break;
1.3126 + }
1.3127 + }
1.3128 +
1.3129 + foundResult:
1.3130 + TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));
1.3131 +
1.3132 + /*
1.3133 + * Peep-hole optimisation: if you're about to jump, do jump
1.3134 + * from here.
1.3135 + */
1.3136 +
1.3137 + pc++;
1.3138 +#ifndef TCL_COMPILE_DEBUG
1.3139 + switch (*pc) {
1.3140 + case INST_JUMP_FALSE1:
1.3141 + NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
1.3142 + case INST_JUMP_TRUE1:
1.3143 + NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
1.3144 + case INST_JUMP_FALSE4:
1.3145 + NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
1.3146 + case INST_JUMP_TRUE4:
1.3147 + NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
1.3148 + }
1.3149 +#endif
1.3150 + objResultPtr = Tcl_NewIntObj(iResult);
1.3151 + NEXT_INST_F(0, 2, 1);
1.3152 + }
1.3153 +
1.3154 + case INST_MOD:
1.3155 + case INST_LSHIFT:
1.3156 + case INST_RSHIFT:
1.3157 + case INST_BITOR:
1.3158 + case INST_BITXOR:
1.3159 + case INST_BITAND:
1.3160 + {
1.3161 + /*
1.3162 + * Only integers are allowed. We compute value op value2.
1.3163 + */
1.3164 +
1.3165 + long i2 = 0, rem, negative;
1.3166 + long iResult = 0; /* Init. avoids compiler warning. */
1.3167 + Tcl_WideInt w2, wResult = W0;
1.3168 + int doWide = 0;
1.3169 +
1.3170 + value2Ptr = stackPtr[stackTop];
1.3171 + valuePtr = stackPtr[stackTop - 1];
1.3172 + if (valuePtr->typePtr == &tclIntType) {
1.3173 + i = valuePtr->internalRep.longValue;
1.3174 + } else if (valuePtr->typePtr == &tclWideIntType) {
1.3175 + TclGetWide(w,valuePtr);
1.3176 + } else { /* try to convert to int */
1.3177 + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
1.3178 + if (result != TCL_OK) {
1.3179 + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
1.3180 + O2S(valuePtr), O2S(value2Ptr),
1.3181 + (valuePtr->typePtr?
1.3182 + valuePtr->typePtr->name : "null")));
1.3183 + DECACHE_STACK_INFO();
1.3184 + IllegalExprOperandType(interp, pc, valuePtr);
1.3185 + CACHE_STACK_INFO();
1.3186 + goto checkForCatch;
1.3187 + }
1.3188 + }
1.3189 + if (value2Ptr->typePtr == &tclIntType) {
1.3190 + i2 = value2Ptr->internalRep.longValue;
1.3191 + } else if (value2Ptr->typePtr == &tclWideIntType) {
1.3192 + TclGetWide(w2,value2Ptr);
1.3193 + } else {
1.3194 + REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
1.3195 + if (result != TCL_OK) {
1.3196 + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
1.3197 + O2S(valuePtr), O2S(value2Ptr),
1.3198 + (value2Ptr->typePtr?
1.3199 + value2Ptr->typePtr->name : "null")));
1.3200 + DECACHE_STACK_INFO();
1.3201 + IllegalExprOperandType(interp, pc, value2Ptr);
1.3202 + CACHE_STACK_INFO();
1.3203 + goto checkForCatch;
1.3204 + }
1.3205 + }
1.3206 +
1.3207 + switch (*pc) {
1.3208 + case INST_MOD:
1.3209 + /*
1.3210 + * This code is tricky: C doesn't guarantee much about
1.3211 + * the quotient or remainder, but Tcl does. The
1.3212 + * remainder always has the same sign as the divisor and
1.3213 + * a smaller absolute value.
1.3214 + */
1.3215 + if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
1.3216 + if (valuePtr->typePtr == &tclIntType) {
1.3217 + TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
1.3218 + } else {
1.3219 + TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
1.3220 + }
1.3221 + goto divideByZero;
1.3222 + }
1.3223 + if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
1.3224 + if (valuePtr->typePtr == &tclIntType) {
1.3225 + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
1.3226 + } else {
1.3227 + TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
1.3228 + }
1.3229 + goto divideByZero;
1.3230 + }
1.3231 + negative = 0;
1.3232 + if (valuePtr->typePtr == &tclWideIntType
1.3233 + || value2Ptr->typePtr == &tclWideIntType) {
1.3234 + Tcl_WideInt wRemainder;
1.3235 + /*
1.3236 + * Promote to wide
1.3237 + */
1.3238 + if (valuePtr->typePtr == &tclIntType) {
1.3239 + w = Tcl_LongAsWide(i);
1.3240 + } else if (value2Ptr->typePtr == &tclIntType) {
1.3241 + w2 = Tcl_LongAsWide(i2);
1.3242 + }
1.3243 + if (w2 < 0) {
1.3244 + w2 = -w2;
1.3245 + w = -w;
1.3246 + negative = 1;
1.3247 + }
1.3248 + wRemainder = w % w2;
1.3249 + if (wRemainder < 0) {
1.3250 + wRemainder += w2;
1.3251 + }
1.3252 + if (negative) {
1.3253 + wRemainder = -wRemainder;
1.3254 + }
1.3255 + wResult = wRemainder;
1.3256 + doWide = 1;
1.3257 + break;
1.3258 + }
1.3259 + if (i2 < 0) {
1.3260 + i2 = -i2;
1.3261 + i = -i;
1.3262 + negative = 1;
1.3263 + }
1.3264 + rem = i % i2;
1.3265 + if (rem < 0) {
1.3266 + rem += i2;
1.3267 + }
1.3268 + if (negative) {
1.3269 + rem = -rem;
1.3270 + }
1.3271 + iResult = rem;
1.3272 + break;
1.3273 + case INST_LSHIFT:
1.3274 + /*
1.3275 + * Shifts are never usefully 64-bits wide!
1.3276 + */
1.3277 + FORCE_LONG(value2Ptr, i2, w2);
1.3278 + if (valuePtr->typePtr == &tclWideIntType) {
1.3279 +#ifdef TCL_COMPILE_DEBUG
1.3280 + w2 = Tcl_LongAsWide(i2);
1.3281 +#endif /* TCL_COMPILE_DEBUG */
1.3282 + wResult = w;
1.3283 + /*
1.3284 + * Shift in steps when the shift gets large to prevent
1.3285 + * annoying compiler/processor bugs. [Bug 868467]
1.3286 + */
1.3287 + if (i2 >= 64) {
1.3288 + wResult = Tcl_LongAsWide(0);
1.3289 + } else if (i2 > 60) {
1.3290 + wResult = w << 30;
1.3291 + wResult <<= 30;
1.3292 + wResult <<= i2-60;
1.3293 + } else if (i2 > 30) {
1.3294 + wResult = w << 30;
1.3295 + wResult <<= i2-30;
1.3296 + } else {
1.3297 + wResult = w << i2;
1.3298 + }
1.3299 + doWide = 1;
1.3300 + break;
1.3301 + }
1.3302 + /*
1.3303 + * Shift in steps when the shift gets large to prevent
1.3304 + * annoying compiler/processor bugs. [Bug 868467]
1.3305 + */
1.3306 + if (i2 >= 64) {
1.3307 + iResult = 0;
1.3308 + } else if (i2 > 60) {
1.3309 + iResult = i << 30;
1.3310 + iResult <<= 30;
1.3311 + iResult <<= i2-60;
1.3312 + } else if (i2 > 30) {
1.3313 + iResult = i << 30;
1.3314 + iResult <<= i2-30;
1.3315 + } else {
1.3316 + iResult = i << i2;
1.3317 + }
1.3318 + break;
1.3319 + case INST_RSHIFT:
1.3320 + /*
1.3321 + * The following code is a bit tricky: it ensures that
1.3322 + * right shifts propagate the sign bit even on machines
1.3323 + * where ">>" won't do it by default.
1.3324 + */
1.3325 + /*
1.3326 + * Shifts are never usefully 64-bits wide!
1.3327 + */
1.3328 + FORCE_LONG(value2Ptr, i2, w2);
1.3329 + if (valuePtr->typePtr == &tclWideIntType) {
1.3330 +#ifdef TCL_COMPILE_DEBUG
1.3331 + w2 = Tcl_LongAsWide(i2);
1.3332 +#endif /* TCL_COMPILE_DEBUG */
1.3333 + if (w < 0) {
1.3334 + wResult = ~w;
1.3335 + } else {
1.3336 + wResult = w;
1.3337 + }
1.3338 + /*
1.3339 + * Shift in steps when the shift gets large to prevent
1.3340 + * annoying compiler/processor bugs. [Bug 868467]
1.3341 + */
1.3342 + if (i2 >= 64) {
1.3343 + wResult = Tcl_LongAsWide(0);
1.3344 + } else if (i2 > 60) {
1.3345 + wResult >>= 30;
1.3346 + wResult >>= 30;
1.3347 + wResult >>= i2-60;
1.3348 + } else if (i2 > 30) {
1.3349 + wResult >>= 30;
1.3350 + wResult >>= i2-30;
1.3351 + } else {
1.3352 + wResult >>= i2;
1.3353 + }
1.3354 + if (w < 0) {
1.3355 + wResult = ~wResult;
1.3356 + }
1.3357 + doWide = 1;
1.3358 + break;
1.3359 + }
1.3360 + if (i < 0) {
1.3361 + iResult = ~i;
1.3362 + } else {
1.3363 + iResult = i;
1.3364 + }
1.3365 + /*
1.3366 + * Shift in steps when the shift gets large to prevent
1.3367 + * annoying compiler/processor bugs. [Bug 868467]
1.3368 + */
1.3369 + if (i2 >= 64) {
1.3370 + iResult = 0;
1.3371 + } else if (i2 > 60) {
1.3372 + iResult >>= 30;
1.3373 + iResult >>= 30;
1.3374 + iResult >>= i2-60;
1.3375 + } else if (i2 > 30) {
1.3376 + iResult >>= 30;
1.3377 + iResult >>= i2-30;
1.3378 + } else {
1.3379 + iResult >>= i2;
1.3380 + }
1.3381 + if (i < 0) {
1.3382 + iResult = ~iResult;
1.3383 + }
1.3384 + break;
1.3385 + case INST_BITOR:
1.3386 + if (valuePtr->typePtr == &tclWideIntType
1.3387 + || value2Ptr->typePtr == &tclWideIntType) {
1.3388 + /*
1.3389 + * Promote to wide
1.3390 + */
1.3391 + if (valuePtr->typePtr == &tclIntType) {
1.3392 + w = Tcl_LongAsWide(i);
1.3393 + } else if (value2Ptr->typePtr == &tclIntType) {
1.3394 + w2 = Tcl_LongAsWide(i2);
1.3395 + }
1.3396 + wResult = w | w2;
1.3397 + doWide = 1;
1.3398 + break;
1.3399 + }
1.3400 + iResult = i | i2;
1.3401 + break;
1.3402 + case INST_BITXOR:
1.3403 + if (valuePtr->typePtr == &tclWideIntType
1.3404 + || value2Ptr->typePtr == &tclWideIntType) {
1.3405 + /*
1.3406 + * Promote to wide
1.3407 + */
1.3408 + if (valuePtr->typePtr == &tclIntType) {
1.3409 + w = Tcl_LongAsWide(i);
1.3410 + } else if (value2Ptr->typePtr == &tclIntType) {
1.3411 + w2 = Tcl_LongAsWide(i2);
1.3412 + }
1.3413 + wResult = w ^ w2;
1.3414 + doWide = 1;
1.3415 + break;
1.3416 + }
1.3417 + iResult = i ^ i2;
1.3418 + break;
1.3419 + case INST_BITAND:
1.3420 + if (valuePtr->typePtr == &tclWideIntType
1.3421 + || value2Ptr->typePtr == &tclWideIntType) {
1.3422 + /*
1.3423 + * Promote to wide
1.3424 + */
1.3425 + if (valuePtr->typePtr == &tclIntType) {
1.3426 + w = Tcl_LongAsWide(i);
1.3427 + } else if (value2Ptr->typePtr == &tclIntType) {
1.3428 + w2 = Tcl_LongAsWide(i2);
1.3429 + }
1.3430 + wResult = w & w2;
1.3431 + doWide = 1;
1.3432 + break;
1.3433 + }
1.3434 + iResult = i & i2;
1.3435 + break;
1.3436 + }
1.3437 +
1.3438 + /*
1.3439 + * Reuse the valuePtr object already on stack if possible.
1.3440 + */
1.3441 +
1.3442 + if (Tcl_IsShared(valuePtr)) {
1.3443 + if (doWide) {
1.3444 + objResultPtr = Tcl_NewWideIntObj(wResult);
1.3445 + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
1.3446 + } else {
1.3447 + objResultPtr = Tcl_NewLongObj(iResult);
1.3448 + TRACE(("%ld %ld => %ld\n", i, i2, iResult));
1.3449 + }
1.3450 + NEXT_INST_F(1, 2, 1);
1.3451 + } else { /* reuse the valuePtr object */
1.3452 + if (doWide) {
1.3453 + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
1.3454 + Tcl_SetWideIntObj(valuePtr, wResult);
1.3455 + } else {
1.3456 + TRACE(("%ld %ld => %ld\n", i, i2, iResult));
1.3457 + Tcl_SetLongObj(valuePtr, iResult);
1.3458 + }
1.3459 + NEXT_INST_F(1, 1, 0);
1.3460 + }
1.3461 + }
1.3462 +
1.3463 + case INST_ADD:
1.3464 + case INST_SUB:
1.3465 + case INST_MULT:
1.3466 + case INST_DIV:
1.3467 + {
1.3468 + /*
1.3469 + * Operands must be numeric and ints get converted to floats
1.3470 + * if necessary. We compute value op value2.
1.3471 + */
1.3472 +
1.3473 + Tcl_ObjType *t1Ptr, *t2Ptr;
1.3474 + long i2 = 0, quot, rem; /* Init. avoids compiler warning. */
1.3475 + double d1, d2;
1.3476 + long iResult = 0; /* Init. avoids compiler warning. */
1.3477 + double dResult = 0.0; /* Init. avoids compiler warning. */
1.3478 + int doDouble = 0; /* 1 if doing floating arithmetic */
1.3479 + Tcl_WideInt w2, wquot, wrem;
1.3480 + Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
1.3481 + int doWide = 0; /* 1 if doing wide arithmetic. */
1.3482 +
1.3483 + value2Ptr = stackPtr[stackTop];
1.3484 + valuePtr = stackPtr[stackTop - 1];
1.3485 + t1Ptr = valuePtr->typePtr;
1.3486 + t2Ptr = value2Ptr->typePtr;
1.3487 +
1.3488 + if (t1Ptr == &tclIntType) {
1.3489 + i = valuePtr->internalRep.longValue;
1.3490 + } else if (t1Ptr == &tclWideIntType) {
1.3491 + TclGetWide(w,valuePtr);
1.3492 + } else if ((t1Ptr == &tclDoubleType)
1.3493 + && (valuePtr->bytes == NULL)) {
1.3494 + /*
1.3495 + * We can only use the internal rep directly if there is
1.3496 + * no string rep. Otherwise the string rep might actually
1.3497 + * look like an integer, which is preferred.
1.3498 + */
1.3499 +
1.3500 + d1 = valuePtr->internalRep.doubleValue;
1.3501 + } else {
1.3502 + char *s = Tcl_GetStringFromObj(valuePtr, &length);
1.3503 + if (TclLooksLikeInt(s, length)) {
1.3504 + GET_WIDE_OR_INT(result, valuePtr, i, w);
1.3505 + } else {
1.3506 + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1.3507 + valuePtr, &d1);
1.3508 + }
1.3509 + if (result != TCL_OK) {
1.3510 + TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
1.3511 + s, O2S(valuePtr),
1.3512 + (valuePtr->typePtr?
1.3513 + valuePtr->typePtr->name : "null")));
1.3514 + DECACHE_STACK_INFO();
1.3515 + IllegalExprOperandType(interp, pc, valuePtr);
1.3516 + CACHE_STACK_INFO();
1.3517 + goto checkForCatch;
1.3518 + }
1.3519 + t1Ptr = valuePtr->typePtr;
1.3520 + }
1.3521 +
1.3522 + if (t2Ptr == &tclIntType) {
1.3523 + i2 = value2Ptr->internalRep.longValue;
1.3524 + } else if (t2Ptr == &tclWideIntType) {
1.3525 + TclGetWide(w2,value2Ptr);
1.3526 + } else if ((t2Ptr == &tclDoubleType)
1.3527 + && (value2Ptr->bytes == NULL)) {
1.3528 + /*
1.3529 + * We can only use the internal rep directly if there is
1.3530 + * no string rep. Otherwise the string rep might actually
1.3531 + * look like an integer, which is preferred.
1.3532 + */
1.3533 +
1.3534 + d2 = value2Ptr->internalRep.doubleValue;
1.3535 + } else {
1.3536 + char *s = Tcl_GetStringFromObj(value2Ptr, &length);
1.3537 + if (TclLooksLikeInt(s, length)) {
1.3538 + GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
1.3539 + } else {
1.3540 + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1.3541 + value2Ptr, &d2);
1.3542 + }
1.3543 + if (result != TCL_OK) {
1.3544 + TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
1.3545 + O2S(value2Ptr), s,
1.3546 + (value2Ptr->typePtr?
1.3547 + value2Ptr->typePtr->name : "null")));
1.3548 + DECACHE_STACK_INFO();
1.3549 + IllegalExprOperandType(interp, pc, value2Ptr);
1.3550 + CACHE_STACK_INFO();
1.3551 + goto checkForCatch;
1.3552 + }
1.3553 + t2Ptr = value2Ptr->typePtr;
1.3554 + }
1.3555 +
1.3556 + if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
1.3557 + /*
1.3558 + * Do double arithmetic.
1.3559 + */
1.3560 + doDouble = 1;
1.3561 + if (t1Ptr == &tclIntType) {
1.3562 + d1 = i; /* promote value 1 to double */
1.3563 + } else if (t2Ptr == &tclIntType) {
1.3564 + d2 = i2; /* promote value 2 to double */
1.3565 + } else if (t1Ptr == &tclWideIntType) {
1.3566 + d1 = Tcl_WideAsDouble(w);
1.3567 + } else if (t2Ptr == &tclWideIntType) {
1.3568 + d2 = Tcl_WideAsDouble(w2);
1.3569 + }
1.3570 + switch (*pc) {
1.3571 + case INST_ADD:
1.3572 + dResult = d1 + d2;
1.3573 + break;
1.3574 + case INST_SUB:
1.3575 + dResult = d1 - d2;
1.3576 + break;
1.3577 + case INST_MULT:
1.3578 + dResult = d1 * d2;
1.3579 + break;
1.3580 + case INST_DIV:
1.3581 + if (d2 == 0.0) {
1.3582 + TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
1.3583 + goto divideByZero;
1.3584 + }
1.3585 + dResult = d1 / d2;
1.3586 + break;
1.3587 + }
1.3588 +
1.3589 + /*
1.3590 + * Check now for IEEE floating-point error.
1.3591 + */
1.3592 +
1.3593 + if (IS_NAN(dResult) || IS_INF(dResult)) {
1.3594 + TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
1.3595 + O2S(valuePtr), O2S(value2Ptr)));
1.3596 + DECACHE_STACK_INFO();
1.3597 + TclExprFloatError(interp, dResult);
1.3598 + CACHE_STACK_INFO();
1.3599 + result = TCL_ERROR;
1.3600 + goto checkForCatch;
1.3601 + }
1.3602 + } else if ((t1Ptr == &tclWideIntType)
1.3603 + || (t2Ptr == &tclWideIntType)) {
1.3604 + /*
1.3605 + * Do wide integer arithmetic.
1.3606 + */
1.3607 + doWide = 1;
1.3608 + if (t1Ptr == &tclIntType) {
1.3609 + w = Tcl_LongAsWide(i);
1.3610 + } else if (t2Ptr == &tclIntType) {
1.3611 + w2 = Tcl_LongAsWide(i2);
1.3612 + }
1.3613 + switch (*pc) {
1.3614 + case INST_ADD:
1.3615 + wResult = w + w2;
1.3616 + break;
1.3617 + case INST_SUB:
1.3618 + wResult = w - w2;
1.3619 + break;
1.3620 + case INST_MULT:
1.3621 + wResult = w * w2;
1.3622 + break;
1.3623 + case INST_DIV:
1.3624 + /*
1.3625 + * This code is tricky: C doesn't guarantee much
1.3626 + * about the quotient or remainder, but Tcl does.
1.3627 + * The remainder always has the same sign as the
1.3628 + * divisor and a smaller absolute value.
1.3629 + */
1.3630 + if (w2 == W0) {
1.3631 + TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
1.3632 + goto divideByZero;
1.3633 + }
1.3634 + if (w2 < 0) {
1.3635 + w2 = -w2;
1.3636 + w = -w;
1.3637 + }
1.3638 + wquot = w / w2;
1.3639 + wrem = w % w2;
1.3640 + if (wrem < W0) {
1.3641 + wquot -= 1;
1.3642 + }
1.3643 + wResult = wquot;
1.3644 + break;
1.3645 + }
1.3646 + } else {
1.3647 + /*
1.3648 + * Do integer arithmetic.
1.3649 + */
1.3650 + switch (*pc) {
1.3651 + case INST_ADD:
1.3652 + iResult = i + i2;
1.3653 + break;
1.3654 + case INST_SUB:
1.3655 + iResult = i - i2;
1.3656 + break;
1.3657 + case INST_MULT:
1.3658 + iResult = i * i2;
1.3659 + break;
1.3660 + case INST_DIV:
1.3661 + /*
1.3662 + * This code is tricky: C doesn't guarantee much
1.3663 + * about the quotient or remainder, but Tcl does.
1.3664 + * The remainder always has the same sign as the
1.3665 + * divisor and a smaller absolute value.
1.3666 + */
1.3667 + if (i2 == 0) {
1.3668 + TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
1.3669 + goto divideByZero;
1.3670 + }
1.3671 + if (i2 < 0) {
1.3672 + i2 = -i2;
1.3673 + i = -i;
1.3674 + }
1.3675 + quot = i / i2;
1.3676 + rem = i % i2;
1.3677 + if (rem < 0) {
1.3678 + quot -= 1;
1.3679 + }
1.3680 + iResult = quot;
1.3681 + break;
1.3682 + }
1.3683 + }
1.3684 +
1.3685 + /*
1.3686 + * Reuse the valuePtr object already on stack if possible.
1.3687 + */
1.3688 +
1.3689 + if (Tcl_IsShared(valuePtr)) {
1.3690 + if (doDouble) {
1.3691 + objResultPtr = Tcl_NewDoubleObj(dResult);
1.3692 + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
1.3693 + } else if (doWide) {
1.3694 + objResultPtr = Tcl_NewWideIntObj(wResult);
1.3695 + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
1.3696 + } else {
1.3697 + objResultPtr = Tcl_NewLongObj(iResult);
1.3698 + TRACE(("%ld %ld => %ld\n", i, i2, iResult));
1.3699 + }
1.3700 + NEXT_INST_F(1, 2, 1);
1.3701 + } else { /* reuse the valuePtr object */
1.3702 + if (doDouble) { /* NB: stack top is off by 1 */
1.3703 + TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
1.3704 + Tcl_SetDoubleObj(valuePtr, dResult);
1.3705 + } else if (doWide) {
1.3706 + TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
1.3707 + Tcl_SetWideIntObj(valuePtr, wResult);
1.3708 + } else {
1.3709 + TRACE(("%ld %ld => %ld\n", i, i2, iResult));
1.3710 + Tcl_SetLongObj(valuePtr, iResult);
1.3711 + }
1.3712 + NEXT_INST_F(1, 1, 0);
1.3713 + }
1.3714 + }
1.3715 +
1.3716 + case INST_UPLUS:
1.3717 + {
1.3718 + /*
1.3719 + * Operand must be numeric.
1.3720 + */
1.3721 +
1.3722 + double d;
1.3723 + Tcl_ObjType *tPtr;
1.3724 +
1.3725 + valuePtr = stackPtr[stackTop];
1.3726 + tPtr = valuePtr->typePtr;
1.3727 + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
1.3728 + || (valuePtr->bytes != NULL))) {
1.3729 + char *s = Tcl_GetStringFromObj(valuePtr, &length);
1.3730 + if (TclLooksLikeInt(s, length)) {
1.3731 + GET_WIDE_OR_INT(result, valuePtr, i, w);
1.3732 + } else {
1.3733 + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
1.3734 + }
1.3735 + if (result != TCL_OK) {
1.3736 + TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1.3737 + s, (tPtr? tPtr->name : "null")));
1.3738 + DECACHE_STACK_INFO();
1.3739 + IllegalExprOperandType(interp, pc, valuePtr);
1.3740 + CACHE_STACK_INFO();
1.3741 + goto checkForCatch;
1.3742 + }
1.3743 + tPtr = valuePtr->typePtr;
1.3744 + }
1.3745 +
1.3746 + /*
1.3747 + * Ensure that the operand's string rep is the same as the
1.3748 + * formatted version of its internal rep. This makes sure
1.3749 + * that "expr +000123" yields "83", not "000123". We
1.3750 + * implement this by _discarding_ the string rep since we
1.3751 + * know it will be regenerated, if needed later, by
1.3752 + * formatting the internal rep's value.
1.3753 + */
1.3754 +
1.3755 + if (Tcl_IsShared(valuePtr)) {
1.3756 + if (tPtr == &tclIntType) {
1.3757 + i = valuePtr->internalRep.longValue;
1.3758 + objResultPtr = Tcl_NewLongObj(i);
1.3759 + } else if (tPtr == &tclWideIntType) {
1.3760 + TclGetWide(w,valuePtr);
1.3761 + objResultPtr = Tcl_NewWideIntObj(w);
1.3762 + } else {
1.3763 + d = valuePtr->internalRep.doubleValue;
1.3764 + objResultPtr = Tcl_NewDoubleObj(d);
1.3765 + }
1.3766 + TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
1.3767 + NEXT_INST_F(1, 1, 1);
1.3768 + } else {
1.3769 + Tcl_InvalidateStringRep(valuePtr);
1.3770 + TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
1.3771 + NEXT_INST_F(1, 0, 0);
1.3772 + }
1.3773 + }
1.3774 +
1.3775 + case INST_UMINUS:
1.3776 + case INST_LNOT:
1.3777 + {
1.3778 + /*
1.3779 + * The operand must be numeric or a boolean string as
1.3780 + * accepted by Tcl_GetBooleanFromObj(). If the operand
1.3781 + * object is unshared modify it directly, otherwise
1.3782 + * create a copy to modify: this is "copy on write".
1.3783 + * Free any old string representation since it is now
1.3784 + * invalid.
1.3785 + */
1.3786 +
1.3787 + double d;
1.3788 + int boolvar;
1.3789 + Tcl_ObjType *tPtr;
1.3790 +
1.3791 + valuePtr = stackPtr[stackTop];
1.3792 + tPtr = valuePtr->typePtr;
1.3793 + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
1.3794 + || (valuePtr->bytes != NULL))) {
1.3795 + if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
1.3796 + valuePtr->typePtr = &tclIntType;
1.3797 + } else {
1.3798 + char *s = Tcl_GetStringFromObj(valuePtr, &length);
1.3799 + if (TclLooksLikeInt(s, length)) {
1.3800 + GET_WIDE_OR_INT(result, valuePtr, i, w);
1.3801 + } else {
1.3802 + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1.3803 + valuePtr, &d);
1.3804 + }
1.3805 + if (result == TCL_ERROR && *pc == INST_LNOT) {
1.3806 + result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
1.3807 + valuePtr, &boolvar);
1.3808 + i = (long)boolvar; /* i is long, not int! */
1.3809 + }
1.3810 + if (result != TCL_OK) {
1.3811 + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
1.3812 + s, (tPtr? tPtr->name : "null")));
1.3813 + DECACHE_STACK_INFO();
1.3814 + IllegalExprOperandType(interp, pc, valuePtr);
1.3815 + CACHE_STACK_INFO();
1.3816 + goto checkForCatch;
1.3817 + }
1.3818 + }
1.3819 + tPtr = valuePtr->typePtr;
1.3820 + }
1.3821 +
1.3822 + if (Tcl_IsShared(valuePtr)) {
1.3823 + /*
1.3824 + * Create a new object.
1.3825 + */
1.3826 + if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
1.3827 + i = valuePtr->internalRep.longValue;
1.3828 + objResultPtr = Tcl_NewLongObj(
1.3829 + (*pc == INST_UMINUS)? -i : !i);
1.3830 + TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
1.3831 + } else if (tPtr == &tclWideIntType) {
1.3832 + TclGetWide(w,valuePtr);
1.3833 + if (*pc == INST_UMINUS) {
1.3834 + objResultPtr = Tcl_NewWideIntObj(-w);
1.3835 + } else {
1.3836 + objResultPtr = Tcl_NewLongObj(w == W0);
1.3837 + }
1.3838 + TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
1.3839 + } else {
1.3840 + d = valuePtr->internalRep.doubleValue;
1.3841 + if (*pc == INST_UMINUS) {
1.3842 + objResultPtr = Tcl_NewDoubleObj(-d);
1.3843 + } else {
1.3844 + /*
1.3845 + * Should be able to use "!d", but apparently
1.3846 + * some compilers can't handle it.
1.3847 + */
1.3848 + objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
1.3849 + }
1.3850 + TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
1.3851 + }
1.3852 + NEXT_INST_F(1, 1, 1);
1.3853 + } else {
1.3854 + /*
1.3855 + * valuePtr is unshared. Modify it directly.
1.3856 + */
1.3857 + if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
1.3858 + i = valuePtr->internalRep.longValue;
1.3859 + Tcl_SetLongObj(valuePtr,
1.3860 + (*pc == INST_UMINUS)? -i : !i);
1.3861 + TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
1.3862 + } else if (tPtr == &tclWideIntType) {
1.3863 + TclGetWide(w,valuePtr);
1.3864 + if (*pc == INST_UMINUS) {
1.3865 + Tcl_SetWideIntObj(valuePtr, -w);
1.3866 + } else {
1.3867 + Tcl_SetLongObj(valuePtr, w == W0);
1.3868 + }
1.3869 + TRACE_WITH_OBJ((LLD" => ", w), valuePtr);
1.3870 + } else {
1.3871 + d = valuePtr->internalRep.doubleValue;
1.3872 + if (*pc == INST_UMINUS) {
1.3873 + Tcl_SetDoubleObj(valuePtr, -d);
1.3874 + } else {
1.3875 + /*
1.3876 + * Should be able to use "!d", but apparently
1.3877 + * some compilers can't handle it.
1.3878 + */
1.3879 + Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
1.3880 + }
1.3881 + TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
1.3882 + }
1.3883 + NEXT_INST_F(1, 0, 0);
1.3884 + }
1.3885 + }
1.3886 +
1.3887 + case INST_BITNOT:
1.3888 + {
1.3889 + /*
1.3890 + * The operand must be an integer. If the operand object is
1.3891 + * unshared modify it directly, otherwise modify a copy.
1.3892 + * Free any old string representation since it is now
1.3893 + * invalid.
1.3894 + */
1.3895 +
1.3896 + Tcl_ObjType *tPtr;
1.3897 +
1.3898 + valuePtr = stackPtr[stackTop];
1.3899 + tPtr = valuePtr->typePtr;
1.3900 + if (!IS_INTEGER_TYPE(tPtr)) {
1.3901 + REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
1.3902 + if (result != TCL_OK) { /* try to convert to double */
1.3903 + TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
1.3904 + O2S(valuePtr), (tPtr? tPtr->name : "null")));
1.3905 + DECACHE_STACK_INFO();
1.3906 + IllegalExprOperandType(interp, pc, valuePtr);
1.3907 + CACHE_STACK_INFO();
1.3908 + goto checkForCatch;
1.3909 + }
1.3910 + }
1.3911 +
1.3912 + if (valuePtr->typePtr == &tclWideIntType) {
1.3913 + TclGetWide(w,valuePtr);
1.3914 + if (Tcl_IsShared(valuePtr)) {
1.3915 + objResultPtr = Tcl_NewWideIntObj(~w);
1.3916 + TRACE(("0x%llx => (%llu)\n", w, ~w));
1.3917 + NEXT_INST_F(1, 1, 1);
1.3918 + } else {
1.3919 + /*
1.3920 + * valuePtr is unshared. Modify it directly.
1.3921 + */
1.3922 + Tcl_SetWideIntObj(valuePtr, ~w);
1.3923 + TRACE(("0x%llx => (%llu)\n", w, ~w));
1.3924 + NEXT_INST_F(1, 0, 0);
1.3925 + }
1.3926 + } else {
1.3927 + i = valuePtr->internalRep.longValue;
1.3928 + if (Tcl_IsShared(valuePtr)) {
1.3929 + objResultPtr = Tcl_NewLongObj(~i);
1.3930 + TRACE(("0x%lx => (%lu)\n", i, ~i));
1.3931 + NEXT_INST_F(1, 1, 1);
1.3932 + } else {
1.3933 + /*
1.3934 + * valuePtr is unshared. Modify it directly.
1.3935 + */
1.3936 + Tcl_SetLongObj(valuePtr, ~i);
1.3937 + TRACE(("0x%lx => (%lu)\n", i, ~i));
1.3938 + NEXT_INST_F(1, 0, 0);
1.3939 + }
1.3940 + }
1.3941 + }
1.3942 +
1.3943 + case INST_CALL_BUILTIN_FUNC1:
1.3944 + opnd = TclGetUInt1AtPtr(pc+1);
1.3945 + {
1.3946 + /*
1.3947 + * Call one of the built-in Tcl math functions.
1.3948 + */
1.3949 +
1.3950 + BuiltinFunc *mathFuncPtr;
1.3951 +
1.3952 + if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
1.3953 + TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
1.3954 + panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
1.3955 + }
1.3956 + mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
1.3957 + DECACHE_STACK_INFO();
1.3958 + result = (*mathFuncPtr->proc)(interp, eePtr,
1.3959 + mathFuncPtr->clientData);
1.3960 + CACHE_STACK_INFO();
1.3961 + if (result != TCL_OK) {
1.3962 + goto checkForCatch;
1.3963 + }
1.3964 + TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
1.3965 + }
1.3966 + NEXT_INST_F(2, 0, 0);
1.3967 +
1.3968 + case INST_CALL_FUNC1:
1.3969 + opnd = TclGetUInt1AtPtr(pc+1);
1.3970 + {
1.3971 + /*
1.3972 + * Call a non-builtin Tcl math function previously
1.3973 + * registered by a call to Tcl_CreateMathFunc.
1.3974 + */
1.3975 +
1.3976 + int objc = opnd; /* Number of arguments. The function name
1.3977 + * is the 0-th argument. */
1.3978 + Tcl_Obj **objv; /* The array of arguments. The function
1.3979 + * name is objv[0]. */
1.3980 +
1.3981 + objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
1.3982 + DECACHE_STACK_INFO();
1.3983 + result = ExprCallMathFunc(interp, eePtr, objc, objv);
1.3984 + CACHE_STACK_INFO();
1.3985 + if (result != TCL_OK) {
1.3986 + goto checkForCatch;
1.3987 + }
1.3988 + TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
1.3989 + }
1.3990 + NEXT_INST_F(2, 0, 0);
1.3991 +
1.3992 + case INST_TRY_CVT_TO_NUMERIC:
1.3993 + {
1.3994 + /*
1.3995 + * Try to convert the topmost stack object to an int or
1.3996 + * double object. This is done in order to support Tcl's
1.3997 + * policy of interpreting operands if at all possible as
1.3998 + * first integers, else floating-point numbers.
1.3999 + */
1.4000 +
1.4001 + double d;
1.4002 + char *s;
1.4003 + Tcl_ObjType *tPtr;
1.4004 + int converted, needNew;
1.4005 +
1.4006 + valuePtr = stackPtr[stackTop];
1.4007 + tPtr = valuePtr->typePtr;
1.4008 + converted = 0;
1.4009 + if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
1.4010 + || (valuePtr->bytes != NULL))) {
1.4011 + if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
1.4012 + valuePtr->typePtr = &tclIntType;
1.4013 + converted = 1;
1.4014 + } else {
1.4015 + s = Tcl_GetStringFromObj(valuePtr, &length);
1.4016 + if (TclLooksLikeInt(s, length)) {
1.4017 + GET_WIDE_OR_INT(result, valuePtr, i, w);
1.4018 + } else {
1.4019 + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1.4020 + valuePtr, &d);
1.4021 + }
1.4022 + if (result == TCL_OK) {
1.4023 + converted = 1;
1.4024 + }
1.4025 + result = TCL_OK; /* reset the result variable */
1.4026 + }
1.4027 + tPtr = valuePtr->typePtr;
1.4028 + }
1.4029 +
1.4030 + /*
1.4031 + * Ensure that the topmost stack object, if numeric, has a
1.4032 + * string rep the same as the formatted version of its
1.4033 + * internal rep. This is used, e.g., to make sure that "expr
1.4034 + * {0001}" yields "1", not "0001". We implement this by
1.4035 + * _discarding_ the string rep since we know it will be
1.4036 + * regenerated, if needed later, by formatting the internal
1.4037 + * rep's value. Also check if there has been an IEEE
1.4038 + * floating point error.
1.4039 + */
1.4040 +
1.4041 + objResultPtr = valuePtr;
1.4042 + needNew = 0;
1.4043 + if (IS_NUMERIC_TYPE(tPtr)) {
1.4044 + if (Tcl_IsShared(valuePtr)) {
1.4045 + if (valuePtr->bytes != NULL) {
1.4046 + /*
1.4047 + * We only need to make a copy of the object
1.4048 + * when it already had a string rep
1.4049 + */
1.4050 + needNew = 1;
1.4051 + if (tPtr == &tclIntType) {
1.4052 + i = valuePtr->internalRep.longValue;
1.4053 + objResultPtr = Tcl_NewLongObj(i);
1.4054 + } else if (tPtr == &tclWideIntType) {
1.4055 + TclGetWide(w,valuePtr);
1.4056 + objResultPtr = Tcl_NewWideIntObj(w);
1.4057 + } else {
1.4058 + d = valuePtr->internalRep.doubleValue;
1.4059 + objResultPtr = Tcl_NewDoubleObj(d);
1.4060 + }
1.4061 + tPtr = objResultPtr->typePtr;
1.4062 + }
1.4063 + } else {
1.4064 + Tcl_InvalidateStringRep(valuePtr);
1.4065 + }
1.4066 +
1.4067 + if (tPtr == &tclDoubleType) {
1.4068 + d = objResultPtr->internalRep.doubleValue;
1.4069 + if (IS_NAN(d) || IS_INF(d)) {
1.4070 + TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
1.4071 + O2S(objResultPtr)));
1.4072 + DECACHE_STACK_INFO();
1.4073 + TclExprFloatError(interp, d);
1.4074 + CACHE_STACK_INFO();
1.4075 + result = TCL_ERROR;
1.4076 + goto checkForCatch;
1.4077 + }
1.4078 + }
1.4079 + converted = converted; /* lint, converted not used. */
1.4080 + TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
1.4081 + (converted? "converted" : "not converted"),
1.4082 + (needNew? "new Tcl_Obj" : "same Tcl_Obj")));
1.4083 + } else {
1.4084 + TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
1.4085 + }
1.4086 + if (needNew) {
1.4087 + NEXT_INST_F(1, 1, 1);
1.4088 + } else {
1.4089 + NEXT_INST_F(1, 0, 0);
1.4090 + }
1.4091 + }
1.4092 +
1.4093 + case INST_BREAK:
1.4094 + DECACHE_STACK_INFO();
1.4095 + Tcl_ResetResult(interp);
1.4096 + CACHE_STACK_INFO();
1.4097 + result = TCL_BREAK;
1.4098 + cleanup = 0;
1.4099 + goto processExceptionReturn;
1.4100 +
1.4101 + case INST_CONTINUE:
1.4102 + DECACHE_STACK_INFO();
1.4103 + Tcl_ResetResult(interp);
1.4104 + CACHE_STACK_INFO();
1.4105 + result = TCL_CONTINUE;
1.4106 + cleanup = 0;
1.4107 + goto processExceptionReturn;
1.4108 +
1.4109 + case INST_FOREACH_START4:
1.4110 + opnd = TclGetUInt4AtPtr(pc+1);
1.4111 + {
1.4112 + /*
1.4113 + * Initialize the temporary local var that holds the count
1.4114 + * of the number of iterations of the loop body to -1.
1.4115 + */
1.4116 +
1.4117 + ForeachInfo *infoPtr = (ForeachInfo *)
1.4118 + codePtr->auxDataArrayPtr[opnd].clientData;
1.4119 + int iterTmpIndex = infoPtr->loopCtTemp;
1.4120 + Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
1.4121 + Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
1.4122 + Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
1.4123 +
1.4124 + if (oldValuePtr == NULL) {
1.4125 + iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
1.4126 + Tcl_IncrRefCount(iterVarPtr->value.objPtr);
1.4127 + } else {
1.4128 + Tcl_SetLongObj(oldValuePtr, -1);
1.4129 + }
1.4130 + TclSetVarScalar(iterVarPtr);
1.4131 + TclClearVarUndefined(iterVarPtr);
1.4132 + TRACE(("%u => loop iter count temp %d\n",
1.4133 + opnd, iterTmpIndex));
1.4134 + }
1.4135 +
1.4136 +#ifndef TCL_COMPILE_DEBUG
1.4137 + /*
1.4138 + * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
1.4139 + * immediately after INST_FOREACH_START4 - let us just fall
1.4140 + * through instead of jumping back to the top.
1.4141 + */
1.4142 +
1.4143 + pc += 5;
1.4144 +#else
1.4145 + NEXT_INST_F(5, 0, 0);
1.4146 +#endif
1.4147 + case INST_FOREACH_STEP4:
1.4148 + opnd = TclGetUInt4AtPtr(pc+1);
1.4149 + {
1.4150 + /*
1.4151 + * "Step" a foreach loop (i.e., begin its next iteration) by
1.4152 + * assigning the next value list element to each loop var.
1.4153 + */
1.4154 +
1.4155 + ForeachInfo *infoPtr = (ForeachInfo *)
1.4156 + codePtr->auxDataArrayPtr[opnd].clientData;
1.4157 + ForeachVarList *varListPtr;
1.4158 + int numLists = infoPtr->numLists;
1.4159 + Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
1.4160 + Tcl_Obj *listPtr;
1.4161 + Var *iterVarPtr, *listVarPtr;
1.4162 + int iterNum, listTmpIndex, listLen, numVars;
1.4163 + int varIndex, valIndex, continueLoop, j;
1.4164 +
1.4165 + /*
1.4166 + * Increment the temp holding the loop iteration number.
1.4167 + */
1.4168 +
1.4169 + iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
1.4170 + valuePtr = iterVarPtr->value.objPtr;
1.4171 + iterNum = (valuePtr->internalRep.longValue + 1);
1.4172 + Tcl_SetLongObj(valuePtr, iterNum);
1.4173 +
1.4174 + /*
1.4175 + * Check whether all value lists are exhausted and we should
1.4176 + * stop the loop.
1.4177 + */
1.4178 +
1.4179 + continueLoop = 0;
1.4180 + listTmpIndex = infoPtr->firstValueTemp;
1.4181 + for (i = 0; i < numLists; i++) {
1.4182 + varListPtr = infoPtr->varLists[i];
1.4183 + numVars = varListPtr->numVars;
1.4184 +
1.4185 + listVarPtr = &(compiledLocals[listTmpIndex]);
1.4186 + listPtr = listVarPtr->value.objPtr;
1.4187 + result = Tcl_ListObjLength(interp, listPtr, &listLen);
1.4188 + if (result != TCL_OK) {
1.4189 + TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
1.4190 + opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
1.4191 + goto checkForCatch;
1.4192 + }
1.4193 + if (listLen > (iterNum * numVars)) {
1.4194 + continueLoop = 1;
1.4195 + }
1.4196 + listTmpIndex++;
1.4197 + }
1.4198 +
1.4199 + /*
1.4200 + * If some var in some var list still has a remaining list
1.4201 + * element iterate one more time. Assign to var the next
1.4202 + * element from its value list. We already checked above
1.4203 + * that each list temp holds a valid list object.
1.4204 + */
1.4205 +
1.4206 + if (continueLoop) {
1.4207 + listTmpIndex = infoPtr->firstValueTemp;
1.4208 + for (i = 0; i < numLists; i++) {
1.4209 + varListPtr = infoPtr->varLists[i];
1.4210 + numVars = varListPtr->numVars;
1.4211 +
1.4212 + listVarPtr = &(compiledLocals[listTmpIndex]);
1.4213 + listPtr = listVarPtr->value.objPtr;
1.4214 +
1.4215 + valIndex = (iterNum * numVars);
1.4216 + for (j = 0; j < numVars; j++) {
1.4217 + Tcl_Obj **elements;
1.4218 +
1.4219 + /*
1.4220 + * The call to TclPtrSetVar might shimmer listPtr,
1.4221 + * so re-fetch pointers every iteration for safety.
1.4222 + * See test foreach-10.1.
1.4223 + */
1.4224 +
1.4225 + Tcl_ListObjGetElements(NULL, listPtr,
1.4226 + &listLen, &elements);
1.4227 + if (valIndex >= listLen) {
1.4228 + TclNewObj(valuePtr);
1.4229 + } else {
1.4230 + valuePtr = elements[valIndex];
1.4231 + }
1.4232 +
1.4233 + varIndex = varListPtr->varIndexes[j];
1.4234 + varPtr = &(varFramePtr->compiledLocals[varIndex]);
1.4235 + part1 = varPtr->name;
1.4236 + while (TclIsVarLink(varPtr)) {
1.4237 + varPtr = varPtr->value.linkPtr;
1.4238 + }
1.4239 + if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL))
1.4240 + && (varPtr->tracePtr == NULL)
1.4241 + && (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) {
1.4242 + value2Ptr = varPtr->value.objPtr;
1.4243 + if (valuePtr != value2Ptr) {
1.4244 + if (value2Ptr != NULL) {
1.4245 + TclDecrRefCount(value2Ptr);
1.4246 + } else {
1.4247 + TclSetVarScalar(varPtr);
1.4248 + TclClearVarUndefined(varPtr);
1.4249 + }
1.4250 + varPtr->value.objPtr = valuePtr;
1.4251 + Tcl_IncrRefCount(valuePtr);
1.4252 + }
1.4253 + } else {
1.4254 + DECACHE_STACK_INFO();
1.4255 + Tcl_IncrRefCount(valuePtr);
1.4256 + value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
1.4257 + NULL, valuePtr, TCL_LEAVE_ERR_MSG);
1.4258 + TclDecrRefCount(valuePtr);
1.4259 + CACHE_STACK_INFO();
1.4260 + if (value2Ptr == NULL) {
1.4261 + TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
1.4262 + opnd, varIndex),
1.4263 + Tcl_GetObjResult(interp));
1.4264 + result = TCL_ERROR;
1.4265 + goto checkForCatch;
1.4266 + }
1.4267 + }
1.4268 + valIndex++;
1.4269 + }
1.4270 + listTmpIndex++;
1.4271 + }
1.4272 + }
1.4273 + TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
1.4274 + iterNum, (continueLoop? "continue" : "exit")));
1.4275 +
1.4276 + /*
1.4277 + * Run-time peep-hole optimisation: the compiler ALWAYS follows
1.4278 + * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
1.4279 + * instruction and jump direct from here.
1.4280 + */
1.4281 +
1.4282 + pc += 5;
1.4283 + if (*pc == INST_JUMP_FALSE1) {
1.4284 + NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
1.4285 + } else {
1.4286 + NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
1.4287 + }
1.4288 + }
1.4289 +
1.4290 + case INST_BEGIN_CATCH4:
1.4291 + /*
1.4292 + * Record start of the catch command with exception range index
1.4293 + * equal to the operand. Push the current stack depth onto the
1.4294 + * special catch stack.
1.4295 + */
1.4296 + catchStackPtr[++catchTop] = stackTop;
1.4297 + TRACE(("%u => catchTop=%d, stackTop=%d\n",
1.4298 + TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
1.4299 + NEXT_INST_F(5, 0, 0);
1.4300 +
1.4301 + case INST_END_CATCH:
1.4302 + catchTop--;
1.4303 + result = TCL_OK;
1.4304 + TRACE(("=> catchTop=%d\n", catchTop));
1.4305 + NEXT_INST_F(1, 0, 0);
1.4306 +
1.4307 + case INST_PUSH_RESULT:
1.4308 + objResultPtr = Tcl_GetObjResult(interp);
1.4309 + TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
1.4310 +
1.4311 + /*
1.4312 + * See the comments at INST_INVOKE_STK
1.4313 + */
1.4314 + {
1.4315 + Tcl_Obj *newObjResultPtr;
1.4316 + TclNewObj(newObjResultPtr);
1.4317 + Tcl_IncrRefCount(newObjResultPtr);
1.4318 + iPtr->objResultPtr = newObjResultPtr;
1.4319 + }
1.4320 +
1.4321 + NEXT_INST_F(1, 0, -1);
1.4322 +
1.4323 + case INST_PUSH_RETURN_CODE:
1.4324 + objResultPtr = Tcl_NewLongObj(result);
1.4325 + TRACE(("=> %u\n", result));
1.4326 + NEXT_INST_F(1, 0, 1);
1.4327 +
1.4328 + default:
1.4329 + panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
1.4330 + } /* end of switch on opCode */
1.4331 +
1.4332 + /*
1.4333 + * Division by zero in an expression. Control only reaches this
1.4334 + * point by "goto divideByZero".
1.4335 + */
1.4336 +
1.4337 + divideByZero:
1.4338 + DECACHE_STACK_INFO();
1.4339 + Tcl_ResetResult(interp);
1.4340 + Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
1.4341 + Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
1.4342 + (char *) NULL);
1.4343 + CACHE_STACK_INFO();
1.4344 +
1.4345 + result = TCL_ERROR;
1.4346 + goto checkForCatch;
1.4347 +
1.4348 + /*
1.4349 + * An external evaluation (INST_INVOKE or INST_EVAL) returned
1.4350 + * something different from TCL_OK, or else INST_BREAK or
1.4351 + * INST_CONTINUE were called.
1.4352 + */
1.4353 +
1.4354 + processExceptionReturn:
1.4355 +#if TCL_COMPILE_DEBUG
1.4356 + switch (*pc) {
1.4357 + case INST_INVOKE_STK1:
1.4358 + case INST_INVOKE_STK4:
1.4359 + TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
1.4360 + break;
1.4361 + case INST_EVAL_STK:
1.4362 + /*
1.4363 + * Note that the object at stacktop has to be used
1.4364 + * before doing the cleanup.
1.4365 + */
1.4366 +
1.4367 + TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop])));
1.4368 + break;
1.4369 + default:
1.4370 + TRACE(("=> "));
1.4371 + }
1.4372 +#endif
1.4373 + if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
1.4374 + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
1.4375 + if (rangePtr == NULL) {
1.4376 + TRACE_APPEND(("no encl. loop or catch, returning %s\n",
1.4377 + StringForResultCode(result)));
1.4378 + goto abnormalReturn;
1.4379 + }
1.4380 + if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
1.4381 + TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
1.4382 + goto processCatch;
1.4383 + }
1.4384 + while (cleanup--) {
1.4385 + valuePtr = POP_OBJECT();
1.4386 + TclDecrRefCount(valuePtr);
1.4387 + }
1.4388 + if (result == TCL_BREAK) {
1.4389 + result = TCL_OK;
1.4390 + pc = (codePtr->codeStart + rangePtr->breakOffset);
1.4391 + TRACE_APPEND(("%s, range at %d, new pc %d\n",
1.4392 + StringForResultCode(result),
1.4393 + rangePtr->codeOffset, rangePtr->breakOffset));
1.4394 + NEXT_INST_F(0, 0, 0);
1.4395 + } else {
1.4396 + if (rangePtr->continueOffset == -1) {
1.4397 + TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
1.4398 + StringForResultCode(result)));
1.4399 + goto checkForCatch;
1.4400 + }
1.4401 + result = TCL_OK;
1.4402 + pc = (codePtr->codeStart + rangePtr->continueOffset);
1.4403 + TRACE_APPEND(("%s, range at %d, new pc %d\n",
1.4404 + StringForResultCode(result),
1.4405 + rangePtr->codeOffset, rangePtr->continueOffset));
1.4406 + NEXT_INST_F(0, 0, 0);
1.4407 + }
1.4408 +#if TCL_COMPILE_DEBUG
1.4409 + } else if (traceInstructions) {
1.4410 + if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
1.4411 + objPtr = Tcl_GetObjResult(interp);
1.4412 + TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
1.4413 + result, O2S(objPtr)));
1.4414 + } else {
1.4415 + objPtr = Tcl_GetObjResult(interp);
1.4416 + TRACE_APPEND(("%s, result= \"%s\"\n",
1.4417 + StringForResultCode(result), O2S(objPtr)));
1.4418 + }
1.4419 +#endif
1.4420 + }
1.4421 +
1.4422 + /*
1.4423 + * Execution has generated an "exception" such as TCL_ERROR. If the
1.4424 + * exception is an error, record information about what was being
1.4425 + * executed when the error occurred. Find the closest enclosing
1.4426 + * catch range, if any. If no enclosing catch range is found, stop
1.4427 + * execution and return the "exception" code.
1.4428 + */
1.4429 +
1.4430 + checkForCatch:
1.4431 + if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
1.4432 + bytes = GetSrcInfoForPc(pc, codePtr, &length);
1.4433 + if (bytes != NULL) {
1.4434 + DECACHE_STACK_INFO();
1.4435 + Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
1.4436 + CACHE_STACK_INFO();
1.4437 + iPtr->flags |= ERR_ALREADY_LOGGED;
1.4438 + }
1.4439 + }
1.4440 + if (catchTop == -1) {
1.4441 +#ifdef TCL_COMPILE_DEBUG
1.4442 + if (traceInstructions) {
1.4443 + fprintf(stdout, " ... no enclosing catch, returning %s\n",
1.4444 + StringForResultCode(result));
1.4445 + }
1.4446 +#endif
1.4447 + goto abnormalReturn;
1.4448 + }
1.4449 + rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
1.4450 + if (rangePtr == NULL) {
1.4451 + /*
1.4452 + * This is only possible when compiling a [catch] that sends its
1.4453 + * script to INST_EVAL. Cannot correct the compiler without
1.4454 + * breakingcompat with previous .tbc compiled scripts.
1.4455 + */
1.4456 +#ifdef TCL_COMPILE_DEBUG
1.4457 + if (traceInstructions) {
1.4458 + fprintf(stdout, " ... no enclosing catch, returning %s\n",
1.4459 + StringForResultCode(result));
1.4460 + }
1.4461 +#endif
1.4462 + goto abnormalReturn;
1.4463 + }
1.4464 +
1.4465 + /*
1.4466 + * A catch exception range (rangePtr) was found to handle an
1.4467 + * "exception". It was found either by checkForCatch just above or
1.4468 + * by an instruction during break, continue, or error processing.
1.4469 + * Jump to its catchOffset after unwinding the operand stack to
1.4470 + * the depth it had when starting to execute the range's catch
1.4471 + * command.
1.4472 + */
1.4473 +
1.4474 + processCatch:
1.4475 + while (stackTop > catchStackPtr[catchTop]) {
1.4476 + valuePtr = POP_OBJECT();
1.4477 + TclDecrRefCount(valuePtr);
1.4478 + }
1.4479 +#ifdef TCL_COMPILE_DEBUG
1.4480 + if (traceInstructions) {
1.4481 + fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
1.4482 + rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
1.4483 + (unsigned int)(rangePtr->catchOffset));
1.4484 + }
1.4485 +#endif
1.4486 + pc = (codePtr->codeStart + rangePtr->catchOffset);
1.4487 + NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */
1.4488 +
1.4489 + /*
1.4490 + * end of infinite loop dispatching on instructions.
1.4491 + */
1.4492 +
1.4493 + /*
1.4494 + * Abnormal return code. Restore the stack to state it had when starting
1.4495 + * to execute the ByteCode. Panic if the stack is below the initial level.
1.4496 + */
1.4497 +
1.4498 + abnormalReturn:
1.4499 + while (stackTop > initStackTop) {
1.4500 + valuePtr = POP_OBJECT();
1.4501 + TclDecrRefCount(valuePtr);
1.4502 + }
1.4503 + if (stackTop < initStackTop) {
1.4504 + fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
1.4505 + (unsigned int)(pc - codePtr->codeStart),
1.4506 + (unsigned int) stackTop,
1.4507 + (unsigned int) initStackTop);
1.4508 + panic("TclExecuteByteCode execution failure: end stack top < start stack top");
1.4509 + }
1.4510 +
1.4511 + /*
1.4512 + * Free the catch stack array if malloc'ed storage was used.
1.4513 + */
1.4514 +
1.4515 + if (catchStackPtr != catchStackStorage) {
1.4516 + ckfree((char *) catchStackPtr);
1.4517 + }
1.4518 + eePtr->stackTop = initStackTop;
1.4519 + return result;
1.4520 +#undef STATIC_CATCH_STACK_SIZE
1.4521 +}
1.4522 +
1.4523 +#ifdef TCL_COMPILE_DEBUG
1.4524 +/*
1.4525 + *----------------------------------------------------------------------
1.4526 + *
1.4527 + * PrintByteCodeInfo --
1.4528 + *
1.4529 + * This procedure prints a summary about a bytecode object to stdout.
1.4530 + * It is called by TclExecuteByteCode when starting to execute the
1.4531 + * bytecode object if tclTraceExec has the value 2 or more.
1.4532 + *
1.4533 + * Results:
1.4534 + * None.
1.4535 + *
1.4536 + * Side effects:
1.4537 + * None.
1.4538 + *
1.4539 + *----------------------------------------------------------------------
1.4540 + */
1.4541 +
1.4542 +static void
1.4543 +PrintByteCodeInfo(codePtr)
1.4544 + register ByteCode *codePtr; /* The bytecode whose summary is printed
1.4545 + * to stdout. */
1.4546 +{
1.4547 + Proc *procPtr = codePtr->procPtr;
1.4548 + Interp *iPtr = (Interp *) *codePtr->interpHandle;
1.4549 +
1.4550 + fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
1.4551 + (unsigned int) codePtr, codePtr->refCount,
1.4552 + codePtr->compileEpoch, (unsigned int) iPtr,
1.4553 + iPtr->compileEpoch);
1.4554 +
1.4555 + fprintf(stdout, " Source: ");
1.4556 + TclPrintSource(stdout, codePtr->source, 60);
1.4557 +
1.4558 + fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
1.4559 + codePtr->numCommands, codePtr->numSrcBytes,
1.4560 + codePtr->numCodeBytes, codePtr->numLitObjects,
1.4561 + codePtr->numAuxDataItems, codePtr->maxStackDepth,
1.4562 +#ifdef TCL_COMPILE_STATS
1.4563 + (codePtr->numSrcBytes?
1.4564 + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
1.4565 +#else
1.4566 + 0.0);
1.4567 +#endif
1.4568 +#ifdef TCL_COMPILE_STATS
1.4569 + fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
1.4570 + codePtr->structureSize,
1.4571 + (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
1.4572 + codePtr->numCodeBytes,
1.4573 + (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
1.4574 + (codePtr->numExceptRanges * sizeof(ExceptionRange)),
1.4575 + (codePtr->numAuxDataItems * sizeof(AuxData)),
1.4576 + codePtr->numCmdLocBytes);
1.4577 +#endif /* TCL_COMPILE_STATS */
1.4578 + if (procPtr != NULL) {
1.4579 + fprintf(stdout,
1.4580 + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
1.4581 + (unsigned int) procPtr, procPtr->refCount,
1.4582 + procPtr->numArgs, procPtr->numCompiledLocals);
1.4583 + }
1.4584 +}
1.4585 +#endif /* TCL_COMPILE_DEBUG */
1.4586 +
1.4587 +/*
1.4588 + *----------------------------------------------------------------------
1.4589 + *
1.4590 + * ValidatePcAndStackTop --
1.4591 + *
1.4592 + * This procedure is called by TclExecuteByteCode when debugging to
1.4593 + * verify that the program counter and stack top are valid during
1.4594 + * execution.
1.4595 + *
1.4596 + * Results:
1.4597 + * None.
1.4598 + *
1.4599 + * Side effects:
1.4600 + * Prints a message to stderr and panics if either the pc or stack
1.4601 + * top are invalid.
1.4602 + *
1.4603 + *----------------------------------------------------------------------
1.4604 + */
1.4605 +
1.4606 +#ifdef TCL_COMPILE_DEBUG
1.4607 +static void
1.4608 +ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound)
1.4609 + register ByteCode *codePtr; /* The bytecode whose summary is printed
1.4610 + * to stdout. */
1.4611 + unsigned char *pc; /* Points to first byte of a bytecode
1.4612 + * instruction. The program counter. */
1.4613 + int stackTop; /* Current stack top. Must be between
1.4614 + * stackLowerBound and stackUpperBound
1.4615 + * (inclusive). */
1.4616 + int stackLowerBound; /* Smallest legal value for stackTop. */
1.4617 +{
1.4618 + int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
1.4619 + /* Greatest legal value for stackTop. */
1.4620 + unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
1.4621 + unsigned int codeStart = (unsigned int) codePtr->codeStart;
1.4622 + unsigned int codeEnd = (unsigned int)
1.4623 + (codePtr->codeStart + codePtr->numCodeBytes);
1.4624 + unsigned char opCode = *pc;
1.4625 +
1.4626 + if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
1.4627 + fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
1.4628 + (unsigned int) pc);
1.4629 + panic("TclExecuteByteCode execution failure: bad pc");
1.4630 + }
1.4631 + if ((unsigned int) opCode > LAST_INST_OPCODE) {
1.4632 + fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
1.4633 + (unsigned int) opCode, relativePc);
1.4634 + panic("TclExecuteByteCode execution failure: bad opcode");
1.4635 + }
1.4636 + if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
1.4637 + int numChars;
1.4638 + char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
1.4639 + char *ellipsis = "";
1.4640 +
1.4641 + fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
1.4642 + stackTop, relativePc, stackLowerBound, stackUpperBound);
1.4643 + if (cmd != NULL) {
1.4644 + if (numChars > 100) {
1.4645 + numChars = 100;
1.4646 + ellipsis = "...";
1.4647 + }
1.4648 + fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
1.4649 + ellipsis);
1.4650 + } else {
1.4651 + fprintf(stderr, "\n");
1.4652 + }
1.4653 + panic("TclExecuteByteCode execution failure: bad stack top");
1.4654 + }
1.4655 +}
1.4656 +#endif /* TCL_COMPILE_DEBUG */
1.4657 +
1.4658 +/*
1.4659 + *----------------------------------------------------------------------
1.4660 + *
1.4661 + * IllegalExprOperandType --
1.4662 + *
1.4663 + * Used by TclExecuteByteCode to add an error message to errorInfo
1.4664 + * when an illegal operand type is detected by an expression
1.4665 + * instruction. The argument opndPtr holds the operand object in error.
1.4666 + *
1.4667 + * Results:
1.4668 + * None.
1.4669 + *
1.4670 + * Side effects:
1.4671 + * An error message is appended to errorInfo.
1.4672 + *
1.4673 + *----------------------------------------------------------------------
1.4674 + */
1.4675 +
1.4676 +static void
1.4677 +IllegalExprOperandType(interp, pc, opndPtr)
1.4678 + Tcl_Interp *interp; /* Interpreter to which error information
1.4679 + * pertains. */
1.4680 + unsigned char *pc; /* Points to the instruction being executed
1.4681 + * when the illegal type was found. */
1.4682 + Tcl_Obj *opndPtr; /* Points to the operand holding the value
1.4683 + * with the illegal type. */
1.4684 +{
1.4685 + unsigned char opCode = *pc;
1.4686 +
1.4687 + Tcl_ResetResult(interp);
1.4688 + if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
1.4689 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.4690 + "can't use empty string as operand of \"",
1.4691 + operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
1.4692 + } else {
1.4693 + char *msg = "non-numeric string";
1.4694 + char *s, *p;
1.4695 + int length;
1.4696 + int looksLikeInt = 0;
1.4697 +
1.4698 + s = Tcl_GetStringFromObj(opndPtr, &length);
1.4699 + p = s;
1.4700 + /*
1.4701 + * strtod() isn't at all consistent about detecting Inf and
1.4702 + * NaN between platforms.
1.4703 + */
1.4704 + if (length == 3) {
1.4705 + if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
1.4706 + (s[2]=='n' || s[2]=='N')) {
1.4707 + msg = "non-numeric floating-point value";
1.4708 + goto makeErrorMessage;
1.4709 + }
1.4710 + if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
1.4711 + (s[2]=='f' || s[2]=='F')) {
1.4712 + msg = "infinite floating-point value";
1.4713 + goto makeErrorMessage;
1.4714 + }
1.4715 + }
1.4716 +
1.4717 + /*
1.4718 + * We cannot use TclLooksLikeInt here because it passes strings
1.4719 + * like "10;" [Bug 587140]. We'll accept as "looking like ints"
1.4720 + * for the present purposes any string that looks formally like
1.4721 + * a (decimal|octal|hex) integer.
1.4722 + */
1.4723 +
1.4724 + while (length && isspace(UCHAR(*p))) {
1.4725 + length--;
1.4726 + p++;
1.4727 + }
1.4728 + if (length && ((*p == '+') || (*p == '-'))) {
1.4729 + length--;
1.4730 + p++;
1.4731 + }
1.4732 + if (length) {
1.4733 + if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
1.4734 + p += 2;
1.4735 + length -= 2;
1.4736 + looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
1.4737 + if (looksLikeInt) {
1.4738 + length--;
1.4739 + p++;
1.4740 + while (length && isxdigit(UCHAR(*p))) {
1.4741 + length--;
1.4742 + p++;
1.4743 + }
1.4744 + }
1.4745 + } else {
1.4746 + looksLikeInt = (length && isdigit(UCHAR(*p)));
1.4747 + if (looksLikeInt) {
1.4748 + length--;
1.4749 + p++;
1.4750 + while (length && isdigit(UCHAR(*p))) {
1.4751 + length--;
1.4752 + p++;
1.4753 + }
1.4754 + }
1.4755 + }
1.4756 + while (length && isspace(UCHAR(*p))) {
1.4757 + length--;
1.4758 + p++;
1.4759 + }
1.4760 + looksLikeInt = !length;
1.4761 + }
1.4762 + if (looksLikeInt) {
1.4763 + /*
1.4764 + * If something that looks like an integer could not be
1.4765 + * converted, then it *must* be a bad octal or too large
1.4766 + * to represent [Bug 542588].
1.4767 + */
1.4768 +
1.4769 + if (TclCheckBadOctal(NULL, s)) {
1.4770 + msg = "invalid octal number";
1.4771 + } else {
1.4772 + msg = "integer value too large to represent";
1.4773 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
1.4774 + "integer value too large to represent", (char *) NULL);
1.4775 + }
1.4776 + } else {
1.4777 + /*
1.4778 + * See if the operand can be interpreted as a double in
1.4779 + * order to improve the error message.
1.4780 + */
1.4781 +
1.4782 + double d;
1.4783 +
1.4784 + if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
1.4785 + msg = "floating-point value";
1.4786 + }
1.4787 + }
1.4788 + makeErrorMessage:
1.4789 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
1.4790 + msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
1.4791 + "\"", (char *) NULL);
1.4792 + }
1.4793 +}
1.4794 +
1.4795 +/*
1.4796 + *----------------------------------------------------------------------
1.4797 + *
1.4798 + * TclGetSrcInfoForPc, GetSrcInfoForPc --
1.4799 + *
1.4800 + * Given a program counter value, finds the closest command in the
1.4801 + * bytecode code unit's CmdLocation array and returns information about
1.4802 + * that command's source: a pointer to its first byte and the number of
1.4803 + * characters.
1.4804 + *
1.4805 + * Results:
1.4806 + * If a command is found that encloses the program counter value, a
1.4807 + * pointer to the command's source is returned and the length of the
1.4808 + * source is stored at *lengthPtr. If multiple commands resulted in
1.4809 + * code at pc, information about the closest enclosing command is
1.4810 + * returned. If no matching command is found, NULL is returned and
1.4811 + * *lengthPtr is unchanged.
1.4812 + *
1.4813 + * Side effects:
1.4814 + * None.
1.4815 + *
1.4816 + *----------------------------------------------------------------------
1.4817 + */
1.4818 +
1.4819 +#ifdef TCL_TIP280
1.4820 +void
1.4821 +TclGetSrcInfoForPc (cfPtr)
1.4822 + CmdFrame* cfPtr;
1.4823 +{
1.4824 + ByteCode* codePtr = (ByteCode*) cfPtr->data.tebc.codePtr;
1.4825 +
1.4826 + if (cfPtr->cmd.str.cmd == NULL) {
1.4827 + cfPtr->cmd.str.cmd = GetSrcInfoForPc((char*) cfPtr->data.tebc.pc,
1.4828 + codePtr,
1.4829 + &cfPtr->cmd.str.len);
1.4830 + }
1.4831 +
1.4832 + if (cfPtr->cmd.str.cmd != NULL) {
1.4833 + /* We now have the command. We can get the srcOffset back and
1.4834 + * from there find the list of word locations for this command
1.4835 + */
1.4836 +
1.4837 + ExtCmdLoc* eclPtr;
1.4838 + ECL* locPtr = NULL;
1.4839 + int srcOffset;
1.4840 +
1.4841 + Interp* iPtr = (Interp*) *codePtr->interpHandle;
1.4842 + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
1.4843 +
1.4844 + if (!hePtr) return;
1.4845 +
1.4846 + srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
1.4847 + eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
1.4848 +
1.4849 + {
1.4850 + int i;
1.4851 + for (i=0; i < eclPtr->nuloc; i++) {
1.4852 + if (eclPtr->loc [i].srcOffset == srcOffset) {
1.4853 + locPtr = &(eclPtr->loc [i]);
1.4854 + break;
1.4855 + }
1.4856 + }
1.4857 + }
1.4858 +
1.4859 + if (locPtr == NULL) {Tcl_Panic ("LocSearch failure");}
1.4860 +
1.4861 + cfPtr->line = locPtr->line;
1.4862 + cfPtr->nline = locPtr->nline;
1.4863 + cfPtr->type = eclPtr->type;
1.4864 +
1.4865 + if (eclPtr->type == TCL_LOCATION_SOURCE) {
1.4866 + cfPtr->data.eval.path = eclPtr->path;
1.4867 + Tcl_IncrRefCount (cfPtr->data.eval.path);
1.4868 + }
1.4869 + /* Do not set cfPtr->data.eval.path NULL for non-SOURCE
1.4870 + * Needed for cfPtr->data.tebc.codePtr.
1.4871 + */
1.4872 + }
1.4873 +}
1.4874 +#endif
1.4875 +
1.4876 +static char *
1.4877 +GetSrcInfoForPc(pc, codePtr, lengthPtr)
1.4878 + unsigned char *pc; /* The program counter value for which to
1.4879 + * return the closest command's source info.
1.4880 + * This points to a bytecode instruction
1.4881 + * in codePtr's code. */
1.4882 + ByteCode *codePtr; /* The bytecode sequence in which to look
1.4883 + * up the command source for the pc. */
1.4884 + int *lengthPtr; /* If non-NULL, the location where the
1.4885 + * length of the command's source should be
1.4886 + * stored. If NULL, no length is stored. */
1.4887 +{
1.4888 + register int pcOffset = (pc - codePtr->codeStart);
1.4889 + int numCmds = codePtr->numCommands;
1.4890 + unsigned char *codeDeltaNext, *codeLengthNext;
1.4891 + unsigned char *srcDeltaNext, *srcLengthNext;
1.4892 + int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
1.4893 + int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
1.4894 + int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
1.4895 + int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
1.4896 +
1.4897 + if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
1.4898 + return NULL;
1.4899 + }
1.4900 +
1.4901 + /*
1.4902 + * Decode the code and source offset and length for each command. The
1.4903 + * closest enclosing command is the last one whose code started before
1.4904 + * pcOffset.
1.4905 + */
1.4906 +
1.4907 + codeDeltaNext = codePtr->codeDeltaStart;
1.4908 + codeLengthNext = codePtr->codeLengthStart;
1.4909 + srcDeltaNext = codePtr->srcDeltaStart;
1.4910 + srcLengthNext = codePtr->srcLengthStart;
1.4911 + codeOffset = srcOffset = 0;
1.4912 + for (i = 0; i < numCmds; i++) {
1.4913 + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
1.4914 + codeDeltaNext++;
1.4915 + delta = TclGetInt4AtPtr(codeDeltaNext);
1.4916 + codeDeltaNext += 4;
1.4917 + } else {
1.4918 + delta = TclGetInt1AtPtr(codeDeltaNext);
1.4919 + codeDeltaNext++;
1.4920 + }
1.4921 + codeOffset += delta;
1.4922 +
1.4923 + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
1.4924 + codeLengthNext++;
1.4925 + codeLen = TclGetInt4AtPtr(codeLengthNext);
1.4926 + codeLengthNext += 4;
1.4927 + } else {
1.4928 + codeLen = TclGetInt1AtPtr(codeLengthNext);
1.4929 + codeLengthNext++;
1.4930 + }
1.4931 + codeEnd = (codeOffset + codeLen - 1);
1.4932 +
1.4933 + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
1.4934 + srcDeltaNext++;
1.4935 + delta = TclGetInt4AtPtr(srcDeltaNext);
1.4936 + srcDeltaNext += 4;
1.4937 + } else {
1.4938 + delta = TclGetInt1AtPtr(srcDeltaNext);
1.4939 + srcDeltaNext++;
1.4940 + }
1.4941 + srcOffset += delta;
1.4942 +
1.4943 + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
1.4944 + srcLengthNext++;
1.4945 + srcLen = TclGetInt4AtPtr(srcLengthNext);
1.4946 + srcLengthNext += 4;
1.4947 + } else {
1.4948 + srcLen = TclGetInt1AtPtr(srcLengthNext);
1.4949 + srcLengthNext++;
1.4950 + }
1.4951 +
1.4952 + if (codeOffset > pcOffset) { /* best cmd already found */
1.4953 + break;
1.4954 + } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
1.4955 + int dist = (pcOffset - codeOffset);
1.4956 + if (dist <= bestDist) {
1.4957 + bestDist = dist;
1.4958 + bestSrcOffset = srcOffset;
1.4959 + bestSrcLength = srcLen;
1.4960 + }
1.4961 + }
1.4962 + }
1.4963 +
1.4964 + if (bestDist == INT_MAX) {
1.4965 + return NULL;
1.4966 + }
1.4967 +
1.4968 + if (lengthPtr != NULL) {
1.4969 + *lengthPtr = bestSrcLength;
1.4970 + }
1.4971 + return (codePtr->source + bestSrcOffset);
1.4972 +}
1.4973 +
1.4974 +/*
1.4975 + *----------------------------------------------------------------------
1.4976 + *
1.4977 + * GetExceptRangeForPc --
1.4978 + *
1.4979 + * Given a program counter value, return the closest enclosing
1.4980 + * ExceptionRange.
1.4981 + *
1.4982 + * Results:
1.4983 + * In the normal case, catchOnly is 0 (false) and this procedure
1.4984 + * returns a pointer to the most closely enclosing ExceptionRange
1.4985 + * structure regardless of whether it is a loop or catch exception
1.4986 + * range. This is appropriate when processing a TCL_BREAK or
1.4987 + * TCL_CONTINUE, which will be "handled" either by a loop exception
1.4988 + * range or a closer catch range. If catchOnly is nonzero, this
1.4989 + * procedure ignores loop exception ranges and returns a pointer to the
1.4990 + * closest catch range. If no matching ExceptionRange is found that
1.4991 + * encloses pc, a NULL is returned.
1.4992 + *
1.4993 + * Side effects:
1.4994 + * None.
1.4995 + *
1.4996 + *----------------------------------------------------------------------
1.4997 + */
1.4998 +
1.4999 +static ExceptionRange *
1.5000 +GetExceptRangeForPc(pc, catchOnly, codePtr)
1.5001 + unsigned char *pc; /* The program counter value for which to
1.5002 + * search for a closest enclosing exception
1.5003 + * range. This points to a bytecode
1.5004 + * instruction in codePtr's code. */
1.5005 + int catchOnly; /* If 0, consider either loop or catch
1.5006 + * ExceptionRanges in search. If nonzero
1.5007 + * consider only catch ranges (and ignore
1.5008 + * any closer loop ranges). */
1.5009 + ByteCode* codePtr; /* Points to the ByteCode in which to search
1.5010 + * for the enclosing ExceptionRange. */
1.5011 +{
1.5012 + ExceptionRange *rangeArrayPtr;
1.5013 + int numRanges = codePtr->numExceptRanges;
1.5014 + register ExceptionRange *rangePtr;
1.5015 + int pcOffset = (pc - codePtr->codeStart);
1.5016 + register int start;
1.5017 +
1.5018 + if (numRanges == 0) {
1.5019 + return NULL;
1.5020 + }
1.5021 +
1.5022 + /*
1.5023 + * This exploits peculiarities of our compiler: nested ranges
1.5024 + * are always *after* their containing ranges, so that by scanning
1.5025 + * backwards we are sure that the first matching range is indeed
1.5026 + * the deepest.
1.5027 + */
1.5028 +
1.5029 + rangeArrayPtr = codePtr->exceptArrayPtr;
1.5030 + rangePtr = rangeArrayPtr + numRanges;
1.5031 + while (--rangePtr >= rangeArrayPtr) {
1.5032 + start = rangePtr->codeOffset;
1.5033 + if ((start <= pcOffset) &&
1.5034 + (pcOffset < (start + rangePtr->numCodeBytes))) {
1.5035 + if ((!catchOnly)
1.5036 + || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
1.5037 + return rangePtr;
1.5038 + }
1.5039 + }
1.5040 + }
1.5041 + return NULL;
1.5042 +}
1.5043 +
1.5044 +/*
1.5045 + *----------------------------------------------------------------------
1.5046 + *
1.5047 + * GetOpcodeName --
1.5048 + *
1.5049 + * This procedure is called by the TRACE and TRACE_WITH_OBJ macros
1.5050 + * used in TclExecuteByteCode when debugging. It returns the name of
1.5051 + * the bytecode instruction at a specified instruction pc.
1.5052 + *
1.5053 + * Results:
1.5054 + * A character string for the instruction.
1.5055 + *
1.5056 + * Side effects:
1.5057 + * None.
1.5058 + *
1.5059 + *----------------------------------------------------------------------
1.5060 + */
1.5061 +
1.5062 +#ifdef TCL_COMPILE_DEBUG
1.5063 +static char *
1.5064 +GetOpcodeName(pc)
1.5065 + unsigned char *pc; /* Points to the instruction whose name
1.5066 + * should be returned. */
1.5067 +{
1.5068 + unsigned char opCode = *pc;
1.5069 +
1.5070 + return tclInstructionTable[opCode].name;
1.5071 +}
1.5072 +#endif /* TCL_COMPILE_DEBUG */
1.5073 +
1.5074 +/*
1.5075 + *----------------------------------------------------------------------
1.5076 + *
1.5077 + * VerifyExprObjType --
1.5078 + *
1.5079 + * This procedure is called by the math functions to verify that
1.5080 + * the object is either an int or double, coercing it if necessary.
1.5081 + * If an error occurs during conversion, an error message is left
1.5082 + * in the interpreter's result unless "interp" is NULL.
1.5083 + *
1.5084 + * Results:
1.5085 + * TCL_OK if it was int or double, TCL_ERROR otherwise
1.5086 + *
1.5087 + * Side effects:
1.5088 + * objPtr is ensured to be of tclIntType, tclWideIntType or
1.5089 + * tclDoubleType.
1.5090 + *
1.5091 + *----------------------------------------------------------------------
1.5092 + */
1.5093 +
1.5094 +static int
1.5095 +VerifyExprObjType(interp, objPtr)
1.5096 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5097 + * function. */
1.5098 + Tcl_Obj *objPtr; /* Points to the object to type check. */
1.5099 +{
1.5100 + if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
1.5101 + return TCL_OK;
1.5102 + } else {
1.5103 + int length, result = TCL_OK;
1.5104 + char *s = Tcl_GetStringFromObj(objPtr, &length);
1.5105 +
1.5106 + if (TclLooksLikeInt(s, length)) {
1.5107 + long i;
1.5108 + Tcl_WideInt w;
1.5109 + GET_WIDE_OR_INT(result, objPtr, i, w);
1.5110 + } else {
1.5111 + double d;
1.5112 + result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
1.5113 + }
1.5114 + if ((result != TCL_OK) && (interp != NULL)) {
1.5115 + Tcl_ResetResult(interp);
1.5116 + if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
1.5117 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.5118 + "argument to math function was an invalid octal number",
1.5119 + -1);
1.5120 + } else {
1.5121 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.5122 + "argument to math function didn't have numeric value",
1.5123 + -1);
1.5124 + }
1.5125 + }
1.5126 + return result;
1.5127 + }
1.5128 +}
1.5129 +
1.5130 +/*
1.5131 + *----------------------------------------------------------------------
1.5132 + *
1.5133 + * Math Functions --
1.5134 + *
1.5135 + * This page contains the procedures that implement all of the
1.5136 + * built-in math functions for expressions.
1.5137 + *
1.5138 + * Results:
1.5139 + * Each procedure returns TCL_OK if it succeeds and pushes an
1.5140 + * Tcl object holding the result. If it fails it returns TCL_ERROR
1.5141 + * and leaves an error message in the interpreter's result.
1.5142 + *
1.5143 + * Side effects:
1.5144 + * None.
1.5145 + *
1.5146 + *----------------------------------------------------------------------
1.5147 + */
1.5148 +
1.5149 +static int
1.5150 +ExprUnaryFunc(interp, eePtr, clientData)
1.5151 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5152 + * function. */
1.5153 + ExecEnv *eePtr; /* Points to the environment for executing
1.5154 + * the function. */
1.5155 + ClientData clientData; /* Contains the address of a procedure that
1.5156 + * takes one double argument and returns a
1.5157 + * double result. */
1.5158 +{
1.5159 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5160 + register int stackTop; /* Cached top index of evaluation stack. */
1.5161 + register Tcl_Obj *valuePtr;
1.5162 + double d, dResult;
1.5163 + int result;
1.5164 +
1.5165 + double (*func) _ANSI_ARGS_((double)) =
1.5166 + (double (*)_ANSI_ARGS_((double))) clientData;
1.5167 +
1.5168 + /*
1.5169 + * Set stackPtr and stackTop from eePtr.
1.5170 + */
1.5171 +
1.5172 + result = TCL_OK;
1.5173 + CACHE_STACK_INFO();
1.5174 +
1.5175 + /*
1.5176 + * Pop the function's argument from the evaluation stack. Convert it
1.5177 + * to a double if necessary.
1.5178 + */
1.5179 +
1.5180 + valuePtr = POP_OBJECT();
1.5181 +
1.5182 + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
1.5183 + result = TCL_ERROR;
1.5184 + goto done;
1.5185 + }
1.5186 +
1.5187 + GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);
1.5188 +
1.5189 + errno = 0;
1.5190 + dResult = (*func)(d);
1.5191 + if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
1.5192 + TclExprFloatError(interp, dResult);
1.5193 + result = TCL_ERROR;
1.5194 + goto done;
1.5195 + }
1.5196 +
1.5197 + /*
1.5198 + * Push a Tcl object holding the result.
1.5199 + */
1.5200 +
1.5201 + PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
1.5202 +
1.5203 + /*
1.5204 + * Reflect the change to stackTop back in eePtr.
1.5205 + */
1.5206 +
1.5207 + done:
1.5208 + TclDecrRefCount(valuePtr);
1.5209 + DECACHE_STACK_INFO();
1.5210 + return result;
1.5211 +}
1.5212 +
1.5213 +static int
1.5214 +ExprBinaryFunc(interp, eePtr, clientData)
1.5215 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5216 + * function. */
1.5217 + ExecEnv *eePtr; /* Points to the environment for executing
1.5218 + * the function. */
1.5219 + ClientData clientData; /* Contains the address of a procedure that
1.5220 + * takes two double arguments and
1.5221 + * returns a double result. */
1.5222 +{
1.5223 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5224 + register int stackTop; /* Cached top index of evaluation stack. */
1.5225 + register Tcl_Obj *valuePtr, *value2Ptr;
1.5226 + double d1, d2, dResult;
1.5227 + int result;
1.5228 +
1.5229 + double (*func) _ANSI_ARGS_((double, double))
1.5230 + = (double (*)_ANSI_ARGS_((double, double))) clientData;
1.5231 +
1.5232 + /*
1.5233 + * Set stackPtr and stackTop from eePtr.
1.5234 + */
1.5235 +
1.5236 + result = TCL_OK;
1.5237 + CACHE_STACK_INFO();
1.5238 +
1.5239 + /*
1.5240 + * Pop the function's two arguments from the evaluation stack. Convert
1.5241 + * them to doubles if necessary.
1.5242 + */
1.5243 +
1.5244 + value2Ptr = POP_OBJECT();
1.5245 + valuePtr = POP_OBJECT();
1.5246 +
1.5247 + if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
1.5248 + (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
1.5249 + result = TCL_ERROR;
1.5250 + goto done;
1.5251 + }
1.5252 +
1.5253 + GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr);
1.5254 + GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr);
1.5255 +
1.5256 + errno = 0;
1.5257 + dResult = (*func)(d1, d2);
1.5258 + if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
1.5259 + TclExprFloatError(interp, dResult);
1.5260 + result = TCL_ERROR;
1.5261 + goto done;
1.5262 + }
1.5263 +
1.5264 + /*
1.5265 + * Push a Tcl object holding the result.
1.5266 + */
1.5267 +
1.5268 + PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
1.5269 +
1.5270 + /*
1.5271 + * Reflect the change to stackTop back in eePtr.
1.5272 + */
1.5273 +
1.5274 + done:
1.5275 + TclDecrRefCount(valuePtr);
1.5276 + TclDecrRefCount(value2Ptr);
1.5277 + DECACHE_STACK_INFO();
1.5278 + return result;
1.5279 +}
1.5280 +
1.5281 +static int
1.5282 +ExprAbsFunc(interp, eePtr, clientData)
1.5283 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5284 + * function. */
1.5285 + ExecEnv *eePtr; /* Points to the environment for executing
1.5286 + * the function. */
1.5287 + ClientData clientData; /* Ignored. */
1.5288 +{
1.5289 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5290 + register int stackTop; /* Cached top index of evaluation stack. */
1.5291 + register Tcl_Obj *valuePtr;
1.5292 + long i, iResult;
1.5293 + double d, dResult;
1.5294 + int result;
1.5295 +
1.5296 + /*
1.5297 + * Set stackPtr and stackTop from eePtr.
1.5298 + */
1.5299 +
1.5300 + result = TCL_OK;
1.5301 + CACHE_STACK_INFO();
1.5302 +
1.5303 + /*
1.5304 + * Pop the argument from the evaluation stack.
1.5305 + */
1.5306 +
1.5307 + valuePtr = POP_OBJECT();
1.5308 +
1.5309 + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
1.5310 + result = TCL_ERROR;
1.5311 + goto done;
1.5312 + }
1.5313 +
1.5314 + /*
1.5315 + * Push a Tcl object with the result.
1.5316 + */
1.5317 + if (valuePtr->typePtr == &tclIntType) {
1.5318 + i = valuePtr->internalRep.longValue;
1.5319 + if (i < 0) {
1.5320 + if (i == LONG_MIN) {
1.5321 +#ifdef TCL_WIDE_INT_IS_LONG
1.5322 + Tcl_SetObjResult(interp, Tcl_NewStringObj(
1.5323 + "integer value too large to represent", -1));
1.5324 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
1.5325 + "integer value too large to represent", (char *) NULL);
1.5326 + result = TCL_ERROR;
1.5327 + goto done;
1.5328 +#else
1.5329 + /*
1.5330 + * Special case: abs(MIN_INT) must promote to wide.
1.5331 + */
1.5332 +
1.5333 + PUSH_OBJECT( Tcl_NewWideIntObj(-(Tcl_WideInt) i) );
1.5334 + result = TCL_OK;
1.5335 + goto done;
1.5336 +#endif
1.5337 +
1.5338 + }
1.5339 + iResult = -i;
1.5340 + } else {
1.5341 + iResult = i;
1.5342 + }
1.5343 + PUSH_OBJECT(Tcl_NewLongObj(iResult));
1.5344 + } else if (valuePtr->typePtr == &tclWideIntType) {
1.5345 + Tcl_WideInt wResult, w;
1.5346 + TclGetWide(w,valuePtr);
1.5347 + if (w < W0) {
1.5348 + wResult = -w;
1.5349 + if (wResult < 0) {
1.5350 + Tcl_ResetResult(interp);
1.5351 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.5352 + "integer value too large to represent", -1);
1.5353 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
1.5354 + "integer value too large to represent", (char *) NULL);
1.5355 + result = TCL_ERROR;
1.5356 + goto done;
1.5357 + }
1.5358 + } else {
1.5359 + wResult = w;
1.5360 + }
1.5361 + PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
1.5362 + } else {
1.5363 + d = valuePtr->internalRep.doubleValue;
1.5364 + if (d < 0.0) {
1.5365 + dResult = -d;
1.5366 + } else {
1.5367 + dResult = d;
1.5368 + }
1.5369 + if (IS_NAN(dResult) || IS_INF(dResult)) {
1.5370 + TclExprFloatError(interp, dResult);
1.5371 + result = TCL_ERROR;
1.5372 + goto done;
1.5373 + }
1.5374 + PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
1.5375 + }
1.5376 +
1.5377 + /*
1.5378 + * Reflect the change to stackTop back in eePtr.
1.5379 + */
1.5380 +
1.5381 + done:
1.5382 + TclDecrRefCount(valuePtr);
1.5383 + DECACHE_STACK_INFO();
1.5384 + return result;
1.5385 +}
1.5386 +
1.5387 +static int
1.5388 +ExprDoubleFunc(interp, eePtr, clientData)
1.5389 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5390 + * function. */
1.5391 + ExecEnv *eePtr; /* Points to the environment for executing
1.5392 + * the function. */
1.5393 + ClientData clientData; /* Ignored. */
1.5394 +{
1.5395 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5396 + register int stackTop; /* Cached top index of evaluation stack. */
1.5397 + register Tcl_Obj *valuePtr;
1.5398 + double dResult;
1.5399 + int result;
1.5400 +
1.5401 + /*
1.5402 + * Set stackPtr and stackTop from eePtr.
1.5403 + */
1.5404 +
1.5405 + result = TCL_OK;
1.5406 + CACHE_STACK_INFO();
1.5407 +
1.5408 + /*
1.5409 + * Pop the argument from the evaluation stack.
1.5410 + */
1.5411 +
1.5412 + valuePtr = POP_OBJECT();
1.5413 +
1.5414 + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
1.5415 + result = TCL_ERROR;
1.5416 + goto done;
1.5417 + }
1.5418 +
1.5419 + GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);
1.5420 +
1.5421 + /*
1.5422 + * Push a Tcl object with the result.
1.5423 + */
1.5424 +
1.5425 + PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
1.5426 +
1.5427 + /*
1.5428 + * Reflect the change to stackTop back in eePtr.
1.5429 + */
1.5430 +
1.5431 + done:
1.5432 + TclDecrRefCount(valuePtr);
1.5433 + DECACHE_STACK_INFO();
1.5434 + return result;
1.5435 +}
1.5436 +
1.5437 +static int
1.5438 +ExprIntFunc(interp, eePtr, clientData)
1.5439 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5440 + * function. */
1.5441 + ExecEnv *eePtr; /* Points to the environment for executing
1.5442 + * the function. */
1.5443 + ClientData clientData; /* Ignored. */
1.5444 +{
1.5445 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5446 + register int stackTop; /* Cached top index of evaluation stack. */
1.5447 + register Tcl_Obj *valuePtr;
1.5448 + long iResult;
1.5449 + double d;
1.5450 + int result;
1.5451 +
1.5452 + /*
1.5453 + * Set stackPtr and stackTop from eePtr.
1.5454 + */
1.5455 +
1.5456 + result = TCL_OK;
1.5457 + CACHE_STACK_INFO();
1.5458 +
1.5459 + /*
1.5460 + * Pop the argument from the evaluation stack.
1.5461 + */
1.5462 +
1.5463 + valuePtr = POP_OBJECT();
1.5464 +
1.5465 + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
1.5466 + result = TCL_ERROR;
1.5467 + goto done;
1.5468 + }
1.5469 +
1.5470 + if (valuePtr->typePtr == &tclIntType) {
1.5471 + iResult = valuePtr->internalRep.longValue;
1.5472 + } else if (valuePtr->typePtr == &tclWideIntType) {
1.5473 + TclGetLongFromWide(iResult,valuePtr);
1.5474 + } else {
1.5475 + d = valuePtr->internalRep.doubleValue;
1.5476 + if (d < 0.0) {
1.5477 + if (d < (double) (long) LONG_MIN) {
1.5478 + tooLarge:
1.5479 + Tcl_ResetResult(interp);
1.5480 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.5481 + "integer value too large to represent", -1);
1.5482 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
1.5483 + "integer value too large to represent", (char *) NULL);
1.5484 + result = TCL_ERROR;
1.5485 + goto done;
1.5486 + }
1.5487 + } else {
1.5488 + if (d > (double) LONG_MAX) {
1.5489 + goto tooLarge;
1.5490 + }
1.5491 + }
1.5492 + if (IS_NAN(d) || IS_INF(d)) {
1.5493 + TclExprFloatError(interp, d);
1.5494 + result = TCL_ERROR;
1.5495 + goto done;
1.5496 + }
1.5497 + iResult = (long) d;
1.5498 + }
1.5499 +
1.5500 + /*
1.5501 + * Push a Tcl object with the result.
1.5502 + */
1.5503 +
1.5504 + PUSH_OBJECT(Tcl_NewLongObj(iResult));
1.5505 +
1.5506 + /*
1.5507 + * Reflect the change to stackTop back in eePtr.
1.5508 + */
1.5509 +
1.5510 + done:
1.5511 + TclDecrRefCount(valuePtr);
1.5512 + DECACHE_STACK_INFO();
1.5513 + return result;
1.5514 +}
1.5515 +
1.5516 +static int
1.5517 +ExprWideFunc(interp, eePtr, clientData)
1.5518 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5519 + * function. */
1.5520 + ExecEnv *eePtr; /* Points to the environment for executing
1.5521 + * the function. */
1.5522 + ClientData clientData; /* Ignored. */
1.5523 +{
1.5524 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5525 + register int stackTop; /* Cached top index of evaluation stack. */
1.5526 + register Tcl_Obj *valuePtr;
1.5527 + Tcl_WideInt wResult;
1.5528 + double d;
1.5529 + int result;
1.5530 +
1.5531 + /*
1.5532 + * Set stackPtr and stackTop from eePtr.
1.5533 + */
1.5534 +
1.5535 + result = TCL_OK;
1.5536 + CACHE_STACK_INFO();
1.5537 +
1.5538 + /*
1.5539 + * Pop the argument from the evaluation stack.
1.5540 + */
1.5541 +
1.5542 + valuePtr = POP_OBJECT();
1.5543 +
1.5544 + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
1.5545 + result = TCL_ERROR;
1.5546 + goto done;
1.5547 + }
1.5548 +
1.5549 + if (valuePtr->typePtr == &tclWideIntType) {
1.5550 + TclGetWide(wResult,valuePtr);
1.5551 + } else if (valuePtr->typePtr == &tclIntType) {
1.5552 + wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
1.5553 + } else {
1.5554 + d = valuePtr->internalRep.doubleValue;
1.5555 + if (d < 0.0) {
1.5556 + if (d < Tcl_WideAsDouble(LLONG_MIN)) {
1.5557 + tooLarge:
1.5558 + Tcl_ResetResult(interp);
1.5559 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.5560 + "integer value too large to represent", -1);
1.5561 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
1.5562 + "integer value too large to represent", (char *) NULL);
1.5563 + result = TCL_ERROR;
1.5564 + goto done;
1.5565 + }
1.5566 + } else {
1.5567 + if (d > Tcl_WideAsDouble(LLONG_MAX)) {
1.5568 + goto tooLarge;
1.5569 + }
1.5570 + }
1.5571 + if (IS_NAN(d) || IS_INF(d)) {
1.5572 + TclExprFloatError(interp, d);
1.5573 + result = TCL_ERROR;
1.5574 + goto done;
1.5575 + }
1.5576 + wResult = Tcl_DoubleAsWide(d);
1.5577 + }
1.5578 +
1.5579 + /*
1.5580 + * Push a Tcl object with the result.
1.5581 + */
1.5582 +
1.5583 + PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
1.5584 +
1.5585 + /*
1.5586 + * Reflect the change to stackTop back in eePtr.
1.5587 + */
1.5588 +
1.5589 + done:
1.5590 + TclDecrRefCount(valuePtr);
1.5591 + DECACHE_STACK_INFO();
1.5592 + return result;
1.5593 +}
1.5594 +
1.5595 +static int
1.5596 +ExprRandFunc(interp, eePtr, clientData)
1.5597 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5598 + * function. */
1.5599 + ExecEnv *eePtr; /* Points to the environment for executing
1.5600 + * the function. */
1.5601 + ClientData clientData; /* Ignored. */
1.5602 +{
1.5603 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5604 + register int stackTop; /* Cached top index of evaluation stack. */
1.5605 + Interp *iPtr = (Interp *) interp;
1.5606 + double dResult;
1.5607 + long tmp; /* Algorithm assumes at least 32 bits.
1.5608 + * Only long guarantees that. See below. */
1.5609 +
1.5610 + if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
1.5611 + iPtr->flags |= RAND_SEED_INITIALIZED;
1.5612 +
1.5613 + /*
1.5614 + * Take into consideration the thread this interp is running in order
1.5615 + * to insure different seeds in different threads (bug #416643)
1.5616 + */
1.5617 +
1.5618 + iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
1.5619 +
1.5620 + /*
1.5621 + * Make sure 1 <= randSeed <= (2^31) - 2. See below.
1.5622 + */
1.5623 +
1.5624 + iPtr->randSeed &= (unsigned long) 0x7fffffff;
1.5625 + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
1.5626 + iPtr->randSeed ^= 123459876;
1.5627 + }
1.5628 + }
1.5629 +
1.5630 + /*
1.5631 + * Set stackPtr and stackTop from eePtr.
1.5632 + */
1.5633 +
1.5634 + CACHE_STACK_INFO();
1.5635 +
1.5636 + /*
1.5637 + * Generate the random number using the linear congruential
1.5638 + * generator defined by the following recurrence:
1.5639 + * seed = ( IA * seed ) mod IM
1.5640 + * where IA is 16807 and IM is (2^31) - 1. The recurrence maps
1.5641 + * a seed in the range [1, IM - 1] to a new seed in that same range.
1.5642 + * The recurrence maps IM to 0, and maps 0 back to 0, so those two
1.5643 + * values must not be allowed as initial values of seed.
1.5644 + *
1.5645 + * In order to avoid potential problems with integer overflow, the
1.5646 + * recurrence is implemented in terms of additional constants
1.5647 + * IQ and IR such that
1.5648 + * IM = IA*IQ + IR
1.5649 + * None of the operations in the implementation overflows a 32-bit
1.5650 + * signed integer, and the C type long is guaranteed to be at least
1.5651 + * 32 bits wide.
1.5652 + *
1.5653 + * For more details on how this algorithm works, refer to the following
1.5654 + * papers:
1.5655 + *
1.5656 + * S.K. Park & K.W. Miller, "Random number generators: good ones
1.5657 + * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
1.5658 + *
1.5659 + * W.H. Press & S.A. Teukolsky, "Portable random number
1.5660 + * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
1.5661 + */
1.5662 +
1.5663 +#define RAND_IA 16807
1.5664 +#define RAND_IM 2147483647
1.5665 +#define RAND_IQ 127773
1.5666 +#define RAND_IR 2836
1.5667 +#define RAND_MASK 123459876
1.5668 +
1.5669 + tmp = iPtr->randSeed/RAND_IQ;
1.5670 + iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
1.5671 + if (iPtr->randSeed < 0) {
1.5672 + iPtr->randSeed += RAND_IM;
1.5673 + }
1.5674 +
1.5675 + /*
1.5676 + * Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
1.5677 + * dividing by RAND_IM yields a double in the range (0, 1).
1.5678 + */
1.5679 +
1.5680 + dResult = iPtr->randSeed * (1.0/RAND_IM);
1.5681 +
1.5682 + /*
1.5683 + * Push a Tcl object with the result.
1.5684 + */
1.5685 +
1.5686 + PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
1.5687 +
1.5688 + /*
1.5689 + * Reflect the change to stackTop back in eePtr.
1.5690 + */
1.5691 +
1.5692 + DECACHE_STACK_INFO();
1.5693 + return TCL_OK;
1.5694 +}
1.5695 +
1.5696 +static int
1.5697 +ExprRoundFunc(interp, eePtr, clientData)
1.5698 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5699 + * function. */
1.5700 + ExecEnv *eePtr; /* Points to the environment for executing
1.5701 + * the function. */
1.5702 + ClientData clientData; /* Ignored. */
1.5703 +{
1.5704 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5705 + register int stackTop; /* Cached top index of evaluation stack. */
1.5706 + Tcl_Obj *valuePtr, *resPtr;
1.5707 + double d, f, i;
1.5708 + int result;
1.5709 +
1.5710 + /*
1.5711 + * Set stackPtr and stackTop from eePtr.
1.5712 + */
1.5713 +
1.5714 + result = TCL_OK;
1.5715 + CACHE_STACK_INFO();
1.5716 +
1.5717 + /*
1.5718 + * Pop the argument from the evaluation stack.
1.5719 + */
1.5720 +
1.5721 + valuePtr = POP_OBJECT();
1.5722 +
1.5723 + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
1.5724 + result = TCL_ERROR;
1.5725 + goto done;
1.5726 + }
1.5727 +
1.5728 + if ((valuePtr->typePtr == &tclIntType) ||
1.5729 + (valuePtr->typePtr == &tclWideIntType)) {
1.5730 + result = TCL_OK;
1.5731 + resPtr = valuePtr;
1.5732 + } else {
1.5733 +
1.5734 + /*
1.5735 + * Round the number to the nearest integer. I'd like to use round(),
1.5736 + * but it's C99 (or BSD), and not yet universal.
1.5737 + */
1.5738 +
1.5739 + d = valuePtr->internalRep.doubleValue;
1.5740 + f = modf(d, &i);
1.5741 + if (d < 0.0) {
1.5742 + if (f <= -0.5) {
1.5743 + i += -1.0;
1.5744 + }
1.5745 + if (i <= Tcl_WideAsDouble(LLONG_MIN)) {
1.5746 + goto tooLarge;
1.5747 + } else if (i <= (double) LONG_MIN) {
1.5748 + resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
1.5749 + } else {
1.5750 + resPtr = Tcl_NewLongObj((long) i);
1.5751 + }
1.5752 + } else {
1.5753 + if (f >= 0.5) {
1.5754 + i += 1.0;
1.5755 + }
1.5756 + if (i >= Tcl_WideAsDouble(LLONG_MAX)) {
1.5757 + goto tooLarge;
1.5758 + } else if (i >= (double) LONG_MAX) {
1.5759 + resPtr = Tcl_NewWideIntObj(Tcl_DoubleAsWide(i));
1.5760 + } else {
1.5761 + resPtr = Tcl_NewLongObj((long) i);
1.5762 + }
1.5763 + }
1.5764 + }
1.5765 +
1.5766 + /*
1.5767 + * Push the result object and free the argument Tcl_Obj.
1.5768 + */
1.5769 +
1.5770 + PUSH_OBJECT(resPtr);
1.5771 +
1.5772 + done:
1.5773 + TclDecrRefCount(valuePtr);
1.5774 + DECACHE_STACK_INFO();
1.5775 + return result;
1.5776 +
1.5777 + /*
1.5778 + * Error return: result cannot be represented as an integer.
1.5779 + */
1.5780 +
1.5781 + tooLarge:
1.5782 + Tcl_ResetResult(interp);
1.5783 + Tcl_AppendToObj(Tcl_GetObjResult(interp),
1.5784 + "integer value too large to represent", -1);
1.5785 + Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
1.5786 + "integer value too large to represent",
1.5787 + (char *) NULL);
1.5788 + result = TCL_ERROR;
1.5789 + goto done;
1.5790 +}
1.5791 +
1.5792 +static int
1.5793 +ExprSrandFunc(interp, eePtr, clientData)
1.5794 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5795 + * function. */
1.5796 + ExecEnv *eePtr; /* Points to the environment for executing
1.5797 + * the function. */
1.5798 + ClientData clientData; /* Ignored. */
1.5799 +{
1.5800 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5801 + register int stackTop; /* Cached top index of evaluation stack. */
1.5802 + Interp *iPtr = (Interp *) interp;
1.5803 + Tcl_Obj *valuePtr;
1.5804 + long i = 0; /* Initialized to avoid compiler warning. */
1.5805 +
1.5806 + /*
1.5807 + * Set stackPtr and stackTop from eePtr.
1.5808 + */
1.5809 +
1.5810 + CACHE_STACK_INFO();
1.5811 +
1.5812 + /*
1.5813 + * Pop the argument from the evaluation stack. Use the value
1.5814 + * to reset the random number seed.
1.5815 + */
1.5816 +
1.5817 + valuePtr = POP_OBJECT();
1.5818 +
1.5819 + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
1.5820 + goto badValue;
1.5821 + }
1.5822 +
1.5823 + if (Tcl_GetLongFromObj(NULL, valuePtr, &i) != TCL_OK) {
1.5824 + Tcl_WideInt w;
1.5825 +
1.5826 + if (Tcl_GetWideIntFromObj(interp, valuePtr, &w) != TCL_OK) {
1.5827 + badValue:
1.5828 + Tcl_AddErrorInfo(interp, "\n (argument to \"srand()\")");
1.5829 + TclDecrRefCount(valuePtr);
1.5830 + DECACHE_STACK_INFO();
1.5831 + return TCL_ERROR;
1.5832 + }
1.5833 +
1.5834 + i = Tcl_WideAsLong(w);
1.5835 + }
1.5836 +
1.5837 + /*
1.5838 + * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
1.5839 + * See comments in ExprRandFunc() for more details.
1.5840 + */
1.5841 +
1.5842 + iPtr->flags |= RAND_SEED_INITIALIZED;
1.5843 + iPtr->randSeed = i;
1.5844 + iPtr->randSeed &= (unsigned long) 0x7fffffff;
1.5845 + if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
1.5846 + iPtr->randSeed ^= 123459876;
1.5847 + }
1.5848 +
1.5849 + /*
1.5850 + * To avoid duplicating the random number generation code we simply
1.5851 + * clean up our state and call the real random number function. That
1.5852 + * function will always succeed.
1.5853 + */
1.5854 +
1.5855 + TclDecrRefCount(valuePtr);
1.5856 + DECACHE_STACK_INFO();
1.5857 +
1.5858 + ExprRandFunc(interp, eePtr, clientData);
1.5859 + return TCL_OK;
1.5860 +}
1.5861 +
1.5862 +/*
1.5863 + *----------------------------------------------------------------------
1.5864 + *
1.5865 + * ExprCallMathFunc --
1.5866 + *
1.5867 + * This procedure is invoked to call a non-builtin math function
1.5868 + * during the execution of an expression.
1.5869 + *
1.5870 + * Results:
1.5871 + * TCL_OK is returned if all went well and the function's value
1.5872 + * was computed successfully. If an error occurred, TCL_ERROR
1.5873 + * is returned and an error message is left in the interpreter's
1.5874 + * result. After a successful return this procedure pushes a Tcl object
1.5875 + * holding the result.
1.5876 + *
1.5877 + * Side effects:
1.5878 + * None, unless the called math function has side effects.
1.5879 + *
1.5880 + *----------------------------------------------------------------------
1.5881 + */
1.5882 +
1.5883 +static int
1.5884 +ExprCallMathFunc(interp, eePtr, objc, objv)
1.5885 + Tcl_Interp *interp; /* The interpreter in which to execute the
1.5886 + * function. */
1.5887 + ExecEnv *eePtr; /* Points to the environment for executing
1.5888 + * the function. */
1.5889 + int objc; /* Number of arguments. The function name is
1.5890 + * the 0-th argument. */
1.5891 + Tcl_Obj **objv; /* The array of arguments. The function name
1.5892 + * is objv[0]. */
1.5893 +{
1.5894 + Interp *iPtr = (Interp *) interp;
1.5895 + Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
1.5896 + register int stackTop; /* Cached top index of evaluation stack. */
1.5897 + char *funcName;
1.5898 + Tcl_HashEntry *hPtr;
1.5899 + MathFunc *mathFuncPtr; /* Information about math function. */
1.5900 + Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
1.5901 + Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
1.5902 + register Tcl_Obj *valuePtr;
1.5903 + long i;
1.5904 + double d;
1.5905 + int j, k, result;
1.5906 +
1.5907 + Tcl_ResetResult(interp);
1.5908 +
1.5909 + /*
1.5910 + * Set stackPtr and stackTop from eePtr.
1.5911 + */
1.5912 +
1.5913 + CACHE_STACK_INFO();
1.5914 +
1.5915 + /*
1.5916 + * Look up the MathFunc record for the function.
1.5917 + */
1.5918 +
1.5919 + funcName = TclGetString(objv[0]);
1.5920 + hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
1.5921 + if (hPtr == NULL) {
1.5922 + Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
1.5923 + "unknown math function \"", funcName, "\"", (char *) NULL);
1.5924 + result = TCL_ERROR;
1.5925 + goto done;
1.5926 + }
1.5927 + mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
1.5928 + if (mathFuncPtr->numArgs != (objc-1)) {
1.5929 + panic("ExprCallMathFunc: expected number of args %d != actual number %d",
1.5930 + mathFuncPtr->numArgs, objc);
1.5931 + result = TCL_ERROR;
1.5932 + goto done;
1.5933 + }
1.5934 +
1.5935 + /*
1.5936 + * Collect the arguments for the function, if there are any, into the
1.5937 + * array "args". Note that args[0] will have the Tcl_Value that
1.5938 + * corresponds to objv[1].
1.5939 + */
1.5940 +
1.5941 + for (j = 1, k = 0; j < objc; j++, k++) {
1.5942 + valuePtr = objv[j];
1.5943 +
1.5944 + if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
1.5945 + result = TCL_ERROR;
1.5946 + goto done;
1.5947 + }
1.5948 +
1.5949 + /*
1.5950 + * Copy the object's numeric value to the argument record,
1.5951 + * converting it if necessary.
1.5952 + */
1.5953 +
1.5954 + if (valuePtr->typePtr == &tclIntType) {
1.5955 + i = valuePtr->internalRep.longValue;
1.5956 + if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
1.5957 + args[k].type = TCL_DOUBLE;
1.5958 + args[k].doubleValue = i;
1.5959 + } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
1.5960 + args[k].type = TCL_WIDE_INT;
1.5961 + args[k].wideValue = Tcl_LongAsWide(i);
1.5962 + } else {
1.5963 + args[k].type = TCL_INT;
1.5964 + args[k].intValue = i;
1.5965 + }
1.5966 + } else if (valuePtr->typePtr == &tclWideIntType) {
1.5967 + Tcl_WideInt w;
1.5968 + TclGetWide(w,valuePtr);
1.5969 + if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
1.5970 + args[k].type = TCL_DOUBLE;
1.5971 + args[k].doubleValue = Tcl_WideAsDouble(w);
1.5972 + } else if (mathFuncPtr->argTypes[k] == TCL_INT) {
1.5973 + args[k].type = TCL_INT;
1.5974 + args[k].intValue = Tcl_WideAsLong(w);
1.5975 + } else {
1.5976 + args[k].type = TCL_WIDE_INT;
1.5977 + args[k].wideValue = w;
1.5978 + }
1.5979 + } else {
1.5980 + d = valuePtr->internalRep.doubleValue;
1.5981 + if (mathFuncPtr->argTypes[k] == TCL_INT) {
1.5982 + args[k].type = TCL_INT;
1.5983 + args[k].intValue = (long) d;
1.5984 + } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
1.5985 + args[k].type = TCL_WIDE_INT;
1.5986 + args[k].wideValue = Tcl_DoubleAsWide(d);
1.5987 + } else {
1.5988 + args[k].type = TCL_DOUBLE;
1.5989 + args[k].doubleValue = d;
1.5990 + }
1.5991 + }
1.5992 + }
1.5993 +
1.5994 + /*
1.5995 + * Invoke the function and copy its result back into valuePtr.
1.5996 + */
1.5997 +
1.5998 + result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
1.5999 + &funcResult);
1.6000 + if (result != TCL_OK) {
1.6001 + goto done;
1.6002 + }
1.6003 +
1.6004 + /*
1.6005 + * Pop the objc top stack elements and decrement their ref counts.
1.6006 + */
1.6007 +
1.6008 + k = (stackTop - (objc-1));
1.6009 + while (stackTop >= k) {
1.6010 + valuePtr = POP_OBJECT();
1.6011 + TclDecrRefCount(valuePtr);
1.6012 + }
1.6013 +
1.6014 + /*
1.6015 + * Push the call's object result.
1.6016 + */
1.6017 +
1.6018 + if (funcResult.type == TCL_INT) {
1.6019 + PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
1.6020 + } else if (funcResult.type == TCL_WIDE_INT) {
1.6021 + PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
1.6022 + } else {
1.6023 + d = funcResult.doubleValue;
1.6024 + if (IS_NAN(d) || IS_INF(d)) {
1.6025 + TclExprFloatError(interp, d);
1.6026 + result = TCL_ERROR;
1.6027 + goto done;
1.6028 + }
1.6029 + PUSH_OBJECT(Tcl_NewDoubleObj(d));
1.6030 + }
1.6031 +
1.6032 + /*
1.6033 + * Reflect the change to stackTop back in eePtr.
1.6034 + */
1.6035 +
1.6036 + done:
1.6037 + DECACHE_STACK_INFO();
1.6038 + return result;
1.6039 +}
1.6040 +
1.6041 +/*
1.6042 + *----------------------------------------------------------------------
1.6043 + *
1.6044 + * TclExprFloatError --
1.6045 + *
1.6046 + * This procedure is called when an error occurs during a
1.6047 + * floating-point operation. It reads errno and sets
1.6048 + * interp->objResultPtr accordingly.
1.6049 + *
1.6050 + * Results:
1.6051 + * interp->objResultPtr is set to hold an error message.
1.6052 + *
1.6053 + * Side effects:
1.6054 + * None.
1.6055 + *
1.6056 + *----------------------------------------------------------------------
1.6057 + */
1.6058 +
1.6059 +void
1.6060 +TclExprFloatError(interp, value)
1.6061 + Tcl_Interp *interp; /* Where to store error message. */
1.6062 + double value; /* Value returned after error; used to
1.6063 + * distinguish underflows from overflows. */
1.6064 +{
1.6065 + char *s;
1.6066 +
1.6067 + Tcl_ResetResult(interp);
1.6068 + if ((errno == EDOM) || IS_NAN(value)) {
1.6069 + s = "domain error: argument not in valid range";
1.6070 + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
1.6071 + Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
1.6072 + } else if ((errno == ERANGE) || IS_INF(value)) {
1.6073 + if (value == 0.0) {
1.6074 + s = "floating-point value too small to represent";
1.6075 + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
1.6076 + Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
1.6077 + } else {
1.6078 + s = "floating-point value too large to represent";
1.6079 + Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
1.6080 + Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
1.6081 + }
1.6082 + } else {
1.6083 + char msg[64 + TCL_INTEGER_SPACE];
1.6084 +
1.6085 + sprintf(msg, "unknown floating-point error, errno = %d", errno);
1.6086 + Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
1.6087 + Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
1.6088 + }
1.6089 +}
1.6090 +
1.6091 +#ifdef TCL_COMPILE_STATS
1.6092 +/*
1.6093 + *----------------------------------------------------------------------
1.6094 + *
1.6095 + * TclLog2 --
1.6096 + *
1.6097 + * Procedure used while collecting compilation statistics to determine
1.6098 + * the log base 2 of an integer.
1.6099 + *
1.6100 + * Results:
1.6101 + * Returns the log base 2 of the operand. If the argument is less
1.6102 + * than or equal to zero, a zero is returned.
1.6103 + *
1.6104 + * Side effects:
1.6105 + * None.
1.6106 + *
1.6107 + *----------------------------------------------------------------------
1.6108 + */
1.6109 +
1.6110 +int
1.6111 +TclLog2(value)
1.6112 + register int value; /* The integer for which to compute the
1.6113 + * log base 2. */
1.6114 +{
1.6115 + register int n = value;
1.6116 + register int result = 0;
1.6117 +
1.6118 + while (n > 1) {
1.6119 + n = n >> 1;
1.6120 + result++;
1.6121 + }
1.6122 + return result;
1.6123 +}
1.6124 +
1.6125 +/*
1.6126 + *----------------------------------------------------------------------
1.6127 + *
1.6128 + * EvalStatsCmd --
1.6129 + *
1.6130 + * Implements the "evalstats" command that prints instruction execution
1.6131 + * counts to stdout.
1.6132 + *
1.6133 + * Results:
1.6134 + * Standard Tcl results.
1.6135 + *
1.6136 + * Side effects:
1.6137 + * None.
1.6138 + *
1.6139 + *----------------------------------------------------------------------
1.6140 + */
1.6141 +
1.6142 +static int
1.6143 +EvalStatsCmd(unused, interp, objc, objv)
1.6144 + ClientData unused; /* Unused. */
1.6145 + Tcl_Interp *interp; /* The current interpreter. */
1.6146 + int objc; /* The number of arguments. */
1.6147 + Tcl_Obj *CONST objv[]; /* The argument strings. */
1.6148 +{
1.6149 + Interp *iPtr = (Interp *) interp;
1.6150 + LiteralTable *globalTablePtr = &(iPtr->literalTable);
1.6151 + ByteCodeStats *statsPtr = &(iPtr->stats);
1.6152 + double totalCodeBytes, currentCodeBytes;
1.6153 + double totalLiteralBytes, currentLiteralBytes;
1.6154 + double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
1.6155 + double strBytesSharedMultX, strBytesSharedOnce;
1.6156 + double numInstructions, currentHeaderBytes;
1.6157 + long numCurrentByteCodes, numByteCodeLits;
1.6158 + long refCountSum, literalMgmtBytes, sum;
1.6159 + int numSharedMultX, numSharedOnce;
1.6160 + int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
1.6161 + char *litTableStats;
1.6162 + LiteralEntry *entryPtr;
1.6163 +
1.6164 + numInstructions = 0.0;
1.6165 + for (i = 0; i < 256; i++) {
1.6166 + if (statsPtr->instructionCount[i] != 0) {
1.6167 + numInstructions += statsPtr->instructionCount[i];
1.6168 + }
1.6169 + }
1.6170 +
1.6171 + totalLiteralBytes = sizeof(LiteralTable)
1.6172 + + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
1.6173 + + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
1.6174 + + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
1.6175 + + statsPtr->totalLitStringBytes;
1.6176 + totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
1.6177 +
1.6178 + numCurrentByteCodes =
1.6179 + statsPtr->numCompilations - statsPtr->numByteCodesFreed;
1.6180 + currentHeaderBytes = numCurrentByteCodes
1.6181 + * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
1.6182 + literalMgmtBytes = sizeof(LiteralTable)
1.6183 + + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
1.6184 + + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
1.6185 + currentLiteralBytes = literalMgmtBytes
1.6186 + + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
1.6187 + + statsPtr->currentLitStringBytes;
1.6188 + currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
1.6189 +
1.6190 + /*
1.6191 + * Summary statistics, total and current source and ByteCode sizes.
1.6192 + */
1.6193 +
1.6194 + fprintf(stdout, "\n----------------------------------------------------------------\n");
1.6195 + fprintf(stdout,
1.6196 + "Compilation and execution statistics for interpreter 0x%x\n",
1.6197 + (unsigned int) iPtr);
1.6198 +
1.6199 + fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
1.6200 + statsPtr->numExecutions);
1.6201 + fprintf(stdout, "Number ByteCodes compiled %ld\n",
1.6202 + statsPtr->numCompilations);
1.6203 + fprintf(stdout, " Mean executions/compile %.1f\n",
1.6204 + ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
1.6205 +
1.6206 + fprintf(stdout, "\nInstructions executed %.0f\n",
1.6207 + numInstructions);
1.6208 + fprintf(stdout, " Mean inst/compile %.0f\n",
1.6209 + numInstructions / statsPtr->numCompilations);
1.6210 + fprintf(stdout, " Mean inst/execution %.0f\n",
1.6211 + numInstructions / statsPtr->numExecutions);
1.6212 +
1.6213 + fprintf(stdout, "\nTotal ByteCodes %ld\n",
1.6214 + statsPtr->numCompilations);
1.6215 + fprintf(stdout, " Source bytes %.6g\n",
1.6216 + statsPtr->totalSrcBytes);
1.6217 + fprintf(stdout, " Code bytes %.6g\n",
1.6218 + totalCodeBytes);
1.6219 + fprintf(stdout, " ByteCode bytes %.6g\n",
1.6220 + statsPtr->totalByteCodeBytes);
1.6221 + fprintf(stdout, " Literal bytes %.6g\n",
1.6222 + totalLiteralBytes);
1.6223 + fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
1.6224 + sizeof(LiteralTable),
1.6225 + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
1.6226 + statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
1.6227 + statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
1.6228 + statsPtr->totalLitStringBytes);
1.6229 + fprintf(stdout, " Mean code/compile %.1f\n",
1.6230 + totalCodeBytes / statsPtr->numCompilations);
1.6231 + fprintf(stdout, " Mean code/source %.1f\n",
1.6232 + totalCodeBytes / statsPtr->totalSrcBytes);
1.6233 +
1.6234 + fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n",
1.6235 + numCurrentByteCodes);
1.6236 + fprintf(stdout, " Source bytes %.6g\n",
1.6237 + statsPtr->currentSrcBytes);
1.6238 + fprintf(stdout, " Code bytes %.6g\n",
1.6239 + currentCodeBytes);
1.6240 + fprintf(stdout, " ByteCode bytes %.6g\n",
1.6241 + statsPtr->currentByteCodeBytes);
1.6242 + fprintf(stdout, " Literal bytes %.6g\n",
1.6243 + currentLiteralBytes);
1.6244 + fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
1.6245 + sizeof(LiteralTable),
1.6246 + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
1.6247 + iPtr->literalTable.numEntries * sizeof(LiteralEntry),
1.6248 + iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
1.6249 + statsPtr->currentLitStringBytes);
1.6250 + fprintf(stdout, " Mean code/source %.1f\n",
1.6251 + currentCodeBytes / statsPtr->currentSrcBytes);
1.6252 + fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
1.6253 + (currentCodeBytes + statsPtr->currentSrcBytes),
1.6254 + (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
1.6255 +
1.6256 + /*
1.6257 + * Tcl_IsShared statistics check
1.6258 + *
1.6259 + * This gives the refcount of each obj as Tcl_IsShared was called
1.6260 + * for it. Shared objects must be duplicated before they can be
1.6261 + * modified.
1.6262 + */
1.6263 +
1.6264 + numSharedMultX = 0;
1.6265 + fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
1.6266 + fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n",
1.6267 + tclObjsShared[1]);
1.6268 + for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
1.6269 + fprintf(stdout, " refcount ==%d %ld\n",
1.6270 + i, tclObjsShared[i]);
1.6271 + numSharedMultX += tclObjsShared[i];
1.6272 + }
1.6273 + fprintf(stdout, " refcount >=%d %ld\n",
1.6274 + i, tclObjsShared[0]);
1.6275 + numSharedMultX += tclObjsShared[0];
1.6276 + fprintf(stdout, " Total shared objects %d\n",
1.6277 + numSharedMultX);
1.6278 +
1.6279 + /*
1.6280 + * Literal table statistics.
1.6281 + */
1.6282 +
1.6283 + numByteCodeLits = 0;
1.6284 + refCountSum = 0;
1.6285 + numSharedMultX = 0;
1.6286 + numSharedOnce = 0;
1.6287 + objBytesIfUnshared = 0.0;
1.6288 + strBytesIfUnshared = 0.0;
1.6289 + strBytesSharedMultX = 0.0;
1.6290 + strBytesSharedOnce = 0.0;
1.6291 + for (i = 0; i < globalTablePtr->numBuckets; i++) {
1.6292 + for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
1.6293 + entryPtr = entryPtr->nextPtr) {
1.6294 + if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
1.6295 + numByteCodeLits++;
1.6296 + }
1.6297 + (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
1.6298 + refCountSum += entryPtr->refCount;
1.6299 + objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
1.6300 + strBytesIfUnshared += (entryPtr->refCount * (length+1));
1.6301 + if (entryPtr->refCount > 1) {
1.6302 + numSharedMultX++;
1.6303 + strBytesSharedMultX += (length+1);
1.6304 + } else {
1.6305 + numSharedOnce++;
1.6306 + strBytesSharedOnce += (length+1);
1.6307 + }
1.6308 + }
1.6309 + }
1.6310 + sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
1.6311 + - currentLiteralBytes;
1.6312 +
1.6313 + fprintf(stdout, "\nTotal objects (all interps) %ld\n",
1.6314 + tclObjsAlloced);
1.6315 + fprintf(stdout, "Current objects %ld\n",
1.6316 + (tclObjsAlloced - tclObjsFreed));
1.6317 + fprintf(stdout, "Total literal objects %ld\n",
1.6318 + statsPtr->numLiteralsCreated);
1.6319 +
1.6320 + fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
1.6321 + globalTablePtr->numEntries,
1.6322 + (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
1.6323 + fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
1.6324 + numByteCodeLits,
1.6325 + (numByteCodeLits * 100.0) / globalTablePtr->numEntries);
1.6326 + fprintf(stdout, " Literals reused > 1x %d\n",
1.6327 + numSharedMultX);
1.6328 + fprintf(stdout, " Mean reference count %.2f\n",
1.6329 + ((double) refCountSum) / globalTablePtr->numEntries);
1.6330 + fprintf(stdout, " Mean len, str reused >1x %.2f\n",
1.6331 + (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
1.6332 + fprintf(stdout, " Mean len, str used 1x %.2f\n",
1.6333 + (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
1.6334 + fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
1.6335 + sharingBytesSaved,
1.6336 + (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
1.6337 + fprintf(stdout, " Bytes with sharing %.6g\n",
1.6338 + currentLiteralBytes);
1.6339 + fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
1.6340 + sizeof(LiteralTable),
1.6341 + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
1.6342 + iPtr->literalTable.numEntries * sizeof(LiteralEntry),
1.6343 + iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
1.6344 + statsPtr->currentLitStringBytes);
1.6345 + fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
1.6346 + (objBytesIfUnshared + strBytesIfUnshared),
1.6347 + objBytesIfUnshared, strBytesIfUnshared);
1.6348 + fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
1.6349 + (strBytesIfUnshared - statsPtr->currentLitStringBytes),
1.6350 + strBytesIfUnshared, statsPtr->currentLitStringBytes);
1.6351 + fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
1.6352 + literalMgmtBytes,
1.6353 + (literalMgmtBytes * 100.0) / currentLiteralBytes);
1.6354 + fprintf(stdout, " table %d + buckets %d + entries %d\n",
1.6355 + sizeof(LiteralTable),
1.6356 + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
1.6357 + iPtr->literalTable.numEntries * sizeof(LiteralEntry));
1.6358 +
1.6359 + /*
1.6360 + * Breakdown of current ByteCode space requirements.
1.6361 + */
1.6362 +
1.6363 + fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
1.6364 + fprintf(stdout, " Bytes Pct of Avg per\n");
1.6365 + fprintf(stdout, " total ByteCode\n");
1.6366 + fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
1.6367 + statsPtr->currentByteCodeBytes,
1.6368 + statsPtr->currentByteCodeBytes / numCurrentByteCodes);
1.6369 + fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
1.6370 + currentHeaderBytes,
1.6371 + ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
1.6372 + currentHeaderBytes / numCurrentByteCodes);
1.6373 + fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
1.6374 + statsPtr->currentInstBytes,
1.6375 + ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
1.6376 + statsPtr->currentInstBytes / numCurrentByteCodes);
1.6377 + fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
1.6378 + statsPtr->currentLitBytes,
1.6379 + ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
1.6380 + statsPtr->currentLitBytes / numCurrentByteCodes);
1.6381 + fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
1.6382 + statsPtr->currentExceptBytes,
1.6383 + ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
1.6384 + statsPtr->currentExceptBytes / numCurrentByteCodes);
1.6385 + fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
1.6386 + statsPtr->currentAuxBytes,
1.6387 + ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
1.6388 + statsPtr->currentAuxBytes / numCurrentByteCodes);
1.6389 + fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
1.6390 + statsPtr->currentCmdMapBytes,
1.6391 + ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
1.6392 + statsPtr->currentCmdMapBytes / numCurrentByteCodes);
1.6393 +
1.6394 + /*
1.6395 + * Detailed literal statistics.
1.6396 + */
1.6397 +
1.6398 + fprintf(stdout, "\nLiteral string sizes:\n");
1.6399 + fprintf(stdout, " Up to length Percentage\n");
1.6400 + maxSizeDecade = 0;
1.6401 + for (i = 31; i >= 0; i--) {
1.6402 + if (statsPtr->literalCount[i] > 0) {
1.6403 + maxSizeDecade = i;
1.6404 + break;
1.6405 + }
1.6406 + }
1.6407 + sum = 0;
1.6408 + for (i = 0; i <= maxSizeDecade; i++) {
1.6409 + decadeHigh = (1 << (i+1)) - 1;
1.6410 + sum += statsPtr->literalCount[i];
1.6411 + fprintf(stdout, " %10d %8.0f%%\n",
1.6412 + decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
1.6413 + }
1.6414 +
1.6415 + litTableStats = TclLiteralStats(globalTablePtr);
1.6416 + fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
1.6417 + litTableStats);
1.6418 + ckfree((char *) litTableStats);
1.6419 +
1.6420 + /*
1.6421 + * Source and ByteCode size distributions.
1.6422 + */
1.6423 +
1.6424 + fprintf(stdout, "\nSource sizes:\n");
1.6425 + fprintf(stdout, " Up to size Percentage\n");
1.6426 + minSizeDecade = maxSizeDecade = 0;
1.6427 + for (i = 0; i < 31; i++) {
1.6428 + if (statsPtr->srcCount[i] > 0) {
1.6429 + minSizeDecade = i;
1.6430 + break;
1.6431 + }
1.6432 + }
1.6433 + for (i = 31; i >= 0; i--) {
1.6434 + if (statsPtr->srcCount[i] > 0) {
1.6435 + maxSizeDecade = i;
1.6436 + break;
1.6437 + }
1.6438 + }
1.6439 + sum = 0;
1.6440 + for (i = minSizeDecade; i <= maxSizeDecade; i++) {
1.6441 + decadeHigh = (1 << (i+1)) - 1;
1.6442 + sum += statsPtr->srcCount[i];
1.6443 + fprintf(stdout, " %10d %8.0f%%\n",
1.6444 + decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
1.6445 + }
1.6446 +
1.6447 + fprintf(stdout, "\nByteCode sizes:\n");
1.6448 + fprintf(stdout, " Up to size Percentage\n");
1.6449 + minSizeDecade = maxSizeDecade = 0;
1.6450 + for (i = 0; i < 31; i++) {
1.6451 + if (statsPtr->byteCodeCount[i] > 0) {
1.6452 + minSizeDecade = i;
1.6453 + break;
1.6454 + }
1.6455 + }
1.6456 + for (i = 31; i >= 0; i--) {
1.6457 + if (statsPtr->byteCodeCount[i] > 0) {
1.6458 + maxSizeDecade = i;
1.6459 + break;
1.6460 + }
1.6461 + }
1.6462 + sum = 0;
1.6463 + for (i = minSizeDecade; i <= maxSizeDecade; i++) {
1.6464 + decadeHigh = (1 << (i+1)) - 1;
1.6465 + sum += statsPtr->byteCodeCount[i];
1.6466 + fprintf(stdout, " %10d %8.0f%%\n",
1.6467 + decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
1.6468 + }
1.6469 +
1.6470 + fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
1.6471 + fprintf(stdout, " Up to ms Percentage\n");
1.6472 + minSizeDecade = maxSizeDecade = 0;
1.6473 + for (i = 0; i < 31; i++) {
1.6474 + if (statsPtr->lifetimeCount[i] > 0) {
1.6475 + minSizeDecade = i;
1.6476 + break;
1.6477 + }
1.6478 + }
1.6479 + for (i = 31; i >= 0; i--) {
1.6480 + if (statsPtr->lifetimeCount[i] > 0) {
1.6481 + maxSizeDecade = i;
1.6482 + break;
1.6483 + }
1.6484 + }
1.6485 + sum = 0;
1.6486 + for (i = minSizeDecade; i <= maxSizeDecade; i++) {
1.6487 + decadeHigh = (1 << (i+1)) - 1;
1.6488 + sum += statsPtr->lifetimeCount[i];
1.6489 + fprintf(stdout, " %12.3f %8.0f%%\n",
1.6490 + decadeHigh / 1000.0,
1.6491 + (sum * 100.0) / statsPtr->numByteCodesFreed);
1.6492 + }
1.6493 +
1.6494 + /*
1.6495 + * Instruction counts.
1.6496 + */
1.6497 +
1.6498 + fprintf(stdout, "\nInstruction counts:\n");
1.6499 + for (i = 0; i <= LAST_INST_OPCODE; i++) {
1.6500 + if (statsPtr->instructionCount[i]) {
1.6501 + fprintf(stdout, "%20s %8ld %6.1f%%\n",
1.6502 + tclInstructionTable[i].name,
1.6503 + statsPtr->instructionCount[i],
1.6504 + (statsPtr->instructionCount[i]*100.0) / numInstructions);
1.6505 + }
1.6506 + }
1.6507 +
1.6508 + fprintf(stdout, "\nInstructions NEVER executed:\n");
1.6509 + for (i = 0; i <= LAST_INST_OPCODE; i++) {
1.6510 + if (statsPtr->instructionCount[i] == 0) {
1.6511 + fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
1.6512 + }
1.6513 + }
1.6514 +
1.6515 +#ifdef TCL_MEM_DEBUG
1.6516 + fprintf(stdout, "\nHeap Statistics:\n");
1.6517 + TclDumpMemoryInfo(stdout);
1.6518 +#endif
1.6519 + fprintf(stdout, "\n----------------------------------------------------------------\n");
1.6520 + return TCL_OK;
1.6521 +}
1.6522 +#endif /* TCL_COMPILE_STATS */
1.6523 +
1.6524 +#ifdef TCL_COMPILE_DEBUG
1.6525 +/*
1.6526 + *----------------------------------------------------------------------
1.6527 + *
1.6528 + * StringForResultCode --
1.6529 + *
1.6530 + * Procedure that returns a human-readable string representing a
1.6531 + * Tcl result code such as TCL_ERROR.
1.6532 + *
1.6533 + * Results:
1.6534 + * If the result code is one of the standard Tcl return codes, the
1.6535 + * result is a string representing that code such as "TCL_ERROR".
1.6536 + * Otherwise, the result string is that code formatted as a
1.6537 + * sequence of decimal digit characters. Note that the resulting
1.6538 + * string must not be modified by the caller.
1.6539 + *
1.6540 + * Side effects:
1.6541 + * None.
1.6542 + *
1.6543 + *----------------------------------------------------------------------
1.6544 + */
1.6545 +
1.6546 +static char *
1.6547 +StringForResultCode(result)
1.6548 + int result; /* The Tcl result code for which to
1.6549 + * generate a string. */
1.6550 +{
1.6551 + static char buf[TCL_INTEGER_SPACE];
1.6552 +
1.6553 + if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
1.6554 + return resultStrings[result];
1.6555 + }
1.6556 + TclFormatInt(buf, result);
1.6557 + return buf;
1.6558 +}
1.6559 +#endif /* TCL_COMPILE_DEBUG */
1.6560 +
1.6561 +/*
1.6562 + * Local Variables:
1.6563 + * mode: c
1.6564 + * c-basic-offset: 4
1.6565 + * fill-column: 78
1.6566 + * End:
1.6567 + */
1.6568 +