Logo Search packages:      
Sourcecode: tcl8.5 version File versions  Download package

tclCompile.c

/*
 * 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.
 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
 *
 * 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.144 2007/12/13 15:23:15 dgp 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".
 */

#ifdef TCL_COMPILE_DEBUG
int tclTraceCompile = 0;
static int traceInitialized = 0;
#endif

/*
 * 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 tclInstructionTable[] = {
    /* Name       Bytes stackEffect #Opnds  Operand types */
    {"done",              1,   -1,         0,   {OPERAND_NONE}},
      /* Finish ByteCode execution and return stktop (top stack item) */
    {"push1",             2,   +1,         1,   {OPERAND_UINT1}},
      /* Push object at ByteCode objArray[op1] */
    {"push4",             5,   +1,         1,   {OPERAND_UINT4}},
      /* Push object at ByteCode objArray[op4] */
    {"pop",         1,   -1,         0,   {OPERAND_NONE}},
      /* Pop the topmost stack object */
    {"dup",         1,   +1,         0,   {OPERAND_NONE}},
      /* Duplicate the topmost stack object and push the result */
    {"concat1",           2,   INT_MIN,    1,   {OPERAND_UINT1}},
      /* Concatenate the top op1 items and push result */
    {"invokeStk1",        2,   INT_MIN,    1,   {OPERAND_UINT1}},
      /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
    {"invokeStk4",        5,   INT_MIN,    1,   {OPERAND_UINT4}},
      /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
    {"evalStk",           1,   0,          0,   {OPERAND_NONE}},
      /* Evaluate command in stktop using Tcl_EvalObj. */
    {"exprStk",           1,   0,          0,   {OPERAND_NONE}},
      /* Execute expression in stktop using Tcl_ExprStringObj. */

    {"loadScalar1",       2,   1,          1,   {OPERAND_LVT1}},
      /* Load scalar variable at index op1 <= 255 in call frame */
    {"loadScalar4",       5,   1,          1,   {OPERAND_LVT4}},
      /* Load scalar variable at index op1 >= 256 in call frame */
    {"loadScalarStk",     1,   0,          0,   {OPERAND_NONE}},
      /* Load scalar variable; scalar's name is stktop */
    {"loadArray1",        2,   0,          1,   {OPERAND_LVT1}},
      /* Load array element; array at slot op1<=255, element is stktop */
    {"loadArray4",        5,   0,          1,   {OPERAND_LVT4}},
      /* Load array element; array at slot op1 > 255, element is stktop */
    {"loadArrayStk",      1,   -1,         0,   {OPERAND_NONE}},
      /* Load array element; element is stktop, array name is stknext */
    {"loadStk",           1,   0,          0,   {OPERAND_NONE}},
      /* Load general variable; unparsed variable name is stktop */
    {"storeScalar1",      2,   0,          1,   {OPERAND_LVT1}},
      /* Store scalar variable at op1<=255 in frame; value is stktop */
    {"storeScalar4",      5,   0,          1,   {OPERAND_LVT4}},
      /* Store scalar variable at op1 > 255 in frame; value is stktop */
    {"storeScalarStk",    1,   -1,         0,   {OPERAND_NONE}},
      /* Store scalar; value is stktop, scalar name is stknext */
    {"storeArray1",       2,   -1,         1,   {OPERAND_LVT1}},
      /* Store array element; array at op1<=255, value is top then elem */
    {"storeArray4",       5,   -1,         1,   {OPERAND_LVT4}},
      /* Store array element; array at op1>=256, value is top then elem */
    {"storeArrayStk",     1,   -2,         0,   {OPERAND_NONE}},
      /* Store array element; value is stktop, then elem, array names */
    {"storeStk",    1,   -1,         0,   {OPERAND_NONE}},
      /* Store general variable; value is stktop, then unparsed name */

    {"incrScalar1",       2,   0,          1,   {OPERAND_LVT1}},
      /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
    {"incrScalarStk",     1,   -1,         0,   {OPERAND_NONE}},
      /* Incr scalar; incr amount is stktop, scalar's name is stknext */
    {"incrArray1",        2,   -1,         1,   {OPERAND_LVT1}},
      /* Incr array elem; arr at slot op1<=255, amount is top then elem */
    {"incrArrayStk",      1,   -2,         0,   {OPERAND_NONE}},
      /* Incr array element; amount is top then elem then array names */
    {"incrStk",           1,   -1,         0,   {OPERAND_NONE}},
      /* Incr general variable; amount is stktop then unparsed var name */
    {"incrScalar1Imm",    3,   +1,         2,   {OPERAND_LVT1, OPERAND_INT1}},
      /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
    {"incrScalarStkImm",  2,   0,          1,   {OPERAND_INT1}},
      /* Incr scalar; scalar name is stktop; incr amount is op1 */
    {"incrArray1Imm",     3,   0,          2,   {OPERAND_LVT1, OPERAND_INT1}},
      /* Incr array elem; array at slot op1 <= 255, elem is stktop,
       * amount is 2nd operand byte */
    {"incrArrayStkImm",   2,   -1,         1,   {OPERAND_INT1}},
      /* Incr array element; elem is top then array name, amount is op1 */
    {"incrStkImm",        2,   0,      1, {OPERAND_INT1}},
      /* Incr general variable; unparsed name is top, amount is op1 */

    {"jump1",             2,   0,          1,   {OPERAND_INT1}},
      /* Jump relative to (pc + op1) */
    {"jump4",             5,   0,          1,   {OPERAND_INT4}},
      /* Jump relative to (pc + op4) */
    {"jumpTrue1",   2,   -1,         1,   {OPERAND_INT1}},
      /* Jump relative to (pc + op1) if stktop expr object is true */
    {"jumpTrue4",   5,   -1,         1,   {OPERAND_INT4}},
      /* Jump relative to (pc + op4) if stktop expr object is true */
    {"jumpFalse1",        2,   -1,         1,   {OPERAND_INT1}},
      /* Jump relative to (pc + op1) if stktop expr object is false */
    {"jumpFalse4",        5,   -1,         1,   {OPERAND_INT4}},
      /* Jump relative to (pc + op4) if stktop expr object is false */

    {"lor",         1,   -1,         0,   {OPERAND_NONE}},
      /* Logical or:    push (stknext || stktop) */
    {"land",              1,   -1,         0,   {OPERAND_NONE}},
      /* Logical and:   push (stknext && stktop) */
    {"bitor",             1,   -1,         0,   {OPERAND_NONE}},
      /* Bitwise or:    push (stknext | stktop) */
    {"bitxor",            1,   -1,         0,   {OPERAND_NONE}},
      /* Bitwise xor    push (stknext ^ stktop) */
    {"bitand",            1,   -1,         0,   {OPERAND_NONE}},
      /* Bitwise and:   push (stknext & stktop) */
    {"eq",          1,   -1,         0,   {OPERAND_NONE}},
      /* Equal:   push (stknext == stktop) */
    {"neq",         1,   -1,         0,   {OPERAND_NONE}},
      /* Not equal:     push (stknext != stktop) */
    {"lt",          1,   -1,         0,   {OPERAND_NONE}},
      /* Less:    push (stknext < stktop) */
    {"gt",          1,   -1,         0,   {OPERAND_NONE}},
      /* Greater: push (stknext || stktop) */
    {"le",          1,   -1,         0,   {OPERAND_NONE}},
      /* Less or equal: push (stknext || stktop) */
    {"ge",          1,   -1,         0,   {OPERAND_NONE}},
      /* Greater or equal: push (stknext || stktop) */
    {"lshift",            1,   -1,         0,   {OPERAND_NONE}},
      /* Left shift:    push (stknext << stktop) */
    {"rshift",            1,   -1,         0,   {OPERAND_NONE}},
      /* Right shift:   push (stknext >> stktop) */
    {"add",         1,   -1,         0,   {OPERAND_NONE}},
      /* Add:           push (stknext + stktop) */
    {"sub",         1,   -1,         0,   {OPERAND_NONE}},
      /* Sub:           push (stkext - stktop) */
    {"mult",              1,   -1,         0,   {OPERAND_NONE}},
      /* Multiply:      push (stknext * stktop) */
    {"div",         1,   -1,         0,   {OPERAND_NONE}},
      /* Divide:  push (stknext / stktop) */
    {"mod",         1,   -1,         0,   {OPERAND_NONE}},
      /* Mod:           push (stknext % stktop) */
    {"uplus",             1,   0,          0,   {OPERAND_NONE}},
      /* Unary plus:    push +stktop */
    {"uminus",            1,   0,          0,   {OPERAND_NONE}},
      /* Unary minus:   push -stktop */
    {"bitnot",            1,   0,          0,   {OPERAND_NONE}},
      /* Bitwise not:   push ~stktop */
    {"not",         1,   0,          0,   {OPERAND_NONE}},
      /* Logical not:   push !stktop */
    {"callBuiltinFunc1",  2,   1,          1,   {OPERAND_UINT1}},
      /* Call builtin math function with index op1; any args are on stk */
    {"callFunc1",   2,   INT_MIN,    1,   {OPERAND_UINT1}},
      /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
    {"tryCvtToNumeric",   1,   0,          0,   {OPERAND_NONE}},
      /* Try converting stktop to first int then double if possible. */

    {"break",             1,   0,          0,   {OPERAND_NONE}},
      /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
    {"continue",    1,   0,          0,   {OPERAND_NONE}},
      /* Skip to next iteration of closest enclosing loop; if none, return
       * TCL_CONTINUE code. */

    {"foreach_start4",    5,   0,          1,   {OPERAND_AUX4}},
      /* Initialize execution of a foreach loop. Operand is aux data index
       * of the ForeachInfo structure for the foreach command. */
    {"foreach_step4",     5,   +1,         1,   {OPERAND_AUX4}},
      /* "Step" or begin next iteration of foreach loop. Push 0 if to
       * terminate loop, else push 1. */

    {"beginCatch4",       5,   0,          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,          0,   {OPERAND_NONE}},
      /* End of last catch. Pop the bytecode interpreter's catch stack. */
    {"pushResult",        1,   +1,         0,   {OPERAND_NONE}},
      /* Push the interpreter's object result onto the stack. */
    {"pushReturnCode",    1,   +1,         0,   {OPERAND_NONE}},
      /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new
       * object onto the stack. */

    {"streq",             1,   -1,         0,   {OPERAND_NONE}},
      /* Str Equal:     push (stknext eq stktop) */
    {"strneq",            1,   -1,         0,   {OPERAND_NONE}},
      /* Str !Equal:    push (stknext neq stktop) */
    {"strcmp",            1,   -1,         0,   {OPERAND_NONE}},
      /* Str Compare:   push (stknext cmp stktop) */
    {"strlen",            1,   0,          0,   {OPERAND_NONE}},
      /* Str Length:    push (strlen stktop) */
    {"strindex",    1,   -1,         0,   {OPERAND_NONE}},
      /* Str Index:     push (strindex stknext stktop) */
    {"strmatch",    2,   -1,         1,   {OPERAND_INT1}},
      /* Str Match:     push (strmatch stknext stktop) opnd == nocase */

    {"list",              5,   INT_MIN,    1,   {OPERAND_UINT4}},
      /* List:    push (stk1 stk2 ... stktop) */
    {"listIndex",   1,   -1,         0,   {OPERAND_NONE}},
      /* List Index:    push (listindex stknext stktop) */
    {"listLength",        1,   0,          0,   {OPERAND_NONE}},
      /* List Len:      push (listlength stktop) */

    {"appendScalar1",     2,   0,          1,   {OPERAND_LVT1}},
      /* Append scalar variable at op1<=255 in frame; value is stktop */
    {"appendScalar4",     5,   0,          1,   {OPERAND_LVT4}},
      /* Append scalar variable at op1 > 255 in frame; value is stktop */
    {"appendArray1",      2,   -1,         1,   {OPERAND_LVT1}},
      /* Append array element; array at op1<=255, value is top then elem */
    {"appendArray4",      5,   -1,         1,   {OPERAND_LVT4}},
      /* Append array element; array at op1>=256, value is top then elem */
    {"appendArrayStk",    1,   -2,         0,   {OPERAND_NONE}},
      /* Append array element; value is stktop, then elem, array names */
    {"appendStk",   1,   -1,         0,   {OPERAND_NONE}},
      /* Append general variable; value is stktop, then unparsed name */
    {"lappendScalar1",    2,   0,          1,   {OPERAND_LVT1}},
      /* Lappend scalar variable at op1<=255 in frame; value is stktop */
    {"lappendScalar4",    5,   0,          1,   {OPERAND_LVT4}},
      /* Lappend scalar variable at op1 > 255 in frame; value is stktop */
    {"lappendArray1",     2,   -1,         1,   {OPERAND_LVT1}},
      /* Lappend array element; array at op1<=255, value is top then elem */
    {"lappendArray4",     5,   -1,         1,   {OPERAND_LVT4}},
      /* Lappend array element; array at op1>=256, value is top then elem */
    {"lappendArrayStk",   1,   -2,         0,   {OPERAND_NONE}},
      /* Lappend array element; value is stktop, then elem, array names */
    {"lappendStk",        1,   -1,         0,   {OPERAND_NONE}},
      /* Lappend general variable; value is stktop, then unparsed name */

    {"lindexMulti",       5,   INT_MIN,    1,   {OPERAND_UINT4}},
      /* Lindex with generalized args, operand is number of stacked objs
       * used: (operand-1) entries from stktop are the indices; then list to
       * process. */
    {"over",              5,   +1,         1,   {OPERAND_UINT4}},
      /* Duplicate the arg-th element from top of stack (TOS=0) */
    {"lsetList",          1,   -2,         0,   {OPERAND_NONE}},
      /* Four-arg version of 'lset'. stktop is old value; next is new
       * element value, next is the index list; pushes new value */
    {"lsetFlat",          5,   INT_MIN,    1,   {OPERAND_UINT4}},
      /* Three- or >=5-arg version of 'lset', operand is number of stacked
       * objs: stktop is old value, next is new element value, next come
       * (operand-2) indices; pushes the new value.
       */

    {"returnImm",   9,   -1,         2,   {OPERAND_INT4, OPERAND_UINT4}},
      /* Compiled [return], code, level are operands; options and result
       * are on the stack. */
    {"expon",             1,   -1,     0, {OPERAND_NONE}},
      /* Binary exponentiation operator: push (stknext ** stktop) */

    /*
     * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong -
     * but it cannot be done right at compile time, the stack effect is only
     * known at run time. The value for invokeExpanded is estimated better at
     * compile time.
     * See the comments further down in this file, where INST_INVOKE_EXPANDED
     * is emitted.
     */
    {"expandStart",       1,    0,          0,  {OPERAND_NONE}},
      /* Start of command with {*} (expanded) arguments */
    {"expandStkTop",      5,    0,          1,  {OPERAND_UINT4}},
      /* Expand the list at stacktop: push its elements on the stack */
    {"invokeExpanded",    1,    0,          0,  {OPERAND_NONE}},
      /* Invoke the command marked by the last 'expandStart' */

    {"listIndexImm",      5,  0,       1, {OPERAND_IDX4}},
      /* List Index:    push (lindex stktop op4) */
    {"listRangeImm",      9,  0,       2, {OPERAND_IDX4, OPERAND_IDX4}},
      /* List Range:    push (lrange stktop op4 op4) */
    {"startCommand",      9,  0,       2, {OPERAND_INT4,OPERAND_UINT4}},
      /* Start of bytecoded command: op is the length of the cmd's code, op2
       * is number of commands here */

    {"listIn",            1,  -1,      0, {OPERAND_NONE}},
      /* List containment: push [lsearch stktop stknext]>=0) */
    {"listNotIn",   1,  -1,      0, {OPERAND_NONE}},
      /* List negated containment: push [lsearch stktop stknext]<0) */

    {"pushReturnOpts",    1,  +1,      0, {OPERAND_NONE}},
      /* Push the interpreter's return option dictionary as an object on the
       * stack. */
    {"returnStk",   1,  -2,      0, {OPERAND_NONE}},
      /* Compiled [return]; options and result are on the stack, code and
       * level are in the options. */

    {"dictGet",           5,  INT_MIN,   1,     {OPERAND_UINT4}},
      /* The top op4 words (min 1) are a key path into the dictionary just
       * below the keys on the stack, and all those values are replaced by
       * the value read out of that key-path (like [dict get]).
       * Stack:  ... dict key1 ... keyN => ... value */
    {"dictSet",           9,  INT_MIN,   2,     {OPERAND_UINT4, OPERAND_LVT4}},
      /* Update a dictionary value such that the keys are a path pointing to
       * the value. op4#1 = numKeys, op4#2 = LVTindex
       * Stack:  ... key1 ... keyN value => ... newDict */
    {"dictUnset",   9,  INT_MIN,   2,     {OPERAND_UINT4, OPERAND_LVT4}},
      /* Update a dictionary value such that the keys are not a path pointing
       * to any value. op4#1 = numKeys, op4#2 = LVTindex
       * Stack:  ... key1 ... keyN => ... newDict */
    {"dictIncrImm",       9,  0,       2, {OPERAND_INT4, OPERAND_LVT4}},
      /* Update a dictionary value such that the value pointed to by key is
       * incremented by some value (or set to it if the key isn't in the
       * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex
       * Stack:  ... key => ... newDict */
    {"dictAppend",        5,  -1,      1, {OPERAND_LVT4}},
      /* Update a dictionary value such that the value pointed to by key has
       * some value string-concatenated onto it. op4 = LVTindex
       * Stack:  ... key valueToAppend => ... newDict */
    {"dictLappend",       5,  -1,      1, {OPERAND_LVT4}},
      /* Update a dictionary value such that the value pointed to by key has
       * some value list-appended onto it. op4 = LVTindex
       * Stack:  ... key valueToAppend => ... newDict */
    {"dictFirst",   5,  +2,      1, {OPERAND_LVT4}},
      /* Begin iterating over the dictionary, using the local scalar
       * indicated by op4 to hold the iterator state. If doneBool is true,
       * dictDone *must* be called later on.
       * Stack:  ... dict => ... value key doneBool */
    {"dictNext",    5,  +3,      1, {OPERAND_LVT4}},
      /* Get the next iteration from the iterator in op4's local scalar.
       * Stack:  ... => ... value key doneBool */
    {"dictDone",    5,  0,       1, {OPERAND_LVT4}},
      /* Terminate the iterator in op4's local scalar. */
    {"dictUpdateStart",   9,    0,     2, {OPERAND_LVT4, OPERAND_AUX4}},
      /* Create the variables (described in the aux data referred to by the
       * second immediate argument) to mirror the state of the dictionary in
       * the variable referred to by the first immediate argument. The list
       * of keys (popped from the stack) must be the same length as the list
       * of variables.
       * Stack:  ... keyList => ... */
    {"dictUpdateEnd",     9,    -1,    2, {OPERAND_LVT4, OPERAND_AUX4}},
      /* Reflect the state of local variables (described in the aux data
       * referred to by the second immediate argument) back to the state of
       * the dictionary in the variable referred to by the first immediate
       * argument. The list of keys (popped from the stack) must be the same
       * length as the list of variables.
       * Stack:  ... keyList => ... */
    {"jumpTable",   5,  -1,      1, {OPERAND_AUX4}},
      /* Jump according to the jump-table (in AuxData as indicated by the
       * operand) and the argument popped from the list. Always executes the
       * next instruction if no match against the table's entries was found.
       * Stack:  ... value => ...
       * Note that the jump table contains offsets relative to the PC when
       * it points to this instruction; the code is relocatable. */
    {"upvar",            5,     0,        1,   {OPERAND_LVT4}},
         /* finds level and otherName in stack, links to local variable at
        * index op1. Leaves the level on stack. */
    {"nsupvar",          5,     0,        1,   {OPERAND_LVT4}},
         /* finds namespace and otherName in stack, links to local variable at
        * index op1. Leaves the namespace on stack. */
    {"variable",         5,     0,        1,   {OPERAND_LVT4}},
         /* finds namespace and otherName in stack, links to local variable at
        * index op1. Leaves the namespace on stack. */
    {"syntax",           9,   -1,         2,    {OPERAND_INT4, OPERAND_UINT4}},
      /* Compiled bytecodes to signal syntax error. */
    {"reverse",          5,    0,         1,    {OPERAND_UINT4}},
      /* Reverse the order of the arg elements at the top of stack */

    {"regexp",           2,   -1,         1,    {OPERAND_INT1}},
      /* Regexp:  push (regexp stknext stktop) opnd == nocase */

    {"existScalar",      5,    1,         1,    {OPERAND_LVT4}},
      /* Test if scalar variable at index op1 in call frame exists */
    {"existArray",       5,    0,         1,    {OPERAND_LVT4}},
      /* Test if array element exists; array at slot op1, element is
       * stktop */
    {"existArrayStk",    1,    -1,        0,    {OPERAND_NONE}},
      /* Test if array element exists; element is stktop, array name is
       * stknext */
    {"existStk",   1,    0,         0,    {OPERAND_NONE}},
      /* Test if general variable exists; unparsed variable name is stktop*/
    {0}
};

