diff options
| author | dkf <donal.k.fellows@manchester.ac.uk> | 2005-07-14 10:50:08 (GMT) |
|---|---|---|
| committer | dkf <donal.k.fellows@manchester.ac.uk> | 2005-07-14 10:50:08 (GMT) |
| commit | d006a47d5d007d1b89e8c2118557e0ef08ac21d9 (patch) | |
| tree | 1542aa6547005ee0530a25b459ab64f7b6452acb | |
| parent | cadce06f20cd4c39398bb5e5640892ff743ca37c (diff) | |
| download | tcl-d006a47d5d007d1b89e8c2118557e0ef08ac21d9.zip tcl-d006a47d5d007d1b89e8c2118557e0ef08ac21d9.tar.gz tcl-d006a47d5d007d1b89e8c2118557e0ef08ac21d9.tar.bz2 | |
Style improvements to tclCompile.c, plus bytecode printing enhancements.
| -rw-r--r-- | ChangeLog | 7 | ||||
| -rw-r--r-- | generic/tclCompile.c | 1796 | ||||
| -rw-r--r-- | generic/tclCompile.h | 7 |
3 files changed, 892 insertions, 918 deletions
@@ -1,3 +1,10 @@ +2005-07-14 Donal K. Fellows <donal.k.fellows@manchester.ac.uk> + + * generic/tclCompile.c: Update to follow style guidelines. + (TclPrintInstruction): Reorganize to do better printing out of + bytecode with far fewer "special hacks" for particular opcodes. + * generic/tclCompile.h: Requires two new opcode types. + 2005-07-13 Don Porter <dgp@users.sourceforge.net> * unix/tclUnixSock.c: Use a ProcessGlobalValue to store the diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 5bb344c..72e99a2 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1,17 +1,17 @@ -/* +/* * 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"). + * 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. + * 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.87 2005/06/20 22:55:20 dkf Exp $ + * RCS: @(#) $Id: tclCompile.c,v 1.88 2005/07/14 10:50:25 dkf Exp $ */ #include "tclInt.h" @@ -20,7 +20,7 @@ /* * Table of all AuxData types. */ - + static Tcl_HashTable auxDataTypeTable; static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ @@ -42,10 +42,10 @@ static int traceInitialized = 0; /* * A table describing the Tcl bytecode instructions. Entries in this table - * must correspond to the instruction opcode definitions in tclCompile.h. - * The names "op1" and "op4" refer to an instruction's one or four byte - * first operand. Similarly, "stktop" and "stknext" refer to the topmost - * and next to topmost stack elements. + * 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 @@ -53,247 +53,247 @@ static int traceInitialized = 0; */ InstructionDesc tclInstructionTable[] = { - /* Name Bytes stackEffect #Opnds Operand types Stack top, next */ - {"done", 1, -1, 0, {OPERAND_NONE}}, + /* 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}}, + {"push1", 2, +1, 1, {OPERAND_UINT1}}, /* Push object at ByteCode objArray[op1] */ - {"push4", 5, +1, 1, {OPERAND_UINT4}}, + {"push4", 5, +1, 1, {OPERAND_UINT4}}, /* Push object at ByteCode objArray[op4] */ - {"pop", 1, -1, 0, {OPERAND_NONE}}, + {"pop", 1, -1, 0, {OPERAND_NONE}}, /* Pop the topmost stack object */ - {"dup", 1, +1, 0, {OPERAND_NONE}}, + {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ - {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ - {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, + {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ - {"evalStk", 1, 0, 0, {OPERAND_NONE}}, + {"evalStk", 1, 0, 0, {OPERAND_NONE}}, /* Evaluate command in stktop using Tcl_EvalObj. */ - {"exprStk", 1, 0, 0, {OPERAND_NONE}}, + {"exprStk", 1, 0, 0, {OPERAND_NONE}}, /* Execute expression in stktop using Tcl_ExprStringObj. */ - - {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}}, + + {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}}, /* Load scalar variable at index op1 <= 255 in call frame */ - {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}}, + {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}}, /* Load scalar variable at index op1 >= 256 in call frame */ - {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, + {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, /* Load scalar variable; scalar's name is stktop */ - {"loadArray1", 2, 0, 1, {OPERAND_UINT1}}, + {"loadArray1", 2, 0, 1, {OPERAND_LVT1}}, /* Load array element; array at slot op1<=255, element is stktop */ - {"loadArray4", 5, 0, 1, {OPERAND_UINT4}}, + {"loadArray4", 5, 0, 1, {OPERAND_LVT4}}, /* Load array element; array at slot op1 > 255, element is stktop */ - {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, + {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, /* Load array element; element is stktop, array name is stknext */ - {"loadStk", 1, 0, 0, {OPERAND_NONE}}, + {"loadStk", 1, 0, 0, {OPERAND_NONE}}, /* Load general variable; unparsed variable name is stktop */ - {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}}, + {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Store scalar variable at op1<=255 in frame; value is stktop */ - {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}}, + {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Store scalar variable at op1 > 255 in frame; value is stktop */ - {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, + {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Store scalar; value is stktop, scalar name is stknext */ - {"storeArray1", 2, -1, 1, {OPERAND_UINT1}}, + {"storeArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Store array element; array at op1<=255, value is top then elem */ - {"storeArray4", 5, -1, 1, {OPERAND_UINT4}}, + {"storeArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Store array element; array at op1>=256, value is top then elem */ - {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, + {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Store array element; value is stktop, then elem, array names */ - {"storeStk", 1, -1, 0, {OPERAND_NONE}}, + {"storeStk", 1, -1, 0, {OPERAND_NONE}}, /* Store general variable; value is stktop, then unparsed name */ - - {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}}, + + {"incrScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ - {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, + {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, /* Incr scalar; incr amount is stktop, scalar's name is stknext */ - {"incrArray1", 2, -1, 1, {OPERAND_UINT1}}, + {"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}}, + {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Incr array element; amount is top then elem then array names */ - {"incrStk", 1, -1, 0, {OPERAND_NONE}}, + {"incrStk", 1, -1, 0, {OPERAND_NONE}}, /* Incr general variable; amount is stktop then unparsed var name */ - {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}}, + {"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}}, + {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr scalar; scalar name is stktop; incr amount is op1 */ - {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}}, + {"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}}, + {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, /* Incr array element; elem is top then array name, amount is op1 */ - {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, + {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, /* Incr general variable; unparsed name is top, amount is op1 */ - - {"jump1", 2, 0, 1, {OPERAND_INT1}}, + + {"jump1", 2, 0, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) */ - {"jump4", 5, 0, 1, {OPERAND_INT4}}, + {"jump4", 5, 0, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) */ - {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is true */ - {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is true */ - {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, + {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, /* Jump relative to (pc + op1) if stktop expr object is false */ - {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, + {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, /* Jump relative to (pc + op4) if stktop expr object is false */ - {"lor", 1, -1, 0, {OPERAND_NONE}}, + {"lor", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ - {"land", 1, -1, 0, {OPERAND_NONE}}, + {"land", 1, -1, 0, {OPERAND_NONE}}, /* Logical and: push (stknext && stktop) */ - {"bitor", 1, -1, 0, {OPERAND_NONE}}, + {"bitor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise or: push (stknext | stktop) */ - {"bitxor", 1, -1, 0, {OPERAND_NONE}}, + {"bitxor", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise xor push (stknext ^ stktop) */ - {"bitand", 1, -1, 0, {OPERAND_NONE}}, + {"bitand", 1, -1, 0, {OPERAND_NONE}}, /* Bitwise and: push (stknext & stktop) */ - {"eq", 1, -1, 0, {OPERAND_NONE}}, + {"eq", 1, -1, 0, {OPERAND_NONE}}, /* Equal: push (stknext == stktop) */ - {"neq", 1, -1, 0, {OPERAND_NONE}}, + {"neq", 1, -1, 0, {OPERAND_NONE}}, /* Not equal: push (stknext != stktop) */ - {"lt", 1, -1, 0, {OPERAND_NONE}}, + {"lt", 1, -1, 0, {OPERAND_NONE}}, /* Less: push (stknext < stktop) */ - {"gt", 1, -1, 0, {OPERAND_NONE}}, + {"gt", 1, -1, 0, {OPERAND_NONE}}, /* Greater: push (stknext || stktop) */ - {"le", 1, -1, 0, {OPERAND_NONE}}, + {"le", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ - {"ge", 1, -1, 0, {OPERAND_NONE}}, + {"ge", 1, -1, 0, {OPERAND_NONE}}, /* Logical or: push (stknext || stktop) */ - {"lshift", 1, -1, 0, {OPERAND_NONE}}, + {"lshift", 1, -1, 0, {OPERAND_NONE}}, /* Left shift: push (stknext << stktop) */ - {"rshift", 1, -1, 0, {OPERAND_NONE}}, + {"rshift", 1, -1, 0, {OPERAND_NONE}}, /* Right shift: push (stknext >> stktop) */ - {"add", 1, -1, 0, {OPERAND_NONE}}, + {"add", 1, -1, 0, {OPERAND_NONE}}, /* Add: push (stknext + stktop) */ - {"sub", 1, -1, 0, {OPERAND_NONE}}, + {"sub", 1, -1, 0, {OPERAND_NONE}}, /* Sub: push (stkext - stktop) */ - {"mult", 1, -1, 0, {OPERAND_NONE}}, + {"mult", 1, -1, 0, {OPERAND_NONE}}, /* Multiply: push (stknext * stktop) */ - {"div", 1, -1, 0, {OPERAND_NONE}}, + {"div", 1, -1, 0, {OPERAND_NONE}}, /* Divide: push (stknext / stktop) */ - {"mod", 1, -1, 0, {OPERAND_NONE}}, + {"mod", 1, -1, 0, {OPERAND_NONE}}, /* Mod: push (stknext % stktop) */ - {"uplus", 1, 0, 0, {OPERAND_NONE}}, + {"uplus", 1, 0, 0, {OPERAND_NONE}}, /* Unary plus: push +stktop */ - {"uminus", 1, 0, 0, {OPERAND_NONE}}, + {"uminus", 1, 0, 0, {OPERAND_NONE}}, /* Unary minus: push -stktop */ - {"bitnot", 1, 0, 0, {OPERAND_NONE}}, + {"bitnot", 1, 0, 0, {OPERAND_NONE}}, /* Bitwise not: push ~stktop */ - {"not", 1, 0, 0, {OPERAND_NONE}}, + {"not", 1, 0, 0, {OPERAND_NONE}}, /* Logical not: push !stktop */ - {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, + {"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}}, + {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ - {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, + {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ - {"break", 1, 0, 0, {OPERAND_NONE}}, + {"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. */ + {"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_UINT4}}, + {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}}, /* Initialize execution of a foreach loop. Operand is aux data index * of the ForeachInfo structure for the foreach command. */ - {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, + {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, /* "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}}, + {"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}}, + {"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. */ + {"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}}, + {"streq", 1, -1, 0, {OPERAND_NONE}}, /* Str Equal: push (stknext eq stktop) */ - {"strneq", 1, -1, 0, {OPERAND_NONE}}, + {"strneq", 1, -1, 0, {OPERAND_NONE}}, /* Str !Equal: push (stknext neq stktop) */ - {"strcmp", 1, -1, 0, {OPERAND_NONE}}, + {"strcmp", 1, -1, 0, {OPERAND_NONE}}, /* Str Compare: push (stknext cmp stktop) */ - {"strlen", 1, 0, 0, {OPERAND_NONE}}, + {"strlen", 1, 0, 0, {OPERAND_NONE}}, /* Str Length: push (strlen stktop) */ - {"strindex", 1, -1, 0, {OPERAND_NONE}}, + {"strindex", 1, -1, 0, {OPERAND_NONE}}, /* Str Index: push (strindex stknext stktop) */ - {"strmatch", 2, -1, 1, {OPERAND_INT1}}, + {"strmatch", 2, -1, 1, {OPERAND_INT1}}, /* Str Match: push (strmatch stknext stktop) opnd == nocase */ - {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, + {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, /* List: push (stk1 stk2 ... stktop) */ - {"listIndex", 1, -1, 0, {OPERAND_NONE}}, + {"listIndex", 1, -1, 0, {OPERAND_NONE}}, /* List Index: push (listindex stknext stktop) */ - {"listLength", 1, 0, 0, {OPERAND_NONE}}, + {"listLength", 1, 0, 0, {OPERAND_NONE}}, /* List Len: push (listlength stktop) */ - {"appendScalar1", 2, 0, 1, {OPERAND_UINT1}}, + {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Append scalar variable at op1<=255 in frame; value is stktop */ - {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}}, + {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Append scalar variable at op1 > 255 in frame; value is stktop */ - {"appendArray1", 2, -1, 1, {OPERAND_UINT1}}, + {"appendArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Append array element; array at op1<=255, value is top then elem */ - {"appendArray4", 5, -1, 1, {OPERAND_UINT4}}, + {"appendArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Append array element; array at op1>=256, value is top then elem */ - {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Append array element; value is stktop, then elem, array names */ - {"appendStk", 1, -1, 0, {OPERAND_NONE}}, + {"appendStk", 1, -1, 0, {OPERAND_NONE}}, /* Append general variable; value is stktop, then unparsed name */ - {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}}, + {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}}, /* Lappend scalar variable at op1<=255 in frame; value is stktop */ - {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}}, + {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}}, /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ - {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}}, + {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}}, /* Lappend array element; array at op1<=255, value is top then elem */ - {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}}, + {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}}, /* Lappend array element; array at op1>=256, value is top then elem */ - {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, /* Lappend array element; value is stktop, then elem, array names */ - {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, + {"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 + {"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. + {"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. */ - {"return", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, - /* Compiled [return], code, level are operands; options and result - * are on the stack. */ + {"return", 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 + /* + * 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}}, + {"expandStart", 1, 0, 0, {OPERAND_NONE}}, /* Start of command with {expand}ed arguments */ - {"expandStkTop", 5, 0, 1, {OPERAND_INT4}}, + {"expandStkTop", 5, 0, 1, {OPERAND_INT4}}, /* Expand the list at stacktop: push its elements on the stack */ - {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, + {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, /* Invoke the command marked by the last 'expandStart' */ {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, @@ -301,7 +301,7 @@ InstructionDesc tclInstructionTable[] = { {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ {"startCommand", 5, 0, 1, {OPERAND_UINT4}}, - /* Start of bytecoded command: op is the length of the cmd's code */ + /* Start of bytecoded command: op is the length of the cmd's code */ {"listIn", 1, -1, 0, {OPERAND_NONE}}, /* List containment: push [lsearch stktop stknext]>=0) */ @@ -320,22 +320,17 @@ InstructionDesc tclInstructionTable[] = { static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, Tcl_Obj *copyPtr)); -static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( - CompileEnv *envPtr, ByteCode *codePtr, - unsigned char *startPtr)); -static void EnterCmdExtentData _ANSI_ARGS_(( - CompileEnv *envPtr, int cmdNumber, - int numSrcBytes, int numCodeBytes)); -static void EnterCmdStartData _ANSI_ARGS_(( - CompileEnv *envPtr, int cmdNumber, - int srcOffset, int codeOffset)); -static void FreeByteCodeInternalRep _ANSI_ARGS_(( - Tcl_Obj *objPtr)); +static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((CompileEnv *envPtr, + ByteCode *codePtr, unsigned char *startPtr)); +static void EnterCmdExtentData _ANSI_ARGS_((CompileEnv *envPtr, + int cmdNumber, int numSrcBytes, int numCodeBytes)); +static void EnterCmdStartData _ANSI_ARGS_((CompileEnv *envPtr, + int cmdNumber, int srcOffset, int codeOffset)); +static void FreeByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr)); static int GetCmdLocEncodingSize _ANSI_ARGS_(( CompileEnv *envPtr)); #ifdef TCL_COMPILE_STATS -static void RecordByteCodeStats _ANSI_ARGS_(( - ByteCode *codePtr)); +static void RecordByteCodeStats _ANSI_ARGS_((ByteCode *codePtr)); #endif /* TCL_COMPILE_STATS */ static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, Tcl_Obj *objPtr)); @@ -360,10 +355,9 @@ Tcl_ObjType tclByteCodeType = { * * 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. + * 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 @@ -372,17 +366,17 @@ Tcl_ObjType tclByteCodeType = { * * 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. + * compiled code is stored as "objPtr"s bytecode representation. Also, if + * debugging, initializes the "tcl_traceCompile" Tcl variable used to + * trace compilations. * *---------------------------------------------------------------------- */ int TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) - Tcl_Interp *interp; /* The interpreter for which the code is - * being compiled. Must not be NULL. */ + Tcl_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. */ @@ -390,8 +384,8 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) #ifdef TCL_COMPILE_DEBUG Interp *iPtr = (Interp *) interp; #endif /*TCL_COMPILE_DEBUG*/ - CompileEnv compEnv; /* Compilation environment structure - * allocated in frame. */ + CompileEnv compEnv; /* Compilation environment structure allocated + * in frame. */ LiteralTable *localTablePtr = &(compEnv.localLitTable); register AuxData *auxDataPtr; LiteralEntry *entryPtr; @@ -401,11 +395,11 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) #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; + 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 @@ -424,14 +418,14 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) */ if (hookProc) { - result = (*hookProc)(interp, &compEnv, clientData); + 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*/ @@ -439,10 +433,10 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); + TclPrintByteCodeObj(interp, objPtr); } #endif /* TCL_COMPILE_DEBUG */ - + if (result != TCL_OK) { /* * Handle any error from the hookProc @@ -466,11 +460,10 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) } } - /* * Free storage allocated during compilation. */ - + if (localTablePtr->buckets != localTablePtr->staticBuckets) { ckfree((char *) localTablePtr->buckets); } @@ -494,17 +487,17 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) * * 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. + * compiled code is stored as "objPtr"s bytecode representation. Also, + * if debugging, initializes the "tcl_traceCompile" Tcl variable used to + * trace compilations. * *---------------------------------------------------------------------- */ static int SetByteCodeFromAny(interp, objPtr) - Tcl_Interp *interp; /* The interpreter for which the code is - * being compiled. Must not be NULL. */ + Tcl_Interp *interp; /* The interpreter for which the code is being + * compiled. Must not be NULL. */ Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ { return TclSetByteCodeFromAny(interp, objPtr, @@ -516,8 +509,8 @@ SetByteCodeFromAny(interp, objPtr) * * DupByteCodeInternalRep -- * - * Part of the bytecode Tcl object type implementation. However, it - * does not copy the internal representation of a bytecode Tcl_Obj, but + * 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. * @@ -543,18 +536,17 @@ DupByteCodeInternalRep(srcPtr, copyPtr) * * 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. + * 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. + * 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. * *---------------------------------------------------------------------- */ @@ -563,8 +555,8 @@ static void FreeByteCodeInternalRep(objPtr) register Tcl_Obj *objPtr; /* Object whose internal rep to free. */ { - register ByteCode *codePtr = - (ByteCode *) objPtr->internalRep.otherValuePtr; + register ByteCode *codePtr = (ByteCode *) + objPtr->internalRep.otherValuePtr; codePtr->refCount--; if (codePtr->refCount <= 0) { @@ -587,9 +579,9 @@ FreeByteCodeInternalRep(objPtr) * 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. + * 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. * *---------------------------------------------------------------------- */ @@ -617,13 +609,13 @@ TclCleanupByteCode(codePtr) 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->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); @@ -631,9 +623,9 @@ TclCleanupByteCode(codePtr) if (lifetimeSec > 2000) { /* avoid overflow */ lifetimeSec = 2000; } - lifetimeMicroSec = - 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec); - + lifetimeMicroSec = 1000000 * lifetimeSec + + (destroyTime.usec - codePtr->createTime.usec); + log2 = TclLog2(lifetimeMicroSec); if (log2 > 31) { log2 = 31; @@ -643,28 +635,27 @@ TclCleanupByteCode(codePtr) #endif /* TCL_COMPILE_STATS */ /* - * A single heap object holds the ByteCode structure and its code, - * object, command location, and auxiliary data arrays. This means we - * only need to 1) decrement the ref counts of the LiteralEntry's in - * its literal array, 2) call the free procs for the auxiliary data - * items, and 3) free the ByteCode structure's heap object. + * A single heap object holds the ByteCode structure and its code, object, + * command location, and auxiliary data arrays. This means we only need to + * 1) decrement the ref counts of the LiteralEntry's in its literal array, + * 2) call the free procs for the auxiliary data items, and 3) free the + * ByteCode structure's heap object. * - * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, - * like those generated from tbcload) is special, as they doesn't - * make use of the global literal table. They instead maintain - * private references to their literals which must be decremented. + * 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. + * 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)) { - + if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { + objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { objPtr = *objArrayPtr; @@ -681,7 +672,7 @@ TclCleanupByteCode(codePtr) * 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); @@ -689,11 +680,11 @@ TclCleanupByteCode(codePtr) objArrayPtr++; } } - + auxDataPtr = codePtr->auxDataArrayPtr; for (i = 0; i < numAuxDataItems; i++) { if (auxDataPtr->type->freeProc != NULL) { - (*auxDataPtr->type->freeProc)(auxDataPtr->clientData); + (auxDataPtr->type->freeProc)(auxDataPtr->clientData); } auxDataPtr++; } @@ -729,7 +720,7 @@ TclInitCompileEnv(interp, envPtr, stringPtr, numBytes) int numBytes; /* Number of bytes in source string. */ { Interp *iPtr = (Interp *) interp; - + envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; @@ -750,16 +741,16 @@ TclInitCompileEnv(interp, envPtr, stringPtr, numBytes) envPtr->literalArrayNext = 0; envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; envPtr->mallocedLiteralArray = 0; - + envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; - + envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; - + envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; @@ -776,14 +767,14 @@ TclInitCompileEnv(interp, envPtr, stringPtr, numBytes) * * 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. + * 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. * *---------------------------------------------------------------------- */ @@ -814,21 +805,20 @@ TclFreeCompileEnv(envPtr) * * TclWordKnownAtCompileTime -- * - * Test whether the value of a token is completely known at compile - * time. + * 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. + * 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. + * When returning true, appends the known value of the word to the + * unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL. * *---------------------------------------------------------------------- */ @@ -859,26 +849,25 @@ TclWordKnownAtCompileTime(tokenPtr, valuePtr) } while (numComponents--) { switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - if (tempPtr != NULL) { - Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size); - } - break; + 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; + 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++; } @@ -909,9 +898,9 @@ TclWordKnownAtCompileTime(tokenPtr, valuePtr) void TclCompileScript(interp, script, numBytes, envPtr) - Tcl_Interp *interp; /* Used for error and status reporting. - * Also serves as context for finding and - * compiling commands. May not be NULL. */ + 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 @@ -922,10 +911,10 @@ TclCompileScript(interp, script, numBytes, envPtr) Tcl_Parse parse; int lastTopLevelCmdIndex = -1; /* Index of most recent toplevel command in - * the command location table. Initialized - * to avoid compiler warning. */ + * 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. */ + * code. Init. to avoid compiler warning. */ unsigned char *entryCodeNext = envPtr->codeNext; CONST char *p, *next; Namespace *cmdNsPtr; @@ -946,7 +935,7 @@ TclCompileScript(interp, script, numBytes, envPtr) if (envPtr->procPtr != NULL) { cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; } else { - cmdNsPtr = NULL; /* use current NS */ + cmdNsPtr = NULL; /* use current NS */ } /* @@ -973,9 +962,9 @@ TclCompileScript(interp, script, numBytes, envPtr) Tcl_IncrRefCount(errInfo); Tcl_AppendToObj(errInfo, "\n while executing\n\"", -1); TclAppendLimitedToObj(errInfo, parse.commandStart, - /* Drop the command terminator (";" or "]") if appropriate */ - (parse.term == parse.commandStart + parse.commandSize - 1) ? - parse.commandSize - 1 : parse.commandSize, 153, NULL); + /* Drop the command terminator (";","]") if appropriate */ + (parse.term == parse.commandStart + parse.commandSize - 1)? + parse.commandSize - 1 : parse.commandSize, 153, NULL); Tcl_AppendToObj(errInfo, "\"", -1); Tcl_ListObjAppendElement(NULL, returnCmd, errInfo); @@ -1024,19 +1013,19 @@ TclCompileScript(interp, script, numBytes, envPtr) commandLength = parse.commandSize; if (parse.term == parse.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. + * 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 tracing, print a line for each top level command compiled. + */ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { fprintf(stdout, " Compiling: "); @@ -1047,8 +1036,7 @@ TclCompileScript(interp, script, numBytes, envPtr) #endif /* - * Check whether expansion has been requested for any of - * the words + * Check whether expansion has been requested for any of the words */ for (wordIdx = 0, tokenPtr = parse.tokenPtr; @@ -1056,7 +1044,7 @@ TclCompileScript(interp, script, numBytes, envPtr) wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { expand = 1; - TclEmitOpcode(INST_EXPAND_START, envPtr); + TclEmitOpcode(INST_EXPAND_START, envPtr); break; } } @@ -1066,155 +1054,151 @@ TclCompileScript(interp, script, numBytes, envPtr) lastTopLevelCmdIndex = currCmdIndex; startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, - (parse.commandStart - envPtr->source), startCodeOffset); + (parse.commandStart - envPtr->source), startCodeOffset); /* - * Each iteration of the following loop compiles one word - * from the command. + * Each iteration of the following loop compiles one word from the + * command. */ - + for (wordIdx = 0, tokenPtr = parse.tokenPtr; wordIdx < parse.numWords; wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { /* - * If this is the first word and the command has a - * compile procedure, let it compile the command. + * The word is not a simple string of characters. */ - 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. - */ + TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, tokenPtr[1].start, - tokenPtr[1].size); + /* + * 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. + */ - cmdPtr = (Command *) Tcl_FindCommand(interp, - Tcl_DStringValue(&ds), - (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + 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. + */ - if ((cmdPtr != NULL) - && (cmdPtr->compileProc != NULL) - && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int savedNumCmds = envPtr->numCommands; - unsigned int savedCodeNext = - envPtr->codeNext - envPtr->codeStart; + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size); - /* - * Mark the start of the command; the proper - * bytecode length will be updated later. There - * is no need to do this for the first command - * in the compile env, as the check is done before - * calling TclExecuteByteCode(). Remark that we - * are compiling the first cmd in the environment - * exactly when (savedCodeNext == 0) - */ + cmdPtr = (Command *) Tcl_FindCommand(interp, + Tcl_DStringValue(&ds), + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); - if (savedCodeNext != 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - } - - code = (*(cmdPtr->compileProc))(interp, &parse, - envPtr); - - if (code == TCL_OK) { - if (savedCodeNext != 0) { - /* - * Fix the bytecode length. - */ - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned int fixLen = envPtr->codeNext - - envPtr->codeStart - - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } else { - /* - * 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; - } - } + if ((cmdPtr != NULL) + && (cmdPtr->compileProc != NULL) + && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + int savedNumCmds = envPtr->numCommands; + unsigned int savedCodeNext = + envPtr->codeNext - envPtr->codeStart; /* - * 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. + * Mark the start of the command; the proper bytecode + * length will be updated later. There is no need to + * do this for the first command in the compile env, + * as the check is done before calling + * TclExecuteByteCode(). Remark that we are compiling + * the first cmd in the environment exactly when + * (savedCodeNext == 0) */ - objIndex = TclRegisterNewNSLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr != NULL) { - TclSetCmdNameObj(interp, - envPtr->literalArrayPtr[objIndex].objPtr, - cmdPtr); + if (savedCodeNext != 0) { + TclEmitInstInt4(INST_START_CMD, 0, envPtr); } - if ((wordIdx == 0) && (parse.numWords == 1)) { + + code = (cmdPtr->compileProc)(interp, &parse, envPtr); + + if (code == TCL_OK) { + if (savedCodeNext != 0) { + /* + * Fix the bytecode length. + */ + unsigned char *fixPtr = envPtr->codeStart + + savedCodeNext + 1; + unsigned int fixLen = envPtr->codeNext + - envPtr->codeStart - savedCodeNext; + + TclStoreInt4AtPtr(fixLen, fixPtr); + } + goto finishCommand; + } else { /* - * Single word script: unshare the command name to - * avoid shimmering between bytecode and cmdName - * representations [Bug 458361] + * Restore numCommands and codeNext to their + * correct values, removing any commands compiled + * before the failure to produce bytecode got + * reported. [Bugs 705406 and 735055] */ - - TclHideLiteral(interp, envPtr, objIndex); + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart+savedCodeNext; } - } else { - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); } - TclEmitPush(objIndex, envPtr); - } else { + /* - * The word is not a simple string of characters. + * 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. */ - - TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - } - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); + + objIndex = TclRegisterNewNSLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (cmdPtr != NULL) { + TclSetCmdNameObj(interp, + envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); + } + if ((wordIdx == 0) && (parse.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); } /* - * Emit an invoke instruction for the command. We skip this - * if a compile procedure was found for the command. + * 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. + * 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); @@ -1225,7 +1209,7 @@ TclCompileScript(interp, script, numBytes, envPtr) } else { TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); } - } + } /* * Update the compilation environment structure and record the @@ -1241,7 +1225,7 @@ TclCompileScript(interp, script, numBytes, envPtr) /* * Advance to the next command in the script. */ - + next = parse.commandStart + parse.commandSize; bytesLeft -= (next - p); p = next; @@ -1259,11 +1243,11 @@ TclCompileScript(interp, script, numBytes, envPtr) * 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); Tcl_DStringFree(&ds); } @@ -1274,17 +1258,17 @@ TclCompileScript(interp, script, numBytes, envPtr) * 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. + * 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. + * Instructions are added to envPtr to push and evaluate the tokens at + * runtime. * *---------------------------------------------------------------------- */ @@ -1292,8 +1276,8 @@ TclCompileScript(interp, script, numBytes, envPtr) void TclCompileTokens(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * to compile. */ + 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. */ @@ -1310,130 +1294,124 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) 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_TEXT: + Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); + break; - case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, - buffer); - Tcl_DStringAppend(&textBuffer, buffer, length); - break; + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, buffer); + Tcl_DStringAppend(&textBuffer, buffer, length); + break; - case TCL_TOKEN_COMMAND: - /* - * Push any accumulated chars appearing before the command. - */ - - if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; - - literal = TclRegisterNewLiteral(envPtr, - Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); - TclEmitPush(literal, envPtr); - numObjsToConcat++; - Tcl_DStringFree(&textBuffer); - } - - TclCompileScript(interp, tokenPtr->start+1, - tokenPtr->size-2, envPtr); + case TCL_TOKEN_COMMAND: + /* + * Push any accumulated chars appearing before the command. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterNewLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer)); + TclEmitPush(literal, envPtr); numObjsToConcat++; - break; + Tcl_DStringFree(&textBuffer); + } - 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; - } + 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. - */ + /* + * 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, /*flags*/ 0, envPtr->procPtr); - } + localVar = -1; + if (localVarName != -1) { + localVar = TclFindCompiledLocal(name, nameBytes, localVarName, + /*flags*/ 0, envPtr->procPtr); + } + if (localVar < 0) { + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), + envPtr); + } + + /* + * Emit instructions to load the variable. + */ + + if (tokenPtr->numComponents == 1) { if (localVar < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), - envPtr); + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, 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 { - 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); - } + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); } - numObjsToConcat++; - count -= tokenPtr->numComponents; - tokenPtr += tokenPtr->numComponents; - break; + } + numObjsToConcat++; + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; - default: - Tcl_Panic("Unexpected token type in TclCompileTokens"); + default: + Tcl_Panic("Unexpected token type in TclCompileTokens"); } } @@ -1445,7 +1423,7 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) int literal; literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); + Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; } @@ -1465,10 +1443,9 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) /* * If the tokens yielded no instructions, push an empty string. */ - + if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), - envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); } Tcl_DStringFree(&textBuffer); } @@ -1481,13 +1458,13 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) * 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. + * 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. * @@ -1497,8 +1474,8 @@ TclCompileTokens(interp, tokenPtr, count, envPtr) void TclCompileCmdWord(interp, tokenPtr, count, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ - Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens - * for a command word to compile inline. */ + 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. */ @@ -1508,13 +1485,13 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) * 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. + * 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); @@ -1536,7 +1513,7 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) * 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. * @@ -1546,20 +1523,20 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr) void TclCompileExprWords(interp, tokenPtr, numWords, envPtr) Tcl_Interp *interp; /* Used for error and status reporting. */ - Tcl_Token *tokenPtr; /* Points to first in an array of word - * tokens tokens for the expression to - * compile inline. */ - int numWords; /* Number of word tokens starting at - * tokenPtr. Must be at least 1. Each word - * token contains one or more subtokens. */ + 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 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)) { @@ -1574,7 +1551,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) envPtr->numCommands = savedNumCmds; envPtr->codeNext = envPtr->codeStart + savedCodeNext; } - + /* * Emit code to call the expr command proc at runtime. Concatenate the * (already substituted once) expr tokens with a space between each. @@ -1584,8 +1561,7 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) for (i = 0; i < numWords; i++) { TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); if (i < (numWords - 1)) { - TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), - envPtr); + TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); } wordPtr += (wordPtr->numComponents + 1); } @@ -1606,10 +1582,10 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) * 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. + * 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 @@ -1617,19 +1593,19 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr) * * 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. + * and its code, object, command location, and aux data arrays. Note that + * "ownership" (i.e., the pointers to) the Tcl objects and aux data items + * will be handed over to the new ByteCode structure from the CompileEnv + * structure. * *---------------------------------------------------------------------- */ void TclInitByteCodeObj(objPtr, envPtr) - Tcl_Obj *objPtr; /* Points object that should be - * initialized, and whose string rep - * contains the source code. */ + 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. */ { @@ -1652,24 +1628,24 @@ TclInitByteCodeObj(objPtr, envPtr) 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(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; + namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; } else { - namespacePtr = envPtr->iPtr->globalNsPtr; + namespacePtr = envPtr->iPtr->globalNsPtr; } - + p = (unsigned char *) ckalloc((size_t) structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); @@ -1698,27 +1674,27 @@ TclInitByteCodeObj(objPtr, envPtr) p += sizeof(ByteCode); codePtr->codeStart = p; memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); - - p += TCL_ALIGN(codeBytes); /* align object array */ + + 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 */ + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr, - (size_t) exceptArrayBytes); + (size_t) exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } - - p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + + p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ if (auxDataArrayBytes > 0) { codePtr->auxDataArrayPtr = (AuxData *) p; memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, - (size_t) auxDataArrayBytes); + (size_t) auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } @@ -1728,11 +1704,11 @@ TclInitByteCodeObj(objPtr, envPtr) EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); - if (((size_t)(nextPtr - p)) != cmdLocBytes) { + if (((size_t)(nextPtr - p)) != cmdLocBytes) { Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); } #endif - + /* * Record various compilation-related statistics about the new ByteCode * structure. Don't include overhead for statistics-related fields. @@ -1742,16 +1718,15 @@ TclInitByteCodeObj(objPtr, envPtr) 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. + * 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; @@ -1771,26 +1746,25 @@ TclInitByteCodeObj(objPtr, envPtr) * 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. + * 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. + * Creates and registers a new local variable if create is 1 and the + * variable is unknown, or if the name is NULL. * *---------------------------------------------------------------------- */ int TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) - register CONST char *name; /* Points to first character of the name of - * a scalar or array variable. If NULL, a + 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. */ + int create; /* If 1, allocate a local frame entry for the + * variable if it is new. */ int flags; /* Flag bits for the compiled local if * created. Only VAR_SCALAR, VAR_ARRAY, and * VAR_LINK make sense. */ @@ -1806,14 +1780,14 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) * name already exist? */ - if (name != NULL) { + 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)) { + if ((nameBytes == localPtr->nameLength) && + (strncmp(name,localName,(unsigned)nameBytes) == 0)) { return i; } } @@ -1824,11 +1798,11 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) /* * Create a new variable if appropriate. */ - + if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + nameBytes+1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; @@ -1847,8 +1821,7 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) localPtr->resolveInfo = NULL; if (name != NULL) { - memcpy((VOID *) localPtr->name, (VOID *) name, - (size_t) nameBytes); + memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; @@ -1861,17 +1834,16 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) * * TclExpandCodeArray -- * - * Procedure that uses malloc to allocate more storage for a - * CompileEnv's code array. + * Procedure that uses malloc to allocate more storage for a CompileEnv's + * code array. * * Results: - * None. + * 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. + * 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. * *---------------------------------------------------------------------- */ @@ -1886,26 +1858,26 @@ TclExpandCodeArray(envArgPtr) /* * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined - * code bytes are stored between envPtr->codeStart and - * (envPtr->codeNext - 1) [inclusive]. + * 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); + size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); /* * Copy from old code array to new, free old code array if needed, and * mark new code array as malloced. */ - + memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); if (envPtr->mallocedCodeArray) { - ckfree((char *) envPtr->codeStart); + ckfree((char *) envPtr->codeStart); } envPtr->codeStart = newPtr; envPtr->codeNext = (newPtr + currBytes); - envPtr->codeEnd = (newPtr + newBytes); + envPtr->codeEnd = (newPtr + newBytes); envPtr->mallocedCodeArray = 1; } @@ -1914,17 +1886,17 @@ TclExpandCodeArray(envArgPtr) * * 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. + * 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. + * environment envPtr for the command at index cmdIndex. The compilation + * environment's CmdLocation array is grown if necessary. * *---------------------------------------------------------------------- */ @@ -1934,17 +1906,17 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex; /* Index of the command whose start data - * is being set. */ + int 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\n", cmdIndex); } - + if (cmdIndex >= envPtr->cmdMapEnd) { /* * Expand the command location array by allocating more storage from @@ -1953,16 +1925,16 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) */ size_t currElems = envPtr->cmdMapEnd; - size_t newElems = 2*currElems; + size_t newElems = 2*currElems; size_t currBytes = currElems * sizeof(CmdLocation); - size_t newBytes = newElems * sizeof(CmdLocation); + size_t newBytes = newElems * sizeof(CmdLocation); CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); - + /* * Copy from old command location array to new, free old command * location array if needed, and mark new array as malloced. */ - + memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes); if (envPtr->mallocedCmdMap) { ckfree((char *) envPtr->cmdMapPtr); @@ -1999,9 +1971,9 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) * * 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. + * environment envPtr for the command at index cmdIndex. Starting source + * and bytecode information for the command must already have been + * registered. * *---------------------------------------------------------------------- */ @@ -2011,8 +1983,8 @@ EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex; /* Index of the command whose source and - * code length data is being set. */ + int 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. */ { @@ -2021,10 +1993,10 @@ EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { Tcl_Panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); } - + if (cmdIndex > envPtr->cmdMapEnd) { Tcl_Panic("EnterCmdExtentData: missing start data for command %d\n", - cmdIndex); + cmdIndex); } cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); @@ -2044,11 +2016,10 @@ EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) * 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. + * 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. * *---------------------------------------------------------------------- */ @@ -2056,34 +2027,32 @@ EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) int TclCreateExceptRange(type, envPtr) ExceptionRangeType type; /* The kind of ExceptionRange desired. */ - register CompileEnv *envPtr;/* Points to CompileEnv for which to - * create a new ExceptionRange structure. */ + register 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); + envPtr->exceptArrayNext * sizeof(ExceptionRange); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); ExceptionRange *newPtr = (ExceptionRange *) - ckalloc((unsigned) newBytes); - + ckalloc((unsigned) newBytes); + /* - * Copy from old ExceptionRange array to new, free old - * ExceptionRange array if needed, and mark the new ExceptionRange - * array as malloced. + * Copy from old ExceptionRange array to new, free old ExceptionRange + * array if needed, and mark the new ExceptionRange array as malloced. */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, - currBytes); + + memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, currBytes); if (envPtr->mallocedExceptArray) { ckfree((char *) envPtr->exceptArrayPtr); } @@ -2092,7 +2061,7 @@ TclCreateExceptRange(type, envPtr) envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayNext++; - + rangePtr = &(envPtr->exceptArrayPtr[index]); rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; @@ -2109,8 +2078,8 @@ TclCreateExceptRange(type, envPtr) * * TclCreateAuxData -- * - * Procedure that allocates and initializes a new AuxData structure in - * a CompileEnv's array of compilation auxiliary data records. These + * 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. * @@ -2118,47 +2087,47 @@ TclCreateExceptRange(type, envPtr) * 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. + * If there is not enough room in the CompileEnv's AuxData array, the + * AuxData array in expanded: a new array of double the size is + * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array + * is freed, and AuxData entries are copied from the old array to the new + * one. * *---------------------------------------------------------------------- */ int TclCreateAuxData(clientData, typePtr, envPtr) - ClientData clientData; /* The compilation auxiliary data to store - * in the new aux data record. */ - AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ + ClientData clientData; /* The compilation auxiliary data to store in + * the new aux data record. */ + AuxDataType *typePtr; /* Pointer to the type to attach to this + * AuxData */ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { int index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; /* Points to the new AuxData structure */ - + index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { - /* + /* * Expand the AuxData array. The currently allocated entries are * stored between elements 0 and (envPtr->auxDataArrayNext - 1) * [inclusive]. */ - + size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); int newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); - + /* * Copy from old AuxData array to new, free old AuxData array if * needed, and mark the new AuxData array as malloced. */ - - memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, - currBytes); + + memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, currBytes); if (envPtr->mallocedAuxDataArray) { ckfree((char *) envPtr->auxDataArrayPtr); } @@ -2167,7 +2136,7 @@ TclCreateAuxData(clientData, typePtr, envPtr) envPtr->mallocedAuxDataArray = 1; } envPtr->auxDataArrayNext++; - + auxDataPtr = &(envPtr->auxDataArrayPtr[index]); auxDataPtr->clientData = clientData; auxDataPtr->type = typePtr; @@ -2179,8 +2148,8 @@ TclCreateAuxData(clientData, typePtr, envPtr) * * TclInitJumpFixupArray -- * - * Initializes a JumpFixupArray structure to hold some number of - * jump fixup entries. + * Initializes a JumpFixupArray structure to hold some number of jump + * fixup entries. * * Results: * None. @@ -2194,8 +2163,8 @@ TclCreateAuxData(clientData, typePtr, envPtr) void TclInitJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to initialize. */ + /* Points to the JumpFixupArray structure to + * initialize. */ { fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; fixupArrayPtr->next = 0; @@ -2208,8 +2177,8 @@ TclInitJumpFixupArray(fixupArrayPtr) * * TclExpandJumpFixupArray -- * - * Procedure that uses malloc to allocate more storage for a - * jump fixup array. + * Procedure that uses malloc to allocate more storage for a jump fixup + * array. * * Results: * None. @@ -2217,8 +2186,8 @@ TclInitJumpFixupArray(fixupArrayPtr) * 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. + * the old array is freed. Jump fixup structures are copied from the old + * array to the new one. * *---------------------------------------------------------------------- */ @@ -2226,12 +2195,12 @@ TclInitJumpFixupArray(fixupArrayPtr) void TclExpandJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to enlarge. */ + /* 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 + * 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. */ @@ -2241,10 +2210,10 @@ TclExpandJumpFixupArray(fixupArrayPtr) JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); /* - * Copy from the old array to new, free the old array if needed, - * and mark the new array as malloced. + * Copy from the old array to new, free the old array if needed, and mark + * the new array as malloced. */ - + memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); @@ -2273,8 +2242,8 @@ TclExpandJumpFixupArray(fixupArrayPtr) void TclFreeJumpFixupArray(fixupArrayPtr) register JumpFixupArray *fixupArrayPtr; - /* Points to the JumpFixupArray structure - * to free. */ + /* Points to the JumpFixupArray structure to + * free. */ { if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); @@ -2289,16 +2258,16 @@ TclFreeJumpFixupArray(fixupArrayPtr) * 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. + * 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. + * 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. * *---------------------------------------------------------------------- */ @@ -2317,15 +2286,15 @@ TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) * 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. + * - 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); @@ -2344,24 +2313,23 @@ TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) * * 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. + * 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. + * 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. + * 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. * *---------------------------------------------------------------------- */ @@ -2372,15 +2340,14 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) * holds the resulting instruction. */ JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that * describes the forward jump. */ - int jumpDist; /* Jump distance to set in jump - * instruction. */ - int distThreshold; /* Maximum distance before the two byte - * jump is grown to five bytes. */ + 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 int numBytes; - + if (jumpDist <= distThreshold) { jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); switch (jumpFixupPtr->jumpType) { @@ -2398,14 +2365,14 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) } /* - * 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. + * 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); + TclExpandCodeArray(envPtr); } jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; @@ -2425,26 +2392,26 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) 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. + * 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); + 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); + 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; @@ -2457,7 +2424,7 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) break; default: Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d\n", - rangePtr->type); + rangePtr->type); } } return 1; /* the jump was grown */ @@ -2468,9 +2435,9 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) * * 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. + * 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 @@ -2493,32 +2460,32 @@ TclGetInstructionTable() * * TclRegisterAuxDataType -- * - * This procedure is called to register a new AuxData type - * in the table of all AuxData types supported by Tcl. + * 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. + * a type with the same name as in typePtr, it is replaced with the new + * type. * *-------------------------------------------------------------- */ void TclRegisterAuxDataType(typePtr) - AuxDataType *typePtr; /* Information about object type; - * storage must be statically - * allocated (must live forever). */ + AuxDataType *typePtr; /* Information about object type; storage must + * be statically allocated (must live + * forever). */ { register Tcl_HashEntry *hPtr; int new; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); + TclInitAuxDataTypeTable(); } /* @@ -2527,7 +2494,7 @@ TclRegisterAuxDataType(typePtr) hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); if (hPtr != (Tcl_HashEntry *) NULL) { - Tcl_DeleteHashEntry(hPtr); + Tcl_DeleteHashEntry(hPtr); } /* @@ -2536,7 +2503,7 @@ TclRegisterAuxDataType(typePtr) hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); if (new) { - Tcl_SetHashValue(hPtr, typePtr); + Tcl_SetHashValue(hPtr, typePtr); } Tcl_MutexUnlock(&tableMutex); } @@ -2567,12 +2534,12 @@ TclGetAuxDataType(typeName) Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); + TclInitAuxDataTypeTable(); } hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); if (hPtr != (Tcl_HashEntry *) NULL) { - typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); @@ -2584,8 +2551,8 @@ TclGetAuxDataType(typeName) * * TclInitAuxDataTypeTable -- * - * This procedure is invoked to perform once-only initialization of - * the AuxData type table. It also registers the AuxData types defined in + * 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: @@ -2620,10 +2587,10 @@ TclInitAuxDataTypeTable() * * 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(). + * 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. @@ -2639,8 +2606,8 @@ TclFinalizeAuxDataTypeTable() { Tcl_MutexLock(&tableMutex); if (auxDataTypeTableInitialized) { - Tcl_DeleteHashTable(&auxDataTypeTable); - auxDataTypeTableInitialized = 0; + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); } @@ -2664,17 +2631,17 @@ TclFinalizeAuxDataTypeTable() static int GetCmdLocEncodingSize(envPtr) - CompileEnv *envPtr; /* Points to compilation environment - * structure containing the CmdLocation - * structure to encode. */ + 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. */ + * sequences where the next encoded offset or + * length should go. */ int prevCodeOffset, prevSrcOffset, i; codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; @@ -2725,8 +2692,8 @@ GetCmdLocEncodingSize(envPtr) * * EncodeCmdLocMap -- * - * Encode the command location information for some compiled code into - * a ByteCode structure. The encoded command location map is stored as + * 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: @@ -2734,30 +2701,30 @@ GetCmdLocEncodingSize(envPtr) * 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. + * The encoded information is stored into the block of memory headed by + * codePtr. Also records pointers to the start of the four byte sequences + * in fields in codePtr's ByteCode header structure. * *---------------------------------------------------------------------- */ static unsigned char * EncodeCmdLocMap(envPtr, codePtr, startPtr) - CompileEnv *envPtr; /* Points to compilation environment - * structure containing the CmdLocation - * structure to encode. */ - ByteCode *codePtr; /* ByteCode in which to encode envPtr's + 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. */ + 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. */ @@ -2839,7 +2806,7 @@ EncodeCmdLocMap(envPtr, codePtr, startPtr) p += 4; } } - + return p; } @@ -2849,8 +2816,8 @@ EncodeCmdLocMap(envPtr, codePtr, startPtr) * * TclPrintByteCodeObj -- * - * This procedure prints ("disassembles") the instructions of a - * bytecode object to stdout. + * This procedure prints ("disassembles") the instructions of a bytecode + * object to stdout. * * Results: * None. @@ -2897,11 +2864,11 @@ TclPrintByteCodeObj(interp, objPtr) codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - (codePtr->numSrcBytes? - ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); -#else - 0.0); + codePtr->numSrcBytes? + codePtr->structureSize/(float)codePtr->numSrcBytes : #endif + 0.0); + #ifdef TCL_COMPILE_STATS fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", @@ -2913,34 +2880,34 @@ TclPrintByteCodeObj(interp, objPtr) (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ - + /* * If the ByteCode is the compiled body of a Tcl procedure, print * information about that procedure. Note that we don't know the * procedure's name since ByteCode's can be shared among procedures. */ - + if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; fprintf(stdout, - " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; for (i = 0; i < numCompiledLocals; i++) { - fprintf(stdout, " slot %d%s%s%s%s%s%s", i, - ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), - ((localPtr->flags & VAR_ARRAY)? ", array" : ""), - ((localPtr->flags & VAR_LINK)? ", link" : ""), - ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), - ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), - ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); + fprintf(stdout, " slot %d%s%s%s%s%s%s", i, + (localPtr->flags & VAR_SCALAR) ? ", scalar" : "", + (localPtr->flags & VAR_ARRAY) ? ", array" : "", + (localPtr->flags & VAR_LINK) ? ", link" : "", + (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", + (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", + (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "\n"); + fprintf(stdout, "\n"); } else { - fprintf(stdout, ", \"%s\"\n", localPtr->name); + fprintf(stdout, ", \"%s\"\n", localPtr->name); } localPtr = localPtr->nextPtr; } @@ -2953,33 +2920,32 @@ TclPrintByteCodeObj(interp, objPtr) if (codePtr->numExceptRanges > 0) { fprintf(stdout, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); + codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", i, rangePtr->nestingLevel, - ((rangePtr->type == LOOP_EXCEPTION_RANGE) - ? "loop" : "catch"), + (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: fprintf(stdout, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); + rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: fprintf(stdout, "catch %d\n", rangePtr->catchOffset); break; default: Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", - rangePtr->type); + rangePtr->type); } } } - + /* - * If there were no commands (e.g., an expression or an empty string - * was compiled), just print all instructions and return. + * If there were no commands (e.g., an expression or an empty string was + * compiled), just print all instructions and return. */ if (numCmds == 0) { @@ -2990,16 +2956,16 @@ TclPrintByteCodeObj(interp, objPtr) } return; } - + /* - * Print table showing the code offset, source offset, and source - * length for each command. These are encoded as a sequence of bytes. + * Print table showing the code offset, source offset, and source length + * for each command. These are encoded as a sequence of bytes. */ fprintf(stdout, " Commands %d:", numCmds); codeDeltaNext = codePtr->codeDeltaStart; codeLengthNext = codePtr->codeLengthStart; - srcDeltaNext = codePtr->srcDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { @@ -3021,7 +2987,7 @@ TclPrintByteCodeObj(interp, objPtr) codeLen = TclGetInt1AtPtr(codeLengthNext); codeLengthNext++; } - + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); @@ -3040,7 +3006,7 @@ TclPrintByteCodeObj(interp, objPtr) srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } - + fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), @@ -3049,15 +3015,15 @@ TclPrintByteCodeObj(interp, objPtr) if (numCmds > 0) { fprintf(stdout, "\n"); } - + /* - * Print each instruction. If the instruction corresponds to the start - * of a command, print the command's source. Note that we don't need - * the code length here. + * 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; + srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; pc = codeStart; @@ -3094,7 +3060,7 @@ TclPrintByteCodeObj(interp, objPtr) /* * Print instructions before command i. */ - + while ((pc-codeStart) < codeOffset) { fprintf(stdout, " "); pc += TclPrintInstruction(codePtr, pc); @@ -3102,7 +3068,7 @@ TclPrintByteCodeObj(interp, objPtr) fprintf(stdout, " Command %d: ", (i+1)); TclPrintSource(stdout, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); + TclMin(srcLen, 55)); fprintf(stdout, "\n"); } if (pc < codeLimit) { @@ -3116,16 +3082,14 @@ TclPrintByteCodeObj(interp, objPtr) } } } -#endif /* TCL_COMPILE_DEBUG */ -#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * TclPrintInstruction -- * - * This procedure prints ("disassembles") one instruction from a - * bytecode object to stdout. + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. * * Results: * Returns the length in bytes of the current instruiction. @@ -3147,89 +3111,50 @@ TclPrintInstruction(codePtr, pc) unsigned char *codeStart = codePtr->codeStart; unsigned int pcOffset = (pc - codeStart); int opnd, i, j, numBytes = 1; - + int localCt = procPtr ? procPtr->numCompiledLocals : 0; + CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; + + char suffixBuffer[64]; /* Additional info to print after main opcode + * and immediates. */ + char *suffixSrc = NULL; + Tcl_Obj *suffixObj = NULL; + + suffixBuffer[0] = '\0'; fprintf(stdout, "(%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 ((i == 0) && ((opCode == INST_JUMP1) - || (opCode == INST_JUMP_TRUE1) - || (opCode == INST_JUMP_FALSE1))) { - fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); - } else { - fprintf(stdout, "%d ", opnd); + if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 + || opCode == INST_JUMP_FALSE1) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } + fprintf(stdout, "%+d ", opnd); break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if ((i == 0) && ((opCode == INST_JUMP4) - || (opCode == INST_JUMP_TRUE4) - || (opCode == INST_JUMP_FALSE4))) { - fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); - } else { - fprintf(stdout, "%d ", opnd); + if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 + || opCode == INST_JUMP_FALSE4) { + sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } + fprintf(stdout, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if ((i == 0) && (opCode == INST_PUSH1)) { - fprintf(stdout, "%u # ", (unsigned int) opnd); - TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); - } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) - || (opCode == INST_LOAD_ARRAY1) - || (opCode == INST_STORE_SCALAR1) - || (opCode == INST_STORE_ARRAY1))) { - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - if (opnd >= localCt) { - Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "%u # temp var %u", - (unsigned int) opnd, (unsigned int) opnd); - } else { - fprintf(stdout, "%u # var ", (unsigned int) opnd); - TclPrintSource(stdout, localPtr->name, 40); - } - } else { - fprintf(stdout, "%u ", (unsigned int) opnd); + if (opCode == INST_PUSH1) { + suffixObj = codePtr->objArrayPtr[opnd]; } + fprintf(stdout, "%u ", (unsigned int) opnd); break; case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_PUSH4) { - fprintf(stdout, "%u # ", opnd); - TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); - } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) - || (opCode == INST_LOAD_ARRAY4) - || (opCode == INST_STORE_SCALAR4) - || (opCode == INST_STORE_ARRAY4))) { - int localCt = procPtr->numCompiledLocals; - CompiledLocal *localPtr = procPtr->firstLocalPtr; - if (opnd >= localCt) { - Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); - } - for (j = 0; j < opnd; j++) { - localPtr = localPtr->nextPtr; - } - if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "%u # temp var %u", - (unsigned int) opnd, (unsigned int) opnd); - } else { - fprintf(stdout, "%u # var ", (unsigned int) opnd); - TclPrintSource(stdout, localPtr->name, 40); - } - } else { - fprintf(stdout, "%u ", (unsigned int) opnd); + suffixObj = codePtr->objArrayPtr[opnd]; + } else if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); } + fprintf(stdout, "%u ", (unsigned int) opnd); break; - case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opnd >= -1) { @@ -3238,20 +3163,51 @@ TclPrintInstruction(codePtr, pc) fprintf(stdout, "end "); } else { fprintf(stdout, "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("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) 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; + } + } + fprintf(stdout, "%%v%u ", (unsigned) opnd); break; - case OPERAND_NONE: default: break; } } + if (suffixObj) { + fprintf(stdout, "\t# "); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if (suffixBuffer[0]) { + fprintf(stdout, "\t# %s", suffixBuffer); + if (suffixSrc) { + TclPrintSource(stdout, suffixSrc, 40); + } + } fprintf(stdout, "\n"); return numBytes; } -#endif /* TCL_COMPILE_DEBUG */ -#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * @@ -3278,20 +3234,18 @@ TclPrintObject(outFile, objPtr, maxChars) { char *bytes; int length; - + bytes = Tcl_GetStringFromObj(objPtr, &length); TclPrintSource(outFile, bytes, TclMin(length, maxChars)); } -#endif /* TCL_COMPILE_DEBUG */ -#ifdef TCL_COMPILE_DEBUG /* *---------------------------------------------------------------------- * * TclPrintSource -- * - * This procedure prints up to a specified number of characters from - * the argument string to a specified file. It tries to produce legible + * 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: @@ -3321,27 +3275,27 @@ TclPrintSource(outFile, stringPtr, maxChars) p = stringPtr; for (; (*p != '\0') && (i < maxChars); p++, i++) { switch (*p) { - case '"': - fprintf(outFile, "\\\""); - continue; - case '\f': - fprintf(outFile, "\\f"); - continue; - case '\n': - fprintf(outFile, "\\n"); - continue; - case '\r': - fprintf(outFile, "\\r"); - continue; - case '\t': - fprintf(outFile, "\\t"); - continue; - case '\v': - fprintf(outFile, "\\v"); - continue; - default: - fprintf(outFile, "%c", *p); - continue; + case '"': + fprintf(outFile, "\\\""); + continue; + case '\f': + fprintf(outFile, "\\f"); + continue; + case '\n': + fprintf(outFile, "\\n"); + continue; + case '\r': + fprintf(outFile, "\\r"); + continue; + case '\t': + fprintf(outFile, "\\t"); + continue; + case '\v': + fprintf(outFile, "\\v"); + continue; + default: + fprintf(outFile, "%c", *p); + continue; } } fprintf(outFile, "\""); @@ -3363,8 +3317,8 @@ TclPrintSource(outFile, stringPtr, maxChars) * * Side effects: * Accumulates aggregate code-related statistics in the interpreter's - * ByteCodeStats structure. Records statistics specific to a ByteCode - * in its ByteCode structure. + * ByteCodeStats structure. Records statistics specific to a ByteCode in + * its ByteCode structure. * *---------------------------------------------------------------------- */ @@ -3378,21 +3332,29 @@ RecordByteCodeStats(codePtr) register ByteCodeStats *statsPtr = &(iPtr->stats); statsPtr->numCompilations++; - statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; - statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; - statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; + 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->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: + */ diff --git a/generic/tclCompile.h b/generic/tclCompile.h index 74c2091..485186d 100644 --- a/generic/tclCompile.h +++ b/generic/tclCompile.h @@ -8,7 +8,7 @@ * See the file "license.terms" for information on usage and redistribution * of this file, and for a DISCLAIMER OF ALL WARRANTIES. * - * RCS: @(#) $Id: tclCompile.h,v 1.56 2005/06/20 21:27:12 dkf Exp $ + * RCS: @(#) $Id: tclCompile.h,v 1.57 2005/07/14 10:50:26 dkf Exp $ */ #ifndef _TCLCOMPILATION @@ -567,6 +567,10 @@ typedef enum InstOperandType { OPERAND_UINT4, /* Four byte unsigned integer. */ OPERAND_IDX4 /* Four byte signed index (actually an * integer, but displayed differently.) */ + OPERAND_LVT1, /* One byte unsigned index into the local + * variable table. */ + OPERAND_LVT4 /* Four byte unsigned index into the local + * variable table. */ } InstOperandType; typedef struct InstructionDesc { @@ -801,6 +805,7 @@ MODULE_SCOPE int TclWordKnownAtCompileTime _ANSI_ARGS_(( #define LITERAL_ON_HEAP 0x01 #define LITERAL_NS_SCOPE 0x02 + /* * Form of TclRegisterLiteral with onHeap == 0. In that case, it is safe to * cast away CONSTness, and it is cleanest to do that here, all in one place. |