/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompile.c
ViewVC logotype

Diff of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompile.c

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

projs/trunk/shared_source/tcl_base/tclcompile.c revision 42 by dashley, Fri Oct 14 01:50:00 2016 UTC projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompile.c revision 71 by dashley, Sat Nov 5 11:07:06 2016 UTC
# Line 1  Line 1 
 /* $Header: /cvsroot/esrg/sfesrg/esrgpcpj/shared/tcl_base/tclcompile.c,v 1.1.1.1 2001/06/13 04:36:17 dtashley Exp $ */  
   
 /*  
  * tclCompile.c --  
  *  
  *      This file contains procedures that compile Tcl commands or parts  
  *      of commands (like quoted strings or nested sub-commands) into a  
  *      sequence of instructions ("bytecodes").  
  *  
  * Copyright (c) 1996-1998 Sun Microsystems, Inc.  
  *  
  * See the file "license.terms" for information on usage and redistribution  
  * of this file, and for a DISCLAIMER OF ALL WARRANTIES.  
  *  
  * RCS: @(#) $Id: tclcompile.c,v 1.1.1.1 2001/06/13 04:36:17 dtashley Exp $  
  */  
   
 #include "tclInt.h"  
 #include "tclCompile.h"  
   
 /*  
  * Table of all AuxData types.  
  */  
   
 static Tcl_HashTable auxDataTypeTable;  
 static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */  
   
 TCL_DECLARE_MUTEX(tableMutex)  
   
 /*  
  * Variable that controls whether compilation tracing is enabled and, if so,  
  * what level of tracing is desired:  
  *    0: no compilation tracing  
  *    1: summarize compilation of top level cmds and proc bodies  
  *    2: display all instructions of each ByteCode compiled  
  * This variable is linked to the Tcl variable "tcl_traceCompile".  
  */  
   
 int tclTraceCompile = 0;  
 static int traceInitialized = 0;  
   
 /*  
  * A table describing the Tcl bytecode instructions. Entries in this table  
  * must correspond to the instruction opcode definitions in tclCompile.h.  
  * The names "op1" and "op4" refer to an instruction's one or four byte  
  * first operand. Similarly, "stktop" and "stknext" refer to the topmost  
  * and next to topmost stack elements.  
  *  
  * Note that the load, store, and incr instructions do not distinguish local  
  * from global variables; the bytecode interpreter at runtime uses the  
  * existence of a procedure call frame to distinguish these.  
  */  
   
 InstructionDesc instructionTable[] = {  
    /* Name            Bytes #Opnds Operand types        Stack top, next   */  
     {"done",              1,   0,   {OPERAND_NONE}},  
         /* Finish ByteCode execution and return stktop (top stack item) */  
     {"push1",             2,   1,   {OPERAND_UINT1}},  
         /* Push object at ByteCode objArray[op1] */  
     {"push4",             5,   1,   {OPERAND_UINT4}},  
         /* Push object at ByteCode objArray[op4] */  
     {"pop",               1,   0,   {OPERAND_NONE}},  
         /* Pop the topmost stack object */  
     {"dup",               1,   0,   {OPERAND_NONE}},  
         /* Duplicate the topmost stack object and push the result */  
     {"concat1",           2,   1,   {OPERAND_UINT1}},  
         /* Concatenate the top op1 items and push result */  
     {"invokeStk1",        2,   1,   {OPERAND_UINT1}},  
         /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */  
     {"invokeStk4",        5,   1,   {OPERAND_UINT4}},  
         /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */  
     {"evalStk",           1,   0,   {OPERAND_NONE}},  
         /* Evaluate command in stktop using Tcl_EvalObj. */  
     {"exprStk",           1,   0,   {OPERAND_NONE}},  
         /* Execute expression in stktop using Tcl_ExprStringObj. */  
       
     {"loadScalar1",       2,   1,   {OPERAND_UINT1}},  
         /* Load scalar variable at index op1 <= 255 in call frame */  
     {"loadScalar4",       5,   1,   {OPERAND_UINT4}},  
         /* Load scalar variable at index op1 >= 256 in call frame */  
     {"loadScalarStk",     1,   0,   {OPERAND_NONE}},  
         /* Load scalar variable; scalar's name is stktop */  
     {"loadArray1",        2,   1,   {OPERAND_UINT1}},  
         /* Load array element; array at slot op1<=255, element is stktop */  
     {"loadArray4",        5,   1,   {OPERAND_UINT4}},  
         /* Load array element; array at slot op1 > 255, element is stktop */  
     {"loadArrayStk",      1,   0,   {OPERAND_NONE}},  
         /* Load array element; element is stktop, array name is stknext */  
     {"loadStk",           1,   0,   {OPERAND_NONE}},  
         /* Load general variable; unparsed variable name is stktop */  
     {"storeScalar1",      2,   1,   {OPERAND_UINT1}},  
         /* Store scalar variable at op1<=255 in frame; value is stktop */  
     {"storeScalar4",      5,   1,   {OPERAND_UINT4}},  
         /* Store scalar variable at op1 > 255 in frame; value is stktop */  
     {"storeScalarStk",    1,   0,   {OPERAND_NONE}},  
         /* Store scalar; value is stktop, scalar name is stknext */  
     {"storeArray1",       2,   1,   {OPERAND_UINT1}},  
         /* Store array element; array at op1<=255, value is top then elem */  
     {"storeArray4",       5,   1,   {OPERAND_UINT4}},  
         /* Store array element; array at op1>=256, value is top then elem */  
     {"storeArrayStk",     1,   0,   {OPERAND_NONE}},  
         /* Store array element; value is stktop, then elem, array names */  
     {"storeStk",          1,   0,   {OPERAND_NONE}},  
         /* Store general variable; value is stktop, then unparsed name */  
       
     {"incrScalar1",       2,   1,   {OPERAND_UINT1}},  
         /* Incr scalar at index op1<=255 in frame; incr amount is stktop */  
     {"incrScalarStk",     1,   0,   {OPERAND_NONE}},  
         /* Incr scalar; incr amount is stktop, scalar's name is stknext */  
     {"incrArray1",        2,   1,   {OPERAND_UINT1}},  
         /* Incr array elem; arr at slot op1<=255, amount is top then elem */  
     {"incrArrayStk",      1,   0,   {OPERAND_NONE}},  
         /* Incr array element; amount is top then elem then array names */  
     {"incrStk",           1,   0,   {OPERAND_NONE}},  
         /* Incr general variable; amount is stktop then unparsed var name */  
     {"incrScalar1Imm",    3,   2,   {OPERAND_UINT1, OPERAND_INT1}},  
         /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */  
     {"incrScalarStkImm",  2,   1,   {OPERAND_INT1}},  
         /* Incr scalar; scalar name is stktop; incr amount is op1 */  
     {"incrArray1Imm",     3,   2,   {OPERAND_UINT1, OPERAND_INT1}},  
         /* Incr array elem; array at slot op1 <= 255, elem is stktop,  
          * amount is 2nd operand byte */  
     {"incrArrayStkImm",   2,   1,   {OPERAND_INT1}},  
         /* Incr array element; elem is top then array name, amount is op1 */  
     {"incrStkImm",        2,   1,   {OPERAND_INT1}},  
         /* Incr general variable; unparsed name is top, amount is op1 */  
       
     {"jump1",             2,   1,   {OPERAND_INT1}},  
         /* Jump relative to (pc + op1) */  
     {"jump4",             5,   1,   {OPERAND_INT4}},  
         /* Jump relative to (pc + op4) */  
     {"jumpTrue1",         2,   1,   {OPERAND_INT1}},  
         /* Jump relative to (pc + op1) if stktop expr object is true */  
     {"jumpTrue4",         5,   1,   {OPERAND_INT4}},  
         /* Jump relative to (pc + op4) if stktop expr object is true */  
     {"jumpFalse1",        2,   1,   {OPERAND_INT1}},  
         /* Jump relative to (pc + op1) if stktop expr object is false */  
     {"jumpFalse4",        5,   1,   {OPERAND_INT4}},  
         /* Jump relative to (pc + op4) if stktop expr object is false */  
   
     {"lor",               1,   0,   {OPERAND_NONE}},  
         /* Logical or:  push (stknext || stktop) */  
     {"land",              1,   0,   {OPERAND_NONE}},  
         /* Logical and: push (stknext && stktop) */  
     {"bitor",             1,   0,   {OPERAND_NONE}},  
         /* Bitwise or:  push (stknext | stktop) */  
     {"bitxor",            1,   0,   {OPERAND_NONE}},  
         /* Bitwise xor  push (stknext ^ stktop) */  
     {"bitand",            1,   0,   {OPERAND_NONE}},  
         /* Bitwise and: push (stknext & stktop) */  
     {"eq",                1,   0,   {OPERAND_NONE}},  
         /* Equal:       push (stknext == stktop) */  
     {"neq",               1,   0,   {OPERAND_NONE}},  
         /* Not equal:   push (stknext != stktop) */  
     {"lt",                1,   0,   {OPERAND_NONE}},  
         /* Less:        push (stknext < stktop) */  
     {"gt",                1,   0,   {OPERAND_NONE}},  
         /* Greater:     push (stknext || stktop) */  
     {"le",                1,   0,   {OPERAND_NONE}},  
         /* Logical or:  push (stknext || stktop) */  
     {"ge",                1,   0,   {OPERAND_NONE}},  
         /* Logical or:  push (stknext || stktop) */  
     {"lshift",            1,   0,   {OPERAND_NONE}},  
         /* Left shift:  push (stknext << stktop) */  
     {"rshift",            1,   0,   {OPERAND_NONE}},  
         /* Right shift: push (stknext >> stktop) */  
     {"add",               1,   0,   {OPERAND_NONE}},  
         /* Add:         push (stknext + stktop) */  
     {"sub",               1,   0,   {OPERAND_NONE}},  
         /* Sub:         push (stkext - stktop) */  
     {"mult",              1,   0,   {OPERAND_NONE}},  
         /* Multiply:    push (stknext * stktop) */  
     {"div",               1,   0,   {OPERAND_NONE}},  
         /* Divide:      push (stknext / stktop) */  
     {"mod",               1,   0,   {OPERAND_NONE}},  
         /* Mod:         push (stknext % stktop) */  
     {"uplus",             1,   0,   {OPERAND_NONE}},  
         /* Unary plus:  push +stktop */  
     {"uminus",            1,   0,   {OPERAND_NONE}},  
         /* Unary minus: push -stktop */  
     {"bitnot",            1,   0,   {OPERAND_NONE}},  
         /* Bitwise not: push ~stktop */  
     {"not",               1,   0,   {OPERAND_NONE}},  
         /* Logical not: push !stktop */  
     {"callBuiltinFunc1",  2,   1,   {OPERAND_UINT1}},  
         /* Call builtin math function with index op1; any args are on stk */  
     {"callFunc1",         2,   1,   {OPERAND_UINT1}},  
         /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1>  */  
     {"tryCvtToNumeric",   1,   0,   {OPERAND_NONE}},  
         /* Try converting stktop to first int then double if possible. */  
   
     {"break",             1,   0,   {OPERAND_NONE}},  
         /* Abort closest enclosing loop; if none, return TCL_BREAK code. */  
     {"continue",          1,   0,   {OPERAND_NONE}},  
         /* Skip to next iteration of closest enclosing loop; if none,  
          * return TCL_CONTINUE code. */  
   
     {"foreach_start4",    5,   1,   {OPERAND_UINT4}},  
         /* Initialize execution of a foreach loop. Operand is aux data index  
          * of the ForeachInfo structure for the foreach command. */  
     {"foreach_step4",     5,   1,   {OPERAND_UINT4}},  
         /* "Step" or begin next iteration of foreach loop. Push 0 if to  
          *  terminate loop, else push 1. */  
   
     {"beginCatch4",       5,   1,   {OPERAND_UINT4}},  
         /* Record start of catch with the operand's exception index.  
          * Push the current stack depth onto a special catch stack. */  
     {"endCatch",          1,   0,   {OPERAND_NONE}},  
         /* End of last catch. Pop the bytecode interpreter's catch stack. */  
     {"pushResult",        1,   0,   {OPERAND_NONE}},  
         /* Push the interpreter's object result onto the stack. */  
     {"pushReturnCode",    1,   0,   {OPERAND_NONE}},  
         /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as  
          * a new object onto the stack. */  
     {0}  
 };  
   
 /*  
  * Prototypes for procedures defined later in this file:  
  */  
   
 static void             DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,  
                             Tcl_Obj *copyPtr));  
 static unsigned char *  EncodeCmdLocMap _ANSI_ARGS_((  
                             CompileEnv *envPtr, ByteCode *codePtr,  
                             unsigned char *startPtr));  
 static void             EnterCmdExtentData _ANSI_ARGS_((  
                             CompileEnv *envPtr, int cmdNumber,  
                             int numSrcBytes, int numCodeBytes));  
 static void             EnterCmdStartData _ANSI_ARGS_((  
                             CompileEnv *envPtr, int cmdNumber,  
                             int srcOffset, int codeOffset));  
 static void             FreeByteCodeInternalRep _ANSI_ARGS_((  
                             Tcl_Obj *objPtr));  
 static int              GetCmdLocEncodingSize _ANSI_ARGS_((  
                             CompileEnv *envPtr));  
 static void             LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,  
                             char *script, char *command, int length));  
 #ifdef TCL_COMPILE_STATS  
 static void             RecordByteCodeStats _ANSI_ARGS_((  
                             ByteCode *codePtr));  
 #endif /* TCL_COMPILE_STATS */  
 static int              SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,  
                             Tcl_Obj *objPtr));  
   
 /*  
  * The structure below defines the bytecode Tcl object type by  
  * means of procedures that can be invoked by generic object code.  
  */  
   
 Tcl_ObjType tclByteCodeType = {  
     "bytecode",                         /* name */  
     FreeByteCodeInternalRep,            /* freeIntRepProc */  
     DupByteCodeInternalRep,             /* dupIntRepProc */  
     (Tcl_UpdateStringProc *) NULL,      /* updateStringProc */  
     SetByteCodeFromAny                  /* setFromAnyProc */  
 };  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclSetByteCodeFromAny --  
  *  
  *      Part of the bytecode Tcl object type implementation. Attempts to  
  *      generate an byte code internal form for the Tcl object "objPtr" by  
  *      compiling its string representation.  This function also takes  
  *      a hook procedure that will be invoked to perform any needed post  
  *      processing on the compilation results before generating byte  
  *      codes.  
  *  
  * Results:  
  *      The return value is a standard Tcl object result. If an error occurs  
  *      during compilation, an error message is left in the interpreter's  
  *      result unless "interp" is NULL.  
  *  
  * Side effects:  
  *      Frees the old internal representation. If no error occurs, then the  
  *      compiled code is stored as "objPtr"s bytecode representation.  
  *      Also, if debugging, initializes the "tcl_traceCompile" Tcl variable  
  *      used to trace compilations.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)  
     Tcl_Interp *interp;         /* The interpreter for which the code is  
                                  * being compiled.  Must not be NULL. */  
     Tcl_Obj *objPtr;            /* The object to make a ByteCode object. */  
     CompileHookProc *hookProc;  /* Procedure to invoke after compilation. */  
     ClientData clientData;      /* Hook procedure private data. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     CompileEnv compEnv;         /* Compilation environment structure  
                                  * allocated in frame. */  
     LiteralTable *localTablePtr = &(compEnv.localLitTable);  
     register AuxData *auxDataPtr;  
     LiteralEntry *entryPtr;  
     register int i;  
     int length, nested, result;  
     char *string;  
   
     if (!traceInitialized) {  
         if (Tcl_LinkVar(interp, "tcl_traceCompile",  
                     (char *) &tclTraceCompile,  TCL_LINK_INT) != TCL_OK) {  
             panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");  
         }  
         traceInitialized = 1;  
     }  
   
     if (iPtr->evalFlags & TCL_BRACKET_TERM) {  
         nested = 1;  
     } else {  
         nested = 0;  
     }  
     string = Tcl_GetStringFromObj(objPtr, &length);  
     TclInitCompileEnv(interp, &compEnv, string, length);  
     result = TclCompileScript(interp, string, length, nested, &compEnv);  
   
     if (result == TCL_OK) {  
         /*  
          * Successful compilation. Add a "done" instruction at the end.  
          */  
   
         compEnv.numSrcBytes = iPtr->termOffset;  
         TclEmitOpcode(INST_DONE, &compEnv);  
   
         /*  
          * Invoke the compilation hook procedure if one exists.  
          */  
   
         if (hookProc) {  
             result = (*hookProc)(interp, &compEnv, clientData);  
         }  
   
         /*  
          * Change the object into a ByteCode object. Ownership of the literal  
          * objects and aux data items is given to the ByteCode object.  
          */  
       
 #ifdef TCL_COMPILE_DEBUG  
         TclVerifyLocalLiteralTable(&compEnv);  
 #endif /*TCL_COMPILE_DEBUG*/  
   
         TclInitByteCodeObj(objPtr, &compEnv);  
 #ifdef TCL_COMPILE_DEBUG  
         if (tclTraceCompile == 2) {  
             TclPrintByteCodeObj(interp, objPtr);  
         }  
 #endif /* TCL_COMPILE_DEBUG */  
     }  
           
     if (result != TCL_OK) {  
         /*  
          * Compilation errors.  
          */  
   
         entryPtr = compEnv.literalArrayPtr;  
         for (i = 0;  i < compEnv.literalArrayNext;  i++) {  
             TclReleaseLiteral(interp, entryPtr->objPtr);  
             entryPtr++;  
         }  
 #ifdef TCL_COMPILE_DEBUG  
         TclVerifyGlobalLiteralTable(iPtr);  
 #endif /*TCL_COMPILE_DEBUG*/  
   
         auxDataPtr = compEnv.auxDataArrayPtr;  
         for (i = 0;  i < compEnv.auxDataArrayNext;  i++) {  
             if (auxDataPtr->type->freeProc != NULL) {  
                 auxDataPtr->type->freeProc(auxDataPtr->clientData);  
             }  
             auxDataPtr++;  
         }  
     }  
   
   
     /*  
      * Free storage allocated during compilation.  
      */  
       
     if (localTablePtr->buckets != localTablePtr->staticBuckets) {  
         ckfree((char *) localTablePtr->buckets);  
     }  
     TclFreeCompileEnv(&compEnv);  
     return result;  
 }  
   
 /*  
  *-----------------------------------------------------------------------  
  *  
  * SetByteCodeFromAny --  
  *  
  *      Part of the bytecode Tcl object type implementation. Attempts to  
  *      generate an byte code internal form for the Tcl object "objPtr" by  
  *      compiling its string representation.  
  *  
  * Results:  
  *      The return value is a standard Tcl object result. If an error occurs  
  *      during compilation, an error message is left in the interpreter's  
  *      result unless "interp" is NULL.  
  *  
  * Side effects:  
  *      Frees the old internal representation. If no error occurs, then the  
  *      compiled code is stored as "objPtr"s bytecode representation.  
  *      Also, if debugging, initializes the "tcl_traceCompile" Tcl variable  
  *      used to trace compilations.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 SetByteCodeFromAny(interp, objPtr)  
     Tcl_Interp *interp;         /* The interpreter for which the code is  
                                  * being compiled.  Must not be NULL. */  
     Tcl_Obj *objPtr;            /* The object to make a ByteCode object. */  
 {  
     return TclSetByteCodeFromAny(interp, objPtr,  
             (CompileHookProc *) NULL, (ClientData) NULL);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * DupByteCodeInternalRep --  
  *  
  *      Part of the bytecode Tcl object type implementation. However, it  
  *      does not copy the internal representation of a bytecode Tcl_Obj, but  
  *      instead leaves the new object untyped (with a NULL type pointer).  
  *      Code will be compiled for the new object only if necessary.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 DupByteCodeInternalRep(srcPtr, copyPtr)  
     Tcl_Obj *srcPtr;            /* Object with internal rep to copy. */  
     Tcl_Obj *copyPtr;           /* Object with internal rep to set. */  
 {  
     return;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * FreeByteCodeInternalRep --  
  *  
  *      Part of the bytecode Tcl object type implementation. Frees the  
  *      storage associated with a bytecode object's internal representation  
  *      unless its code is actively being executed.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The bytecode object's internal rep is marked invalid and its  
  *      code gets freed unless the code is actively being executed.  
  *      In that case the cleanup is delayed until the last execution  
  *      of the code completes.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 FreeByteCodeInternalRep(objPtr)  
     register Tcl_Obj *objPtr;   /* Object whose internal rep to free. */  
 {  
     register ByteCode *codePtr =  
             (ByteCode *) objPtr->internalRep.otherValuePtr;  
   
     codePtr->refCount--;  
     if (codePtr->refCount <= 0) {  
         TclCleanupByteCode(codePtr);  
     }  
     objPtr->typePtr = NULL;  
     objPtr->internalRep.otherValuePtr = NULL;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCleanupByteCode --  
  *  
  *      This procedure does all the real work of freeing up a bytecode  
  *      object's ByteCode structure. It's called only when the structure's  
  *      reference count becomes zero.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Frees objPtr's bytecode internal representation and sets its type  
  *      and objPtr->internalRep.otherValuePtr NULL. Also releases its  
  *      literals and frees its auxiliary data items.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclCleanupByteCode(codePtr)  
     register ByteCode *codePtr; /* Points to the ByteCode to free. */  
 {  
     Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;  
     int numLitObjects = codePtr->numLitObjects;  
     int numAuxDataItems = codePtr->numAuxDataItems;  
     register Tcl_Obj **objArrayPtr;  
     register AuxData *auxDataPtr;  
     int i;  
 #ifdef TCL_COMPILE_STATS  
   
     if (interp != NULL) {  
         ByteCodeStats *statsPtr;  
         Tcl_Time destroyTime;  
         int lifetimeSec, lifetimeMicroSec, log2;  
   
         statsPtr = &((Interp *) interp)->stats;  
   
         statsPtr->numByteCodesFreed++;  
         statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;  
         statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;  
   
         statsPtr->currentInstBytes   -= (double) codePtr->numCodeBytes;  
         statsPtr->currentLitBytes    -=  
                 (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));  
         statsPtr->currentExceptBytes -=  
                 (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));  
         statsPtr->currentAuxBytes    -=  
                 (double) (codePtr->numAuxDataItems * sizeof(AuxData));  
         statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;  
   
         TclpGetTime(&destroyTime);  
         lifetimeSec = destroyTime.sec - codePtr->createTime.sec;  
         if (lifetimeSec > 2000) {       /* avoid overflow */  
             lifetimeSec = 2000;  
         }  
         lifetimeMicroSec =  
             1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);  
           
         log2 = TclLog2(lifetimeMicroSec);  
         if (log2 > 31) {  
             log2 = 31;  
         }  
         statsPtr->lifetimeCount[log2]++;  
     }  
 #endif /* TCL_COMPILE_STATS */  
   
     /*  
      * A single heap object holds the ByteCode structure and its code,  
      * object, command location, and auxiliary data arrays. This means we  
      * only need to 1) decrement the ref counts of the LiteralEntry's in  
      * its literal array, 2) call the free procs for the auxiliary data  
      * items, and 3) free the ByteCode structure's heap object.  
      *  
      * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,  
      * like those generated from tbcload) is special, as they doesn't  
      * make use of the global literal table.  They instead maintain  
      * private references to their literals which must be decremented.  
      */  
   
     if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {  
         register Tcl_Obj *objPtr;  
   
         objArrayPtr = codePtr->objArrayPtr;  
         for (i = 0;  i < numLitObjects;  i++) {  
             objPtr = *objArrayPtr;  
             if (objPtr) {  
                 Tcl_DecrRefCount(objPtr);  
             }  
             objArrayPtr++;  
         }  
         codePtr->numLitObjects = 0;  
     } else if (interp != NULL) {  
         /*  
          * If the interp has already been freed, then Tcl will have already  
          * forcefully released all the literals used by ByteCodes compiled  
          * with respect to that interp.  
          */  
           
         objArrayPtr = codePtr->objArrayPtr;  
         for (i = 0;  i < numLitObjects;  i++) {  
             /*  
              * TclReleaseLiteral sets a ByteCode's object array entry NULL to  
              * indicate that it has already freed the literal.  
              */  
               
             if (*objArrayPtr != NULL) {  
                 TclReleaseLiteral(interp, *objArrayPtr);  
             }  
             objArrayPtr++;  
         }  
     }  
       
     auxDataPtr = codePtr->auxDataArrayPtr;  
     for (i = 0;  i < numAuxDataItems;  i++) {  
         if (auxDataPtr->type->freeProc != NULL) {  
             (*auxDataPtr->type->freeProc)(auxDataPtr->clientData);  
         }  
         auxDataPtr++;  
     }  
   
     TclHandleRelease(codePtr->interpHandle);  
     ckfree((char *) codePtr);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclInitCompileEnv --  
  *  
  *      Initializes a CompileEnv compilation environment structure for the  
  *      compilation of a string in an interpreter.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The CompileEnv structure is initialized.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclInitCompileEnv(interp, envPtr, string, numBytes)  
     Tcl_Interp *interp;          /* The interpreter for which a CompileEnv  
                                   * structure is initialized. */  
     register CompileEnv *envPtr; /* Points to the CompileEnv structure to  
                                   * initialize. */  
     char *string;                /* The source string to be compiled. */  
     int numBytes;                /* Number of bytes in source string. */  
 {  
     Interp *iPtr = (Interp *) interp;  
       
     envPtr->iPtr = iPtr;  
     envPtr->source = string;  
     envPtr->numSrcBytes = numBytes;  
     envPtr->procPtr = iPtr->compiledProcPtr;  
     envPtr->numCommands = 0;  
     envPtr->exceptDepth = 0;  
     envPtr->maxExceptDepth = 0;  
     envPtr->maxStackDepth = 0;  
     TclInitLiteralTable(&(envPtr->localLitTable));  
     envPtr->exprIsJustVarRef = 0;  
     envPtr->exprIsComparison = 0;  
   
     envPtr->codeStart = envPtr->staticCodeSpace;  
     envPtr->codeNext = envPtr->codeStart;  
     envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);  
     envPtr->mallocedCodeArray = 0;  
   
     envPtr->literalArrayPtr = envPtr->staticLiteralSpace;  
     envPtr->literalArrayNext = 0;  
     envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;  
     envPtr->mallocedLiteralArray = 0;  
       
     envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;  
     envPtr->exceptArrayNext = 0;  
     envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;  
     envPtr->mallocedExceptArray = 0;  
       
     envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;  
     envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;  
     envPtr->mallocedCmdMap = 0;  
       
     envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;  
     envPtr->auxDataArrayNext = 0;  
     envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;  
     envPtr->mallocedAuxDataArray = 0;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclFreeCompileEnv --  
  *  
  *      Free the storage allocated in a CompileEnv compilation environment  
  *      structure.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Allocated storage in the CompileEnv structure is freed. Note that  
  *      its local literal table is not deleted and its literal objects are  
  *      not released. In addition, storage referenced by its auxiliary data  
  *      items is not freed. This is done so that, when compilation is  
  *      successful, "ownership" of these objects and aux data items is  
  *      handed over to the corresponding ByteCode structure.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclFreeCompileEnv(envPtr)  
     register CompileEnv *envPtr; /* Points to the CompileEnv structure. */  
 {  
     if (envPtr->mallocedCodeArray) {  
         ckfree((char *) envPtr->codeStart);  
     }  
     if (envPtr->mallocedLiteralArray) {  
         ckfree((char *) envPtr->literalArrayPtr);  
     }  
     if (envPtr->mallocedExceptArray) {  
         ckfree((char *) envPtr->exceptArrayPtr);  
     }  
     if (envPtr->mallocedCmdMap) {  
         ckfree((char *) envPtr->cmdMapPtr);  
     }  
     if (envPtr->mallocedAuxDataArray) {  
         ckfree((char *) envPtr->auxDataArrayPtr);  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileScript --  
  *  
  *      Compile a Tcl script in a string.  
  *  
  * Results:  
  *      The return value is TCL_OK on a successful compilation and TCL_ERROR  
  *      on failure. If TCL_ERROR is returned, then the interpreter's result  
  *      contains an error message.  
  *  
  *      interp->termOffset is set to the offset of the character in the  
  *      script just after the last one successfully processed; this will be  
  *      the offset of the ']' if (flags & TCL_BRACKET_TERM).  
  *      envPtr->maxStackDepth is set to the maximum number of stack elements  
  *      needed to execute the script's commands.  
  *  
  * Side effects:  
  *      Adds instructions to envPtr to evaluate the script at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileScript(interp, script, numBytes, nested, envPtr)  
     Tcl_Interp *interp;         /* Used for error and status reporting. */  
     char *script;               /* The source script to compile. */  
     int numBytes;               /* Number of bytes in script. If < 0, the  
                                  * script consists of all bytes up to the  
                                  * first null character. */  
     int nested;                 /* Non-zero means this is a nested command:  
                                  * close bracket ']' should be considered a  
                                  * command terminator. If zero, close  
                                  * bracket has no special meaning. */  
     CompileEnv *envPtr;         /* Holds resulting instructions. */  
 {  
     Interp *iPtr = (Interp *) interp;  
     Tcl_Parse parse;  
     int maxDepth = 0;           /* Maximum number of stack elements needed  
                                  * to execute all cmds. */  
     int lastTopLevelCmdIndex = -1;  
                                 /* Index of most recent toplevel command in  
                                  * the command location table. Initialized  
                                  * to avoid compiler warning. */  
     int startCodeOffset = -1;   /* Offset of first byte of current command's  
                                  * code. Init. to avoid compiler warning. */  
     unsigned char *entryCodeNext = envPtr->codeNext;  
     char *p, *next;  
     Namespace *cmdNsPtr;  
     Command *cmdPtr;  
     Tcl_Token *tokenPtr;  
     int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;  
     int commandLength, objIndex, code;  
     char prev;  
     Tcl_DString ds;  
   
     Tcl_DStringInit(&ds);  
   
     if (numBytes < 0) {  
         numBytes = strlen(script);  
     }  
     Tcl_ResetResult(interp);  
     isFirstCmd = 1;  
   
     /*  
      * Each iteration through the following loop compiles the next  
      * command from the script.  
      */  
   
     p = script;  
     bytesLeft = numBytes;  
     gotParse = 0;  
     while (bytesLeft > 0) {  
         if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {  
             code = TCL_ERROR;  
             goto error;  
         }  
         gotParse = 1;  
         if (parse.numWords > 0) {  
             /*  
              * If not the first command, pop the previous command's result  
              * and, if we're compiling a top level command, update the last  
              * command's code size to account for the pop instruction.  
              */  
   
             if (!isFirstCmd) {  
                 TclEmitOpcode(INST_POP, envPtr);  
                 if (!nested) {  
                     envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =  
                            (envPtr->codeNext - envPtr->codeStart)  
                            - startCodeOffset;  
                 }  
             }  
   
             /*  
              * Determine the actual length of the command.  
              */  
   
             commandLength = parse.commandSize;  
             prev = '\0';  
             if (commandLength > 0) {  
                 prev = parse.commandStart[commandLength-1];  
             }  
             if (((parse.commandStart+commandLength) != (script+numBytes))  
                     || ((prev=='\n') || (nested && (prev==']')))) {  
                 /*  
                  * The command didn't end at the end of the script (i.e.  it  
                  * ended at a terminator character such as ";".  Reduce the  
                  * length by one so that the trace message doesn't include  
                  * the terminator character.  
                  */  
                   
                 commandLength -= 1;  
             }  
   
             /*  
              * If tracing, print a line for each top level command compiled.  
              */  
   
             if ((tclTraceCompile >= 1)  
                     && !nested && (envPtr->procPtr == NULL)) {  
                 fprintf(stdout, "  Compiling: ");  
                 TclPrintSource(stdout, parse.commandStart,  
                         TclMin(commandLength, 55));  
                 fprintf(stdout, "\n");  
             }  
   
             /*  
              * Each iteration of the following loop compiles one word  
              * from the command.  
              */  
               
             envPtr->numCommands++;  
             currCmdIndex = (envPtr->numCommands - 1);  
             if (!nested) {  
                 lastTopLevelCmdIndex = currCmdIndex;  
             }  
             startCodeOffset = (envPtr->codeNext - envPtr->codeStart);  
             EnterCmdStartData(envPtr, currCmdIndex,  
                     (parse.commandStart - envPtr->source), startCodeOffset);  
               
             for (wordIdx = 0, tokenPtr = parse.tokenPtr;  
                     wordIdx < parse.numWords;  
                     wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {  
                 if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {  
                     /*  
                      * If this is the first word and the command has a  
                      * compile procedure, let it compile the command.  
                      */  
   
                     if (wordIdx == 0) {  
                         if (envPtr->procPtr != NULL) {  
                             cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;  
                         } else {  
                             cmdNsPtr = NULL; /* use current NS */  
                         }  
   
                         /*  
                          * We copy the string before trying to find the command  
                          * by name.  We used to modify the string in place, but  
                          * this is not safe because the name resolution  
                          * handlers could have side effects that rely on the  
                          * unmodified string.  
                          */  
   
                         Tcl_DStringSetLength(&ds, 0);  
                         Tcl_DStringAppend(&ds, tokenPtr[1].start,  
                                 tokenPtr[1].size);  
   
                         cmdPtr = (Command *) Tcl_FindCommand(interp,  
                                 Tcl_DStringValue(&ds),  
                                 (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);  
   
                         if ((cmdPtr != NULL)  
                                 && (cmdPtr->compileProc != NULL)  
                                 && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {  
                             code = (*(cmdPtr->compileProc))(interp, &parse,  
                                     envPtr);  
                             if (code == TCL_OK) {  
                                 maxDepth = TclMax(envPtr->maxStackDepth,  
                                         maxDepth);  
                                 goto finishCommand;  
                             } else if (code == TCL_OUT_LINE_COMPILE) {  
                                 /* do nothing */  
                             } else { /* an error */  
                                 /*  
                                  * There was a compilation error, the last  
                                  * command did not get compiled into (*envPtr).  
                                  * Decrement the number of commands  
                                  * claimed to be in (*envPtr).  
                                  */  
                                 envPtr->numCommands--;  
                                 goto error;  
                             }  
                         }  
   
                         /*  
                          * No compile procedure so push the word. If the  
                          * command was found, push a CmdName object to  
                          * reduce runtime lookups.  
                          */  
   
                         objIndex = TclRegisterLiteral(envPtr,  
                                 tokenPtr[1].start, tokenPtr[1].size,  
                                 /*onHeap*/ 0);  
                         if (cmdPtr != NULL) {  
                             TclSetCmdNameObj(interp,  
                                    envPtr->literalArrayPtr[objIndex].objPtr,  
                                    cmdPtr);  
                         }  
                     } else {  
                         objIndex = TclRegisterLiteral(envPtr,  
                                 tokenPtr[1].start, tokenPtr[1].size,  
                                 /*onHeap*/ 0);  
                     }  
                     TclEmitPush(objIndex, envPtr);  
                     maxDepth = TclMax((wordIdx + 1), maxDepth);  
                 } else {  
                     /*  
                      * The word is not a simple string of characters.  
                      */  
                       
                     code = TclCompileTokens(interp, tokenPtr+1,  
                             tokenPtr->numComponents, envPtr);  
                     if (code != TCL_OK) {  
                         goto error;  
                     }  
                     maxDepth = TclMax((wordIdx + envPtr->maxStackDepth),  
                            maxDepth);  
                 }  
             }  
   
             /*  
              * Emit an invoke instruction for the command. We skip this  
              * if a compile procedure was found for the command.  
              */  
               
             if (wordIdx > 0) {  
                 if (wordIdx <= 255) {  
                     TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);  
                 } else {  
                     TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);  
                 }  
             }  
   
             /*  
              * Update the compilation environment structure and record the  
              * offsets of the source and code for the command.  
              */  
   
             finishCommand:  
             EnterCmdExtentData(envPtr, currCmdIndex, commandLength,  
                     (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);  
             isFirstCmd = 0;  
         } /* end if parse.numWords > 0 */  
   
         /*  
          * Advance to the next command in the script.  
          */  
           
         next = parse.commandStart + parse.commandSize;  
         bytesLeft -= (next - p);  
         p = next;  
         Tcl_FreeParse(&parse);  
         gotParse = 0;  
         if (nested && (p[-1] == ']')) {  
             /*  
              * We get here in the special case where TCL_BRACKET_TERM was  
              * set in the interpreter and we reached a close bracket in the  
              * script. Stop compilation.  
              */  
               
             break;  
         }  
     }  
   
     /*  
      * If the source script yielded no instructions (e.g., if it was empty),  
      * push an empty string as the command's result.  
      */  
       
     if (envPtr->codeNext == entryCodeNext) {  
         TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),  
                 envPtr);  
         maxDepth = 1;  
     }  
       
     if ((nested != 0) && (p > script) && (p[-1] == ']')) {  
         iPtr->termOffset = (p - 1) - script;  
     } else {  
         iPtr->termOffset = (p - script);  
     }  
     envPtr->maxStackDepth = maxDepth;  
     Tcl_DStringFree(&ds);  
     return TCL_OK;  
           
     error:  
     /*  
      * Generate various pieces of error information, such as the line  
      * number where the error occurred and information to add to the  
      * errorInfo variable. Then free resources that had been allocated  
      * to the command.  
      */  
   
     commandLength = parse.commandSize;  
     prev = '\0';  
     if (commandLength > 0) {  
         prev = parse.commandStart[commandLength-1];  
     }  
     if (((parse.commandStart+commandLength) != (script+numBytes))  
             || ((prev == '\n') || (nested && (prev == ']')))) {  
         /*  
          * The command where the error occurred didn't end at the end  
          * of the script (i.e. it ended at a terminator character such  
          * as ";".  Reduce the length by one so that the error message  
          * doesn't include the terminator character.  
          */  
   
         commandLength -= 1;  
     }  
     LogCompilationInfo(interp, script, parse.commandStart, commandLength);  
     if (gotParse) {  
         Tcl_FreeParse(&parse);  
     }  
     iPtr->termOffset = (p - script);  
     envPtr->maxStackDepth = maxDepth;  
     Tcl_DStringFree(&ds);  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileTokens --  
  *  
  *      Given an array of tokens parsed from a Tcl command (e.g., the tokens  
  *      that make up a word) this procedure emits instructions to evaluate  
  *      the tokens and concatenate their values to form a single result  
  *      value on the interpreter's runtime evaluation stack.  
  *  
  * Results:  
  *      The return value is a standard Tcl result. If an error occurs, an  
  *      error message is left in the interpreter's result.  
  *        
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to evaluate the tokens.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to push and evaluate the tokens  
  *      at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileTokens(interp, tokenPtr, count, envPtr)  
     Tcl_Interp *interp;         /* Used for error and status reporting. */  
     Tcl_Token *tokenPtr;        /* Pointer to first in an array of tokens  
                                  * to compile. */  
     int count;                  /* Number of tokens to consider at tokenPtr.  
                                  * Must be at least 1. */  
     CompileEnv *envPtr;         /* Holds the resulting instructions. */  
 {  
     Tcl_DString textBuffer;     /* Holds concatenated chars from adjacent  
                                  * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */  
     char buffer[TCL_UTF_MAX];  
     char *name, *p;  
     int numObjsToConcat, nameBytes, hasNsQualifiers, localVar;  
     int length, maxDepth, depthForVar, i, code;  
     unsigned char *entryCodeNext = envPtr->codeNext;  
   
     Tcl_DStringInit(&textBuffer);  
     maxDepth = 0;  
     numObjsToConcat = 0;  
     for ( ;  count > 0;  count--, tokenPtr++) {  
         switch (tokenPtr->type) {  
             case TCL_TOKEN_TEXT:  
                 Tcl_DStringAppend(&textBuffer, tokenPtr->start,  
                         tokenPtr->size);  
                 break;  
   
             case TCL_TOKEN_BS:  
                 length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,  
                         buffer);  
                 Tcl_DStringAppend(&textBuffer, buffer, length);  
                 break;  
   
             case TCL_TOKEN_COMMAND:  
                 /*  
                  * Push any accumulated chars appearing before the command.  
                  */  
                   
                 if (Tcl_DStringLength(&textBuffer) > 0) {  
                     int literal;  
                       
                     literal = TclRegisterLiteral(envPtr,  
                             Tcl_DStringValue(&textBuffer),  
                             Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);  
                     TclEmitPush(literal, envPtr);  
                     numObjsToConcat++;  
                     maxDepth = TclMax(numObjsToConcat, maxDepth);  
                     Tcl_DStringFree(&textBuffer);  
                 }  
                   
                 code = TclCompileScript(interp, tokenPtr->start+1,  
                         tokenPtr->size-2, /*nested*/ 1, envPtr);  
                 if (code != TCL_OK) {  
                     goto error;  
                 }  
                 maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth),  
                         maxDepth);  
                 numObjsToConcat++;  
                 break;  
   
             case TCL_TOKEN_VARIABLE:  
                 /*  
                  * Push any accumulated chars appearing before the $<var>.  
                  */  
                   
                 if (Tcl_DStringLength(&textBuffer) > 0) {  
                     int literal;  
                       
                     literal = TclRegisterLiteral(envPtr,  
                             Tcl_DStringValue(&textBuffer),  
                             Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);  
                     TclEmitPush(literal, envPtr);  
                     numObjsToConcat++;  
                     maxDepth = TclMax(numObjsToConcat, maxDepth);  
                     Tcl_DStringFree(&textBuffer);  
                 }  
                   
                 /*  
                  * Check if the name contains any namespace qualifiers.  
                  */  
                   
                 name = tokenPtr[1].start;  
                 nameBytes = tokenPtr[1].size;  
                 hasNsQualifiers = 0;  
                 for (i = 0, p = name;  i < nameBytes;  i++, p++) {  
                     if ((*p == ':') && (i < (nameBytes-1))  
                             && (*(p+1) == ':')) {  
                         hasNsQualifiers = 1;  
                         break;  
                     }  
                 }  
   
                 /*  
                  * Either push the variable's name, or find its index in  
                  * the array of local variables in a procedure frame.  
                  */  
   
                 depthForVar = 0;  
                 if ((envPtr->procPtr == NULL) || hasNsQualifiers) {  
                     localVar = -1;  
                     TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes,  
                             /*onHeap*/ 0), envPtr);  
                     depthForVar = 1;  
                 } else {  
                     localVar = TclFindCompiledLocal(name, nameBytes,  
                             /*create*/ 0, /*flags*/ 0, envPtr->procPtr);  
                     if (localVar < 0) {  
                         TclEmitPush(TclRegisterLiteral(envPtr, name,  
                                 nameBytes, /*onHeap*/ 0), envPtr);  
                         depthForVar = 1;  
                     }  
                 }  
   
                 /*  
                  * Emit instructions to load the variable.  
                  */  
                   
                 if (tokenPtr->numComponents == 1) {  
                     if (localVar < 0) {  
                         TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);  
                     } else if (localVar <= 255) {  
                         TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,  
                                 envPtr);  
                     } else {  
                         TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,  
                                 envPtr);  
                     }  
                 } else {  
                     code = TclCompileTokens(interp, tokenPtr+2,  
                             tokenPtr->numComponents-1, envPtr);  
                     if (code != TCL_OK) {  
                         sprintf(buffer,  
                                 "\n    (parsing index for array \"%.*s\")",  
                                 ((nameBytes > 100)? 100 : nameBytes), name);  
                         Tcl_AddObjErrorInfo(interp, buffer, -1);  
                         goto error;  
                     }  
                     depthForVar += envPtr->maxStackDepth;  
                     if (localVar < 0) {  
                         TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);  
                     } else if (localVar <= 255) {  
                         TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,  
                                 envPtr);  
                     } else {  
                         TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,  
                                 envPtr);  
                     }  
                 }  
                 maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth);  
                 numObjsToConcat++;  
                 count -= tokenPtr->numComponents;  
                 tokenPtr += tokenPtr->numComponents;  
                 break;  
   
             default:  
                 panic("Unexpected token type in TclCompileTokens");  
         }  
     }  
   
     /*  
      * Push any accumulated characters appearing at the end.  
      */  
   
     if (Tcl_DStringLength(&textBuffer) > 0) {  
         int literal;  
   
         literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),  
                 Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);  
         TclEmitPush(literal, envPtr);  
         numObjsToConcat++;  
         maxDepth = TclMax(numObjsToConcat, maxDepth);  
     }  
   
     /*  
      * If necessary, concatenate the parts of the word.  
      */  
   
     while (numObjsToConcat > 255) {  
         TclEmitInstInt1(INST_CONCAT1, 255, envPtr);  
         numObjsToConcat -= 254; /* concat pushes 1 obj, the result */  
     }  
     if (numObjsToConcat > 1) {  
         TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);  
     }  
   
     /*  
      * If the tokens yielded no instructions, push an empty string.  
      */  
       
     if (envPtr->codeNext == entryCodeNext) {  
         TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),  
                 envPtr);  
         maxDepth = 1;  
     }  
     Tcl_DStringFree(&textBuffer);  
     envPtr->maxStackDepth = maxDepth;  
     return TCL_OK;  
   
     error:  
     Tcl_DStringFree(&textBuffer);  
     envPtr->maxStackDepth = maxDepth;  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileCmdWord --  
  *  
  *      Given an array of parse tokens for a word containing one or more Tcl  
  *      commands, emit inline instructions to execute them. This procedure  
  *      differs from TclCompileTokens in that a simple word such as a loop  
  *      body enclosed in braces is not just pushed as a string, but is  
  *      itself parsed into tokens and compiled.  
  *  
  * Results:  
  *      The return value is a standard Tcl result. If an error occurs, an  
  *      error message is left in the interpreter's result.  
  *        
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the tokens.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the tokens at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileCmdWord(interp, tokenPtr, count, envPtr)  
     Tcl_Interp *interp;         /* Used for error and status reporting. */  
     Tcl_Token *tokenPtr;        /* Pointer to first in an array of tokens  
                                  * for a command word to compile inline. */  
     int count;                  /* Number of tokens to consider at tokenPtr.  
                                  * Must be at least 1. */  
     CompileEnv *envPtr;         /* Holds the resulting instructions. */  
 {  
     int code;  
   
     /*  
      * Handle the common case: if there is a single text token, compile it  
      * into an inline sequence of instructions.  
      */  
       
     envPtr->maxStackDepth = 0;  
     if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {  
         code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,  
                 /*nested*/ 0, envPtr);  
         return code;  
     }  
   
     /*  
      * Multiple tokens or the single token involves substitutions. Emit  
      * instructions to invoke the eval command procedure at runtime on the  
      * result of evaluating the tokens.  
      */  
   
     code = TclCompileTokens(interp, tokenPtr, count, envPtr);  
     if (code != TCL_OK) {  
         return code;  
     }  
     TclEmitOpcode(INST_EVAL_STK, envPtr);  
     return TCL_OK;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCompileExprWords --  
  *  
  *      Given an array of parse tokens representing one or more words that  
  *      contain a Tcl expression, emit inline instructions to execute the  
  *      expression. This procedure differs from TclCompileExpr in that it  
  *      supports Tcl's two-level substitution semantics for expressions that  
  *      appear as command words.  
  *  
  * Results:  
  *      The return value is a standard Tcl result. If an error occurs, an  
  *      error message is left in the interpreter's result.  
  *        
  *      envPtr->maxStackDepth is updated with the maximum number of stack  
  *      elements needed to execute the expression.  
  *  
  * Side effects:  
  *      Instructions are added to envPtr to execute the expression.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCompileExprWords(interp, tokenPtr, numWords, envPtr)  
     Tcl_Interp *interp;         /* Used for error and status reporting. */  
     Tcl_Token *tokenPtr;        /* Points to first in an array of word  
                                  * tokens tokens for the expression to  
                                  * compile inline. */  
     int numWords;               /* Number of word tokens starting at  
                                  * tokenPtr. Must be at least 1. Each word  
                                  * token contains one or more subtokens. */  
     CompileEnv *envPtr;         /* Holds the resulting instructions. */  
 {  
     Tcl_Token *wordPtr;  
     int maxDepth, range, numBytes, i, code;  
     char *script;  
     int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;  
     int saveExprIsComparison = envPtr->exprIsComparison;  
   
     envPtr->maxStackDepth = 0;  
     maxDepth = 0;  
     range = -1;  
     code = TCL_OK;  
   
     /*  
      * If the expression is a single word that doesn't require  
      * substitutions, just compile it's string into inline instructions.  
      */  
   
     if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {  
         /*  
          * Temporarily overwrite the character just after the end of the  
          * string with a 0 byte.  
          */  
   
         script = tokenPtr[1].start;  
         numBytes = tokenPtr[1].size;  
         code = TclCompileExpr(interp, script, numBytes, envPtr);  
         return code;  
     }  
     
     /*  
      * Emit code to call the expr command proc at runtime. Concatenate the  
      * (already substituted once) expr tokens with a space between each.  
      */  
   
     wordPtr = tokenPtr;  
     for (i = 0;  i < numWords;  i++) {  
         code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,  
                 envPtr);  
         if (code != TCL_OK) {  
             break;  
         }  
         if (i < (numWords - 1)) {  
             TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),  
                     envPtr);  
             maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);  
         } else {  
             maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);  
         }  
         wordPtr += (wordPtr->numComponents + 1);  
     }  
     if (code == TCL_OK) {  
         int concatItems = 2*numWords - 1;  
         while (concatItems > 255) {  
             TclEmitInstInt1(INST_CONCAT1, 255, envPtr);  
             concatItems -= 254;  
         }  
         if (concatItems > 1) {  
             TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);  
         }  
         TclEmitOpcode(INST_EXPR_STK, envPtr);  
     }  
   
     envPtr->exprIsJustVarRef = saveExprIsJustVarRef;  
     envPtr->exprIsComparison = saveExprIsComparison;  
     envPtr->maxStackDepth = maxDepth;  
     return code;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclInitByteCodeObj --  
  *  
  *      Create a ByteCode structure and initialize it from a CompileEnv  
  *      compilation environment structure. The ByteCode structure is  
  *      smaller and contains just that information needed to execute  
  *      the bytecode instructions resulting from compiling a Tcl script.  
  *      The resulting structure is placed in the specified object.  
  *  
  * Results:  
  *      A newly constructed ByteCode object is stored in the internal  
  *      representation of the objPtr.  
  *  
  * Side effects:  
  *      A single heap object is allocated to hold the new ByteCode structure  
  *      and its code, object, command location, and aux data arrays. Note  
  *      that "ownership" (i.e., the pointers to) the Tcl objects and aux  
  *      data items will be handed over to the new ByteCode structure from  
  *      the CompileEnv structure.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclInitByteCodeObj(objPtr, envPtr)  
     Tcl_Obj *objPtr;             /* Points object that should be  
                                   * initialized, and whose string rep  
                                   * contains the source code. */  
     register CompileEnv *envPtr; /* Points to the CompileEnv structure from  
                                   * which to create a ByteCode structure. */  
 {  
     register ByteCode *codePtr;  
     size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;  
     size_t auxDataArrayBytes, structureSize;  
     register unsigned char *p;  
     unsigned char *nextPtr;  
     int numLitObjects = envPtr->literalArrayNext;  
     Namespace *namespacePtr;  
     int i;  
     Interp *iPtr;  
   
     iPtr = envPtr->iPtr;  
   
     codeBytes = (envPtr->codeNext - envPtr->codeStart);  
     objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));  
     exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));  
     auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));  
     cmdLocBytes = GetCmdLocEncodingSize(envPtr);  
       
     /*  
      * Compute the total number of bytes needed for this bytecode.  
      */  
   
     structureSize = sizeof(ByteCode);  
     structureSize += TCL_ALIGN(codeBytes);        /* align object array */  
     structureSize += TCL_ALIGN(objArrayBytes);    /* align exc range arr */  
     structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */  
     structureSize += auxDataArrayBytes;  
     structureSize += cmdLocBytes;  
   
     if (envPtr->iPtr->varFramePtr != NULL) {  
         namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;  
     } else {  
         namespacePtr = envPtr->iPtr->globalNsPtr;  
     }  
       
     p = (unsigned char *) ckalloc((size_t) structureSize);  
     codePtr = (ByteCode *) p;  
     codePtr->interpHandle = TclHandlePreserve(iPtr->handle);  
     codePtr->compileEpoch = iPtr->compileEpoch;  
     codePtr->nsPtr = namespacePtr;  
     codePtr->nsEpoch = namespacePtr->resolverEpoch;  
     codePtr->refCount = 1;  
     codePtr->flags = 0;  
     codePtr->source = envPtr->source;  
     codePtr->procPtr = envPtr->procPtr;  
   
     codePtr->numCommands = envPtr->numCommands;  
     codePtr->numSrcBytes = envPtr->numSrcBytes;  
     codePtr->numCodeBytes = codeBytes;  
     codePtr->numLitObjects = numLitObjects;  
     codePtr->numExceptRanges = envPtr->exceptArrayNext;  
     codePtr->numAuxDataItems = envPtr->auxDataArrayNext;  
     codePtr->numCmdLocBytes = cmdLocBytes;  
     codePtr->maxExceptDepth = envPtr->maxExceptDepth;  
     codePtr->maxStackDepth = envPtr->maxStackDepth;  
       
     p += sizeof(ByteCode);  
     codePtr->codeStart = p;  
     memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);  
       
     p += TCL_ALIGN(codeBytes);        /* align object array */  
     codePtr->objArrayPtr = (Tcl_Obj **) p;  
     for (i = 0;  i < numLitObjects;  i++) {  
         codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;  
     }  
   
     p += TCL_ALIGN(objArrayBytes);    /* align exception range array */  
     if (exceptArrayBytes > 0) {  
         codePtr->exceptArrayPtr = (ExceptionRange *) p;  
         memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,  
                 (size_t) exceptArrayBytes);  
     } else {  
         codePtr->exceptArrayPtr = NULL;  
     }  
       
     p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */  
     if (auxDataArrayBytes > 0) {  
         codePtr->auxDataArrayPtr = (AuxData *) p;  
         memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,  
                 (size_t) auxDataArrayBytes);  
     } else {  
         codePtr->auxDataArrayPtr = NULL;  
     }  
   
     p += auxDataArrayBytes;  
     nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);  
 #ifdef TCL_COMPILE_DEBUG  
     if (((size_t)(nextPtr - p)) != cmdLocBytes) {        
         panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);  
     }  
 #endif  
       
     /*  
      * Record various compilation-related statistics about the new ByteCode  
      * structure. Don't include overhead for statistics-related fields.  
      */  
   
 #ifdef TCL_COMPILE_STATS  
     codePtr->structureSize = structureSize  
             - (sizeof(size_t) + sizeof(Tcl_Time));  
     TclpGetTime(&(codePtr->createTime));  
       
     RecordByteCodeStats(codePtr);  
 #endif /* TCL_COMPILE_STATS */  
       
     /*  
      * Free the old internal rep then convert the object to a  
      * bytecode object by making its internal rep point to the just  
      * compiled ByteCode.  
      */  
               
     if ((objPtr->typePtr != NULL) &&  
             (objPtr->typePtr->freeIntRepProc != NULL)) {  
         (*objPtr->typePtr->freeIntRepProc)(objPtr);  
     }  
     objPtr->internalRep.otherValuePtr = (VOID *) codePtr;  
     objPtr->typePtr = &tclByteCodeType;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * LogCompilationInfo --  
  *  
  *      This procedure is invoked after an error occurs during compilation.  
  *      It adds information to the "errorInfo" variable to describe the  
  *      command that was being compiled when the error occurred.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Information about the command is added to errorInfo and the  
  *      line number stored internally in the interpreter is set.  If this  
  *      is the first call to this procedure or Tcl_AddObjErrorInfo since  
  *      an error occurred, then old information in errorInfo is  
  *      deleted.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 LogCompilationInfo(interp, script, command, length)  
     Tcl_Interp *interp;         /* Interpreter in which to log the  
                                  * information. */  
     char *script;               /* First character in script containing  
                                  * command (must be <= command). */  
     char *command;              /* First character in command that  
                                  * generated the error. */  
     int length;                 /* Number of bytes in command (-1 means  
                                  * use all bytes up to first null byte). */  
 {  
     char buffer[200];  
     register char *p;  
     char *ellipsis = "";  
     Interp *iPtr = (Interp *) interp;  
   
     if (iPtr->flags & ERR_ALREADY_LOGGED) {  
         /*  
          * Someone else has already logged error information for this  
          * command; we shouldn't add anything more.  
          */  
   
         return;  
     }  
   
     /*  
      * Compute the line number where the error occurred.  
      */  
   
     iPtr->errorLine = 1;  
     for (p = script; p != command; p++) {  
         if (*p == '\n') {  
             iPtr->errorLine++;  
         }  
     }  
   
     /*  
      * Create an error message to add to errorInfo, including up to a  
      * maximum number of characters of the command.  
      */  
   
     if (length < 0) {  
         length = strlen(command);  
     }  
     if (length > 150) {  
         length = 150;  
         ellipsis = "...";  
     }  
     sprintf(buffer, "\n    while compiling\n\"%.*s%s\"",  
             length, command, ellipsis);  
     Tcl_AddObjErrorInfo(interp, buffer, -1);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclFindCompiledLocal --  
  *  
  *      This procedure is called at compile time to look up and optionally  
  *      allocate an entry ("slot") for a variable in a procedure's array of  
  *      local variables. If the variable's name is NULL, a new temporary  
  *      variable is always created. (Such temporary variables can only be  
  *      referenced using their slot index.)  
  *  
  * Results:  
  *      If create is 0 and the name is non-NULL, then if the variable is  
  *      found, the index of its entry in the procedure's array of local  
  *      variables is returned; otherwise -1 is returned. If name is NULL,  
  *      the index of a new temporary variable is returned. Finally, if  
  *      create is 1 and name is non-NULL, the index of a new entry is  
  *      returned.  
  *  
  * Side effects:  
  *      Creates and registers a new local variable if create is 1 and  
  *      the variable is unknown, or if the name is NULL.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)  
     register char *name;        /* Points to first character of the name of  
                                  * a scalar or array variable. If NULL, a  
                                  * temporary var should be created. */  
     int nameBytes;              /* Number of bytes in the name. */  
     int create;                 /* If 1, allocate a local frame entry for  
                                  * the variable if it is new. */  
     int flags;                  /* Flag bits for the compiled local if  
                                  * created. Only VAR_SCALAR, VAR_ARRAY, and  
                                  * VAR_LINK make sense. */  
     register Proc *procPtr;     /* Points to structure describing procedure  
                                  * containing the variable reference. */  
 {  
     register CompiledLocal *localPtr;  
     int localVar = -1;  
     register int i;  
   
     /*  
      * If not creating a temporary, does a local variable of the specified  
      * name already exist?  
      */  
   
     if (name != NULL) {  
         int localCt = procPtr->numCompiledLocals;  
         localPtr = procPtr->firstLocalPtr;  
         for (i = 0;  i < localCt;  i++) {  
             if (!TclIsVarTemporary(localPtr)) {  
                 char *localName = localPtr->name;  
                 if ((nameBytes == localPtr->nameLength)  
                         && (strncmp(name, localName, (unsigned) nameBytes) == 0)) {  
                     return i;  
                 }  
             }  
             localPtr = localPtr->nextPtr;  
         }  
     }  
   
     /*  
      * Create a new variable if appropriate.  
      */  
       
     if (create || (name == NULL)) {  
         localVar = procPtr->numCompiledLocals;  
         localPtr = (CompiledLocal *) ckalloc((unsigned)  
                 (sizeof(CompiledLocal) - sizeof(localPtr->name)  
                 + nameBytes+1));  
         if (procPtr->firstLocalPtr == NULL) {  
             procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;  
         } else {  
             procPtr->lastLocalPtr->nextPtr = localPtr;  
             procPtr->lastLocalPtr = localPtr;  
         }  
         localPtr->nextPtr = NULL;  
         localPtr->nameLength = nameBytes;  
         localPtr->frameIndex = localVar;  
         localPtr->flags = flags;  
         if (name == NULL) {  
             localPtr->flags |= VAR_TEMPORARY;  
         }  
         localPtr->defValuePtr = NULL;  
         localPtr->resolveInfo = NULL;  
   
         if (name != NULL) {  
             memcpy((VOID *) localPtr->name, (VOID *) name,  
                     (size_t) nameBytes);  
         }  
         localPtr->name[nameBytes] = '\0';  
         procPtr->numCompiledLocals++;  
     }  
     return localVar;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclInitCompiledLocals --  
  *  
  *      This routine is invoked in order to initialize the compiled  
  *      locals table for a new call frame.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      May invoke various name resolvers in order to determine which  
  *      variables are being referenced at runtime.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclInitCompiledLocals(interp, framePtr, nsPtr)  
     Tcl_Interp *interp;         /* Current interpreter. */  
     CallFrame *framePtr;        /* Call frame to initialize. */  
     Namespace *nsPtr;           /* Pointer to current namespace. */  
 {  
     register CompiledLocal *localPtr;  
     Interp *iPtr = (Interp*) interp;  
     Tcl_ResolvedVarInfo *vinfo, *resVarInfo;  
     Var *varPtr = framePtr->compiledLocals;  
     Var *resolvedVarPtr;  
     ResolverScheme *resPtr;  
     int result;  
   
     /*  
      * Initialize the array of local variables stored in the call frame.  
      * Some variables may have special resolution rules.  In that case,  
      * we call their "resolver" procs to get our hands on the variable,  
      * and we make the compiled local a link to the real variable.  
      */  
   
     for (localPtr = framePtr->procPtr->firstLocalPtr;  
          localPtr != NULL;  
          localPtr = localPtr->nextPtr) {  
   
         /*  
          * Check to see if this local is affected by namespace or  
          * interp resolvers.  The resolver to use is cached for the  
          * next invocation of the procedure.  
          */  
   
         if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))  
                 && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {  
             resPtr = iPtr->resolverPtr;  
   
             if (nsPtr->compiledVarResProc) {  
                 result = (*nsPtr->compiledVarResProc)(nsPtr->interp,  
                         localPtr->name, localPtr->nameLength,  
                         (Tcl_Namespace *) nsPtr, &vinfo);  
             } else {  
                 result = TCL_CONTINUE;  
             }  
   
             while ((result == TCL_CONTINUE) && resPtr) {  
                 if (resPtr->compiledVarResProc) {  
                     result = (*resPtr->compiledVarResProc)(nsPtr->interp,  
                             localPtr->name, localPtr->nameLength,  
                             (Tcl_Namespace *) nsPtr, &vinfo);  
                 }  
                 resPtr = resPtr->nextPtr;  
             }  
             if (result == TCL_OK) {  
                 localPtr->resolveInfo = vinfo;  
                 localPtr->flags |= VAR_RESOLVED;  
             }  
         }  
   
         /*  
          * Now invoke the resolvers to determine the exact variables that  
          * should be used.  
          */  
   
         resVarInfo = localPtr->resolveInfo;  
         resolvedVarPtr = NULL;  
   
         if (resVarInfo && resVarInfo->fetchProc) {  
             resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,  
                     resVarInfo);  
         }  
   
         if (resolvedVarPtr) {  
             varPtr->name = localPtr->name; /* will be just '\0' if temp var */  
             varPtr->nsPtr = NULL;  
             varPtr->hPtr = NULL;  
             varPtr->refCount = 0;  
             varPtr->tracePtr = NULL;  
             varPtr->searchPtr = NULL;  
             varPtr->flags = 0;  
             TclSetVarLink(varPtr);  
             varPtr->value.linkPtr = resolvedVarPtr;  
             resolvedVarPtr->refCount++;  
         } else {  
             varPtr->value.objPtr = NULL;  
             varPtr->name = localPtr->name; /* will be just '\0' if temp var */  
             varPtr->nsPtr = NULL;  
             varPtr->hPtr = NULL;  
             varPtr->refCount = 0;  
             varPtr->tracePtr = NULL;  
             varPtr->searchPtr = NULL;  
             varPtr->flags = (localPtr->flags | VAR_UNDEFINED);  
         }  
         varPtr++;  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclExpandCodeArray --  
  *  
  *      Procedure that uses malloc to allocate more storage for a  
  *      CompileEnv's code array.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The byte code array in *envPtr is reallocated to a new array of  
  *      double the size, and if envPtr->mallocedCodeArray is non-zero the  
  *      old array is freed. Byte codes are copied from the old array to the  
  *      new one.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclExpandCodeArray(envPtr)  
     CompileEnv *envPtr;         /* Points to the CompileEnv whose code array  
                                  * must be enlarged. */  
 {  
     /*  
      * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined  
      * code bytes are stored between envPtr->codeStart and  
      * (envPtr->codeNext - 1) [inclusive].  
      */  
       
     size_t currBytes = (envPtr->codeNext - envPtr->codeStart);  
     size_t newBytes  = 2*(envPtr->codeEnd  - envPtr->codeStart);  
     unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);  
   
     /*  
      * Copy from old code array to new, free old code array if needed, and  
      * mark new code array as malloced.  
      */  
   
     memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);  
     if (envPtr->mallocedCodeArray) {  
         ckfree((char *) envPtr->codeStart);  
     }  
     envPtr->codeStart = newPtr;  
     envPtr->codeNext = (newPtr + currBytes);  
     envPtr->codeEnd  = (newPtr + newBytes);  
     envPtr->mallocedCodeArray = 1;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * EnterCmdStartData --  
  *  
  *      Registers the starting source and bytecode location of a  
  *      command. This information is used at runtime to map between  
  *      instruction pc and source locations.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Inserts source and code location information into the compilation  
  *      environment envPtr for the command at index cmdIndex. The  
  *      compilation environment's CmdLocation array is grown if necessary.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)  
     CompileEnv *envPtr;         /* Points to the compilation environment  
                                  * structure in which to enter command  
                                  * location information. */  
     int cmdIndex;               /* Index of the command whose start data  
                                  * is being set. */  
     int srcOffset;              /* Offset of first char of the command. */  
     int codeOffset;             /* Offset of first byte of command code. */  
 {  
     CmdLocation *cmdLocPtr;  
       
     if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {  
         panic("EnterCmdStartData: bad command index %d\n", cmdIndex);  
     }  
       
     if (cmdIndex >= envPtr->cmdMapEnd) {  
         /*  
          * Expand the command location array by allocating more storage from  
          * the heap. The currently allocated CmdLocation entries are stored  
          * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).  
          */  
   
         size_t currElems = envPtr->cmdMapEnd;  
         size_t newElems  = 2*currElems;  
         size_t currBytes = currElems * sizeof(CmdLocation);  
         size_t newBytes  = newElems  * sizeof(CmdLocation);  
         CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);  
           
         /*  
          * Copy from old command location array to new, free old command  
          * location array if needed, and mark new array as malloced.  
          */  
           
         memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);  
         if (envPtr->mallocedCmdMap) {  
             ckfree((char *) envPtr->cmdMapPtr);  
         }  
         envPtr->cmdMapPtr = (CmdLocation *) newPtr;  
         envPtr->cmdMapEnd = newElems;  
         envPtr->mallocedCmdMap = 1;  
     }  
   
     if (cmdIndex > 0) {  
         if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {  
             panic("EnterCmdStartData: cmd map not sorted by code offset");  
         }  
     }  
   
     cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);  
     cmdLocPtr->codeOffset = codeOffset;  
     cmdLocPtr->srcOffset = srcOffset;  
     cmdLocPtr->numSrcBytes = -1;  
     cmdLocPtr->numCodeBytes = -1;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * EnterCmdExtentData --  
  *  
  *      Registers the source and bytecode length for a command. This  
  *      information is used at runtime to map between instruction pc and  
  *      source locations.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Inserts source and code length information into the compilation  
  *      environment envPtr for the command at index cmdIndex. Starting  
  *      source and bytecode information for the command must already  
  *      have been registered.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static void  
 EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)  
     CompileEnv *envPtr;         /* Points to the compilation environment  
                                  * structure in which to enter command  
                                  * location information. */  
     int cmdIndex;               /* Index of the command whose source and  
                                  * code length data is being set. */  
     int numSrcBytes;            /* Number of command source chars. */  
     int numCodeBytes;           /* Offset of last byte of command code. */  
 {  
     CmdLocation *cmdLocPtr;  
   
     if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {  
         panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);  
     }  
       
     if (cmdIndex > envPtr->cmdMapEnd) {  
         panic("EnterCmdExtentData: missing start data for command %d\n",  
                 cmdIndex);  
     }  
   
     cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);  
     cmdLocPtr->numSrcBytes = numSrcBytes;  
     cmdLocPtr->numCodeBytes = numCodeBytes;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCreateExceptRange --  
  *  
  *      Procedure that allocates and initializes a new ExceptionRange  
  *      structure of the specified kind in a CompileEnv.  
  *  
  * Results:  
  *      Returns the index for the newly created ExceptionRange.  
  *  
  * Side effects:  
  *      If there is not enough room in the CompileEnv's ExceptionRange  
  *      array, the array in expanded: a new array of double the size is  
  *      allocated, if envPtr->mallocedExceptArray is non-zero the old  
  *      array is freed, and ExceptionRange entries are copied from the old  
  *      array to the new one.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCreateExceptRange(type, envPtr)  
     ExceptionRangeType type;    /* The kind of ExceptionRange desired. */  
     register CompileEnv *envPtr;/* Points to CompileEnv for which to  
                                  * create a new ExceptionRange structure. */  
 {  
     register ExceptionRange *rangePtr;  
     int index = envPtr->exceptArrayNext;  
       
     if (index >= envPtr->exceptArrayEnd) {  
         /*  
          * Expand the ExceptionRange array. The currently allocated entries  
          * are stored between elements 0 and (envPtr->exceptArrayNext - 1)  
          * [inclusive].  
          */  
           
         size_t currBytes =  
                 envPtr->exceptArrayNext * sizeof(ExceptionRange);  
         int newElems = 2*envPtr->exceptArrayEnd;  
         size_t newBytes = newElems * sizeof(ExceptionRange);  
         ExceptionRange *newPtr = (ExceptionRange *)  
                 ckalloc((unsigned) newBytes);  
           
         /*  
          * Copy from old ExceptionRange array to new, free old  
          * ExceptionRange array if needed, and mark the new ExceptionRange  
          * array as malloced.  
          */  
           
         memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr,  
                 currBytes);  
         if (envPtr->mallocedExceptArray) {  
             ckfree((char *) envPtr->exceptArrayPtr);  
         }  
         envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;  
         envPtr->exceptArrayEnd = newElems;  
         envPtr->mallocedExceptArray = 1;  
     }  
     envPtr->exceptArrayNext++;  
       
     rangePtr = &(envPtr->exceptArrayPtr[index]);  
     rangePtr->type = type;  
     rangePtr->nestingLevel = envPtr->exceptDepth;  
     rangePtr->codeOffset = -1;  
     rangePtr->numCodeBytes = -1;  
     rangePtr->breakOffset = -1;  
     rangePtr->continueOffset = -1;  
     rangePtr->catchOffset = -1;  
     return index;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclCreateAuxData --  
  *  
  *      Procedure that allocates and initializes a new AuxData structure in  
  *      a CompileEnv's array of compilation auxiliary data records. These  
  *      AuxData records hold information created during compilation by  
  *      CompileProcs and used by instructions during execution.  
  *  
  * Results:  
  *      Returns the index for the newly created AuxData structure.  
  *  
  * Side effects:  
  *      If there is not enough room in the CompileEnv's AuxData array,  
  *      the AuxData array in expanded: a new array of double the size  
  *      is allocated, if envPtr->mallocedAuxDataArray is non-zero  
  *      the old array is freed, and AuxData entries are copied from  
  *      the old array to the new one.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclCreateAuxData(clientData, typePtr, envPtr)  
     ClientData clientData;      /* The compilation auxiliary data to store  
                                  * in the new aux data record. */  
     AuxDataType *typePtr;       /* Pointer to the type to attach to this AuxData */  
     register CompileEnv *envPtr;/* Points to the CompileEnv for which a new  
                                  * aux data structure is to be allocated. */  
 {  
     int index;                  /* Index for the new AuxData structure. */  
     register AuxData *auxDataPtr;  
                                 /* Points to the new AuxData structure */  
       
     index = envPtr->auxDataArrayNext;  
     if (index >= envPtr->auxDataArrayEnd) {  
         /*  
          * Expand the AuxData array. The currently allocated entries are  
          * stored between elements 0 and (envPtr->auxDataArrayNext - 1)  
          * [inclusive].  
          */  
           
         size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);  
         int newElems = 2*envPtr->auxDataArrayEnd;  
         size_t newBytes = newElems * sizeof(AuxData);  
         AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);  
           
         /*  
          * Copy from old AuxData array to new, free old AuxData array if  
          * needed, and mark the new AuxData array as malloced.  
          */  
           
         memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,  
                 currBytes);  
         if (envPtr->mallocedAuxDataArray) {  
             ckfree((char *) envPtr->auxDataArrayPtr);  
         }  
         envPtr->auxDataArrayPtr = newPtr;  
         envPtr->auxDataArrayEnd = newElems;  
         envPtr->mallocedAuxDataArray = 1;  
     }  
     envPtr->auxDataArrayNext++;  
       
     auxDataPtr = &(envPtr->auxDataArrayPtr[index]);  
     auxDataPtr->clientData = clientData;  
     auxDataPtr->type = typePtr;  
     return index;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclInitJumpFixupArray --  
  *  
  *      Initializes a JumpFixupArray structure to hold some number of  
  *      jump fixup entries.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The JumpFixupArray structure is initialized.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclInitJumpFixupArray(fixupArrayPtr)  
     register JumpFixupArray *fixupArrayPtr;  
                                  /* Points to the JumpFixupArray structure  
                                   * to initialize. */  
 {  
     fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;  
     fixupArrayPtr->next = 0;  
     fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);  
     fixupArrayPtr->mallocedArray = 0;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclExpandJumpFixupArray --  
  *  
  *      Procedure that uses malloc to allocate more storage for a  
  *      jump fixup array.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The jump fixup array in *fixupArrayPtr is reallocated to a new array  
  *      of double the size, and if fixupArrayPtr->mallocedArray is non-zero  
  *      the old array is freed. Jump fixup structures are copied from the  
  *      old array to the new one.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclExpandJumpFixupArray(fixupArrayPtr)  
     register JumpFixupArray *fixupArrayPtr;  
                                  /* Points to the JumpFixupArray structure  
                                   * to enlarge. */  
 {  
     /*  
      * The currently allocated jump fixup entries are stored from fixup[0]  
      * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume  
      * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.  
      */  
   
     size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);  
     int newElems = 2*(fixupArrayPtr->end + 1);  
     size_t newBytes = newElems * sizeof(JumpFixup);  
     JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);  
   
     /*  
      * Copy from the old array to new, free the old array if needed,  
      * and mark the new array as malloced.  
      */  
   
     memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);  
     if (fixupArrayPtr->mallocedArray) {  
         ckfree((char *) fixupArrayPtr->fixup);  
     }  
     fixupArrayPtr->fixup = (JumpFixup *) newPtr;  
     fixupArrayPtr->end = newElems;  
     fixupArrayPtr->mallocedArray = 1;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclFreeJumpFixupArray --  
  *  
  *      Free any storage allocated in a jump fixup array structure.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Allocated storage in the JumpFixupArray structure is freed.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclFreeJumpFixupArray(fixupArrayPtr)  
     register JumpFixupArray *fixupArrayPtr;  
                                  /* Points to the JumpFixupArray structure  
                                   * to free. */  
 {  
     if (fixupArrayPtr->mallocedArray) {  
         ckfree((char *) fixupArrayPtr->fixup);  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclEmitForwardJump --  
  *  
  *      Procedure to emit a two-byte forward jump of kind "jumpType". Since  
  *      the jump may later have to be grown to five bytes if the jump target  
  *      is more than, say, 127 bytes away, this procedure also initializes a  
  *      JumpFixup record with information about the jump.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The JumpFixup record pointed to by "jumpFixupPtr" is initialized  
  *      with information needed later if the jump is to be grown. Also,  
  *      a two byte jump of the designated type is emitted at the current  
  *      point in the bytecode stream.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)  
     CompileEnv *envPtr;         /* Points to the CompileEnv structure that  
                                  * holds the resulting instruction. */  
     TclJumpType jumpType;       /* Indicates the kind of jump: if true or  
                                  * false or unconditional. */  
     JumpFixup *jumpFixupPtr;    /* Points to the JumpFixup structure to  
                                  * initialize with information about this  
                                  * forward jump. */  
 {  
     /*  
      * Initialize the JumpFixup structure:  
      *    - codeOffset is offset of first byte of jump below  
      *    - cmdIndex is index of the command after the current one  
      *    - exceptIndex is the index of the first ExceptionRange after  
      *      the current one.  
      */  
       
     jumpFixupPtr->jumpType = jumpType;  
     jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);  
     jumpFixupPtr->cmdIndex = envPtr->numCommands;  
     jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;  
       
     switch (jumpType) {  
     case TCL_UNCONDITIONAL_JUMP:  
         TclEmitInstInt1(INST_JUMP1, 0, envPtr);  
         break;  
     case TCL_TRUE_JUMP:  
         TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);  
         break;  
     default:  
         TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);  
         break;  
     }  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclFixupForwardJump --  
  *  
  *      Procedure that updates a previously-emitted forward jump to jump  
  *      a specified number of bytes, "jumpDist". If necessary, the jump is  
  *      grown from two to five bytes; this is done if the jump distance is  
  *      greater than "distThreshold" (normally 127 bytes). The jump is  
  *      described by a JumpFixup record previously initialized by  
  *      TclEmitForwardJump.  
  *  
  * Results:  
  *      1 if the jump was grown and subsequent instructions had to be moved;  
  *      otherwise 0. This result is returned to allow callers to update  
  *      any additional code offsets they may hold.  
  *  
  * Side effects:  
  *      The jump may be grown and subsequent instructions moved. If this  
  *      happens, the code offsets for any commands and any ExceptionRange  
  *      records between the jump and the current code address will be  
  *      updated to reflect the moved code. Also, the bytecode instruction  
  *      array in the CompileEnv structure may be grown and reallocated.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)  
     CompileEnv *envPtr;         /* Points to the CompileEnv structure that  
                                  * holds the resulting instruction. */  
     JumpFixup *jumpFixupPtr;    /* Points to the JumpFixup structure that  
                                  * describes the forward jump. */  
     int jumpDist;               /* Jump distance to set in jump  
                                  * instruction. */  
     int distThreshold;          /* Maximum distance before the two byte  
                                  * jump is grown to five bytes. */  
 {  
     unsigned char *jumpPc, *p;  
     int firstCmd, lastCmd, firstRange, lastRange, k;  
     unsigned int numBytes;  
       
     if (jumpDist <= distThreshold) {  
         jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);  
         switch (jumpFixupPtr->jumpType) {  
         case TCL_UNCONDITIONAL_JUMP:  
             TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);  
             break;  
         case TCL_TRUE_JUMP:  
             TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);  
             break;  
         default:  
             TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);  
             break;  
         }  
         return 0;  
     }  
   
     /*  
      * We must grow the jump then move subsequent instructions down.  
      * Note that if we expand the space for generated instructions,  
      * code addresses might change; be careful about updating any of  
      * these addresses held in variables.  
      */  
       
     if ((envPtr->codeNext + 3) > envPtr->codeEnd) {  
         TclExpandCodeArray(envPtr);  
     }  
     jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);  
     for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;  
             numBytes > 0;  numBytes--, p--) {  
         p[3] = p[0];  
     }  
     envPtr->codeNext += 3;  
     jumpDist += 3;  
     switch (jumpFixupPtr->jumpType) {  
     case TCL_UNCONDITIONAL_JUMP:  
         TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);  
         break;  
     case TCL_TRUE_JUMP:  
         TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);  
         break;  
     default:  
         TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);  
         break;  
     }  
       
     /*  
      * Adjust the code offsets for any commands and any ExceptionRange  
      * records between the jump and the current code address.  
      */  
       
     firstCmd = jumpFixupPtr->cmdIndex;  
     lastCmd  = (envPtr->numCommands - 1);  
     if (firstCmd < lastCmd) {  
         for (k = firstCmd;  k <= lastCmd;  k++) {  
             (envPtr->cmdMapPtr[k]).codeOffset += 3;  
         }  
     }  
       
     firstRange = jumpFixupPtr->exceptIndex;  
     lastRange  = (envPtr->exceptArrayNext - 1);  
     for (k = firstRange;  k <= lastRange;  k++) {  
         ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);  
         rangePtr->codeOffset += 3;  
           
         switch (rangePtr->type) {  
         case LOOP_EXCEPTION_RANGE:  
             rangePtr->breakOffset += 3;  
             if (rangePtr->continueOffset != -1) {  
                 rangePtr->continueOffset += 3;  
             }  
             break;  
         case CATCH_EXCEPTION_RANGE:  
             rangePtr->catchOffset += 3;  
             break;  
         default:  
             panic("TclFixupForwardJump: bad ExceptionRange type %d\n",  
                     rangePtr->type);  
         }  
     }  
     return 1;                   /* the jump was grown */  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclGetInstructionTable --  
  *  
  *  Returns a pointer to the table describing Tcl bytecode instructions.  
  *  This procedure is defined so that clients can access the pointer from  
  *  outside the TCL DLLs.  
  *  
  * Results:  
  *      Returns a pointer to the global instruction table, same as the  
  *      expression (&instructionTable[0]).  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 InstructionDesc *  
 TclGetInstructionTable()  
 {  
     return &instructionTable[0];  
 }  
   
 /*  
  *--------------------------------------------------------------  
  *  
  * TclRegisterAuxDataType --  
  *  
  *      This procedure is called to register a new AuxData type  
  *      in the table of all AuxData types supported by Tcl.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      The type is registered in the AuxData type table. If there was already  
  *      a type with the same name as in typePtr, it is replaced with the  
  *      new type.  
  *  
  *--------------------------------------------------------------  
  */  
   
 void  
 TclRegisterAuxDataType(typePtr)  
     AuxDataType *typePtr;       /* Information about object type;  
                              * storage must be statically  
                              * allocated (must live forever). */  
 {  
     register Tcl_HashEntry *hPtr;  
     int new;  
   
     Tcl_MutexLock(&tableMutex);  
     if (!auxDataTypeTableInitialized) {  
         TclInitAuxDataTypeTable();  
     }  
   
     /*  
      * If there's already a type with the given name, remove it.  
      */  
   
     hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);  
     if (hPtr != (Tcl_HashEntry *) NULL) {  
         Tcl_DeleteHashEntry(hPtr);  
     }  
   
     /*  
      * Now insert the new object type.  
      */  
   
     hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);  
     if (new) {  
         Tcl_SetHashValue(hPtr, typePtr);  
     }  
     Tcl_MutexUnlock(&tableMutex);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclGetAuxDataType --  
  *  
  *      This procedure looks up an Auxdata type by name.  
  *  
  * Results:  
  *      If an AuxData type with name matching "typeName" is found, a pointer  
  *      to its AuxDataType structure is returned; otherwise, NULL is returned.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 AuxDataType *  
 TclGetAuxDataType(typeName)  
     char *typeName;             /* Name of AuxData type to look up. */  
 {  
     register Tcl_HashEntry *hPtr;  
     AuxDataType *typePtr = NULL;  
   
     Tcl_MutexLock(&tableMutex);  
     if (!auxDataTypeTableInitialized) {  
         TclInitAuxDataTypeTable();  
     }  
   
     hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);  
     if (hPtr != (Tcl_HashEntry *) NULL) {  
         typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);  
     }  
     Tcl_MutexUnlock(&tableMutex);  
   
     return typePtr;  
 }  
   
 /*  
  *--------------------------------------------------------------  
  *  
  * TclInitAuxDataTypeTable --  
  *  
  *      This procedure is invoked to perform once-only initialization of  
  *      the AuxData type table. It also registers the AuxData types defined in  
  *      this file.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Initializes the table of defined AuxData types "auxDataTypeTable" with  
  *      builtin AuxData types defined in this file.  
  *  
  *--------------------------------------------------------------  
  */  
   
 void  
 TclInitAuxDataTypeTable()  
 {  
     /*  
      * The table mutex must already be held before this routine is invoked.  
      */  
   
     auxDataTypeTableInitialized = 1;  
     Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);  
   
     /*  
      * There is only one AuxData type at this time, so register it here.  
      */  
   
     TclRegisterAuxDataType(&tclForeachInfoType);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclFinalizeAuxDataTypeTable --  
  *  
  *      This procedure is called by Tcl_Finalize after all exit handlers  
  *      have been run to free up storage associated with the table of AuxData  
  *      types.  This procedure is called by TclFinalizeExecution() which  
  *      is called by Tcl_Finalize().  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Deletes all entries in the hash table of AuxData types.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclFinalizeAuxDataTypeTable()  
 {  
     Tcl_MutexLock(&tableMutex);  
     if (auxDataTypeTableInitialized) {  
         Tcl_DeleteHashTable(&auxDataTypeTable);  
         auxDataTypeTableInitialized = 0;  
     }  
     Tcl_MutexUnlock(&tableMutex);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * GetCmdLocEncodingSize --  
  *  
  *      Computes the total number of bytes needed to encode the command  
  *      location information for some compiled code.  
  *  
  * Results:  
  *      The byte count needed to encode the compiled location information.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static int  
 GetCmdLocEncodingSize(envPtr)  
      CompileEnv *envPtr;        /* Points to compilation environment  
                                  * structure containing the CmdLocation  
                                  * structure to encode. */  
 {  
     register CmdLocation *mapPtr = envPtr->cmdMapPtr;  
     int numCmds = envPtr->numCommands;  
     int codeDelta, codeLen, srcDelta, srcLen;  
     int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;  
                                 /* The offsets in their respective byte  
                                  * sequences where the next encoded offset  
                                  * or length should go. */  
     int prevCodeOffset, prevSrcOffset, i;  
   
     codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;  
     prevCodeOffset = prevSrcOffset = 0;  
     for (i = 0;  i < numCmds;  i++) {  
         codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);  
         if (codeDelta < 0) {  
             panic("GetCmdLocEncodingSize: bad code offset");  
         } else if (codeDelta <= 127) {  
             codeDeltaNext++;  
         } else {  
             codeDeltaNext += 5;  /* 1 byte for 0xFF, 4 for positive delta */  
         }  
         prevCodeOffset = mapPtr[i].codeOffset;  
   
         codeLen = mapPtr[i].numCodeBytes;  
         if (codeLen < 0) {  
             panic("GetCmdLocEncodingSize: bad code length");  
         } else if (codeLen <= 127) {  
             codeLengthNext++;  
         } else {  
             codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */  
         }  
   
         srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);  
         if ((-127 <= srcDelta) && (srcDelta <= 127)) {  
             srcDeltaNext++;  
         } else {  
             srcDeltaNext += 5;   /* 1 byte for 0xFF, 4 for delta */  
         }  
         prevSrcOffset = mapPtr[i].srcOffset;  
   
         srcLen = mapPtr[i].numSrcBytes;  
         if (srcLen < 0) {  
             panic("GetCmdLocEncodingSize: bad source length");  
         } else if (srcLen <= 127) {  
             srcLengthNext++;  
         } else {  
             srcLengthNext += 5;  /* 1 byte for 0xFF, 4 for length */  
         }  
     }  
   
     return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * EncodeCmdLocMap --  
  *  
  *      Encode the command location information for some compiled code into  
  *      a ByteCode structure. The encoded command location map is stored as  
  *      three adjacent byte sequences.  
  *  
  * Results:  
  *      Pointer to the first byte after the encoded command location  
  *      information.  
  *  
  * Side effects:  
  *      The encoded information is stored into the block of memory headed  
  *      by codePtr. Also records pointers to the start of the four byte  
  *      sequences in fields in codePtr's ByteCode header structure.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 static unsigned char *  
 EncodeCmdLocMap(envPtr, codePtr, startPtr)  
      CompileEnv *envPtr;        /* Points to compilation environment  
                                  * structure containing the CmdLocation  
                                  * structure to encode. */  
      ByteCode *codePtr;         /* ByteCode in which to encode envPtr's  
                                  * command location information. */  
      unsigned char *startPtr;   /* Points to the first byte in codePtr's  
                                  * memory block where the location  
                                  * information is to be stored. */  
 {  
     register CmdLocation *mapPtr = envPtr->cmdMapPtr;  
     int numCmds = envPtr->numCommands;  
     register unsigned char *p = startPtr;  
     int codeDelta, codeLen, srcDelta, srcLen, prevOffset;  
     register int i;  
       
     /*  
      * Encode the code offset for each command as a sequence of deltas.  
      */  
   
     codePtr->codeDeltaStart = p;  
     prevOffset = 0;  
     for (i = 0;  i < numCmds;  i++) {  
         codeDelta = (mapPtr[i].codeOffset - prevOffset);  
         if (codeDelta < 0) {  
             panic("EncodeCmdLocMap: bad code offset");  
         } else if (codeDelta <= 127) {  
             TclStoreInt1AtPtr(codeDelta, p);  
             p++;  
         } else {  
             TclStoreInt1AtPtr(0xFF, p);  
             p++;  
             TclStoreInt4AtPtr(codeDelta, p);  
             p += 4;  
         }  
         prevOffset = mapPtr[i].codeOffset;  
     }  
   
     /*  
      * Encode the code length for each command.  
      */  
   
     codePtr->codeLengthStart = p;  
     for (i = 0;  i < numCmds;  i++) {  
         codeLen = mapPtr[i].numCodeBytes;  
         if (codeLen < 0) {  
             panic("EncodeCmdLocMap: bad code length");  
         } else if (codeLen <= 127) {  
             TclStoreInt1AtPtr(codeLen, p);  
             p++;  
         } else {  
             TclStoreInt1AtPtr(0xFF, p);  
             p++;  
             TclStoreInt4AtPtr(codeLen, p);  
             p += 4;  
         }  
     }  
   
     /*  
      * Encode the source offset for each command as a sequence of deltas.  
      */  
   
     codePtr->srcDeltaStart = p;  
     prevOffset = 0;  
     for (i = 0;  i < numCmds;  i++) {  
         srcDelta = (mapPtr[i].srcOffset - prevOffset);  
         if ((-127 <= srcDelta) && (srcDelta <= 127)) {  
             TclStoreInt1AtPtr(srcDelta, p);  
             p++;  
         } else {  
             TclStoreInt1AtPtr(0xFF, p);  
             p++;  
             TclStoreInt4AtPtr(srcDelta, p);  
             p += 4;  
         }  
         prevOffset = mapPtr[i].srcOffset;  
     }  
   
     /*  
      * Encode the source length for each command.  
      */  
   
     codePtr->srcLengthStart = p;  
     for (i = 0;  i < numCmds;  i++) {  
         srcLen = mapPtr[i].numSrcBytes;  
         if (srcLen < 0) {  
             panic("EncodeCmdLocMap: bad source length");  
         } else if (srcLen <= 127) {  
             TclStoreInt1AtPtr(srcLen, p);  
             p++;  
         } else {  
             TclStoreInt1AtPtr(0xFF, p);  
             p++;  
             TclStoreInt4AtPtr(srcLen, p);  
             p += 4;  
         }  
     }  
       
     return p;  
 }  
   
 #ifdef TCL_COMPILE_DEBUG  
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclPrintByteCodeObj --  
  *  
  *      This procedure prints ("disassembles") the instructions of a  
  *      bytecode object to stdout.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclPrintByteCodeObj(interp, objPtr)  
     Tcl_Interp *interp;         /* Used only for Tcl_GetStringFromObj. */  
     Tcl_Obj *objPtr;            /* The bytecode object to disassemble. */  
 {  
     ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;  
     unsigned char *codeStart, *codeLimit, *pc;  
     unsigned char *codeDeltaNext, *codeLengthNext;  
     unsigned char *srcDeltaNext, *srcLengthNext;  
     int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;  
     Interp *iPtr = (Interp *) *codePtr->interpHandle;  
   
     if (codePtr->refCount <= 0) {  
         return;                 /* already freed */  
     }  
   
     codeStart = codePtr->codeStart;  
     codeLimit = (codeStart + codePtr->numCodeBytes);  
     numCmds = codePtr->numCommands;  
   
     /*  
      * Print header lines describing the ByteCode.  
      */  
   
     fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",  
             (unsigned int) codePtr, codePtr->refCount,  
             codePtr->compileEpoch, (unsigned int) iPtr,  
             iPtr->compileEpoch);  
     fprintf(stdout, "  Source ");  
     TclPrintSource(stdout, codePtr->source,  
             TclMin(codePtr->numSrcBytes, 55));  
     fprintf(stdout, "\n  Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",  
             numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,  
             codePtr->numLitObjects, codePtr->numAuxDataItems,  
             codePtr->maxStackDepth,  
 #ifdef TCL_COMPILE_STATS  
             (codePtr->numSrcBytes?  
                     ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));  
 #else  
             0.0);  
 #endif  
 #ifdef TCL_COMPILE_STATS  
     fprintf(stdout,  
             "  Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",  
             codePtr->structureSize,  
             (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),  
             codePtr->numCodeBytes,  
             (codePtr->numLitObjects * sizeof(Tcl_Obj *)),  
             (codePtr->numExceptRanges * sizeof(ExceptionRange)),  
             (codePtr->numAuxDataItems * sizeof(AuxData)),  
             codePtr->numCmdLocBytes);  
 #endif /* TCL_COMPILE_STATS */  
       
     /*  
      * If the ByteCode is the compiled body of a Tcl procedure, print  
      * information about that procedure. Note that we don't know the  
      * procedure's name since ByteCode's can be shared among procedures.  
      */  
       
     if (codePtr->procPtr != NULL) {  
         Proc *procPtr = codePtr->procPtr;  
         int numCompiledLocals = procPtr->numCompiledLocals;  
         fprintf(stdout,  
                 "  Proc 0x%x, refCt %d, args %d, compiled locals %d\n",  
                 (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,  
                 numCompiledLocals);  
         if (numCompiledLocals > 0) {  
             CompiledLocal *localPtr = procPtr->firstLocalPtr;  
             for (i = 0;  i < numCompiledLocals;  i++) {  
                 fprintf(stdout, "      slot %d%s%s%s%s%s%s", i,  
                         ((localPtr->flags & VAR_SCALAR)?  ", scalar"  : ""),  
                         ((localPtr->flags & VAR_ARRAY)?  ", array"  : ""),  
                         ((localPtr->flags & VAR_LINK)?  ", link"  : ""),  
                         ((localPtr->flags & VAR_ARGUMENT)?  ", arg"  : ""),  
                         ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),  
                         ((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));  
                 if (TclIsVarTemporary(localPtr)) {  
                     fprintf(stdout,     "\n");  
                 } else {  
                     fprintf(stdout,     ", \"%s\"\n", localPtr->name);  
                 }  
                 localPtr = localPtr->nextPtr;  
             }  
         }  
     }  
   
     /*  
      * Print the ExceptionRange array.  
      */  
   
     if (codePtr->numExceptRanges > 0) {  
         fprintf(stdout, "  Exception ranges %d, depth %d:\n",  
                 codePtr->numExceptRanges, codePtr->maxExceptDepth);  
         for (i = 0;  i < codePtr->numExceptRanges;  i++) {  
             ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);  
             fprintf(stdout, "      %d: level %d, %s, pc %d-%d, ",  
                     i, rangePtr->nestingLevel,  
                     ((rangePtr->type == LOOP_EXCEPTION_RANGE)  
                             ? "loop" : "catch"),  
                     rangePtr->codeOffset,  
                     (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));  
             switch (rangePtr->type) {  
             case LOOP_EXCEPTION_RANGE:  
                 fprintf(stdout, "continue %d, break %d\n",  
                         rangePtr->continueOffset, rangePtr->breakOffset);  
                 break;  
             case CATCH_EXCEPTION_RANGE:  
                 fprintf(stdout, "catch %d\n", rangePtr->catchOffset);  
                 break;  
             default:  
                 panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",  
                         rangePtr->type);  
             }  
         }  
     }  
       
     /*  
      * If there were no commands (e.g., an expression or an empty string  
      * was compiled), just print all instructions and return.  
      */  
   
     if (numCmds == 0) {  
         pc = codeStart;  
         while (pc < codeLimit) {  
             fprintf(stdout, "    ");  
             pc += TclPrintInstruction(codePtr, pc);  
         }  
         return;  
     }  
       
     /*  
      * Print table showing the code offset, source offset, and source  
      * length for each command. These are encoded as a sequence of bytes.  
      */  
   
     fprintf(stdout, "  Commands %d:", numCmds);  
     codeDeltaNext = codePtr->codeDeltaStart;  
     codeLengthNext = codePtr->codeLengthStart;  
     srcDeltaNext  = codePtr->srcDeltaStart;  
     srcLengthNext = codePtr->srcLengthStart;  
     codeOffset = srcOffset = 0;  
     for (i = 0;  i < numCmds;  i++) {  
         if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {  
             codeDeltaNext++;  
             delta = TclGetInt4AtPtr(codeDeltaNext);  
             codeDeltaNext += 4;  
         } else {  
             delta = TclGetInt1AtPtr(codeDeltaNext);  
             codeDeltaNext++;  
         }  
         codeOffset += delta;  
   
         if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {  
             codeLengthNext++;  
             codeLen = TclGetInt4AtPtr(codeLengthNext);  
             codeLengthNext += 4;  
         } else {  
             codeLen = TclGetInt1AtPtr(codeLengthNext);  
             codeLengthNext++;  
         }  
           
         if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {  
             srcDeltaNext++;  
             delta = TclGetInt4AtPtr(srcDeltaNext);  
             srcDeltaNext += 4;  
         } else {  
             delta = TclGetInt1AtPtr(srcDeltaNext);  
             srcDeltaNext++;  
         }  
         srcOffset += delta;  
   
         if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {  
             srcLengthNext++;  
             srcLen = TclGetInt4AtPtr(srcLengthNext);  
             srcLengthNext += 4;  
         } else {  
             srcLen = TclGetInt1AtPtr(srcLengthNext);  
             srcLengthNext++;  
         }  
           
         fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",  
                 ((i % 2)? "     " : "\n   "),  
                 (i+1), codeOffset, (codeOffset + codeLen - 1),  
                 srcOffset, (srcOffset + srcLen - 1));  
     }  
     if (numCmds > 0) {  
         fprintf(stdout, "\n");  
     }  
       
     /*  
      * Print each instruction. If the instruction corresponds to the start  
      * of a command, print the command's source. Note that we don't need  
      * the code length here.  
      */  
   
     codeDeltaNext = codePtr->codeDeltaStart;  
     srcDeltaNext  = codePtr->srcDeltaStart;  
     srcLengthNext = codePtr->srcLengthStart;  
     codeOffset = srcOffset = 0;  
     pc = codeStart;  
     for (i = 0;  i < numCmds;  i++) {  
         if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {  
             codeDeltaNext++;  
             delta = TclGetInt4AtPtr(codeDeltaNext);  
             codeDeltaNext += 4;  
         } else {  
             delta = TclGetInt1AtPtr(codeDeltaNext);  
             codeDeltaNext++;  
         }  
         codeOffset += delta;  
   
         if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {  
             srcDeltaNext++;  
             delta = TclGetInt4AtPtr(srcDeltaNext);  
             srcDeltaNext += 4;  
         } else {  
             delta = TclGetInt1AtPtr(srcDeltaNext);  
             srcDeltaNext++;  
         }  
         srcOffset += delta;  
   
         if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {  
             srcLengthNext++;  
             srcLen = TclGetInt4AtPtr(srcLengthNext);  
             srcLengthNext += 4;  
         } else {  
             srcLen = TclGetInt1AtPtr(srcLengthNext);  
             srcLengthNext++;  
         }  
   
         /*  
          * Print instructions before command i.  
          */  
           
         while ((pc-codeStart) < codeOffset) {  
             fprintf(stdout, "    ");  
             pc += TclPrintInstruction(codePtr, pc);  
         }  
   
         fprintf(stdout, "  Command %d: ", (i+1));  
         TclPrintSource(stdout, (codePtr->source + srcOffset),  
                 TclMin(srcLen, 55));  
         fprintf(stdout, "\n");  
     }  
     if (pc < codeLimit) {  
         /*  
          * Print instructions after the last command.  
          */  
   
         while (pc < codeLimit) {  
             fprintf(stdout, "    ");  
             pc += TclPrintInstruction(codePtr, pc);  
         }  
     }  
 }  
 #endif /* TCL_COMPILE_DEBUG */  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclPrintInstruction --  
  *  
  *      This procedure prints ("disassembles") one instruction from a  
  *      bytecode object to stdout.  
  *  
  * Results:  
  *      Returns the length in bytes of the current instruiction.  
  *  
  * Side effects:  
  *      None.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 int  
 TclPrintInstruction(codePtr, pc)  
     ByteCode* codePtr;          /* Bytecode containing the instruction. */  
     unsigned char *pc;          /* Points to first byte of instruction. */  
 {  
     Proc *procPtr = codePtr->procPtr;  
     unsigned char opCode = *pc;  
     register InstructionDesc *instDesc = &instructionTable[opCode];  
     unsigned char *codeStart = codePtr->codeStart;  
     unsigned int pcOffset = (pc - codeStart);  
     int opnd, i, j;  
       
     fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);  
     for (i = 0;  i < instDesc->numOperands;  i++) {  
         switch (instDesc->opTypes[i]) {  
         case OPERAND_INT1:  
             opnd = TclGetInt1AtPtr(pc+1+i);  
             if ((i == 0) && ((opCode == INST_JUMP1)  
                              || (opCode == INST_JUMP_TRUE1)  
                              || (opCode == INST_JUMP_FALSE1))) {  
                 fprintf(stdout, "%d     # pc %u", opnd, (pcOffset + opnd));  
             } else {  
                 fprintf(stdout, "%d", opnd);  
             }  
             break;  
         case OPERAND_INT4:  
             opnd = TclGetInt4AtPtr(pc+1+i);  
             if ((i == 0) && ((opCode == INST_JUMP4)  
                              || (opCode == INST_JUMP_TRUE4)  
                              || (opCode == INST_JUMP_FALSE4))) {  
                 fprintf(stdout, "%d     # pc %u", opnd, (pcOffset + opnd));  
             } else {  
                 fprintf(stdout, "%d", opnd);  
             }  
             break;  
         case OPERAND_UINT1:  
             opnd = TclGetUInt1AtPtr(pc+1+i);  
             if ((i == 0) && (opCode == INST_PUSH1)) {  
                 fprintf(stdout, "%u     # ", (unsigned int) opnd);  
                 TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);  
             } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)  
                                     || (opCode == INST_LOAD_ARRAY1)  
                                     || (opCode == INST_STORE_SCALAR1)  
                                     || (opCode == INST_STORE_ARRAY1))) {  
                 int localCt = procPtr->numCompiledLocals;  
                 CompiledLocal *localPtr = procPtr->firstLocalPtr;  
                 if (opnd >= localCt) {  
                     panic("TclPrintInstruction: bad local var index %u (%u locals)\n",  
                              (unsigned int) opnd, localCt);  
                     return instDesc->numBytes;  
                 }  
                 for (j = 0;  j < opnd;  j++) {  
                     localPtr = localPtr->nextPtr;  
                 }  
                 if (TclIsVarTemporary(localPtr)) {  
                     fprintf(stdout, "%u # temp var %u",  
                             (unsigned int) opnd, (unsigned int) opnd);  
                 } else {  
                     fprintf(stdout, "%u # var ", (unsigned int) opnd);  
                     TclPrintSource(stdout, localPtr->name, 40);  
                 }  
             } else {  
                 fprintf(stdout, "%u ", (unsigned int) opnd);  
             }  
             break;  
         case OPERAND_UINT4:  
             opnd = TclGetUInt4AtPtr(pc+1+i);  
             if (opCode == INST_PUSH4) {  
                 fprintf(stdout, "%u     # ", opnd);  
                 TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);  
             } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)  
                                     || (opCode == INST_LOAD_ARRAY4)  
                                     || (opCode == INST_STORE_SCALAR4)  
                                     || (opCode == INST_STORE_ARRAY4))) {  
                 int localCt = procPtr->numCompiledLocals;  
                 CompiledLocal *localPtr = procPtr->firstLocalPtr;  
                 if (opnd >= localCt) {  
                     panic("TclPrintInstruction: bad local var index %u (%u locals)\n",  
                              (unsigned int) opnd, localCt);  
                     return instDesc->numBytes;  
                 }  
                 for (j = 0;  j < opnd;  j++) {  
                     localPtr = localPtr->nextPtr;  
                 }  
                 if (TclIsVarTemporary(localPtr)) {  
                     fprintf(stdout, "%u # temp var %u",  
                             (unsigned int) opnd, (unsigned int) opnd);  
                 } else {  
                     fprintf(stdout, "%u # var ", (unsigned int) opnd);  
                     TclPrintSource(stdout, localPtr->name, 40);  
                 }  
             } else {  
                 fprintf(stdout, "%u ", (unsigned int) opnd);  
             }  
             break;  
         case OPERAND_NONE:  
         default:  
             break;  
         }  
     }  
     fprintf(stdout, "\n");  
     return instDesc->numBytes;  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclPrintObject --  
  *  
  *      This procedure prints up to a specified number of characters from  
  *      the argument Tcl object's string representation to a specified file.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Outputs characters to the specified file.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclPrintObject(outFile, objPtr, maxChars)  
     FILE *outFile;              /* The file to print the source to. */  
     Tcl_Obj *objPtr;            /* Points to the Tcl object whose string  
                                  * representation should be printed. */  
     int maxChars;               /* Maximum number of chars to print. */  
 {  
     char *bytes;  
     int length;  
       
     bytes = Tcl_GetStringFromObj(objPtr, &length);  
     TclPrintSource(outFile, bytes, TclMin(length, maxChars));  
 }  
   
 /*  
  *----------------------------------------------------------------------  
  *  
  * TclPrintSource --  
  *  
  *      This procedure prints up to a specified number of characters from  
  *      the argument string to a specified file. It tries to produce legible  
  *      output by adding backslashes as necessary.  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Outputs characters to the specified file.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 TclPrintSource(outFile, string, maxChars)  
     FILE *outFile;              /* The file to print the source to. */  
     char *string;               /* The string to print. */  
     int maxChars;               /* Maximum number of chars to print. */  
 {  
     register char *p;  
     register int i = 0;  
   
     if (string == NULL) {  
         fprintf(outFile, "\"\"");  
         return;  
     }  
   
     fprintf(outFile, "\"");  
     p = string;  
     for (;  (*p != '\0') && (i < maxChars);  p++, i++) {  
         switch (*p) {  
             case '"':  
                 fprintf(outFile, "\\\"");  
                 continue;  
             case '\f':  
                 fprintf(outFile, "\\f");  
                 continue;  
             case '\n':  
                 fprintf(outFile, "\\n");  
                 continue;  
             case '\r':  
                 fprintf(outFile, "\\r");  
                 continue;  
             case '\t':  
                 fprintf(outFile, "\\t");  
                 continue;  
             case '\v':  
                 fprintf(outFile, "\\v");  
                 continue;  
             default:  
                 fprintf(outFile, "%c", *p);  
                 continue;  
         }  
     }  
     fprintf(outFile, "\"");  
 }  
   
 #ifdef TCL_COMPILE_STATS  
 /*  
  *----------------------------------------------------------------------  
  *  
  * RecordByteCodeStats --  
  *  
  *      Accumulates various compilation-related statistics for each newly  
  *      compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is  
  *      compiled with the -DTCL_COMPILE_STATS flag  
  *  
  * Results:  
  *      None.  
  *  
  * Side effects:  
  *      Accumulates aggregate code-related statistics in the interpreter's  
  *      ByteCodeStats structure. Records statistics specific to a ByteCode  
  *      in its ByteCode structure.  
  *  
  *----------------------------------------------------------------------  
  */  
   
 void  
 RecordByteCodeStats(codePtr)  
     ByteCode *codePtr;          /* Points to ByteCode structure with info  
                                  * to add to accumulated statistics. */  
 {  
     Interp *iPtr = (Interp *) *codePtr->interpHandle;  
     register ByteCodeStats *statsPtr = &(iPtr->stats);  
   
     statsPtr->numCompilations++;  
     statsPtr->totalSrcBytes        += (double) codePtr->numSrcBytes;  
     statsPtr->totalByteCodeBytes   += (double) codePtr->structureSize;  
     statsPtr->currentSrcBytes      += (double) codePtr->numSrcBytes;  
     statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;  
       
     statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;  
     statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++;  
   
     statsPtr->currentInstBytes   += (double) codePtr->numCodeBytes;  
     statsPtr->currentLitBytes    +=  
             (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));  
     statsPtr->currentExceptBytes +=  
             (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));  
     statsPtr->currentAuxBytes    +=  
             (double) (codePtr->numAuxDataItems * sizeof(AuxData));  
     statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;  
 }  
 #endif /* TCL_COMPILE_STATS */  
   
   
 /* $History: tclcompile.c $  
  *  
  * *****************  Version 1  *****************  
  * User: Dtashley     Date: 1/02/01    Time: 1:27a  
  * Created in $/IjuScripter, IjuConsole/Source/Tcl Base  
  * Initial check-in.  
  */  
   
 /* End of TCLCOMPILE.C */  