/*
 * Prototypes for procedures defined later in this file:
 */

static void       DupByteCodeInternalRep(Tcl_Obj *srcPtr,
                      Tcl_Obj *copyPtr);
static unsigned char *  EncodeCmdLocMap(CompileEnv *envPtr,
                      ByteCode *codePtr, unsigned char *startPtr);
static void       EnterCmdExtentData(CompileEnv *envPtr,
                      int cmdNumber, int numSrcBytes, int numCodeBytes);
static void       EnterCmdStartData(CompileEnv *envPtr,
                      int cmdNumber, int srcOffset, int codeOffset);
static void       FreeByteCodeInternalRep(Tcl_Obj *objPtr);
static int        GetCmdLocEncodingSize(CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
static void       RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
static int        SetByteCodeFromAny(Tcl_Interp *interp,
                      Tcl_Obj *objPtr);
static int        FormatInstruction(ByteCode *codePtr,
                      unsigned char *pc, Tcl_Obj *bufferObj);
static void       PrintSourceToObj(Tcl_Obj *appendObj,
                      const char *stringPtr, int maxChars);
/*
 * TIP #280: Helper for building the per-word line information of all compiled
 * commands.
 */
static void       EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset,
                      Tcl_Token *tokenPtr, const char *cmd, int len,
                      int numWords, int line, int **lines);

