diff options
Diffstat (limited to 'generic/tclCompile.c')
| -rw-r--r-- | generic/tclCompile.c | 3763 |
1 files changed, 1841 insertions, 1922 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 3c65be8..1ec7c58 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -1,15 +1,15 @@ -/* +/* * 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. + * 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. */ #include "tclInt.h" @@ -18,7 +18,7 @@ /* * Table of all AuxData types. */ - + static Tcl_HashTable auxDataTypeTable; static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ @@ -40,10 +40,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 @@ -51,398 +51,276 @@ static int traceInitialized = 0; */ InstructionDesc tclInstructionTable[] = { - /* Name Bytes stackEffect #Opnds Operand types */ - {"done", 1, -1, 0, {OPERAND_NONE}}, + /* Name Bytes stackEffect #Opnds Operand types Stack top, next */ + {"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_LVT1}}, + + {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}}, /* Load scalar variable at index op1 <= 255 in call frame */ - {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}}, + {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}}, /* 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_LVT1}}, + {"loadArray1", 2, 0, 1, {OPERAND_UINT1}}, /* Load array element; array at slot op1<=255, element is stktop */ - {"loadArray4", 5, 0, 1, {OPERAND_LVT4}}, + {"loadArray4", 5, 0, 1, {OPERAND_UINT4}}, /* 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_LVT1}}, + {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}}, /* Store scalar variable at op1<=255 in frame; value is stktop */ - {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}}, + {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}}, /* 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_LVT1}}, + {"storeArray1", 2, -1, 1, {OPERAND_UINT1}}, /* Store array element; array at op1<=255, value is top then elem */ - {"storeArray4", 5, -1, 1, {OPERAND_LVT4}}, + {"storeArray4", 5, -1, 1, {OPERAND_UINT4}}, /* 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_LVT1}}, + + {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}}, /* 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_LVT1}}, + {"incrArray1", 2, -1, 1, {OPERAND_UINT1}}, /* 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_LVT1, OPERAND_INT1}}, + {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, 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_LVT1, OPERAND_INT1}}, + {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, 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}}, - /* Less or equal: push (stknext || stktop) */ - {"ge", 1, -1, 0, {OPERAND_NONE}}, - /* Greater or equal: push (stknext || stktop) */ - {"lshift", 1, -1, 0, {OPERAND_NONE}}, + {"le", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"ge", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"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}}, - /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ - {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, + {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ + {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, /* Try converting stktop to first int then double if possible. */ - {"break", 1, 0, 0, {OPERAND_NONE}}, + {"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_AUX4}}, + {"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_AUX4}}, + {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, /* "Step" or begin next iteration of foreach loop. Push 0 if to - * terminate loop, else push 1. */ + * 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. */ - - {"streq", 1, -1, 0, {OPERAND_NONE}}, + {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, + /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as + * a new object onto the stack. */ + {"streq", 1, -1, 0, {OPERAND_NONE}}, /* Str Equal: push (stknext eq stktop) */ - {"strneq", 1, -1, 0, {OPERAND_NONE}}, + {"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_LVT1}}, + {"appendScalar1", 2, 0, 1, {OPERAND_UINT1}}, /* Append scalar variable at op1<=255 in frame; value is stktop */ - {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}}, + {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}}, /* Append scalar variable at op1 > 255 in frame; value is stktop */ - {"appendArray1", 2, -1, 1, {OPERAND_LVT1}}, + {"appendArray1", 2, -1, 1, {OPERAND_UINT1}}, /* Append array element; array at op1<=255, value is top then elem */ - {"appendArray4", 5, -1, 1, {OPERAND_LVT4}}, + {"appendArray4", 5, -1, 1, {OPERAND_UINT4}}, /* 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_LVT1}}, + {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}}, /* Lappend scalar variable at op1<=255 in frame; value is stktop */ - {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}}, + {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}}, /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ - {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}}, + {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}}, /* Lappend array element; array at op1<=255, value is top then elem */ - {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}}, + {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}}, /* 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 - * 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. + {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Lindex with generalized args, operand is number of stacked objs + * used: (operand-1) entries from stktop are the indices; then list + * to process. */ + {"over", 5, +1, 1, {OPERAND_UINT4}}, + /* Duplicate the arg-th element from top of stack (TOS=0) */ + {"lsetList", 1, -2, 0, {OPERAND_NONE}}, + /* Four-arg version of 'lset'. stktop is old value; next is + * new element value, next is the index list; pushes new value */ + {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Three- or >=5-arg version of 'lset', operand is number of + * stacked objs: stktop is old value, next is new element value, next + * come (operand-2) indices; pushes the new value. */ - - {"returnImm", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, - /* Compiled [return], code, level are operands; options and result - * are on the stack. */ - {"expon", 1, -1, 0, {OPERAND_NONE}}, - /* Binary exponentiation operator: push (stknext ** stktop) */ - - /* - * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong - - * but it cannot be done right at compile time, the stack effect is only - * known at run time. The value for invokeExpanded is estimated better at - * compile time. - * See the comments further down in this file, where INST_INVOKE_EXPANDED - * is emitted. - */ - {"expandStart", 1, 0, 0, {OPERAND_NONE}}, - /* Start of command with {*} (expanded) arguments */ - {"expandStkTop", 5, 0, 1, {OPERAND_UINT4}}, - /* Expand the list at stacktop: push its elements on the stack */ - {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, - /* Invoke the command marked by the last 'expandStart' */ - - {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, - /* List Index: push (lindex stktop op4) */ - {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, - /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, - /* Start of bytecoded command: op is the length of the cmd's code, op2 - * is number of commands here */ - - {"listIn", 1, -1, 0, {OPERAND_NONE}}, - /* List containment: push [lsearch stktop stknext]>=0) */ - {"listNotIn", 1, -1, 0, {OPERAND_NONE}}, - /* List negated containment: push [lsearch stktop stknext]<0) */ - - {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, - /* Push the interpreter's return option dictionary as an object on the - * stack. */ - {"returnStk", 1, -2, 0, {OPERAND_NONE}}, - /* Compiled [return]; options and result are on the stack, code and - * level are in the options. */ - - {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}}, - /* The top op4 words (min 1) are a key path into the dictionary just - * below the keys on the stack, and all those values are replaced by - * the value read out of that key-path (like [dict get]). - * Stack: ... dict key1 ... keyN => ... value */ - {"dictSet", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, - /* Update a dictionary value such that the keys are a path pointing to - * the value. op4#1 = numKeys, op4#2 = LVTindex - * Stack: ... key1 ... keyN value => ... newDict */ - {"dictUnset", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, - /* Update a dictionary value such that the keys are not a path pointing - * to any value. op4#1 = numKeys, op4#2 = LVTindex - * Stack: ... key1 ... keyN => ... newDict */ - {"dictIncrImm", 9, 0, 2, {OPERAND_INT4, OPERAND_LVT4}}, - /* Update a dictionary value such that the value pointed to by key is - * incremented by some value (or set to it if the key isn't in the - * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex - * Stack: ... key => ... newDict */ - {"dictAppend", 5, -1, 1, {OPERAND_LVT4}}, - /* Update a dictionary value such that the value pointed to by key has - * some value string-concatenated onto it. op4 = LVTindex - * Stack: ... key valueToAppend => ... newDict */ - {"dictLappend", 5, -1, 1, {OPERAND_LVT4}}, - /* Update a dictionary value such that the value pointed to by key has - * some value list-appended onto it. op4 = LVTindex - * Stack: ... key valueToAppend => ... newDict */ - {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, - /* Begin iterating over the dictionary, using the local scalar - * indicated by op4 to hold the iterator state. If doneBool is true, - * dictDone *must* be called later on. - * Stack: ... dict => ... value key doneBool */ - {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, - /* Get the next iteration from the iterator in op4's local scalar. - * Stack: ... => ... value key doneBool */ - {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, - /* Terminate the iterator in op4's local scalar. */ - {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, - /* Create the variables (described in the aux data referred to by the - * second immediate argument) to mirror the state of the dictionary in - * the variable referred to by the first immediate argument. The list - * of keys (popped from the stack) must be the same length as the list - * of variables. - * Stack: ... keyList => ... */ - {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, - /* Reflect the state of local variables (described in the aux data - * referred to by the second immediate argument) back to the state of - * the dictionary in the variable referred to by the first immediate - * argument. The list of keys (popped from the stack) must be the same - * length as the list of variables. - * Stack: ... keyList => ... */ - {"jumpTable", 5, -1, 1, {OPERAND_AUX4}}, - /* Jump according to the jump-table (in AuxData as indicated by the - * operand) and the argument popped from the list. Always executes the - * next instruction if no match against the table's entries was found. - * Stack: ... value => ... - * Note that the jump table contains offsets relative to the PC when - * it points to this instruction; the code is relocatable. */ - {"upvar", 5, 0, 1, {OPERAND_LVT4}}, - /* finds level and otherName in stack, links to local variable at - * index op1. Leaves the level on stack. */ - {"nsupvar", 5, 0, 1, {OPERAND_LVT4}}, - /* finds namespace and otherName in stack, links to local variable at - * index op1. Leaves the namespace on stack. */ - {"variable", 5, 0, 1, {OPERAND_LVT4}}, - /* finds namespace and otherName in stack, links to local variable at - * index op1. Leaves the namespace on stack. */ - {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, - /* Compiled bytecodes to signal syntax error. */ - {"reverse", 5, 0, 1, {OPERAND_UINT4}}, - /* Reverse the order of the arg elements at the top of stack */ - - {"regexp", 2, -1, 1, {OPERAND_INT1}}, - /* Regexp: push (regexp stknext stktop) opnd == nocase */ - - {"existScalar", 5, 1, 1, {OPERAND_LVT4}}, - /* Test if scalar variable at index op1 in call frame exists */ - {"existArray", 5, 0, 1, {OPERAND_LVT4}}, - /* Test if array element exists; array at slot op1, element is - * stktop */ - {"existArrayStk", 1, -1, 0, {OPERAND_NONE}}, - /* Test if array element exists; element is stktop, array name is - * stknext */ - {"existStk", 1, 0, 0, {OPERAND_NONE}}, - /* Test if general variable exists; unparsed variable name is stktop*/ - {0, 0, 0, 0, {0}} + {0, 0, 0, 0, {OPERAND_NONE}} }; /* * Prototypes for procedures defined later in this file: */ -static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, - Tcl_Obj *copyPtr); -static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, - ByteCode *codePtr, unsigned char *startPtr); -static void EnterCmdExtentData(CompileEnv *envPtr, - int cmdNumber, int numSrcBytes, int numCodeBytes); -static void EnterCmdStartData(CompileEnv *envPtr, - int cmdNumber, int srcOffset, int codeOffset); -static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); -static int GetCmdLocEncodingSize(CompileEnv *envPtr); +static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( + CompileEnv *envPtr, ByteCode *codePtr, + unsigned char *startPtr)); +static void EnterCmdExtentData _ANSI_ARGS_(( + CompileEnv *envPtr, int cmdNumber, + int numSrcBytes, int numCodeBytes)); +static void EnterCmdStartData _ANSI_ARGS_(( + CompileEnv *envPtr, int cmdNumber, + int srcOffset, int codeOffset)); +static void FreeByteCodeInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static int GetCmdLocEncodingSize _ANSI_ARGS_(( + CompileEnv *envPtr)); +static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *script, CONST char *command, + int length)); #ifdef TCL_COMPILE_STATS -static void RecordByteCodeStats(ByteCode *codePtr); +static void RecordByteCodeStats _ANSI_ARGS_(( + ByteCode *codePtr)); #endif /* TCL_COMPILE_STATS */ -static int SetByteCodeFromAny(Tcl_Interp *interp, - Tcl_Obj *objPtr); -static int FormatInstruction(ByteCode *codePtr, - unsigned char *pc, Tcl_Obj *bufferObj); -static void PrintSourceToObj(Tcl_Obj *appendObj, - const char *stringPtr, int maxChars); -/* - * TIP #280: Helper for building the per-word line information of all compiled - * commands. - */ -static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, - Tcl_Token *tokenPtr, const char *cmd, int len, - int numWords, int line, int* clNext, int **lines, - CompileEnv* envPtr); +static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + +#ifdef TCL_TIP280 +/* TIP #280 : Helper for building the per-word line information of all + * compiled commands */ +static void EnterCmdWordData _ANSI_ARGS_(( + ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr, + CONST char* cmd, int len, int numWords, int line, + int* clNext, int** lines, CompileEnv* envPtr)); +static void ReleaseCmdWordData _ANSI_ARGS_((ExtCmdLoc* eclPtr)); +#endif + /* - * The structure below defines the bytecode Tcl object type by means of - * procedures that can be invoked by generic object code. + * The structure below defines the bytecode Tcl object type by + * means of procedures that can be invoked by generic object code. */ Tcl_ObjType tclByteCodeType = { - "bytecode", /* name */ - FreeByteCodeInternalRep, /* freeIntRepProc */ - DupByteCodeInternalRep, /* dupIntRepProc */ - NULL, /* updateStringProc */ - SetByteCodeFromAny /* setFromAnyProc */ + "bytecode", /* name */ + FreeByteCodeInternalRep, /* freeIntRepProc */ + DupByteCodeInternalRep, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + SetByteCodeFromAny /* setFromAnyProc */ }; /* @@ -452,10 +330,10 @@ 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. interp is - * compilation context and may not be NULL. + * 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. interp is compilation context and may not be NULL. * * Results: * The return value is a standard Tcl object result. If an error occurs @@ -464,51 +342,61 @@ 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( - 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. */ +TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) + Tcl_Interp *interp; /* The interpreter for which the code is + * being compiled. Must not be NULL. */ + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ + CompileHookProc *hookProc; /* Procedure to invoke after compilation. */ + ClientData clientData; /* Hook procedure private data. */ { Interp *iPtr = (Interp *) interp; - CompileEnv compEnv; /* Compilation environment structure allocated - * in frame. */ + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); register AuxData *auxDataPtr; LiteralEntry *entryPtr; register int i; - int length, result = TCL_OK; - const char *stringPtr; + int length, nested, result; + char *string; +#ifdef TCL_TIP280 ContLineLoc* clLocPtr; - +#endif #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) { + panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); + } + traceInitialized = 1; } #endif - stringPtr = TclGetStringFromObj(objPtr, &length); - + if (iPtr->evalFlags & TCL_BRACKET_TERM) { + nested = 1; + } else { + nested = 0; + } + string = Tcl_GetStringFromObj(objPtr, &length); +#ifndef TCL_TIP280 + TclInitCompileEnv(interp, &compEnv, string, length); +#else /* - * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and - * use to initialize the tracking in the compiler. This information was - * stored by TclCompEvalObj and ProcCompileProc. + * TIP #280. Pick up the CmdFrame in which the BC compiler was invoked + * and use to initialize the tracking in the compiler. This information + * was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc + * (tclProc.c). */ - TclInitCompileEnv(interp, &compEnv, stringPtr, length, - iPtr->invokeCmdFramePtr, iPtr->invokeWord); + TclInitCompileEnv(interp, &compEnv, string, length, + iPtr->invokeCmdFramePtr, iPtr->invokeWord); /* * Now we check if we have data about invisible continuation lines for the * script, and make it available to the compile environment, if so. @@ -527,43 +415,45 @@ TclSetByteCodeFromAny( compEnv.clNext = &compEnv.clLoc->loc[0]; Tcl_Preserve (compEnv.clLoc); } +#endif + result = TclCompileScript(interp, string, length, nested, &compEnv); - TclCompileScript(interp, stringPtr, length, &compEnv); - - /* - * Successful compilation. Add a "done" instruction at the end. - */ - - TclEmitOpcode(INST_DONE, &compEnv); + if (result == TCL_OK) { + /* + * Successful compilation. Add a "done" instruction at the end. + */ - /* - * Invoke the compilation hook procedure if one exists. - */ + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); - if (hookProc) { - result = (*hookProc)(interp, &compEnv, clientData); - } + /* + * Invoke the compilation hook procedure if one exists. + */ - /* - * Change the object into a ByteCode object. Ownership of the literal - * objects and aux data items is given to the ByteCode object. - */ + if (hookProc) { + result = (*hookProc)(interp, &compEnv, clientData); + } + /* + * Change the object into a ByteCode object. Ownership of the literal + * objects and aux data items is given to the ByteCode object. + */ + #ifdef TCL_COMPILE_DEBUG - TclVerifyLocalLiteralTable(&compEnv); + TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - fflush(stdout); - } + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + } #endif /* TCL_COMPILE_DEBUG */ - + } + if (result != TCL_OK) { /* - * Handle any error from the hookProc + * Compilation errors. */ entryPtr = compEnv.literalArrayPtr; @@ -584,6 +474,14 @@ TclSetByteCodeFromAny( } } + + /* + * Free storage allocated during compilation. + */ + + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); + } TclFreeCompileEnv(&compEnv); return result; } @@ -604,24 +502,24 @@ TclSetByteCodeFromAny( * * 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( - 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. */ +SetByteCodeFromAny(interp, objPtr) + Tcl_Interp *interp; /* The interpreter for which the code is + * being compiled. Must not be NULL. */ + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ { if (interp == NULL) { return TCL_ERROR; } - (void) TclSetByteCodeFromAny(interp, objPtr, NULL, (ClientData) NULL); - return TCL_OK; + return TclSetByteCodeFromAny(interp, objPtr, + (CompileHookProc *) NULL, (ClientData) NULL); } /* @@ -629,8 +527,8 @@ SetByteCodeFromAny( * * 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. * @@ -644,9 +542,9 @@ SetByteCodeFromAny( */ static void -DupByteCodeInternalRep( - Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ - Tcl_Obj *copyPtr) /* Object with internal rep to set. */ +DupByteCodeInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ { return; } @@ -656,27 +554,28 @@ DupByteCodeInternalRep( * * 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. * *---------------------------------------------------------------------- */ static void -FreeByteCodeInternalRep( - register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ +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) { @@ -699,22 +598,24 @@ FreeByteCodeInternalRep( * 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. * *---------------------------------------------------------------------- */ void -TclCleanupByteCode( - register ByteCode *codePtr) /* Points to the ByteCode to free. */ +TclCleanupByteCode(codePtr) + register ByteCode *codePtr; /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; - Interp *iPtr = (Interp *) interp; +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif int numLitObjects = codePtr->numLitObjects; int numAuxDataItems = codePtr->numAuxDataItems; - register Tcl_Obj **objArrayPtr, *objPtr; + register Tcl_Obj **objArrayPtr; register AuxData *auxDataPtr; int i; #ifdef TCL_COMPILE_STATS @@ -730,13 +631,13 @@ TclCleanupByteCode( 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); @@ -744,9 +645,9 @@ TclCleanupByteCode( 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; @@ -756,28 +657,21 @@ TclCleanupByteCode( #endif /* TCL_COMPILE_STATS */ /* - * A single heap object holds the ByteCode structure and its code, object, - * command location, and auxiliary data arrays. This means we only need to - * 1) decrement the ref counts of the LiteralEntry's in its literal array, - * 2) call the free procs for the auxiliary data items, 3) free the - * localCache if it is unused, and finally 4) free the ByteCode - * structure's heap object. - * - * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like - * those generated from tbcload) is special, as they doesn't make use of - * the global literal table. They instead maintain private references to - * their literals which must be decremented. + * 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. * - * 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. + * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, + * like those generated from tbcload) is special, as they doesn't + * make use of the global literal table. They instead maintain + * private references to their literals which must be decremented. */ - if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { - + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + register Tcl_Obj *objPtr; + objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { objPtr = *objArrayPtr; @@ -787,30 +681,36 @@ TclCleanupByteCode( objArrayPtr++; } codePtr->numLitObjects = 0; - } else { + } else if (interp != NULL) { + /* + * If the interp has already been freed, then Tcl will have already + * forcefully released all the literals used by ByteCodes compiled + * with respect to that interp. + */ + objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { /* * TclReleaseLiteral sets a ByteCode's object array entry NULL to * indicate that it has already freed the literal. */ - - objPtr = *objArrayPtr; - if (objPtr != NULL) { - TclReleaseLiteral(interp, objPtr); + + if (*objArrayPtr != NULL) { + TclReleaseLiteral(interp, *objArrayPtr); } objArrayPtr++; } } - + auxDataPtr = codePtr->auxDataArrayPtr; for (i = 0; i < numAuxDataItems; i++) { if (auxDataPtr->type->freeProc != NULL) { - (auxDataPtr->type->freeProc)(auxDataPtr->clientData); + (*auxDataPtr->type->freeProc)(auxDataPtr->clientData); } auxDataPtr++; } +#ifdef TCL_TIP280 /* * TIP #280. Release the location data associated with this byte code * structure, if any. NOTE: The interp we belong to may be gone already, @@ -820,37 +720,43 @@ TclCleanupByteCode( */ if (iPtr) { - Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, - (char *) codePtr); + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); if (hePtr) { - ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); - int i; + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); - if (eclPtr->type == TCL_LOCATION_SOURCE) { - Tcl_DecrRefCount(eclPtr->path); - } - for (i=0 ; i<eclPtr->nuloc ; i++) { - ckfree((char *) eclPtr->loc[i].line); - } + ReleaseCmdWordData (eclPtr); + Tcl_DeleteHashEntry (hePtr); + } + } +#endif - if (eclPtr->loc != NULL) { - ckfree((char *) eclPtr->loc); - } + TclHandleRelease(codePtr->interpHandle); + ckfree((char *) codePtr); +} - Tcl_DeleteHashTable (&eclPtr->litInfo); +#ifdef TCL_TIP280 +static void +ReleaseCmdWordData (eclPtr) + ExtCmdLoc* eclPtr; +{ + int i; - ckfree((char *) eclPtr); - Tcl_DeleteHashEntry(hePtr); - } + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (eclPtr->path); + } + for (i=0; i < eclPtr->nuloc; i++) { + ckfree ((char*) eclPtr->loc[i].line); } - if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) { - TclFreeLocalCache(interp, codePtr->localCachePtr); + if (eclPtr->loc != NULL) { + ckfree ((char*) eclPtr->loc); } - TclHandleRelease(codePtr->interpHandle); - ckfree((char *) codePtr); + Tcl_DeleteHashTable (&eclPtr->litInfo); + + ckfree ((char*) eclPtr); } +#endif /* *---------------------------------------------------------------------- @@ -870,21 +776,27 @@ TclCleanupByteCode( */ void -TclInitCompileEnv( - Tcl_Interp *interp, /* The interpreter for which a CompileEnv - * structure is initialized. */ - register CompileEnv *envPtr,/* Points to the CompileEnv structure to - * initialize. */ - const char *stringPtr, /* The source string to be compiled. */ - int numBytes, /* Number of bytes in source string. */ - const CmdFrame *invoker, /* Location context invoking the bcc */ - int word) /* Index of the word in that context getting - * compiled */ +#ifndef TCL_TIP280 +TclInitCompileEnv(interp, envPtr, string, numBytes) +#else +TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word) +#endif + Tcl_Interp *interp; /* The interpreter for which a CompileEnv + * structure is initialized. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure to + * initialize. */ + char *string; /* The source string to be compiled. */ + int numBytes; /* Number of bytes in source string. */ +#ifdef TCL_TIP280 + CONST CmdFrame* invoker; /* Location context invoking the bcc */ + int word; /* Index of the word in that context + * getting compiled */ +#endif { Interp *iPtr = (Interp *) interp; - + envPtr->iPtr = iPtr; - envPtr->source = stringPtr; + envPtr->source = string; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; iPtr->compiledProcPtr = NULL; @@ -904,17 +816,17 @@ TclInitCompileEnv( envPtr->literalArrayNext = 0; envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; envPtr->mallocedLiteralArray = 0; - + envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; - + envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; - envPtr->atCmdStart = 1; +#ifdef TCL_TIP280 /* * TIP #280: Set up the extended command location information, based on * the context invoking the byte code compiler. This structure is used to @@ -924,11 +836,11 @@ TclInitCompileEnv( * non-compiling evaluator */ - envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc)); - envPtr->extCmdMapPtr->loc = NULL; - envPtr->extCmdMapPtr->nloc = 0; + envPtr->extCmdMapPtr = (ExtCmdLoc*) ckalloc (sizeof (ExtCmdLoc)); + envPtr->extCmdMapPtr->loc = NULL; + envPtr->extCmdMapPtr->nloc = 0; envPtr->extCmdMapPtr->nuloc = 0; - envPtr->extCmdMapPtr->path = NULL; + envPtr->extCmdMapPtr->path = NULL; Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); if (invoker == NULL || @@ -938,75 +850,61 @@ TclInitCompileEnv( * dynamic context. */ - envPtr->line = 1; - envPtr->extCmdMapPtr->type = - (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); + envPtr->line = 1; + envPtr->extCmdMapPtr->type = (envPtr->procPtr + ? TCL_LOCATION_PROC + : TCL_LOCATION_BC); } else { - /* - * Initialize the compiler using the context, making counting absolute - * to that context. Note that the context can be byte code execution. - * In that case we have to fill out the missing pieces (line, path, - * ...) which may make change the type as well. + /* Initialize the compiler using the context, making counting absolute + * to that context. Note that the context can be byte code + * execution. In that case we have to fill out the missing pieces + * (line, path, ...). Which may make change the type as well. */ - CmdFrame* ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); - int pc = 0; - - *ctxPtr = *invoker; + CmdFrame ctx = *invoker; + int pc = 0; if (invoker->type == TCL_LOCATION_BC) { - /* - * Note: Type BC => ctx.data.eval.path is not used. + /* Note: Type BC => ctx.data.eval.path is not used. * ctx.data.tebc.codePtr is used instead. - */ - - TclGetSrcInfoForPc(ctxPtr); + */ + TclGetSrcInfoForPc (&ctx); pc = 1; } - if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) { - /* - * Word is not a literal, relative counting. - */ + if ((ctx.nline <= word) || (ctx.line[word] < 0)) { + /* Word is not a literal, relative counting */ - envPtr->line = 1; - envPtr->extCmdMapPtr->type = - (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); + envPtr->line = 1; + envPtr->extCmdMapPtr->type = (envPtr->procPtr + ? TCL_LOCATION_PROC + : TCL_LOCATION_BC); - if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { + if (pc && (ctx.type == TCL_LOCATION_SOURCE)) { /* * The reference made by 'TclGetSrcInfoForPc' is dead. */ - Tcl_DecrRefCount(ctxPtr->data.eval.path); + Tcl_DecrRefCount(ctx.data.eval.path); } } else { - envPtr->line = ctxPtr->line[word]; - envPtr->extCmdMapPtr->type = ctxPtr->type; - - if (ctxPtr->type == TCL_LOCATION_SOURCE) { - envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; + envPtr->line = ctx.line [word]; + envPtr->extCmdMapPtr->type = ctx.type; + envPtr->extCmdMapPtr->path = ctx.data.eval.path; + if (ctx.type == TCL_LOCATION_SOURCE) { if (pc) { - /* - * The reference 'TclGetSrcInfoForPc' made is transfered. - */ - - ctxPtr->data.eval.path = NULL; + /* The reference 'TclGetSrcInfoForPc' made is transfered */ + ctx.data.eval.path = NULL; } else { - /* - * We have a new reference here. - */ - - Tcl_IncrRefCount(ctxPtr->data.eval.path); + /* We have a new reference here */ + Tcl_IncrRefCount (ctx.data.eval.path); } } } - TclStackFree(interp, ctxPtr); + /* ctx going out of scope */ } - envPtr->extCmdMapPtr->start = envPtr->line; - /* * Initialize the data about invisible continuation lines as empty, * i.e. not used. The caller (TclSetByteCodeFromAny) will set this up, if @@ -1015,6 +913,7 @@ TclInitCompileEnv( envPtr->clLoc = NULL; envPtr->clNext = NULL; +#endif envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; @@ -1032,26 +931,22 @@ TclInitCompileEnv( * * 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. * *---------------------------------------------------------------------- */ void -TclFreeCompileEnv( - register CompileEnv *envPtr)/* Points to the CompileEnv structure. */ +TclFreeCompileEnv(envPtr) + register CompileEnv *envPtr; /* Points to the CompileEnv structure. */ { - if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets) { - ckfree((char *) envPtr->localLitTable.buckets); - envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; - } if (envPtr->mallocedCodeArray) { ckfree((char *) envPtr->codeStart); } @@ -1067,10 +962,7 @@ TclFreeCompileEnv( if (envPtr->mallocedAuxDataArray) { ckfree((char *) envPtr->auxDataArrayPtr); } - if (envPtr->extCmdMapPtr) { - ckfree((char *) envPtr->extCmdMapPtr); - } - +#ifdef TCL_TIP280 /* * If we used data about invisible continuation lines, then now is the * time to release on our hold on it. The lock was set in function @@ -1080,8 +972,13 @@ TclFreeCompileEnv( if (envPtr->clLoc) { Tcl_Release (envPtr->clLoc); } + if (envPtr->extCmdMapPtr) { + ReleaseCmdWordData (envPtr->extCmdMapPtr); + } +#endif } +#ifdef TCL_TIP280 /* *---------------------------------------------------------------------- * @@ -1099,67 +996,35 @@ TclFreeCompileEnv( * 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. + * None. * + * TIP #280 *---------------------------------------------------------------------- */ int -TclWordKnownAtCompileTime( - Tcl_Token *tokenPtr, /* Points to Tcl_Token we should check */ - Tcl_Obj *valuePtr) /* If not NULL, points to an unshared Tcl_Obj - * to which we should append the known value - * of the word. */ +TclWordKnownAtCompileTime (tokenPtr) + Tcl_Token* tokenPtr; { - int numComponents = tokenPtr->numComponents; - Tcl_Obj *tempPtr = NULL; + int i; + Tcl_Token* sub; - if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { - if (valuePtr != NULL) { - Tcl_AppendToObj(valuePtr, tokenPtr[1].start, tokenPtr[1].size); - } - return 1; - } - if (tokenPtr->type != TCL_TOKEN_WORD) { - return 0; - } - tokenPtr++; - if (valuePtr != NULL) { - tempPtr = Tcl_NewObj(); - Tcl_IncrRefCount(tempPtr); - } - while (numComponents--) { - switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - if (tempPtr != NULL) { - Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size); - } - break; + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;}; + if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;}; - case TCL_TOKEN_BS: - if (tempPtr != NULL) { - char utfBuf[TCL_UTF_MAX]; - int length = TclParseBackslash(tokenPtr->start, - tokenPtr->size, NULL, utfBuf); - Tcl_AppendToObj(tempPtr, utfBuf, length); - } - break; + /* Check the sub tokens of the word. It is a literal if we find + * only BS and TEXT tokens */ - default: - if (tempPtr != NULL) { - Tcl_DecrRefCount(tempPtr); - } - return 0; - } - tokenPtr++; - } - if (valuePtr != NULL) { - Tcl_AppendObjToObj(valuePtr, tempPtr); - Tcl_DecrRefCount(tempPtr); + for (i=0, sub = tokenPtr + 1; + i < tokenPtr->numComponents; + i++, sub ++) { + if (sub->type == TCL_TOKEN_TEXT) continue; + if (sub->type == TCL_TOKEN_BS) continue; + return 0; } return 1; } +#endif /* *---------------------------------------------------------------------- @@ -1173,44 +1038,55 @@ TclWordKnownAtCompileTime( * on failure. If TCL_ERROR is returned, then the interpreter's result * contains an error message. * + * interp->termOffset is set to the offset of the character in the + * script just after the last one successfully processed; this will be + * the offset of the ']' if (flags & TCL_BRACKET_TERM). + * * Side effects: * Adds instructions to envPtr to evaluate the script at runtime. * *---------------------------------------------------------------------- */ -void -TclCompileScript( - Tcl_Interp *interp, /* Used for error and status reporting. Also - * serves as context for finding and compiling - * commands. May not be NULL. */ - const char *script, /* The source script to compile. */ - int numBytes, /* Number of bytes in script. If < 0, the +int +TclCompileScript(interp, script, numBytes, nested, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. + * Also serves as context for finding and + * compiling commands. May not be NULL. */ + CONST char *script; /* The source script to compile. */ + int numBytes; /* Number of bytes in script. If < 0, the * script consists of all bytes up to the * first null character. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ + int nested; /* Non-zero means this is a nested command: + * close bracket ']' should be considered a + * command terminator. If zero, close + * bracket has no special meaning. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ { Interp *iPtr = (Interp *) interp; + Tcl_Parse parse; int 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; + CONST char *p, *next; Namespace *cmdNsPtr; Command *cmdPtr; Tcl_Token *tokenPtr; - int bytesLeft, isFirstCmd, wordIdx, currCmdIndex; - int commandLength, objIndex; + int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex; + int commandLength, objIndex, code; Tcl_DString ds; + +#ifdef TCL_TIP280 /* TIP #280 */ - ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; - int *wlines, wlineat, cmdLine; + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + int* wlines = NULL; + int wlineat, cmdLine; int* clNext; - Tcl_Parse *parsePtr = (Tcl_Parse *) - TclStackAlloc(interp, sizeof(Tcl_Parse)); +#endif Tcl_DStringInit(&ds); @@ -1220,39 +1096,70 @@ TclCompileScript( Tcl_ResetResult(interp); isFirstCmd = 1; - if (envPtr->procPtr != NULL) { - cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; - } else { - cmdNsPtr = NULL; /* use current NS */ - } - /* - * Each iteration through the following loop compiles the next command - * from the script. + * Each iteration through the following loop compiles the next + * command from the script. */ p = script; bytesLeft = numBytes; + gotParse = 0; +#ifdef TCL_TIP280 cmdLine = envPtr->line; - clNext = envPtr->clNext; + clNext = envPtr->clNext; +#endif + do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) { + code = TCL_ERROR; + goto error; + } + gotParse = 1; + if (nested) { /* - * Compile bytecodes to report the parse error at runtime. + * This is an unusual situation where the caller has passed us + * a non-zero value for "nested". How unusual? Well, this + * procedure, TclCompileScript, is internal to Tcl, so all + * callers should be within Tcl itself. All but one of those + * callers explicitly pass in (nested = 0). The exceptional + * caller is TclSetByteCodeFromAny, which will pass in + * (nested = 1) if and only if the flag TCL_BRACKET_TERM + * is set in the evalFlags field of interp. + * + * It appears that the TCL_BRACKET_TERM flag is only ever set + * by Tcl_SubstObj, and it immediately calls Tcl_EvalEx + * which clears the flag before passing the interp along. + * So, I don't think this procedure, TclCompileScript, is + * **ever** called with (nested != 0). + * (The testsuite indeed doesn't exercise this code. MS) + * + * This means that the branches in this procedure that are + * only active when (nested != 0) are probably never exercised. + * This means that any bugs in them go unnoticed, and any bug + * fixes in them have a semi-theoretical nature. + * + * All that said, the spec for this procedure says it should + * handle the (nested != 0) case, so here's an attempt to fix + * bugs (Tcl Bug 681841) in that case. Just in case some + * callers eventually come along and expect it to work... */ - Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, - /* Drop the command terminator (";","]") if appropriate */ - (parsePtr->term == - parsePtr->commandStart + parsePtr->commandSize - 1)? - parsePtr->commandSize - 1 : parsePtr->commandSize); - TclCompileSyntaxError(interp, envPtr); - break; - } - if (parsePtr->numWords > 0) { - int expand = 0; /* Set if there are dynamic expansions to - * handle */ + if (parse.term == (script + numBytes)) { + /* + * The (nested != 0) case is meant to indicate that the + * caller found an open bracket ([) and asked us to + * parse and compile Tcl commands up to the matching + * close bracket (]). We have to detect and handle + * the case where the close bracket is missing. + */ + Tcl_SetObjResult(interp, + Tcl_NewStringObj("missing close-bracket", -1)); + code = TCL_ERROR; + goto error; + } + } + if (parse.numWords > 0) { /* * If not the first command, pop the previous command's result * and, if we're compiling a top level command, update the last @@ -1261,294 +1168,195 @@ TclCompileScript( if (!isFirstCmd) { TclEmitOpcode(INST_POP, envPtr); - envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - startCodeOffset; + if (!nested) { + envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - startCodeOffset; + } } /* * Determine the actual length of the command. */ - commandLength = parsePtr->commandSize; - if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { + 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)) { + if ((tclTraceCompile >= 1) + && !nested && (envPtr->procPtr == NULL)) { fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parsePtr->commandStart, + TclPrintSource(stdout, parse.commandStart, TclMin(commandLength, 55)); fprintf(stdout, "\n"); } #endif - /* - * Check whether expansion has been requested for any of the - * words. + * Each iteration of the following loop compiles one word + * from the command. */ - - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; - wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - break; - } - } - + envPtr->numCommands++; currCmdIndex = (envPtr->numCommands - 1); - lastTopLevelCmdIndex = currCmdIndex; + if (!nested) { + lastTopLevelCmdIndex = currCmdIndex; + } startCodeOffset = (envPtr->codeNext - envPtr->codeStart); EnterCmdStartData(envPtr, currCmdIndex, - parsePtr->commandStart - envPtr->source, startCodeOffset); + (parse.commandStart - envPtr->source), startCodeOffset); - /* - * Should only start issuing instructions after the "command has - * started" so that the command range is correct in the bytecode. - */ - - if (expand) { - TclEmitOpcode(INST_EXPAND_START, envPtr); - } - - /* - * TIP #280. Scan the words and compute the extended location +#ifdef TCL_TIP280 + /* TIP #280. Scan the words and compute the extended location * information. The map first contain full per-word line * information for use by the compiler. This is later replaced by * a reduced form which signals non-literal words, stored in * 'wlines'. */ - TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); + TclAdvanceLines (&cmdLine, p, parse.commandStart); TclAdvanceContinuations (&cmdLine, &clNext, - parsePtr->commandStart - envPtr->source); - EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, - parsePtr->tokenPtr, parsePtr->commandStart, - parsePtr->commandSize, parsePtr->numWords, cmdLine, - clNext, &wlines, envPtr); + parse.commandStart - envPtr->source); + EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source), + parse.tokenPtr, parse.commandStart, + parse.commandSize, parse.numWords, + cmdLine, clNext, &wlines, envPtr); wlineat = eclPtr->nuloc - 1; +#endif - /* - * Each iteration of the following loop compiles one word from the - * command. - */ - - for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; - wordIdx < parsePtr->numWords; wordIdx++, - tokenPtr += (tokenPtr->numComponents + 1)) { - - envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; + for (wordIdx = 0, tokenPtr = parse.tokenPtr; + wordIdx < parse.numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { +#ifdef TCL_TIP280 + envPtr->line = eclPtr->loc [wlineat].line [wordIdx]; envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx]; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * The word is not a simple string of characters. - */ - - TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } - - /* - * This is a simple string of literal characters (i.e. we know - * it absolutely and can use it directly). If this is the - * first word and the command has a compile procedure, let it - * compile the command. - */ - - if ((wordIdx == 0) && !expand) { +#endif + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { /* - * 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 this is the first word and the command has a + * compile procedure, let it compile the command. */ - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size); - - cmdPtr = (Command *) Tcl_FindCommand(interp, - Tcl_DStringValue(&ds), - (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); - - if ((cmdPtr != NULL) - && (cmdPtr->compileProc != NULL) - && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int savedNumCmds = envPtr->numCommands; - unsigned savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - int update = 0, code; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first bytecode in the compile env, - * as the check is done before calling - * TclExecuteByteCode(). Do emit an INST_START_CMD in - * special cases where the first bytecode is in a - * loop, to insure that the corresponding command is - * counted properly. Compilers for commands able to - * produce such a beast (currently 'while 1' only) set - * envPtr->atCmdStart to 0 in order to signal this - * case. [Bug 1752146] - * - * Note that the environment is initialised with - * atCmdStart=1 to avoid emitting ISC for the first - * command. - */ - - if (envPtr->atCmdStart) { - if (savedCodeNext != 0) { - /* - * Increase the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! - */ - - unsigned char *fixPtr = envPtr->codeNext - 4; - - TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1, - fixPtr); - } + if (wordIdx == 0) { + if (envPtr->procPtr != NULL) { + cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; } else { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - TclEmitInt4(1, envPtr); - update = 1; + cmdNsPtr = NULL; /* use current NS */ } - code = (cmdPtr->compileProc)(interp, parsePtr, - cmdPtr, envPtr); + /* + * 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 (code == TCL_OK) { - if (update) { + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, tokenPtr[1].start, + tokenPtr[1].size); + + cmdPtr = (Command *) Tcl_FindCommand(interp, + Tcl_DStringValue(&ds), + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + + if ((cmdPtr != NULL) + && (cmdPtr->compileProc != NULL) + && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + int savedNumCmds = envPtr->numCommands; + unsigned int savedCodeNext = + envPtr->codeNext - envPtr->codeStart; + + code = (*(cmdPtr->compileProc))(interp, &parse, + envPtr); + if (code == TCL_OK) { + goto finishCommand; + } else if (code == TCL_OUT_LINE_COMPILE) { /* - * Fix the bytecode length. + * Restore numCommands and codeNext to their correct + * values, removing any commands compiled before + * TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055] */ - - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned fixLen = envPtr->codeNext - - envPtr->codeStart - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } else { - if (envPtr->atCmdStart && savedCodeNext != 0) { + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + savedCodeNext; + } else { /* an error */ /* - * Decrease the number of commands being - * started at the current point. Note that - * this depends on the exact layout of the - * INST_START_CMD's operands, so be careful! + * There was a compilation error, the last + * command did not get compiled into (*envPtr). + * Decrement the number of commands + * claimed to be in (*envPtr). */ - - unsigned char *fixPtr = envPtr->codeNext - 4; - - TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1, - fixPtr); + envPtr->numCommands--; + goto log; } - - /* - * Restore numCommands and codeNext to their - * correct values, removing any commands compiled - * before the failure to produce bytecode got - * reported. [Bugs 705406 and 735055] - */ - - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart+savedCodeNext; } - } - /* - * No compile procedure so push the word. If the command - * was found, push a CmdName object to reduce runtime - * lookups. Avoid sharing this literal among different - * namespaces to reduce shimmering. - */ - - objIndex = TclRegisterNewNSLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr != NULL) { - TclSetCmdNameObj(interp, - envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); - } - if ((wordIdx == 0) && (parsePtr->numWords == 1)) { /* - * Single word script: unshare the command name to - * avoid shimmering between bytecode and cmdName - * representations [Bug 458361] + * No compile procedure so push the word. If the + * command was found, push a CmdName object to + * reduce runtime lookups. */ - TclHideLiteral(interp, envPtr, objIndex); + objIndex = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (cmdPtr != NULL) { + TclSetCmdNameObj(interp, + envPtr->literalArrayPtr[objIndex].objPtr, + cmdPtr); + } + } else { + /* Simple argument word of a command. We reach this if + * and only if the command word was not compiled for + * whatever reason. Register the literal's location + * for use by uplevel, etc. commands, should they + * encounter it unmodified. We care only if the we are + * in a context which already allows absolute + * counting. + */ + + objIndex = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); +#ifdef TCL_TIP280 + if (envPtr->clNext) { + TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr, + tokenPtr[1].start - envPtr->source, + eclPtr->loc [wlineat].next [wordIdx]); + } +#endif } + TclEmitPush(objIndex, envPtr); } else { /* - * Simple argument word of a command. We reach this if and - * only if the command word was not compiled for whatever - * reason. Register the literal's location for use by - * uplevel, etc. commands, should they encounter it - * unmodified. We care only if the we are in a context - * which already allows absolute counting. + * The word is not a simple string of characters. */ - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - - if (envPtr->clNext) { - TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr, - tokenPtr[1].start - envPtr->source, - eclPtr->loc [wlineat].next [wordIdx]); + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto log; } } - TclEmitPush(objIndex, envPtr); - } /* for loop */ + } /* - * 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. - */ - - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - TclAdjustStackDepth((1-wordIdx), envPtr); - } else if (wordIdx > 0) { + + if (wordIdx > 0) { +#ifdef TCL_TIP280 /* * Save PC -> command map for the TclArgumentBC* functions. */ @@ -1556,8 +1364,8 @@ TclCompileScript( int isnew; Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, (char*) (envPtr->codeNext - envPtr->codeStart), &isnew); - Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); - + Tcl_SetHashValue(hePtr, (char*) wlineat); +#endif if (wordIdx <= 255) { TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); } else { @@ -1570,57 +1378,115 @@ TclCompileScript( * offsets of the source and code for the command. */ - finishCommand: + finishCommand: EnterCmdExtentData(envPtr, currCmdIndex, commandLength, (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); isFirstCmd = 0; - /* - * TIP #280: Free full form of per-word line data and insert the - * reduced form now +#ifdef TCL_TIP280 + /* TIP #280: Free full form of per-word line data and insert + * the reduced form now */ - - ckfree((char *) eclPtr->loc[wlineat].line); - ckfree((char *) eclPtr->loc[wlineat].next); - eclPtr->loc[wlineat].line = wlines; - eclPtr->loc[wlineat].next = NULL; - } /* end if parsePtr->numWords > 0 */ + ckfree ((char*) eclPtr->loc [wlineat].line); + ckfree ((char*) eclPtr->loc [wlineat].next); + eclPtr->loc [wlineat].line = wlines; + eclPtr->loc [wlineat].next = NULL; + wlines = NULL; +#endif + } /* end if parse.numWords > 0 */ /* * Advance to the next command in the script. */ - next = parsePtr->commandStart + parsePtr->commandSize; - bytesLeft -= next - p; + next = parse.commandStart + parse.commandSize; + bytesLeft -= (next - p); p = next; - - /* - * TIP #280: Track lines in the just compiled command. - */ - - TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); +#ifdef TCL_TIP280 + /* TIP #280 : Track lines in the just compiled command */ + TclAdvanceLines (&cmdLine, parse.commandStart, p); TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source); - Tcl_FreeParse(parsePtr); +#endif + Tcl_FreeParse(&parse); + gotParse = 0; + if (nested && (*parse.term == ']')) { + /* + * We get here in the special case where TCL_BRACKET_TERM was + * set in the interpreter and the latest parsed command was + * terminated by the matching close-bracket we were looking for. + * Stop compilation. + */ + + break; + } } while (bytesLeft > 0); /* * If the source script yielded no instructions (e.g., if it was empty), * push an empty string as the command's result. - * - * WARNING: push an unshared object! If the script being compiled is a - * shared empty string, it will otherwise be self-referential and cause - * difficulties with literal management [Bugs 467523, 983660]. We used to - * have special code in TclReleaseLiteral to handle this particular - * self-reference, but now opt for avoiding its creation altogether. */ - + if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), + envPtr); + } + + if (nested) { + /* + * When (nested != 0) back up 1 character to have + * iPtr->termOffset indicate the offset to the matching + * close-bracket. + */ + + iPtr->termOffset = (p - 1) - script; + } else { + iPtr->termOffset = (p - script); + } + Tcl_DStringFree(&ds); + return TCL_OK; + + error: + /* + * Generate various pieces of error information, such as the line + * number where the error occurred and information to add to the + * errorInfo variable. Then free resources that had been allocated + * to the command. + */ + + commandLength = parse.commandSize; + if (parse.term == parse.commandStart + commandLength - 1) { + /* + * The terminator character (such as ; or ]) of the command where + * the error occurred is the last character in the parsed command. + * Reduce the length by one so that the error message doesn't + * include the terminator character. + */ + + commandLength -= 1; + } + + log: +#ifdef TCL_TIP280 + /* TIP #280: Free the per-word line data left over from parsing an + * erroneous command, if any. + */ + if (wlines) { + ckfree ((char*) eclPtr->loc [wlineat].line); + ckfree ((char*) eclPtr->loc [wlineat].next); + ckfree ((char*) wlines); + eclPtr->loc [wlineat].line = NULL; + eclPtr->loc [wlineat].next = NULL; + wlines = NULL; } +#endif - envPtr->numSrcBytes = (p - script); - TclStackFree(interp, parsePtr); + LogCompilationInfo(interp, script, parse.commandStart, commandLength); + if (gotParse) { + Tcl_FreeParse(&parse); + } + iPtr->termOffset = (p - script); Tcl_DStringFree(&ds); + return code; } /* @@ -1629,37 +1495,38 @@ TclCompileScript( * 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. * *---------------------------------------------------------------------- */ -void -TclCompileTokens( - Tcl_Interp *interp, /* Used for error and status reporting. */ - Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to - * compile. */ - int count, /* Number of tokens to consider at tokenPtr. +int +TclCompileTokens(interp, tokenPtr, count, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * to compile. */ + int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - const char *name, *p; + CONST char *name, *p; int numObjsToConcat, nameBytes, localVarName, localVar; - int length, i; + int length, i, code; unsigned char *entryCodeNext = envPtr->codeNext; +#ifdef TCL_TIP280 #define NUM_STATIC_POS 20 int isLiteral, maxNumCL, numCL; int* clPosition = NULL; @@ -1672,7 +1539,7 @@ TclCompileTokens( * any. The table is extended if needed. * * Note: Different to the equivalent code in function - * 'TclSubstTokens()' (see file "tclParse.c") we do not seem to need + * 'EvalTokensStandard()' (see file "tclBasic.c") we do not seem to need * the 'adjust' variable. We also do not seem to need code which merges * continuation line information of multiple words which concat'd at * runtime. Either that or I have not managed to find a test case for @@ -1695,166 +1562,186 @@ TclCompileTokens( maxNumCL = NUM_STATIC_POS; clPosition = (int*) ckalloc (maxNumCL*sizeof(int)); } +#endif Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { - case TCL_TOKEN_TEXT: - Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); - break; + case TCL_TOKEN_TEXT: + Tcl_DStringAppend(&textBuffer, tokenPtr->start, + tokenPtr->size); + break; - case TCL_TOKEN_BS: - length = TclParseBackslash(tokenPtr->start, tokenPtr->size, - NULL, buffer); - Tcl_DStringAppend(&textBuffer, buffer, length); + case TCL_TOKEN_BS: + length = TclParseBackslash(tokenPtr->start, tokenPtr->size, + (int *) NULL, buffer); + Tcl_DStringAppend(&textBuffer, buffer, length); - /* - * If the backslash sequence we found is in a literal, and - * represented a continuation line, we compute and store its - * location (as char offset to the beginning of the _result_ - * script). We may have to extend the table of locations. - * - * Note that the continuation line information is relevant even if - * the word we are processing is not a literal, as it can affect - * nested commands. See the branch for TCL_TOKEN_COMMAND below, - * where the adjustment we are tracking here is taken into - * account. The good thing is that we do not need a table of - * everything, just the number of lines we have to add as - * correction. - */ +#ifdef TCL_TIP280 + /* + * If the backslash sequence we found is in a literal, and + * represented a continuation line, we compute and store its + * location (as char offset to the beginning of the _result_ + * script). We may have to extend the table of locations. + * + * Note that the continuation line information is relevant + * even if the word we are processing is not a literal, as it + * can affect nested commands. See the branch for + * TCL_TOKEN_COMMAND below, where the adjustment we are + * tracking here is taken into account. The good thing is that + * we do not need a table of everything, just the number of + * lines we have to add as correction. + */ - if ((length == 1) && (buffer[0] == ' ') && - (tokenPtr->start[1] == '\n')) { - if (isLiteral) { - int clPos = Tcl_DStringLength (&textBuffer); + if ((length == 1) && (buffer[0] == ' ') && + (tokenPtr->start[1] == '\n')) { + if (isLiteral) { + int clPos = Tcl_DStringLength (&textBuffer); - if (numCL >= maxNumCL) { - maxNumCL *= 2; - clPosition = (int*) ckrealloc ((char*)clPosition, - maxNumCL*sizeof(int)); + if (numCL >= maxNumCL) { + maxNumCL *= 2; + clPosition = (int*) ckrealloc ((char*)clPosition, + maxNumCL*sizeof(int)); + } + clPosition[numCL] = clPos; + numCL ++; } - clPosition[numCL] = clPos; - numCL ++; } - } - break; - - case TCL_TOKEN_COMMAND: - /* - * Push any accumulated chars appearing before the command. - */ - - if (Tcl_DStringLength(&textBuffer) > 0) { - int literal = TclRegisterNewLiteral(envPtr, - Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); - - TclEmitPush(literal, envPtr); - numObjsToConcat++; - Tcl_DStringFree(&textBuffer); +#endif + break; - if (numCL) { - TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, - numCL, clPosition); + case TCL_TOKEN_COMMAND: + /* + * Push any accumulated chars appearing before the command. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + Tcl_DStringFree(&textBuffer); +#ifdef TCL_TIP280 + if (numCL) { + TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, + numCL, clPosition); + } + numCL = 0; +#endif + } + + code = TclCompileScript(interp, tokenPtr->start+1, + tokenPtr->size-2, /*nested*/ 0, envPtr); + if (code != TCL_OK) { + goto error; } - numCL = 0; - } - - 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). - */ + break; - 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; + case TCL_TOKEN_VARIABLE: + /* + * Push any accumulated chars appearing before the $<var>. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + Tcl_DStringFree(&textBuffer); + } + + /* + * Determine how the variable name should be handled: if it contains + * any namespace qualifiers it is not a local variable (localVarName=-1); + * if it looks like an array element and the token has a single component, + * it should not be created here [Bug 569438] (localVarName=0); otherwise, + * the local variable can safely be created (localVarName=1). + */ + + name = tokenPtr[1].start; + nameBytes = tokenPtr[1].size; + localVarName = -1; + if (envPtr->procPtr != NULL) { + localVarName = 1; + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < (nameBytes-1)) + && (*(p+1) == ':')) { + localVarName = -1; + break; + } else if ((*p == '(') + && (tokenPtr->numComponents == 1) + && (*(name + nameBytes - 1) == ')')) { + localVarName = 0; + break; + } } } - } - - /* - * Either push the variable's name, or find its index in the array - * of local variables in a procedure frame. - */ - localVar = -1; - if (localVarName != -1) { - localVar = TclFindCompiledLocal(name, nameBytes, localVarName, - envPtr->procPtr); - } - if (localVar < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), - envPtr); - } - - /* - * Emit instructions to load the variable. - */ + /* + * Either push the variable's name, or find its index in + * the array of local variables in a procedure frame. + */ - 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); + localVar = -1; + if (localVarName != -1) { + localVar = TclFindCompiledLocal(name, nameBytes, + localVarName, /*flags*/ 0, envPtr->procPtr); } - } 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); + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), + envPtr); + } + + /* + * Emit instructions to load the variable. + */ + + if (tokenPtr->numComponents == 1) { + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, + envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, + envPtr); + } } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); + code = TclCompileTokens(interp, tokenPtr+2, + tokenPtr->numComponents-1, envPtr); + if (code != TCL_OK) { + char errorBuffer[150]; + sprintf(errorBuffer, + "\n (parsing index for array \"%.*s\")", + ((nameBytes > 100)? 100 : nameBytes), name); + Tcl_AddObjErrorInfo(interp, errorBuffer, -1); + goto error; + } + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, + envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, + envPtr); + } } - } - numObjsToConcat++; - count -= tokenPtr->numComponents; - tokenPtr += tokenPtr->numComponents; - break; + numObjsToConcat++; + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; - default: - Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s", - tokenPtr->type, tokenPtr->size, tokenPtr->start); + default: + panic("Unexpected token type in TclCompileTokens"); } } @@ -1865,16 +1752,18 @@ TclCompileTokens( if (Tcl_DStringLength(&textBuffer) > 0) { int literal; - literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); + literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); TclEmitPush(literal, envPtr); numObjsToConcat++; +#ifdef TCL_TIP280 if (numCL) { TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, numCL, clPosition); } numCL = 0; +#endif } /* @@ -1892,12 +1781,16 @@ TclCompileTokens( /* * If the tokens yielded no instructions, push an empty string. */ - + if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), + envPtr); } - Tcl_DStringFree(&textBuffer); + code = TCL_OK; + error: + Tcl_DStringFree(&textBuffer); +#ifdef TCL_TIP280 /* * Release the temp table we used to collect the locations of * continuation lines, if any. @@ -1906,6 +1799,8 @@ TclCompileTokens( if (maxNumCL) { ckfree ((char*) clPosition); } +#endif + return code; } /* @@ -1916,45 +1811,53 @@ TclCompileTokens( * 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. * *---------------------------------------------------------------------- */ -void -TclCompileCmdWord( - Tcl_Interp *interp, /* Used for error and status reporting. */ - Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for - * a command word to compile inline. */ - int count, /* Number of tokens to consider at tokenPtr. +int +TclCompileCmdWord(interp, tokenPtr, count, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * for a command word to compile inline. */ + int count; /* Number of tokens to consider at tokenPtr. * Must be at least 1. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ { + int code; + + /* + * Handle the common case: if there is a single text token, compile it + * into an inline sequence of instructions. + */ + if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { - /* - * Handle the common case: if there is a single text token, compile it - * into an inline sequence of instructions. - */ + code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, + /*nested*/ 0, envPtr); + return code; + } - 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); - TclEmitOpcode(INST_EVAL_STK, envPtr); + code = TclCompileTokens(interp, tokenPtr, count, envPtr); + if (code != TCL_OK) { + return code; } + TclEmitOpcode(INST_EVAL_STK, envPtr); + return TCL_OK; } /* @@ -1971,37 +1874,42 @@ TclCompileCmdWord( * Results: * The return value is a standard Tcl result. If an error occurs, an * error message is left in the interpreter's result. - * + * * Side effects: * Instructions are added to envPtr to execute the expression. * *---------------------------------------------------------------------- */ -void -TclCompileExprWords( - Tcl_Interp *interp, /* Used for error and status reporting. */ - Tcl_Token *tokenPtr, /* Points to first in an array of word tokens - * tokens for the expression to compile - * inline. */ - int numWords, /* Number of word tokens starting at tokenPtr. - * Must be at least 1. Each word token - * contains one or more subtokens. */ - CompileEnv *envPtr) /* Holds the resulting instructions. */ +int +TclCompileExprWords(interp, tokenPtr, numWords, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Points to first in an array of word + * tokens tokens for the expression to + * compile inline. */ + int numWords; /* Number of word tokens starting at + * tokenPtr. Must be at least 1. Each word + * token contains one or more subtokens. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ { Tcl_Token *wordPtr; - int i, concatItems; + int numBytes, i, code; + CONST char *script; + + code = TCL_OK; /* - * 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)) { - TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr, 1); - return; + script = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + code = TclCompileExpr(interp, script, numBytes, envPtr); + return code; } - + /* * Emit code to call the expr command proc at runtime. Concatenate the * (already substituted once) expr tokens with a space between each. @@ -2009,68 +1917,30 @@ TclCompileExprWords( wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { - TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); + code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, + envPtr); + if (code != TCL_OK) { + break; + } if (i < (numWords - 1)) { - TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); + TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0), + envPtr); } wordPtr += (wordPtr->numComponents + 1); } - concatItems = 2*numWords - 1; - while (concatItems > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); - concatItems -= 254; - } - if (concatItems > 1) { - TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); - } - TclEmitOpcode(INST_EXPR_STK, envPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclCompileNoOp -- - * - * Function called to compile no-op's - * - * Results: - * The return value is TCL_OK, indicating successful compilation. - * - * Side effects: - * Instructions are added to envPtr to execute a no-op at runtime. No - * result is pushed onto the stack: the compiler has to take care of this - * itself if the last compiled command is a NoOp. - * - *---------------------------------------------------------------------- - */ - -int -TclCompileNoOp( - Tcl_Interp *interp, /* Used for error reporting. */ - Tcl_Parse *parsePtr, /* Points to a parse structure for the command - * created by Tcl_ParseCommand. */ - Command *cmdPtr, /* Points to defintion of command being - * compiled. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ -{ - Tcl_Token *tokenPtr; - int i; - int savedStackDepth = envPtr->currStackDepth; - - tokenPtr = parsePtr->tokenPtr; - for(i = 1; i < parsePtr->numWords; i++) { - tokenPtr = tokenPtr + tokenPtr->numComponents + 1; - envPtr->currStackDepth = savedStackDepth; - - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, - envPtr); - TclEmitOpcode(INST_POP, envPtr); + if (code == TCL_OK) { + int concatItems = 2*numWords - 1; + while (concatItems > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + concatItems -= 254; + } + if (concatItems > 1) { + TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); } + TclEmitOpcode(INST_EXPR_STK, envPtr); } - envPtr->currStackDepth = savedStackDepth; - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); - return TCL_OK; + + return code; } /* @@ -2079,10 +1949,10 @@ TclCompileNoOp( * 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 @@ -2090,21 +1960,21 @@ TclCompileNoOp( * * 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( - 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. */ +TclInitByteCodeObj(objPtr, envPtr) + Tcl_Obj *objPtr; /* Points object that should be + * initialized, and whose string rep + * contains the source code. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure from + * which to create a ByteCode structure. */ { register ByteCode *codePtr; size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; @@ -2115,7 +1985,10 @@ TclInitByteCodeObj( #endif int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; - int i, isNew; + int i; +#ifdef TCL_TIP280 + int new; +#endif Interp *iPtr; iPtr = envPtr->iPtr; @@ -2125,24 +1998,24 @@ TclInitByteCodeObj( 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); @@ -2150,11 +2023,7 @@ TclInitByteCodeObj( codePtr->nsPtr = namespacePtr; codePtr->nsEpoch = namespacePtr->resolverEpoch; codePtr->refCount = 1; - if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { - codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; - } else { - codePtr->flags = 0; - } + codePtr->flags = 0; codePtr->source = envPtr->source; codePtr->procPtr = envPtr->procPtr; @@ -2170,26 +2039,28 @@ TclInitByteCodeObj( p += sizeof(ByteCode); codePtr->codeStart = p; - memcpy(p, envPtr->codeStart, (size_t) codeBytes); - - p += TCL_ALIGN(codeBytes); /* align object array */ + memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); + + p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; } - p += TCL_ALIGN(objArrayBytes); /* align exception range array */ + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; - memcpy(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); + memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr, + (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(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); + memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, + (size_t) auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } @@ -2199,11 +2070,11 @@ TclInitByteCodeObj( EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); - if (((size_t)(nextPtr - p)) != cmdLocBytes) { - Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d", (nextPtr - p), cmdLocBytes); + if (((size_t)(nextPtr - p)) != cmdLocBytes) { + panic("TclInitByteCodeObj: encoded cmd location bytes %ld != expected size %ld\n", (nextPtr - p), cmdLocBytes); } #endif - + /* * Record various compilation-related statistics about the new ByteCode * structure. Don't include overhead for statistics-related fields. @@ -2213,29 +2084,115 @@ TclInitByteCodeObj( 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; + + if ((objPtr->typePtr != NULL) && + (objPtr->typePtr->freeIntRepProc != NULL)) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + objPtr->internalRep.otherValuePtr = (VOID *) codePtr; objPtr->typePtr = &tclByteCodeType; - /* - * TIP #280. Associate the extended per-word line information with the +#ifdef TCL_TIP280 + /* TIP #280. Associate the extended per-word line information with the * byte code object (internal rep), for use with the bc compiler. */ - Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr, - &isNew), envPtr->extCmdMapPtr); + Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->lineBCPtr, (char*) codePtr, &new), + envPtr->extCmdMapPtr); envPtr->extCmdMapPtr = NULL; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * LogCompilationInfo -- + * + * This procedure is invoked after an error occurs during compilation. + * It adds information to the "errorInfo" variable to describe the + * command that was being compiled when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo and the + * line number stored internally in the interpreter is set. If this + * is the first call to this procedure or Tcl_AddObjErrorInfo since + * an error occurred, then old information in errorInfo is + * deleted. + * + *---------------------------------------------------------------------- + */ - codePtr->localCachePtr = NULL; +static void +LogCompilationInfo(interp, script, command, length) + Tcl_Interp *interp; /* Interpreter in which to log the + * information. */ + CONST char *script; /* First character in script containing + * command (must be <= command). */ + CONST char *command; /* First character in command that + * generated the error. */ + int length; /* Number of bytes in command (-1 means + * use all bytes up to first null byte). */ +{ + char buffer[200]; + register CONST char *p; + char *ellipsis = ""; + Interp *iPtr = (Interp *) interp; + + if (iPtr->flags & ERR_ALREADY_LOGGED) { + /* + * Someone else has already logged error information for this + * command; we shouldn't add anything more. + */ + + return; + } + + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + /* + * Create an error message to add to errorInfo, including up to a + * maximum number of characters of the command. + */ + + if (length < 0) { + length = strlen(command); + } + if (length > 150) { + length = 150; + ellipsis = "..."; + } + while ( (command[length] & 0xC0) == 0x80 ) { + /* + * Back up truncation point so that we don't truncate in the + * middle of a multi-byte character (in UTF-8) + */ + length--; + ellipsis = "..."; + } + sprintf(buffer, "\n while compiling\n\"%.*s%s\"", + length, command, ellipsis); + Tcl_AddObjErrorInfo(interp, buffer, -1); } /* @@ -2252,26 +2209,30 @@ TclInitByteCodeObj( * 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( - register const char *name, /* Points to first character of the name of a - * scalar or array variable. If NULL, a +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 * temporary var should be created. */ - int nameBytes, /* Number of bytes in the name. */ - int create, /* If 1, allocate a local frame entry for the - * variable if it is new. */ - register Proc *procPtr) /* Points to structure describing procedure + int nameBytes; /* Number of bytes in the name. */ + int create; /* If 1, allocate a local frame entry for + * the variable if it is new. */ + int flags; /* Flag bits for the compiled local if + * created. Only VAR_SCALAR, VAR_ARRAY, and + * VAR_LINK make sense. */ + register Proc *procPtr; /* Points to structure describing procedure * containing the variable reference. */ { register CompiledLocal *localPtr; @@ -2283,16 +2244,14 @@ TclFindCompiledLocal( * 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; } } @@ -2303,12 +2262,12 @@ TclFindCompiledLocal( /* * Create a new variable if appropriate. */ - + if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameBytes + 1)); + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameBytes+1)); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -2318,7 +2277,7 @@ TclFindCompiledLocal( localPtr->nextPtr = NULL; localPtr->nameLength = nameBytes; localPtr->frameIndex = localVar; - localPtr->flags = 0; + localPtr->flags = flags | VAR_UNDEFINED; if (name == NULL) { localPtr->flags |= VAR_TEMPORARY; } @@ -2326,7 +2285,8 @@ TclFindCompiledLocal( localPtr->resolveInfo = NULL; if (name != NULL) { - memcpy(localPtr->name, name, (size_t) nameBytes); + memcpy((VOID *) localPtr->name, (VOID *) name, + (size_t) nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; @@ -2337,56 +2297,167 @@ TclFindCompiledLocal( /* *---------------------------------------------------------------------- * - * TclExpandCodeArray -- + * TclInitCompiledLocals -- * - * Procedure that uses malloc to allocate more storage for a CompileEnv's - * code array. + * This routine is invoked in order to initialize the compiled + * locals table for a new call frame. * * Results: * None. * * Side effects: - * The byte code array in *envPtr is reallocated to a new array of double - * the size, and if envPtr->mallocedCodeArray is non-zero the old array - * is freed. Byte codes are copied from the old array to the new one. + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. * *---------------------------------------------------------------------- */ void -TclExpandCodeArray( - void *envArgPtr) /* Points to the CompileEnv whose code array - * must be enlarged. */ +TclInitCompiledLocals(interp, framePtr, nsPtr) + Tcl_Interp *interp; /* Current interpreter. */ + CallFrame *framePtr; /* Call frame to initialize. */ + Namespace *nsPtr; /* Pointer to current namespace. */ { - CompileEnv *envPtr = (CompileEnv *) envArgPtr; - /* The CompileEnv containing the code array to - * be doubled in size. */ + register CompiledLocal *localPtr; + Interp *iPtr = (Interp*) interp; + Tcl_ResolvedVarInfo *vinfo, *resVarInfo; + Var *varPtr = framePtr->compiledLocals; + Var *resolvedVarPtr; + ResolverScheme *resPtr; + int result; /* - * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined - * code bytes are stored between envPtr->codeStart and envPtr->codeNext-1 - * [inclusive]. + * Initialize the array of local variables stored in the call frame. + * Some variables may have special resolution rules. In that case, + * we call their "resolver" procs to get our hands on the variable, + * and we make the compiled local a link to the real variable. */ - size_t currBytes = (envPtr->codeNext - envPtr->codeStart); - size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); + for (localPtr = framePtr->procPtr->firstLocalPtr; + localPtr != NULL; + localPtr = localPtr->nextPtr) { - if (envPtr->mallocedCodeArray) { - envPtr->codeStart = (unsigned char *) - ckrealloc((char *)envPtr->codeStart, newBytes); - } else { /* - * envPtr->codeStart isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. + * Check to see if this local is affected by namespace or + * interp resolvers. The resolver to use is cached for the + * next invocation of the procedure. */ - unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); - memcpy(newPtr, envPtr->codeStart, currBytes); - envPtr->codeStart = newPtr; - envPtr->mallocedCodeArray = 1; + + if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED)) + && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) { + resPtr = iPtr->resolverPtr; + + if (nsPtr->compiledVarResProc) { + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; + } + + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = (*resPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } + resPtr = resPtr->nextPtr; + } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } + + /* + * Now invoke the resolvers to determine the exact variables that + * should be used. + */ + + resVarInfo = localPtr->resolveInfo; + resolvedVarPtr = NULL; + + if (resVarInfo && resVarInfo->fetchProc) { + resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, + resVarInfo); + } + + if (resolvedVarPtr) { + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = 0; + TclSetVarLink(varPtr); + varPtr->value.linkPtr = resolvedVarPtr; + resolvedVarPtr->refCount++; + } else { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + } + varPtr++; } +} + +/* + *---------------------------------------------------------------------- + * + * TclExpandCodeArray -- + * + * Procedure that uses malloc to allocate more storage for a + * CompileEnv's code array. + * + * Results: + * None. + * + * Side effects: + * The byte code array in *envPtr is reallocated to a new array of + * double the size, and if envPtr->mallocedCodeArray is non-zero the + * old array is freed. Byte codes are copied from the old array to the + * new one. + * + *---------------------------------------------------------------------- + */ + +void +TclExpandCodeArray(envArgPtr) + void *envArgPtr; /* Points to the CompileEnv whose code array + * must be enlarged. */ +{ + CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* Points to the CompileEnv whose code array + * must be enlarged. */ + + /* + * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined + * code bytes are stored between envPtr->codeStart and + * (envPtr->codeNext - 1) [inclusive]. + */ + + size_t currBytes = (envPtr->codeNext - envPtr->codeStart); + size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); + unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); - envPtr->codeNext = (envPtr->codeStart + currBytes); - envPtr->codeEnd = (envPtr->codeStart + newBytes); + /* + * Copy from old code array to new, free old code array if needed, and + * mark new code array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); + if (envPtr->mallocedCodeArray) { + ckfree((char *) envPtr->codeStart); + } + envPtr->codeStart = newPtr; + envPtr->codeNext = (newPtr + currBytes); + envPtr->codeEnd = (newPtr + newBytes); + envPtr->mallocedCodeArray = 1; } /* @@ -2394,37 +2465,37 @@ TclExpandCodeArray( * * 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. * *---------------------------------------------------------------------- */ static void -EnterCmdStartData( - CompileEnv *envPtr, /* Points to the compilation environment +EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) + CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex, /* Index of the command whose start data is - * being set. */ - int srcOffset, /* Offset of first char of the command. */ - int codeOffset) /* Offset of first byte of command code. */ + int cmdIndex; /* Index of the command whose start data + * is being set. */ + int srcOffset; /* Offset of first char of the command. */ + int codeOffset; /* Offset of first byte of command code. */ { CmdLocation *cmdLocPtr; - + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex); + panic("EnterCmdStartData: bad command index %d\n", cmdIndex); } - + if (cmdIndex >= envPtr->cmdMapEnd) { /* * Expand the command location array by allocating more storage from @@ -2433,29 +2504,28 @@ EnterCmdStartData( */ 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) { - envPtr->cmdMapPtr = (CmdLocation *) - ckrealloc((char *) envPtr->cmdMapPtr, newBytes); - } else { - /* - * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. - */ - CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); - memcpy(newPtr, envPtr->cmdMapPtr, currBytes); - envPtr->cmdMapPtr = newPtr; - envPtr->mallocedCmdMap = 1; + ckfree((char *) envPtr->cmdMapPtr); } + envPtr->cmdMapPtr = (CmdLocation *) newPtr; envPtr->cmdMapEnd = newElems; + envPtr->mallocedCmdMap = 1; } if (cmdIndex > 0) { if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { - Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset"); + panic("EnterCmdStartData: cmd map not sorted by code offset"); } } @@ -2480,32 +2550,32 @@ EnterCmdStartData( * * 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. * *---------------------------------------------------------------------- */ static void -EnterCmdExtentData( - CompileEnv *envPtr, /* Points to the compilation environment +EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) + CompileEnv *envPtr; /* Points to the compilation environment * structure in which to enter command * location information. */ - int cmdIndex, /* Index of the command whose source and code - * length data is being set. */ - int numSrcBytes, /* Number of command source chars. */ - int numCodeBytes) /* Offset of last byte of command code. */ + int cmdIndex; /* Index of the command whose source and + * code length data is being set. */ + int numSrcBytes; /* Number of command source chars. */ + int numCodeBytes; /* Offset of last byte of command code. */ { CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex); + panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); } - + if (cmdIndex > envPtr->cmdMapEnd) { - Tcl_Panic("EnterCmdExtentData: missing start data for command %d", - cmdIndex); + panic("EnterCmdExtentData: missing start data for command %d\n", + cmdIndex); } cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); @@ -2513,86 +2583,105 @@ EnterCmdExtentData( cmdLocPtr->numCodeBytes = numCodeBytes; } +#ifdef TCL_TIP280 /* *---------------------------------------------------------------------- * TIP #280 * * EnterCmdWordData -- * - * Registers the lines for the words of a command. This information is - * used at runtime by 'info frame'. + * Registers the lines for the words of a command. This information + * is used at runtime by 'info frame'. * * Results: * None. * * Side effects: - * Inserts word location information into the compilation environment - * envPtr for the command at index cmdIndex. The compilation - * environment's ExtCmdLoc.ECL array is grown if necessary. + * Inserts word location information into the compilation + * environment envPtr for the command at index cmdIndex. The + * compilation environment's ExtCmdLoc.ECL array is grown if necessary. * *---------------------------------------------------------------------- */ static void -EnterCmdWordData( - ExtCmdLoc *eclPtr, /* Points to the map environment structure in - * which to enter command location - * information. */ - int srcOffset, /* Offset of first char of the command. */ - Tcl_Token *tokenPtr, - const char *cmd, - int len, - int numWords, - int line, - int* clNext, - int **wlines, - CompileEnv* envPtr) -{ - ECL *ePtr; - const char *last; - int wordIdx, wordLine, *wwlines; - int* wordNext; +EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, clNext, wlines, envPtr) + ExtCmdLoc *eclPtr; /* Points to the map environment + * structure in which to enter command + * location information. */ + int srcOffset; /* Offset of first char of the command. */ + Tcl_Token* tokenPtr; + CONST char* cmd; + int len; + int numWords; + int line; + int* clNext; + int** wlines; + CompileEnv* envPtr; +{ + ECL* ePtr; + int wordIdx; + CONST char* last; + int wordLine; + int* wordNext; + int* wwlines; if (eclPtr->nuloc >= eclPtr->nloc) { /* - * Expand the ECL array by allocating more storage from the heap. The - * currently allocated ECL entries are stored from eclPtr->loc[0] up - * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). + * Expand the ECL array by allocating more storage from the + * heap. The currently allocated ECL entries are stored from + * eclPtr->loc[0] up to eclPtr->loc[eclPtr->nuloc-1] (inclusive). */ size_t currElems = eclPtr->nloc; - size_t newElems = (currElems ? 2*currElems : 1); - size_t newBytes = newElems * sizeof(ECL); + size_t newElems = (currElems ? 2*currElems : 1); + size_t currBytes = currElems * sizeof(ECL); + size_t newBytes = newElems * sizeof(ECL); + ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes); - eclPtr->loc = (ECL *) ckrealloc((char *)(eclPtr->loc), newBytes); + /* + * Copy from old ECL array to new, free old ECL array if + * needed. + */ + + if (currBytes) { + memcpy((VOID *) newPtr, (VOID *) eclPtr->loc, currBytes); + } + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); + } + eclPtr->loc = (ECL *) newPtr; eclPtr->nloc = newElems; } - ePtr = &eclPtr->loc[eclPtr->nuloc]; + ePtr = &eclPtr->loc [eclPtr->nuloc]; ePtr->srcOffset = srcOffset; - ePtr->line = (int *) ckalloc(numWords * sizeof(int)); - ePtr->next = (int**) ckalloc (numWords * sizeof (int*)); - ePtr->nline = numWords; - wwlines = (int *) ckalloc(numWords * sizeof(int)); + ePtr->line = (int*) ckalloc (numWords * sizeof (int)); + ePtr->next = (int**) ckalloc (numWords * sizeof (int*)); + ePtr->nline = numWords; + wwlines = (int*) ckalloc (numWords * sizeof (int)); - last = cmd; + last = cmd; wordLine = line; wordNext = clNext; - for (wordIdx=0 ; wordIdx<numWords; - wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + for (wordIdx = 0; + wordIdx < numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { TclAdvanceLines (&wordLine, last, tokenPtr->start); TclAdvanceContinuations (&wordLine, &wordNext, tokenPtr->start - envPtr->source); - wwlines[wordIdx] = - (TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1); - ePtr->line[wordIdx] = wordLine; - ePtr->next[wordIdx] = wordNext; + wwlines [wordIdx] = (TclWordKnownAtCompileTime (tokenPtr) + ? wordLine + : -1); + ePtr->line [wordIdx] = wordLine; + ePtr->next [wordIdx] = wordNext; last = tokenPtr->start; } *wlines = wwlines; eclPtr->nuloc ++; } +#endif /* *---------------------------------------------------------------------- @@ -2606,53 +2695,55 @@ EnterCmdWordData( * 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. * *---------------------------------------------------------------------- */ int -TclCreateExceptRange( - ExceptionRangeType type, /* The kind of ExceptionRange desired. */ - register CompileEnv *envPtr)/* Points to CompileEnv for which to create a - * new ExceptionRange structure. */ +TclCreateExceptRange(type, envPtr) + ExceptionRangeType type; /* The kind of ExceptionRange desired. */ + register CompileEnv *envPtr;/* Points to CompileEnv for which to + * create a new ExceptionRange structure. */ { register ExceptionRange *rangePtr; int index = envPtr->exceptArrayNext; - + if (index >= envPtr->exceptArrayEnd) { - /* + /* * Expand the ExceptionRange array. The currently allocated entries * are stored between elements 0 and (envPtr->exceptArrayNext - 1) * [inclusive]. */ - + size_t currBytes = - envPtr->exceptArrayNext * sizeof(ExceptionRange); + envPtr->exceptArrayNext * sizeof(ExceptionRange); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); - + ExceptionRange *newPtr = (ExceptionRange *) + ckalloc((unsigned) newBytes); + + /* + * Copy from old ExceptionRange array to new, free old + * ExceptionRange array if needed, and mark the new ExceptionRange + * array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, + currBytes); if (envPtr->mallocedExceptArray) { - envPtr->exceptArrayPtr = (ExceptionRange *) - ckrealloc((char *)(envPtr->exceptArrayPtr), newBytes); - } else { - /* - * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. - */ - ExceptionRange *newPtr = (ExceptionRange *) - ckalloc((unsigned) newBytes); - memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); - envPtr->exceptArrayPtr = newPtr; - envPtr->mallocedExceptArray = 1; + ckfree((char *) envPtr->exceptArrayPtr); } + envPtr->exceptArrayPtr = (ExceptionRange *) newPtr; envPtr->exceptArrayEnd = newElems; + envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayNext++; - + rangePtr = &(envPtr->exceptArrayPtr[index]); rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; @@ -2669,8 +2760,8 @@ TclCreateExceptRange( * * 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. * @@ -2678,57 +2769,56 @@ TclCreateExceptRange( * 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 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 +TclCreateAuxData(clientData, typePtr, envPtr) + ClientData clientData; /* The compilation auxiliary data to store + * in the new aux data record. */ + AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ + register CompileEnv *envPtr;/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { int index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; /* Points to the new AuxData structure */ - + index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { - /* + /* * Expand the AuxData array. The currently allocated entries are * stored between elements 0 and (envPtr->auxDataArrayNext - 1) * [inclusive]. */ - + size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); int newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); - + AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); + + /* + * Copy from old AuxData array to new, free old AuxData array if + * needed, and mark the new AuxData array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, + currBytes); if (envPtr->mallocedAuxDataArray) { - envPtr->auxDataArrayPtr = (AuxData *) - ckrealloc((char *)(envPtr->auxDataArrayPtr), newBytes); - } else { - /* - * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. - */ - AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); - memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); - envPtr->auxDataArrayPtr = newPtr; - envPtr->mallocedAuxDataArray = 1; + ckfree((char *) envPtr->auxDataArrayPtr); } + envPtr->auxDataArrayPtr = newPtr; envPtr->auxDataArrayEnd = newElems; + envPtr->mallocedAuxDataArray = 1; } envPtr->auxDataArrayNext++; - + auxDataPtr = &(envPtr->auxDataArrayPtr[index]); auxDataPtr->clientData = clientData; auxDataPtr->type = typePtr; @@ -2740,8 +2830,8 @@ TclCreateAuxData( * * 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. @@ -2753,10 +2843,10 @@ TclCreateAuxData( */ void -TclInitJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure to - * initialize. */ +TclInitJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to initialize. */ { fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; fixupArrayPtr->next = 0; @@ -2769,8 +2859,8 @@ TclInitJumpFixupArray( * * 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. @@ -2778,42 +2868,41 @@ TclInitJumpFixupArray( * 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. * *---------------------------------------------------------------------- */ void -TclExpandJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure - * to enlarge. */ +TclExpandJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to enlarge. */ { /* - * The currently allocated jump fixup entries are stored from fixup[0] up - * to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume + * The currently allocated jump fixup entries are stored from fixup[0] + * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. */ size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); int newElems = 2*(fixupArrayPtr->end + 1); size_t newBytes = newElems * sizeof(JumpFixup); + JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); + /* + * Copy from the old array to new, free the old array if needed, + * and mark the new array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); if (fixupArrayPtr->mallocedArray) { - fixupArrayPtr->fixup = (JumpFixup *) - ckrealloc((char *)(fixupArrayPtr->fixup), newBytes); - } else { - /* - * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must - * code a ckrealloc equivalent for ourselves. - */ - JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); - memcpy(newPtr, fixupArrayPtr->fixup, currBytes); - fixupArrayPtr->fixup = newPtr; - fixupArrayPtr->mallocedArray = 1; + ckfree((char *) fixupArrayPtr->fixup); } + fixupArrayPtr->fixup = (JumpFixup *) newPtr; fixupArrayPtr->end = newElems; + fixupArrayPtr->mallocedArray = 1; } /* @@ -2833,10 +2922,10 @@ TclExpandJumpFixupArray( */ void -TclFreeJumpFixupArray( - register JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure to - * free. */ +TclFreeJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to free. */ { if (fixupArrayPtr->mallocedArray) { ckfree((char *) fixupArrayPtr->fixup); @@ -2851,27 +2940,27 @@ TclFreeJumpFixupArray( * 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. * *---------------------------------------------------------------------- */ void -TclEmitForwardJump( - CompileEnv *envPtr, /* Points to the CompileEnv structure that +TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) + CompileEnv *envPtr; /* Points to the CompileEnv structure that * holds the resulting instruction. */ - TclJumpType jumpType, /* Indicates the kind of jump: if true or + TclJumpType jumpType; /* Indicates the kind of jump: if true or * false or unconditional. */ - JumpFixup *jumpFixupPtr) /* Points to the JumpFixup structure to + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to * initialize with information about this * forward jump. */ { @@ -2879,15 +2968,15 @@ TclEmitForwardJump( * 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); @@ -2906,41 +2995,43 @@ TclEmitForwardJump( * * 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. * *---------------------------------------------------------------------- */ int -TclFixupForwardJump( - CompileEnv *envPtr, /* Points to the CompileEnv structure that +TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) + CompileEnv *envPtr; /* Points to the CompileEnv structure that * holds the resulting instruction. */ - JumpFixup *jumpFixupPtr, /* Points to the JumpFixup structure that + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that * describes the forward jump. */ - int jumpDist, /* Jump distance to set in jump instr. */ - int distThreshold) /* Maximum distance before the two byte jump - * is grown to five bytes. */ + int jumpDist; /* Jump distance to set in jump + * instruction. */ + int distThreshold; /* Maximum distance before the two byte + * jump is grown to five bytes. */ { unsigned char *jumpPc, *p; int firstCmd, lastCmd, firstRange, lastRange, k; - unsigned numBytes; - + unsigned int numBytes; + if (jumpDist <= distThreshold) { jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); switch (jumpFixupPtr->jumpType) { @@ -2958,14 +3049,14 @@ TclFixupForwardJump( } /* - * 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); numBytes = envPtr->codeNext-jumpPc-2; @@ -2985,26 +3076,26 @@ TclFixupForwardJump( 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; @@ -3016,74 +3107,10 @@ TclFixupForwardJump( rangePtr->catchOffset += 3; break; default: - Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d", - rangePtr->type); + panic("TclFixupForwardJump: bad ExceptionRange type %d\n", + rangePtr->type); } } - - /* - * TIP #280: Adjust the mapping from PC values to the per-command - * information about arguments and their line numbers. - * - * Note: We cannot simply remove an out-of-date entry and then reinsert - * with the proper PC, because then we might overwrite another entry which - * was at that location. Therefore we pull (copy + delete) all effected - * entries (beyond the fixed PC) into an array, update them there, and at - * last reinsert them all. - */ - - { - ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; - - /* A helper structure */ - - typedef struct { - int pc; - int cmd; - } MAP; - - /* - * And the helper array. At most the whole hashtable is placed into - * this. - */ - - MAP *map = (MAP*) ckalloc (sizeof(MAP) * eclPtr->litInfo.numEntries); - - Tcl_HashSearch hSearch; - Tcl_HashEntry* hPtr; - int n, k, isnew; - - /* - * Phase I: Locate the affected entries, and save them in adjusted - * form to the array. This removes them from the hash. - */ - - for (n = 0, hPtr = Tcl_FirstHashEntry(&eclPtr->litInfo, &hSearch); - hPtr != NULL; - hPtr = Tcl_NextHashEntry(&hSearch)) { - - map [n].cmd = PTR2INT(Tcl_GetHashValue(hPtr)); - map [n].pc = PTR2INT(Tcl_GetHashKey (&eclPtr->litInfo,hPtr)); - - if (map[n].pc >= (jumpFixupPtr->codeOffset + 2)) { - Tcl_DeleteHashEntry(hPtr); - map [n].pc += 3; - n++; - } - } - - /* - * Phase II: Re-insert the modified entries into the hash. - */ - - for (k=0;k<n;k++) { - hPtr = Tcl_CreateHashEntry(&eclPtr->litInfo, INT2PTR(map[k].pc), &isnew); - Tcl_SetHashValue(hPtr, INT2PTR(map[k].cmd)); - } - - ckfree ((char *) map); - } - return 1; /* the jump was grown */ } @@ -3092,9 +3119,9 @@ TclFixupForwardJump( * * 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 @@ -3107,7 +3134,7 @@ TclFixupForwardJump( */ void * /* == InstructionDesc* == */ -TclGetInstructionTable(void) +TclGetInstructionTable() { return &tclInstructionTable[0]; } @@ -3117,32 +3144,32 @@ TclGetInstructionTable(void) * * 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( - AuxDataType *typePtr) /* Information about object type; storage must - * be statically allocated (must live forever; - * will not be deallocated). */ +TclRegisterAuxDataType(typePtr) + AuxDataType *typePtr; /* Information about object type; + * storage must be statically + * allocated (must live forever). */ { register Tcl_HashEntry *hPtr; - int isNew; + int new; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); + TclInitAuxDataTypeTable(); } /* @@ -3150,17 +3177,17 @@ TclRegisterAuxDataType( */ hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); - if (hPtr != NULL) { - Tcl_DeleteHashEntry(hPtr); + if (hPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(hPtr); } /* * Now insert the new object type. */ - hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &isNew); - if (isNew) { - Tcl_SetHashValue(hPtr, typePtr); + hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); + if (new) { + Tcl_SetHashValue(hPtr, typePtr); } Tcl_MutexUnlock(&tableMutex); } @@ -3183,20 +3210,20 @@ TclRegisterAuxDataType( */ AuxDataType * -TclGetAuxDataType( - char *typeName) /* Name of AuxData type to look up. */ +TclGetAuxDataType(typeName) + char *typeName; /* Name of AuxData type to look up. */ { register Tcl_HashEntry *hPtr; AuxDataType *typePtr = NULL; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { - TclInitAuxDataTypeTable(); + TclInitAuxDataTypeTable(); } hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); - if (hPtr != NULL) { - typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); @@ -3208,8 +3235,8 @@ TclGetAuxDataType( * * 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: @@ -3223,7 +3250,7 @@ TclGetAuxDataType( */ void -TclInitAuxDataTypeTable(void) +TclInitAuxDataTypeTable() { /* * The table mutex must already be held before this routine is invoked. @@ -3233,11 +3260,10 @@ TclInitAuxDataTypeTable(void) Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); /* - * There are only two AuxData type at this time, so register them here. + * There is only one AuxData type at this time, so register it here. */ TclRegisterAuxDataType(&tclForeachInfoType); - TclRegisterAuxDataType(&tclJumptableInfoType); } /* @@ -3245,10 +3271,10 @@ TclInitAuxDataTypeTable(void) * * 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. @@ -3260,12 +3286,12 @@ TclInitAuxDataTypeTable(void) */ void -TclFinalizeAuxDataTypeTable(void) +TclFinalizeAuxDataTypeTable() { Tcl_MutexLock(&tableMutex); if (auxDataTypeTableInitialized) { - Tcl_DeleteHashTable(&auxDataTypeTable); - auxDataTypeTableInitialized = 0; + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; } Tcl_MutexUnlock(&tableMutex); } @@ -3288,18 +3314,18 @@ TclFinalizeAuxDataTypeTable(void) */ static int -GetCmdLocEncodingSize( - CompileEnv *envPtr) /* Points to compilation environment structure - * containing the CmdLocation structure to - * encode. */ +GetCmdLocEncodingSize(envPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ { register CmdLocation *mapPtr = envPtr->cmdMapPtr; int numCmds = envPtr->numCommands; int codeDelta, codeLen, srcDelta, srcLen; int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; /* The offsets in their respective byte - * sequences where the next encoded offset or - * length should go. */ + * sequences where the next encoded offset + * or length should go. */ int prevCodeOffset, prevSrcOffset, i; codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; @@ -3307,7 +3333,7 @@ GetCmdLocEncodingSize( for (i = 0; i < numCmds; i++) { codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); if (codeDelta < 0) { - Tcl_Panic("GetCmdLocEncodingSize: bad code offset"); + panic("GetCmdLocEncodingSize: bad code offset"); } else if (codeDelta <= 127) { codeDeltaNext++; } else { @@ -3317,7 +3343,7 @@ GetCmdLocEncodingSize( codeLen = mapPtr[i].numCodeBytes; if (codeLen < 0) { - Tcl_Panic("GetCmdLocEncodingSize: bad code length"); + panic("GetCmdLocEncodingSize: bad code length"); } else if (codeLen <= 127) { codeLengthNext++; } else { @@ -3334,7 +3360,7 @@ GetCmdLocEncodingSize( srcLen = mapPtr[i].numSrcBytes; if (srcLen < 0) { - Tcl_Panic("GetCmdLocEncodingSize: bad source length"); + panic("GetCmdLocEncodingSize: bad source length"); } else if (srcLen <= 127) { srcLengthNext++; } else { @@ -3350,8 +3376,8 @@ GetCmdLocEncodingSize( * * 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: @@ -3359,30 +3385,30 @@ GetCmdLocEncodingSize( * 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( - CompileEnv *envPtr, /* Points to compilation environment structure - * containing the CmdLocation structure to - * encode. */ - ByteCode *codePtr, /* ByteCode in which to encode envPtr's +EncodeCmdLocMap(envPtr, codePtr, startPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ + ByteCode *codePtr; /* ByteCode in which to encode envPtr's * command location information. */ - unsigned char *startPtr) /* Points to the first byte in codePtr's - * memory block where the location information - * is to be stored. */ + 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. */ @@ -3392,7 +3418,7 @@ EncodeCmdLocMap( for (i = 0; i < numCmds; i++) { codeDelta = (mapPtr[i].codeOffset - prevOffset); if (codeDelta < 0) { - Tcl_Panic("EncodeCmdLocMap: bad code offset"); + panic("EncodeCmdLocMap: bad code offset"); } else if (codeDelta <= 127) { TclStoreInt1AtPtr(codeDelta, p); p++; @@ -3413,7 +3439,7 @@ EncodeCmdLocMap( for (i = 0; i < numCmds; i++) { codeLen = mapPtr[i].numCodeBytes; if (codeLen < 0) { - Tcl_Panic("EncodeCmdLocMap: bad code length"); + panic("EncodeCmdLocMap: bad code length"); } else if (codeLen <= 127) { TclStoreInt1AtPtr(codeLen, p); p++; @@ -3453,7 +3479,7 @@ EncodeCmdLocMap( for (i = 0; i < numCmds; i++) { srcLen = mapPtr[i].numSrcBytes; if (srcLen < 0) { - Tcl_Panic("EncodeCmdLocMap: bad source length"); + panic("EncodeCmdLocMap: bad source length"); } else if (srcLen <= 127) { TclStoreInt1AtPtr(srcLen, p); p++; @@ -3464,7 +3490,7 @@ EncodeCmdLocMap( p += 4; } } - + return p; } @@ -3474,8 +3500,8 @@ EncodeCmdLocMap( * * 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. @@ -3487,140 +3513,19 @@ EncodeCmdLocMap( */ void -TclPrintByteCodeObj( - Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +TclPrintByteCodeObj(interp, objPtr) + Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ { - Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); - - fprintf(stdout, "\n%s", TclGetString(bufPtr)); - Tcl_DecrRefCount(bufPtr); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintInstruction -- - * - * This procedure prints ("disassembles") one instruction from a bytecode - * object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. - * - *---------------------------------------------------------------------- - */ - -int -TclPrintInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - unsigned char *pc) /* Points to first byte of instruction. */ -{ - Tcl_Obj *bufferObj; - int numBytes; - - TclNewObj(bufferObj); - numBytes = FormatInstruction(codePtr, pc, bufferObj); - fprintf(stdout, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); - return numBytes; -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintObject -- - * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintObject( - FILE *outFile, /* The file to print the source to. */ - Tcl_Obj *objPtr, /* Points to the Tcl object whose string - * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ -{ - char *bytes; - int length; - - bytes = Tcl_GetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); -} - -/* - *---------------------------------------------------------------------- - * - * TclPrintSource -- - * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. - * - * Results: - * None. - * - * Side effects: - * Outputs characters to the specified file. - * - *---------------------------------------------------------------------- - */ - -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ -{ - Tcl_Obj *bufferObj; - - TclNewObj(bufferObj); - PrintSourceToObj(bufferObj, stringPtr, maxChars); - fprintf(outFile, "%s", TclGetString(bufferObj)); - Tcl_DecrRefCount(bufferObj); -} -#endif /* TCL_COMPILE_DEBUG */ - -/* - *---------------------------------------------------------------------- - * - * TclDisassembleByteCodeObj -- - * - * Given an object which is of bytecode type, return a disassembled - * version of the bytecode (in a new refcount 0 object). No guarantees - * are made about the details of the contents of the result. - * - *---------------------------------------------------------------------- - */ - -Tcl_Obj * -TclDisassembleByteCodeObj( - Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ -{ - ByteCode *codePtr = objPtr->internalRep.otherValuePtr; + ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; Interp *iPtr = (Interp *) *codePtr->interpHandle; - Tcl_Obj *bufferObj; - char ptrBuf1[20], ptrBuf2[20]; - TclNewObj(bufferObj); if (codePtr->refCount <= 0) { - return bufferObj; /* Already freed. */ + return; /* already freed */ } codeStart = codePtr->codeStart; @@ -3631,70 +3536,62 @@ TclDisassembleByteCodeObj( * Print header lines describing the ByteCode. */ - sprintf(ptrBuf1, "%p", codePtr); - sprintf(ptrBuf2, "%p", iPtr); - Tcl_AppendPrintfToObj(bufferObj, - "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", - ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, + fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) iPtr, iPtr->compileEpoch); - Tcl_AppendToObj(bufferObj, " Source ", -1); - PrintSourceToObj(bufferObj, codePtr->source, + fprintf(stdout, " Source "); + TclPrintSource(stdout, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); - Tcl_AppendPrintfToObj(bufferObj, - "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, #ifdef TCL_COMPILE_STATS - codePtr->numSrcBytes? - codePtr->structureSize/(float)codePtr->numSrcBytes : -#endif + (codePtr->numSrcBytes? + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); +#else 0.0); - +#endif #ifdef TCL_COMPILE_STATS - Tcl_AppendPrintfToObj(bufferObj, - " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", - (unsigned long) codePtr->structureSize, - (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), + fprintf(stdout, + " Code %u = header %u+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned int)codePtr->structureSize, + (unsigned int)(sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), codePtr->numCodeBytes, - (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), - (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), + (unsigned long)(codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (unsigned long)(codePtr->numExceptRanges * sizeof(ExceptionRange)), + (unsigned long)(codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ - + /* * If the ByteCode is the compiled body of a Tcl procedure, print * information about that procedure. Note that we don't know the * procedure's name since ByteCode's can be shared among procedures. */ - + if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; - - sprintf(ptrBuf1, "%p", procPtr); - Tcl_AppendPrintfToObj(bufferObj, - " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", - ptrBuf1, procPtr->refCount, procPtr->numArgs, + fprintf(stdout, + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; - for (i = 0; i < numCompiledLocals; i++) { - Tcl_AppendPrintfToObj(bufferObj, - " slot %d%s%s%s%s%s%s", i, - (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", - (localPtr->flags & VAR_ARRAY) ? ", array" : "", - (localPtr->flags & VAR_LINK) ? ", link" : "", - (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", - (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", - (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); + 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)) { - Tcl_AppendToObj(bufferObj, "\n", -1); + fprintf(stdout, "\n"); } else { - Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", - localPtr->name); + fprintf(stdout, ", \"%s\"\n", localPtr->name); } localPtr = localPtr->nextPtr; } @@ -3706,60 +3603,58 @@ TclDisassembleByteCodeObj( */ if (codePtr->numExceptRanges > 0) { - Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", - codePtr->numExceptRanges, codePtr->maxExceptDepth); + fprintf(stdout, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < codePtr->numExceptRanges; i++) { ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); - - Tcl_AppendPrintfToObj(bufferObj, - " %d: level %d, %s, pc %d-%d, ", + 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: - Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", - rangePtr->continueOffset, rangePtr->breakOffset); + fprintf(stdout, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: - Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", - rangePtr->catchOffset); + fprintf(stdout, "catch %d\n", rangePtr->catchOffset); break; default: - Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", - rangePtr->type); + panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", + rangePtr->type); } } } - + /* - * If there were no commands (e.g., an expression or an empty string was - * compiled), just print all instructions and return. + * If there were no commands (e.g., an expression or an empty string + * was compiled), just print all instructions and return. */ if (numCmds == 0) { pc = codeStart; while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); } - return bufferObj; + 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. */ - Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); + 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++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; @@ -3769,7 +3664,7 @@ TclDisassembleByteCodeObj( } codeOffset += delta; - if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; @@ -3777,8 +3672,8 @@ TclDisassembleByteCodeObj( codeLen = TclGetInt1AtPtr(codeLengthNext); codeLengthNext++; } - - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; @@ -3788,7 +3683,7 @@ TclDisassembleByteCodeObj( } srcOffset += delta; - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; @@ -3796,29 +3691,29 @@ TclDisassembleByteCodeObj( srcLen = TclGetInt1AtPtr(srcLengthNext); srcLengthNext++; } - - Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", + + fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); } if (numCmds > 0) { - Tcl_AppendToObj(bufferObj, "\n", -1); + 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; for (i = 0; i < numCmds; i++) { - if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; @@ -3828,7 +3723,7 @@ TclDisassembleByteCodeObj( } codeOffset += delta; - if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; @@ -3838,7 +3733,7 @@ TclDisassembleByteCodeObj( } srcOffset += delta; - if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; @@ -3850,16 +3745,16 @@ TclDisassembleByteCodeObj( /* * Print instructions before command i. */ - + while ((pc-codeStart) < codeOffset) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); } - Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); - PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), - TclMin(srcLen, 55)); - Tcl_AppendToObj(bufferObj, "\n", -1); + fprintf(stdout, " Command %d: ", (i+1)); + TclPrintSource(stdout, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + fprintf(stdout, "\n"); } if (pc < codeLimit) { /* @@ -3867,201 +3762,225 @@ TclDisassembleByteCodeObj( */ while (pc < codeLimit) { - Tcl_AppendToObj(bufferObj, " ", -1); - pc += FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); } } - return bufferObj; } +#endif /* TCL_COMPILE_DEBUG */ /* *---------------------------------------------------------------------- * - * FormatInstruction -- + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a + * bytecode object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. * - * Appends a representation of a bytecode instruction to a Tcl_Obj. + * Side effects: + * None. * *---------------------------------------------------------------------- */ -static int -FormatInstruction( - ByteCode *codePtr, /* Bytecode containing the instruction. */ - unsigned char *pc, /* Points to first byte of instruction. */ - Tcl_Obj *bufferObj) /* Object to append instruction info to. */ +int +TclPrintInstruction(codePtr, pc) + ByteCode* codePtr; /* Bytecode containing the instruction. */ + unsigned char *pc; /* Points to first byte of instruction. */ { Proc *procPtr = codePtr->procPtr; unsigned char opCode = *pc; register InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; - unsigned pcOffset = pc - codeStart; - int opnd = 0, i, j, numBytes = 1; - int localCt = procPtr ? procPtr->numCompiledLocals : 0; - CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - char suffixBuffer[128]; /* Additional info to print after main opcode - * and immediates. */ - char *suffixSrc = NULL; - Tcl_Obj *suffixObj = NULL; - AuxData *auxPtr = NULL; - - suffixBuffer[0] = '\0'; - Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); + unsigned int pcOffset = (pc - codeStart); + int opnd, i, j; + + fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: - opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 - || opCode == INST_JUMP_FALSE1) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + opnd = TclGetInt1AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP1) + || (opCode == INST_JUMP_TRUE1) + || (opCode == INST_JUMP_FALSE1))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_INT4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 - || opCode == INST_JUMP_FALSE4) { - sprintf(suffixBuffer, "pc %u", pcOffset+opnd); - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + opnd = TclGetInt4AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP4) + || (opCode == INST_JUMP_TRUE4) + || (opCode == INST_JUMP_FALSE4))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); } - Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; - if (opCode == INST_PUSH1) { - suffixObj = codePtr->objArrayPtr[opnd]; + opnd = TclGetUInt1AtPtr(pc+1+i); + if ((i == 0) && (opCode == INST_PUSH1)) { + fprintf(stdout, "%u # ", (unsigned int) opnd); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) + || (opCode == INST_LOAD_ARRAY1) + || (opCode == INST_STORE_SCALAR1) + || (opCode == INST_STORE_ARRAY1))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; - case OPERAND_AUX4: case OPERAND_UINT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; + opnd = TclGetUInt4AtPtr(pc+1+i); if (opCode == INST_PUSH4) { - suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD && opnd != 1) { - sprintf(suffixBuffer+strlen(suffixBuffer), - ", %u cmds start here", opnd); - } - Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); - if (instDesc->opTypes[i] == OPERAND_AUX4) { - auxPtr = &codePtr->auxDataArrayPtr[opnd]; - } - break; - case OPERAND_IDX4: - opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; - if (opnd >= -1) { - Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); - } else if (opnd == -2) { - Tcl_AppendPrintfToObj(bufferObj, "end "); - } else { - Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); - } - break; - case OPERAND_LVT1: - opnd = TclGetUInt1AtPtr(pc+numBytes); - numBytes++; - goto printLVTindex; - case OPERAND_LVT4: - opnd = TclGetUInt4AtPtr(pc+numBytes); - numBytes += 4; - printLVTindex: - if (localPtr != NULL) { + 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("FormatInstruction: bad local var index %u (%u locals)", - (unsigned) opnd, localCt); + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; } if (TclIsVarTemporary(localPtr)) { - sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); } else { - sprintf(suffixBuffer, "var "); - suffixSrc = localPtr->name; + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); } - Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); break; case OPERAND_NONE: default: break; } } - if (suffixObj) { - char *bytes; - int length; - - Tcl_AppendToObj(bufferObj, "\t# ", -1); - bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); - PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); - } else if (suffixBuffer[0]) { - Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); - if (suffixSrc) { - PrintSourceToObj(bufferObj, suffixSrc, 40); - } - } - Tcl_AppendToObj(bufferObj, "\n", -1); - if (auxPtr && auxPtr->type->printProc) { - Tcl_AppendToObj(bufferObj, "\t\t[", -1); - auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, - pcOffset); - Tcl_AppendToObj(bufferObj, "]\n", -1); - } - return numBytes; + fprintf(stdout, "\n"); + return instDesc->numBytes; } /* *---------------------------------------------------------------------- * - * PrintSourceToObj -- + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from + * the argument Tcl object's string representation to a specified file. * - * Appends a quoted representation of a string to a Tcl_Obj. + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. * *---------------------------------------------------------------------- */ -static void -PrintSourceToObj( - Tcl_Obj *appendObj, /* The object to print the source to. */ - const char *stringPtr, /* The string to print. */ - int maxChars) /* Maximum number of chars to print. */ +void +TclPrintObject(outFile, objPtr, maxChars) + FILE *outFile; /* The file to print the source to. */ + Tcl_Obj *objPtr; /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars; /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from + * the argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource(outFile, string, maxChars) + FILE *outFile; /* The file to print the source to. */ + CONST char *string; /* The string to print. */ + int maxChars; /* Maximum number of chars to print. */ { - register const char *p; + register CONST char *p; register int i = 0; - if (stringPtr == NULL) { - Tcl_AppendToObj(appendObj, "\"\"", -1); + if (string == NULL) { + fprintf(outFile, "\"\""); return; } - Tcl_AppendToObj(appendObj, "\"", -1); - p = stringPtr; + fprintf(outFile, "\""); + p = string; for (; (*p != '\0') && (i < maxChars); p++, i++) { switch (*p) { - case '"': - Tcl_AppendToObj(appendObj, "\\\"", -1); - continue; - case '\f': - Tcl_AppendToObj(appendObj, "\\f", -1); - continue; - case '\n': - Tcl_AppendToObj(appendObj, "\\n", -1); - continue; - case '\r': - Tcl_AppendToObj(appendObj, "\\r", -1); - continue; - case '\t': - Tcl_AppendToObj(appendObj, "\\t", -1); - continue; - case '\v': - Tcl_AppendToObj(appendObj, "\\v", -1); - continue; - default: - Tcl_AppendPrintfToObj(appendObj, "%c", *p); - continue; + 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; } } - Tcl_AppendToObj(appendObj, "\"", -1); + fprintf(outFile, "\""); } #ifdef TCL_COMPILE_STATS @@ -4079,42 +3998,41 @@ PrintSourceToObj( * * 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. * *---------------------------------------------------------------------- */ void -RecordByteCodeStats( - ByteCode *codePtr) /* Points to ByteCode structure with info +RecordByteCodeStats(codePtr) + ByteCode *codePtr; /* Points to ByteCode structure with info * to add to accumulated statistics. */ { Interp *iPtr = (Interp *) *codePtr->interpHandle; - register ByteCodeStats *statsPtr; + register ByteCodeStats *statsPtr = &(iPtr->stats); if (iPtr == NULL) { /* Avoid segfaulting in case we're called in a deleted interp */ return; } - 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 */ @@ -4126,3 +4044,4 @@ RecordByteCodeStats( * fill-column: 78 * End: */ + |