1    /* $Header$ */
2    /*
3     * tclCompile.c --
4     *
5     *      This file contains procedures that compile Tcl commands or parts
6     *      of commands (like quoted strings or nested sub-commands) into a
7     *      sequence of instructions ("bytecodes").
8     *
9     * Copyright (c) 1996-1998 Sun Microsystems, Inc.
10     *
11     * See the file "license.terms" for information on usage and redistribution
12     * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13     *
14     * RCS: @(#) $Id: tclcompile.c,v 1.1.1.1 2001/06/13 04:36:17 dtashley Exp $
15     */
16    
17    #include "tclInt.h"
18    #include "tclCompile.h"
19    
20    /*
21     * Table of all AuxData types.
22     */
23    
24    static Tcl_HashTable auxDataTypeTable;
25    static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
26    
27    TCL_DECLARE_MUTEX(tableMutex)
28    
29    /*
30     * Variable that controls whether compilation tracing is enabled and, if so,
31     * what level of tracing is desired:
32     *    0: no compilation tracing
33     *    1: summarize compilation of top level cmds and proc bodies
34     *    2: display all instructions of each ByteCode compiled
35     * This variable is linked to the Tcl variable "tcl_traceCompile".
36     */
37    
38    int tclTraceCompile = 0;
39    static int traceInitialized = 0;
40    
41    /*
42     * A table describing the Tcl bytecode instructions. Entries in this table
43     * must correspond to the instruction opcode definitions in tclCompile.h.
44     * The names "op1" and "op4" refer to an instruction's one or four byte
45     * first operand. Similarly, "stktop" and "stknext" refer to the topmost
46     * and next to topmost stack elements.
47     *
48     * Note that the load, store, and incr instructions do not distinguish local
49     * from global variables; the bytecode interpreter at runtime uses the
50     * existence of a procedure call frame to distinguish these.
51     */
52    
53    InstructionDesc instructionTable[] = {
54       /* Name            Bytes #Opnds Operand types        Stack top, next   */
55        {"done",              1,   0,   {OPERAND_NONE}},
56            /* Finish ByteCode execution and return stktop (top stack item) */
57        {"push1",             2,   1,   {OPERAND_UINT1}},
58            /* Push object at ByteCode objArray[op1] */
59        {"push4",             5,   1,   {OPERAND_UINT4}},
60            /* Push object at ByteCode objArray[op4] */
61        {"pop",               1,   0,   {OPERAND_NONE}},
62            /* Pop the topmost stack object */
63        {"dup",               1,   0,   {OPERAND_NONE}},
64            /* Duplicate the topmost stack object and push the result */
65        {"concat1",           2,   1,   {OPERAND_UINT1}},
66            /* Concatenate the top op1 items and push result */
67        {"invokeStk1",        2,   1,   {OPERAND_UINT1}},
68            /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
69        {"invokeStk4",        5,   1,   {OPERAND_UINT4}},
70            /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
71        {"evalStk",           1,   0,   {OPERAND_NONE}},
72            /* Evaluate command in stktop using Tcl_EvalObj. */
73        {"exprStk",           1,   0,   {OPERAND_NONE}},
74            /* Execute expression in stktop using Tcl_ExprStringObj. */
75        
76        {"loadScalar1",       2,   1,   {OPERAND_UINT1}},
77            /* Load scalar variable at index op1 <= 255 in call frame */
78        {"loadScalar4",       5,   1,   {OPERAND_UINT4}},
79            /* Load scalar variable at index op1 >= 256 in call frame */
80        {"loadScalarStk",     1,   0,   {OPERAND_NONE}},
81            /* Load scalar variable; scalar's name is stktop */
82        {"loadArray1",        2,   1,   {OPERAND_UINT1}},
83            /* Load array element; array at slot op1<=255, element is stktop */
84        {"loadArray4",        5,   1,   {OPERAND_UINT4}},
85            /* Load array element; array at slot op1 > 255, element is stktop */
86        {"loadArrayStk",      1,   0,   {OPERAND_NONE}},
87            /* Load array element; element is stktop, array name is stknext */
88        {"loadStk",           1,   0,   {OPERAND_NONE}},
89            /* Load general variable; unparsed variable name is stktop */
90        {"storeScalar1",      2,   1,   {OPERAND_UINT1}},
91            /* Store scalar variable at op1<=255 in frame; value is stktop */
92        {"storeScalar4",      5,   1,   {OPERAND_UINT4}},
93            /* Store scalar variable at op1 > 255 in frame; value is stktop */
94        {"storeScalarStk",    1,   0,   {OPERAND_NONE}},
95            /* Store scalar; value is stktop, scalar name is stknext */
96        {"storeArray1",       2,   1,   {OPERAND_UINT1}},
97            /* Store array element; array at op1<=255, value is top then elem */
98        {"storeArray4",       5,   1,   {OPERAND_UINT4}},
99            /* Store array element; array at op1>=256, value is top then elem */
100        {"storeArrayStk",     1,   0,   {OPERAND_NONE}},
101            /* Store array element; value is stktop, then elem, array names */
102        {"storeStk",          1,   0,   {OPERAND_NONE}},
103            /* Store general variable; value is stktop, then unparsed name */
104        
105        {"incrScalar1",       2,   1,   {OPERAND_UINT1}},
106            /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
107        {"incrScalarStk",     1,   0,   {OPERAND_NONE}},
108            /* Incr scalar; incr amount is stktop, scalar's name is stknext */
109        {"incrArray1",        2,   1,   {OPERAND_UINT1}},
110            /* Incr array elem; arr at slot op1<=255, amount is top then elem */
111        {"incrArrayStk",      1,   0,   {OPERAND_NONE}},
112            /* Incr array element; amount is top then elem then array names */
113        {"incrStk",           1,   0,   {OPERAND_NONE}},
114            /* Incr general variable; amount is stktop then unparsed var name */
115        {"incrScalar1Imm",    3,   2,   {OPERAND_UINT1, OPERAND_INT1}},
116            /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
117        {"incrScalarStkImm",  2,   1,   {OPERAND_INT1}},
118            /* Incr scalar; scalar name is stktop; incr amount is op1 */
119        {"incrArray1Imm",     3,   2,   {OPERAND_UINT1, OPERAND_INT1}},
120            /* Incr array elem; array at slot op1 <= 255, elem is stktop,
121             * amount is 2nd operand byte */
122        {"incrArrayStkImm",   2,   1,   {OPERAND_INT1}},
123            /* Incr array element; elem is top then array name, amount is op1 */
124        {"incrStkImm",        2,   1,   {OPERAND_INT1}},
125            /* Incr general variable; unparsed name is top, amount is op1 */
126        
127        {"jump1",             2,   1,   {OPERAND_INT1}},
128            /* Jump relative to (pc + op1) */
129        {"jump4",             5,   1,   {OPERAND_INT4}},
130            /* Jump relative to (pc + op4) */
131        {"jumpTrue1",         2,   1,   {OPERAND_INT1}},
132            /* Jump relative to (pc + op1) if stktop expr object is true */
133        {"jumpTrue4",         5,   1,   {OPERAND_INT4}},
134            /* Jump relative to (pc + op4) if stktop expr object is true */
135        {"jumpFalse1",        2,   1,   {OPERAND_INT1}},
136            /* Jump relative to (pc + op1) if stktop expr object is false */
137        {"jumpFalse4",        5,   1,   {OPERAND_INT4}},
138            /* Jump relative to (pc + op4) if stktop expr object is false */
139    
140        {"lor",               1,   0,   {OPERAND_NONE}},
141            /* Logical or:  push (stknext || stktop) */
142        {"land",              1,   0,   {OPERAND_NONE}},
143            /* Logical and: push (stknext && stktop) */
144        {"bitor",             1,   0,   {OPERAND_NONE}},
145            /* Bitwise or:  push (stknext | stktop) */
146        {"bitxor",            1,   0,   {OPERAND_NONE}},
147            /* Bitwise xor  push (stknext ^ stktop) */
148        {"bitand",            1,   0,   {OPERAND_NONE}},
149            /* Bitwise and: push (stknext & stktop) */
150        {"eq",                1,   0,   {OPERAND_NONE}},
151            /* Equal:       push (stknext == stktop) */
152        {"neq",               1,   0,   {OPERAND_NONE}},
153            /* Not equal:   push (stknext != stktop) */
154        {"lt",                1,   0,   {OPERAND_NONE}},
155            /* Less:        push (stknext < stktop) */
156        {"gt",                1,   0,   {OPERAND_NONE}},
157            /* Greater:     push (stknext || stktop) */
158        {"le",                1,   0,   {OPERAND_NONE}},
159            /* Logical or:  push (stknext || stktop) */
160        {"ge",                1,   0,   {OPERAND_NONE}},
161            /* Logical or:  push (stknext || stktop) */
162        {"lshift",            1,   0,   {OPERAND_NONE}},
163            /* Left shift:  push (stknext << stktop) */
164        {"rshift",            1,   0,   {OPERAND_NONE}},
165            /* Right shift: push (stknext >> stktop) */
166        {"add",               1,   0,   {OPERAND_NONE}},
167            /* Add:         push (stknext + stktop) */
168        {"sub",               1,   0,   {OPERAND_NONE}},
169            /* Sub:         push (stkext - stktop) */
170        {"mult",              1,   0,   {OPERAND_NONE}},
171            /* Multiply:    push (stknext * stktop) */
172        {"div",               1,   0,   {OPERAND_NONE}},
173            /* Divide:      push (stknext / stktop) */
174        {"mod",               1,   0,   {OPERAND_NONE}},
175            /* Mod:         push (stknext % stktop) */
176        {"uplus",             1,   0,   {OPERAND_NONE}},
177            /* Unary plus:  push +stktop */
178        {"uminus",            1,   0,   {OPERAND_NONE}},
179            /* Unary minus: push -stktop */
180        {"bitnot",            1,   0,   {OPERAND_NONE}},
181            /* Bitwise not: push ~stktop */
182        {"not",               1,   0,   {OPERAND_NONE}},
183            /* Logical not: push !stktop */
184        {"callBuiltinFunc1",  2,   1,   {OPERAND_UINT1}},
185            /* Call builtin math function with index op1; any args are on stk */
186        {"callFunc1",         2,   1,   {OPERAND_UINT1}},
187            /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1>  */
188        {"tryCvtToNumeric",   1,   0,   {OPERAND_NONE}},
189            /* Try converting stktop to first int then double if possible. */
190    
191        {"break",             1,   0,   {OPERAND_NONE}},
192            /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
193        {"continue",          1,   0,   {OPERAND_NONE}},
194            /* Skip to next iteration of closest enclosing loop; if none,
195             * return TCL_CONTINUE code. */
196    
197        {"foreach_start4",    5,   1,   {OPERAND_UINT4}},
198            /* Initialize execution of a foreach loop. Operand is aux data index
199             * of the ForeachInfo structure for the foreach command. */
200        {"foreach_step4",     5,   1,   {OPERAND_UINT4}},
201            /* "Step" or begin next iteration of foreach loop. Push 0 if to
202             *  terminate loop, else push 1. */
203    
204        {"beginCatch4",       5,   1,   {OPERAND_UINT4}},
205            /* Record start of catch with the operand's exception index.
206             * Push the current stack depth onto a special catch stack. */
207        {"endCatch",          1,   0,   {OPERAND_NONE}},
208            /* End of last catch. Pop the bytecode interpreter's catch stack. */
209        {"pushResult",        1,   0,   {OPERAND_NONE}},
210            /* Push the interpreter's object result onto the stack. */
211        {"pushReturnCode",    1,   0,   {OPERAND_NONE}},
212            /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
213             * a new object onto the stack. */
214        {0}
215    };
216    
217    /*
218     * Prototypes for procedures defined later in this file:
219     */
220    
221    static void             DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
222                                Tcl_Obj *copyPtr));
223    static unsigned char *  EncodeCmdLocMap _ANSI_ARGS_((
224                                CompileEnv *envPtr, ByteCode *codePtr,
225                                unsigned char *startPtr));
226    static void             EnterCmdExtentData _ANSI_ARGS_((
227                                CompileEnv *envPtr, int cmdNumber,
228                                int numSrcBytes, int numCodeBytes));
229    static void             EnterCmdStartData _ANSI_ARGS_((
230                                CompileEnv *envPtr, int cmdNumber,
231                                int srcOffset, int codeOffset));
232    static void             FreeByteCodeInternalRep _ANSI_ARGS_((
233                                Tcl_Obj *objPtr));
234    static int              GetCmdLocEncodingSize _ANSI_ARGS_((
235                                CompileEnv *envPtr));
236    static void             LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
237                                char *script, char *command, int length));
238    #ifdef TCL_COMPILE_STATS
239    static void             RecordByteCodeStats _ANSI_ARGS_((
240                                ByteCode *codePtr));
241    #endif /* TCL_COMPILE_STATS */
242    static int              SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
243                                Tcl_Obj *objPtr));
244    
245    /*
246     * The structure below defines the bytecode Tcl object type by
247     * means of procedures that can be invoked by generic object code.
248     */
249    
250    Tcl_ObjType tclByteCodeType = {
251        "bytecode",                         /* name */
252        FreeByteCodeInternalRep,            /* freeIntRepProc */
253        DupByteCodeInternalRep,             /* dupIntRepProc */
254        (Tcl_UpdateStringProc *) NULL,      /* updateStringProc */
255        SetByteCodeFromAny                  /* setFromAnyProc */
256    };
257    
258    /*
259     *----------------------------------------------------------------------
260     *
261     * TclSetByteCodeFromAny --
262     *
263     *      Part of the bytecode Tcl object type implementation. Attempts to
264     *      generate an byte code internal form for the Tcl object "objPtr" by
265     *      compiling its string representation.  This function also takes
266     *      a hook procedure that will be invoked to perform any needed post
267     *      processing on the compilation results before generating byte
268     *      codes.
269     *
270     * Results:
271     *      The return value is a standard Tcl object result. If an error occurs
272     *      during compilation, an error message is left in the interpreter's
273     *      result unless "interp" is NULL.
274     *
275     * Side effects:
276     *      Frees the old internal representation. If no error occurs, then the
277     *      compiled code is stored as "objPtr"s bytecode representation.
278     *      Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
279     *      used to trace compilations.
280     *
281     *----------------------------------------------------------------------
282     */
283    
284    int
285    TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
286        Tcl_Interp *interp;         /* The interpreter for which the code is
287                                     * being compiled.  Must not be NULL. */
288        Tcl_Obj *objPtr;            /* The object to make a ByteCode object. */
289        CompileHookProc *hookProc;  /* Procedure to invoke after compilation. */
290        ClientData clientData;      /* Hook procedure private data. */
291    {
292        Interp *iPtr = (Interp *) interp;
293        CompileEnv compEnv;         /* Compilation environment structure
294                                     * allocated in frame. */
295        LiteralTable *localTablePtr = &(compEnv.localLitTable);
296        register AuxData *auxDataPtr;
297        LiteralEntry *entryPtr;
298        register int i;
299        int length, nested, result;
300        char *string;
301    
302        if (!traceInitialized) {
303            if (Tcl_LinkVar(interp, "tcl_traceCompile",
304                        (char *) &tclTraceCompile,  TCL_LINK_INT) != TCL_OK) {
305                panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
306            }
307            traceInitialized = 1;
308        }
309    
310        if (iPtr->evalFlags & TCL_BRACKET_TERM) {
311            nested = 1;
312        } else {
313            nested = 0;
314        }
315        string = Tcl_GetStringFromObj(objPtr, &length);
316        TclInitCompileEnv(interp, &compEnv, string, length);
317        result = TclCompileScript(interp, string, length, nested, &compEnv);
318    
319        if (result == TCL_OK) {
320            /*
321             * Successful compilation. Add a "done" instruction at the end.
322             */
323    
324            compEnv.numSrcBytes = iPtr->termOffset;
325            TclEmitOpcode(INST_DONE, &compEnv);
326    
327            /*
328             * Invoke the compilation hook procedure if one exists.
329             */
330    
331            if (hookProc) {
332                result = (*hookProc)(interp, &compEnv, clientData);
333            }
334    
335            /*
336             * Change the object into a ByteCode object. Ownership of the literal
337             * objects and aux data items is given to the ByteCode object.
338             */
339        
340    #ifdef TCL_COMPILE_DEBUG
341            TclVerifyLocalLiteralTable(&compEnv);
342    #endif /*TCL_COMPILE_DEBUG*/
343    
344            TclInitByteCodeObj(objPtr, &compEnv);
345    #ifdef TCL_COMPILE_DEBUG
346            if (tclTraceCompile == 2) {
347                TclPrintByteCodeObj(interp, objPtr);
348            }
349    #endif /* TCL_COMPILE_DEBUG */
350        }
351            
352        if (result != TCL_OK) {
353            /*
354             * Compilation errors.
355             */
356    
357            entryPtr = compEnv.literalArrayPtr;
358            for (i = 0;  i < compEnv.literalArrayNext;  i++) {
359                TclReleaseLiteral(interp, entryPtr->objPtr);
360                entryPtr++;
361            }
362    #ifdef TCL_COMPILE_DEBUG
363            TclVerifyGlobalLiteralTable(iPtr);
364    #endif /*TCL_COMPILE_DEBUG*/
365    
366            auxDataPtr = compEnv.auxDataArrayPtr;
367            for (i = 0;  i < compEnv.auxDataArrayNext;  i++) {
368                if (auxDataPtr->type->freeProc != NULL) {
369                    auxDataPtr->type->freeProc(auxDataPtr->clientData);
370                }
371                auxDataPtr++;
372            }
373        }
374    
375    
376        /*
377         * Free storage allocated during compilation.
378         */
379        
380        if (localTablePtr->buckets != localTablePtr->staticBuckets) {
381            ckfree((char *) localTablePtr->buckets);
382        }
383        TclFreeCompileEnv(&compEnv);
384        return result;
385    }
386    
387    /*
388     *-----------------------------------------------------------------------
389     *
390     * SetByteCodeFromAny --
391     *
392     *      Part of the bytecode Tcl object type implementation. Attempts to
393     *      generate an byte code internal form for the Tcl object "objPtr" by
394     *      compiling its string representation.
395     *
396     * Results:
397     *      The return value is a standard Tcl object result. If an error occurs
398     *      during compilation, an error message is left in the interpreter's
399     *      result unless "interp" is NULL.
400     *
401     * Side effects:
402     *      Frees the old internal representation. If no error occurs, then the
403     *      compiled code is stored as "objPtr"s bytecode representation.
404     *      Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
405     *      used to trace compilations.
406     *
407     *----------------------------------------------------------------------
408     */
409    
410    static int
411    SetByteCodeFromAny(interp, objPtr)
412        Tcl_Interp *interp;         /* The interpreter for which the code is
413                                     * being compiled.  Must not be NULL. */
414        Tcl_Obj *objPtr;            /* The object to make a ByteCode object. */
415    {
416        return TclSetByteCodeFromAny(interp, objPtr,
417                (CompileHookProc *) NULL, (ClientData) NULL);
418    }
419    
420    /*
421     *----------------------------------------------------------------------
422     *
423     * DupByteCodeInternalRep --
424     *
425     *      Part of the bytecode Tcl object type implementation. However, it
426     *      does not copy the internal representation of a bytecode Tcl_Obj, but
427     *      instead leaves the new object untyped (with a NULL type pointer).
428     *      Code will be compiled for the new object only if necessary.
429     *
430     * Results:
431     *      None.
432     *
433     * Side effects:
434     *      None.
435     *
436     *----------------------------------------------------------------------
437     */
438    
439    static void
440    DupByteCodeInternalRep(srcPtr, copyPtr)
441        Tcl_Obj *srcPtr;            /* Object with internal rep to copy. */
442        Tcl_Obj *copyPtr;           /* Object with internal rep to set. */
443    {
444        return;
445    }
446    
447    /*
448     *----------------------------------------------------------------------
449     *
450     * FreeByteCodeInternalRep --
451     *
452     *      Part of the bytecode Tcl object type implementation. Frees the
453     *      storage associated with a bytecode object's internal representation
454     *      unless its code is actively being executed.
455     *
456     * Results:
457     *      None.
458     *
459     * Side effects:
460     *      The bytecode object's internal rep is marked invalid and its
461     *      code gets freed unless the code is actively being executed.
462     *      In that case the cleanup is delayed until the last execution
463     *      of the code completes.
464     *
465     *----------------------------------------------------------------------
466     */
467    
468    static void
469    FreeByteCodeInternalRep(objPtr)
470        register Tcl_Obj *objPtr;   /* Object whose internal rep to free. */
471    {
472        register ByteCode *codePtr =
473                (ByteCode *) objPtr->internalRep.otherValuePtr;
474    
475        codePtr->refCount--;
476        if (codePtr->refCount <= 0) {
477            TclCleanupByteCode(codePtr);
478        }
479        objPtr->typePtr = NULL;
480        objPtr->internalRep.otherValuePtr = NULL;
481    }
482    
483    /*
484     *----------------------------------------------------------------------
485     *
486     * TclCleanupByteCode --
487     *
488     *      This procedure does all the real work of freeing up a bytecode
489     *      object's ByteCode structure. It's called only when the structure's
490     *      reference count becomes zero.
491     *
492     * Results:
493     *      None.
494     *
495     * Side effects:
496     *      Frees objPtr's bytecode internal representation and sets its type
497     *      and objPtr->internalRep.otherValuePtr NULL. Also releases its
498     *      literals and frees its auxiliary data items.
499     *
500     *----------------------------------------------------------------------
501     */
502    
503    void
504    TclCleanupByteCode(codePtr)
505        register ByteCode *codePtr; /* Points to the ByteCode to free. */
506    {
507        Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
508        int numLitObjects = codePtr->numLitObjects;
509        int numAuxDataItems = codePtr->numAuxDataItems;
510        register Tcl_Obj **objArrayPtr;
511        register AuxData *auxDataPtr;
512        int i;
513    #ifdef TCL_COMPILE_STATS
514    
515        if (interp != NULL) {
516            ByteCodeStats *statsPtr;
517            Tcl_Time destroyTime;
518            int lifetimeSec, lifetimeMicroSec, log2;
519    
520            statsPtr = &((Interp *) interp)->stats;
521    
522            statsPtr->numByteCodesFreed++;
523            statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
524            statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
525    
526            statsPtr->currentInstBytes   -= (double) codePtr->numCodeBytes;
527            statsPtr->currentLitBytes    -=
528                    (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
529            statsPtr->currentExceptBytes -=
530                    (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
531            statsPtr->currentAuxBytes    -=
532                    (double) (codePtr->numAuxDataItems * sizeof(AuxData));
533            statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
534    
535            TclpGetTime(&destroyTime);
536            lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
537            if (lifetimeSec > 2000) {       /* avoid overflow */
538                lifetimeSec = 2000;
539            }
540            lifetimeMicroSec =
541                1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
542            
543            log2 = TclLog2(lifetimeMicroSec);
544            if (log2 > 31) {
545                log2 = 31;
546            }
547            statsPtr->lifetimeCount[log2]++;
548        }
549    #endif /* TCL_COMPILE_STATS */
550    
551        /*
552         * A single heap object holds the ByteCode structure and its code,
553         * object, command location, and auxiliary data arrays. This means we
554         * only need to 1) decrement the ref counts of the LiteralEntry's in
555         * its literal array, 2) call the free procs for the auxiliary data
556         * items, and 3) free the ByteCode structure's heap object.
557         *
558         * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,
559         * like those generated from tbcload) is special, as they doesn't
560         * make use of the global literal table.  They instead maintain
561         * private references to their literals which must be decremented.
562         */
563    
564        if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
565            register Tcl_Obj *objPtr;
566    
567            objArrayPtr = codePtr->objArrayPtr;
568            for (i = 0;  i < numLitObjects;  i++) {
569                objPtr = *objArrayPtr;
570                if (objPtr) {
571                    Tcl_DecrRefCount(objPtr);
572                }
573                objArrayPtr++;
574            }
575            codePtr->numLitObjects = 0;
576        } else if (interp != NULL) {
577            /*
578             * If the interp has already been freed, then Tcl will have already
579             * forcefully released all the literals used by ByteCodes compiled
580             * with respect to that interp.
581             */
582            
583            objArrayPtr = codePtr->objArrayPtr;
584            for (i = 0;  i < numLitObjects;  i++) {
585                /*
586                 * TclReleaseLiteral sets a ByteCode's object array entry NULL to
587                 * indicate that it has already freed the literal.
588                 */
589                
590                if (*objArrayPtr != NULL) {
591                    TclReleaseLiteral(interp, *objArrayPtr);
592                }
593                objArrayPtr++;
594            }
595        }
596        
597        auxDataPtr = codePtr->auxDataArrayPtr;
598        for (i = 0;  i < numAuxDataItems;  i++) {
599            if (auxDataPtr->type->freeProc != NULL) {
600                (*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
601            }
602            auxDataPtr++;
603        }
604    
605        TclHandleRelease(codePtr->interpHandle);
606        ckfree((char *) codePtr);
607    }
608    
609    /*
610     *----------------------------------------------------------------------
611     *
612     * TclInitCompileEnv --
613     *
614     *      Initializes a CompileEnv compilation environment structure for the
615     *      compilation of a string in an interpreter.
616     *
617     * Results:
618     *      None.
619     *
620     * Side effects:
621     *      The CompileEnv structure is initialized.
622     *
623     *----------------------------------------------------------------------
624     */
625    
626    void
627    TclInitCompileEnv(interp, envPtr, string, numBytes)
628        Tcl_Interp *interp;          /* The interpreter for which a CompileEnv
629                                      * structure is initialized. */
630        register CompileEnv *envPtr; /* Points to the CompileEnv structure to
631                                      * initialize. */
632        char *string;                /* The source string to be compiled. */
633        int numBytes;                /* Number of bytes in source string. */
634    {
635        Interp *iPtr = (Interp *) interp;
636        
637        envPtr->iPtr = iPtr;
638        envPtr->source = string;
639        envPtr->numSrcBytes = numBytes;
640        envPtr->procPtr = iPtr->compiledProcPtr;
641        envPtr->numCommands = 0;
642        envPtr->exceptDepth = 0;
643        envPtr->maxExceptDepth = 0;
644        envPtr->maxStackDepth = 0;
645        TclInitLiteralTable(&(envPtr->localLitTable));
646        envPtr->exprIsJustVarRef = 0;
647        envPtr->exprIsComparison = 0;
648    
649        envPtr->codeStart = envPtr->staticCodeSpace;
650        envPtr->codeNext = envPtr->codeStart;
651        envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
652        envPtr->mallocedCodeArray = 0;
653    
654        envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
655        envPtr->literalArrayNext = 0;
656        envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
657        envPtr->mallocedLiteralArray = 0;
658        
659        envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
660        envPtr->exceptArrayNext = 0;
661        envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
662        envPtr->mallocedExceptArray = 0;
663        
664        envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
665        envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
666        envPtr->mallocedCmdMap = 0;
667        
668        envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
669        envPtr->auxDataArrayNext = 0;
670        envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
671        envPtr->mallocedAuxDataArray = 0;
672    }
673    
674    /*
675     *----------------------------------------------------------------------
676     *
677     * TclFreeCompileEnv --
678     *
679     *      Free the storage allocated in a CompileEnv compilation environment
680     *      structure.
681     *
682     * Results:
683     *      None.
684     *
685     * Side effects:
686     *      Allocated storage in the CompileEnv structure is freed. Note that
687     *      its local literal table is not deleted and its literal objects are
688     *      not released. In addition, storage referenced by its auxiliary data
689     *      items is not freed. This is done so that, when compilation is
690     *      successful, "ownership" of these objects and aux data items is
691     *      handed over to the corresponding ByteCode structure.
692     *
693     *----------------------------------------------------------------------
694     */
695    
696    void
697    TclFreeCompileEnv(envPtr)
698        register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
699    {
700        if (envPtr->mallocedCodeArray) {
701            ckfree((char *) envPtr->codeStart);
702        }
703        if (envPtr->mallocedLiteralArray) {
704            ckfree((char *) envPtr->literalArrayPtr);
705        }
706        if (envPtr->mallocedExceptArray) {
707            ckfree((char *) envPtr->exceptArrayPtr);
708        }
709        if (envPtr->mallocedCmdMap) {
710            ckfree((char *) envPtr->cmdMapPtr);
711        }
712        if (envPtr->mallocedAuxDataArray) {
713            ckfree((char *) envPtr->auxDataArrayPtr);
714        }
715    }
716    
717    /*
718     *----------------------------------------------------------------------
719     *
720     * TclCompileScript --
721     *
722     *      Compile a Tcl script in a string.
723     *
724     * Results:
725     *      The return value is TCL_OK on a successful compilation and TCL_ERROR
726     *      on failure. If TCL_ERROR is returned, then the interpreter's result
727     *      contains an error message.
728     *
729     *      interp->termOffset is set to the offset of the character in the
730     *      script just after the last one successfully processed; this will be
731     *      the offset of the ']' if (flags & TCL_BRACKET_TERM).
732     *      envPtr->maxStackDepth is set to the maximum number of stack elements
733     *      needed to execute the script's commands.
734     *
735     * Side effects:
736     *      Adds instructions to envPtr to evaluate the script at runtime.
737     *
738     *----------------------------------------------------------------------
739     */
740    
741    int
742    TclCompileScript(interp, script, numBytes, nested, envPtr)
743        Tcl_Interp *interp;         /* Used for error and status reporting. */
744        char *script;               /* The source script to compile. */
745        int numBytes;               /* Number of bytes in script. If < 0, the
746                                     * script consists of all bytes up to the
747                                     * first null character. */
748        int nested;                 /* Non-zero means this is a nested command:
749                                     * close bracket ']' should be considered a
750                                     * command terminator. If zero, close
751                                     * bracket has no special meaning. */
752        CompileEnv *envPtr;         /* Holds resulting instructions. */
753    {
754        Interp *iPtr = (Interp *) interp;
755        Tcl_Parse parse;
756        int maxDepth = 0;           /* Maximum number of stack elements needed
757                                     * to execute all cmds. */
758        int lastTopLevelCmdIndex = -1;
759                                    /* Index of most recent toplevel command in
760                                     * the command location table. Initialized
761                                     * to avoid compiler warning. */
762        int startCodeOffset = -1;   /* Offset of first byte of current command's
763                                     * code. Init. to avoid compiler warning. */
764        unsigned char *entryCodeNext = envPtr->codeNext;
765        char *p, *next;
766        Namespace *cmdNsPtr;
767        Command *cmdPtr;
768        Tcl_Token *tokenPtr;
769        int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
770        int commandLength, objIndex, code;
771        char prev;
772        Tcl_DString ds;
773    
774        Tcl_DStringInit(&ds);
775    
776        if (numBytes < 0) {
777            numBytes = strlen(script);
778        }
779        Tcl_ResetResult(interp);
780        isFirstCmd = 1;
781    
782        /*
783         * Each iteration through the following loop compiles the next
784         * command from the script.
785         */
786    
787        p = script;
788        bytesLeft = numBytes;
789        gotParse = 0;
790        while (bytesLeft > 0) {
791            if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
792                code = TCL_ERROR;
793                goto error;
794            }
795            gotParse = 1;
796            if (parse.numWords > 0) {
797                /*
798                 * If not the first command, pop the previous command's result
799                 * and, if we're compiling a top level command, update the last
800                 * command's code size to account for the pop instruction.
801                 */
802    
803                if (!isFirstCmd) {
804                    TclEmitOpcode(INST_POP, envPtr);
805                    if (!nested) {
806                        envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
807                               (envPtr->codeNext - envPtr->codeStart)
808                               - startCodeOffset;
809                    }
810                }
811    
812                /*
813                 * Determine the actual length of the command.
814                 */
815    
816                commandLength = parse.commandSize;
817                prev = '\0';
818                if (commandLength > 0) {
819                    prev = parse.commandStart[commandLength-1];
820                }
821                if (((parse.commandStart+commandLength) != (script+numBytes))
822                        || ((prev=='\n') || (nested && (prev==']')))) {
823                    /*
824                     * The command didn't end at the end of the script (i.e.  it
825                     * ended at a terminator character such as ";".  Reduce the
826                     * length by one so that the trace message doesn't include
827                     * the terminator character.
828                     */
829                    
830                    commandLength -= 1;
831                }
832    
833                /*
834                 * If tracing, print a line for each top level command compiled.
835                 */
836    
837                if ((tclTraceCompile >= 1)
838                        && !nested && (envPtr->procPtr == NULL)) {
839                    fprintf(stdout, "  Compiling: ");
840                    TclPrintSource(stdout, parse.commandStart,
841                            TclMin(commandLength, 55));
842                    fprintf(stdout, "\n");
843                }
844    
845                /*
846                 * Each iteration of the following loop compiles one word
847                 * from the command.
848                 */
849                
850                envPtr->numCommands++;
851                currCmdIndex = (envPtr->numCommands - 1);
852                if (!nested) {
853                    lastTopLevelCmdIndex = currCmdIndex;
854                }
855                startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
856                EnterCmdStartData(envPtr, currCmdIndex,
857                        (parse.commandStart - envPtr->source), startCodeOffset);
858                
859                for (wordIdx = 0, tokenPtr = parse.tokenPtr;
860                        wordIdx < parse.numWords;
861                        wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
862                    if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
863                        /*
864                         * If this is the first word and the command has a
865                         * compile procedure, let it compile the command.
866                         */
867    
868                        if (wordIdx == 0) {
869                            if (envPtr->procPtr != NULL) {
870                                cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
871                            } else {
872                                cmdNsPtr = NULL; /* use current NS */
873                            }
874    
875                            /*
876                             * We copy the string before trying to find the command
877                             * by name.  We used to modify the string in place, but
878                             * this is not safe because the name resolution
879                             * handlers could have side effects that rely on the
880                             * unmodified string.
881                             */
882    
883                            Tcl_DStringSetLength(&ds, 0);
884                            Tcl_DStringAppend(&ds, tokenPtr[1].start,
885                                    tokenPtr[1].size);
886    
887                            cmdPtr = (Command *) Tcl_FindCommand(interp,
888                                    Tcl_DStringValue(&ds),
889                                    (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
890    
891                            if ((cmdPtr != NULL)
892                                    && (cmdPtr->compileProc != NULL)
893                                    && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
894                                code = (*(cmdPtr->compileProc))(interp, &parse,
895                                        envPtr);
896                                if (code == TCL_OK) {
897                                    maxDepth = TclMax(envPtr->maxStackDepth,
898                                            maxDepth);
899                                    goto finishCommand;
900                                } else if (code == TCL_OUT_LINE_COMPILE) {
901                                    /* do nothing */
902                                } else { /* an error */
903                                    /*
904                                     * There was a compilation error, the last
905                                     * command did not get compiled into (*envPtr).
906                                     * Decrement the number of commands
907                                     * claimed to be in (*envPtr).
908                                     */
909                                    envPtr->numCommands--;
910                                    goto error;
911                                }
912                            }
913    
914                            /*
915                             * No compile procedure so push the word. If the
916                             * command was found, push a CmdName object to
917                             * reduce runtime lookups.
918                             */
919    
920                            objIndex = TclRegisterLiteral(envPtr,
921                                    tokenPtr[1].start, tokenPtr[1].size,
922                                    /*onHeap*/ 0);
923                            if (cmdPtr != NULL) {
924                                TclSetCmdNameObj(interp,
925                                       envPtr->literalArrayPtr[objIndex].objPtr,
926                                       cmdPtr);
927                            }
928                        } else {
929                            objIndex = TclRegisterLiteral(envPtr,
930                                    tokenPtr[1].start, tokenPtr[1].size,
931                                    /*onHeap*/ 0);
932                        }
933                        TclEmitPush(objIndex, envPtr);
934                        maxDepth = TclMax((wordIdx + 1), maxDepth);
935                    } else {
936                        /*
937                         * The word is not a simple string of characters.
938                         */
939                        
940                        code = TclCompileTokens(interp, tokenPtr+1,
941                                tokenPtr->numComponents, envPtr);
942                        if (code != TCL_OK) {
943                            goto error;
944                        }
945                        maxDepth = TclMax((wordIdx + envPtr->maxStackDepth),
946                               maxDepth);
947                    }
948                }
949    
950                /*
951                 * Emit an invoke instruction for the command. We skip this
952                 * if a compile procedure was found for the command.
953                 */
954                
955                if (wordIdx > 0) {
956                    if (wordIdx <= 255) {
957                        TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
958                    } else {
959                        TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
960                    }
961                }
962    
963                /*
964                 * Update the compilation environment structure and record the
965                 * offsets of the source and code for the command.
966                 */
967    
968                finishCommand:
969                EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
970                        (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
971                isFirstCmd = 0;
972            } /* end if parse.numWords > 0 */
973    
974            /*
975             * Advance to the next command in the script.
976             */
977            
978            next = parse.commandStart + parse.commandSize;
979            bytesLeft -= (next - p);
980            p = next;
981            Tcl_FreeParse(&parse);
982            gotParse = 0;
983            if (nested && (p[-1] == ']')) {
984                /*
985                 * We get here in the special case where TCL_BRACKET_TERM was
986                 * set in the interpreter and we reached a close bracket in the
987                 * script. Stop compilation.
988                 */
989                
990                break;
991            }
992        }
993    
994        /*
995         * If the source script yielded no instructions (e.g., if it was empty),
996         * push an empty string as the command's result.
997         */
998        
999        if (envPtr->codeNext == entryCodeNext) {
1000            TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
1001                    envPtr);
1002            maxDepth = 1;
1003        }
1004        
1005        if ((nested != 0) && (p > script) && (p[-1] == ']')) {
1006            iPtr->termOffset = (p - 1) - script;
1007        } else {
1008            iPtr->termOffset = (p - script);
1009        }
1010        envPtr->maxStackDepth = maxDepth;
1011        Tcl_DStringFree(&ds);
1012        return TCL_OK;
1013            
1014        error:
1015        /*
1016         * Generate various pieces of error information, such as the line
1017         * number where the error occurred and information to add to the
1018         * errorInfo variable. Then free resources that had been allocated
1019         * to the command.
1020         */
1021    
1022        commandLength = parse.commandSize;
1023        prev = '\0';
1024        if (commandLength > 0) {
1025            prev = parse.commandStart[commandLength-1];
1026        }
1027        if (((parse.commandStart+commandLength) != (script+numBytes))
1028                || ((prev == '\n') || (nested && (prev == ']')))) {
1029            /*
1030             * The command where the error occurred didn't end at the end
1031             * of the script (i.e. it ended at a terminator character such
1032             * as ";".  Reduce the length by one so that the error message
1033             * doesn't include the terminator character.
1034             */
1035    
1036            commandLength -= 1;
1037        }
1038        LogCompilationInfo(interp, script, parse.commandStart, commandLength);
1039        if (gotParse) {
1040            Tcl_FreeParse(&parse);
1041        }
1042        iPtr->termOffset = (p - script);
1043        envPtr->maxStackDepth = maxDepth;
1044        Tcl_DStringFree(&ds);
1045        return code;
1046    }
1047    
1048    /*
1049     *----------------------------------------------------------------------
1050     *
1051     * TclCompileTokens --
1052     *
1053     *      Given an array of tokens parsed from a Tcl command (e.g., the tokens
1054     *      that make up a word) this procedure emits instructions to evaluate
1055     *      the tokens and concatenate their values to form a single result
1056     *      value on the interpreter's runtime evaluation stack.
1057     *
1058     * Results:
1059     *      The return value is a standard Tcl result. If an error occurs, an
1060     *      error message is left in the interpreter's result.
1061     *      
1062     *      envPtr->maxStackDepth is updated with the maximum number of stack
1063     *      elements needed to evaluate the tokens.
1064     *
1065     * Side effects:
1066     *      Instructions are added to envPtr to push and evaluate the tokens
1067     *      at runtime.
1068     *
1069     *----------------------------------------------------------------------
1070     */
1071    
1072    int
1073    TclCompileTokens(interp, tokenPtr, count, envPtr)
1074        Tcl_Interp *interp;         /* Used for error and status reporting. */
1075        Tcl_Token *tokenPtr;        /* Pointer to first in an array of tokens
1076                                     * to compile. */
1077        int count;                  /* Number of tokens to consider at tokenPtr.
1078                                     * Must be at least 1. */
1079        CompileEnv *envPtr;         /* Holds the resulting instructions. */
1080    {
1081        Tcl_DString textBuffer;     /* Holds concatenated chars from adjacent
1082                                     * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
1083        char buffer[TCL_UTF_MAX];
1084        char *name, *p;
1085        int numObjsToConcat, nameBytes, hasNsQualifiers, localVar;
1086        int length, maxDepth, depthForVar, i, code;
1087        unsigned char *entryCodeNext = envPtr->codeNext;
1088    
1089        Tcl_DStringInit(&textBuffer);
1090        maxDepth = 0;
1091        numObjsToConcat = 0;
1092        for ( ;  count > 0;  count--, tokenPtr++) {
1093            switch (tokenPtr->type) {
1094                case TCL_TOKEN_TEXT:
1095                    Tcl_DStringAppend(&textBuffer, tokenPtr->start,
1096                            tokenPtr->size);
1097                    break;
1098    
1099                case TCL_TOKEN_BS:
1100                    length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
1101                            buffer);
1102                    Tcl_DStringAppend(&textBuffer, buffer, length);
1103                    break;
1104    
1105                case TCL_TOKEN_COMMAND:
1106                    /*
1107                     * Push any accumulated chars appearing before the command.
1108                     */
1109                    
1110                    if (Tcl_DStringLength(&textBuffer) > 0) {
1111                        int literal;
1112                        
1113                        literal = TclRegisterLiteral(envPtr,
1114                                Tcl_DStringValue(&textBuffer),
1115                                Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1116                        TclEmitPush(literal, envPtr);
1117                        numObjsToConcat++;
1118                        maxDepth = TclMax(numObjsToConcat, maxDepth);
1119                        Tcl_DStringFree(&textBuffer);
1120                    }
1121                    
1122                    code = TclCompileScript(interp, tokenPtr->start+1,
1123                            tokenPtr->size-2, /*nested*/ 1, envPtr);
1124                    if (code != TCL_OK) {
1125                        goto error;
1126                    }
1127                    maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth),
1128                            maxDepth);
1129                    numObjsToConcat++;
1130                    break;
1131    
1132                case TCL_TOKEN_VARIABLE:
1133                    /*
1134                     * Push any accumulated chars appearing before the $<var>.
1135                     */
1136                    
1137                    if (Tcl_DStringLength(&textBuffer) > 0) {
1138                        int literal;
1139                        
1140                        literal = TclRegisterLiteral(envPtr,
1141                                Tcl_DStringValue(&textBuffer),
1142                                Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1143                        TclEmitPush(literal, envPtr);
1144                        numObjsToConcat++;
1145                        maxDepth = TclMax(numObjsToConcat, maxDepth);
1146                        Tcl_DStringFree(&textBuffer);
1147                    }
1148                    
1149                    /*
1150                     * Check if the name contains any namespace qualifiers.
1151                     */
1152                    
1153                    name = tokenPtr[1].start;
1154                    nameBytes = tokenPtr[1].size;
1155                    hasNsQualifiers = 0;
1156                    for (i = 0, p = name;  i < nameBytes;  i++, p++) {
1157                        if ((*p == ':') && (i < (nameBytes-1))
1158                                && (*(p+1) == ':')) {
1159                            hasNsQualifiers = 1;
1160                            break;
1161                        }
1162                    }
1163    
1164                    /*
1165                     * Either push the variable's name, or find its index in
1166                     * the array of local variables in a procedure frame.
1167                     */
1168    
1169                    depthForVar = 0;
1170                    if ((envPtr->procPtr == NULL) || hasNsQualifiers) {
1171                        localVar = -1;
1172                        TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes,
1173                                /*onHeap*/ 0), envPtr);
1174                        depthForVar = 1;
1175                    } else {
1176                        localVar = TclFindCompiledLocal(name, nameBytes,
1177                                /*create*/ 0, /*flags*/ 0, envPtr->procPtr);
1178                        if (localVar < 0) {
1179                            TclEmitPush(TclRegisterLiteral(envPtr, name,
1180                                    nameBytes, /*onHeap*/ 0), envPtr);
1181                            depthForVar = 1;
1182                        }
1183                    }
1184    
1185                    /*
1186                     * Emit instructions to load the variable.
1187                     */
1188                    
1189                    if (tokenPtr->numComponents == 1) {
1190                        if (localVar < 0) {
1191                            TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
1192                        } else if (localVar <= 255) {
1193                            TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
1194                                    envPtr);
1195                        } else {
1196                            TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
1197                                    envPtr);
1198                        }
1199                    } else {
1200                        code = TclCompileTokens(interp, tokenPtr+2,
1201                                tokenPtr->numComponents-1, envPtr);
1202                        if (code != TCL_OK) {
1203                            sprintf(buffer,
1204                                    "\n    (parsing index for array \"%.*s\")",
1205                                    ((nameBytes > 100)? 100 : nameBytes), name);
1206                            Tcl_AddObjErrorInfo(interp, buffer, -1);
1207                            goto error;
1208                        }
1209                        depthForVar += envPtr->maxStackDepth;
1210                        if (localVar < 0) {
1211                            TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
1212                        } else if (localVar <= 255) {
1213                            TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
1214                                    envPtr);
1215                        } else {
1216                            TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
1217                                    envPtr);
1218                        }
1219                    }
1220                    maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth);
1221                    numObjsToConcat++;
1222                    count -= tokenPtr->numComponents;
1223                    tokenPtr += tokenPtr->numComponents;
1224                    break;
1225    
1226                default:
1227                    panic("Unexpected token type in TclCompileTokens");
1228            }
1229        }
1230    
1231        /*
1232         * Push any accumulated characters appearing at the end.
1233         */
1234    
1235        if (Tcl_DStringLength(&textBuffer) > 0) {
1236            int literal;
1237    
1238            literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
1239                    Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1240            TclEmitPush(literal, envPtr);
1241            numObjsToConcat++;
1242            maxDepth = TclMax(numObjsToConcat, maxDepth);
1243        }
1244    
1245        /*
1246         * If necessary, concatenate the parts of the word.
1247         */
1248    
1249        while (numObjsToConcat > 255) {
1250            TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
1251            numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
1252        }
1253        if (numObjsToConcat > 1) {
1254            TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
1255        }
1256    
1257        /*
1258         * If the tokens yielded no instructions, push an empty string.
1259         */
1260        
1261        if (envPtr->codeNext == entryCodeNext) {
1262            TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
1263                    envPtr);
1264            maxDepth = 1;
1265        }
1266        Tcl_DStringFree(&textBuffer);
1267        envPtr->maxStackDepth = maxDepth;
1268        return TCL_OK;
1269    
1270        error:
1271        Tcl_DStringFree(&textBuffer);
1272        envPtr->maxStackDepth = maxDepth;
1273        return code;
1274    }
1275    
1276    /*
1277     *----------------------------------------------------------------------
1278     *
1279     * TclCompileCmdWord --
1280     *
1281     *      Given an array of parse tokens for a word containing one or more Tcl
1282     *      commands, emit inline instructions to execute them. This procedure
1283     *      differs from TclCompileTokens in that a simple word such as a loop
1284     *      body enclosed in braces is not just pushed as a string, but is
1285     *      itself parsed into tokens and compiled.
1286     *
1287     * Results:
1288     *      The return value is a standard Tcl result. If an error occurs, an
1289     *      error message is left in the interpreter's result.
1290     *      
1291     *      envPtr->maxStackDepth is updated with the maximum number of stack
1292     *      elements needed to execute the tokens.
1293     *
1294     * Side effects:
1295     *      Instructions are added to envPtr to execute the tokens at runtime.
1296     *
1297     *----------------------------------------------------------------------
1298     */
1299    
1300    int
1301    TclCompileCmdWord(interp, tokenPtr, count, envPtr)
1302        Tcl_Interp *interp;         /* Used for error and status reporting. */
1303        Tcl_Token *tokenPtr;        /* Pointer to first in an array of tokens
1304                                     * for a command word to compile inline. */
1305        int count;                  /* Number of tokens to consider at tokenPtr.
1306                                     * Must be at least 1. */
1307        CompileEnv *envPtr;         /* Holds the resulting instructions. */
1308    {
1309        int code;
1310    
1311        /*
1312         * Handle the common case: if there is a single text token, compile it
1313         * into an inline sequence of instructions.
1314         */
1315        
1316        envPtr->maxStackDepth = 0;
1317        if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
1318            code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
1319                    /*nested*/ 0, envPtr);
1320            return code;
1321        }
1322    
1323        /*
1324         * Multiple tokens or the single token involves substitutions. Emit
1325         * instructions to invoke the eval command procedure at runtime on the
1326         * result of evaluating the tokens.
1327         */
1328    
1329        code = TclCompileTokens(interp, tokenPtr, count, envPtr);
1330        if (code != TCL_OK) {
1331            return code;
1332        }
1333        TclEmitOpcode(INST_EVAL_STK, envPtr);
1334        return TCL_OK;
1335    }
1336    
1337    /*
1338     *----------------------------------------------------------------------
1339     *
1340     * TclCompileExprWords --
1341     *
1342     *      Given an array of parse tokens representing one or more words that
1343     *      contain a Tcl expression, emit inline instructions to execute the
1344     *      expression. This procedure differs from TclCompileExpr in that it
1345     *      supports Tcl's two-level substitution semantics for expressions that
1346     *      appear as command words.
1347     *
1348     * Results:
1349     *      The return value is a standard Tcl result. If an error occurs, an
1350     *      error message is left in the interpreter's result.
1351     *      
1352     *      envPtr->maxStackDepth is updated with the maximum number of stack
1353     *      elements needed to execute the expression.
1354     *
1355     * Side effects:
1356     *      Instructions are added to envPtr to execute the expression.
1357     *
1358     *----------------------------------------------------------------------
1359     */
1360    
1361    int
1362    TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
1363        Tcl_Interp *interp;         /* Used for error and status reporting. */
1364        Tcl_Token *tokenPtr;        /* Points to first in an array of word
1365                                     * tokens tokens for the expression to
1366                                     * compile inline. */
1367        int numWords;               /* Number of word tokens starting at
1368                                     * tokenPtr. Must be at least 1. Each word
1369                                     * token contains one or more subtokens. */
1370        CompileEnv *envPtr;         /* Holds the resulting instructions. */
1371    {
1372        Tcl_Token *wordPtr;
1373        int maxDepth, range, numBytes, i, code;
1374        char *script;
1375        int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
1376        int saveExprIsComparison = envPtr->exprIsComparison;
1377    
1378        envPtr->maxStackDepth = 0;
1379        maxDepth = 0;
1380        range = -1;
1381        code = TCL_OK;
1382    
1383        /*
1384         * If the expression is a single word that doesn't require
1385         * substitutions, just compile it's string into inline instructions.
1386         */
1387    
1388        if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
1389            /*
1390             * Temporarily overwrite the character just after the end of the
1391             * string with a 0 byte.
1392             */
1393    
1394            script = tokenPtr[1].start;
1395            numBytes = tokenPtr[1].size;
1396            code = TclCompileExpr(interp, script, numBytes, envPtr);
1397            return code;
1398        }
1399      
1400        /*
1401         * Emit code to call the expr command proc at runtime. Concatenate the
1402         * (already substituted once) expr tokens with a space between each.
1403         */
1404    
1405        wordPtr = tokenPtr;
1406        for (i = 0;  i < numWords;  i++) {
1407            code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
1408                    envPtr);
1409            if (code != TCL_OK) {
1410                break;
1411            }
1412            if (i < (numWords - 1)) {
1413                TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
1414