/*
 * 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 */
    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(
    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. */
    register AuxData *auxDataPtr;
    LiteralEntry *entryPtr;
    register int i;
    int length, result = TCL_OK;
    const char *stringPtr;

#ifdef TCL_COMPILE_DEBUG
    if (!traceInitialized) {
      if (Tcl_LinkVar(interp, "tcl_traceCompile",
            (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
          Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
      }
      traceInitialized = 1;
    }
#endif

    stringPtr = TclGetStringFromObj(objPtr, &length);

    /*
     * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
     * use to initialize the tracking in the compiler. This information was
     * stored by TclCompEvalObj and ProcCompileProc.
     */

    TclInitCompileEnv(interp, &compEnv, stringPtr, length,
          iPtr->invokeCmdFramePtr, iPtr->invokeWord);
    TclCompileScript(interp, stringPtr, length, &compEnv);

    /*
     * Successful compilation. Add a "done" instruction at the end.
     */

    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);
      fflush(stdout);
    }
#endif /* TCL_COMPILE_DEBUG */

    if (result != TCL_OK) {
      /*
       * Handle any error from the hookProc
       */

      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++;
      }
    }

    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(
    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. */
{
    (void) TclSetByteCodeFromAny(interp, objPtr, NULL, (ClientData) NULL);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    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(
    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(
    register ByteCode *codePtr)     /* Points to the ByteCode to free. */
{
    Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
    Interp *iPtr = (Interp *) interp;
    int numLitObjects = codePtr->numLitObjects;
    int numAuxDataItems = codePtr->numAuxDataItems;
    register Tcl_Obj **objArrayPtr, *objPtr;
    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;

      Tcl_GetTime(&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, 3) free the
     * localCache if it is unused, and finally 4) 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.
     *
     * In order to insure a proper and efficient cleanup of the literal array
     * when it contains non-shared literals [Bug 983660], we also distinguish
     * the case of an interpreter being deleted (signaled by interp == NULL).
     * Also, as the interp deletion will remove the global literal table
     * anyway, we avoid the extra cost of updating it for each literal being
     * released.
     */

    if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) {

      objArrayPtr = codePtr->objArrayPtr;
      for (i = 0;  i < numLitObjects;  i++) {
          objPtr = *objArrayPtr;
          if (objPtr) {
            Tcl_DecrRefCount(objPtr);
          }
          objArrayPtr++;
      }
      codePtr->numLitObjects = 0;
    } else {
      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.
           */

          objPtr = *objArrayPtr;
          if (objPtr != NULL) {
            TclReleaseLiteral(interp, objPtr);
          }
          objArrayPtr++;
      }
    }

    auxDataPtr = codePtr->auxDataArrayPtr;
    for (i = 0;  i < numAuxDataItems;  i++) {
      if (auxDataPtr->type->freeProc != NULL) {
          (auxDataPtr->type->freeProc)(auxDataPtr->clientData);
      }
      auxDataPtr++;
    }

    /*
     * TIP #280. Release the location data associated with this byte code
     * structure, if any. NOTE: The interp we belong to may be gone already,
     * and the data with it.
     *
     * See also tclBasic.c, DeleteInterpProc
     */

    if (iPtr) {
      Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
            (char *) codePtr);
      if (hePtr) {
          ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
          int i;

          if (eclPtr->type == TCL_LOCATION_SOURCE) {
            Tcl_DecrRefCount(eclPtr->path);
          }
          for (i=0 ; i<eclPtr->nuloc ; i++) {
            ckfree((char *) eclPtr->loc[i].line);
          }

          if (eclPtr->loc != NULL) {
            ckfree((char *) eclPtr->loc);
          }

          ckfree((char *) eclPtr);
          Tcl_DeleteHashEntry(hePtr);
      }
    }

    if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
      TclFreeLocalCache(interp, codePtr->localCachePtr);
    }

    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(
    Tcl_Interp *interp,       /* The interpreter for which a CompileEnv
                         * structure is initialized. */
    register CompileEnv *envPtr,/* Points to the CompileEnv structure to
                         * initialize. */
    const char *stringPtr,    /* The source string to be compiled. */
    int numBytes,       /* Number of bytes in source string. */
    const CmdFrame *invoker,  /* Location context invoking the bcc */
    int word)                 /* Index of the word in that context getting
                         * compiled */
{
    Interp *iPtr = (Interp *) interp;

    envPtr->iPtr = iPtr;
    envPtr->source = stringPtr;
    envPtr->numSrcBytes = numBytes;
    envPtr->procPtr = iPtr->compiledProcPtr;
    envPtr->numCommands = 0;
    envPtr->exceptDepth = 0;
    envPtr->maxExceptDepth = 0;
    envPtr->maxStackDepth = 0;
    envPtr->currStackDepth = 0;
    TclInitLiteralTable(&(envPtr->localLitTable));

    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->atCmdStart = 1;

    /*
     * TIP #280: Set up the extended command location information, based on
     * the context invoking the byte code compiler. This structure is used to
     * keep the per-word line information for all compiled commands.
     *
     * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
     * non-compiling evaluator
     */

    envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc));
    envPtr->extCmdMapPtr->loc = NULL;
    envPtr->extCmdMapPtr->nloc = 0;
    envPtr->extCmdMapPtr->nuloc = 0;
    envPtr->extCmdMapPtr->path = NULL;

    if (invoker == NULL) {
        /*
       * Initialize the compiler for relative counting.
       */

      envPtr->line = 1;
      envPtr->extCmdMapPtr->type =
            (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
    } else {
        /*
       * Initialize the compiler using the context, making counting absolute
       * to that context. Note that the context can be byte code execution.
       * In that case we have to fill out the missing pieces (line, path,
       * ...) which may make change the type as well.
       */

      if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
          /*
           * Word is not a literal, relative counting.
           */

          envPtr->line = 1;
          envPtr->extCmdMapPtr->type =
                (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC);
      } else {
          CmdFrame *ctxPtr;
          int pc = 0;

          ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
          *ctxPtr = *invoker;

          if (invoker->type == TCL_LOCATION_BC) {
            /*
             * Note: Type BC => ctx.data.eval.path    is not used.
             *                  ctx.data.tebc.codePtr is used instead.
             */

            TclGetSrcInfoForPc(ctxPtr);
            pc = 1;
          }

          envPtr->line = ctxPtr->line[word];
          envPtr->extCmdMapPtr->type = ctxPtr->type;

          if (ctxPtr->type == TCL_LOCATION_SOURCE) {
            if (pc) {
                /*
                 * The reference 'TclGetSrcInfoForPc' made is transfered.
                 */

                envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path;
                ctxPtr->data.eval.path = NULL;
            } else {
                /*
                 * We have a new reference here.
                 */

                envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path;
                Tcl_IncrRefCount(envPtr->extCmdMapPtr->path);
            }
          }
          TclStackFree(interp, ctxPtr);
      }
    }

    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(
    register CompileEnv *envPtr)/* Points to the CompileEnv structure. */
{
    if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets) {
      ckfree((char *) envPtr->localLitTable.buckets);
      envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets;
    }
    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);
    }
    if (envPtr->extCmdMapPtr) {
      ckfree((char *) envPtr->extCmdMapPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * TclWordKnownAtCompileTime --
 *
 *    Test whether the value of a token is completely known at compile time.
 *
 * Results:
 *    Returns true if the tokenPtr argument points to a word value that is
 *    completely known at compile time. Generally, values that are known at
 *    compile time can be compiled to their values, while values that cannot
 *    be known until substitution at runtime must be compiled to bytecode
 *    instructions that perform that substitution. For several commands,
 *    whether or not arguments are known at compile time determine whether
 *    it is worthwhile to compile at all.
 *
 * Side effects:
 *    When returning true, appends the known value of the word to the
 *    unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL.
 *
 *----------------------------------------------------------------------
 */

int
TclWordKnownAtCompileTime(
    Tcl_Token *tokenPtr,      /* Points to Tcl_Token we should check */
    Tcl_Obj *valuePtr)        /* If not NULL, points to an unshared Tcl_Obj
                         * to which we should append the known value
                         * of the word. */
{
    int numComponents = tokenPtr->numComponents;
    Tcl_Obj *tempPtr = NULL;

    if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
      if (valuePtr != NULL) {
          Tcl_AppendToObj(valuePtr, tokenPtr[1].start, tokenPtr[1].size);
      }
      return 1;
    }
    if (tokenPtr->type != TCL_TOKEN_WORD) {
      return 0;
    }
    tokenPtr++;
    if (valuePtr != NULL) {
      tempPtr = Tcl_NewObj();
      Tcl_IncrRefCount(tempPtr);
    }
    while (numComponents--) {
      switch (tokenPtr->type) {
      case TCL_TOKEN_TEXT:
          if (tempPtr != NULL) {
            Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size);
          }
          break;

      case TCL_TOKEN_BS:
          if (tempPtr != NULL) {
            char utfBuf[TCL_UTF_MAX];
            int length = Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf);
            Tcl_AppendToObj(tempPtr, utfBuf, length);
          }
          break;

      default:
          if (tempPtr != NULL) {
            Tcl_DecrRefCount(tempPtr);
          }
          return 0;
      }
      tokenPtr++;
    }
    if (valuePtr != NULL) {
      Tcl_AppendObjToObj(valuePtr, tempPtr);
      Tcl_DecrRefCount(tempPtr);
    }
    return 1;
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Side effects:
 *    Adds instructions to envPtr to evaluate the script at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileScript(
    Tcl_Interp *interp,       /* Used for error and status reporting. Also
                         * serves as context for finding and compiling
                         * commands. May not be NULL. */
    const 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. */
    CompileEnv *envPtr)       /* Holds resulting instructions. */
{
    Interp *iPtr = (Interp *) interp;
    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;
    const char *p, *next;
    Namespace *cmdNsPtr;
    Command *cmdPtr;
    Tcl_Token *tokenPtr;
    int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
    int commandLength, objIndex;
    Tcl_DString ds;
    /* TIP #280 */
    ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
    int *wlines, wlineat, cmdLine;
    Tcl_Parse *parsePtr = (Tcl_Parse *)
          TclStackAlloc(interp, sizeof(Tcl_Parse));

    Tcl_DStringInit(&ds);

    if (numBytes < 0) {
      numBytes = strlen(script);
    }
    Tcl_ResetResult(interp);
    isFirstCmd = 1;

    if (envPtr->procPtr != NULL) {
      cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
    } else {
      cmdNsPtr = NULL;  /* use current NS */
    }

    /*
     * Each iteration through the following loop compiles the next command
     * from the script.
     */

    p = script;
    bytesLeft = numBytes;
    gotParse = 0;
    cmdLine = envPtr->line;
    do {
      if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
          /*
           * Compile bytecodes to report the parse error at runtime.
           */

          Tcl_LogCommandInfo(interp, script, parsePtr->commandStart,
                /* Drop the command terminator (";","]") if appropriate */
                (parsePtr->term ==
                parsePtr->commandStart + parsePtr->commandSize - 1)?
                parsePtr->commandSize - 1 : parsePtr->commandSize);
          TclCompileSyntaxError(interp, envPtr);
          break;
      }
      gotParse = 1;
      if (parsePtr->numWords > 0) {
          int expand = 0;     /* Set if there are dynamic expansions to
                         * handle */

          /*
           * 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);
            envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
                  (envPtr->codeNext - envPtr->codeStart)
                  - startCodeOffset;
          }

          /*
           * Determine the actual length of the command.
           */

          commandLength = parsePtr->commandSize;
          if (parsePtr->term == parsePtr->commandStart + commandLength - 1) {
            /*
             * The command terminator character (such as ; or ]) is the
             * last character in the parsed command. Reduce the length by
             * one so that the trace message doesn't include the
             * terminator character.
             */

            commandLength -= 1;
          }

#ifdef TCL_COMPILE_DEBUG
          /*
           * If tracing, print a line for each top level command compiled.
           */

          if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
            fprintf(stdout, "  Compiling: ");
            TclPrintSource(stdout, parsePtr->commandStart,
                  TclMin(commandLength, 55));
            fprintf(stdout, "\n");
          }
#endif

          /*
           * Check whether expansion has been requested for any of the
           * words.
           */

          for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
                wordIdx < parsePtr->numWords;
                wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
            if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
                expand = 1;
                break;
            }
          }

          envPtr->numCommands++;
          currCmdIndex = (envPtr->numCommands - 1);
          lastTopLevelCmdIndex = currCmdIndex;
          startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
          EnterCmdStartData(envPtr, currCmdIndex,
                parsePtr->commandStart - envPtr->source, startCodeOffset);

          /*
           * Should only start issuing instructions after the "command has
           * started" so that the command range is correct in the bytecode.
           */

          if (expand) {
            TclEmitOpcode(INST_EXPAND_START, envPtr);
          }

          /*
           * TIP #280. Scan the words and compute the extended location
           * information. The map first contain full per-word line
           * information for use by the compiler. This is later replaced by
           * a reduced form which signals non-literal words, stored in
           * 'wlines'.
           */

          TclAdvanceLines(&cmdLine, p, parsePtr->commandStart);
          EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
                parsePtr->tokenPtr, parsePtr->commandStart,
                parsePtr->commandSize, parsePtr->numWords, cmdLine,
                &wlines);
          wlineat = eclPtr->nuloc - 1;

          /*
           * Each iteration of the following loop compiles one word from the
           * command.
           */

          for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
                wordIdx < parsePtr->numWords; wordIdx++,
                tokenPtr += (tokenPtr->numComponents + 1)) {

            envPtr->line = eclPtr->loc[wlineat].line[wordIdx];
            if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
                /*
                 * The word is not a simple string of characters.
                 */

                TclCompileTokens(interp, tokenPtr+1,
                      tokenPtr->numComponents, envPtr);
                if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
                  TclEmitInstInt4(INST_EXPAND_STKTOP,
                        envPtr->currStackDepth, envPtr);
                }
                continue;
            }

            /*
             * This is a simple string of literal characters (i.e. we know
             * it absolutely and can use it directly). If this is the
             * first word and the command has a compile procedure, let it
             * compile the command.
             */

            if ((wordIdx == 0) && !expand) {
                /*
                 * 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)
                      && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
                      && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
                  int savedNumCmds = envPtr->numCommands;
                  unsigned savedCodeNext =
                        envPtr->codeNext - envPtr->codeStart;
                  int update = 0, code;

                  /*
                   * Mark the start of the command; the proper bytecode
                   * length will be updated later. There is no need to
                   * do this for the first bytecode in the compile env,
                   * as the check is done before calling
                   * TclExecuteByteCode(). Do emit an INST_START_CMD in
                   * special cases where the first bytecode is in a
                   * loop, to insure that the corresponding command is
                   * counted properly. Compilers for commands able to
                   * produce such a beast (currently 'while 1' only) set
                   * envPtr->atCmdStart to 0 in order to signal this
                   * case. [Bug 1752146]
                   *
                   * Note that the environment is initialised with
                   * atCmdStart=1 to avoid emitting ISC for the first
                   * command.
                   */

                  if (envPtr->atCmdStart) {
                      if (savedCodeNext != 0) {
                        /*
                         * Increase the number of commands being
                         * started at the current point. Note that
                         * this depends on the exact layout of the
                         * INST_START_CMD's operands, so be careful!
                         */

                        unsigned char *fixPtr = envPtr->codeNext - 4;

                        TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1,
                              fixPtr);
                      }
                  } else {
                      TclEmitInstInt4(INST_START_CMD, 0, envPtr);
                      TclEmitInt4(1, envPtr);
                      update = 1;
                  }

                  code = (cmdPtr->compileProc)(interp, parsePtr,
                        cmdPtr, envPtr);

                  if (code == TCL_OK) {
                      if (update) {
                        /*
                         * Fix the bytecode length.
                         */

                        unsigned char *fixPtr = envPtr->codeStart
                              + savedCodeNext + 1;
                        unsigned fixLen = envPtr->codeNext
                              - envPtr->codeStart - savedCodeNext;

                        TclStoreInt4AtPtr(fixLen, fixPtr);
                      }
                      goto finishCommand;
                  } else {
                      if (envPtr->atCmdStart && savedCodeNext != 0) {
                        /*
                         * Decrease the number of commands being
                         * started at the current point. Note that
                         * this depends on the exact layout of the
                         * INST_START_CMD's operands, so be careful!
                         */

                        unsigned char *fixPtr = envPtr->codeNext - 4;

                        TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1,
                              fixPtr);
                      }

                      /*
                       * Restore numCommands and codeNext to their
                       * correct values, removing any commands compiled
                       * before the failure to produce bytecode got
                       * reported. [Bugs 705406 and 735055]
                       */

                      envPtr->numCommands = savedNumCmds;
                      envPtr->codeNext = envPtr->codeStart+savedCodeNext;
                  }
                }

                /*
                 * No compile procedure so push the word. If the command
                 * was found, push a CmdName object to reduce runtime
                 * lookups. Avoid sharing this literal among different
                 * namespaces to reduce shimmering.
                 */

                objIndex = TclRegisterNewNSLiteral(envPtr,
                      tokenPtr[1].start, tokenPtr[1].size);
                if (cmdPtr != NULL) {
                  TclSetCmdNameObj(interp,
                        envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr);
                }
                if ((wordIdx == 0) && (parsePtr->numWords == 1)) {
                  /*
                   * Single word script: unshare the command name to
                   * avoid shimmering between bytecode and cmdName
                   * representations [Bug 458361]
                   */

                  TclHideLiteral(interp, envPtr, objIndex);
                }
            } else {
                objIndex = TclRegisterNewLiteral(envPtr,
                      tokenPtr[1].start, tokenPtr[1].size);
            }
            TclEmitPush(objIndex, envPtr);
          } /* for loop */

          /*
           * Emit an invoke instruction for the command. We skip this if a
           * compile procedure was found for the command.
           */

          if (expand) {
            /*
             * The stack depth during argument expansion can only be
             * managed at runtime, as the number of elements in the
             * expanded lists is not known at compile time. We adjust here
             * the stack depth estimate so that it is correct after the
             * command with expanded arguments returns.
             *
             * The end effect of this command's invocation is that all the
             * words of the command are popped from the stack, and the
             * result is pushed: the stack top changes by (1-wordIdx).
             *
             * Note that the estimates are not correct while the command
             * is being prepared and run, INST_EXPAND_STKTOP is not
             * stack-neutral in general.
             */

            TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr);
            TclAdjustStackDepth((1-wordIdx), envPtr);
          } else 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;

          /*
           * TIP #280: Free full form of per-word line data and insert the
           * reduced form now
           */

          ckfree((char *) eclPtr->loc[wlineat].line);
          eclPtr->loc[wlineat].line = wlines;
      } /* end if parsePtr->numWords > 0 */

      /*
       * Advance to the next command in the script.
       */

      next = parsePtr->commandStart + parsePtr->commandSize;
      bytesLeft -= next - p;
      p = next;

      /*
       * TIP #280: Track lines in the just compiled command.
       */

      TclAdvanceLines(&cmdLine, parsePtr->commandStart, p);
      Tcl_FreeParse(parsePtr);
      gotParse = 0;
    } while (bytesLeft > 0);

    /*
     * If the source script yielded no instructions (e.g., if it was empty),
     * push an empty string as the command's result.
     *
     * WARNING: push an unshared object! If the script being compiled is a
     * shared empty string, it will otherwise be self-referential and cause
     * difficulties with literal management [Bugs 467523, 983660]. We used to
     * have special code in TclReleaseLiteral to handle this particular
     * self-reference, but now opt for avoiding its creation altogether.
     */

    if (envPtr->codeNext == entryCodeNext) {
      TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr);
    }

    envPtr->numSrcBytes = (p - script);
    TclStackFree(interp, parsePtr);
    Tcl_DStringFree(&ds);
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Side effects:
 *    Instructions are added to envPtr to push and evaluate the tokens at
 *    runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileTokens(
    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];
    const char *name, *p;
    int numObjsToConcat, nameBytes, localVarName, localVar;
    int length, i;
    unsigned char *entryCodeNext = envPtr->codeNext;

    Tcl_DStringInit(&textBuffer);
    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, 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 = TclRegisterNewLiteral(envPtr,
                  Tcl_DStringValue(&textBuffer),
                  Tcl_DStringLength(&textBuffer));

            TclEmitPush(literal, envPtr);
            numObjsToConcat++;
            Tcl_DStringFree(&textBuffer);
          }

          TclCompileScript(interp, tokenPtr->start+1,
                tokenPtr->size-2, envPtr);
          numObjsToConcat++;
          break;

      case TCL_TOKEN_VARIABLE:
          /*
           * Push any accumulated chars appearing before the $<var>.
           */

          if (Tcl_DStringLength(&textBuffer) > 0) {
            int literal;

            literal = TclRegisterNewLiteral(envPtr,
                  Tcl_DStringValue(&textBuffer),
                  Tcl_DStringLength(&textBuffer));
            TclEmitPush(literal, envPtr);
            numObjsToConcat++;
            Tcl_DStringFree(&textBuffer);
          }

          /*
           * Determine how the variable name should be handled: if it
           * contains any namespace qualifiers it is not a local variable
           * (localVarName=-1); if it looks like an array element and the
           * token has a single component, it should not be created here
           * [Bug 569438] (localVarName=0); otherwise, the local variable
           * can safely be created (localVarName=1).
           */

          name = tokenPtr[1].start;
          nameBytes = tokenPtr[1].size;
          localVarName = -1;
          if (envPtr->procPtr != NULL) {
            localVarName = 1;
            for (i = 0, p = name;  i < nameBytes;  i++, p++) {
                if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) {
                  localVarName = -1;
                  break;
                } else if ((*p == '(')
                      && (tokenPtr->numComponents == 1)
                      && (*(name + nameBytes - 1) == ')')) {
                  localVarName = 0;
                  break;
                }
            }
          }

          /*
           * Either push the variable's name, or find its index in the array
           * of local variables in a procedure frame.
           */

          localVar = -1;
          if (localVarName != -1) {
            localVar = TclFindCompiledLocal(name, nameBytes, localVarName,
                  envPtr->procPtr);
          }
          if (localVar < 0) {
            TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
                  envPtr);
          }

          /*
           * 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 {
            TclCompileTokens(interp, tokenPtr+2,
                  tokenPtr->numComponents-1, envPtr);
            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);
            }
          }
          numObjsToConcat++;
          count -= tokenPtr->numComponents;
          tokenPtr += tokenPtr->numComponents;
          break;

      default:
          Tcl_Panic("Unexpected token type in TclCompileTokens");
      }
    }

    /*
     * Push any accumulated characters appearing at the end.
     */

    if (Tcl_DStringLength(&textBuffer) > 0) {
      int literal;

      literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer),
            Tcl_DStringLength(&textBuffer));
      TclEmitPush(literal, envPtr);
      numObjsToConcat++;
    }

    /*
     * 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(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    }
    Tcl_DStringFree(&textBuffer);
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the tokens at runtime.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileCmdWord(
    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. */
{
    if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
      /*
       * Handle the common case: if there is a single text token, compile it
       * into an inline sequence of instructions.
       */

      TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr);
    } else {
      /*
       * 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.
       */

      TclCompileTokens(interp, tokenPtr, count, envPtr);
      TclEmitOpcode(INST_EVAL_STK, envPtr);
    }
}

