tcl/generic/tclExecute.c

   1 /*
   2  * tclExecute.c --
   3  *
   4  *      This file contains procedures that execute byte-compiled Tcl
   5  *      commands.
   6  *
   7  * Copyright (c) 1996-1997 Sun Microsystems, Inc.
   8  *
   9  * See the file "license.terms" for information on usage and redistribution
  10  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  11  *
  12  * RCS: @(#) $Id$
  13  */
  14
  15 #include "tclInt.h"
  16 #include "tclCompile.h"
  17
  18 #ifdef NO_FLOAT_H
  19 #   include "../compat/float.h"
  20 #else
  21 #   include <float.h>
  22 #endif
  23 #ifndef TCL_NO_MATH
  24 #include "tclMath.h"
  25 #endif
  26
  27 /*
  28  * The stuff below is a bit of a hack so that this file can be used
  29  * in environments that include no UNIX, i.e. no errno.  Just define
  30  * errno here.
  31  */
  32
  33 #ifndef TCL_GENERIC_ONLY
  34 #include "tclPort.h"
  35 #else
  36 #define NO_ERRNO_H
  37 #endif
  38
  39 #ifdef NO_ERRNO_H
  40 int errno;
  41 #define EDOM 33
  42 #define ERANGE 34
  43 #endif
  44
  45 /*
  46  * Boolean flag indicating whether the Tcl bytecode interpreter has been
  47  * initialized.
  48  */
  49
  50 static int execInitialized = 0;
  51 TCL_DECLARE_MUTEX(execMutex)
  52
  53 /*
  54  * Variable that controls whether execution tracing is enabled and, if so,
  55  * what level of tracing is desired:
  56  *    0: no execution tracing
  57  *    1: trace invocations of Tcl procs only
  58  *    2: trace invocations of all (not compiled away) commands
  59  *    3: display each instruction executed
  60  * This variable is linked to the Tcl variable "tcl_traceExec".
  61  */
  62
  63 int tclTraceExec = 0;
  64
  65 typedef struct ThreadSpecificData {
  66     /*
  67      * The following global variable is use to signal matherr that Tcl
  68      * is responsible for the arithmetic, so errors can be handled in a
  69      * fashion appropriate for Tcl.  Zero means no Tcl math is in
  70      * progress;  non-zero means Tcl is doing math.
  71      */
  72
  73     int mathInProgress;
  74
  75 } ThreadSpecificData;
  76
  77 static Tcl_ThreadDataKey dataKey;
  78
  79 /*
  80  * The variable below serves no useful purpose except to generate
  81  * a reference to matherr, so that the Tcl version of matherr is
  82  * linked in rather than the system version. Without this reference
  83  * the need for matherr won't be discovered during linking until after
  84  * libtcl.a has been processed, so Tcl's version won't be used.
  85  */
  86
  87 #ifdef NEED_MATHERR
  88 extern int matherr();
  89 int (*tclMatherrPtr)() = matherr;
  90 #endif
  91
  92 /*
  93  * Mapping from expression instruction opcodes to strings; used for error
  94  * messages. Note that these entries must match the order and number of the
  95  * expression opcodes (e.g., INST_LOR) in tclCompile.h.
  96  */
  97
  98 static char *operatorStrings[] = {
  99     "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
 100     "+", "-", "*", "/", "%", "+", "-", "~", "!",
 101     "BUILTIN FUNCTION", "FUNCTION"
 102 };
 103
 104 /*
 105  * Mapping from Tcl result codes to strings; used for error and debugging
 106  * messages.
 107  */
 108
 109 #ifdef TCL_COMPILE_DEBUG
 110 static char *resultStrings[] = {
 111     "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
 112 };
 113 #endif
 114
 115 /*
 116  * Macros for testing floating-point values for certain special cases. Test
 117  * for not-a-number by comparing a value against itself; test for infinity
 118  * by comparing against the largest floating-point value.
 119  */
 120
 121 #define IS_NAN(v) ((v) != (v))
 122 #ifdef DBL_MAX
 123 #   define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
 124 #else
 125 #   define IS_INF(v) 0
 126 #endif
 127
 128 /*
 129  * Macro to adjust the program counter and restart the instruction execution
 130  * loop after each instruction is executed.
 131  */
 132
 133 #define ADJUST_PC(instBytes) \
 134     pc += (instBytes); \
 135     continue
 136
 137 /*
 138  * Macros used to cache often-referenced Tcl evaluation stack information
 139  * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
 140  * pair must surround any call inside TclExecuteByteCode (and a few other
 141  * procedures that use this scheme) that could result in a recursive call
 142  * to TclExecuteByteCode.
 143  */
 144
 145 #define CACHE_STACK_INFO() \
 146     stackPtr = eePtr->stackPtr; \
 147     stackTop = eePtr->stackTop
 148
 149 #define DECACHE_STACK_INFO() \
 150     eePtr->stackTop = stackTop
 151
 152 /*
 153  * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
 154  * increments the object's ref count since it makes the stack have another
 155  * reference pointing to the object. However, POP_OBJECT does not decrement
 156  * the ref count. This is because the stack may hold the only reference to
 157  * the object, so the object would be destroyed if its ref count were
 158  * decremented before the caller had a chance to, e.g., store it in a
 159  * variable. It is the caller's responsibility to decrement the ref count
 160  * when it is finished with an object.
 161  *
 162  * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
 163  * macro. The actual parameter might be an expression with side effects,
 164  * and this ensures that it will be executed only once.
 165  */
 166
 167 #define PUSH_OBJECT(objPtr) \
 168     Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
 169
 170 #define POP_OBJECT() \
 171     (stackPtr[stackTop--])
 172
 173 /*
 174  * Macros used to trace instruction execution. The macros TRACE,
 175  * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
 176  * O2S is only used in TRACE* calls to get a string from an object.
 177  */
 178
 179 #ifdef TCL_COMPILE_DEBUG
 180 #define TRACE(a) \
 181     if (traceInstructions) { \
 182         fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
 183                (unsigned int)(pc - codePtr->codeStart), \
 184                GetOpcodeName(pc)); \
 185         printf a; \
 186     }
 187 #define TRACE_WITH_OBJ(a, objPtr) \
 188     if (traceInstructions) { \
 189         fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
 190                (unsigned int)(pc - codePtr->codeStart), \
 191                GetOpcodeName(pc)); \
 192         printf a; \
 193         TclPrintObject(stdout, (objPtr), 30); \
 194         fprintf(stdout, "\n"); \
 195     }
 196 #define O2S(objPtr) \
 197     Tcl_GetString(objPtr)
 198 #else
 199 #define TRACE(a)
 200 #define TRACE_WITH_OBJ(a, objPtr)
 201 #define O2S(objPtr)
 202 #endif /* TCL_COMPILE_DEBUG */
 203
 204 /*
 205  * Declarations for local procedures to this file:
 206  */
 207
 208 static void             CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
 209                             Trace *tracePtr, Command *cmdPtr,
 210                             char *command, int numChars,
 211                             int objc, Tcl_Obj *objv[]));
 212 static void             DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
 213                             Tcl_Obj *copyPtr));
 214 static int              ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
 215                             ExecEnv *eePtr, ClientData clientData));
 216 static int              ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
 217                             ExecEnv *eePtr, ClientData clientData));
 218 static int              ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
 219                             ExecEnv *eePtr, int objc, Tcl_Obj **objv));
 220 static int              ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
 221                             ExecEnv *eePtr, ClientData clientData));
 222 static int              ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
 223                             ExecEnv *eePtr, ClientData clientData));
 224 static int              ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
 225                             ExecEnv *eePtr, ClientData clientData));
 226 static int              ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
 227                             ExecEnv *eePtr, ClientData clientData));
 228 static int              ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
 229                             ExecEnv *eePtr, ClientData clientData));
 230 static int              ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
 231                             ExecEnv *eePtr, ClientData clientData));
 232 #ifdef TCL_COMPILE_STATS
 233 static int              EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
 234                             Tcl_Interp *interp, int argc, char **argv));
 235 #endif
 236 static void             FreeCmdNameInternalRep _ANSI_ARGS_((
 237                             Tcl_Obj *objPtr));
 238 #ifdef TCL_COMPILE_DEBUG
 239 static char *           GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
 240 #endif
 241 static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
 242                             int catchOnly, ByteCode* codePtr));
 243 static char *           GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
 244                             ByteCode* codePtr, int *lengthPtr));
 245 static void             GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
 246 static void             IllegalExprOperandType _ANSI_ARGS_((
 247                             Tcl_Interp *interp, unsigned char *pc,
 248                             Tcl_Obj *opndPtr));
 249 static void             InitByteCodeExecution _ANSI_ARGS_((
 250                             Tcl_Interp *interp));
 251 #ifdef TCL_COMPILE_DEBUG
 252 static void             PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
 253 #endif
 254 static int              SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
 255                             Tcl_Obj *objPtr));
 256 #ifdef TCL_COMPILE_DEBUG
 257 static char *           StringForResultCode _ANSI_ARGS_((int result));
 258 static void             ValidatePcAndStackTop _ANSI_ARGS_((
 259                             ByteCode *codePtr, unsigned char *pc,
 260                             int stackTop, int stackLowerBound,
 261                             int stackUpperBound));
 262 #endif
 263 static int              VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
 264                             Tcl_Obj *objPtr));
 265
 266 /*
 267  * Table describing the built-in math functions. Entries in this table are
 268  * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
 269  * operand byte.
 270  */
 271
 272 BuiltinFunc builtinFuncTable[] = {
 273 #ifndef TCL_NO_MATH
 274     {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
 275     {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
 276     {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
 277     {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
 278     {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
 279     {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
 280     {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
 281     {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
 282     {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
 283     {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
 284     {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
 285     {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
 286     {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
 287     {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
 288     {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
 289     {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
 290     {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
 291     {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
 292     {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
 293 #endif
 294     {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
 295     {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
 296     {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
 297     {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
 298     {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
 299     {"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
 300     {0},
 301 };
 302
 303 /*
 304  * The structure below defines the command name Tcl object type by means of
 305  * procedures that can be invoked by generic object code. Objects of this
 306  * type cache the Command pointer that results from looking up command names
 307  * in the command hashtable. Such objects appear as the zeroth ("command
 308  * name") argument in a Tcl command.
 309  */
 310
 311 Tcl_ObjType tclCmdNameType = {
 312     "cmdName",                          /* name */
 313     FreeCmdNameInternalRep,             /* freeIntRepProc */
 314     DupCmdNameInternalRep,              /* dupIntRepProc */
 315     (Tcl_UpdateStringProc *) NULL,      /* updateStringProc */
 316     SetCmdNameFromAny                   /* setFromAnyProc */
 317 };
 318 \f
 319 /*
 320  *----------------------------------------------------------------------
 321  *
 322  * InitByteCodeExecution --
 323  *
 324  *      This procedure is called once to initialize the Tcl bytecode
 325  *      interpreter.
 326  *
 327  * Results:
 328  *      None.
 329  *
 330  * Side effects:
 331  *      This procedure initializes the array of instruction names. If
 332  *      compiling with the TCL_COMPILE_STATS flag, it initializes the
 333  *      array that counts the executions of each instruction and it
 334  *      creates the "evalstats" command. It also registers the command name
 335  *      Tcl_ObjType. It also establishes the link between the Tcl
 336  *      "tcl_traceExec" and C "tclTraceExec" variables.
 337  *
 338  *----------------------------------------------------------------------
 339  */
 340
 341 static void
 342 InitByteCodeExecution(interp)
 343     Tcl_Interp *interp;         /* Interpreter for which the Tcl variable
 344                                  * "tcl_traceExec" is linked to control
 345                                  * instruction tracing. */
 346 {
 347     Tcl_RegisterObjType(&tclCmdNameType);
 348     if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
 349                     TCL_LINK_INT) != TCL_OK) {
 350         panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
 351     }
 352
 353 #ifdef TCL_COMPILE_STATS
 354     Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
 355                       (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
 356 #endif /* TCL_COMPILE_STATS */
 357 }
 358 \f
 359 /*
 360  *----------------------------------------------------------------------
 361  *
 362  * TclCreateExecEnv --
 363  *
 364  *      This procedure creates a new execution environment for Tcl bytecode
 365  *      execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
 366  *      is typically created once for each Tcl interpreter (Interp
 367  *      structure) and recursively passed to TclExecuteByteCode to execute
 368  *      ByteCode sequences for nested commands.
 369  *
 370  * Results:
 371  *      A newly allocated ExecEnv is returned. This points to an empty
 372  *      evaluation stack of the standard initial size.
 373  *
 374  * Side effects:
 375  *      The bytecode interpreter is also initialized here, as this
 376  *      procedure will be called before any call to TclExecuteByteCode.
 377  *
 378  *----------------------------------------------------------------------
 379  */
 380
 381 #define TCL_STACK_INITIAL_SIZE 2000
 382
 383 ExecEnv *
 384 TclCreateExecEnv(interp)
 385     Tcl_Interp *interp;         /* Interpreter for which the execution
 386                                  * environment is being created. */
 387 {
 388     ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
 389
 390     eePtr->stackPtr = (Tcl_Obj **)
 391         ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
 392     eePtr->stackTop = -1;
 393     eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
 394
 395     Tcl_MutexLock(&execMutex);
 396     if (!execInitialized) {
 397         TclInitAuxDataTypeTable();
 398         InitByteCodeExecution(interp);
 399         execInitialized = 1;
 400     }
 401     Tcl_MutexUnlock(&execMutex);
 402
 403     return eePtr;
 404 }
 405 #undef TCL_STACK_INITIAL_SIZE
 406 \f
 407 /*
 408  *----------------------------------------------------------------------
 409  *
 410  * TclDeleteExecEnv --
 411  *
 412  *      Frees the storage for an ExecEnv.
 413  *
 414  * Results:
 415  *      None.
 416  *
 417  * Side effects:
 418  *      Storage for an ExecEnv and its contained storage (e.g. the
 419  *      evaluation stack) is freed.
 420  *
 421  *----------------------------------------------------------------------
 422  */
 423
 424 void
 425 TclDeleteExecEnv(eePtr)
 426     ExecEnv *eePtr;             /* Execution environment to free. */
 427 {
 428     ckfree((char *) eePtr->stackPtr);
 429     ckfree((char *) eePtr);
 430 }
 431 \f
 432 /*
 433  *----------------------------------------------------------------------
 434  *
 435  * TclFinalizeExecution --
 436  *
 437  *      Finalizes the execution environment setup so that it can be
 438  *      later reinitialized.
 439  *
 440  * Results:
 441  *      None.
 442  *
 443  * Side effects:
 444  *      After this call, the next time TclCreateExecEnv will be called
 445  *      it will call InitByteCodeExecution.
 446  *
 447  *----------------------------------------------------------------------
 448  */
 449
 450 void
 451 TclFinalizeExecution()
 452 {
 453     Tcl_MutexLock(&execMutex);
 454     execInitialized = 0;
 455     Tcl_MutexUnlock(&execMutex);
 456     TclFinalizeAuxDataTypeTable();
 457 }
 458 \f
 459 /*
 460  *----------------------------------------------------------------------
 461  *
 462  * GrowEvaluationStack --
 463  *
 464  *      This procedure grows a Tcl evaluation stack stored in an ExecEnv.
 465  *
 466  * Results:
 467  *      None.
 468  *
 469  * Side effects:
 470  *      The size of the evaluation stack is doubled.
 471  *
 472  *----------------------------------------------------------------------
 473  */
 474
 475 static void
 476 GrowEvaluationStack(eePtr)
 477     register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
 478                               * stack to enlarge. */
 479 {
 480     /*
 481      * The current Tcl stack elements are stored from eePtr->stackPtr[0]
 482      * to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
 483      */
 484
 485     int currElems = (eePtr->stackEnd + 1);
 486     int newElems  = 2*currElems;
 487     int currBytes = currElems * sizeof(Tcl_Obj *);
 488     int newBytes  = 2*currBytes;
 489     Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
 490
 491     /*
 492      * Copy the existing stack items to the new stack space, free the old
 493      * storage if appropriate, and mark new space as malloc'ed.
 494      */
 495
 496     memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
 497            (size_t) currBytes);
 498     ckfree((char *) eePtr->stackPtr);
 499     eePtr->stackPtr = newStackPtr;
 500     eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
 501 }
 502 \f
 503 /*
 504  *----------------------------------------------------------------------
 505  *
 506  * TclExecuteByteCode --
 507  *
 508  *      This procedure executes the instructions of a ByteCode structure.
 509  *      It returns when a "done" instruction is executed or an error occurs.
 510  *
 511  * Results:
 512  *      The return value is one of the return codes defined in tcl.h
 513  *      (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
 514  *      that either contains the result of executing the code or an
 515  *      error message.
 516  *
 517  * Side effects:
 518  *      Almost certainly, depending on the ByteCode's instructions.
 519  *
 520  *----------------------------------------------------------------------
 521  */
 522
 523 int
 524 TclExecuteByteCode(interp, codePtr)
 525     Tcl_Interp *interp;         /* Token for command interpreter. */
 526     ByteCode *codePtr;          /* The bytecode sequence to interpret. */
 527 {
 528     Interp *iPtr = (Interp *) interp;
 529     ExecEnv *eePtr = iPtr->execEnvPtr;
 530                                 /* Points to the execution environment. */
 531     register Tcl_Obj **stackPtr = eePtr->stackPtr;
 532                                 /* Cached evaluation stack base pointer. */
 533     register int stackTop = eePtr->stackTop;
 534                                 /* Cached top index of evaluation stack. */
 535     register unsigned char *pc = codePtr->codeStart;
 536                                 /* The current program counter. */
 537     int opnd;                   /* Current instruction's operand byte. */
 538     int pcAdjustment;           /* Hold pc adjustment after instruction. */
 539     int initStackTop = stackTop;/* Stack top at start of execution. */
 540     ExceptionRange *rangePtr;   /* Points to closest loop or catch exception
 541                                  * range enclosing the pc. Used by various
 542                                  * instructions and processCatch to
 543                                  * process break, continue, and errors. */
 544     int result = TCL_OK;        /* Return code returned after execution. */
 545     int traceInstructions = (tclTraceExec == 3);
 546     Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
 547     char *bytes;
 548     int length;
 549     long i;
 550
 551     /*
 552      * This procedure uses a stack to hold information about catch commands.
 553      * This information is the current operand stack top when starting to
 554      * execute the code for each catch command. It starts out with stack-
 555      * allocated space but uses dynamically-allocated storage if needed.
 556      */
 557
 558 #define STATIC_CATCH_STACK_SIZE 4
 559     int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
 560     int *catchStackPtr = catchStackStorage;
 561     int catchTop = -1;
 562
 563 #ifdef TCL_COMPILE_DEBUG
 564     if (tclTraceExec >= 2) {
 565         PrintByteCodeInfo(codePtr);
 566         fprintf(stdout, "  Starting stack top=%d\n", eePtr->stackTop);
 567         fflush(stdout);
 568     }
 569 #endif
 570
 571 #ifdef TCL_COMPILE_STATS
 572     iPtr->stats.numExecutions++;
 573 #endif
 574
 575     /*
 576      * Make sure the catch stack is large enough to hold the maximum number
 577      * of catch commands that could ever be executing at the same time. This
 578      * will be no more than the exception range array's depth.
 579      */
 580
 581     if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
 582         catchStackPtr = (int *)
 583                 ckalloc(codePtr->maxExceptDepth * sizeof(int));
 584     }
 585
 586     /*
 587      * Make sure the stack has enough room to execute this ByteCode.
 588      */
 589
 590     while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
 591         GrowEvaluationStack(eePtr);
 592         stackPtr = eePtr->stackPtr;
 593     }
 594
 595     /*
 596      * Loop executing instructions until a "done" instruction, a TCL_RETURN,
 597      * or some error.
 598      */
 599
 600     for (;;) {
 601 #ifdef TCL_COMPILE_DEBUG
 602         ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
 603                 eePtr->stackEnd);
 604 #else /* not TCL_COMPILE_DEBUG */
 605         if (traceInstructions) {
 606             fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
 607             TclPrintInstruction(codePtr, pc);
 608             fflush(stdout);
 609         }
 610 #endif /* TCL_COMPILE_DEBUG */
 611
 612 #ifdef TCL_COMPILE_STATS
 613         iPtr->stats.instructionCount[*pc]++;
 614 #endif
 615         switch (*pc) {
 616         case INST_DONE:
 617             /*
 618              * Pop the topmost object from the stack, set the interpreter's
 619              * object result to point to it, and return.
 620              */
 621             valuePtr = POP_OBJECT();
 622             Tcl_SetObjResult(interp, valuePtr);
 623             TclDecrRefCount(valuePtr);
 624             if (stackTop != initStackTop) {
 625                 fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
 626                         (unsigned int)(pc - codePtr->codeStart),
 627                         (unsigned int) stackTop,
 628                         (unsigned int) initStackTop);
 629                 panic("TclExecuteByteCode execution failure: end stack top != start stack top");
 630             }
 631             TRACE_WITH_OBJ(("=> return code=%d, result=", result),
 632                     iPtr->objResultPtr);
 633 #ifdef TCL_COMPILE_DEBUG
 634             if (traceInstructions) {
 635                 fprintf(stdout, "\n");
 636             }
 637 #endif
 638             goto done;
 639
 640         case INST_PUSH1:
 641 #ifdef TCL_COMPILE_DEBUG
 642             valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
 643             PUSH_OBJECT(valuePtr);
 644             TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
 645 #else
 646             PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
 647 #endif /* TCL_COMPILE_DEBUG */
 648             ADJUST_PC(2);
 649
 650         case INST_PUSH4:
 651             valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
 652             PUSH_OBJECT(valuePtr);
 653             TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
 654             ADJUST_PC(5);
 655
 656         case INST_POP:
 657             valuePtr = POP_OBJECT();
 658             TRACE_WITH_OBJ(("=> discarding "), valuePtr);
 659             TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
 660             ADJUST_PC(1);
 661
 662         case INST_DUP:
 663             valuePtr = stackPtr[stackTop];
 664             PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
 665             TRACE_WITH_OBJ(("=> "), valuePtr);
 666             ADJUST_PC(1);
 667
 668         case INST_CONCAT1:
 669             opnd = TclGetUInt1AtPtr(pc+1);
 670             {
 671                 Tcl_Obj *concatObjPtr;
 672                 int totalLen = 0;
 673
 674                 /*
 675                  * Concatenate strings (with no separators) from the top
 676                  * opnd items on the stack starting with the deepest item.
 677                  * First, determine how many characters are needed.
 678                  */
 679
 680                 for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
 681                     bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
 682                     if (bytes != NULL) {
 683                         totalLen += length;
 684                     }
 685                 }
 686
 687                 /*
 688                  * Initialize the new append string object by appending the
 689                  * strings of the opnd stack objects. Also pop the objects.
 690                  */
 691
 692                 TclNewObj(concatObjPtr);
 693                 if (totalLen > 0) {
 694                     char *p = (char *) ckalloc((unsigned) (totalLen + 1));
 695                     concatObjPtr->bytes = p;
 696                     concatObjPtr->length = totalLen;
 697                     for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
 698                         valuePtr = stackPtr[i];
 699                         bytes = Tcl_GetStringFromObj(valuePtr, &length);
 700                         if (bytes != NULL) {
 701                             memcpy((VOID *) p, (VOID *) bytes,
 702                                     (size_t) length);
 703                             p += length;
 704                         }
 705                         TclDecrRefCount(valuePtr);
 706                     }
 707                     *p = '\0';
 708                 } else {
 709                     for (i = (stackTop - (opnd-1));  i <= stackTop;  i++) {
 710                         Tcl_DecrRefCount(stackPtr[i]);
 711                     }
 712                 }
 713                 stackTop -= opnd;
 714
 715                 PUSH_OBJECT(concatObjPtr);
 716                 TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
 717                 ADJUST_PC(2);
 718             }
 719
 720         case INST_INVOKE_STK4:
 721             opnd = TclGetUInt4AtPtr(pc+1);
 722             pcAdjustment = 5;
 723             goto doInvocation;
 724
 725         case INST_INVOKE_STK1:
 726             opnd = TclGetUInt1AtPtr(pc+1);
 727             pcAdjustment = 2;
 728
 729             doInvocation:
 730             {
 731                 int objc = opnd; /* The number of arguments. */
 732                 Tcl_Obj **objv;  /* The array of argument objects. */
 733                 Command *cmdPtr; /* Points to command's Command struct. */
 734                 int newPcOffset; /* New inst offset for break, continue. */
 735 #ifdef TCL_COMPILE_DEBUG
 736                 int isUnknownCmd = 0;
 737                 char cmdNameBuf[21];
 738 #endif /* TCL_COMPILE_DEBUG */
 739
 740                 /*
 741                  * If the interpreter was deleted, return an error.
 742                  */
 743
 744                 if (iPtr->flags & DELETED) {
 745                     Tcl_ResetResult(interp);
 746                     Tcl_AppendToObj(Tcl_GetObjResult(interp),
 747                             "attempt to call eval in deleted interpreter", -1);
 748                     Tcl_SetErrorCode(interp, "CORE", "IDELETE",
 749                             "attempt to call eval in deleted interpreter",
 750                             (char *) NULL);
 751                     result = TCL_ERROR;
 752                     goto checkForCatch;
 753                 }
 754
 755                 /*
 756                  * Find the procedure to execute this command. If the
 757                  * command is not found, handle it with the "unknown" proc.
 758                  */
 759
 760                 objv = &(stackPtr[stackTop - (objc-1)]);
 761                 cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
 762                 if (cmdPtr == NULL) {
 763                     cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
 764                             (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
 765                     if (cmdPtr == NULL) {
 766                         Tcl_ResetResult(interp);
 767                         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
 768                                 "invalid command name \"",
 769                                 Tcl_GetString(objv[0]), "\"",
 770                                 (char *) NULL);
 771                         TRACE(("%u => unknown proc not found: ", objc));
 772                         result = TCL_ERROR;
 773                         goto checkForCatch;
 774                     }
 775 #ifdef TCL_COMPILE_DEBUG
 776                     isUnknownCmd = 1;
 777 #endif /*TCL_COMPILE_DEBUG*/
 778                     stackTop++; /* need room for new inserted objv[0] */
 779                     for (i = objc-1;  i >= 0;  i--) {
 780                         objv[i+1] = objv[i];
 781                     }
 782                     objc++;
 783                     objv[0] = Tcl_NewStringObj("unknown", -1);
 784                     Tcl_IncrRefCount(objv[0]);
 785                 }
 786
 787                 /*
 788                  * Call any trace procedures.
 789                  */
 790
 791                 if (iPtr->tracePtr != NULL) {
 792                     Trace *tracePtr, *nextTracePtr;
 793
 794                     for (tracePtr = iPtr->tracePtr;  tracePtr != NULL;
 795                             tracePtr = nextTracePtr) {
 796                         nextTracePtr = tracePtr->nextPtr;
 797                         if (iPtr->numLevels <= tracePtr->level) {
 798                             int numChars;
 799                             char *cmd = GetSrcInfoForPc(pc, codePtr,
 800                                     &numChars);
 801                             if (cmd != NULL) {
 802                                 DECACHE_STACK_INFO();
 803                                 CallTraceProcedure(interp, tracePtr, cmdPtr,
 804                                         cmd, numChars, objc, objv);
 805                                 CACHE_STACK_INFO();
 806                             }
 807                         }
 808                     }
 809                 }
 810
 811                 /*
 812                  * Finally, invoke the command's Tcl_ObjCmdProc. First reset
 813                  * the interpreter's string and object results to their
 814                  * default empty values since they could have gotten changed
 815                  * by earlier invocations.
 816                  */
 817
 818                 Tcl_ResetResult(interp);
 819                 if (tclTraceExec >= 2) {
 820 #ifdef TCL_COMPILE_DEBUG
 821                     if (traceInstructions) {
 822                         strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
 823                         TRACE(("%u => call ", (isUnknownCmd? objc-1:objc)));
 824                     } else {
 825                         fprintf(stdout, "%d: (%u) invoking ",
 826                                 iPtr->numLevels,
 827                                 (unsigned int)(pc - codePtr->codeStart));
 828                     }
 829                     for (i = 0;  i < objc;  i++) {
 830                         TclPrintObject(stdout, objv[i], 15);
 831                         fprintf(stdout, " ");
 832                     }
 833                     fprintf(stdout, "\n");
 834                     fflush(stdout);
 835 #else /* TCL_COMPILE_DEBUG */
 836                     fprintf(stdout, "%d: (%u) invoking %s\n",
 837                             iPtr->numLevels,
 838                             (unsigned int)(pc - codePtr->codeStart),
 839                             Tcl_GetString(objv[0]));
 840 #endif /*TCL_COMPILE_DEBUG*/
 841                 }
 842
 843                 iPtr->cmdCount++;
 844                 DECACHE_STACK_INFO();
 845                 result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
 846                                             objc, objv);
 847                 if (Tcl_AsyncReady()) {
 848                     result = Tcl_AsyncInvoke(interp, result);
 849                 }
 850                 CACHE_STACK_INFO();
 851
 852                 /*
 853                  * If the interpreter has a non-empty string result, the
 854                  * result object is either empty or stale because some
 855                  * procedure set interp->result directly. If so, move the
 856                  * string result to the result object, then reset the
 857                  * string result.
 858                  */
 859
 860                 if (*(iPtr->result) != 0) {
 861                     (void) Tcl_GetObjResult(interp);
 862                 }
 863
 864                 /*
 865                  * Pop the objc top stack elements and decrement their ref
 866                  * counts.
 867                  */
 868
 869                 for (i = 0;  i < objc;  i++) {
 870                     valuePtr = stackPtr[stackTop];
 871                     TclDecrRefCount(valuePtr);
 872                     stackTop--;
 873                 }
 874
 875                 /*
 876                  * Process the result of the Tcl_ObjCmdProc call.
 877                  */
 878
 879                 switch (result) {
 880                 case TCL_OK:
 881                     /*
 882                      * Push the call's object result and continue execution
 883                      * with the next instruction.
 884                      */
 885                     PUSH_OBJECT(Tcl_GetObjResult(interp));
 886                     TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
 887                             objc, cmdNameBuf), Tcl_GetObjResult(interp));
 888                     ADJUST_PC(pcAdjustment);
 889
 890                 case TCL_BREAK:
 891                 case TCL_CONTINUE:
 892                     /*
 893                      * The invoked command requested a break or continue.
 894                      * Find the closest enclosing loop or catch exception
 895                      * range, if any. If a loop is found, terminate its
 896                      * execution or skip to its next iteration. If the
 897                      * closest is a catch exception range, jump to its
 898                      * catchOffset. If no enclosing range is found, stop
 899                      * execution and return the TCL_BREAK or TCL_CONTINUE.
 900                      */
 901                     rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
 902                             codePtr);
 903                     if (rangePtr == NULL) {
 904                         TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
 905                                 objc, cmdNameBuf,
 906                                 StringForResultCode(result)));
 907                         goto abnormalReturn; /* no catch exists to check */
 908                     }
 909                     newPcOffset = 0;
 910                     switch (rangePtr->type) {
 911                     case LOOP_EXCEPTION_RANGE:
 912                         if (result == TCL_BREAK) {
 913                             newPcOffset = rangePtr->breakOffset;
 914                         } else if (rangePtr->continueOffset == -1) {
 915                             TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
 916                                    objc, cmdNameBuf,
 917                                    StringForResultCode(result)));
 918                             goto checkForCatch;
 919                         } else {
 920                             newPcOffset = rangePtr->continueOffset;
 921                         }
 922                         TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
 923                                objc, cmdNameBuf,
 924                                StringForResultCode(result),
 925                                rangePtr->codeOffset, newPcOffset));
 926                         break;
 927                     case CATCH_EXCEPTION_RANGE:
 928                         TRACE(("%u => ... after \"%.20s\", %s...\n",
 929                                objc, cmdNameBuf,
 930                                StringForResultCode(result)));
 931                         goto processCatch; /* it will use rangePtr */
 932                     default:
 933                         panic("TclExecuteByteCode: bad ExceptionRange type\n");
 934                     }
 935                     result = TCL_OK;
 936                     pc = (codePtr->codeStart + newPcOffset);
 937                     continue;   /* restart outer instruction loop at pc */
 938
 939                 case TCL_ERROR:
 940                     /*
 941                      * The invoked command returned an error. Look for an
 942                      * enclosing catch exception range, if any.
 943                      */
 944                     TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
 945                             objc, cmdNameBuf), Tcl_GetObjResult(interp));
 946                     goto checkForCatch;
 947
 948                 case TCL_RETURN:
 949                     /*
 950                      * The invoked command requested that the current
 951                      * procedure stop execution and return. First check
 952                      * for an enclosing catch exception range, if any.
 953                      */
 954                     TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
 955                             objc, cmdNameBuf));
 956                     goto checkForCatch;
 957
 958                 default:
 959                     TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
 960                             objc, cmdNameBuf, result),
 961                             Tcl_GetObjResult(interp));
 962                     goto checkForCatch;
 963                 }
 964             }
 965
 966         case INST_EVAL_STK:
 967             objPtr = POP_OBJECT();
 968             DECACHE_STACK_INFO();
 969             result = Tcl_EvalObjEx(interp, objPtr, 0);
 970             CACHE_STACK_INFO();
 971             if (result == TCL_OK) {
 972                 /*
 973                  * Normal return; push the eval's object result.
 974                  */
 975                 PUSH_OBJECT(Tcl_GetObjResult(interp));
 976                 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
 977                         Tcl_GetObjResult(interp));
 978                 TclDecrRefCount(objPtr);
 979                 ADJUST_PC(1);
 980             } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
 981                 /*
 982                  * Find the closest enclosing loop or catch exception range,
 983                  * if any. If a loop is found, terminate its execution or
 984                  * skip to its next iteration. If the closest is a catch
 985                  * exception range, jump to its catchOffset. If no enclosing
 986                  * range is found, stop execution and return that same
 987                  * TCL_BREAK or TCL_CONTINUE.
 988                  */
 989
 990                 int newPcOffset = 0; /* Pc offset computed during break,
 991                                       * continue, error processing. Init.
 992                                       * to avoid compiler warning. */
 993
 994                 rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
 995                         codePtr);
 996                 if (rangePtr == NULL) {
 997                     TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
 998                             O2S(objPtr), StringForResultCode(result)));
 999                     Tcl_DecrRefCount(objPtr);
1000                     goto abnormalReturn;    /* no catch exists to check */
1001                 }
1002                 switch (rangePtr->type) {
1003                 case LOOP_EXCEPTION_RANGE:
1004                     if (result == TCL_BREAK) {
1005                         newPcOffset = rangePtr->breakOffset;
1006                     } else if (rangePtr->continueOffset == -1) {
1007                         TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
1008                                O2S(objPtr), StringForResultCode(result)));
1009                         Tcl_DecrRefCount(objPtr);
1010                         goto checkForCatch;
1011                     } else {
1012                         newPcOffset = rangePtr->continueOffset;
1013                     }
1014                     result = TCL_OK;
1015                     TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ",
1016                             O2S(objPtr), StringForResultCode(result),
1017                             rangePtr->codeOffset, newPcOffset), valuePtr);
1018                     break;
1019                 case CATCH_EXCEPTION_RANGE:
1020                     TRACE_WITH_OBJ(("\"%.30s\" => %s ",
1021                             O2S(objPtr), StringForResultCode(result)),
1022                             valuePtr);
1023                     Tcl_DecrRefCount(objPtr);
1024                     goto processCatch;  /* it will use rangePtr */
1025                 default:
1026                     panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
1027                 }
1028                 Tcl_DecrRefCount(objPtr);
1029                 pc = (codePtr->codeStart + newPcOffset);
1030                 continue;       /* restart outer instruction loop at pc */
1031             } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
1032                 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
1033                         Tcl_GetObjResult(interp));
1034                 Tcl_DecrRefCount(objPtr);
1035                 goto checkForCatch;
1036             }
1037
1038         case INST_EXPR_STK:
1039             objPtr = POP_OBJECT();
1040             Tcl_ResetResult(interp);
1041             DECACHE_STACK_INFO();
1042             result = Tcl_ExprObj(interp, objPtr, &valuePtr);
1043             CACHE_STACK_INFO();
1044             if (result != TCL_OK) {
1045                 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1046                         O2S(objPtr)), Tcl_GetObjResult(interp));
1047                 Tcl_DecrRefCount(objPtr);
1048                 goto checkForCatch;
1049             }
1050             stackPtr[++stackTop] = valuePtr; /* already has right refct */
1051             TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1052             TclDecrRefCount(objPtr);
1053             ADJUST_PC(1);
1054
1055         case INST_LOAD_SCALAR1:
1056 #ifdef TCL_COMPILE_DEBUG
1057             opnd = TclGetUInt1AtPtr(pc+1);
1058             DECACHE_STACK_INFO();
1059             valuePtr = TclGetIndexedScalar(interp, opnd,
1060                     /*leaveErrorMsg*/ 1);
1061             CACHE_STACK_INFO();
1062             if (valuePtr == NULL) {
1063                 TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
1064                         Tcl_GetObjResult(interp));
1065                 result = TCL_ERROR;
1066                 goto checkForCatch;
1067             }
1068             PUSH_OBJECT(valuePtr);
1069             TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
1070 #else /* TCL_COMPILE_DEBUG */
1071             DECACHE_STACK_INFO();
1072             opnd = TclGetUInt1AtPtr(pc+1);
1073             valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1);
1074             CACHE_STACK_INFO();
1075             if (valuePtr == NULL) {
1076                 result = TCL_ERROR;
1077                 goto checkForCatch;
1078             }
1079             PUSH_OBJECT(valuePtr);
1080 #endif /* TCL_COMPILE_DEBUG */
1081             ADJUST_PC(2);
1082
1083         case INST_LOAD_SCALAR4:
1084             opnd = TclGetUInt4AtPtr(pc+1);
1085             DECACHE_STACK_INFO();
1086             valuePtr = TclGetIndexedScalar(interp, opnd,
1087                                            /*leaveErrorMsg*/ 1);
1088             CACHE_STACK_INFO();
1089             if (valuePtr == NULL) {
1090                 TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
1091                         Tcl_GetObjResult(interp));
1092                 result = TCL_ERROR;
1093                 goto checkForCatch;
1094             }
1095             PUSH_OBJECT(valuePtr);
1096             TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
1097             ADJUST_PC(5);
1098
1099         case INST_LOAD_SCALAR_STK:
1100             objPtr = POP_OBJECT(); /* scalar name */
1101             DECACHE_STACK_INFO();
1102             valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
1103             CACHE_STACK_INFO();
1104             if (valuePtr == NULL) {
1105                 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
1106                         Tcl_GetObjResult(interp));
1107                 Tcl_DecrRefCount(objPtr);
1108                 result = TCL_ERROR;
1109                 goto checkForCatch;
1110             }
1111             PUSH_OBJECT(valuePtr);
1112             TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1113             TclDecrRefCount(objPtr);
1114             ADJUST_PC(1);
1115
1116         case INST_LOAD_ARRAY4:
1117             opnd = TclGetUInt4AtPtr(pc+1);
1118             pcAdjustment = 5;
1119             goto doLoadArray;
1120
1121         case INST_LOAD_ARRAY1:
1122             opnd = TclGetUInt1AtPtr(pc+1);
1123             pcAdjustment = 2;
1124
1125             doLoadArray:
1126             {
1127                 Tcl_Obj *elemPtr = POP_OBJECT();
1128
1129                 DECACHE_STACK_INFO();
1130                 valuePtr = TclGetElementOfIndexedArray(interp, opnd,
1131                         elemPtr, /*leaveErrorMsg*/ 1);
1132                 CACHE_STACK_INFO();
1133                 if (valuePtr == NULL) {
1134                     TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
1135                             opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
1136                     Tcl_DecrRefCount(elemPtr);
1137                     result = TCL_ERROR;
1138                     goto checkForCatch;
1139                 }
1140                 PUSH_OBJECT(valuePtr);
1141                 TRACE_WITH_OBJ(("%u \"%.30s\" => ",
1142                         opnd, O2S(elemPtr)),valuePtr);
1143                 TclDecrRefCount(elemPtr);
1144             }
1145             ADJUST_PC(pcAdjustment);
1146
1147         case INST_LOAD_ARRAY_STK:
1148             {
1149                 Tcl_Obj *elemPtr = POP_OBJECT();
1150
1151                 objPtr = POP_OBJECT();  /* array name */
1152                 DECACHE_STACK_INFO();
1153                 valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
1154                         TCL_LEAVE_ERR_MSG);
1155                 CACHE_STACK_INFO();
1156                 if (valuePtr == NULL) {
1157                     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
1158                             O2S(objPtr), O2S(elemPtr)),
1159                             Tcl_GetObjResult(interp));
1160                     Tcl_DecrRefCount(objPtr);
1161                     Tcl_DecrRefCount(elemPtr);
1162                     result = TCL_ERROR;
1163                     goto checkForCatch;
1164                 }
1165                 PUSH_OBJECT(valuePtr);
1166                 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
1167                         O2S(objPtr), O2S(elemPtr)), valuePtr);
1168                 TclDecrRefCount(objPtr);
1169                 TclDecrRefCount(elemPtr);
1170             }
1171             ADJUST_PC(1);
1172
1173         case INST_LOAD_STK:
1174             objPtr = POP_OBJECT(); /* variable name */
1175             DECACHE_STACK_INFO();
1176             valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
1177             CACHE_STACK_INFO();
1178             if (valuePtr == NULL) {
1179                 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1180                         O2S(objPtr)), Tcl_GetObjResult(interp));
1181                 Tcl_DecrRefCount(objPtr);
1182                 result = TCL_ERROR;
1183                 goto checkForCatch;
1184             }
1185             PUSH_OBJECT(valuePtr);
1186             TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1187             TclDecrRefCount(objPtr);
1188             ADJUST_PC(1);
1189
1190         case INST_STORE_SCALAR4:
1191             opnd = TclGetUInt4AtPtr(pc+1);
1192             pcAdjustment = 5;
1193             goto doStoreScalar;
1194
1195         case INST_STORE_SCALAR1:
1196             opnd = TclGetUInt1AtPtr(pc+1);
1197             pcAdjustment = 2;
1198
1199           doStoreScalar:
1200             valuePtr = POP_OBJECT();
1201             DECACHE_STACK_INFO();
1202             value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
1203                     /*leaveErrorMsg*/ 1);
1204             CACHE_STACK_INFO();
1205             if (value2Ptr == NULL) {
1206                 TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
1207                         opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1208                 Tcl_DecrRefCount(valuePtr);
1209                 result = TCL_ERROR;
1210                 goto checkForCatch;
1211             }
1212             PUSH_OBJECT(value2Ptr);
1213             TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
1214                     opnd, O2S(valuePtr)), value2Ptr);
1215             TclDecrRefCount(valuePtr);
1216             ADJUST_PC(pcAdjustment);
1217
1218         case INST_STORE_SCALAR_STK:
1219             valuePtr = POP_OBJECT();
1220             objPtr = POP_OBJECT(); /* scalar name */
1221             DECACHE_STACK_INFO();
1222             value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
1223                     TCL_LEAVE_ERR_MSG);
1224             CACHE_STACK_INFO();
1225             if (value2Ptr == NULL) {
1226                 TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
1227                         O2S(objPtr), O2S(valuePtr)),
1228                         Tcl_GetObjResult(interp));
1229                 Tcl_DecrRefCount(objPtr);
1230                 Tcl_DecrRefCount(valuePtr);
1231                 result = TCL_ERROR;
1232                 goto checkForCatch;
1233             }
1234             PUSH_OBJECT(value2Ptr);
1235             TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
1236                     O2S(objPtr), O2S(valuePtr)), value2Ptr);
1237             TclDecrRefCount(objPtr);
1238             TclDecrRefCount(valuePtr);
1239             ADJUST_PC(1);
1240
1241         case INST_STORE_ARRAY4:
1242             opnd = TclGetUInt4AtPtr(pc+1);
1243             pcAdjustment = 5;
1244             goto doStoreArray;
1245
1246         case INST_STORE_ARRAY1:
1247             opnd = TclGetUInt1AtPtr(pc+1);
1248             pcAdjustment = 2;
1249
1250             doStoreArray:
1251             {
1252                 Tcl_Obj *elemPtr;
1253
1254                 valuePtr = POP_OBJECT();
1255                 elemPtr = POP_OBJECT();
1256                 DECACHE_STACK_INFO();
1257                 value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
1258                         elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
1259                 CACHE_STACK_INFO();
1260                 if (value2Ptr == NULL) {
1261                     TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
1262                             opnd, O2S(elemPtr), O2S(valuePtr)),
1263                             Tcl_GetObjResult(interp));
1264                     Tcl_DecrRefCount(elemPtr);
1265                     Tcl_DecrRefCount(valuePtr);
1266                     result = TCL_ERROR;
1267                     goto checkForCatch;
1268                 }
1269                 PUSH_OBJECT(value2Ptr);
1270                 TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
1271                         opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
1272                 TclDecrRefCount(elemPtr);
1273                 TclDecrRefCount(valuePtr);
1274             }
1275             ADJUST_PC(pcAdjustment);
1276
1277         case INST_STORE_ARRAY_STK:
1278             {
1279                 Tcl_Obj *elemPtr;
1280
1281                 valuePtr = POP_OBJECT();
1282                 elemPtr = POP_OBJECT();
1283                 objPtr = POP_OBJECT();  /* array name */
1284                 DECACHE_STACK_INFO();
1285                 value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
1286                         TCL_LEAVE_ERR_MSG);
1287                 CACHE_STACK_INFO();
1288                 if (value2Ptr == NULL) {
1289                     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
1290                             O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1291                             Tcl_GetObjResult(interp));
1292                     Tcl_DecrRefCount(objPtr);
1293                     Tcl_DecrRefCount(elemPtr);
1294                     Tcl_DecrRefCount(valuePtr);
1295                     result = TCL_ERROR;
1296                     goto checkForCatch;
1297                 }
1298                 PUSH_OBJECT(value2Ptr);
1299                 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
1300                         O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1301                         value2Ptr);
1302                 TclDecrRefCount(objPtr);
1303                 TclDecrRefCount(elemPtr);
1304                 TclDecrRefCount(valuePtr);
1305             }
1306             ADJUST_PC(1);
1307
1308         case INST_STORE_STK:
1309             valuePtr = POP_OBJECT();
1310             objPtr = POP_OBJECT(); /* variable name */
1311             DECACHE_STACK_INFO();
1312             value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
1313                     TCL_LEAVE_ERR_MSG);
1314             CACHE_STACK_INFO();
1315             if (value2Ptr == NULL) {
1316                 TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
1317                         O2S(objPtr), O2S(valuePtr)),
1318                         Tcl_GetObjResult(interp));
1319                 Tcl_DecrRefCount(objPtr);
1320                 Tcl_DecrRefCount(valuePtr);
1321                 result = TCL_ERROR;
1322                 goto checkForCatch;
1323             }
1324             PUSH_OBJECT(value2Ptr);
1325             TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
1326                     O2S(objPtr), O2S(valuePtr)), value2Ptr);
1327             TclDecrRefCount(objPtr);
1328             TclDecrRefCount(valuePtr);
1329             ADJUST_PC(1);
1330
1331         case INST_INCR_SCALAR1:
1332             opnd = TclGetUInt1AtPtr(pc+1);
1333             valuePtr = POP_OBJECT();
1334             if (valuePtr->typePtr != &tclIntType) {
1335                 result = tclIntType.setFromAnyProc(interp, valuePtr);
1336                 if (result != TCL_OK) {
1337                     TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
1338                             opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1339                     Tcl_DecrRefCount(valuePtr);
1340                     goto checkForCatch;
1341                 }
1342             }
1343             i = valuePtr->internalRep.longValue;
1344             DECACHE_STACK_INFO();
1345             value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1346             CACHE_STACK_INFO();
1347             if (value2Ptr == NULL) {
1348                 TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
1349                         Tcl_GetObjResult(interp));
1350                 Tcl_DecrRefCount(valuePtr);
1351                 result = TCL_ERROR;
1352                 goto checkForCatch;
1353             }
1354             PUSH_OBJECT(value2Ptr);
1355             TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
1356             TclDecrRefCount(valuePtr);
1357             ADJUST_PC(2);
1358
1359         case INST_INCR_SCALAR_STK:
1360         case INST_INCR_STK:
1361             valuePtr = POP_OBJECT();
1362             objPtr = POP_OBJECT(); /* scalar name */
1363             if (valuePtr->typePtr != &tclIntType) {
1364                 result = tclIntType.setFromAnyProc(interp, valuePtr);
1365                 if (result != TCL_OK) {
1366                     TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1367                             O2S(objPtr), O2S(valuePtr)),
1368                             Tcl_GetObjResult(interp));
1369                     Tcl_DecrRefCount(objPtr);
1370                     Tcl_DecrRefCount(valuePtr);
1371                     goto checkForCatch;
1372                 }
1373             }
1374             i = valuePtr->internalRep.longValue;
1375             DECACHE_STACK_INFO();
1376             value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
1377                     TCL_LEAVE_ERR_MSG);
1378             CACHE_STACK_INFO();
1379             if (value2Ptr == NULL) {
1380                 TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
1381                         O2S(objPtr), i), Tcl_GetObjResult(interp));
1382                 Tcl_DecrRefCount(objPtr);
1383                 Tcl_DecrRefCount(valuePtr);
1384                 result = TCL_ERROR;
1385                 goto checkForCatch;
1386             }
1387             PUSH_OBJECT(value2Ptr);
1388             TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
1389                     value2Ptr);
1390             Tcl_DecrRefCount(objPtr);
1391             Tcl_DecrRefCount(valuePtr);
1392             ADJUST_PC(1);
1393
1394         case INST_INCR_ARRAY1:
1395             {
1396                 Tcl_Obj *elemPtr;
1397
1398                 opnd = TclGetUInt1AtPtr(pc+1);
1399                 valuePtr = POP_OBJECT();
1400                 elemPtr = POP_OBJECT();
1401                 if (valuePtr->typePtr != &tclIntType) {
1402                     result = tclIntType.setFromAnyProc(interp, valuePtr);
1403                     if (result != TCL_OK) {
1404                         TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1405                                 opnd, O2S(elemPtr), O2S(valuePtr)),
1406                                 Tcl_GetObjResult(interp));
1407                         Tcl_DecrRefCount(elemPtr);
1408                         Tcl_DecrRefCount(valuePtr);
1409                         goto checkForCatch;
1410                     }
1411                 }
1412                 i = valuePtr->internalRep.longValue;
1413                 DECACHE_STACK_INFO();
1414                 value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1415                         elemPtr, i);
1416                 CACHE_STACK_INFO();
1417                 if (value2Ptr == NULL) {
1418                     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
1419                             opnd, O2S(elemPtr), i),
1420                             Tcl_GetObjResult(interp));
1421                     Tcl_DecrRefCount(elemPtr);
1422                     Tcl_DecrRefCount(valuePtr);
1423                     result = TCL_ERROR;
1424                     goto checkForCatch;
1425                 }
1426                 PUSH_OBJECT(value2Ptr);
1427                 TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
1428                         opnd, O2S(elemPtr), i), value2Ptr);
1429                 Tcl_DecrRefCount(elemPtr);
1430                 Tcl_DecrRefCount(valuePtr);
1431             }
1432             ADJUST_PC(2);
1433
1434         case INST_INCR_ARRAY_STK:
1435             {
1436                 Tcl_Obj *elemPtr;
1437
1438                 valuePtr = POP_OBJECT();
1439                 elemPtr = POP_OBJECT();
1440                 objPtr = POP_OBJECT();  /* array name */
1441                 if (valuePtr->typePtr != &tclIntType) {
1442                     result = tclIntType.setFromAnyProc(interp, valuePtr);
1443                     if (result != TCL_OK) {
1444                         TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
1445                                 O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1446                                 Tcl_GetObjResult(interp));
1447                         Tcl_DecrRefCount(objPtr);
1448                         Tcl_DecrRefCount(elemPtr);
1449                         Tcl_DecrRefCount(valuePtr);
1450                         goto checkForCatch;
1451                     }
1452                 }
1453                 i = valuePtr->internalRep.longValue;
1454                 DECACHE_STACK_INFO();
1455                 value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
1456                         TCL_LEAVE_ERR_MSG);
1457                 CACHE_STACK_INFO();
1458                 if (value2Ptr == NULL) {
1459                     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
1460                             O2S(objPtr), O2S(elemPtr), i),
1461                             Tcl_GetObjResult(interp));
1462                     Tcl_DecrRefCount(objPtr);
1463                     Tcl_DecrRefCount(elemPtr);
1464                     Tcl_DecrRefCount(valuePtr);
1465                     result = TCL_ERROR;
1466                     goto checkForCatch;
1467                 }
1468                 PUSH_OBJECT(value2Ptr);
1469                 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
1470                         O2S(objPtr), O2S(elemPtr), i), value2Ptr);
1471                 Tcl_DecrRefCount(objPtr);
1472                 Tcl_DecrRefCount(elemPtr);
1473                 Tcl_DecrRefCount(valuePtr);
1474             }
1475             ADJUST_PC(1);
1476
1477         case INST_INCR_SCALAR1_IMM:
1478             opnd = TclGetUInt1AtPtr(pc+1);
1479             i = TclGetInt1AtPtr(pc+2);
1480             DECACHE_STACK_INFO();
1481             value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1482             CACHE_STACK_INFO();
1483             if (value2Ptr == NULL) {
1484                 TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
1485                         Tcl_GetObjResult(interp));
1486                 result = TCL_ERROR;
1487                 goto checkForCatch;
1488             }
1489             PUSH_OBJECT(value2Ptr);
1490             TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
1491             ADJUST_PC(3);
1492
1493         case INST_INCR_SCALAR_STK_IMM:
1494         case INST_INCR_STK_IMM:
1495             objPtr = POP_OBJECT(); /* variable name */
1496             i = TclGetInt1AtPtr(pc+1);
1497             DECACHE_STACK_INFO();
1498             value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
1499                     TCL_LEAVE_ERR_MSG);
1500             CACHE_STACK_INFO();
1501             if (value2Ptr == NULL) {
1502                 TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
1503                         O2S(objPtr), i), Tcl_GetObjResult(interp));
1504                 result = TCL_ERROR;
1505                 Tcl_DecrRefCount(objPtr);
1506                 goto checkForCatch;
1507             }
1508             PUSH_OBJECT(value2Ptr);
1509             TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),
1510                     value2Ptr);
1511             TclDecrRefCount(objPtr);
1512             ADJUST_PC(2);
1513
1514         case INST_INCR_ARRAY1_IMM:
1515             {
1516                 Tcl_Obj *elemPtr;
1517
1518                 opnd = TclGetUInt1AtPtr(pc+1);
1519                 i = TclGetInt1AtPtr(pc+2);
1520                 elemPtr = POP_OBJECT();
1521                 DECACHE_STACK_INFO();
1522                 value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1523                         elemPtr, i);
1524                 CACHE_STACK_INFO();
1525                 if (value2Ptr == NULL) {
1526                     TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
1527                             opnd, O2S(elemPtr), i),
1528                             Tcl_GetObjResult(interp));
1529                     Tcl_DecrRefCount(elemPtr);
1530                     result = TCL_ERROR;
1531                     goto checkForCatch;
1532                 }
1533                 PUSH_OBJECT(value2Ptr);
1534                 TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
1535                         opnd, O2S(elemPtr), i), value2Ptr);
1536                 Tcl_DecrRefCount(elemPtr);
1537             }
1538             ADJUST_PC(3);
1539
1540         case INST_INCR_ARRAY_STK_IMM:
1541             {
1542                 Tcl_Obj *elemPtr;
1543
1544                 i = TclGetInt1AtPtr(pc+1);
1545                 elemPtr = POP_OBJECT();
1546                 objPtr = POP_OBJECT();  /* array name */
1547                 DECACHE_STACK_INFO();
1548                 value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
1549                         TCL_LEAVE_ERR_MSG);
1550                 CACHE_STACK_INFO();
1551                 if (value2Ptr == NULL) {
1552                     TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
1553                             O2S(objPtr), O2S(elemPtr), i),
1554                             Tcl_GetObjResult(interp));
1555                     Tcl_DecrRefCount(objPtr);
1556                     Tcl_DecrRefCount(elemPtr);
1557                     result = TCL_ERROR;
1558                     goto checkForCatch;
1559                 }
1560                 PUSH_OBJECT(value2Ptr);
1561                 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
1562                         O2S(objPtr), O2S(elemPtr), i), value2Ptr);
1563                 Tcl_DecrRefCount(objPtr);
1564                 Tcl_DecrRefCount(elemPtr);
1565             }
1566             ADJUST_PC(2);
1567
1568         case INST_JUMP1:
1569 #ifdef TCL_COMPILE_DEBUG
1570             opnd = TclGetInt1AtPtr(pc+1);
1571             TRACE(("%d => new pc %u\n", opnd,
1572                    (unsigned int)(pc + opnd - codePtr->codeStart)));
1573             pc += opnd;
1574 #else
1575             pc += TclGetInt1AtPtr(pc+1);
1576 #endif /* TCL_COMPILE_DEBUG */
1577             continue;
1578
1579         case INST_JUMP4:
1580             opnd = TclGetInt4AtPtr(pc+1);
1581             TRACE(("%d => new pc %u\n", opnd,
1582                    (unsigned int)(pc + opnd - codePtr->codeStart)));
1583             ADJUST_PC(opnd);
1584
1585         case INST_JUMP_TRUE4:
1586             opnd = TclGetInt4AtPtr(pc+1);
1587             pcAdjustment = 5;
1588             goto doJumpTrue;
1589
1590         case INST_JUMP_TRUE1:
1591             opnd = TclGetInt1AtPtr(pc+1);
1592             pcAdjustment = 2;
1593
1594             doJumpTrue:
1595             {
1596                 int b;
1597
1598                 valuePtr = POP_OBJECT();
1599                 if (valuePtr->typePtr == &tclIntType) {
1600                     b = (valuePtr->internalRep.longValue != 0);
1601                 } else if (valuePtr->typePtr == &tclDoubleType) {
1602                     b = (valuePtr->internalRep.doubleValue != 0.0);
1603                 } else {
1604                     result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1605                     if (result != TCL_OK) {
1606                         TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
1607                                 Tcl_GetObjResult(interp));
1608                         Tcl_DecrRefCount(valuePtr);
1609                         goto checkForCatch;
1610                     }
1611                 }
1612                 if (b) {
1613                     TRACE(("%d => %.20s true, new pc %u\n",
1614                             opnd, O2S(valuePtr),
1615                             (unsigned int)(pc+opnd - codePtr->codeStart)));
1616                     TclDecrRefCount(valuePtr);
1617                     ADJUST_PC(opnd);
1618                 } else {
1619                     TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
1620                     TclDecrRefCount(valuePtr);
1621                     ADJUST_PC(pcAdjustment);
1622                 }
1623             }
1624
1625         case INST_JUMP_FALSE4:
1626             opnd = TclGetInt4AtPtr(pc+1);
1627             pcAdjustment = 5;
1628             goto doJumpFalse;
1629
1630         case INST_JUMP_FALSE1:
1631             opnd = TclGetInt1AtPtr(pc+1);
1632             pcAdjustment = 2;
1633
1634             doJumpFalse:
1635             {
1636                 int b;
1637
1638                 valuePtr = POP_OBJECT();
1639                 if (valuePtr->typePtr == &tclIntType) {
1640                     b = (valuePtr->internalRep.longValue != 0);
1641                 } else if (valuePtr->typePtr == &tclDoubleType) {
1642                     b = (valuePtr->internalRep.doubleValue != 0.0);
1643                 } else {
1644                     result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1645                     if (result != TCL_OK) {
1646                         TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
1647                                 Tcl_GetObjResult(interp));
1648                         Tcl_DecrRefCount(valuePtr);
1649                         goto checkForCatch;
1650                     }
1651                 }
1652                 if (b) {
1653                     TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
1654                     TclDecrRefCount(valuePtr);
1655                     ADJUST_PC(pcAdjustment);
1656                 } else {
1657                     TRACE(("%d => %.20s false, new pc %u\n",
1658                            opnd, O2S(valuePtr),
1659                            (unsigned int)(pc + opnd - codePtr->codeStart)));
1660                     TclDecrRefCount(valuePtr);
1661                     ADJUST_PC(opnd);
1662                 }
1663             }
1664
1665         case INST_LOR:
1666         case INST_LAND:
1667             {
1668                 /*
1669                  * Operands must be boolean or numeric. No int->double
1670                  * conversions are performed.
1671                  */
1672
1673                 int i1, i2;
1674                 int iResult;
1675                 char *s;
1676                 Tcl_ObjType *t1Ptr, *t2Ptr;
1677
1678                 value2Ptr = POP_OBJECT();
1679                 valuePtr  = POP_OBJECT();
1680                 t1Ptr = valuePtr->typePtr;
1681                 t2Ptr = value2Ptr->typePtr;
1682
1683                 if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
1684                     i1 = (valuePtr->internalRep.longValue != 0);
1685                 } else if (t1Ptr == &tclDoubleType) {
1686                     i1 = (valuePtr->internalRep.doubleValue != 0.0);
1687                 } else {
1688                     s = Tcl_GetStringFromObj(valuePtr, &length);
1689                     if (TclLooksLikeInt(s, length)) {
1690                         result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1691                                 valuePtr, &i);
1692                         i1 = (i != 0);
1693                     } else {
1694                         result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1695                                 valuePtr, &i1);
1696                         i1 = (i1 != 0);
1697                     }
1698                     if (result != TCL_OK) {
1699                         TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1700                                 O2S(valuePtr),
1701                                 (t1Ptr? t1Ptr->name : "null")));
1702                         IllegalExprOperandType(interp, pc, valuePtr);
1703                         Tcl_DecrRefCount(valuePtr);
1704                         Tcl_DecrRefCount(value2Ptr);
1705                         goto checkForCatch;
1706                     }
1707                 }
1708
1709                 if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
1710                     i2 = (value2Ptr->internalRep.longValue != 0);
1711                 } else if (t2Ptr == &tclDoubleType) {
1712                     i2 = (value2Ptr->internalRep.doubleValue != 0.0);
1713                 } else {
1714                     s = Tcl_GetStringFromObj(value2Ptr, &length);
1715                     if (TclLooksLikeInt(s, length)) {
1716                         result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1717                                 value2Ptr, &i);
1718                         i2 = (i != 0);
1719                     } else {
1720                         result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1721                                 value2Ptr, &i2);
1722                     }
1723                     if (result != TCL_OK) {
1724                         TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1725                                 O2S(value2Ptr),
1726                                 (t2Ptr? t2Ptr->name : "null")));
1727                         IllegalExprOperandType(interp, pc, value2Ptr);
1728                         Tcl_DecrRefCount(valuePtr);
1729                         Tcl_DecrRefCount(value2Ptr);
1730                         goto checkForCatch;
1731                     }
1732                 }
1733
1734                 /*
1735                  * Reuse the valuePtr object already on stack if possible.
1736                  */
1737
1738                 if (*pc == INST_LOR) {
1739                     iResult = (i1 || i2);
1740                 } else {
1741                     iResult = (i1 && i2);
1742                 }
1743                 if (Tcl_IsShared(valuePtr)) {
1744                     PUSH_OBJECT(Tcl_NewLongObj(iResult));
1745                     TRACE(("%.20s %.20s => %d\n",
1746                            O2S(valuePtr), O2S(value2Ptr), iResult));
1747                     TclDecrRefCount(valuePtr);
1748                 } else {        /* reuse the valuePtr object */
1749                     TRACE(("%.20s %.20s => %d\n",
1750                            O2S(valuePtr), O2S(value2Ptr), iResult));
1751                     Tcl_SetLongObj(valuePtr, iResult);
1752                     ++stackTop; /* valuePtr now on stk top has right r.c. */
1753                 }
1754                 TclDecrRefCount(value2Ptr);
1755             }
1756             ADJUST_PC(1);
1757
1758         case INST_EQ:
1759         case INST_NEQ:
1760         case INST_LT:
1761         case INST_GT:
1762         case INST_LE:
1763         case INST_GE:
1764             {
1765                 /*
1766                  * Any type is allowed but the two operands must have the
1767                  * same type. We will compute value op value2.
1768                  */
1769
1770                 Tcl_ObjType *t1Ptr, *t2Ptr;
1771                 char *s1 = NULL;   /* Init. avoids compiler warning. */
1772                 char *s2 = NULL;   /* Init. avoids compiler warning. */
1773                 long i2 = 0;       /* Init. avoids compiler warning. */
1774                 double d1 = 0.0;   /* Init. avoids compiler warning. */
1775                 double d2 = 0.0;   /* Init. avoids compiler warning. */
1776                 long iResult = 0;  /* Init. avoids compiler warning. */
1777
1778                 value2Ptr = POP_OBJECT();
1779                 valuePtr  = POP_OBJECT();
1780                 t1Ptr = valuePtr->typePtr;
1781                 t2Ptr = value2Ptr->typePtr;
1782
1783                 /*
1784                  * We only want to coerce numeric validation if
1785                  * neither type is NULL.  A NULL type means the arg is
1786                  * essentially an empty object ("", {} or [list]).
1787                  */
1788                 if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL))
1789                         || (valuePtr->bytes && (valuePtr->length == 0)))
1790                         || (((t2Ptr == NULL) && (value2Ptr->bytes == NULL))
1791                                 || (value2Ptr->bytes && (value2Ptr->length == 0))))) {
1792                     if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
1793                         s1 = Tcl_GetStringFromObj(valuePtr, &length);
1794                         if (TclLooksLikeInt(s1, length)) {
1795                             (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1796                                     valuePtr, &i);
1797                         } else {
1798                             (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1799                                     valuePtr, &d1);
1800                         }
1801                         t1Ptr = valuePtr->typePtr;
1802                     }
1803                     if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
1804                         s2 = Tcl_GetStringFromObj(value2Ptr, &length);
1805                         if (TclLooksLikeInt(s2, length)) {
1806                             (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1807                                     value2Ptr, &i2);
1808                         } else {
1809                             (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1810                                     value2Ptr, &d2);
1811                         }
1812                         t2Ptr = value2Ptr->typePtr;
1813                     }
1814                 }
1815                 if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType))
1816                         || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
1817                     /*
1818                      * One operand is not numeric. Compare as strings.
1819                      */
1820                     int cmpValue;
1821                     s1 = Tcl_GetString(valuePtr);
1822                     s2 = Tcl_GetString(value2Ptr);
1823                     cmpValue = strcmp(s1, s2);
1824                     switch (*pc) {
1825                     case INST_EQ:
1826                         iResult = (cmpValue == 0);
1827                         break;
1828                     case INST_NEQ:
1829                         iResult = (cmpValue != 0);
1830                         break;
1831                     case INST_LT:
1832                         iResult = (cmpValue < 0);
1833                         break;
1834                     case INST_GT:
1835                         iResult = (cmpValue > 0);
1836                         break;
1837                     case INST_LE:
1838                         iResult = (cmpValue <= 0);
1839                         break;
1840                     case INST_GE:
1841                         iResult = (cmpValue >= 0);
1842                         break;
1843                     }
1844                 } else if ((t1Ptr == &tclDoubleType)
1845                         || (t2Ptr == &tclDoubleType)) {
1846                     /*
1847                      * Compare as doubles.
1848                      */
1849                     if (t1Ptr == &tclDoubleType) {
1850                         d1 = valuePtr->internalRep.doubleValue;
1851                         if (t2Ptr == &tclIntType) {
1852                             d2 = value2Ptr->internalRep.longValue;
1853                         } else {
1854                             d2 = value2Ptr->internalRep.doubleValue;
1855                         }
1856                     } else {    /* t1Ptr is int, t2Ptr is double */
1857                         d1 = valuePtr->internalRep.longValue;
1858                         d2 = value2Ptr->internalRep.doubleValue;
1859                     }
1860                     switch (*pc) {
1861                     case INST_EQ:
1862                         iResult = d1 == d2;
1863                         break;
1864                     case INST_NEQ:
1865                         iResult = d1 != d2;
1866                         break;
1867                     case INST_LT:
1868                         iResult = d1 < d2;
1869                         break;
1870                     case INST_GT:
1871                         iResult = d1 > d2;
1872                         break;
1873                     case INST_LE:
1874                         iResult = d1 <= d2;
1875                         break;
1876                     case INST_GE:
1877                         iResult = d1 >= d2;
1878                         break;
1879                     }
1880                 } else {
1881                     /*
1882                      * Compare as ints.
1883                      */
1884                     i  = valuePtr->internalRep.longValue;
1885                     i2 = value2Ptr->internalRep.longValue;
1886                     switch (*pc) {
1887                     case INST_EQ:
1888                         iResult = i == i2;
1889                         break;
1890                     case INST_NEQ:
1891                         iResult = i != i2;
1892                         break;
1893                     case INST_LT:
1894                         iResult = i < i2;
1895                         break;
1896                     case INST_GT:
1897                         iResult = i > i2;
1898                         break;
1899                     case INST_LE:
1900                         iResult = i <= i2;
1901                         break;
1902                     case INST_GE:
1903                         iResult = i >= i2;
1904                         break;
1905                     }
1906                 }
1907
1908                 /*
1909                  * Reuse the valuePtr object already on stack if possible.
1910                  */
1911
1912                 if (Tcl_IsShared(valuePtr)) {
1913                     PUSH_OBJECT(Tcl_NewLongObj(iResult));
1914                     TRACE(("%.20s %.20s => %ld\n",
1915                            O2S(valuePtr), O2S(value2Ptr), iResult));
1916                     TclDecrRefCount(valuePtr);
1917                 } else {        /* reuse the valuePtr object */
1918                     TRACE(("%.20s %.20s => %ld\n",
1919                             O2S(valuePtr), O2S(value2Ptr), iResult));
1920                     Tcl_SetLongObj(valuePtr, iResult);
1921                     ++stackTop; /* valuePtr now on stk top has right r.c. */
1922                 }
1923                 TclDecrRefCount(value2Ptr);
1924             }
1925             ADJUST_PC(1);
1926
1927         case INST_MOD:
1928         case INST_LSHIFT:
1929         case INST_RSHIFT:
1930         case INST_BITOR:
1931         case INST_BITXOR:
1932         case INST_BITAND:
1933             {
1934                 /*
1935                  * Only integers are allowed. We compute value op value2.
1936                  */
1937
1938                 long i2, rem, negative;
1939                 long iResult = 0; /* Init. avoids compiler warning. */
1940
1941                 value2Ptr = POP_OBJECT();
1942                 valuePtr  = POP_OBJECT();
1943                 if (valuePtr->typePtr == &tclIntType) {
1944                     i = valuePtr->internalRep.longValue;
1945                 } else {        /* try to convert to int */
1946                     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1947                             valuePtr, &i);
1948                     if (result != TCL_OK) {
1949                         TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
1950                               O2S(valuePtr), O2S(value2Ptr),
1951                               (valuePtr->typePtr?
1952                                    valuePtr->typePtr->name : "null")));
1953                         IllegalExprOperandType(interp, pc, valuePtr);
1954                         Tcl_DecrRefCount(valuePtr);
1955                         Tcl_DecrRefCount(value2Ptr);
1956                         goto checkForCatch;
1957                     }
1958                 }
1959                 if (value2Ptr->typePtr == &tclIntType) {
1960                     i2 = value2Ptr->internalRep.longValue;
1961                 } else {
1962                     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1963                             value2Ptr, &i2);
1964                     if (result != TCL_OK) {
1965                         TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
1966                               O2S(valuePtr), O2S(value2Ptr),
1967                               (value2Ptr->typePtr?
1968                                    value2Ptr->typePtr->name : "null")));
1969                         IllegalExprOperandType(interp, pc, value2Ptr);
1970                         Tcl_DecrRefCount(valuePtr);
1971                         Tcl_DecrRefCount(value2Ptr);
1972                         goto checkForCatch;
1973                     }
1974                 }
1975
1976                 switch (*pc) {
1977                 case INST_MOD:
1978                     /*
1979                      * This code is tricky: C doesn't guarantee much about
1980                      * the quotient or remainder, but Tcl does. The
1981                      * remainder always has the same sign as the divisor and
1982                      * a smaller absolute value.
1983                      */
1984                     if (i2 == 0) {
1985                         TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
1986                         Tcl_DecrRefCount(valuePtr);
1987                         Tcl_DecrRefCount(value2Ptr);
1988                         goto divideByZero;
1989                     }
1990                     negative = 0;
1991                     if (i2 < 0) {
1992                         i2 = -i2;
1993                         i = -i;
1994                         negative = 1;
1995                     }
1996                     rem  = i % i2;
1997                     if (rem < 0) {
1998                         rem += i2;
1999                     }
2000                     if (negative) {
2001                         rem = -rem;
2002                     }
2003                     iResult = rem;
2004                     break;
2005                 case INST_LSHIFT:
2006                     iResult = i << i2;
2007                     break;
2008                 case INST_RSHIFT:
2009                     /*
2010                      * The following code is a bit tricky: it ensures that
2011                      * right shifts propagate the sign bit even on machines
2012                      * where ">>" won't do it by default.
2013                      */
2014                     if (i < 0) {
2015                         iResult = ~((~i) >> i2);
2016                     } else {
2017                         iResult = i >> i2;
2018                     }
2019                     break;
2020                 case INST_BITOR:
2021                     iResult = i | i2;
2022                     break;
2023                 case INST_BITXOR:
2024                     iResult = i ^ i2;
2025                     break;
2026                 case INST_BITAND:
2027                     iResult = i & i2;
2028                     break;
2029                 }
2030
2031                 /*
2032                  * Reuse the valuePtr object already on stack if possible.
2033                  */
2034
2035                 if (Tcl_IsShared(valuePtr)) {
2036                     PUSH_OBJECT(Tcl_NewLongObj(iResult));
2037                     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2038                     TclDecrRefCount(valuePtr);
2039                 } else {        /* reuse the valuePtr object */
2040                     TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2041                     Tcl_SetLongObj(valuePtr, iResult);
2042                     ++stackTop; /* valuePtr now on stk top has right r.c. */
2043                 }
2044                 TclDecrRefCount(value2Ptr);
2045             }
2046             ADJUST_PC(1);
2047
2048         case INST_ADD:
2049         case INST_SUB:
2050         case INST_MULT:
2051         case INST_DIV:
2052             {
2053                 /*
2054                  * Operands must be numeric and ints get converted to floats
2055                  * if necessary. We compute value op value2.
2056                  */
2057
2058                 Tcl_ObjType *t1Ptr, *t2Ptr;
2059                 long i2, quot, rem;
2060                 double d1, d2;
2061                 long iResult = 0;     /* Init. avoids compiler warning. */
2062                 double dResult = 0.0; /* Init. avoids compiler warning. */
2063                 int doDouble = 0;     /* 1 if doing floating arithmetic */
2064
2065                 value2Ptr = POP_OBJECT();
2066                 valuePtr  = POP_OBJECT();
2067                 t1Ptr = valuePtr->typePtr;
2068                 t2Ptr = value2Ptr->typePtr;
2069
2070                 if (t1Ptr == &tclIntType) {
2071                     i  = valuePtr->internalRep.longValue;
2072                 } else if ((t1Ptr == &tclDoubleType)
2073                         && (valuePtr->bytes == NULL)) {
2074                     /*
2075                      * We can only use the internal rep directly if there is
2076                      * no string rep.  Otherwise the string rep might actually
2077                      * look like an integer, which is preferred.
2078                      */
2079
2080                     d1 = valuePtr->internalRep.doubleValue;
2081                 } else {
2082                     char *s = Tcl_GetStringFromObj(valuePtr, &length);
2083                     if (TclLooksLikeInt(s, length)) {
2084                         result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2085                                 valuePtr, &i);
2086                     } else {
2087                         result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2088                                 valuePtr, &d1);
2089                     }
2090                     if (result != TCL_OK) {
2091                         TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
2092                                s, O2S(valuePtr),
2093                                (valuePtr->typePtr?
2094                                     valuePtr->typePtr->name : "null")));
2095                         IllegalExprOperandType(interp, pc, valuePtr);
2096                         Tcl_DecrRefCount(valuePtr);
2097                         Tcl_DecrRefCount(value2Ptr);
2098                         goto checkForCatch;
2099                     }
2100                     t1Ptr = valuePtr->typePtr;
2101                 }
2102
2103                 if (t2Ptr == &tclIntType) {
2104                     i2 = value2Ptr->internalRep.longValue;
2105                 } else if ((t2Ptr == &tclDoubleType)
2106                         && (value2Ptr->bytes == NULL)) {
2107                     /*
2108                      * We can only use the internal rep directly if there is
2109                      * no string rep.  Otherwise the string rep might actually
2110                      * look like an integer, which is preferred.
2111                      */
2112
2113                     d2 = value2Ptr->internalRep.doubleValue;
2114                 } else {
2115                     char *s = Tcl_GetStringFromObj(value2Ptr, &length);
2116                     if (TclLooksLikeInt(s, length)) {
2117                         result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2118                                 value2Ptr, &i2);
2119                     } else {
2120                         result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2121                                 value2Ptr, &d2);
2122                     }
2123                     if (result != TCL_OK) {
2124                         TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
2125                                O2S(value2Ptr), s,
2126                                (value2Ptr->typePtr?
2127                                     value2Ptr->typePtr->name : "null")));
2128                         IllegalExprOperandType(interp, pc, value2Ptr);
2129                         Tcl_DecrRefCount(valuePtr);
2130                         Tcl_DecrRefCount(value2Ptr);
2131                         goto checkForCatch;
2132                     }
2133                     t2Ptr = value2Ptr->typePtr;
2134                 }
2135
2136                 if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
2137                     /*
2138                      * Do double arithmetic.
2139                      */
2140                     doDouble = 1;
2141                     if (t1Ptr == &tclIntType) {
2142                         d1 = i;       /* promote value 1 to double */
2143                     } else if (t2Ptr == &tclIntType) {
2144                         d2 = i2;      /* promote value 2 to double */
2145                     }
2146                     switch (*pc) {
2147                     case INST_ADD:
2148                         dResult = d1 + d2;
2149                         break;
2150                     case INST_SUB:
2151                         dResult = d1 - d2;
2152                         break;
2153                     case INST_MULT:
2154                         dResult = d1 * d2;
2155                         break;
2156                     case INST_DIV:
2157                         if (d2 == 0.0) {
2158                             TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
2159                             Tcl_DecrRefCount(valuePtr);
2160                             Tcl_DecrRefCount(value2Ptr);
2161                             goto divideByZero;
2162                         }
2163                         dResult = d1 / d2;
2164                         break;
2165                     }
2166
2167                     /*
2168                      * Check now for IEEE floating-point error.
2169                      */
2170
2171                     if (IS_NAN(dResult) || IS_INF(dResult)) {
2172                         TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
2173                                O2S(valuePtr), O2S(value2Ptr)));
2174                         TclExprFloatError(interp, dResult);
2175                         result = TCL_ERROR;
2176                         Tcl_DecrRefCount(valuePtr);
2177                         Tcl_DecrRefCount(value2Ptr);
2178                         goto checkForCatch;
2179                     }
2180                 } else {
2181                     /*
2182                      * Do integer arithmetic.
2183                      */
2184                     switch (*pc) {
2185                     case INST_ADD:
2186                         iResult = i + i2;
2187                         break;
2188                     case INST_SUB:
2189                         iResult = i - i2;
2190                         break;
2191                     case INST_MULT:
2192                         iResult = i * i2;
2193                         break;
2194                     case INST_DIV:
2195                         /*
2196                          * This code is tricky: C doesn't guarantee much
2197                          * about the quotient or remainder, but Tcl does.
2198                          * The remainder always has the same sign as the
2199                          * divisor and a smaller absolute value.
2200                          */
2201                         if (i2 == 0) {
2202                             TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
2203                             Tcl_DecrRefCount(valuePtr);
2204                             Tcl_DecrRefCount(value2Ptr);
2205                             goto divideByZero;
2206                         }
2207                         if (i2 < 0) {
2208                             i2 = -i2;
2209                             i = -i;
2210                         }
2211                         quot = i / i2;
2212                         rem  = i % i2;
2213                         if (rem < 0) {
2214                             quot -= 1;
2215                         }
2216                         iResult = quot;
2217                         break;
2218                     }
2219                 }
2220
2221                 /*
2222                  * Reuse the valuePtr object already on stack if possible.
2223                  */
2224
2225                 if (Tcl_IsShared(valuePtr)) {
2226                     if (doDouble) {
2227                         PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
2228                         TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
2229                     } else {
2230                         PUSH_OBJECT(Tcl_NewLongObj(iResult));
2231                         TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2232                     }
2233                     TclDecrRefCount(valuePtr);
2234                 } else {            /* reuse the valuePtr object */
2235                     if (doDouble) { /* NB: stack top is off by 1 */
2236                         TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
2237                         Tcl_SetDoubleObj(valuePtr, dResult);
2238                     } else {
2239                         TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2240                         Tcl_SetLongObj(valuePtr, iResult);
2241                     }
2242                     ++stackTop; /* valuePtr now on stk top has right r.c. */
2243                 }
2244                 TclDecrRefCount(value2Ptr);
2245             }
2246             ADJUST_PC(1);
2247
2248         case INST_UPLUS:
2249             {
2250                 /*
2251                  * Operand must be numeric.
2252                  */
2253
2254                 double d;
2255                 Tcl_ObjType *tPtr;
2256
2257                 valuePtr = stackPtr[stackTop];
2258                 tPtr = valuePtr->typePtr;
2259                 if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2260                         || (valuePtr->bytes != NULL))) {
2261                     char *s = Tcl_GetStringFromObj(valuePtr, &length);
2262                     if (TclLooksLikeInt(s, length)) {
2263                         result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2264                                 valuePtr, &i);
2265                     } else {
2266                         result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2267                                 valuePtr, &d);
2268                     }
2269                     if (result != TCL_OK) {
2270                         TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
2271                                 s, (tPtr? tPtr->name : "null")));
2272                         IllegalExprOperandType(interp, pc, valuePtr);
2273                         goto checkForCatch;
2274                     }
2275                     tPtr = valuePtr->typePtr;
2276                 }
2277
2278                 /*
2279                  * Ensure that the operand's string rep is the same as the
2280                  * formatted version of its internal rep. This makes sure
2281                  * that "expr +000123" yields "83", not "000123". We
2282                  * implement this by _discarding_ the string rep since we
2283                  * know it will be regenerated, if needed later, by
2284                  * formatting the internal rep's value.
2285                  */
2286
2287                 if (Tcl_IsShared(valuePtr)) {
2288                     if (tPtr == &tclIntType) {
2289                         i = valuePtr->internalRep.longValue;
2290                         objPtr = Tcl_NewLongObj(i);
2291                     } else {
2292                         d = valuePtr->internalRep.doubleValue;
2293                         objPtr = Tcl_NewDoubleObj(d);
2294                     }
2295                     Tcl_IncrRefCount(objPtr);
2296                     Tcl_DecrRefCount(valuePtr);
2297                     valuePtr = objPtr;
2298                     stackPtr[stackTop] = valuePtr;
2299                 } else {
2300                     Tcl_InvalidateStringRep(valuePtr);
2301                 }
2302                 TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
2303             }
2304             ADJUST_PC(1);
2305
2306         case INST_UMINUS:
2307         case INST_LNOT:
2308             {
2309                 /*
2310                  * The operand must be numeric. If the operand object is
2311                  * unshared modify it directly, otherwise create a copy to
2312                  * modify: this is "copy on write". free any old string
2313                  * representation since it is now invalid.
2314                  */
2315
2316                 double d;
2317                 Tcl_ObjType *tPtr;
2318
2319                 valuePtr = POP_OBJECT();
2320                 tPtr = valuePtr->typePtr;
2321                 if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2322                         || (valuePtr->bytes != NULL))) {
2323                     if ((tPtr == &tclBooleanType)
2324                             && (valuePtr->bytes == NULL)) {
2325                         valuePtr->typePtr = &tclIntType;
2326                     } else {
2327                         char *s = Tcl_GetStringFromObj(valuePtr, &length);
2328                         if (TclLooksLikeInt(s, length)) {
2329                             result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2330                                     valuePtr, &i);
2331                         } else {
2332                             result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2333                                     valuePtr, &d);
2334                         }
2335                         if (result != TCL_OK) {
2336                             TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
2337                                     s, (tPtr? tPtr->name : "null")));
2338                             IllegalExprOperandType(interp, pc, valuePtr);
2339                             Tcl_DecrRefCount(valuePtr);
2340                             goto checkForCatch;
2341                         }
2342                     }
2343                     tPtr = valuePtr->typePtr;
2344                 }
2345
2346                 if (Tcl_IsShared(valuePtr)) {
2347                     /*
2348                      * Create a new object.
2349                      */
2350                     if (tPtr == &tclIntType) {
2351                         i = valuePtr->internalRep.longValue;
2352                         objPtr = Tcl_NewLongObj(
2353                                 (*pc == INST_UMINUS)? -i : !i);
2354                         TRACE_WITH_OBJ(("%ld => ", i), objPtr);
2355                     } else {
2356                         d = valuePtr->internalRep.doubleValue;
2357                         if (*pc == INST_UMINUS) {
2358                             objPtr = Tcl_NewDoubleObj(-d);
2359                         } else {
2360                             /*
2361                              * Should be able to use "!d", but apparently
2362                              * some compilers can't handle it.
2363                              */
2364                             objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
2365                         }
2366                         TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
2367                     }
2368                     PUSH_OBJECT(objPtr);
2369                     TclDecrRefCount(valuePtr);
2370                 } else {
2371                     /*
2372                      * valuePtr is unshared. Modify it directly.
2373                      */
2374                     if (tPtr == &tclIntType) {
2375                         i = valuePtr->internalRep.longValue;
2376                         Tcl_SetLongObj(valuePtr,
2377                                 (*pc == INST_UMINUS)? -i : !i);
2378                         TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
2379                     } else {
2380                         d = valuePtr->internalRep.doubleValue;
2381                         if (*pc == INST_UMINUS) {
2382                             Tcl_SetDoubleObj(valuePtr, -d);
2383                         } else {
2384                             /*
2385                              * Should be able to use "!d", but apparently
2386                              * some compilers can't handle it.
2387                              */
2388                             Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
2389                         }
2390                         TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
2391                     }
2392                     ++stackTop; /* valuePtr now on stk top has right r.c. */
2393                 }
2394             }
2395             ADJUST_PC(1);
2396
2397         case INST_BITNOT:
2398             {
2399                 /*
2400                  * The operand must be an integer. If the operand object is
2401                  * unshared modify it directly, otherwise modify a copy.
2402                  * Free any old string representation since it is now
2403                  * invalid.
2404                  */
2405
2406                 Tcl_ObjType *tPtr;
2407
2408                 valuePtr = POP_OBJECT();
2409                 tPtr = valuePtr->typePtr;
2410                 if (tPtr != &tclIntType) {
2411                     result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2412                             valuePtr, &i);
2413                     if (result != TCL_OK) {   /* try to convert to double */
2414                         TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
2415                                O2S(valuePtr), (tPtr? tPtr->name : "null")));
2416                         IllegalExprOperandType(interp, pc, valuePtr);
2417                         Tcl_DecrRefCount(valuePtr);
2418                         goto checkForCatch;
2419                     }
2420                 }
2421
2422                 i = valuePtr->internalRep.longValue;
2423                 if (Tcl_IsShared(valuePtr)) {
2424                     PUSH_OBJECT(Tcl_NewLongObj(~i));
2425                     TRACE(("0x%lx => (%lu)\n", i, ~i));
2426                     TclDecrRefCount(valuePtr);
2427                 } else {
2428                     /*
2429                      * valuePtr is unshared. Modify it directly.
2430                      */
2431                     Tcl_SetLongObj(valuePtr, ~i);
2432                     ++stackTop; /* valuePtr now on stk top has right r.c. */
2433                     TRACE(("0x%lx => (%lu)\n", i, ~i));
2434                 }
2435             }
2436             ADJUST_PC(1);
2437
2438         case INST_CALL_BUILTIN_FUNC1:
2439             opnd = TclGetUInt1AtPtr(pc+1);
2440             {
2441                 /*
2442                  * Call one of the built-in Tcl math functions.
2443                  */
2444
2445                 BuiltinFunc *mathFuncPtr;
2446                 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
2447
2448                 if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
2449                     TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
2450                     panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
2451                 }
2452                 mathFuncPtr = &(builtinFuncTable[opnd]);
2453                 DECACHE_STACK_INFO();
2454                 tsdPtr->mathInProgress++;
2455                 result = (*mathFuncPtr->proc)(interp, eePtr,
2456                         mathFuncPtr->clientData);
2457                 tsdPtr->mathInProgress--;
2458                 CACHE_STACK_INFO();
2459                 if (result != TCL_OK) {
2460                     goto checkForCatch;
2461                 }
2462                 TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
2463             }
2464             ADJUST_PC(2);
2465
2466         case INST_CALL_FUNC1:
2467             opnd = TclGetUInt1AtPtr(pc+1);
2468             {
2469                 /*
2470                  * Call a non-builtin Tcl math function previously
2471                  * registered by a call to Tcl_CreateMathFunc.
2472                  */
2473
2474                 int objc = opnd;   /* Number of arguments. The function name
2475                                     * is the 0-th argument. */
2476                 Tcl_Obj **objv;    /* The array of arguments. The function
2477                                     * name is objv[0]. */
2478                 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
2479
2480                 objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
2481                 DECACHE_STACK_INFO();
2482                 tsdPtr->mathInProgress++;
2483                 result = ExprCallMathFunc(interp, eePtr, objc, objv);
2484                 tsdPtr->mathInProgress--;
2485                 CACHE_STACK_INFO();
2486                 if (result != TCL_OK) {
2487                     goto checkForCatch;
2488                 }
2489                 TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
2490                 ADJUST_PC(2);
2491             }
2492
2493         case INST_TRY_CVT_TO_NUMERIC:
2494             {
2495                 /*
2496                  * Try to convert the topmost stack object to an int or
2497                  * double object. This is done in order to support Tcl's
2498                  * policy of interpreting operands if at all possible as
2499                  * first integers, else floating-point numbers.
2500                  */
2501
2502                 double d;
2503                 char *s;
2504                 Tcl_ObjType *tPtr;
2505                 int converted, shared;
2506
2507                 valuePtr = stackPtr[stackTop];
2508                 tPtr = valuePtr->typePtr;
2509                 converted = 0;
2510                 if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2511                         || (valuePtr->bytes != NULL))) {
2512                     if ((tPtr == &tclBooleanType)
2513                             && (valuePtr->bytes == NULL)) {
2514                         valuePtr->typePtr = &tclIntType;
2515                         converted = 1;
2516                     } else {
2517                         s = Tcl_GetStringFromObj(valuePtr, &length);
2518                         if (TclLooksLikeInt(s, length)) {
2519                             result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2520                                     valuePtr, &i);
2521                         } else {
2522                             result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2523                                     valuePtr, &d);
2524                         }
2525                         if (result == TCL_OK) {
2526                             converted = 1;
2527                        }
2528                         result = TCL_OK; /* reset the result variable */
2529                     }
2530                     tPtr = valuePtr->typePtr;
2531                 }
2532
2533                 /*
2534                  * Ensure that the topmost stack object, if numeric, has a
2535                  * string rep the same as the formatted version of its
2536                  * internal rep. This is used, e.g., to make sure that "expr
2537                  * {0001}" yields "1", not "0001". We implement this by
2538                  * _discarding_ the string rep since we know it will be
2539                  * regenerated, if needed later, by formatting the internal
2540                  * rep's value. Also check if there has been an IEEE
2541                  * floating point error.
2542                  */
2543
2544                 if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) {
2545                     shared = 0;
2546                     if (Tcl_IsShared(valuePtr)) {
2547                         shared = 1;
2548                         if (valuePtr->bytes != NULL) {
2549                             /*
2550                              * We only need to make a copy of the object
2551                              * when it already had a string rep
2552                              */
2553                             if (tPtr == &tclIntType) {
2554                                 i = valuePtr->internalRep.longValue;
2555                                 objPtr = Tcl_NewLongObj(i);
2556                             } else {
2557                                 d = valuePtr->internalRep.doubleValue;
2558                                 objPtr = Tcl_NewDoubleObj(d);
2559                             }
2560                             Tcl_IncrRefCount(objPtr);
2561                             TclDecrRefCount(valuePtr);
2562                             valuePtr = objPtr;
2563                             stackPtr[stackTop] = valuePtr;
2564                             tPtr = valuePtr->typePtr;
2565                         }
2566                     } else {
2567                         Tcl_InvalidateStringRep(valuePtr);
2568                     }
2569
2570                     if (tPtr == &tclDoubleType) {
2571                         d = valuePtr->internalRep.doubleValue;
2572                         if (IS_NAN(d) || IS_INF(d)) {
2573                             TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
2574                                    O2S(valuePtr)));
2575                             TclExprFloatError(interp, d);
2576                             result = TCL_ERROR;
2577                             goto checkForCatch;
2578                         }
2579                     }
2580                     shared = shared;        /* lint, shared not used. */
2581                     converted = converted;  /* lint, converted not used. */
2582                     TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
2583                            (converted? "converted" : "not converted"),
2584                            (shared? "shared" : "not shared")));
2585                 } else {
2586                     TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
2587                 }
2588             }
2589             ADJUST_PC(1);
2590
2591         case INST_BREAK:
2592             /*
2593              * First reset the interpreter's result. Then find the closest
2594              * enclosing loop or catch exception range, if any. If a loop is
2595              * found, terminate its execution. If the closest is a catch
2596              * exception range, jump to its catchOffset. If no enclosing
2597              * range is found, stop execution and return TCL_BREAK.
2598              */
2599
2600             Tcl_ResetResult(interp);
2601             rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
2602             if (rangePtr == NULL) {
2603                 TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
2604                 result = TCL_BREAK;
2605                 goto abnormalReturn; /* no catch exists to check */
2606             }
2607             switch (rangePtr->type) {
2608             case LOOP_EXCEPTION_RANGE:
2609                 result = TCL_OK;
2610                 TRACE(("=> range at %d, new pc %d\n",
2611                        rangePtr->codeOffset, rangePtr->breakOffset));
2612                 break;
2613             case CATCH_EXCEPTION_RANGE:
2614                 result = TCL_BREAK;
2615                 TRACE(("=> ...\n"));
2616                 goto processCatch; /* it will use rangePtr */
2617             default:
2618                 panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2619             }
2620             pc = (codePtr->codeStart + rangePtr->breakOffset);
2621             continue;   /* restart outer instruction loop at pc */
2622
2623         case INST_CONTINUE:
2624             /*
2625              * Find the closest enclosing loop or catch exception range,
2626              * if any. If a loop is found, skip to its next iteration.
2627              * If the closest is a catch exception range, jump to its
2628              * catchOffset. If no enclosing range is found, stop
2629              * execution and return TCL_CONTINUE.
2630              */
2631
2632             Tcl_ResetResult(interp);
2633             rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
2634             if (rangePtr == NULL) {
2635                 TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
2636                 result = TCL_CONTINUE;
2637                 goto abnormalReturn;
2638             }
2639             switch (rangePtr->type) {
2640             case LOOP_EXCEPTION_RANGE:
2641                 if (rangePtr->continueOffset == -1) {
2642                     TRACE(("=> loop w/o continue, checking for catch\n"));
2643                     goto checkForCatch;
2644                 } else {
2645                     result = TCL_OK;
2646                     TRACE(("=> range at %d, new pc %d\n",
2647                            rangePtr->codeOffset, rangePtr->continueOffset));
2648                 }
2649                 break;
2650             case CATCH_EXCEPTION_RANGE:
2651                 result = TCL_CONTINUE;
2652                 TRACE(("=> ...\n"));
2653                 goto processCatch; /* it will use rangePtr */
2654             default:
2655                 panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2656             }
2657             pc = (codePtr->codeStart + rangePtr->continueOffset);
2658             continue;   /* restart outer instruction loop at pc */
2659
2660         case INST_FOREACH_START4:
2661             opnd = TclGetUInt4AtPtr(pc+1);
2662             {
2663                 /*
2664                  * Initialize the temporary local var that holds the count
2665                  * of the number of iterations of the loop body to -1.
2666                  */
2667
2668                 ForeachInfo *infoPtr = (ForeachInfo *)
2669                     codePtr->auxDataArrayPtr[opnd].clientData;
2670                 int iterTmpIndex = infoPtr->loopCtTemp;
2671                 Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2672                 Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
2673                 Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
2674
2675                 if (oldValuePtr == NULL) {
2676                     iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
2677                     Tcl_IncrRefCount(iterVarPtr->value.objPtr);
2678                 } else {
2679                     Tcl_SetLongObj(oldValuePtr, -1);
2680                 }
2681                 TclSetVarScalar(iterVarPtr);
2682                 TclClearVarUndefined(iterVarPtr);
2683                 TRACE(("%u => loop iter count temp %d\n",
2684                         opnd, iterTmpIndex));
2685             }
2686             ADJUST_PC(5);
2687
2688         case INST_FOREACH_STEP4:
2689             opnd = TclGetUInt4AtPtr(pc+1);
2690             {
2691                 /*
2692                  * "Step" a foreach loop (i.e., begin its next iteration) by
2693                  * assigning the next value list element to each loop var.
2694                  */
2695
2696                 ForeachInfo *infoPtr = (ForeachInfo *)
2697                         codePtr->auxDataArrayPtr[opnd].clientData;
2698                 ForeachVarList *varListPtr;
2699                 int numLists = infoPtr->numLists;
2700                 Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2701                 Tcl_Obj *listPtr;
2702                 List *listRepPtr;
2703                 Var *iterVarPtr, *listVarPtr;
2704                 int iterNum, listTmpIndex, listLen, numVars;
2705                 int varIndex, valIndex, continueLoop, j;
2706
2707                 /*
2708                  * Increment the temp holding the loop iteration number.
2709                  */
2710
2711                 iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
2712                 valuePtr = iterVarPtr->value.objPtr;
2713                 iterNum = (valuePtr->internalRep.longValue + 1);
2714                 Tcl_SetLongObj(valuePtr, iterNum);
2715
2716                 /*
2717                  * Check whether all value lists are exhausted and we should
2718                  * stop the loop.
2719                  */
2720
2721                 continueLoop = 0;
2722                 listTmpIndex = infoPtr->firstValueTemp;
2723                 for (i = 0;  i < numLists;  i++) {
2724                     varListPtr = infoPtr->varLists[i];
2725                     numVars = varListPtr->numVars;
2726
2727                     listVarPtr = &(compiledLocals[listTmpIndex]);
2728                     listPtr = listVarPtr->value.objPtr;
2729                     result = Tcl_ListObjLength(interp, listPtr, &listLen);
2730                     if (result != TCL_OK) {
2731                         TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
2732                                 opnd, i, O2S(listPtr)),
2733                                 Tcl_GetObjResult(interp));
2734                         goto checkForCatch;
2735                     }
2736                     if (listLen > (iterNum * numVars)) {
2737                         continueLoop = 1;
2738                     }
2739                     listTmpIndex++;
2740                 }
2741
2742                 /*
2743                  * If some var in some var list still has a remaining list
2744                  * element iterate one more time. Assign to var the next
2745                  * element from its value list. We already checked above
2746                  * that each list temp holds a valid list object.
2747                  */
2748
2749                 if (continueLoop) {
2750                     listTmpIndex = infoPtr->firstValueTemp;
2751                     for (i = 0;  i < numLists;  i++) {
2752                         varListPtr = infoPtr->varLists[i];
2753                         numVars = varListPtr->numVars;
2754
2755                         listVarPtr = &(compiledLocals[listTmpIndex]);
2756                         listPtr = listVarPtr->value.objPtr;
2757                         listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
2758                         listLen = listRepPtr->elemCount;
2759
2760                         valIndex = (iterNum * numVars);
2761                         for (j = 0;  j < numVars;  j++) {
2762                             int setEmptyStr = 0;
2763                             if (valIndex >= listLen) {
2764                                 setEmptyStr = 1;
2765                                 valuePtr = Tcl_NewObj();
2766                             } else {
2767                                 valuePtr = listRepPtr->elements[valIndex];
2768                             }
2769
2770                             varIndex = varListPtr->varIndexes[j];
2771                             DECACHE_STACK_INFO();
2772                             value2Ptr = TclSetIndexedScalar(interp,
2773                                    varIndex, valuePtr, /*leaveErrorMsg*/ 1);
2774                             CACHE_STACK_INFO();
2775                             if (value2Ptr == NULL) {
2776                                 TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
2777                                        opnd, varIndex),
2778                                        Tcl_GetObjResult(interp));
2779                                 if (setEmptyStr) {
2780                                     Tcl_DecrRefCount(valuePtr);
2781                                 }
2782                                 result = TCL_ERROR;
2783                                 goto checkForCatch;
2784                             }
2785                             valIndex++;
2786                         }
2787                         listTmpIndex++;
2788                     }
2789                 }
2790
2791                 /*
2792                  * Push 1 if at least one value list had a remaining element
2793                  * and the loop should continue. Otherwise push 0.
2794                  */
2795
2796                 PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
2797                 TRACE(("%u => %d lists, iter %d, %s loop\n",
2798                         opnd, numLists, iterNum,
2799                         (continueLoop? "continue" : "exit")));
2800             }
2801             ADJUST_PC(5);
2802
2803         case INST_BEGIN_CATCH4:
2804             /*
2805              * Record start of the catch command with exception range index
2806              * equal to the operand. Push the current stack depth onto the
2807              * special catch stack.
2808              */
2809             catchStackPtr[++catchTop] = stackTop;
2810             TRACE(("%u => catchTop=%d, stackTop=%d\n",
2811                     TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
2812             ADJUST_PC(5);
2813
2814         case INST_END_CATCH:
2815             catchTop--;
2816             result = TCL_OK;
2817             TRACE(("=> catchTop=%d\n", catchTop));
2818             ADJUST_PC(1);
2819
2820         case INST_PUSH_RESULT:
2821             PUSH_OBJECT(Tcl_GetObjResult(interp));
2822             TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
2823             ADJUST_PC(1);
2824
2825         case INST_PUSH_RETURN_CODE:
2826             PUSH_OBJECT(Tcl_NewLongObj(result));
2827             TRACE(("=> %u\n", result));
2828             ADJUST_PC(1);
2829
2830         default:
2831             panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
2832         } /* end of switch on opCode */
2833
2834         /*
2835          * Division by zero in an expression. Control only reaches this
2836          * point by "goto divideByZero".
2837          */
2838
2839         divideByZero:
2840         Tcl_ResetResult(interp);
2841         Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
2842         Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
2843                          (char *) NULL);
2844         result = TCL_ERROR;
2845
2846         /*
2847          * Execution has generated an "exception" such as TCL_ERROR. If the
2848          * exception is an error, record information about what was being
2849          * executed when the error occurred. Find the closest enclosing
2850          * catch range, if any. If no enclosing catch range is found, stop
2851          * execution and return the "exception" code.
2852          */
2853
2854         checkForCatch:
2855         if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
2856             bytes = GetSrcInfoForPc(pc, codePtr, &length);
2857             if (bytes != NULL) {
2858                 Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
2859                 iPtr->flags |= ERR_ALREADY_LOGGED;
2860             }
2861         }
2862         rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
2863         if (rangePtr == NULL) {
2864 #ifdef TCL_COMPILE_DEBUG
2865             if (traceInstructions) {
2866                 fprintf(stdout, "   ... no enclosing catch, returning %s\n",
2867                         StringForResultCode(result));
2868             }
2869 #endif
2870             goto abnormalReturn;
2871         }
2872
2873         /*
2874          * A catch exception range (rangePtr) was found to handle an
2875          * "exception". It was found either by checkForCatch just above or
2876          * by an instruction during break, continue, or error processing.
2877          * Jump to its catchOffset after unwinding the operand stack to
2878          * the depth it had when starting to execute the range's catch
2879          * command.
2880          */
2881
2882         processCatch:
2883         while (stackTop > catchStackPtr[catchTop]) {
2884             valuePtr = POP_OBJECT();
2885             TclDecrRefCount(valuePtr);
2886         }
2887 #ifdef TCL_COMPILE_DEBUG
2888         if (traceInstructions) {
2889             fprintf(stdout, "  ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
2890                 rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
2891                 (unsigned int)(rangePtr->catchOffset));
2892         }
2893 #endif
2894         pc = (codePtr->codeStart + rangePtr->catchOffset);
2895         continue;               /* restart the execution loop at pc */
2896     } /* end of infinite loop dispatching on instructions */
2897
2898     /*
2899      * Abnormal return code. Restore the stack to state it had when starting
2900      * to execute the ByteCode.
2901      */
2902
2903     abnormalReturn:
2904     while (stackTop > initStackTop) {
2905         valuePtr = POP_OBJECT();
2906         Tcl_DecrRefCount(valuePtr);
2907     }
2908
2909     /*
2910      * Free the catch stack array if malloc'ed storage was used.
2911      */
2912
2913     done:
2914     if (catchStackPtr != catchStackStorage) {
2915         ckfree((char *) catchStackPtr);
2916     }
2917     eePtr->stackTop = initStackTop;
2918     return result;
2919 #undef STATIC_CATCH_STACK_SIZE
2920 }
2921 \f
2922 #ifdef TCL_COMPILE_DEBUG
2923 /*
2924  *----------------------------------------------------------------------
2925  *
2926  * PrintByteCodeInfo --
2927  *
2928  *      This procedure prints a summary about a bytecode object to stdout.
2929  *      It is called by TclExecuteByteCode when starting to execute the
2930  *      bytecode object if tclTraceExec has the value 2 or more.
2931  *
2932  * Results:
2933  *      None.
2934  *
2935  * Side effects:
2936  *      None.
2937  *
2938  *----------------------------------------------------------------------
2939  */
2940
2941 static void
2942 PrintByteCodeInfo(codePtr)
2943     register ByteCode *codePtr; /* The bytecode whose summary is printed
2944                                  * to stdout. */
2945 {
2946     Proc *procPtr = codePtr->procPtr;
2947     Interp *iPtr = (Interp *) *codePtr->interpHandle;
2948
2949     fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
2950             (unsigned int) codePtr, codePtr->refCount,
2951             codePtr->compileEpoch, (unsigned int) iPtr,
2952             iPtr->compileEpoch);
2953
2954     fprintf(stdout, "  Source: ");
2955     TclPrintSource(stdout, codePtr->source, 60);
2956
2957     fprintf(stdout, "\n  Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
2958             codePtr->numCommands, codePtr->numSrcBytes,
2959             codePtr->numCodeBytes, codePtr->numLitObjects,
2960             codePtr->numAuxDataItems, codePtr->maxStackDepth,
2961 #ifdef TCL_COMPILE_STATS
2962             (codePtr->numSrcBytes?
2963                     ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
2964 #else
2965             0.0);
2966 #endif
2967 #ifdef TCL_COMPILE_STATS
2968     fprintf(stdout, "  Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
2969             codePtr->structureSize,
2970             (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
2971             codePtr->numCodeBytes,
2972             (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
2973             (codePtr->numExceptRanges * sizeof(ExceptionRange)),
2974             (codePtr->numAuxDataItems * sizeof(AuxData)),
2975             codePtr->numCmdLocBytes);
2976 #endif /* TCL_COMPILE_STATS */
2977     if (procPtr != NULL) {
2978         fprintf(stdout,
2979                 "  Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
2980                 (unsigned int) procPtr, procPtr->refCount,
2981                 procPtr->numArgs, procPtr->numCompiledLocals);
2982     }
2983 }
2984 #endif /* TCL_COMPILE_DEBUG */
2985 \f
2986 /*
2987  *----------------------------------------------------------------------
2988  *
2989  * ValidatePcAndStackTop --
2990  *
2991  *      This procedure is called by TclExecuteByteCode when debugging to
2992  *      verify that the program counter and stack top are valid during
2993  *      execution.
2994  *
2995  * Results:
2996  *      None.
2997  *
2998  * Side effects:
2999  *      Prints a message to stderr and panics if either the pc or stack
3000  *      top are invalid.
3001  *
3002  *----------------------------------------------------------------------
3003  */
3004
3005 #ifdef TCL_COMPILE_DEBUG
3006 static void
3007 ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound,
3008         stackUpperBound)
3009     register ByteCode *codePtr; /* The bytecode whose summary is printed
3010                                  * to stdout. */
3011     unsigned char *pc;          /* Points to first byte of a bytecode
3012                                  * instruction. The program counter. */
3013     int stackTop;               /* Current stack top. Must be between
3014                                  * stackLowerBound and stackUpperBound
3015                                  * (inclusive). */
3016     int stackLowerBound;        /* Smallest legal value for stackTop. */
3017     int stackUpperBound;        /* Greatest legal value for stackTop. */
3018 {
3019     unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
3020     unsigned int codeStart = (unsigned int) codePtr->codeStart;
3021     unsigned int codeEnd = (unsigned int)
3022             (codePtr->codeStart + codePtr->numCodeBytes);
3023     unsigned char opCode = *pc;
3024
3025     if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
3026         fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
3027                 (unsigned int) pc);
3028         panic("TclExecuteByteCode execution failure: bad pc");
3029     }
3030     if ((unsigned int) opCode > LAST_INST_OPCODE) {
3031         fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
3032                 (unsigned int) opCode, relativePc);
3033         panic("TclExecuteByteCode execution failure: bad opcode");
3034     }
3035     if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
3036         int numChars;
3037         char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
3038         char *ellipsis = "";
3039
3040         fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
3041                 stackTop, relativePc);
3042         if (cmd != NULL) {
3043             if (numChars > 100) {
3044                 numChars = 100;
3045                 ellipsis = "...";
3046             }
3047             fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
3048                     ellipsis);
3049         } else {
3050             fprintf(stderr, "\n");
3051         }
3052         panic("TclExecuteByteCode execution failure: bad stack top");
3053     }
3054 }
3055 #endif /* TCL_COMPILE_DEBUG */
3056 \f
3057 /*
3058  *----------------------------------------------------------------------
3059  *
3060  * IllegalExprOperandType --
3061  *
3062  *      Used by TclExecuteByteCode to add an error message to errorInfo
3063  *      when an illegal operand type is detected by an expression
3064  *      instruction. The argument opndPtr holds the operand object in error.
3065  *
3066  * Results:
3067  *      None.
3068  *
3069  * Side effects:
3070  *      An error message is appended to errorInfo.
3071  *
3072  *----------------------------------------------------------------------
3073  */
3074
3075 static void
3076 IllegalExprOperandType(interp, pc, opndPtr)
3077     Tcl_Interp *interp;         /* Interpreter to which error information
3078                                  * pertains. */
3079     unsigned char *pc;          /* Points to the instruction being executed
3080                                  * when the illegal type was found. */
3081     Tcl_Obj *opndPtr;           /* Points to the operand holding the value
3082                                  * with the illegal type. */
3083 {
3084     unsigned char opCode = *pc;
3085
3086     Tcl_ResetResult(interp);
3087     if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
3088         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3089                 "can't use empty string as operand of \"",
3090                 operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
3091     } else {
3092         char *msg = "non-numeric string";
3093         if (opndPtr->typePtr != &tclDoubleType) {
3094             /*
3095              * See if the operand can be interpreted as a double in order to
3096              * improve the error message.
3097              */
3098
3099             char *s = Tcl_GetString(opndPtr);
3100             double d;
3101
3102             if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
3103                 /*
3104                  * Make sure that what appears to be a double
3105                  * (ie 08) isn't really a bad octal
3106                  */
3107                 if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) {
3108                     msg = "invalid octal number";
3109                 } else {
3110                     msg = "floating-point value";
3111                 }
3112             }
3113         }
3114         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
3115                 msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
3116                 "\"", (char *) NULL);
3117     }
3118 }
3119 \f
3120 /*
3121  *----------------------------------------------------------------------
3122  *
3123  * CallTraceProcedure --
3124  *
3125  *      Invokes a trace procedure registered with an interpreter. These
3126  *      procedures trace command execution. Currently this trace procedure
3127  *      is called with the address of the string-based Tcl_CmdProc for the
3128  *      command, not the Tcl_ObjCmdProc.
3129  *
3130  * Results:
3131  *      None.
3132  *
3133  * Side effects:
3134  *      Those side effects made by the trace procedure.
3135  *
3136  *----------------------------------------------------------------------
3137  */
3138
3139 static void
3140 CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
3141     Tcl_Interp *interp;         /* The current interpreter. */
3142     register Trace *tracePtr;   /* Describes the trace procedure to call. */
3143     Command *cmdPtr;            /* Points to command's Command struct. */
3144     char *command;              /* Points to the first character of the
3145                                  * command's source before substitutions. */
3146     int numChars;               /* The number of characters in the
3147                                  * command's source. */
3148     register int objc;          /* Number of arguments for the command. */
3149     Tcl_Obj *objv[];            /* Pointers to Tcl_Obj of each argument. */
3150 {
3151     Interp *iPtr = (Interp *) interp;
3152     register char **argv;
3153     register int i;
3154     int length;
3155     char *p;
3156
3157     /*
3158      * Get the string rep from the objv argument objects and place their
3159      * pointers in argv. First make sure argv is large enough to hold the
3160      * objc args plus 1 extra word for the zero end-of-argv word.
3161      */
3162
3163     argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
3164     for (i = 0;  i < objc;  i++) {
3165         argv[i] = Tcl_GetStringFromObj(objv[i], &length);
3166     }
3167     argv[objc] = 0;
3168
3169     /*
3170      * Copy the command characters into a new string.
3171      */
3172
3173     p = (char *) ckalloc((unsigned) (numChars + 1));
3174     memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
3175     p[numChars] = '\0';
3176
3177     /*
3178      * Call the trace procedure then free allocated storage.
3179      */
3180
3181     (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
3182                       p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
3183
3184     ckfree((char *) argv);
3185     ckfree((char *) p);
3186 }
3187 \f
3188 /*
3189  *----------------------------------------------------------------------
3190  *
3191  * GetSrcInfoForPc --
3192  *
3193  *      Given a program counter value, finds the closest command in the
3194  *      bytecode code unit's CmdLocation array and returns information about
3195  *      that command's source: a pointer to its first byte and the number of
3196  *      characters.
3197  *
3198  * Results:
3199  *      If a command is found that encloses the program counter value, a
3200  *      pointer to the command's source is returned and the length of the
3201  *      source is stored at *lengthPtr. If multiple commands resulted in
3202  *      code at pc, information about the closest enclosing command is
3203  *      returned. If no matching command is found, NULL is returned and
3204  *      *lengthPtr is unchanged.
3205  *
3206  * Side effects:
3207  *      None.
3208  *
3209  *----------------------------------------------------------------------
3210  */
3211
3212 static char *
3213 GetSrcInfoForPc(pc, codePtr, lengthPtr)
3214     unsigned char *pc;          /* The program counter value for which to
3215                                  * return the closest command's source info.
3216                                  * This points to a bytecode instruction
3217                                  * in codePtr's code. */
3218     ByteCode *codePtr;          /* The bytecode sequence in which to look
3219                                  * up the command source for the pc. */
3220     int *lengthPtr;             /* If non-NULL, the location where the
3221                                  * length of the command's source should be
3222                                  * stored. If NULL, no length is stored. */
3223 {
3224     register int pcOffset = (pc - codePtr->codeStart);
3225     int numCmds = codePtr->numCommands;
3226     unsigned char *codeDeltaNext, *codeLengthNext;
3227     unsigned char *srcDeltaNext, *srcLengthNext;
3228     int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
3229     int bestDist = INT_MAX;     /* Distance of pc to best cmd's start pc. */
3230     int bestSrcOffset = -1;     /* Initialized to avoid compiler warning. */
3231     int bestSrcLength = -1;     /* Initialized to avoid compiler warning. */
3232
3233     if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
3234         return NULL;
3235     }
3236
3237     /*
3238      * Decode the code and source offset and length for each command. The
3239      * closest enclosing command is the last one whose code started before
3240      * pcOffset.
3241      */
3242
3243     codeDeltaNext = codePtr->codeDeltaStart;
3244     codeLengthNext = codePtr->codeLengthStart;
3245     srcDeltaNext  = codePtr->srcDeltaStart;
3246     srcLengthNext = codePtr->srcLengthStart;
3247     codeOffset = srcOffset = 0;
3248     for (i = 0;  i < numCmds;  i++) {
3249         if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
3250             codeDeltaNext++;
3251             delta = TclGetInt4AtPtr(codeDeltaNext);
3252             codeDeltaNext += 4;
3253         } else {
3254             delta = TclGetInt1AtPtr(codeDeltaNext);
3255             codeDeltaNext++;
3256         }
3257         codeOffset += delta;
3258
3259         if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
3260             codeLengthNext++;
3261             codeLen = TclGetInt4AtPtr(codeLengthNext);
3262             codeLengthNext += 4;
3263         } else {
3264             codeLen = TclGetInt1AtPtr(codeLengthNext);
3265             codeLengthNext++;
3266         }
3267         codeEnd = (codeOffset + codeLen - 1);
3268
3269         if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
3270             srcDeltaNext++;
3271             delta = TclGetInt4AtPtr(srcDeltaNext);
3272             srcDeltaNext += 4;
3273         } else {
3274             delta = TclGetInt1AtPtr(srcDeltaNext);
3275             srcDeltaNext++;
3276         }
3277         srcOffset += delta;
3278
3279         if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
3280             srcLengthNext++;
3281             srcLen = TclGetInt4AtPtr(srcLengthNext);
3282             srcLengthNext += 4;
3283         } else {
3284             srcLen = TclGetInt1AtPtr(srcLengthNext);
3285             srcLengthNext++;
3286         }
3287
3288         if (codeOffset > pcOffset) {      /* best cmd already found */
3289             break;
3290         } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
3291             int dist = (pcOffset - codeOffset);
3292             if (dist <= bestDist) {
3293                 bestDist = dist;
3294                 bestSrcOffset = srcOffset;
3295                 bestSrcLength = srcLen;
3296             }
3297         }
3298     }
3299
3300     if (bestDist == INT_MAX) {
3301         return NULL;
3302     }
3303
3304     if (lengthPtr != NULL) {
3305         *lengthPtr = bestSrcLength;
3306     }
3307     return (codePtr->source + bestSrcOffset);
3308 }
3309 \f
3310 /*
3311  *----------------------------------------------------------------------
3312  *
3313  * GetExceptRangeForPc --
3314  *
3315  *      Given a program counter value, return the closest enclosing
3316  *      ExceptionRange.
3317  *
3318  * Results:
3319  *      In the normal case, catchOnly is 0 (false) and this procedure
3320  *      returns a pointer to the most closely enclosing ExceptionRange
3321  *      structure regardless of whether it is a loop or catch exception
3322  *      range. This is appropriate when processing a TCL_BREAK or
3323  *      TCL_CONTINUE, which will be "handled" either by a loop exception
3324  *      range or a closer catch range. If catchOnly is nonzero, this
3325  *      procedure ignores loop exception ranges and returns a pointer to the
3326  *      closest catch range. If no matching ExceptionRange is found that
3327  *      encloses pc, a NULL is returned.
3328  *
3329  * Side effects:
3330  *      None.
3331  *
3332  *----------------------------------------------------------------------
3333  */
3334
3335 static ExceptionRange *
3336 GetExceptRangeForPc(pc, catchOnly, codePtr)
3337     unsigned char *pc;          /* The program counter value for which to
3338                                  * search for a closest enclosing exception
3339                                  * range. This points to a bytecode
3340                                  * instruction in codePtr's code. */
3341     int catchOnly;              /* If 0, consider either loop or catch
3342                                  * ExceptionRanges in search. If nonzero
3343                                  * consider only catch ranges (and ignore
3344                                  * any closer loop ranges). */
3345     ByteCode* codePtr;          /* Points to the ByteCode in which to search
3346                                  * for the enclosing ExceptionRange. */
3347 {
3348     ExceptionRange *rangeArrayPtr;
3349     int numRanges = codePtr->numExceptRanges;
3350     register ExceptionRange *rangePtr;
3351     int pcOffset = (pc - codePtr->codeStart);
3352     register int i, level;
3353
3354     if (numRanges == 0) {
3355         return NULL;
3356     }
3357     rangeArrayPtr = codePtr->exceptArrayPtr;
3358
3359     for (level = codePtr->maxExceptDepth;  level >= 0;  level--) {
3360         for (i = 0;  i < numRanges;  i++) {
3361             rangePtr = &(rangeArrayPtr[i]);
3362             if (rangePtr->nestingLevel == level) {
3363                 int start = rangePtr->codeOffset;
3364                 int end   = (start + rangePtr->numCodeBytes);
3365                 if ((start <= pcOffset) && (pcOffset < end)) {
3366                     if ((!catchOnly)
3367                             || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
3368                         return rangePtr;
3369                     }
3370                 }
3371             }
3372         }
3373     }
3374     return NULL;
3375 }
3376 \f
3377 /*
3378  *----------------------------------------------------------------------
3379  *
3380  * GetOpcodeName --
3381  *
3382  *      This procedure is called by the TRACE and TRACE_WITH_OBJ macros
3383  *      used in TclExecuteByteCode when debugging. It returns the name of
3384  *      the bytecode instruction at a specified instruction pc.
3385  *
3386  * Results:
3387  *      A character string for the instruction.
3388  *
3389  * Side effects:
3390  *      None.
3391  *
3392  *----------------------------------------------------------------------
3393  */
3394
3395 #ifdef TCL_COMPILE_DEBUG
3396 static char *
3397 GetOpcodeName(pc)
3398     unsigned char *pc;          /* Points to the instruction whose name
3399                                  * should be returned. */
3400 {
3401     unsigned char opCode = *pc;
3402
3403     return instructionTable[opCode].name;
3404 }
3405 #endif /* TCL_COMPILE_DEBUG */
3406 \f
3407 /*
3408  *----------------------------------------------------------------------
3409  *
3410  * VerifyExprObjType --
3411  *
3412  *      This procedure is called by the math functions to verify that
3413  *      the object is either an int or double, coercing it if necessary.
3414  *      If an error occurs during conversion, an error message is left
3415  *      in the interpreter's result unless "interp" is NULL.
3416  *
3417  * Results:
3418  *      TCL_OK if it was int or double, TCL_ERROR otherwise
3419  *
3420  * Side effects:
3421  *      objPtr is ensured to be either tclIntType of tclDoubleType.
3422  *
3423  *----------------------------------------------------------------------
3424  */
3425
3426 static int
3427 VerifyExprObjType(interp, objPtr)
3428     Tcl_Interp *interp;         /* The interpreter in which to execute the
3429                                  * function. */
3430     Tcl_Obj *objPtr;            /* Points to the object to type check. */
3431 {
3432     if ((objPtr->typePtr == &tclIntType) ||
3433             (objPtr->typePtr == &tclDoubleType)) {
3434         return TCL_OK;
3435     } else {
3436         int length, result = TCL_OK;
3437         char *s = Tcl_GetStringFromObj(objPtr, &length);
3438
3439         if (TclLooksLikeInt(s, length)) {
3440             long i;
3441             result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i);
3442         } else {
3443             double d;
3444             result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
3445         }
3446         if ((result != TCL_OK) && (interp != NULL)) {
3447             Tcl_ResetResult(interp);
3448             if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
3449                 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3450                         "argument to math function was an invalid octal number",
3451                         -1);
3452             } else {
3453                 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3454                         "argument to math function didn't have numeric value",
3455                         -1);
3456             }
3457         }
3458         return result;
3459     }
3460 }
3461 \f
3462 /*
3463  *----------------------------------------------------------------------
3464  *
3465  * Math Functions --
3466  *
3467  *      This page contains the procedures that implement all of the
3468  *      built-in math functions for expressions.
3469  *
3470  * Results:
3471  *      Each procedure returns TCL_OK if it succeeds and pushes an
3472  *      Tcl object holding the result. If it fails it returns TCL_ERROR
3473  *      and leaves an error message in the interpreter's result.
3474  *
3475  * Side effects:
3476  *      None.
3477  *
3478  *----------------------------------------------------------------------
3479  */
3480
3481 static int
3482 ExprUnaryFunc(interp, eePtr, clientData)
3483     Tcl_Interp *interp;         /* The interpreter in which to execute the
3484                                  * function. */
3485     ExecEnv *eePtr;             /* Points to the environment for executing
3486                                  * the function. */
3487     ClientData clientData;      /* Contains the address of a procedure that
3488                                  * takes one double argument and returns a
3489                                  * double result. */
3490 {
3491     Tcl_Obj **stackPtr;         /* Cached evaluation stack base pointer. */
3492     register int stackTop;      /* Cached top index of evaluation stack. */
3493     register Tcl_Obj *valuePtr;
3494     double d, dResult;
3495     int result;
3496
3497     double (*func) _ANSI_ARGS_((double)) =
3498         (double (*)_ANSI_ARGS_((double))) clientData;
3499
3500     /*
3501      * Set stackPtr and stackTop from eePtr.
3502      */
3503
3504     result = TCL_OK;
3505     CACHE_STACK_INFO();
3506
3507     /*
3508      * Pop the function's argument from the evaluation stack. Convert it
3509      * to a double if necessary.
3510      */
3511
3512     valuePtr = POP_OBJECT();
3513
3514     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3515         result = TCL_ERROR;
3516         goto done;
3517     }
3518
3519     if (valuePtr->typePtr == &tclIntType) {
3520         d = (double) valuePtr->internalRep.longValue;
3521     } else {
3522         d = valuePtr->internalRep.doubleValue;
3523     }
3524
3525     errno = 0;
3526     dResult = (*func)(d);
3527     if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
3528         TclExprFloatError(interp, dResult);
3529         result = TCL_ERROR;
3530         goto done;
3531     }
3532
3533     /*
3534      * Push a Tcl object holding the result.
3535      */
3536
3537     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3538
3539     /*
3540      * Reflect the change to stackTop back in eePtr.
3541      */
3542
3543     done:
3544     Tcl_DecrRefCount(valuePtr);
3545     DECACHE_STACK_INFO();
3546     return result;
3547 }
3548
3549 static int
3550 ExprBinaryFunc(interp, eePtr, clientData)
3551     Tcl_Interp *interp;         /* The interpreter in which to execute the
3552                                  * function. */
3553     ExecEnv *eePtr;             /* Points to the environment for executing
3554                                  * the function. */
3555     ClientData clientData;      /* Contains the address of a procedure that
3556                                  * takes two double arguments and
3557                                  * returns a double result. */
3558 {
3559     Tcl_Obj **stackPtr;        /* Cached evaluation stack base pointer. */
3560     register int stackTop;      /* Cached top index of evaluation stack. */
3561     register Tcl_Obj *valuePtr, *value2Ptr;
3562     double d1, d2, dResult;
3563     int result;
3564
3565     double (*func) _ANSI_ARGS_((double, double))
3566         = (double (*)_ANSI_ARGS_((double, double))) clientData;
3567
3568     /*
3569      * Set stackPtr and stackTop from eePtr.
3570      */
3571
3572     result = TCL_OK;
3573     CACHE_STACK_INFO();
3574
3575     /*
3576      * Pop the function's two arguments from the evaluation stack. Convert
3577      * them to doubles if necessary.
3578      */
3579
3580     value2Ptr = POP_OBJECT();
3581     valuePtr  = POP_OBJECT();
3582
3583     if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
3584             (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
3585         result = TCL_ERROR;
3586         goto done;
3587     }
3588
3589     if (valuePtr->typePtr == &tclIntType) {
3590         d1 = (double) valuePtr->internalRep.longValue;
3591     } else {
3592         d1 = valuePtr->internalRep.doubleValue;
3593     }
3594
3595     if (value2Ptr->typePtr == &tclIntType) {
3596         d2 = (double) value2Ptr->internalRep.longValue;
3597     } else {
3598         d2 = value2Ptr->internalRep.doubleValue;
3599     }
3600
3601     errno = 0;
3602     dResult = (*func)(d1, d2);
3603     if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
3604         TclExprFloatError(interp, dResult);
3605         result = TCL_ERROR;
3606         goto done;
3607     }
3608
3609     /*
3610      * Push a Tcl object holding the result.
3611      */
3612
3613     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3614
3615     /*
3616      * Reflect the change to stackTop back in eePtr.
3617      */
3618
3619     done:
3620     Tcl_DecrRefCount(valuePtr);
3621     Tcl_DecrRefCount(value2Ptr);
3622     DECACHE_STACK_INFO();
3623     return result;
3624 }
3625
3626 static int
3627 ExprAbsFunc(interp, eePtr, clientData)
3628     Tcl_Interp *interp;         /* The interpreter in which to execute the
3629                                  * function. */
3630     ExecEnv *eePtr;             /* Points to the environment for executing
3631                                  * the function. */
3632     ClientData clientData;      /* Ignored. */
3633 {
3634     Tcl_Obj **stackPtr;        /* Cached evaluation stack base pointer. */
3635     register int stackTop;      /* Cached top index of evaluation stack. */
3636     register Tcl_Obj *valuePtr;
3637     long i, iResult;
3638     double d, dResult;
3639     int result;
3640
3641     /*
3642      * Set stackPtr and stackTop from eePtr.
3643      */
3644
3645     result = TCL_OK;
3646     CACHE_STACK_INFO();
3647
3648     /*
3649      * Pop the argument from the evaluation stack.
3650      */
3651
3652     valuePtr = POP_OBJECT();
3653
3654     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3655         result = TCL_ERROR;
3656         goto done;
3657     }
3658
3659     /*
3660      * Push a Tcl object with the result.
3661      */
3662     if (valuePtr->typePtr == &tclIntType) {
3663         i = valuePtr->internalRep.longValue;
3664         if (i < 0) {
3665             iResult = -i;
3666             if (iResult < 0) {
3667                 Tcl_ResetResult(interp);
3668                 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3669                         "integer value too large to represent", -1);
3670                 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3671                         "integer value too large to represent", (char *) NULL);
3672                 result = TCL_ERROR;
3673                 goto done;
3674             }
3675         } else {
3676             iResult = i;
3677         }
3678         PUSH_OBJECT(Tcl_NewLongObj(iResult));
3679     } else {
3680         d = valuePtr->internalRep.doubleValue;
3681         if (d < 0.0) {
3682             dResult = -d;
3683         } else {
3684             dResult = d;
3685         }
3686         if (IS_NAN(dResult) || IS_INF(dResult)) {
3687             TclExprFloatError(interp, dResult);
3688             result = TCL_ERROR;
3689             goto done;
3690         }
3691         PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3692     }
3693
3694     /*
3695      * Reflect the change to stackTop back in eePtr.
3696      */
3697
3698     done:
3699     Tcl_DecrRefCount(valuePtr);
3700     DECACHE_STACK_INFO();
3701     return result;
3702 }
3703
3704 static int
3705 ExprDoubleFunc(interp, eePtr, clientData)
3706     Tcl_Interp *interp;         /* The interpreter in which to execute the
3707                                  * function. */
3708     ExecEnv *eePtr;             /* Points to the environment for executing
3709                                  * the function. */
3710     ClientData clientData;      /* Ignored. */
3711 {
3712     Tcl_Obj **stackPtr;        /* Cached evaluation stack base pointer. */
3713     register int stackTop;      /* Cached top index of evaluation stack. */
3714     register Tcl_Obj *valuePtr;
3715     double dResult;
3716     int result;
3717
3718     /*
3719      * Set stackPtr and stackTop from eePtr.
3720      */
3721
3722     result = TCL_OK;
3723     CACHE_STACK_INFO();
3724
3725     /*
3726      * Pop the argument from the evaluation stack.
3727      */
3728
3729     valuePtr = POP_OBJECT();
3730
3731     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3732         result = TCL_ERROR;
3733         goto done;
3734     }
3735
3736     if (valuePtr->typePtr == &tclIntType) {
3737         dResult = (double) valuePtr->internalRep.longValue;
3738     } else {
3739         dResult = valuePtr->internalRep.doubleValue;
3740     }
3741
3742     /*
3743      * Push a Tcl object with the result.
3744      */
3745
3746     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3747
3748     /*
3749      * Reflect the change to stackTop back in eePtr.
3750      */
3751
3752     done:
3753     Tcl_DecrRefCount(valuePtr);
3754     DECACHE_STACK_INFO();
3755     return result;
3756 }
3757
3758 static int
3759 ExprIntFunc(interp, eePtr, clientData)
3760     Tcl_Interp *interp;         /* The interpreter in which to execute the
3761                                  * function. */
3762     ExecEnv *eePtr;             /* Points to the environment for executing
3763                                  * the function. */
3764     ClientData clientData;      /* Ignored. */
3765 {
3766     Tcl_Obj **stackPtr;        /* Cached evaluation stack base pointer. */
3767     register int stackTop;      /* Cached top index of evaluation stack. */
3768     register Tcl_Obj *valuePtr;
3769     long iResult;
3770     double d;
3771     int result;
3772
3773     /*
3774      * Set stackPtr and stackTop from eePtr.
3775      */
3776
3777     result = TCL_OK;
3778     CACHE_STACK_INFO();
3779
3780     /*
3781      * Pop the argument from the evaluation stack.
3782      */
3783
3784     valuePtr = POP_OBJECT();
3785
3786     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3787         result = TCL_ERROR;
3788         goto done;
3789     }
3790
3791     if (valuePtr->typePtr == &tclIntType) {
3792         iResult = valuePtr->internalRep.longValue;
3793     } else {
3794         d = valuePtr->internalRep.doubleValue;
3795         if (d < 0.0) {
3796             if (d < (double) (long) LONG_MIN) {
3797                 tooLarge:
3798                 Tcl_ResetResult(interp);
3799                 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3800                         "integer value too large to represent", -1);
3801                 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3802                         "integer value too large to represent", (char *) NULL);
3803                 result = TCL_ERROR;
3804                 goto done;
3805             }
3806         } else {
3807             if (d > (double) LONG_MAX) {
3808                 goto tooLarge;
3809             }
3810         }
3811         if (IS_NAN(d) || IS_INF(d)) {
3812             TclExprFloatError(interp, d);
3813             result = TCL_ERROR;
3814             goto done;
3815         }
3816         iResult = (long) d;
3817     }
3818
3819     /*
3820      * Push a Tcl object with the result.
3821      */
3822
3823     PUSH_OBJECT(Tcl_NewLongObj(iResult));
3824
3825     /*
3826      * Reflect the change to stackTop back in eePtr.
3827      */
3828
3829     done:
3830     Tcl_DecrRefCount(valuePtr);
3831     DECACHE_STACK_INFO();
3832     return result;
3833 }
3834
3835 static int
3836 ExprRandFunc(interp, eePtr, clientData)
3837     Tcl_Interp *interp;         /* The interpreter in which to execute the
3838                                  * function. */
3839     ExecEnv *eePtr;             /* Points to the environment for executing
3840                                  * the function. */
3841     ClientData clientData;      /* Ignored. */
3842 {
3843     Tcl_Obj **stackPtr;        /* Cached evaluation stack base pointer. */
3844     register int stackTop;      /* Cached top index of evaluation stack. */
3845     Interp *iPtr = (Interp *) interp;
3846     double dResult;
3847     int tmp;
3848
3849     if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
3850         iPtr->flags |= RAND_SEED_INITIALIZED;
3851         iPtr->randSeed = TclpGetClicks();
3852     }
3853
3854     /*
3855      * Set stackPtr and stackTop from eePtr.
3856      */
3857
3858     CACHE_STACK_INFO();
3859
3860     /*
3861      * Generate the random number using the linear congruential
3862      * generator defined by the following recurrence:
3863      *          seed = ( IA * seed ) mod IM
3864      * where IA is 16807 and IM is (2^31) - 1.  In order to avoid
3865      * potential problems with integer overflow, the  code uses
3866      * additional constants IQ and IR such that
3867      *          IM = IA*IQ + IR
3868      * For details on how this algorithm works, refer to the following
3869      * papers:
3870      *
3871      *  S.K. Park & K.W. Miller, "Random number generators: good ones
3872      *  are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
3873      *
3874      *  W.H. Press & S.A. Teukolsky, "Portable random number
3875      *  generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
3876      */
3877
3878 #define RAND_IA         16807
3879 #define RAND_IM         2147483647
3880 #define RAND_IQ         127773
3881 #define RAND_IR         2836
3882 #define RAND_MASK       123459876
3883
3884     if (iPtr->randSeed == 0) {
3885         /*
3886          * Don't allow a 0 seed, since it breaks the generator.  Shift
3887          * it to some other value.
3888          */
3889
3890         iPtr->randSeed = 123459876;
3891     }
3892     tmp = iPtr->randSeed/RAND_IQ;
3893     iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
3894     if (iPtr->randSeed < 0) {
3895         iPtr->randSeed += RAND_IM;
3896     }
3897
3898     /*
3899      * On 64-bit architectures we need to mask off the upper bits to
3900      * ensure we only have a 32-bit range.  The constant has the
3901      * bizarre form below in order to make sure that it doesn't
3902      * get sign-extended (the rules for sign extension are very
3903      * concat, particularly on 64-bit machines).
3904      */
3905
3906     iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
3907     dResult = iPtr->randSeed * (1.0/RAND_IM);
3908
3909     /*
3910      * Push a Tcl object with the result.
3911      */
3912
3913     PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3914
3915     /*
3916      * Reflect the change to stackTop back in eePtr.
3917      */
3918
3919     DECACHE_STACK_INFO();
3920     return TCL_OK;
3921 }
3922
3923 static int
3924 ExprRoundFunc(interp, eePtr, clientData)
3925     Tcl_Interp *interp;         /* The interpreter in which to execute the
3926                                  * function. */
3927     ExecEnv *eePtr;             /* Points to the environment for executing
3928                                  * the function. */
3929     ClientData clientData;      /* Ignored. */
3930 {
3931     Tcl_Obj **stackPtr;        /* Cached evaluation stack base pointer. */
3932     register int stackTop;      /* Cached top index of evaluation stack. */
3933     Tcl_Obj *valuePtr;
3934     long iResult;
3935     double d, temp;
3936     int result;
3937
3938     /*
3939      * Set stackPtr and stackTop from eePtr.
3940      */
3941
3942     result = TCL_OK;
3943     CACHE_STACK_INFO();
3944
3945     /*
3946      * Pop the argument from the evaluation stack.
3947      */
3948
3949     valuePtr = POP_OBJECT();
3950
3951     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3952         result = TCL_ERROR;
3953         goto done;
3954     }
3955
3956     if (valuePtr->typePtr == &tclIntType) {
3957         iResult = valuePtr->internalRep.longValue;
3958     } else {
3959         d = valuePtr->internalRep.doubleValue;
3960         if (d < 0.0) {
3961             if (d <= (((double) (long) LONG_MIN) - 0.5)) {
3962                 tooLarge:
3963                 Tcl_ResetResult(interp);
3964                 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3965                         "integer value too large to represent", -1);
3966                 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3967                         "integer value too large to represent",
3968                         (char *) NULL);
3969                 result = TCL_ERROR;
3970                 goto done;
3971             }
3972             temp = (long) (d - 0.5);
3973         } else {
3974             if (d >= (((double) LONG_MAX + 0.5))) {
3975                 goto tooLarge;
3976             }
3977             temp = (long) (d + 0.5);
3978         }
3979         if (IS_NAN(temp) || IS_INF(temp)) {
3980             TclExprFloatError(interp, temp);
3981             result = TCL_ERROR;
3982             goto done;
3983         }
3984         iResult = (long) temp;
3985     }
3986
3987     /*
3988      * Push a Tcl object with the result.
3989      */
3990
3991     PUSH_OBJECT(Tcl_NewLongObj(iResult));
3992
3993     /*
3994      * Reflect the change to stackTop back in eePtr.
3995      */
3996
3997     done:
3998     Tcl_DecrRefCount(valuePtr);
3999     DECACHE_STACK_INFO();
4000     return result;
4001 }
4002
4003 static int
4004 ExprSrandFunc(interp, eePtr, clientData)
4005     Tcl_Interp *interp;         /* The interpreter in which to execute the
4006                                  * function. */
4007     ExecEnv *eePtr;             /* Points to the environment for executing
4008                                  * the function. */
4009     ClientData clientData;      /* Ignored. */
4010 {
4011     Tcl_Obj **stackPtr;        /* Cached evaluation stack base pointer. */
4012     register int stackTop;      /* Cached top index of evaluation stack. */
4013     Interp *iPtr = (Interp *) interp;
4014     Tcl_Obj *valuePtr;
4015     long i = 0;                 /* Initialized to avoid compiler warning. */
4016     int result;
4017
4018     /*
4019      * Set stackPtr and stackTop from eePtr.
4020      */
4021
4022     CACHE_STACK_INFO();
4023
4024     /*
4025      * Pop the argument from the evaluation stack.  Use the value
4026      * to reset the random number seed.
4027      */
4028
4029     valuePtr = POP_OBJECT();
4030
4031     if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
4032         result = TCL_ERROR;
4033         goto badValue;
4034     }
4035
4036     if (valuePtr->typePtr == &tclIntType) {
4037         i = valuePtr->internalRep.longValue;
4038     } else {
4039         /*
4040          * At this point, the only other possible type is double
4041          */
4042         Tcl_ResetResult(interp);
4043         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
4044                 "can't use floating-point value as argument to srand",
4045                 (char *) NULL);
4046         badValue:
4047         Tcl_DecrRefCount(valuePtr);
4048         DECACHE_STACK_INFO();
4049         return TCL_ERROR;
4050     }
4051
4052     /*
4053      * Reset the seed.
4054      */
4055
4056     iPtr->flags |= RAND_SEED_INITIALIZED;
4057     iPtr->randSeed = i;
4058
4059     /*
4060      * To avoid duplicating the random number generation code we simply
4061      * clean up our state and call the real random number function. That
4062      * function will always succeed.
4063      */
4064
4065     Tcl_DecrRefCount(valuePtr);
4066     DECACHE_STACK_INFO();
4067
4068     ExprRandFunc(interp, eePtr, clientData);
4069     return TCL_OK;
4070 }
4071 \f
4072 /*
4073  *----------------------------------------------------------------------
4074  *
4075  * ExprCallMathFunc --
4076  *
4077  *      This procedure is invoked to call a non-builtin math function
4078  *      during the execution of an expression.
4079  *
4080  * Results:
4081  *      TCL_OK is returned if all went well and the function's value
4082  *      was computed successfully. If an error occurred, TCL_ERROR
4083  *      is returned and an error message is left in the interpreter's
4084  *      result. After a successful return this procedure pushes a Tcl object
4085  *      holding the result.
4086  *
4087  * Side effects:
4088  *      None, unless the called math function has side effects.
4089  *
4090  *----------------------------------------------------------------------
4091  */
4092
4093 static int
4094 ExprCallMathFunc(interp, eePtr, objc, objv)
4095     Tcl_Interp *interp;         /* The interpreter in which to execute the
4096                                  * function. */
4097     ExecEnv *eePtr;             /* Points to the environment for executing
4098                                  * the function. */
4099     int objc;                   /* Number of arguments. The function name is
4100                                  * the 0-th argument. */
4101     Tcl_Obj **objv;             /* The array of arguments. The function name
4102                                  * is objv[0]. */
4103 {
4104     Interp *iPtr = (Interp *) interp;
4105     Tcl_Obj **stackPtr;         /* Cached evaluation stack base pointer. */
4106     register int stackTop;      /* Cached top index of evaluation stack. */
4107     char *funcName;
4108     Tcl_HashEntry *hPtr;
4109     MathFunc *mathFuncPtr;      /* Information about math function. */
4110     Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
4111     Tcl_Value funcResult;       /* Result of function call as Tcl_Value. */
4112     register Tcl_Obj *valuePtr;
4113     long i;
4114     double d;
4115     int j, k, result;
4116     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
4117
4118     Tcl_ResetResult(interp);
4119
4120     /*
4121      * Set stackPtr and stackTop from eePtr.
4122      */
4123
4124     CACHE_STACK_INFO();
4125
4126     /*
4127      * Look up the MathFunc record for the function.
4128      */
4129
4130     funcName = Tcl_GetString(objv[0]);
4131     hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
4132     if (hPtr == NULL) {
4133         Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
4134                 "unknown math function \"", funcName, "\"", (char *) NULL);
4135         result = TCL_ERROR;
4136         goto done;
4137     }
4138     mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
4139     if (mathFuncPtr->numArgs != (objc-1)) {
4140         panic("ExprCallMathFunc: expected number of args %d != actual number %d",
4141                 mathFuncPtr->numArgs, objc);
4142         result = TCL_ERROR;
4143         goto done;
4144     }
4145
4146     /*
4147      * Collect the arguments for the function, if there are any, into the
4148      * array "args". Note that args[0] will have the Tcl_Value that
4149      * corresponds to objv[1].
4150      */
4151
4152     for (j = 1, k = 0;  j < objc;  j++, k++) {
4153         valuePtr = objv[j];
4154
4155         if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
4156             result = TCL_ERROR;
4157             goto done;
4158         }
4159
4160         /*
4161          * Copy the object's numeric value to the argument record,
4162          * converting it if necessary.
4163          */
4164
4165         if (valuePtr->typePtr == &tclIntType) {
4166             i = valuePtr->internalRep.longValue;
4167             if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
4168                 args[k].type = TCL_DOUBLE;
4169                 args[k].doubleValue = i;
4170             } else {
4171                 args[k].type = TCL_INT;
4172                 args[k].intValue = i;
4173             }
4174         } else {
4175             d = valuePtr->internalRep.doubleValue;
4176             if (mathFuncPtr->argTypes[k] == TCL_INT) {
4177                 args[k].type = TCL_INT;
4178                 args[k].intValue = (long) d;
4179             } else {
4180                 args[k].type = TCL_DOUBLE;
4181                 args[k].doubleValue = d;
4182             }
4183         }
4184     }
4185
4186     /*
4187      * Invoke the function and copy its result back into valuePtr.
4188      */
4189
4190     tsdPtr->mathInProgress++;
4191     result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
4192             &funcResult);
4193     tsdPtr->mathInProgress--;
4194     if (result != TCL_OK) {
4195         goto done;
4196     }
4197
4198     /*
4199      * Pop the objc top stack elements and decrement their ref counts.
4200      */
4201
4202     i = (stackTop - (objc-1));
4203     while (i <= stackTop) {
4204         valuePtr = stackPtr[i];
4205         Tcl_DecrRefCount(valuePtr);
4206         i++;
4207     }
4208     stackTop -= objc;
4209
4210     /*
4211      * Push the call's object result.
4212      */
4213
4214     if (funcResult.type == TCL_INT) {
4215         PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
4216     } else {
4217         d = funcResult.doubleValue;
4218         if (IS_NAN(d) || IS_INF(d)) {
4219             TclExprFloatError(interp, d);
4220             result = TCL_ERROR;
4221             goto done;
4222         }
4223         PUSH_OBJECT(Tcl_NewDoubleObj(d));
4224     }
4225
4226     /*
4227      * Reflect the change to stackTop back in eePtr.
4228      */
4229
4230     done:
4231     DECACHE_STACK_INFO();
4232     return result;
4233 }
4234 \f
4235 /*
4236  *----------------------------------------------------------------------
4237  *
4238  * TclExprFloatError --
4239  *
4240  *      This procedure is called when an error occurs during a
4241  *      floating-point operation. It reads errno and sets
4242  *      interp->objResultPtr accordingly.
4243  *
4244  * Results:
4245  *      interp->objResultPtr is set to hold an error message.
4246  *
4247  * Side effects:
4248  *      None.
4249  *
4250  *----------------------------------------------------------------------
4251  */
4252
4253 void
4254 TclExprFloatError(interp, value)
4255     Tcl_Interp *interp;         /* Where to store error message. */
4256     double value;               /* Value returned after error;  used to
4257                                  * distinguish underflows from overflows. */
4258 {
4259     char *s;
4260
4261     Tcl_ResetResult(interp);
4262     if ((errno == EDOM) || (value != value)) {
4263         s = "domain error: argument not in valid range";
4264         Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4265         Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
4266     } else if ((errno == ERANGE) || IS_INF(value)) {
4267         if (value == 0.0) {
4268             s = "floating-point value too small to represent";
4269             Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4270             Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
4271         } else {
4272             s = "floating-point value too large to represent";
4273             Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4274             Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
4275         }
4276     } else {
4277         char msg[64 + TCL_INTEGER_SPACE];
4278
4279         sprintf(msg, "unknown floating-point error, errno = %d", errno);
4280         Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
4281         Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
4282     }
4283 }
4284 \f
4285 /*
4286  *----------------------------------------------------------------------
4287  *
4288  * TclMathInProgress --
4289  *
4290  *      This procedure is called to find out if Tcl is doing math
4291  *      in this thread.
4292  *
4293  * Results:
4294  *      0 or 1.
4295  *
4296  * Side effects:
4297  *      None.
4298  *
4299  *----------------------------------------------------------------------
4300  */
4301
4302 int
4303 TclMathInProgress()
4304 {
4305     ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
4306     return tsdPtr->mathInProgress;
4307 }
4308 \f
4309 #ifdef TCL_COMPILE_STATS
4310 /*
4311  *----------------------------------------------------------------------
4312  *
4313  * TclLog2 --
4314  *
4315  *      Procedure used while collecting compilation statistics to determine
4316  *      the log base 2 of an integer.
4317  *
4318  * Results:
4319  *      Returns the log base 2 of the operand. If the argument is less
4320  *      than or equal to zero, a zero is returned.
4321  *
4322  * Side effects:
4323  *      None.
4324  *
4325  *----------------------------------------------------------------------
4326  */
4327
4328 int
4329 TclLog2(value)
4330     register int value;         /* The integer for which to compute the
4331                                  * log base 2. */
4332 {
4333     register int n = value;
4334     register int result = 0;
4335
4336     while (n > 1) {
4337         n = n >> 1;
4338         result++;
4339     }
4340     return result;
4341 }
4342 \f
4343 /*
4344  *----------------------------------------------------------------------
4345  *
4346  * EvalStatsCmd --
4347  *
4348  *      Implements the "evalstats" command that prints instruction execution
4349  *      counts to stdout.
4350  *
4351  * Results:
4352  *      Standard Tcl results.
4353  *
4354  * Side effects:
4355  *      None.
4356  *
4357  *----------------------------------------------------------------------
4358  */
4359
4360 static int
4361 EvalStatsCmd(unused, interp, argc, argv)
4362     ClientData unused;          /* Unused. */
4363     Tcl_Interp *interp;         /* The current interpreter. */
4364     int argc;                   /* The number of arguments. */
4365     char **argv;                /* The argument strings. */
4366 {
4367     Interp *iPtr = (Interp *) interp;
4368     LiteralTable *globalTablePtr = &(iPtr->literalTable);
4369     ByteCodeStats *statsPtr = &(iPtr->stats);
4370     double totalCodeBytes, currentCodeBytes;
4371     double totalLiteralBytes, currentLiteralBytes;
4372     double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
4373     double strBytesSharedMultX, strBytesSharedOnce;
4374     double numInstructions, currentHeaderBytes;
4375     long numCurrentByteCodes, numByteCodeLits;
4376     long refCountSum, literalMgmtBytes, sum;
4377     int numSharedMultX, numSharedOnce;
4378     int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
4379     char *litTableStats;
4380     LiteralEntry *entryPtr;
4381
4382     numInstructions = 0.0;
4383     for (i = 0;  i < 256;  i++) {
4384         if (statsPtr->instructionCount[i] != 0) {
4385             numInstructions += statsPtr->instructionCount[i];
4386         }
4387     }
4388
4389     totalLiteralBytes = sizeof(LiteralTable)
4390             + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
4391             + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
4392             + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
4393             + statsPtr->totalLitStringBytes;
4394     totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
4395
4396     numCurrentByteCodes =
4397             statsPtr->numCompilations - statsPtr->numByteCodesFreed;
4398     currentHeaderBytes = numCurrentByteCodes
4399             * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
4400     literalMgmtBytes = sizeof(LiteralTable)
4401             + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
4402             + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
4403     currentLiteralBytes = literalMgmtBytes
4404             + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
4405             + statsPtr->currentLitStringBytes;
4406     currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
4407
4408     /*
4409      * Summary statistics, total and current source and ByteCode sizes.
4410      */
4411
4412     fprintf(stdout, "\n----------------------------------------------------------------\n");
4413     fprintf(stdout,
4414             "Compilation and execution statistics for interpreter 0x%x\n",
4415             (unsigned int) iPtr);
4416
4417     fprintf(stdout, "\nNumber ByteCodes executed        %ld\n",
4418             statsPtr->numExecutions);
4419     fprintf(stdout, "Number ByteCodes compiled  %ld\n",
4420             statsPtr->numCompilations);
4421     fprintf(stdout, "  Mean executions/compile  %.1f\n",
4422             ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
4423
4424     fprintf(stdout, "\nInstructions executed            %.0f\n",
4425             numInstructions);
4426     fprintf(stdout, "  Mean inst/compile                %.0f\n",
4427             numInstructions / statsPtr->numCompilations);
4428     fprintf(stdout, "  Mean inst/execution              %.0f\n",
4429             numInstructions / statsPtr->numExecutions);
4430
4431     fprintf(stdout, "\nTotal ByteCodes                  %ld\n",
4432             statsPtr->numCompilations);
4433     fprintf(stdout, "  Source bytes                     %.6g\n",
4434             statsPtr->totalSrcBytes);
4435     fprintf(stdout, "  Code bytes                       %.6g\n",
4436             totalCodeBytes);
4437     fprintf(stdout, "    ByteCode bytes         %.6g\n",
4438             statsPtr->totalByteCodeBytes);
4439     fprintf(stdout, "    Literal bytes          %.6g\n",
4440             totalLiteralBytes);
4441     fprintf(stdout, "      table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
4442             sizeof(LiteralTable),
4443             iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4444             statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
4445             statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
4446             statsPtr->totalLitStringBytes);
4447     fprintf(stdout, "  Mean code/compile                %.1f\n",
4448             totalCodeBytes / statsPtr->numCompilations);
4449     fprintf(stdout, "  Mean code/source         %.1f\n",
4450             totalCodeBytes / statsPtr->totalSrcBytes);
4451
4452     fprintf(stdout, "\nCurrent ByteCodes                %ld\n",
4453             numCurrentByteCodes);
4454     fprintf(stdout, "  Source bytes                     %.6g\n",
4455             statsPtr->currentSrcBytes);
4456     fprintf(stdout, "  Code bytes                       %.6g\n",
4457             currentCodeBytes);
4458     fprintf(stdout, "    ByteCode bytes         %.6g\n",
4459             statsPtr->currentByteCodeBytes);
4460     fprintf(stdout, "    Literal bytes          %.6g\n",
4461             currentLiteralBytes);
4462     fprintf(stdout, "      table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
4463             sizeof(LiteralTable),
4464             iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4465             iPtr->literalTable.numEntries * sizeof(LiteralEntry),
4466             iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
4467             statsPtr->currentLitStringBytes);
4468     fprintf(stdout, "  Mean code/source         %.1f\n",
4469             currentCodeBytes / statsPtr->currentSrcBytes);
4470     fprintf(stdout, "  Code + source bytes              %.6g (%0.1f mean code/src)\n",
4471             (currentCodeBytes + statsPtr->currentSrcBytes),
4472             (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
4473
4474     /*
4475      * Literal table statistics.
4476      */
4477
4478     numByteCodeLits = 0;
4479     refCountSum = 0;
4480     numSharedMultX = 0;
4481     numSharedOnce  = 0;
4482     objBytesIfUnshared  = 0.0;
4483     strBytesIfUnshared  = 0.0;
4484     strBytesSharedMultX = 0.0;
4485     strBytesSharedOnce  = 0.0;
4486     for (i = 0;  i < globalTablePtr->numBuckets;  i++) {
4487         for (entryPtr = globalTablePtr->buckets[i];  entryPtr != NULL;
4488                 entryPtr = entryPtr->nextPtr) {
4489             if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
4490                 numByteCodeLits++;
4491             }
4492             (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
4493             refCountSum += entryPtr->refCount;
4494             objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
4495             strBytesIfUnshared += (entryPtr->refCount * (length+1));
4496             if (entryPtr->refCount > 1) {
4497                 numSharedMultX++;
4498                 strBytesSharedMultX += (length+1);
4499             } else {
4500                 numSharedOnce++;
4501                 strBytesSharedOnce += (length+1);
4502             }
4503         }
4504     }
4505     sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
4506             - currentLiteralBytes;
4507
4508     fprintf(stdout, "\nTotal objects (all interps)      %ld\n",
4509             tclObjsAlloced);
4510     fprintf(stdout, "Current objects                    %ld\n",
4511             (tclObjsAlloced - tclObjsFreed));
4512     fprintf(stdout, "Total literal objects              %ld\n",
4513             statsPtr->numLiteralsCreated);
4514
4515     fprintf(stdout, "\nCurrent literal objects          %d (%0.1f%% of current objects)\n",
4516             globalTablePtr->numEntries,
4517             (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
4518     fprintf(stdout, "  ByteCode literals                %ld (%0.1f%% of current literals)\n",
4519             numByteCodeLits,
4520             (numByteCodeLits * 100.0) / globalTablePtr->numEntries);
4521     fprintf(stdout, "  Literals reused > 1x             %d\n",
4522             numSharedMultX);
4523     fprintf(stdout, "  Mean reference count             %.2f\n",
4524             ((double) refCountSum) / globalTablePtr->numEntries);
4525     fprintf(stdout, "  Mean len, str reused >1x         %.2f\n",
4526             (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
4527     fprintf(stdout, "  Mean len, str used 1x            %.2f\n",
4528             (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
4529     fprintf(stdout, "  Total sharing savings            %.6g (%0.1f%% of bytes if no sharing)\n",
4530             sharingBytesSaved,
4531             (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
4532     fprintf(stdout, "    Bytes with sharing             %.6g\n",
4533             currentLiteralBytes);
4534     fprintf(stdout, "      table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
4535             sizeof(LiteralTable),
4536             iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4537             iPtr->literalTable.numEntries * sizeof(LiteralEntry),
4538             iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
4539             statsPtr->currentLitStringBytes);
4540     fprintf(stdout, "    Bytes if no sharing            %.6g = objects %.6g + strings %.6g\n",
4541             (objBytesIfUnshared + strBytesIfUnshared),
4542             objBytesIfUnshared, strBytesIfUnshared);
4543     fprintf(stdout, "  String sharing savings   %.6g = unshared %.6g - shared %.6g\n",
4544             (strBytesIfUnshared - statsPtr->currentLitStringBytes),
4545             strBytesIfUnshared, statsPtr->currentLitStringBytes);
4546     fprintf(stdout, "  Literal mgmt overhead            %ld (%0.1f%% of bytes with sharing)\n",
4547             literalMgmtBytes,
4548             (literalMgmtBytes * 100.0) / currentLiteralBytes);
4549     fprintf(stdout, "    table %d + buckets %d + entries %d\n",
4550             sizeof(LiteralTable),
4551             iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4552             iPtr->literalTable.numEntries * sizeof(LiteralEntry));
4553
4554     /*
4555      * Breakdown of current ByteCode space requirements.
4556      */
4557
4558     fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
4559     fprintf(stdout, "                         Bytes      Pct of    Avg per\n");
4560     fprintf(stdout, "                                     total    ByteCode\n");
4561     fprintf(stdout, "Total             %12.6g     100.00%%   %8.1f\n",
4562             statsPtr->currentByteCodeBytes,
4563             statsPtr->currentByteCodeBytes / numCurrentByteCodes);
4564     fprintf(stdout, "Header            %12.6g   %8.1f%%   %8.1f\n",
4565             currentHeaderBytes,
4566             ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
4567             currentHeaderBytes / numCurrentByteCodes);
4568     fprintf(stdout, "Instructions      %12.6g   %8.1f%%   %8.1f\n",
4569             statsPtr->currentInstBytes,
4570             ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
4571             statsPtr->currentInstBytes / numCurrentByteCodes);
4572     fprintf(stdout, "Literal ptr array %12.6g   %8.1f%%   %8.1f\n",
4573             statsPtr->currentLitBytes,
4574             ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
4575             statsPtr->currentLitBytes / numCurrentByteCodes);
4576     fprintf(stdout, "Exception table   %12.6g   %8.1f%%   %8.1f\n",
4577             statsPtr->currentExceptBytes,
4578             ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
4579             statsPtr->currentExceptBytes / numCurrentByteCodes);
4580     fprintf(stdout, "Auxiliary data    %12.6g   %8.1f%%   %8.1f\n",
4581             statsPtr->currentAuxBytes,
4582             ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
4583             statsPtr->currentAuxBytes / numCurrentByteCodes);
4584     fprintf(stdout, "Command map       %12.6g   %8.1f%%   %8.1f\n",
4585             statsPtr->currentCmdMapBytes,
4586             ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
4587             statsPtr->currentCmdMapBytes / numCurrentByteCodes);
4588
4589     /*
4590      * Detailed literal statistics.
4591      */
4592
4593     fprintf(stdout, "\nLiteral string sizes:\n");
4594     fprintf(stdout, "    Up to length           Percentage\n");
4595     maxSizeDecade = 0;
4596     for (i = 31;  i >= 0;  i--) {
4597         if (statsPtr->literalCount[i] > 0) {
4598             maxSizeDecade = i;
4599             break;
4600         }
4601     }
4602     sum = 0;
4603     for (i = 0;  i <= maxSizeDecade;  i++) {
4604         decadeHigh = (1 << (i+1)) - 1;
4605         sum += statsPtr->literalCount[i];
4606         fprintf(stdout, "       %10d            %8.0f%%\n",
4607                 decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
4608     }
4609
4610     litTableStats = TclLiteralStats(globalTablePtr);
4611     fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
4612             litTableStats);
4613     ckfree((char *) litTableStats);
4614
4615     /*
4616      * Source and ByteCode size distributions.
4617      */
4618
4619     fprintf(stdout, "\nSource sizes:\n");
4620     fprintf(stdout, "    Up to size             Percentage\n");
4621     minSizeDecade = maxSizeDecade = 0;
4622     for (i = 0;  i < 31;  i++) {
4623         if (statsPtr->srcCount[i] > 0) {
4624             minSizeDecade = i;
4625             break;
4626         }
4627     }
4628     for (i = 31;  i >= 0;  i--) {
4629         if (statsPtr->srcCount[i] > 0) {
4630             maxSizeDecade = i;
4631             break;
4632         }
4633     }
4634     sum = 0;
4635     for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
4636         decadeHigh = (1 << (i+1)) - 1;
4637         sum += statsPtr->srcCount[i];
4638         fprintf(stdout, "       %10d            %8.0f%%\n",
4639                 decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
4640     }
4641
4642     fprintf(stdout, "\nByteCode sizes:\n");
4643     fprintf(stdout, "    Up to size             Percentage\n");
4644     minSizeDecade = maxSizeDecade = 0;
4645     for (i = 0;  i < 31;  i++) {
4646         if (statsPtr->byteCodeCount[i] > 0) {
4647             minSizeDecade = i;
4648             break;
4649         }
4650     }
4651     for (i = 31;  i >= 0;  i--) {
4652         if (statsPtr->byteCodeCount[i] > 0) {
4653             maxSizeDecade = i;
4654             break;
4655         }
4656     }
4657     sum = 0;
4658     for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
4659         decadeHigh = (1 << (i+1)) - 1;
4660         sum += statsPtr->byteCodeCount[i];
4661         fprintf(stdout, "       %10d            %8.0f%%\n",
4662                 decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
4663     }
4664
4665     fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n");
4666     fprintf(stdout, "          Up to ms         Percentage\n");
4667     minSizeDecade = maxSizeDecade = 0;
4668     for (i = 0;  i < 31;  i++) {
4669         if (statsPtr->lifetimeCount[i] > 0) {
4670             minSizeDecade = i;
4671             break;
4672         }
4673     }
4674     for (i = 31;  i >= 0;  i--) {
4675         if (statsPtr->lifetimeCount[i] > 0) {
4676             maxSizeDecade = i;
4677             break;
4678         }
4679     }
4680     sum = 0;
4681     for (i = minSizeDecade;  i <= maxSizeDecade;  i++) {
4682         decadeHigh = (1 << (i+1)) - 1;
4683         sum += statsPtr->lifetimeCount[i];
4684         fprintf(stdout, "       %12.3f          %8.0f%%\n",
4685                 decadeHigh / 1000.0,
4686                 (sum * 100.0) / statsPtr->numByteCodesFreed);
4687     }
4688
4689     /*
4690      * Instruction counts.
4691      */
4692
4693     fprintf(stdout, "\nInstruction counts:\n");
4694     for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
4695         if (statsPtr->instructionCount[i]) {
4696             fprintf(stdout, "%20s %8ld %6.1f%%\n",
4697                     instructionTable[i].name,
4698                     statsPtr->instructionCount[i],
4699                     (statsPtr->instructionCount[i]*100.0) / numInstructions);
4700         }
4701     }
4702
4703     fprintf(stdout, "\nInstructions NEVER executed:\n");
4704     for (i = 0;  i <= LAST_INST_OPCODE;  i++) {
4705         if (statsPtr->instructionCount[i] == 0) {
4706             fprintf(stdout, "%20s\n",
4707                     instructionTable[i].name);
4708         }
4709     }
4710
4711 #ifdef TCL_MEM_DEBUG
4712     fprintf(stdout, "\nHeap Statistics:\n");
4713     TclDumpMemoryInfo(stdout);
4714 #endif
4715     fprintf(stdout, "\n----------------------------------------------------------------\n");
4716     return TCL_OK;
4717 }
4718 #endif /* TCL_COMPILE_STATS */
4719 \f
4720 /*
4721  *----------------------------------------------------------------------
4722  *
4723  * Tcl_GetCommandFromObj --
4724  *
4725  *      Returns the command specified by the name in a Tcl_Obj.
4726  *
4727  * Results:
4728  *      Returns a token for the command if it is found. Otherwise, if it
4729  *      can't be found or there is an error, returns NULL.
4730  *
4731  * Side effects:
4732  *      May update the internal representation for the object, caching
4733  *      the command reference so that the next time this procedure is
4734  *      called with the same object, the command can be found quickly.
4735  *
4736  *----------------------------------------------------------------------
4737  */
4738
4739 Tcl_Command
4740 Tcl_GetCommandFromObj(interp, objPtr)
4741     Tcl_Interp *interp;         /* The interpreter in which to resolve the
4742                                  * command and to report errors. */
4743     register Tcl_Obj *objPtr;   /* The object containing the command's
4744                                  * name. If the name starts with "::", will
4745                                  * be looked up in global namespace. Else,
4746                                  * looked up first in the current namespace
4747                                  * if contextNsPtr is NULL, then in global
4748                                  * namespace. */
4749 {
4750     Interp *iPtr = (Interp *) interp;
4751     register ResolvedCmdName *resPtr;
4752     register Command *cmdPtr;
4753     Namespace *currNsPtr;
4754     int result;
4755
4756     /*
4757      * Get the internal representation, converting to a command type if
4758      * needed. The internal representation is a ResolvedCmdName that points
4759      * to the actual command.
4760      */
4761
4762     if (objPtr->typePtr != &tclCmdNameType) {
4763         result = tclCmdNameType.setFromAnyProc(interp, objPtr);
4764         if (result != TCL_OK) {
4765             return (Tcl_Command) NULL;
4766         }
4767     }
4768     resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4769
4770     /*
4771      * Get the current namespace.
4772      */
4773
4774     if (iPtr->varFramePtr != NULL) {
4775         currNsPtr = iPtr->varFramePtr->nsPtr;
4776     } else {
4777         currNsPtr = iPtr->globalNsPtr;
4778     }
4779
4780     /*
4781      * Check the context namespace and the namespace epoch of the resolved
4782      * symbol to make sure that it is fresh. If not, then force another
4783      * conversion to the command type, to discard the old rep and create a
4784      * new one. Note that we verify that the namespace id of the context
4785      * namespace is the same as the one we cached; this insures that the
4786      * namespace wasn't deleted and a new one created at the same address
4787      * with the same command epoch.
4788      */
4789
4790     cmdPtr = NULL;
4791     if ((resPtr != NULL)
4792             && (resPtr->refNsPtr == currNsPtr)
4793             && (resPtr->refNsId == currNsPtr->nsId)
4794             && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
4795         cmdPtr = resPtr->cmdPtr;
4796         if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
4797             cmdPtr = NULL;
4798         }
4799     }
4800
4801     if (cmdPtr == NULL) {
4802         result = tclCmdNameType.setFromAnyProc(interp, objPtr);
4803         if (result != TCL_OK) {
4804             return (Tcl_Command) NULL;
4805         }
4806         resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4807         if (resPtr != NULL) {
4808             cmdPtr = resPtr->cmdPtr;
4809         }
4810     }
4811     return (Tcl_Command) cmdPtr;
4812 }
4813 \f
4814 /*
4815  *----------------------------------------------------------------------
4816  *
4817  * TclSetCmdNameObj --
4818  *
4819  *      Modify an object to be an CmdName object that refers to the argument
4820  *      Command structure.
4821  *
4822  * Results:
4823  *      None.
4824  *
4825  * Side effects:
4826  *      The object's old internal rep is freed. It's string rep is not
4827  *      changed. The refcount in the Command structure is incremented to
4828  *      keep it from being freed if the command is later deleted until
4829  *      TclExecuteByteCode has a chance to recognize that it was deleted.
4830  *
4831  *----------------------------------------------------------------------
4832  */
4833
4834 void
4835 TclSetCmdNameObj(interp, objPtr, cmdPtr)
4836     Tcl_Interp *interp;         /* Points to interpreter containing command
4837                                  * that should be cached in objPtr. */
4838     register Tcl_Obj *objPtr;   /* Points to Tcl object to be changed to
4839                                  * a CmdName object. */
4840     Command *cmdPtr;            /* Points to Command structure that the
4841                                  * CmdName object should refer to. */
4842 {
4843     Interp *iPtr = (Interp *) interp;
4844     register ResolvedCmdName *resPtr;
4845     Tcl_ObjType *oldTypePtr = objPtr->typePtr;
4846     register Namespace *currNsPtr;
4847
4848     if (oldTypePtr == &tclCmdNameType) {
4849         return;
4850     }
4851
4852     /*
4853      * Get the current namespace.
4854      */
4855
4856     if (iPtr->varFramePtr != NULL) {
4857         currNsPtr = iPtr->varFramePtr->nsPtr;
4858     } else {
4859         currNsPtr = iPtr->globalNsPtr;
4860     }
4861
4862     cmdPtr->refCount++;
4863     resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
4864     resPtr->cmdPtr = cmdPtr;
4865     resPtr->refNsPtr = currNsPtr;
4866     resPtr->refNsId  = currNsPtr->nsId;
4867     resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
4868     resPtr->cmdEpoch = cmdPtr->cmdEpoch;
4869     resPtr->refCount = 1;
4870
4871     if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
4872         oldTypePtr->freeIntRepProc(objPtr);
4873     }
4874     objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
4875     objPtr->internalRep.twoPtrValue.ptr2 = NULL;
4876     objPtr->typePtr = &tclCmdNameType;
4877 }
4878 \f
4879 /*
4880  *----------------------------------------------------------------------
4881  *
4882  * FreeCmdNameInternalRep --
4883  *
4884  *      Frees the resources associated with a cmdName object's internal
4885  *      representation.
4886  *
4887  * Results:
4888  *      None.
4889  *
4890  * Side effects:
4891  *      Decrements the ref count of any cached ResolvedCmdName structure
4892  *      pointed to by the cmdName's internal representation. If this is
4893  *      the last use of the ResolvedCmdName, it is freed. This in turn
4894  *      decrements the ref count of the Command structure pointed to by
4895  *      the ResolvedSymbol, which may free the Command structure.
4896  *
4897  *----------------------------------------------------------------------
4898  */
4899
4900 static void
4901 FreeCmdNameInternalRep(objPtr)
4902     register Tcl_Obj *objPtr;   /* CmdName object with internal
4903                                  * representation to free. */
4904 {
4905     register ResolvedCmdName *resPtr =
4906         (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4907
4908     if (resPtr != NULL) {
4909         /*
4910          * Decrement the reference count of the ResolvedCmdName structure.
4911          * If there are no more uses, free the ResolvedCmdName structure.
4912          */
4913
4914         resPtr->refCount--;
4915         if (resPtr->refCount == 0) {
4916             /*
4917              * Now free the cached command, unless it is still in its
4918              * hash table or if there are other references to it
4919              * from other cmdName objects.
4920              */
4921
4922             Command *cmdPtr = resPtr->cmdPtr;
4923             TclCleanupCommand(cmdPtr);
4924             ckfree((char *) resPtr);
4925         }
4926     }
4927 }
4928 \f
4929 /*
4930  *----------------------------------------------------------------------
4931  *
4932  * DupCmdNameInternalRep --
4933  *
4934  *      Initialize the internal representation of an cmdName Tcl_Obj to a
4935  *      copy of the internal representation of an existing cmdName object.
4936  *
4937  * Results:
4938  *      None.
4939  *
4940  * Side effects:
4941  *      "copyPtr"s internal rep is set to point to the ResolvedCmdName
4942  *      structure corresponding to "srcPtr"s internal rep. Increments the
4943  *      ref count of the ResolvedCmdName structure pointed to by the
4944  *      cmdName's internal representation.
4945  *
4946  *----------------------------------------------------------------------
4947  */
4948
4949 static void
4950 DupCmdNameInternalRep(srcPtr, copyPtr)
4951     Tcl_Obj *srcPtr;            /* Object with internal rep to copy. */
4952     register Tcl_Obj *copyPtr;  /* Object with internal rep to set. */
4953 {
4954     register ResolvedCmdName *resPtr =
4955         (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
4956
4957     copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
4958     copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
4959     if (resPtr != NULL) {
4960         resPtr->refCount++;
4961     }
4962     copyPtr->typePtr = &tclCmdNameType;
4963 }
4964 \f
4965 /*
4966  *----------------------------------------------------------------------
4967  *
4968  * SetCmdNameFromAny --
4969  *
4970  *      Generate an cmdName internal form for the Tcl object "objPtr".
4971  *
4972  * Results:
4973  *      The return value is a standard Tcl result. The conversion always
4974  *      succeeds and TCL_OK is returned.
4975  *
4976  * Side effects:
4977  *      A pointer to a ResolvedCmdName structure that holds a cached pointer
4978  *      to the command with a name that matches objPtr's string rep is
4979  *      stored as objPtr's internal representation. This ResolvedCmdName
4980  *      pointer will be NULL if no matching command was found. The ref count
4981  *      of the cached Command's structure (if any) is also incremented.
4982  *
4983  *----------------------------------------------------------------------
4984  */
4985
4986 static int
4987 SetCmdNameFromAny(interp, objPtr)
4988     Tcl_Interp *interp;         /* Used for error reporting if not NULL. */
4989     register Tcl_Obj *objPtr;   /* The object to convert. */
4990 {
4991     Interp *iPtr = (Interp *) interp;
4992     char *name;
4993     Tcl_Command cmd;
4994     register Command *cmdPtr;
4995     Namespace *currNsPtr;
4996     register ResolvedCmdName *resPtr;
4997
4998     /*
4999      * Get "objPtr"s string representation. Make it up-to-date if necessary.
5000      */
5001
5002     name = objPtr->bytes;
5003     if (name == NULL) {
5004         name = Tcl_GetString(objPtr);
5005     }
5006
5007     /*
5008      * Find the Command structure, if any, that describes the command called
5009      * "name". Build a ResolvedCmdName that holds a cached pointer to this
5010      * Command, and bump the reference count in the referenced Command
5011      * structure. A Command structure will not be deleted as long as it is
5012      * referenced from a CmdName object.
5013      */
5014
5015     cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
5016             /*flags*/ 0);
5017     cmdPtr = (Command *) cmd;
5018     if (cmdPtr != NULL) {
5019         /*
5020          * Get the current namespace.
5021          */
5022
5023         if (iPtr->varFramePtr != NULL) {
5024             currNsPtr = iPtr->varFramePtr->nsPtr;
5025         } else {
5026             currNsPtr = iPtr->globalNsPtr;
5027         }
5028
5029         cmdPtr->refCount++;
5030         resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
5031         resPtr->cmdPtr        = cmdPtr;
5032         resPtr->refNsPtr      = currNsPtr;
5033         resPtr->refNsId       = currNsPtr->nsId;
5034         resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
5035         resPtr->cmdEpoch      = cmdPtr->cmdEpoch;
5036         resPtr->refCount      = 1;
5037     } else {
5038         resPtr = NULL;  /* no command named "name" was found */
5039     }
5040
5041     /*
5042      * Free the old internalRep before setting the new one. We do this as
5043      * late as possible to allow the conversion code, in particular
5044      * GetStringFromObj, to use that old internalRep. If no Command
5045      * structure was found, leave NULL as the cached value.
5046      */
5047
5048     if ((objPtr->typePtr != NULL)
5049             && (objPtr->typePtr->freeIntRepProc != NULL)) {
5050         objPtr->typePtr->freeIntRepProc(objPtr);
5051     }
5052
5053     objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
5054     objPtr->internalRep.twoPtrValue.ptr2 = NULL;
5055     objPtr->typePtr = &tclCmdNameType;
5056     return TCL_OK;
5057 }
5058 \f
5059 #ifdef TCL_COMPILE_DEBUG
5060 /*
5061  *----------------------------------------------------------------------
5062  *
5063  * StringForResultCode --
5064  *
5065  *      Procedure that returns a human-readable string representing a
5066  *      Tcl result code such as TCL_ERROR.
5067  *
5068  * Results:
5069  *      If the result code is one of the standard Tcl return codes, the
5070  *      result is a string representing that code such as "TCL_ERROR".
5071  *      Otherwise, the result string is that code formatted as a
5072  *      sequence of decimal digit characters. Note that the resulting
5073  *      string must not be modified by the caller.
5074  *
5075  * Side effects:
5076  *      None.
5077  *
5078  *----------------------------------------------------------------------
5079  */
5080
5081 static char *
5082 StringForResultCode(result)
5083     int result;                 /* The Tcl result code for which to
5084                                  * generate a string. */
5085 {
5086     static char buf[TCL_INTEGER_SPACE];
5087
5088     if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
5089         return resultStrings[result];
5090     }
5091     TclFormatInt(buf, result);
5092     return buf;
5093 }
5094 #endif /* TCL_COMPILE_DEBUG */
5095