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