/*
 *----------------------------------------------------------------------
 *
 * 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.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute the expression.
 *
 *----------------------------------------------------------------------
 */

void
TclCompileExprWords(
    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 i, concatItems;

    /*
     * If the expression is a single word that doesn't require substitutions,
     * just compile its string into inline instructions.
     */

    if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
      TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr);
      return;
    }

    /*
     * 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++) {
      TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr);
      if (i < (numWords - 1)) {
          TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr);
      }
      wordPtr += (wordPtr->numComponents + 1);
    }
    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);
}

/*
 *----------------------------------------------------------------------
 *
 * TclCompileNoOp --
 *
 *    Function called to compile no-op's
 *
 * Results:
 *    The return value is TCL_OK, indicating successful compilation.
 *
 * Side effects:
 *    Instructions are added to envPtr to execute a no-op at runtime. No
 *      result is pushed onto the stack: the compiler has to take care of this
 *      itself if the last compiled command is a NoOp.
 *
 *----------------------------------------------------------------------
 */

int
TclCompileNoOp(
    Tcl_Interp *interp,       /* Used for error reporting. */
    Tcl_Parse *parsePtr,      /* Points to a parse structure for the command
                         * created by Tcl_ParseCommand. */
    Command *cmdPtr,          /* Points to defintion of command being
                         * compiled. */
    CompileEnv *envPtr)       /* Holds resulting instructions. */
{
    Tcl_Token *tokenPtr;
    int i;
    int savedStackDepth = envPtr->currStackDepth;

    tokenPtr = parsePtr->tokenPtr;
    for(i = 1; i < parsePtr->numWords; i++) {
      tokenPtr = tokenPtr + tokenPtr->numComponents + 1;
      envPtr->currStackDepth = savedStackDepth;

      if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
          TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
                envPtr);
          TclEmitOpcode(INST_POP, envPtr);
      }
    }
    envPtr->currStackDepth = savedStackDepth;
    TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
    return TCL_OK;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    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;
#ifdef TCL_COMPILE_DEBUG
    unsigned char *nextPtr;
#endif
    int numLitObjects = envPtr->literalArrayNext;
    Namespace *namespacePtr;
    int i, isNew;
    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;
    if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) {
      codePtr->flags = TCL_BYTECODE_RESOLVE_VARS;
    } else {
      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(p, 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(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes);
    } else {
      codePtr->exceptArrayPtr = NULL;
    }

    p += TCL_ALIGN(exceptArrayBytes);     /* align AuxData array */
    if (auxDataArrayBytes > 0) {
      codePtr->auxDataArrayPtr = (AuxData *) p;
      memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes);
    } else {
      codePtr->auxDataArrayPtr = NULL;
    }

    p += auxDataArrayBytes;
#ifndef TCL_COMPILE_DEBUG
    EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
#else
    nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
    if (((size_t)(nextPtr - p)) != cmdLocBytes) {
      Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d", (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));
    Tcl_GetTime(&(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.
     */

    TclFreeIntRep(objPtr);
    objPtr->internalRep.otherValuePtr = (void *) codePtr;
    objPtr->typePtr = &tclByteCodeType;

    /*
     * TIP #280. Associate the extended per-word line information with the
     * byte code object (internal rep), for use with the bc compiler.
     */

    Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr,
          &isNew), envPtr->extCmdMapPtr);
    envPtr->extCmdMapPtr = NULL;

    codePtr->localCachePtr = NULL;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    register const 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. */
    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 = 0;
      if (name == NULL) {
          localPtr->flags |= VAR_TEMPORARY;
      }
      localPtr->defValuePtr = NULL;
      localPtr->resolveInfo = NULL;

      if (name != NULL) {
          memcpy(localPtr->name, name, (size_t) nameBytes);
      }
      localPtr->name[nameBytes] = '\0';
      procPtr->numCompiledLocals++;
    }
    return localVar;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    void *envArgPtr)          /* Points to the CompileEnv whose code array
                         * must be enlarged. */
{
    CompileEnv *envPtr = (CompileEnv *) envArgPtr;
                        /* The CompileEnv containing the code array to
                         * be doubled in size. */

    /*
     * 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);

    if (envPtr->mallocedCodeArray) {
      envPtr->codeStart = (unsigned char *)
            ckrealloc((char *)envPtr->codeStart, newBytes);
    } else {
      /*
       * envPtr->codeStart isn't a ckalloc'd pointer, so we must
       * code a ckrealloc equivalent for ourselves.
       */
      unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
      memcpy(newPtr, envPtr->codeStart, currBytes);
      envPtr->codeStart = newPtr;
      envPtr->mallocedCodeArray = 1;
    }

    envPtr->codeNext = (envPtr->codeStart + currBytes);
    envPtr->codeEnd = (envPtr->codeStart + newBytes);
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    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)) {
      Tcl_Panic("EnterCmdStartData: bad command index %d", 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);

      if (envPtr->mallocedCmdMap) {
          envPtr->cmdMapPtr = (CmdLocation *)
                ckrealloc((char *) envPtr->cmdMapPtr, newBytes);
      } else {
          /*
           * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must
           * code a ckrealloc equivalent for ourselves.
           */
          CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
          memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
          envPtr->cmdMapPtr = newPtr;
          envPtr->mallocedCmdMap = 1;
      }
      envPtr->cmdMapEnd = newElems;
    }

    if (cmdIndex > 0) {
      if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
          Tcl_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(
    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)) {
      Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex);
    }

    if (cmdIndex > envPtr->cmdMapEnd) {
      Tcl_Panic("EnterCmdExtentData: missing start data for command %d",
            cmdIndex);
    }

    cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
    cmdLocPtr->numSrcBytes = numSrcBytes;
    cmdLocPtr->numCodeBytes = numCodeBytes;
}

/*
 *----------------------------------------------------------------------
 * TIP #280
 *
 * EnterCmdWordData --
 *
 *    Registers the lines for the words of a command. This information is
 *    used at runtime by 'info frame'.
 *
 * Results:
 *    None.
 *
 * Side effects:
 *    Inserts word location information into the compilation environment
 *    envPtr for the command at index cmdIndex. The compilation
 *    environment's ExtCmdLoc.ECL array is grown if necessary.
 *
 *----------------------------------------------------------------------
 */

static void
EnterCmdWordData(
    ExtCmdLoc *eclPtr,        /* Points to the map environment structure in
                         * which to enter command location
                         * information. */
    int srcOffset,            /* Offset of first char of the command. */
    Tcl_Token *tokenPtr,
    const char *cmd,
    int len,
    int numWords,
    int line,
    int **wlines)
{
    ECL *ePtr;
    const char *last;
    int wordIdx, wordLine, *wwlines;

    if (eclPtr->nuloc >= eclPtr->nloc) {
      /*
       * Expand the ECL array by allocating more storage from the heap. The
       * currently allocated ECL entries are stored from eclPtr->loc[0] up
       * to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
       */

      size_t currElems = eclPtr->nloc;
      size_t newElems = (currElems ? 2*currElems : 1);
      size_t newBytes = newElems * sizeof(ECL);

      eclPtr->loc = (ECL *) ckrealloc((char *)(eclPtr->loc), newBytes);
      eclPtr->nloc = newElems;
    }

    ePtr = &eclPtr->loc[eclPtr->nuloc];
    ePtr->srcOffset = srcOffset;
    ePtr->line = (int *) ckalloc(numWords * sizeof(int));
    ePtr->nline = numWords;
    wwlines = (int *) ckalloc(numWords * sizeof(int));

    last = cmd;
    wordLine = line;
    for (wordIdx=0 ; wordIdx<numWords;
          wordIdx++, tokenPtr += tokenPtr->numComponents + 1) {
        TclAdvanceLines(&wordLine, last, tokenPtr->start);
      wwlines[wordIdx] =
            (TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1);
      ePtr->line[wordIdx] = wordLine;
      last = tokenPtr->start;
    }

    *wlines = wwlines;
    eclPtr->nuloc ++;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    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);

      if (envPtr->mallocedExceptArray) {
          envPtr->exceptArrayPtr = (ExceptionRange *)
                ckrealloc((char *)(envPtr->exceptArrayPtr), newBytes);
      } else {
          /*
           * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
           * code a ckrealloc equivalent for ourselves.
           */
          ExceptionRange *newPtr = (ExceptionRange *)
                ckalloc((unsigned) newBytes);
          memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
          envPtr->exceptArrayPtr = newPtr;
          envPtr->mallocedExceptArray = 1;
      }
      envPtr->exceptArrayEnd = newElems;
    }
    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 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);

      if (envPtr->mallocedAuxDataArray) {
          envPtr->auxDataArrayPtr = (AuxData *)
                ckrealloc((char *)(envPtr->auxDataArrayPtr), newBytes);
      } else {
          /*
           * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
           * code a ckrealloc equivalent for ourselves.
           */
          AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
          memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
          envPtr->auxDataArrayPtr = newPtr;
          envPtr->mallocedAuxDataArray = 1;
      }
      envPtr->auxDataArrayEnd = newElems;
    }
    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(
    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(
    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);

    if (fixupArrayPtr->mallocedArray) {
      fixupArrayPtr->fixup = (JumpFixup *)
            ckrealloc((char *)(fixupArrayPtr->fixup), newBytes);
    } else {
      /*
       * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must
       * code a ckrealloc equivalent for ourselves.
       */
      JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
      memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
      fixupArrayPtr->fixup = newPtr;
      fixupArrayPtr->mallocedArray = 1;
    }
    fixupArrayPtr->end = newElems;
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    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(
    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(
    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 instr. */
    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 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);
    numBytes = envPtr->codeNext-jumpPc-2;
    p = jumpPc+2;
    memmove(p+3, p, numBytes);

    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:
          Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d",
                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 (&tclInstructionTable[0]).
 *
 * Side effects:
 *    None.
 *
 *----------------------------------------------------------------------
 */

void * /* == InstructionDesc* == */
TclGetInstructionTable(void)
{
    return &tclInstructionTable[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(
    AuxDataType *typePtr)     /* Information about object type; storage must
                         * be statically allocated (must live forever;
                         * will not be deallocated). */
{
    register Tcl_HashEntry *hPtr;
    int isNew;

    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 != NULL) {
      Tcl_DeleteHashEntry(hPtr);
    }

    /*
     * Now insert the new object type.
     */

    hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &isNew);
    if (isNew) {
      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(
    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 != 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(void)
{
    /*
     * The table mutex must already be held before this routine is invoked.
     */

    auxDataTypeTableInitialized = 1;
    Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);

    /*
     * There are only two AuxData type at this time, so register them here.
     */

    TclRegisterAuxDataType(&tclForeachInfoType);
    TclRegisterAuxDataType(&tclJumptableInfoType);
}

/*
 *----------------------------------------------------------------------
 *
 * 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(void)
{
    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(
    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) {
          Tcl_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) {
          Tcl_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) {
          Tcl_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(
    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) {
          Tcl_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) {
          Tcl_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) {
          Tcl_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(
    Tcl_Interp *interp,       /* Used only for Tcl_GetStringFromObj. */
    Tcl_Obj *objPtr)          /* The bytecode object to disassemble. */
{
    Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr);

    fprintf(stdout, "\n%s", TclGetString(bufPtr));
    Tcl_DecrRefCount(bufPtr);
}

/*
 *----------------------------------------------------------------------
 *
 * 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(
    ByteCode *codePtr,        /* Bytecode containing the instruction. */
    unsigned char *pc)        /* Points to first byte of instruction. */
{
    Tcl_Obj *bufferObj;
    int numBytes;

    TclNewObj(bufferObj);
    numBytes = FormatInstruction(codePtr, pc, bufferObj);
    fprintf(stdout, "%s", TclGetString(bufferObj));
    Tcl_DecrRefCount(bufferObj);
    return 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(
    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(
    FILE *outFile,            /* The file to print the source to. */
    const char *stringPtr,    /* The string to print. */
    int maxChars)       /* Maximum number of chars to print. */
{
    Tcl_Obj *bufferObj;

    TclNewObj(bufferObj);
    PrintSourceToObj(bufferObj, stringPtr, maxChars);
    fprintf(outFile, TclGetString(bufferObj));
    Tcl_DecrRefCount(bufferObj);
}
#endif /* TCL_COMPILE_DEBUG */

/*
 *----------------------------------------------------------------------
 *
 * TclDisassembleByteCodeObj --
 *
 *    Given an object which is of bytecode type, return a disassembled
 *    version of the bytecode (in a new refcount 0 object). No guarantees
 *    are made about the details of the contents of the result.
 *
 *----------------------------------------------------------------------
 */

Tcl_Obj *
TclDisassembleByteCodeObj(
    Tcl_Obj *objPtr)          /* The bytecode object to disassemble. */
{
    ByteCode *codePtr = 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;
    Tcl_Obj *bufferObj;
    char ptrBuf1[20], ptrBuf2[20];

    TclNewObj(bufferObj);
    if (codePtr->refCount <= 0) {
      return bufferObj; /* Already freed. */
    }

    codeStart = codePtr->codeStart;
    codeLimit = (codeStart + codePtr->numCodeBytes);
    numCmds = codePtr->numCommands;

    /*
     * Print header lines describing the ByteCode.
     */

    sprintf(ptrBuf1, "%p", codePtr);
    sprintf(ptrBuf2, "%p", iPtr);
    Tcl_AppendPrintfToObj(bufferObj,
          "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n",
          ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2,
          iPtr->compileEpoch);
    Tcl_AppendToObj(bufferObj, "  Source ", -1);
    PrintSourceToObj(bufferObj, codePtr->source,
          TclMin(codePtr->numSrcBytes, 55));
    Tcl_AppendPrintfToObj(bufferObj,
          "\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?
                codePtr->structureSize/(float)codePtr->numSrcBytes :
#endif
          0.0);

#ifdef TCL_COMPILE_STATS
    Tcl_AppendPrintfToObj(bufferObj,
          "  Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
          (unsigned long) codePtr->structureSize,
          (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)),
          codePtr->numCodeBytes,
          (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
          (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
          (unsigned long) (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;

      sprintf(ptrBuf1, "%p", procPtr);
      Tcl_AppendPrintfToObj(bufferObj,
            "  Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
            ptrBuf1, procPtr->refCount, procPtr->numArgs,
            numCompiledLocals);
      if (numCompiledLocals > 0) {
          CompiledLocal *localPtr = procPtr->firstLocalPtr;

          for (i = 0;  i < numCompiledLocals;  i++) {
            Tcl_AppendPrintfToObj(bufferObj,
                  "      slot %d%s%s%s%s%s%s", i,
                  (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", 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)) {
                Tcl_AppendToObj(bufferObj, "\n", -1);
            } else {
                Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
                      localPtr->name);
            }
            localPtr = localPtr->nextPtr;
          }
      }
    }

    /*
     * Print the ExceptionRange array.
     */

    if (codePtr->numExceptRanges > 0) {
      Tcl_AppendPrintfToObj(bufferObj, "  Exception ranges %d, depth %d:\n",
            codePtr->numExceptRanges, codePtr->maxExceptDepth);
      for (i = 0;  i < codePtr->numExceptRanges;  i++) {
          ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);

          Tcl_AppendPrintfToObj(bufferObj,
                "      %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:
            Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
                  rangePtr->continueOffset, rangePtr->breakOffset);
            break;
          case CATCH_EXCEPTION_RANGE:
            Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
                  rangePtr->catchOffset);
            break;
          default:
            Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
                  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) {
          Tcl_AppendToObj(bufferObj, "    ", -1);
          pc += FormatInstruction(codePtr, pc, bufferObj);
      }
      return bufferObj;
    }

    /*
     * Print table showing the code offset, source offset, and source length
     * for each command. These are encoded as a sequence of bytes.
     */

    Tcl_AppendPrintfToObj(bufferObj, "  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) *codeDeltaNext == (unsigned) 0xFF) {
          codeDeltaNext++;
          delta = TclGetInt4AtPtr(codeDeltaNext);
          codeDeltaNext += 4;
      } else {
          delta = TclGetInt1AtPtr(codeDeltaNext);
          codeDeltaNext++;
      }
      codeOffset += delta;

      if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
          codeLengthNext++;
          codeLen = TclGetInt4AtPtr(codeLengthNext);
          codeLengthNext += 4;
      } else {
          codeLen = TclGetInt1AtPtr(codeLengthNext);
          codeLengthNext++;
      }

      if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
          srcDeltaNext++;
          delta = TclGetInt4AtPtr(srcDeltaNext);
          srcDeltaNext += 4;
      } else {
          delta = TclGetInt1AtPtr(srcDeltaNext);
          srcDeltaNext++;
      }
      srcOffset += delta;

      if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
          srcLengthNext++;
          srcLen = TclGetInt4AtPtr(srcLengthNext);
          srcLengthNext += 4;
      } else {
          srcLen = TclGetInt1AtPtr(srcLengthNext);
          srcLengthNext++;
      }

      Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
            ((i % 2)? "       " : "\n   "),
            (i+1), codeOffset, (codeOffset + codeLen - 1),
            srcOffset, (srcOffset + srcLen - 1));
    }
    if (numCmds > 0) {
      Tcl_AppendToObj(bufferObj, "\n", -1);
    }

    /*
     * 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) *codeDeltaNext == (unsigned) 0xFF) {
          codeDeltaNext++;
          delta = TclGetInt4AtPtr(codeDeltaNext);
          codeDeltaNext += 4;
      } else {
          delta = TclGetInt1AtPtr(codeDeltaNext);
          codeDeltaNext++;
      }
      codeOffset += delta;

      if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
          srcDeltaNext++;
          delta = TclGetInt4AtPtr(srcDeltaNext);
          srcDeltaNext += 4;
      } else {
          delta = TclGetInt1AtPtr(srcDeltaNext);
          srcDeltaNext++;
      }
      srcOffset += delta;

      if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
          srcLengthNext++;
          srcLen = TclGetInt4AtPtr(srcLengthNext);
          srcLengthNext += 4;
      } else {
          srcLen = TclGetInt1AtPtr(srcLengthNext);
          srcLengthNext++;
      }

      /*
       * Print instructions before command i.
       */

      while ((pc-codeStart) < codeOffset) {
          Tcl_AppendToObj(bufferObj, "    ", -1);
          pc += FormatInstruction(codePtr, pc, bufferObj);
      }

      Tcl_AppendPrintfToObj(bufferObj, "  Command %d: ", i+1);
      PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
            TclMin(srcLen, 55));
      Tcl_AppendToObj(bufferObj, "\n", -1);
    }
    if (pc < codeLimit) {
      /*
       * Print instructions after the last command.
       */

      while (pc < codeLimit) {
          Tcl_AppendToObj(bufferObj, "    ", -1);
          pc += FormatInstruction(codePtr, pc, bufferObj);
      }
    }
    return bufferObj;
}

/*
 *----------------------------------------------------------------------
 *
 * FormatInstruction --
 *
 *    Appends a representation of a bytecode instruction to a Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

static int
FormatInstruction(
    ByteCode *codePtr,        /* Bytecode containing the instruction. */
    unsigned char *pc,        /* Points to first byte of instruction. */
    Tcl_Obj *bufferObj)       /* Object to append instruction info to. */
{
    Proc *procPtr = codePtr->procPtr;
    unsigned char opCode = *pc;
    register InstructionDesc *instDesc = &tclInstructionTable[opCode];
    unsigned char *codeStart = codePtr->codeStart;
    unsigned pcOffset = pc - codeStart;
    int opnd = 0, i, j, numBytes = 1;
    int localCt = procPtr ? procPtr->numCompiledLocals : 0;
    CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
    char suffixBuffer[128];   /* Additional info to print after main opcode
                         * and immediates. */
    char *suffixSrc = NULL;
    Tcl_Obj *suffixObj = NULL;
    AuxData *auxPtr = NULL;

    suffixBuffer[0] = '\0';
    Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
    for (i = 0;  i < instDesc->numOperands;  i++) {
      switch (instDesc->opTypes[i]) {
      case OPERAND_INT1:
          opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
          if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1
                || opCode == INST_JUMP_FALSE1) {
            sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
          }
          Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
          break;
      case OPERAND_INT4:
          opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
          if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4
                || opCode == INST_JUMP_FALSE4) {
            sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
          } else if (opCode == INST_START_CMD) {
            sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
          }
          Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
          break;
      case OPERAND_UINT1:
          opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
          if (opCode == INST_PUSH1) {
            suffixObj = codePtr->objArrayPtr[opnd];
          }
          Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
          break;
      case OPERAND_AUX4:
      case OPERAND_UINT4:
          opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
          if (opCode == INST_PUSH4) {
            suffixObj = codePtr->objArrayPtr[opnd];
          } else if (opCode == INST_START_CMD && opnd != 1) {
            sprintf(suffixBuffer+strlen(suffixBuffer),
                  ", %u cmds start here", opnd);
          }
          Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
          if (instDesc->opTypes[i] == OPERAND_AUX4) {
            auxPtr = &codePtr->auxDataArrayPtr[opnd];
          }
          break;
      case OPERAND_IDX4:
          opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
          if (opnd >= -1) {
            Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
          } else if (opnd == -2) {
            Tcl_AppendPrintfToObj(bufferObj, "end ");
          } else {
            Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
          }
          break;
      case OPERAND_LVT1:
          opnd = TclGetUInt1AtPtr(pc+numBytes);
          numBytes++;
          goto printLVTindex;
      case OPERAND_LVT4:
          opnd = TclGetUInt4AtPtr(pc+numBytes);
          numBytes += 4;
      printLVTindex:
          if (localPtr != NULL) {
            if (opnd >= localCt) {
                Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
                      (unsigned) opnd, localCt);
            }
            for (j = 0;  j < opnd;  j++) {
                localPtr = localPtr->nextPtr;
            }
            if (TclIsVarTemporary(localPtr)) {
                sprintf(suffixBuffer, "temp var %u", (unsigned) opnd);
            } else {
                sprintf(suffixBuffer, "var ");
                suffixSrc = localPtr->name;
            }
          }
          Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
          break;
      case OPERAND_NONE:
      default:
          break;
      }
    }
    if (suffixObj) {
      char *bytes;
      int length;

      Tcl_AppendToObj(bufferObj, "\t# ", -1);
      bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length);
      PrintSourceToObj(bufferObj, bytes, TclMin(length, 40));
    } else if (suffixBuffer[0]) {
      Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer);
      if (suffixSrc) {
          PrintSourceToObj(bufferObj, suffixSrc, 40);
      }
    }
    Tcl_AppendToObj(bufferObj, "\n", -1);
    if (auxPtr && auxPtr->type->printProc) {
      Tcl_AppendToObj(bufferObj, "\t\t[", -1);
      auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr,
            pcOffset);
      Tcl_AppendToObj(bufferObj, "]\n", -1);
    }
    return numBytes;
}

/*
 *----------------------------------------------------------------------
 *
 * PrintSourceToObj --
 *
 *    Appends a quoted representation of a string to a Tcl_Obj.
 *
 *----------------------------------------------------------------------
 */

static void
PrintSourceToObj(
    Tcl_Obj *appendObj,       /* The object to print the source to. */
    const char *stringPtr,    /* The string to print. */
    int maxChars)       /* Maximum number of chars to print. */
{
    register const char *p;
    register int i = 0;

    if (stringPtr == NULL) {
      Tcl_AppendToObj(appendObj, "\"\"", -1);
      return;
    }

    Tcl_AppendToObj(appendObj, "\"", -1);
    p = stringPtr;
    for (;  (*p != '\0') && (i < maxChars);  p++, i++) {
      switch (*p) {
      case '"':
          Tcl_AppendToObj(appendObj, "\\\"", -1);
          continue;
      case '\f':
          Tcl_AppendToObj(appendObj, "\\f", -1);
          continue;
      case '\n':
          Tcl_AppendToObj(appendObj, "\\n", -1);
          continue;
      case '\r':
          Tcl_AppendToObj(appendObj, "\\r", -1);
          continue;
      case '\t':
          Tcl_AppendToObj(appendObj, "\\t", -1);
          continue;
      case '\v':
          Tcl_AppendToObj(appendObj, "\\v", -1);
          continue;
      default:
          Tcl_AppendPrintfToObj(appendObj, "%c", *p);
          continue;
      }
    }
    Tcl_AppendToObj(appendObj, "\"", -1);
}

#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(
    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((int)(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 */

/*
 * Local Variables:
 * mode: c
 * c-basic-offset: 4
 * fill-column: 78
 * End:
 */

Generated by  Doxygen 1.6.0   Back to index