summaryrefslogtreecommitdiffstats
path: root/generic/tclCompile.c
diff options
context:
space:
mode:
Diffstat (limited to 'generic/tclCompile.c')
-rw-r--r--generic/tclCompile.c3761
1 files changed, 1921 insertions, 1840 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c
index e281a0a..9b23389 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,222 +51,352 @@ static int traceInitialized = 0;
*/
InstructionDesc tclInstructionTable[] = {
- /* Name Bytes stackEffect #Opnds Operand types Stack top, next */
- {"done", 1, -1, 0, {OPERAND_NONE}},
+ /* Name Bytes stackEffect #Opnds Operand types */
+ {"done", 1, -1, 0, {OPERAND_NONE}},
/* Finish ByteCode execution and return stktop (top stack item) */
- {"push1", 2, +1, 1, {OPERAND_UINT1}},
+ {"push1", 2, +1, 1, {OPERAND_UINT1}},
/* Push object at ByteCode objArray[op1] */
- {"push4", 5, +1, 1, {OPERAND_UINT4}},
+ {"push4", 5, +1, 1, {OPERAND_UINT4}},
/* Push object at ByteCode objArray[op4] */
- {"pop", 1, -1, 0, {OPERAND_NONE}},
+ {"pop", 1, -1, 0, {OPERAND_NONE}},
/* Pop the topmost stack object */
- {"dup", 1, +1, 0, {OPERAND_NONE}},
+ {"dup", 1, +1, 0, {OPERAND_NONE}},
/* Duplicate the topmost stack object and push the result */
- {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Concatenate the top op1 items and push result */
- {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
+ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
/* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
- {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},
+ {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},
/* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
- {"evalStk", 1, 0, 0, {OPERAND_NONE}},
+ {"evalStk", 1, 0, 0, {OPERAND_NONE}},
/* Evaluate command in stktop using Tcl_EvalObj. */
- {"exprStk", 1, 0, 0, {OPERAND_NONE}},
+ {"exprStk", 1, 0, 0, {OPERAND_NONE}},
/* Execute expression in stktop using Tcl_ExprStringObj. */
-
- {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}},
+
+ {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}},
/* Load scalar variable at index op1 <= 255 in call frame */
- {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}},
+ {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}},
/* Load scalar variable at index op1 >= 256 in call frame */
- {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}},
+ {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}},
/* Load scalar variable; scalar's name is stktop */
- {"loadArray1", 2, 0, 1, {OPERAND_UINT1}},
+ {"loadArray1", 2, 0, 1, {OPERAND_LVT1}},
/* Load array element; array at slot op1<=255, element is stktop */
- {"loadArray4", 5, 0, 1, {OPERAND_UINT4}},
+ {"loadArray4", 5, 0, 1, {OPERAND_LVT4}},
/* Load array element; array at slot op1 > 255, element is stktop */
- {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}},
+ {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}},
/* Load array element; element is stktop, array name is stknext */
- {"loadStk", 1, 0, 0, {OPERAND_NONE}},
+ {"loadStk", 1, 0, 0, {OPERAND_NONE}},
/* Load general variable; unparsed variable name is stktop */
- {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}},
+ {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}},
/* Store scalar variable at op1<=255 in frame; value is stktop */
- {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}},
+ {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}},
/* Store scalar variable at op1 > 255 in frame; value is stktop */
- {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}},
+ {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}},
/* Store scalar; value is stktop, scalar name is stknext */
- {"storeArray1", 2, -1, 1, {OPERAND_UINT1}},
+ {"storeArray1", 2, -1, 1, {OPERAND_LVT1}},
/* Store array element; array at op1<=255, value is top then elem */
- {"storeArray4", 5, -1, 1, {OPERAND_UINT4}},
+ {"storeArray4", 5, -1, 1, {OPERAND_LVT4}},
/* Store array element; array at op1>=256, value is top then elem */
- {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}},
/* Store array element; value is stktop, then elem, array names */
- {"storeStk", 1, -1, 0, {OPERAND_NONE}},
+ {"storeStk", 1, -1, 0, {OPERAND_NONE}},
/* Store general variable; value is stktop, then unparsed name */
-
- {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}},
+
+ {"incrScalar1", 2, 0, 1, {OPERAND_LVT1}},
/* Incr scalar at index op1<=255 in frame; incr amount is stktop */
- {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}},
+ {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}},
/* Incr scalar; incr amount is stktop, scalar's name is stknext */
- {"incrArray1", 2, -1, 1, {OPERAND_UINT1}},
+ {"incrArray1", 2, -1, 1, {OPERAND_LVT1}},
/* Incr array elem; arr at slot op1<=255, amount is top then elem */
- {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}},
/* Incr array element; amount is top then elem then array names */
- {"incrStk", 1, -1, 0, {OPERAND_NONE}},
+ {"incrStk", 1, -1, 0, {OPERAND_NONE}},
/* Incr general variable; amount is stktop then unparsed var name */
- {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}},
+ {"incrScalar1Imm", 3, +1, 2, {OPERAND_LVT1, OPERAND_INT1}},
/* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
- {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}},
+ {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}},
/* Incr scalar; scalar name is stktop; incr amount is op1 */
- {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}},
+ {"incrArray1Imm", 3, 0, 2, {OPERAND_LVT1, OPERAND_INT1}},
/* Incr array elem; array at slot op1 <= 255, elem is stktop,
* amount is 2nd operand byte */
- {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}},
+ {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}},
/* Incr array element; elem is top then array name, amount is op1 */
- {"incrStkImm", 2, 0, 1, {OPERAND_INT1}},
+ {"incrStkImm", 2, 0, 1, {OPERAND_INT1}},
/* Incr general variable; unparsed name is top, amount is op1 */
-
- {"jump1", 2, 0, 1, {OPERAND_INT1}},
+
+ {"jump1", 2, 0, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) */
- {"jump4", 5, 0, 1, {OPERAND_INT4}},
+ {"jump4", 5, 0, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) */
- {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}},
+ {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) if stktop expr object is true */
- {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}},
+ {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) if stktop expr object is true */
- {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}},
+ {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}},
/* Jump relative to (pc + op1) if stktop expr object is false */
- {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}},
+ {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}},
/* Jump relative to (pc + op4) if stktop expr object is false */
- {"lor", 1, -1, 0, {OPERAND_NONE}},
+ {"lor", 1, -1, 0, {OPERAND_NONE}},
/* Logical or: push (stknext || stktop) */
- {"land", 1, -1, 0, {OPERAND_NONE}},
+ {"land", 1, -1, 0, {OPERAND_NONE}},
/* Logical and: push (stknext && stktop) */
- {"bitor", 1, -1, 0, {OPERAND_NONE}},
+ {"bitor", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise or: push (stknext | stktop) */
- {"bitxor", 1, -1, 0, {OPERAND_NONE}},
+ {"bitxor", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise xor push (stknext ^ stktop) */
- {"bitand", 1, -1, 0, {OPERAND_NONE}},
+ {"bitand", 1, -1, 0, {OPERAND_NONE}},
/* Bitwise and: push (stknext & stktop) */
- {"eq", 1, -1, 0, {OPERAND_NONE}},
+ {"eq", 1, -1, 0, {OPERAND_NONE}},
/* Equal: push (stknext == stktop) */
- {"neq", 1, -1, 0, {OPERAND_NONE}},
+ {"neq", 1, -1, 0, {OPERAND_NONE}},
/* Not equal: push (stknext != stktop) */
- {"lt", 1, -1, 0, {OPERAND_NONE}},
+ {"lt", 1, -1, 0, {OPERAND_NONE}},
/* Less: push (stknext < stktop) */
- {"gt", 1, -1, 0, {OPERAND_NONE}},
+ {"gt", 1, -1, 0, {OPERAND_NONE}},
/* Greater: push (stknext || stktop) */
- {"le", 1, -1, 0, {OPERAND_NONE}},
- /* Logical or: push (stknext || stktop) */
- {"ge", 1, -1, 0, {OPERAND_NONE}},
- /* Logical or: push (stknext || stktop) */
- {"lshift", 1, -1, 0, {OPERAND_NONE}},
+ {"le", 1, -1, 0, {OPERAND_NONE}},
+ /* Less or equal: push (stknext || stktop) */
+ {"ge", 1, -1, 0, {OPERAND_NONE}},
+ /* Greater or equal: push (stknext || stktop) */
+ {"lshift", 1, -1, 0, {OPERAND_NONE}},
/* Left shift: push (stknext << stktop) */
- {"rshift", 1, -1, 0, {OPERAND_NONE}},
+ {"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_UINT4}},
+ {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}},
/* Initialize execution of a foreach loop. Operand is aux data index
* of the ForeachInfo structure for the foreach command. */
- {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}},
+ {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}},
/* "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_UINT1}},
+
+ {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}},
/* Append scalar variable at op1<=255 in frame; value is stktop */
- {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}},
+ {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}},
/* Append scalar variable at op1 > 255 in frame; value is stktop */
- {"appendArray1", 2, -1, 1, {OPERAND_UINT1}},
+ {"appendArray1", 2, -1, 1, {OPERAND_LVT1}},
/* Append array element; array at op1<=255, value is top then elem */
- {"appendArray4", 5, -1, 1, {OPERAND_UINT4}},
+ {"appendArray4", 5, -1, 1, {OPERAND_LVT4}},
/* Append array element; array at op1>=256, value is top then elem */
- {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}},
/* Append array element; value is stktop, then elem, array names */
- {"appendStk", 1, -1, 0, {OPERAND_NONE}},
+ {"appendStk", 1, -1, 0, {OPERAND_NONE}},
/* Append general variable; value is stktop, then unparsed name */
- {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}},
+ {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}},
/* Lappend scalar variable at op1<=255 in frame; value is stktop */
- {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}},
+ {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}},
/* Lappend scalar variable at op1 > 255 in frame; value is stktop */
- {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}},
+ {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}},
/* Lappend array element; array at op1<=255, value is top then elem */
- {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}},
+ {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}},
/* Lappend array element; array at op1>=256, value is top then elem */
- {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}},
+ {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}},
/* Lappend array element; value is stktop, then elem, array names */
- {"lappendStk", 1, -1, 0, {OPERAND_NONE}},
+ {"lappendStk", 1, -1, 0, {OPERAND_NONE}},
/* Lappend general variable; value is stktop, then unparsed name */
- {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}},
- /* Lindex with generalized args, operand is number of stacked objs
- * 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}
};
@@ -274,53 +404,45 @@ InstructionDesc tclInstructionTable[] = {
* Prototypes for procedures defined later in this file:
*/
-static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
- Tcl_Obj *copyPtr));
-static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
- CompileEnv *envPtr, ByteCode *codePtr,
- unsigned char *startPtr));
-static void EnterCmdExtentData _ANSI_ARGS_((
- CompileEnv *envPtr, int cmdNumber,
- int numSrcBytes, int numCodeBytes));
-static void EnterCmdStartData _ANSI_ARGS_((
- CompileEnv *envPtr, int cmdNumber,
- int srcOffset, int codeOffset));
-static void FreeByteCodeInternalRep _ANSI_ARGS_((
- Tcl_Obj *objPtr));
-static int GetCmdLocEncodingSize _ANSI_ARGS_((
- CompileEnv *envPtr));
-static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
- CONST char *script, CONST char *command,
- int length));
+static void DupByteCodeInternalRep(Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr);
+static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr,
+ ByteCode *codePtr, unsigned char *startPtr);
+static void EnterCmdExtentData(CompileEnv *envPtr,
+ int cmdNumber, int numSrcBytes, int numCodeBytes);
+static void EnterCmdStartData(CompileEnv *envPtr,
+ int cmdNumber, int srcOffset, int codeOffset);
+static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
+static int GetCmdLocEncodingSize(CompileEnv *envPtr);
#ifdef TCL_COMPILE_STATS
-static void RecordByteCodeStats _ANSI_ARGS_((
- ByteCode *codePtr));
+static void RecordByteCodeStats(ByteCode *codePtr);
#endif /* TCL_COMPILE_STATS */
-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
-
+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);
/*
- * 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 */
- (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
- SetByteCodeFromAny /* setFromAnyProc */
+ "bytecode", /* name */
+ FreeByteCodeInternalRep, /* freeIntRepProc */
+ DupByteCodeInternalRep, /* dupIntRepProc */
+ NULL, /* updateStringProc */
+ SetByteCodeFromAny /* setFromAnyProc */
};
/*
@@ -330,10 +452,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
@@ -342,61 +464,51 @@ Tcl_ObjType tclByteCodeType = {
*
* Side effects:
* Frees the old internal representation. If no error occurs, then the
- * compiled code is stored as "objPtr"s bytecode representation.
- * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
- * used to trace compilations.
+ * compiled code is stored as "objPtr"s bytecode representation. Also, if
+ * debugging, initializes the "tcl_traceCompile" Tcl variable used to
+ * trace compilations.
*
*----------------------------------------------------------------------
*/
int
-TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
- Tcl_Interp *interp; /* The interpreter for which the code is
- * being compiled. Must not be NULL. */
- Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
- CompileHookProc *hookProc; /* Procedure to invoke after compilation. */
- ClientData clientData; /* Hook procedure private data. */
+TclSetByteCodeFromAny(
+ Tcl_Interp *interp, /* The interpreter for which the code is being
+ * compiled. Must not be NULL. */
+ Tcl_Obj *objPtr, /* The object to make a ByteCode object. */
+ CompileHookProc *hookProc, /* Procedure to invoke after compilation. */
+ ClientData clientData) /* Hook procedure private data. */
{
Interp *iPtr = (Interp *) interp;
- CompileEnv compEnv; /* Compilation environment structure
- * allocated in frame. */
- LiteralTable *localTablePtr = &(compEnv.localLitTable);
+ CompileEnv compEnv; /* Compilation environment structure allocated
+ * in frame. */
register AuxData *auxDataPtr;
LiteralEntry *entryPtr;
register int i;
- int length, nested, result;
- char *string;
-#ifdef TCL_TIP280
+ int length, result = TCL_OK;
+ const char *stringPtr;
ContLineLoc* clLocPtr;
-#endif
+
#ifdef TCL_COMPILE_DEBUG
if (!traceInitialized) {
- if (Tcl_LinkVar(interp, "tcl_traceCompile",
- (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
- panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
- }
- traceInitialized = 1;
+ if (Tcl_LinkVar(interp, "tcl_traceCompile",
+ (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
+ Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
+ }
+ traceInitialized = 1;
}
#endif
- 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
+ stringPtr = TclGetStringFromObj(objPtr, &length);
+
/*
- * TIP #280. Pick up the CmdFrame in which the BC compiler was invoked
- * and use to initialize the tracking in the compiler. This information
- * was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc
- * (tclProc.c).
+ * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and
+ * use to initialize the tracking in the compiler. This information was
+ * stored by TclCompEvalObj and ProcCompileProc.
*/
- TclInitCompileEnv(interp, &compEnv, string, length,
- iPtr->invokeCmdFramePtr, iPtr->invokeWord);
+ TclInitCompileEnv(interp, &compEnv, stringPtr, 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.
@@ -415,45 +527,43 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
compEnv.clNext = &compEnv.clLoc->loc[0];
Tcl_Preserve (compEnv.clLoc);
}
-#endif
- result = TclCompileScript(interp, string, length, nested, &compEnv);
- if (result == TCL_OK) {
- /*
- * Successful compilation. Add a "done" instruction at the end.
- */
+ TclCompileScript(interp, stringPtr, length, &compEnv);
- compEnv.numSrcBytes = iPtr->termOffset;
- TclEmitOpcode(INST_DONE, &compEnv);
+ /*
+ * Successful compilation. Add a "done" instruction at the end.
+ */
- /*
- * Invoke the compilation hook procedure if one exists.
- */
+ TclEmitOpcode(INST_DONE, &compEnv);
- if (hookProc) {
- result = (*hookProc)(interp, &compEnv, clientData);
- }
+ /*
+ * Invoke the compilation hook procedure if one exists.
+ */
+
+ if (hookProc) {
+ result = (*hookProc)(interp, &compEnv, clientData);
+ }
+
+ /*
+ * Change the object into a ByteCode object. Ownership of the literal
+ * objects and aux data items is given to the ByteCode object.
+ */
- /*
- * 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);
- }
-#endif /* TCL_COMPILE_DEBUG */
+ if (tclTraceCompile >= 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ fflush(stdout);
}
-
+#endif /* TCL_COMPILE_DEBUG */
+
if (result != TCL_OK) {
/*
- * Compilation errors.
+ * Handle any error from the hookProc
*/
entryPtr = compEnv.literalArrayPtr;
@@ -474,14 +584,6 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
}
}
-
- /*
- * Free storage allocated during compilation.
- */
-
- if (localTablePtr->buckets != localTablePtr->staticBuckets) {
- ckfree((char *) localTablePtr->buckets);
- }
TclFreeCompileEnv(&compEnv);
return result;
}
@@ -502,24 +604,24 @@ TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
*
* Side effects:
* Frees the old internal representation. If no error occurs, then the
- * compiled code is stored as "objPtr"s bytecode representation.
- * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
- * used to trace compilations.
+ * compiled code is stored as "objPtr"s bytecode representation. Also, if
+ * debugging, initializes the "tcl_traceCompile" Tcl variable used to
+ * trace compilations.
*
*----------------------------------------------------------------------
*/
static int
-SetByteCodeFromAny(interp, objPtr)
- Tcl_Interp *interp; /* The interpreter for which the code is
- * being compiled. Must not be NULL. */
- Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
+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. */
{
if (interp == NULL) {
return TCL_ERROR;
}
- return TclSetByteCodeFromAny(interp, objPtr,
- (CompileHookProc *) NULL, (ClientData) NULL);
+ (void) TclSetByteCodeFromAny(interp, objPtr, NULL, (ClientData) NULL);
+ return TCL_OK;
}
/*
@@ -527,8 +629,8 @@ SetByteCodeFromAny(interp, objPtr)
*
* DupByteCodeInternalRep --
*
- * Part of the bytecode Tcl object type implementation. However, it
- * does not copy the internal representation of a bytecode Tcl_Obj, but
+ * Part of the bytecode Tcl object type implementation. However, it does
+ * not copy the internal representation of a bytecode Tcl_Obj, but
* instead leaves the new object untyped (with a NULL type pointer).
* Code will be compiled for the new object only if necessary.
*
@@ -542,9 +644,9 @@ SetByteCodeFromAny(interp, objPtr)
*/
static void
-DupByteCodeInternalRep(srcPtr, copyPtr)
- Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
- Tcl_Obj *copyPtr; /* Object with internal rep to set. */
+DupByteCodeInternalRep(
+ Tcl_Obj *srcPtr, /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr) /* Object with internal rep to set. */
{
return;
}
@@ -554,28 +656,27 @@ DupByteCodeInternalRep(srcPtr, copyPtr)
*
* FreeByteCodeInternalRep --
*
- * Part of the bytecode Tcl object type implementation. Frees the
- * storage associated with a bytecode object's internal representation
- * unless its code is actively being executed.
+ * Part of the bytecode Tcl object type implementation. Frees the storage
+ * associated with a bytecode object's internal representation unless its
+ * code is actively being executed.
*
* Results:
* None.
*
* Side effects:
- * The bytecode object's internal rep is marked invalid and its
- * code gets freed unless the code is actively being executed.
- * In that case the cleanup is delayed until the last execution
- * of the code completes.
+ * The bytecode object's internal rep is marked invalid and its code gets
+ * freed unless the code is actively being executed. In that case the
+ * cleanup is delayed until the last execution of the code completes.
*
*----------------------------------------------------------------------
*/
static void
-FreeByteCodeInternalRep(objPtr)
- register Tcl_Obj *objPtr; /* Object whose internal rep to free. */
+FreeByteCodeInternalRep(
+ 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) {
@@ -598,24 +699,22 @@ FreeByteCodeInternalRep(objPtr)
* None.
*
* Side effects:
- * Frees objPtr's bytecode internal representation and sets its type
- * and objPtr->internalRep.otherValuePtr NULL. Also releases its
- * literals and frees its auxiliary data items.
+ * Frees objPtr's bytecode internal representation and sets its type and
+ * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and
+ * frees its auxiliary data items.
*
*----------------------------------------------------------------------
*/
void
-TclCleanupByteCode(codePtr)
- register ByteCode *codePtr; /* Points to the ByteCode to free. */
+TclCleanupByteCode(
+ register ByteCode *codePtr) /* Points to the ByteCode to free. */
{
Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
-#ifdef TCL_TIP280
- Interp* iPtr = (Interp*) interp;
-#endif
+ Interp *iPtr = (Interp *) interp;
int numLitObjects = codePtr->numLitObjects;
int numAuxDataItems = codePtr->numAuxDataItems;
- register Tcl_Obj **objArrayPtr;
+ register Tcl_Obj **objArrayPtr, *objPtr;
register AuxData *auxDataPtr;
int i;
#ifdef TCL_COMPILE_STATS
@@ -631,13 +730,13 @@ TclCleanupByteCode(codePtr)
statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
- statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
- statsPtr->currentLitBytes -=
- (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
- statsPtr->currentExceptBytes -=
- (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
- statsPtr->currentAuxBytes -=
- (double) (codePtr->numAuxDataItems * sizeof(AuxData));
+ statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
+ statsPtr->currentLitBytes -= (double)
+ codePtr->numLitObjects * sizeof(Tcl_Obj *);
+ statsPtr->currentExceptBytes -= (double)
+ codePtr->numExceptRanges * sizeof(ExceptionRange);
+ statsPtr->currentAuxBytes -= (double)
+ codePtr->numAuxDataItems * sizeof(AuxData);
statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
Tcl_GetTime(&destroyTime);
@@ -645,9 +744,9 @@ TclCleanupByteCode(codePtr)
if (lifetimeSec > 2000) { /* avoid overflow */
lifetimeSec = 2000;
}
- lifetimeMicroSec =
- 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
-
+ lifetimeMicroSec = 1000000 * lifetimeSec +
+ (destroyTime.usec - codePtr->createTime.usec);
+
log2 = TclLog2(lifetimeMicroSec);
if (log2 > 31) {
log2 = 31;
@@ -657,21 +756,28 @@ TclCleanupByteCode(codePtr)
#endif /* TCL_COMPILE_STATS */
/*
- * A single heap object holds the ByteCode structure and its code,
- * object, command location, and auxiliary data arrays. This means we
- * only need to 1) decrement the ref counts of the LiteralEntry's in
- * its literal array, 2) call the free procs for the auxiliary data
- * items, and 3) free the ByteCode structure's heap object.
+ * A single heap object holds the ByteCode structure and its code, object,
+ * command location, and auxiliary data arrays. This means we only need to
+ * 1) decrement the ref counts of the LiteralEntry's in its literal array,
+ * 2) call the free procs for the auxiliary data items, 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.
*
- * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,
- * like those generated from tbcload) is special, as they doesn't
- * make use of the global literal table. They instead maintain
- * private references to their literals which must be decremented.
+ * In order to insure a proper and efficient cleanup of the literal array
+ * when it contains non-shared literals [Bug 983660], we also distinguish
+ * the case of an interpreter being deleted (signaled by interp == NULL).
+ * Also, as the interp deletion will remove the global literal table
+ * anyway, we avoid the extra cost of updating it for each literal being
+ * released.
*/
- if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
- register Tcl_Obj *objPtr;
-
+ if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) {
+
objArrayPtr = codePtr->objArrayPtr;
for (i = 0; i < numLitObjects; i++) {
objPtr = *objArrayPtr;
@@ -681,36 +787,30 @@ TclCleanupByteCode(codePtr)
objArrayPtr++;
}
codePtr->numLitObjects = 0;
- } else if (interp != NULL) {
- /*
- * If the interp has already been freed, then Tcl will have already
- * forcefully released all the literals used by ByteCodes compiled
- * with respect to that interp.
- */
-
+ } else {
objArrayPtr = codePtr->objArrayPtr;
for (i = 0; i < numLitObjects; i++) {
/*
* TclReleaseLiteral sets a ByteCode's object array entry NULL to
* indicate that it has already freed the literal.
*/
-
- if (*objArrayPtr != NULL) {
- TclReleaseLiteral(interp, *objArrayPtr);
+
+ objPtr = *objArrayPtr;
+ if (objPtr != NULL) {
+ TclReleaseLiteral(interp, objPtr);
}
objArrayPtr++;
}
}
-
+
auxDataPtr = codePtr->auxDataArrayPtr;
for (i = 0; i < numAuxDataItems; i++) {
if (auxDataPtr->type->freeProc != NULL) {
- (*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
+ (auxDataPtr->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,
@@ -720,43 +820,37 @@ TclCleanupByteCode(codePtr)
*/
if (iPtr) {
- Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
+ Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr,
+ (char *) codePtr);
if (hePtr) {
- ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
+ ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
+ int i;
- ReleaseCmdWordData (eclPtr);
- Tcl_DeleteHashEntry (hePtr);
- }
- }
-#endif
+ if (eclPtr->type == TCL_LOCATION_SOURCE) {
+ Tcl_DecrRefCount(eclPtr->path);
+ }
+ for (i=0 ; i<eclPtr->nuloc ; i++) {
+ ckfree((char *) eclPtr->loc[i].line);
+ }
- TclHandleRelease(codePtr->interpHandle);
- ckfree((char *) codePtr);
-}
+ if (eclPtr->loc != NULL) {
+ ckfree((char *) eclPtr->loc);
+ }
-#ifdef TCL_TIP280
-static void
-ReleaseCmdWordData (eclPtr)
- ExtCmdLoc* eclPtr;
-{
- int i;
+ Tcl_DeleteHashTable (&eclPtr->litInfo);
- if (eclPtr->type == TCL_LOCATION_SOURCE) {
- Tcl_DecrRefCount (eclPtr->path);
- }
- for (i=0; i < eclPtr->nuloc; i++) {
- ckfree ((char*) eclPtr->loc[i].line);
+ ckfree((char *) eclPtr);
+ Tcl_DeleteHashEntry(hePtr);
+ }
}
- if (eclPtr->loc != NULL) {
- ckfree ((char*) eclPtr->loc);
+ if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) {
+ TclFreeLocalCache(interp, codePtr->localCachePtr);
}
- Tcl_DeleteHashTable (&eclPtr->litInfo);
-
- ckfree ((char*) eclPtr);
+ TclHandleRelease(codePtr->interpHandle);
+ ckfree((char *) codePtr);
}
-#endif
/*
*----------------------------------------------------------------------
@@ -776,27 +870,21 @@ ReleaseCmdWordData (eclPtr)
*/
void
-#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
+TclInitCompileEnv(
+ Tcl_Interp *interp, /* The interpreter for which a CompileEnv
+ * structure is initialized. */
+ register CompileEnv *envPtr,/* Points to the CompileEnv structure to
+ * initialize. */
+ const char *stringPtr, /* The source string to be compiled. */
+ int numBytes, /* Number of bytes in source string. */
+ const CmdFrame *invoker, /* Location context invoking the bcc */
+ int word) /* Index of the word in that context getting
+ * compiled */
{
Interp *iPtr = (Interp *) interp;
-
+
envPtr->iPtr = iPtr;
- envPtr->source = string;
+ envPtr->source = stringPtr;
envPtr->numSrcBytes = numBytes;
envPtr->procPtr = iPtr->compiledProcPtr;
iPtr->compiledProcPtr = NULL;
@@ -816,17 +904,17 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
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
@@ -836,11 +924,11 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
* 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 ||
@@ -850,61 +938,75 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
* 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 ctx = *invoker;
- int pc = 0;
+ CmdFrame* ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame));
+ int pc = 0;
+
+ *ctxPtr = *invoker;
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 (&ctx);
+ */
+
+ TclGetSrcInfoForPc(ctxPtr);
pc = 1;
}
- if ((ctx.nline <= word) || (ctx.line[word] < 0)) {
- /* Word is not a literal, relative counting */
+ if ((ctxPtr->nline <= word) || (ctxPtr->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 && (ctx.type == TCL_LOCATION_SOURCE)) {
+ if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) {
/*
* The reference made by 'TclGetSrcInfoForPc' is dead.
*/
- Tcl_DecrRefCount(ctx.data.eval.path);
+ Tcl_DecrRefCount(ctxPtr->data.eval.path);
}
} else {
- envPtr->line = ctx.line [word];
- envPtr->extCmdMapPtr->type = ctx.type;
- envPtr->extCmdMapPtr->path = ctx.data.eval.path;
+ envPtr->line = ctxPtr->line[word];
+ envPtr->extCmdMapPtr->type = ctxPtr->type;
+
+ if (ctxPtr->type == TCL_LOCATION_SOURCE) {
+ envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path;
- if (ctx.type == TCL_LOCATION_SOURCE) {
if (pc) {
- /* The reference 'TclGetSrcInfoForPc' made is transfered */
- ctx.data.eval.path = NULL;
+ /*
+ * The reference 'TclGetSrcInfoForPc' made is transfered.
+ */
+
+ ctxPtr->data.eval.path = NULL;
} else {
- /* We have a new reference here */
- Tcl_IncrRefCount (ctx.data.eval.path);
+ /*
+ * We have a new reference here.
+ */
+
+ Tcl_IncrRefCount(ctxPtr->data.eval.path);
}
}
}
- /* ctx going out of scope */
+ TclStackFree(interp, ctxPtr);
}
+ 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
@@ -913,7 +1015,6 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
envPtr->clLoc = NULL;
envPtr->clNext = NULL;
-#endif
envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
envPtr->auxDataArrayNext = 0;
@@ -931,22 +1032,26 @@ TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
*
* 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(envPtr)
- register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
+TclFreeCompileEnv(
+ register CompileEnv *envPtr)/* Points to the CompileEnv structure. */
{
+ if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets) {
+ ckfree((char *) envPtr->localLitTable.buckets);
+ envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets;
+ }
if (envPtr->mallocedCodeArray) {
ckfree((char *) envPtr->codeStart);
}
@@ -962,7 +1067,10 @@ TclFreeCompileEnv(envPtr)
if (envPtr->mallocedAuxDataArray) {
ckfree((char *) envPtr->auxDataArrayPtr);
}
-#ifdef TCL_TIP280
+ if (envPtr->extCmdMapPtr) {
+ ckfree((char *) envPtr->extCmdMapPtr);
+ }
+
/*
* 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
@@ -972,13 +1080,8 @@ TclFreeCompileEnv(envPtr)
if (envPtr->clLoc) {
Tcl_Release (envPtr->clLoc);
}
- if (envPtr->extCmdMapPtr) {
- ReleaseCmdWordData (envPtr->extCmdMapPtr);
- }
-#endif
}
-#ifdef TCL_TIP280
/*
*----------------------------------------------------------------------
*
@@ -996,35 +1099,67 @@ TclFreeCompileEnv(envPtr)
* it is worthwhile to compile at all.
*
* Side effects:
- * None.
+ * When returning true, appends the known value of the word to the
+ * unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL.
*
- * TIP #280
*----------------------------------------------------------------------
*/
int
-TclWordKnownAtCompileTime (tokenPtr)
- Tcl_Token* tokenPtr;
+TclWordKnownAtCompileTime(
+ Tcl_Token *tokenPtr, /* Points to Tcl_Token we should check */
+ Tcl_Obj *valuePtr) /* If not NULL, points to an unshared Tcl_Obj
+ * to which we should append the known value
+ * of the word. */
{
- int i;
- Tcl_Token* sub;
+ int numComponents = tokenPtr->numComponents;
+ Tcl_Obj *tempPtr = NULL;
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;};
- if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;};
+ 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;
- /* Check the sub tokens of the word. It is a literal if we find
- * only BS and TEXT tokens */
+ 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;
- 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;
+ default:
+ if (tempPtr != NULL) {
+ Tcl_DecrRefCount(tempPtr);
+ }
+ return 0;
+ }
+ tokenPtr++;
+ }
+ if (valuePtr != NULL) {
+ Tcl_AppendObjToObj(valuePtr, tempPtr);
+ Tcl_DecrRefCount(tempPtr);
}
return 1;
}
-#endif
/*
*----------------------------------------------------------------------
@@ -1038,55 +1173,44 @@ TclWordKnownAtCompileTime (tokenPtr)
* 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.
*
*----------------------------------------------------------------------
*/
-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
+void
+TclCompileScript(
+ Tcl_Interp *interp, /* Used for error and status reporting. Also
+ * serves as context for finding and compiling
+ * commands. May not be NULL. */
+ const char *script, /* The source script to compile. */
+ int numBytes, /* Number of bytes in script. If < 0, the
* script consists of all bytes up to the
* first null character. */
- 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. */
+ 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, gotParse, wordIdx, currCmdIndex;
- int commandLength, objIndex, code;
+ int bytesLeft, isFirstCmd, wordIdx, currCmdIndex;
+ int commandLength, objIndex;
Tcl_DString ds;
-
-#ifdef TCL_TIP280
/* TIP #280 */
- ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr;
- int* wlines = NULL;
- int wlineat, cmdLine;
+ ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr;
+ int *wlines, wlineat, cmdLine;
int* clNext;
-#endif
+ Tcl_Parse *parsePtr = (Tcl_Parse *)
+ TclStackAlloc(interp, sizeof(Tcl_Parse));
Tcl_DStringInit(&ds);
@@ -1096,70 +1220,39 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
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;
-#endif
-
+ clNext = envPtr->clNext;
do {
- if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
- code = TCL_ERROR;
- goto error;
- }
- gotParse = 1;
- if (nested) {
+ if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) {
/*
- * 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...
+ * Compile bytecodes to report the parse error at runtime.
*/
- 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;
- }
+ 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 (parse.numWords > 0) {
+ if (parsePtr->numWords > 0) {
+ int expand = 0; /* Set if there are dynamic expansions to
+ * handle */
+
/*
* If not the first command, pop the previous command's result
* and, if we're compiling a top level command, update the last
@@ -1168,195 +1261,294 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
if (!isFirstCmd) {
TclEmitOpcode(INST_POP, envPtr);
- if (!nested) {
- envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
- (envPtr->codeNext - envPtr->codeStart)
- - startCodeOffset;
- }
+ envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart)
+ - startCodeOffset;
}
/*
* Determine the actual length of the command.
*/
- commandLength = parse.commandSize;
- if (parse.term == parse.commandStart + commandLength - 1) {
+ commandLength = parsePtr->commandSize;
+ if (parsePtr->term == parsePtr->commandStart + commandLength - 1) {
/*
- * The command terminator character (such as ; or ]) is
- * the last character in the parsed command. Reduce the
- * length by one so that the trace message doesn't include
- * the terminator character.
+ * 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)
- && !nested && (envPtr->procPtr == NULL)) {
+ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
fprintf(stdout, " Compiling: ");
- TclPrintSource(stdout, parse.commandStart,
+ TclPrintSource(stdout, parsePtr->commandStart,
TclMin(commandLength, 55));
fprintf(stdout, "\n");
}
#endif
+
/*
- * Each iteration of the following loop compiles one word
- * from the command.
+ * Check whether expansion has been requested for any of the
+ * words.
*/
-
+
+ for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr;
+ wordIdx < parsePtr->numWords;
+ wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
+ if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ expand = 1;
+ break;
+ }
+ }
+
envPtr->numCommands++;
currCmdIndex = (envPtr->numCommands - 1);
- if (!nested) {
- lastTopLevelCmdIndex = currCmdIndex;
- }
+ lastTopLevelCmdIndex = currCmdIndex;
startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
EnterCmdStartData(envPtr, currCmdIndex,
- (parse.commandStart - envPtr->source), startCodeOffset);
+ parsePtr->commandStart - envPtr->source, startCodeOffset);
-#ifdef TCL_TIP280
- /* TIP #280. Scan the words and compute the extended location
+ /*
+ * Should only start issuing instructions after the "command has
+ * started" so that the command range is correct in the bytecode.
+ */
+
+ if (expand) {
+ TclEmitOpcode(INST_EXPAND_START, envPtr);
+ }
+
+ /*
+ * TIP #280. Scan the words and compute the extended location
* information. The map first contain full per-word line
* information for use by the compiler. This is later replaced by
* a reduced form which signals non-literal words, stored in
* 'wlines'.
*/
- TclAdvanceLines (&cmdLine, p, parse.commandStart);
+ TclAdvanceLines(&cmdLine, p, parsePtr->commandStart);
TclAdvanceContinuations (&cmdLine, &clNext,
- parse.commandStart - envPtr->source);
- EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source),
- parse.tokenPtr, parse.commandStart,
- parse.commandSize, parse.numWords,
- cmdLine, clNext, &wlines, envPtr);
+ parsePtr->commandStart - envPtr->source);
+ EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source,
+ parsePtr->tokenPtr, parsePtr->commandStart,
+ parsePtr->commandSize, parsePtr->numWords, cmdLine,
+ clNext, &wlines, envPtr);
wlineat = eclPtr->nuloc - 1;
-#endif
- for (wordIdx = 0, tokenPtr = parse.tokenPtr;
- wordIdx < parse.numWords;
- wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
-#ifdef TCL_TIP280
- envPtr->line = eclPtr->loc [wlineat].line [wordIdx];
+ /*
+ * 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];
envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx];
-#endif
- if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
+
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
/*
- * If this is the first word and the command has a
- * compile procedure, let it compile the command.
+ * The word is not a simple string of characters.
*/
- if (wordIdx == 0) {
- if (envPtr->procPtr != NULL) {
- cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
- } else {
- cmdNsPtr = NULL; /* use current NS */
- }
+ TclCompileTokens(interp, tokenPtr+1,
+ tokenPtr->numComponents, envPtr);
+ if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) {
+ TclEmitInstInt4(INST_EXPAND_STKTOP,
+ envPtr->currStackDepth, envPtr);
+ }
+ continue;
+ }
+
+ /*
+ * This is a simple string of literal characters (i.e. we know
+ * it absolutely and can use it directly). If this is the
+ * first word and the command has a compile procedure, let it
+ * compile the command.
+ */
+
+ if ((wordIdx == 0) && !expand) {
+ /*
+ * We copy the string before trying to find the command by
+ * name. We used to modify the string in place, but this
+ * is not safe because the name resolution handlers could
+ * have side effects that rely on the unmodified string.
+ */
+
+ Tcl_DStringSetLength(&ds, 0);
+ Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size);
+
+ cmdPtr = (Command *) Tcl_FindCommand(interp,
+ Tcl_DStringValue(&ds),
+ (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
+
+ if ((cmdPtr != NULL)
+ && (cmdPtr->compileProc != NULL)
+ && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
+ && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
+ int savedNumCmds = envPtr->numCommands;
+ unsigned savedCodeNext =
+ envPtr->codeNext - envPtr->codeStart;
+ int update = 0, code;
/*
- * 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.
+ * 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.
*/
- 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) {
+ if (envPtr->atCmdStart) {
+ if (savedCodeNext != 0) {
/*
- * Restore numCommands and codeNext to their correct
- * values, removing any commands compiled before
- * TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055]
+ * 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!
*/
- envPtr->numCommands = savedNumCmds;
- envPtr->codeNext = envPtr->codeStart + savedCodeNext;
- } else { /* an error */
+
+ unsigned char *fixPtr = envPtr->codeNext - 4;
+
+ TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1,
+ fixPtr);
+ }
+ } else {
+ TclEmitInstInt4(INST_START_CMD, 0, envPtr);
+ TclEmitInt4(1, envPtr);
+ update = 1;
+ }
+
+ code = (cmdPtr->compileProc)(interp, parsePtr,
+ cmdPtr, envPtr);
+
+ if (code == TCL_OK) {
+ if (update) {
/*
- * There was a compilation error, the last
- * command did not get compiled into (*envPtr).
- * Decrement the number of commands
- * claimed to be in (*envPtr).
+ * Fix the bytecode length.
*/
- envPtr->numCommands--;
- goto log;
+
+ unsigned char *fixPtr = envPtr->codeStart
+ + savedCodeNext + 1;
+ unsigned fixLen = envPtr->codeNext
+ - envPtr->codeStart - savedCodeNext;
+
+ TclStoreInt4AtPtr(fixLen, fixPtr);
}
- }
+ goto finishCommand;
+ } else {
+ if (envPtr->atCmdStart && savedCodeNext != 0) {
+ /*
+ * Decrease the number of commands being
+ * started at the current point. Note that
+ * this depends on the exact layout of the
+ * INST_START_CMD's operands, so be careful!
+ */
- /*
- * No compile procedure so push the word. If the
- * command was found, push a CmdName object to
- * reduce runtime lookups.
- */
+ unsigned char *fixPtr = envPtr->codeNext - 4;
+
+ TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1,
+ fixPtr);
+ }
+
+ /*
+ * Restore numCommands and codeNext to their
+ * correct values, removing any commands compiled
+ * before the failure to produce bytecode got
+ * reported. [Bugs 705406 and 735055]
+ */
- objIndex = TclRegisterNewLiteral(envPtr,
- tokenPtr[1].start, tokenPtr[1].size);
- if (cmdPtr != NULL) {
- TclSetCmdNameObj(interp,
- envPtr->literalArrayPtr[objIndex].objPtr,
- cmdPtr);
+ envPtr->numCommands = savedNumCmds;
+ envPtr->codeNext = envPtr->codeStart+savedCodeNext;
}
- } 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.
+ }
+
+ /*
+ * 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]
*/
- 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
+ TclHideLiteral(interp, envPtr, objIndex);
}
- TclEmitPush(objIndex, envPtr);
} else {
/*
- * The word is not a simple string of characters.
+ * 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.
*/
- code = TclCompileTokens(interp, tokenPtr+1,
- tokenPtr->numComponents, envPtr);
- if (code != TCL_OK) {
- goto log;
+ 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]);
}
}
- }
+ 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 (wordIdx > 0) {
-#ifdef TCL_TIP280
+
+ 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) {
/*
* Save PC -> command map for the TclArgumentBC* functions.
*/
@@ -1364,8 +1556,8 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
int isnew;
Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo,
(char*) (envPtr->codeNext - envPtr->codeStart), &isnew);
- Tcl_SetHashValue(hePtr, (char*) wlineat);
-#endif
+ Tcl_SetHashValue(hePtr, INT2PTR(wlineat));
+
if (wordIdx <= 255) {
TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
} else {
@@ -1378,115 +1570,57 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
* offsets of the source and code for the command.
*/
- finishCommand:
+ finishCommand:
EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
(envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
isFirstCmd = 0;
-#ifdef TCL_TIP280
- /* TIP #280: Free full form of per-word line data and insert
- * the reduced form now
+ /*
+ * 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;
- wlines = NULL;
-#endif
- } /* end if parse.numWords > 0 */
+
+ 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 */
/*
* Advance to the next command in the script.
*/
- next = parse.commandStart + parse.commandSize;
- bytesLeft -= (next - p);
+ next = parsePtr->commandStart + parsePtr->commandSize;
+ bytesLeft -= next - p;
p = next;
-#ifdef TCL_TIP280
- /* TIP #280 : Track lines in the just compiled command */
- TclAdvanceLines (&cmdLine, parse.commandStart, p);
+
+ /*
+ * TIP #280: Track lines in the just compiled command.
+ */
+
+ TclAdvanceLines(&cmdLine, parsePtr->commandStart, p);
TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source);
-#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;
- }
+ Tcl_FreeParse(parsePtr);
} 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.
- */
-
- if (envPtr->codeNext == entryCodeNext) {
- 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.
+ *
+ * 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.
*/
- 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;
+ if (envPtr->codeNext == entryCodeNext) {
+ TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr);
}
-#endif
- LogCompilationInfo(interp, script, parse.commandStart, commandLength);
- if (gotParse) {
- Tcl_FreeParse(&parse);
- }
- iPtr->termOffset = (p - script);
+ envPtr->numSrcBytes = (p - script);
+ TclStackFree(interp, parsePtr);
Tcl_DStringFree(&ds);
- return code;
}
/*
@@ -1495,38 +1629,37 @@ TclCompileScript(interp, script, numBytes, nested, envPtr)
* TclCompileTokens --
*
* Given an array of tokens parsed from a Tcl command (e.g., the tokens
- * that make up a word) this procedure emits instructions to evaluate
- * the tokens and concatenate their values to form a single result
- * value on the interpreter's runtime evaluation stack.
+ * that make up a word) this procedure emits instructions to evaluate the
+ * tokens and concatenate their values to form a single result value on
+ * the interpreter's runtime evaluation stack.
*
* Results:
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
- *
+ *
* Side effects:
- * Instructions are added to envPtr to push and evaluate the tokens
- * at runtime.
+ * Instructions are added to envPtr to push and evaluate the tokens at
+ * runtime.
*
*----------------------------------------------------------------------
*/
-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.
+void
+TclCompileTokens(
+ Tcl_Interp *interp, /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to
+ * compile. */
+ int count, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
+ 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, code;
+ int length, i;
unsigned char *entryCodeNext = envPtr->codeNext;
-#ifdef TCL_TIP280
#define NUM_STATIC_POS 20
int isLiteral, maxNumCL, numCL;
int* clPosition = NULL;
@@ -1539,7 +1672,7 @@ TclCompileTokens(interp, tokenPtr, count, envPtr)
* any. The table is extended if needed.
*
* Note: Different to the equivalent code in function
- * 'EvalTokensStandard()' (see file "tclBasic.c") we do not seem to need
+ * 'TclSubstTokens()' (see file "tclParse.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
@@ -1562,186 +1695,166 @@ TclCompileTokens(interp, tokenPtr, count, envPtr)
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,
- (int *) NULL, buffer);
- Tcl_DStringAppend(&textBuffer, buffer, length);
+ case TCL_TOKEN_BS:
+ length = TclParseBackslash(tokenPtr->start, tokenPtr->size,
+ NULL, buffer);
+ Tcl_DStringAppend(&textBuffer, buffer, length);
-#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 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));
- }
- clPosition[numCL] = clPos;
- numCL ++;
+ if (numCL >= maxNumCL) {
+ maxNumCL *= 2;
+ clPosition = (int*) ckrealloc ((char*)clPosition,
+ maxNumCL*sizeof(int));
}
+ clPosition[numCL] = clPos;
+ numCL ++;
}
-#endif
- break;
+ }
+ break;
- case TCL_TOKEN_COMMAND:
- /*
- * Push any accumulated chars appearing before the command.
- */
-
- if (Tcl_DStringLength(&textBuffer) > 0) {
- int literal;
-
- literal = TclRegisterLiteral(envPtr,
- Tcl_DStringValue(&textBuffer),
- Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
- TclEmitPush(literal, envPtr);
- numObjsToConcat++;
- 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;
- }
+ 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++;
- break;
+ Tcl_DStringFree(&textBuffer);
- 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);
+ if (numCL) {
+ TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
+ numCL, clPosition);
}
-
- /*
- * 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;
- }
+ 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).
+ */
+
+ name = tokenPtr[1].start;
+ nameBytes = tokenPtr[1].size;
+ localVarName = -1;
+ if (envPtr->procPtr != NULL) {
+ localVarName = 1;
+ for (i = 0, p = name; i < nameBytes; i++, p++) {
+ if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) {
+ localVarName = -1;
+ break;
+ } else if ((*p == '(')
+ && (tokenPtr->numComponents == 1)
+ && (*(name + nameBytes - 1) == ')')) {
+ localVarName = 0;
+ break;
}
}
+ }
- /*
- * Either push the variable's name, or find its index in
- * the array of local variables in a procedure frame.
- */
+ /*
+ * Either push the variable's name, or find its index in the array
+ * of local variables in a procedure frame.
+ */
- localVar = -1;
- if (localVarName != -1) {
- localVar = TclFindCompiledLocal(name, nameBytes,
- localVarName, /*flags*/ 0, envPtr->procPtr);
- }
+ localVar = -1;
+ if (localVarName != -1) {
+ localVar = TclFindCompiledLocal(name, nameBytes, localVarName,
+ envPtr->procPtr);
+ }
+ if (localVar < 0) {
+ TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
+ envPtr);
+ }
+
+ /*
+ * Emit instructions to load the variable.
+ */
+
+ if (tokenPtr->numComponents == 1) {
if (localVar < 0) {
- TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
- envPtr);
+ TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ } else if (localVar <= 255) {
+ TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr);
+ } else {
+ TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr);
}
-
- /*
- * Emit instructions to load the variable.
- */
-
- if (tokenPtr->numComponents == 1) {
- if (localVar < 0) {
- TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
- } else if (localVar <= 255) {
- TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
- envPtr);
- } else {
- TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
- envPtr);
- }
+ } else {
+ TclCompileTokens(interp, tokenPtr+2,
+ tokenPtr->numComponents-1, envPtr);
+ if (localVar < 0) {
+ TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
+ } else if (localVar <= 255) {
+ TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr);
} else {
- 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);
- }
+ TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr);
}
- numObjsToConcat++;
- count -= tokenPtr->numComponents;
- tokenPtr += tokenPtr->numComponents;
- break;
+ }
+ numObjsToConcat++;
+ count -= tokenPtr->numComponents;
+ tokenPtr += tokenPtr->numComponents;
+ break;
- default:
- panic("Unexpected token type in TclCompileTokens");
+ default:
+ Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s",
+ tokenPtr->type, tokenPtr->size, tokenPtr->start);
}
}
@@ -1752,18 +1865,16 @@ TclCompileTokens(interp, tokenPtr, count, envPtr)
if (Tcl_DStringLength(&textBuffer) > 0) {
int literal;
- literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
- Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
+ literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer),
+ Tcl_DStringLength(&textBuffer));
TclEmitPush(literal, envPtr);
numObjsToConcat++;
-#ifdef TCL_TIP280
if (numCL) {
TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr,
numCL, clPosition);
}
numCL = 0;
-#endif
}
/*
@@ -1781,16 +1892,12 @@ TclCompileTokens(interp, tokenPtr, count, envPtr)
/*
* If the tokens yielded no instructions, push an empty string.
*/
-
+
if (envPtr->codeNext == entryCodeNext) {
- TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
- envPtr);
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
}
- 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.
@@ -1799,8 +1906,6 @@ TclCompileTokens(interp, tokenPtr, count, envPtr)
if (maxNumCL) {
ckfree ((char*) clPosition);
}
-#endif
- return code;
}
/*
@@ -1811,53 +1916,45 @@ TclCompileTokens(interp, tokenPtr, count, envPtr)
* Given an array of parse tokens for a word containing one or more Tcl
* commands, emit inline instructions to execute them. This procedure
* differs from TclCompileTokens in that a simple word such as a loop
- * body enclosed in braces is not just pushed as a string, but is
- * itself parsed into tokens and compiled.
+ * body enclosed in braces is not just pushed as a string, but is itself
+ * parsed into tokens and compiled.
*
* Results:
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
- *
+ *
* Side effects:
* Instructions are added to envPtr to execute the tokens at runtime.
*
*----------------------------------------------------------------------
*/
-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.
+void
+TclCompileCmdWord(
+ Tcl_Interp *interp, /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for
+ * a command word to compile inline. */
+ int count, /* Number of tokens to consider at tokenPtr.
* Must be at least 1. */
- CompileEnv *envPtr; /* Holds the resulting instructions. */
+ 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)) {
- code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
- /*nested*/ 0, envPtr);
- return code;
- }
+ /*
+ * Handle the common case: if there is a single text token, compile it
+ * into an inline sequence of instructions.
+ */
- /*
- * 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.
- */
+ 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.
+ */
- code = TclCompileTokens(interp, tokenPtr, count, envPtr);
- if (code != TCL_OK) {
- return code;
+ TclCompileTokens(interp, tokenPtr, count, envPtr);
+ TclEmitOpcode(INST_EVAL_STK, envPtr);
}
- TclEmitOpcode(INST_EVAL_STK, envPtr);
- return TCL_OK;
}
/*
@@ -1874,42 +1971,37 @@ TclCompileCmdWord(interp, tokenPtr, count, envPtr)
* Results:
* The return value is a standard Tcl result. If an error occurs, an
* error message is left in the interpreter's result.
- *
+ *
* Side effects:
* Instructions are added to envPtr to execute the expression.
*
*----------------------------------------------------------------------
*/
-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. */
+void
+TclCompileExprWords(
+ Tcl_Interp *interp, /* Used for error and status reporting. */
+ Tcl_Token *tokenPtr, /* Points to first in an array of word tokens
+ * tokens for the expression to compile
+ * inline. */
+ int numWords, /* Number of word tokens starting at tokenPtr.
+ * Must be at least 1. Each word token
+ * contains one or more subtokens. */
+ CompileEnv *envPtr) /* Holds the resulting instructions. */
{
Tcl_Token *wordPtr;
- int numBytes, i, code;
- CONST char *script;
-
- code = TCL_OK;
+ int i, concatItems;
/*
- * If the expression is a single word that doesn't require
- * substitutions, just compile its string into inline instructions.
+ * If the expression is a single word that doesn't require substitutions,
+ * just compile its string into inline instructions.
*/
if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
- script = tokenPtr[1].start;
- numBytes = tokenPtr[1].size;
- code = TclCompileExpr(interp, script, numBytes, envPtr);
- return code;
+ TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr, 1);
+ return;
}
-
+
/*
* Emit code to call the expr command proc at runtime. Concatenate the
* (already substituted once) expr tokens with a space between each.
@@ -1917,30 +2009,68 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
wordPtr = tokenPtr;
for (i = 0; i < numWords; i++) {
- code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
- envPtr);
- if (code != TCL_OK) {
- break;
- }
+ TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr);
if (i < (numWords - 1)) {
- TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
- envPtr);
+ TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr);
}
wordPtr += (wordPtr->numComponents + 1);
}
- if (code == TCL_OK) {
- int concatItems = 2*numWords - 1;
- while (concatItems > 255) {
- TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
- concatItems -= 254;
- }
- if (concatItems > 1) {
- TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
- }
- TclEmitOpcode(INST_EXPR_STK, envPtr);
+ 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;
- return code;
+ if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) {
+ TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents,
+ envPtr);
+ TclEmitOpcode(INST_POP, envPtr);
+ }
+ }
+ envPtr->currStackDepth = savedStackDepth;
+ TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr);
+ return TCL_OK;
}
/*
@@ -1949,10 +2079,10 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
* TclInitByteCodeObj --
*
* Create a ByteCode structure and initialize it from a CompileEnv
- * compilation environment structure. The ByteCode structure is
- * smaller and contains just that information needed to execute
- * the bytecode instructions resulting from compiling a Tcl script.
- * The resulting structure is placed in the specified object.
+ * compilation environment structure. The ByteCode structure is smaller
+ * and contains just that information needed to execute the bytecode
+ * instructions resulting from compiling a Tcl script. The resulting
+ * structure is placed in the specified object.
*
* Results:
* A newly constructed ByteCode object is stored in the internal
@@ -1960,21 +2090,21 @@ TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
*
* Side effects:
* A single heap object is allocated to hold the new ByteCode structure
- * and its code, object, command location, and aux data arrays. Note
- * that "ownership" (i.e., the pointers to) the Tcl objects and aux
- * data items will be handed over to the new ByteCode structure from
- * the CompileEnv structure.
+ * and its code, object, command location, and aux data arrays. Note that
+ * "ownership" (i.e., the pointers to) the Tcl objects and aux data items
+ * will be handed over to the new ByteCode structure from the CompileEnv
+ * structure.
*
*----------------------------------------------------------------------
*/
void
-TclInitByteCodeObj(objPtr, envPtr)
- Tcl_Obj *objPtr; /* Points object that should be
- * initialized, and whose string rep
- * contains the source code. */
- register CompileEnv *envPtr; /* Points to the CompileEnv structure from
- * which to create a ByteCode structure. */
+TclInitByteCodeObj(
+ Tcl_Obj *objPtr, /* Points object that should be initialized,
+ * and whose string rep contains the source
+ * code. */
+ register CompileEnv *envPtr)/* Points to the CompileEnv structure from
+ * which to create a ByteCode structure. */
{
register ByteCode *codePtr;
size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
@@ -1985,10 +2115,7 @@ TclInitByteCodeObj(objPtr, envPtr)
#endif
int numLitObjects = envPtr->literalArrayNext;
Namespace *namespacePtr;
- int i;
-#ifdef TCL_TIP280
- int new;
-#endif
+ int i, isNew;
Interp *iPtr;
iPtr = envPtr->iPtr;
@@ -1998,24 +2125,24 @@ TclInitByteCodeObj(objPtr, envPtr)
exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
cmdLocBytes = GetCmdLocEncodingSize(envPtr);
-
+
/*
* Compute the total number of bytes needed for this bytecode.
*/
structureSize = sizeof(ByteCode);
- structureSize += TCL_ALIGN(codeBytes); /* align object array */
- structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
+ structureSize += TCL_ALIGN(codeBytes); /* align object array */
+ structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
structureSize += auxDataArrayBytes;
structureSize += cmdLocBytes;
if (envPtr->iPtr->varFramePtr != NULL) {
- namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
+ namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
} else {
- namespacePtr = envPtr->iPtr->globalNsPtr;
+ namespacePtr = envPtr->iPtr->globalNsPtr;
}
-
+
p = (unsigned char *) ckalloc((size_t) structureSize);
codePtr = (ByteCode *) p;
codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
@@ -2023,7 +2150,11 @@ TclInitByteCodeObj(objPtr, envPtr)
codePtr->nsPtr = namespacePtr;
codePtr->nsEpoch = namespacePtr->resolverEpoch;
codePtr->refCount = 1;
- codePtr->flags = 0;
+ if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) {
+ codePtr->flags = TCL_BYTECODE_RESOLVE_VARS;
+ } else {
+ codePtr->flags = 0;
+ }
codePtr->source = envPtr->source;
codePtr->procPtr = envPtr->procPtr;
@@ -2039,28 +2170,26 @@ TclInitByteCodeObj(objPtr, envPtr)
p += sizeof(ByteCode);
codePtr->codeStart = p;
- memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);
-
- p += TCL_ALIGN(codeBytes); /* align object array */
+ memcpy(p, envPtr->codeStart, (size_t) codeBytes);
+
+ p += TCL_ALIGN(codeBytes); /* align object array */
codePtr->objArrayPtr = (Tcl_Obj **) p;
for (i = 0; i < numLitObjects; i++) {
codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
}
- p += TCL_ALIGN(objArrayBytes); /* align exception range array */
+ p += TCL_ALIGN(objArrayBytes); /* align exception range array */
if (exceptArrayBytes > 0) {
codePtr->exceptArrayPtr = (ExceptionRange *) p;
- memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,
- (size_t) exceptArrayBytes);
+ memcpy(p, 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((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
- (size_t) auxDataArrayBytes);
+ memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes);
} else {
codePtr->auxDataArrayPtr = NULL;
}
@@ -2070,11 +2199,11 @@ TclInitByteCodeObj(objPtr, envPtr)
EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
#else
nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
- if (((size_t)(nextPtr - p)) != cmdLocBytes) {
- panic("TclInitByteCodeObj: encoded cmd location bytes %ld != expected size %ld\n", (nextPtr - p), cmdLocBytes);
+ if (((size_t)(nextPtr - p)) != cmdLocBytes) {
+ Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d", (nextPtr - p), cmdLocBytes);
}
#endif
-
+
/*
* Record various compilation-related statistics about the new ByteCode
* structure. Don't include overhead for statistics-related fields.
@@ -2084,115 +2213,29 @@ TclInitByteCodeObj(objPtr, envPtr)
codePtr->structureSize = structureSize
- (sizeof(size_t) + sizeof(Tcl_Time));
Tcl_GetTime(&(codePtr->createTime));
-
+
RecordByteCodeStats(codePtr);
#endif /* TCL_COMPILE_STATS */
-
+
/*
- * Free the old internal rep then convert the object to a
- * bytecode object by making its internal rep point to the just
- * compiled ByteCode.
+ * Free the old internal rep then convert the object to a bytecode object
+ * by making its internal rep point to the just compiled ByteCode.
*/
-
- if ((objPtr->typePtr != NULL) &&
- (objPtr->typePtr->freeIntRepProc != NULL)) {
- (*objPtr->typePtr->freeIntRepProc)(objPtr);
- }
- objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
+
+ TclFreeIntRep(objPtr);
+ objPtr->internalRep.otherValuePtr = (void *) codePtr;
objPtr->typePtr = &tclByteCodeType;
-#ifdef TCL_TIP280
- /* TIP #280. Associate the extended per-word line information with the
+ /*
+ * 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, &new),
- envPtr->extCmdMapPtr);
+ Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr,
+ &isNew), 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.
- *
- *----------------------------------------------------------------------
- */
-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);
+ codePtr->localCachePtr = NULL;
}
/*
@@ -2209,30 +2252,26 @@ LogCompilationInfo(interp, script, command, length)
* Results:
* If create is 0 and the name is non-NULL, then if the variable is
* found, the index of its entry in the procedure's array of local
- * variables is returned; otherwise -1 is returned. If name is NULL,
- * the index of a new temporary variable is returned. Finally, if
- * create is 1 and name is non-NULL, the index of a new entry is
- * returned.
+ * variables is returned; otherwise -1 is returned. If name is NULL, the
+ * index of a new temporary variable is returned. Finally, if create is 1
+ * and name is non-NULL, the index of a new entry is returned.
*
* Side effects:
- * Creates and registers a new local variable if create is 1 and
- * the variable is unknown, or if the name is NULL.
+ * Creates and registers a new local variable if create is 1 and the
+ * variable is unknown, or if the name is NULL.
*
*----------------------------------------------------------------------
*/
int
-TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
- register CONST char *name; /* Points to first character of the name of
- * a scalar or array variable. If NULL, a
+TclFindCompiledLocal(
+ register const char *name, /* Points to first character of the name of a
+ * scalar or array variable. If NULL, a
* temporary var should be created. */
- int nameBytes; /* Number of bytes in the name. */
- int create; /* If 1, allocate a local frame entry for
- * the variable if it is new. */
- 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
+ int nameBytes, /* Number of bytes in the name. */
+ int create, /* If 1, allocate a local frame entry for the
+ * variable if it is new. */
+ register Proc *procPtr) /* Points to structure describing procedure
* containing the variable reference. */
{
register CompiledLocal *localPtr;
@@ -2244,14 +2283,16 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
* name already exist?
*/
- if (name != NULL) {
+ if (name != NULL) {
int localCt = procPtr->numCompiledLocals;
+
localPtr = procPtr->firstLocalPtr;
for (i = 0; i < localCt; i++) {
if (!TclIsVarTemporary(localPtr)) {
char *localName = localPtr->name;
- if ((nameBytes == localPtr->nameLength)
- && (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
+
+ if ((nameBytes == localPtr->nameLength) &&
+ (strncmp(name,localName,(unsigned)nameBytes) == 0)) {
return i;
}
}
@@ -2262,12 +2303,12 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
/*
* Create a new variable if appropriate.
*/
-
+
if (create || (name == NULL)) {
localVar = procPtr->numCompiledLocals;
- localPtr = (CompiledLocal *) ckalloc((unsigned)
- (sizeof(CompiledLocal) - sizeof(localPtr->name)
- + nameBytes+1));
+ localPtr = (CompiledLocal *) ckalloc((unsigned)
+ (sizeof(CompiledLocal) - sizeof(localPtr->name)
+ + nameBytes + 1));
if (procPtr->firstLocalPtr == NULL) {
procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
} else {
@@ -2277,7 +2318,7 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
localPtr->nextPtr = NULL;
localPtr->nameLength = nameBytes;
localPtr->frameIndex = localVar;
- localPtr->flags = flags | VAR_UNDEFINED;
+ localPtr->flags = 0;
if (name == NULL) {
localPtr->flags |= VAR_TEMPORARY;
}
@@ -2285,8 +2326,7 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
localPtr->resolveInfo = NULL;
if (name != NULL) {
- memcpy((VOID *) localPtr->name, (VOID *) name,
- (size_t) nameBytes);
+ memcpy(localPtr->name, name, (size_t) nameBytes);
}
localPtr->name[nameBytes] = '\0';
procPtr->numCompiledLocals++;
@@ -2297,167 +2337,56 @@ TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
/*
*----------------------------------------------------------------------
*
- * TclInitCompiledLocals --
- *
- * This routine is invoked in order to initialize the compiled
- * locals table for a new call frame.
- *
- * Results:
- * None.
- *
- * Side effects:
- * May invoke various name resolvers in order to determine which
- * variables are being referenced at runtime.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclInitCompiledLocals(interp, framePtr, nsPtr)
- Tcl_Interp *interp; /* Current interpreter. */
- CallFrame *framePtr; /* Call frame to initialize. */
- Namespace *nsPtr; /* Pointer to current namespace. */
-{
- register CompiledLocal *localPtr;
- Interp *iPtr = (Interp*) interp;
- Tcl_ResolvedVarInfo *vinfo, *resVarInfo;
- Var *varPtr = framePtr->compiledLocals;
- Var *resolvedVarPtr;
- ResolverScheme *resPtr;
- int result;
-
- /*
- * Initialize the array of local variables stored in the call frame.
- * Some variables may have special resolution rules. In that case,
- * we call their "resolver" procs to get our hands on the variable,
- * and we make the compiled local a link to the real variable.
- */
-
- for (localPtr = framePtr->procPtr->firstLocalPtr;
- localPtr != NULL;
- localPtr = localPtr->nextPtr) {
-
- /*
- * Check to see if this local is affected by namespace or
- * interp resolvers. The resolver to use is cached for the
- * next invocation of the procedure.
- */
-
- if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))
- && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {
- resPtr = iPtr->resolverPtr;
-
- if (nsPtr->compiledVarResProc) {
- result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
- localPtr->name, localPtr->nameLength,
- (Tcl_Namespace *) nsPtr, &vinfo);
- } else {
- result = TCL_CONTINUE;
- }
-
- while ((result == TCL_CONTINUE) && resPtr) {
- if (resPtr->compiledVarResProc) {
- result = (*resPtr->compiledVarResProc)(nsPtr->interp,
- localPtr->name, localPtr->nameLength,
- (Tcl_Namespace *) nsPtr, &vinfo);
- }
- resPtr = resPtr->nextPtr;
- }
- if (result == TCL_OK) {
- localPtr->resolveInfo = vinfo;
- localPtr->flags |= VAR_RESOLVED;
- }
- }
-
- /*
- * Now invoke the resolvers to determine the exact variables that
- * should be used.
- */
-
- resVarInfo = localPtr->resolveInfo;
- resolvedVarPtr = NULL;
-
- if (resVarInfo && resVarInfo->fetchProc) {
- resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
- resVarInfo);
- }
-
- if (resolvedVarPtr) {
- varPtr->name = localPtr->name; /* will be just '\0' if temp var */
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = 0;
- TclSetVarLink(varPtr);
- varPtr->value.linkPtr = resolvedVarPtr;
- resolvedVarPtr->refCount++;
- } else {
- varPtr->value.objPtr = NULL;
- varPtr->name = localPtr->name; /* will be just '\0' if temp var */
- varPtr->nsPtr = NULL;
- varPtr->hPtr = NULL;
- varPtr->refCount = 0;
- varPtr->tracePtr = NULL;
- varPtr->searchPtr = NULL;
- varPtr->flags = localPtr->flags;
- }
- varPtr++;
- }
-}
-
-/*
- *----------------------------------------------------------------------
- *
* TclExpandCodeArray --
*
- * Procedure that uses malloc to allocate more storage for a
- * CompileEnv's code array.
+ * Procedure that uses malloc to allocate more storage for a CompileEnv's
+ * code array.
*
* Results:
- * None.
+ * None.
*
* Side effects:
- * The byte code array in *envPtr is reallocated to a new array of
- * double the size, and if envPtr->mallocedCodeArray is non-zero the
- * old array is freed. Byte codes are copied from the old array to the
- * new one.
+ * The byte code array in *envPtr is reallocated to a new array of double
+ * the size, and if envPtr->mallocedCodeArray is non-zero the old array
+ * is freed. Byte codes are copied from the old array to the new one.
*
*----------------------------------------------------------------------
*/
void
-TclExpandCodeArray(envArgPtr)
- void *envArgPtr; /* Points to the CompileEnv whose code array
+TclExpandCodeArray(
+ 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. */
+ CompileEnv *envPtr = (CompileEnv *) envArgPtr;
+ /* The CompileEnv containing the code array to
+ * be doubled in size. */
/*
* envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
- * code bytes are stored between envPtr->codeStart and
- * (envPtr->codeNext - 1) [inclusive].
+ * 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);
+ size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
- /*
- * 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 = (unsigned char *)
+ ckrealloc((char *)envPtr->codeStart, newBytes);
+ } else {
+ /*
+ * envPtr->codeStart isn't a ckalloc'd pointer, so we must
+ * code a ckrealloc equivalent for ourselves.
+ */
+ unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
+ memcpy(newPtr, envPtr->codeStart, currBytes);
+ envPtr->codeStart = newPtr;
+ envPtr->mallocedCodeArray = 1;
}
- envPtr->codeStart = newPtr;
- envPtr->codeNext = (newPtr + currBytes);
- envPtr->codeEnd = (newPtr + newBytes);
- envPtr->mallocedCodeArray = 1;
+
+ envPtr->codeNext = (envPtr->codeStart + currBytes);
+ envPtr->codeEnd = (envPtr->codeStart + newBytes);
}
/*
@@ -2465,37 +2394,37 @@ TclExpandCodeArray(envArgPtr)
*
* EnterCmdStartData --
*
- * Registers the starting source and bytecode location of a
- * command. This information is used at runtime to map between
- * instruction pc and source locations.
+ * Registers the starting source and bytecode location of a command. This
+ * information is used at runtime to map between instruction pc and
+ * source locations.
*
* Results:
* None.
*
* Side effects:
* Inserts source and code location information into the compilation
- * environment envPtr for the command at index cmdIndex. The
- * compilation environment's CmdLocation array is grown if necessary.
+ * environment envPtr for the command at index cmdIndex. The compilation
+ * environment's CmdLocation array is grown if necessary.
*
*----------------------------------------------------------------------
*/
static void
-EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
- CompileEnv *envPtr; /* Points to the compilation environment
+EnterCmdStartData(
+ CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
- int cmdIndex; /* Index of the command whose start data
- * is being set. */
- int srcOffset; /* Offset of first char of the command. */
- int codeOffset; /* Offset of first byte of command code. */
+ int cmdIndex, /* Index of the command whose start data is
+ * being set. */
+ int srcOffset, /* Offset of first char of the command. */
+ int codeOffset) /* Offset of first byte of command code. */
{
CmdLocation *cmdLocPtr;
-
+
if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
- panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
+ Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex);
}
-
+
if (cmdIndex >= envPtr->cmdMapEnd) {
/*
* Expand the command location array by allocating more storage from
@@ -2504,28 +2433,29 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
*/
size_t currElems = envPtr->cmdMapEnd;
- size_t newElems = 2*currElems;
+ size_t newElems = 2*currElems;
size_t currBytes = currElems * sizeof(CmdLocation);
- size_t newBytes = newElems * sizeof(CmdLocation);
- 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);
+ size_t newBytes = newElems * sizeof(CmdLocation);
+
if (envPtr->mallocedCmdMap) {
- ckfree((char *) envPtr->cmdMapPtr);
+ envPtr->cmdMapPtr = (CmdLocation *)
+ ckrealloc((char *) envPtr->cmdMapPtr, newBytes);
+ } else {
+ /*
+ * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must
+ * code a ckrealloc equivalent for ourselves.
+ */
+ CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
+ memcpy(newPtr, envPtr->cmdMapPtr, currBytes);
+ envPtr->cmdMapPtr = newPtr;
+ envPtr->mallocedCmdMap = 1;
}
- envPtr->cmdMapPtr = (CmdLocation *) newPtr;
envPtr->cmdMapEnd = newElems;
- envPtr->mallocedCmdMap = 1;
}
if (cmdIndex > 0) {
if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
- panic("EnterCmdStartData: cmd map not sorted by code offset");
+ Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset");
}
}
@@ -2550,32 +2480,32 @@ EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
*
* Side effects:
* Inserts source and code length information into the compilation
- * environment envPtr for the command at index cmdIndex. Starting
- * source and bytecode information for the command must already
- * have been registered.
+ * environment envPtr for the command at index cmdIndex. Starting source
+ * and bytecode information for the command must already have been
+ * registered.
*
*----------------------------------------------------------------------
*/
static void
-EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
- CompileEnv *envPtr; /* Points to the compilation environment
+EnterCmdExtentData(
+ CompileEnv *envPtr, /* Points to the compilation environment
* structure in which to enter command
* location information. */
- int cmdIndex; /* Index of the command whose source and
- * code length data is being set. */
- int numSrcBytes; /* Number of command source chars. */
- int numCodeBytes; /* Offset of last byte of command code. */
+ int cmdIndex, /* Index of the command whose source and code
+ * length data is being set. */
+ int numSrcBytes, /* Number of command source chars. */
+ int numCodeBytes) /* Offset of last byte of command code. */
{
CmdLocation *cmdLocPtr;
if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
- panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
+ Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex);
}
-
+
if (cmdIndex > envPtr->cmdMapEnd) {
- panic("EnterCmdExtentData: missing start data for command %d\n",
- cmdIndex);
+ Tcl_Panic("EnterCmdExtentData: missing start data for command %d",
+ cmdIndex);
}
cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
@@ -2583,105 +2513,86 @@ EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
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(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;
+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;
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 currBytes = currElems * sizeof(ECL);
- size_t newBytes = newElems * sizeof(ECL);
- ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes);
+ size_t newElems = (currElems ? 2*currElems : 1);
+ size_t newBytes = newElems * sizeof(ECL);
- /*
- * 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->loc = (ECL *) ckrealloc((char *)(eclPtr->loc), newBytes);
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)
- ? wordLine
- : -1);
- ePtr->line [wordIdx] = wordLine;
- ePtr->next [wordIdx] = wordNext;
+ wwlines[wordIdx] =
+ (TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1);
+ ePtr->line[wordIdx] = wordLine;
+ ePtr->next[wordIdx] = wordNext;
last = tokenPtr->start;
}
*wlines = wwlines;
eclPtr->nuloc ++;
}
-#endif
/*
*----------------------------------------------------------------------
@@ -2695,55 +2606,53 @@ EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, clNext,
* 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(type, envPtr)
- ExceptionRangeType type; /* The kind of ExceptionRange desired. */
- register CompileEnv *envPtr;/* Points to CompileEnv for which to
- * create a new ExceptionRange structure. */
+TclCreateExceptRange(
+ ExceptionRangeType type, /* The kind of ExceptionRange desired. */
+ register CompileEnv *envPtr)/* Points to CompileEnv for which to create a
+ * new ExceptionRange structure. */
{
register ExceptionRange *rangePtr;
int index = envPtr->exceptArrayNext;
-
+
if (index >= envPtr->exceptArrayEnd) {
- /*
+ /*
* Expand the ExceptionRange array. The currently allocated entries
* are stored between elements 0 and (envPtr->exceptArrayNext - 1)
* [inclusive].
*/
-
+
size_t currBytes =
- envPtr->exceptArrayNext * sizeof(ExceptionRange);
+ envPtr->exceptArrayNext * sizeof(ExceptionRange);
int newElems = 2*envPtr->exceptArrayEnd;
size_t newBytes = newElems * sizeof(ExceptionRange);
- ExceptionRange *newPtr = (ExceptionRange *)
- ckalloc((unsigned) newBytes);
-
- /*
- * Copy from old ExceptionRange array to new, free old
- * ExceptionRange array if needed, and mark the new ExceptionRange
- * array as malloced.
- */
-
- memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr,
- currBytes);
+
if (envPtr->mallocedExceptArray) {
- ckfree((char *) envPtr->exceptArrayPtr);
+ envPtr->exceptArrayPtr = (ExceptionRange *)
+ ckrealloc((char *)(envPtr->exceptArrayPtr), newBytes);
+ } else {
+ /*
+ * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must
+ * code a ckrealloc equivalent for ourselves.
+ */
+ ExceptionRange *newPtr = (ExceptionRange *)
+ ckalloc((unsigned) newBytes);
+ memcpy(newPtr, envPtr->exceptArrayPtr, currBytes);
+ envPtr->exceptArrayPtr = newPtr;
+ envPtr->mallocedExceptArray = 1;
}
- envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
envPtr->exceptArrayEnd = newElems;
- envPtr->mallocedExceptArray = 1;
}
envPtr->exceptArrayNext++;
-
+
rangePtr = &(envPtr->exceptArrayPtr[index]);
rangePtr->type = type;
rangePtr->nestingLevel = envPtr->exceptDepth;
@@ -2760,8 +2669,8 @@ TclCreateExceptRange(type, envPtr)
*
* TclCreateAuxData --
*
- * Procedure that allocates and initializes a new AuxData structure in
- * a CompileEnv's array of compilation auxiliary data records. These
+ * Procedure that allocates and initializes a new AuxData structure in a
+ * CompileEnv's array of compilation auxiliary data records. These
* AuxData records hold information created during compilation by
* CompileProcs and used by instructions during execution.
*
@@ -2769,56 +2678,57 @@ TclCreateExceptRange(type, envPtr)
* Returns the index for the newly created AuxData structure.
*
* Side effects:
- * If there is not enough room in the CompileEnv's AuxData array,
- * the AuxData array in expanded: a new array of double the size
- * is allocated, if envPtr->mallocedAuxDataArray is non-zero
- * the old array is freed, and AuxData entries are copied from
- * the old array to the new one.
+ * If there is not enough room in the CompileEnv's AuxData array, the
+ * AuxData array in expanded: a new array of double the size is
+ * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array
+ * is freed, and AuxData entries are copied from the old array to the new
+ * one.
*
*----------------------------------------------------------------------
*/
int
-TclCreateAuxData(clientData, typePtr, envPtr)
- ClientData clientData; /* The compilation auxiliary data to store
- * in the new aux data record. */
- AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */
- register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
+TclCreateAuxData(
+ ClientData clientData, /* The compilation auxiliary data to store in
+ * the new aux data record. */
+ AuxDataType *typePtr, /* Pointer to the type to attach to this
+ * AuxData */
+ register CompileEnv *envPtr)/* Points to the CompileEnv for which a new
* aux data structure is to be allocated. */
{
int index; /* Index for the new AuxData structure. */
register AuxData *auxDataPtr;
/* Points to the new AuxData structure */
-
+
index = envPtr->auxDataArrayNext;
if (index >= envPtr->auxDataArrayEnd) {
- /*
+ /*
* Expand the AuxData array. The currently allocated entries are
* stored between elements 0 and (envPtr->auxDataArrayNext - 1)
* [inclusive].
*/
-
+
size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
int newElems = 2*envPtr->auxDataArrayEnd;
size_t newBytes = newElems * sizeof(AuxData);
- AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
-
- /*
- * Copy from old AuxData array to new, free old AuxData array if
- * needed, and mark the new AuxData array as malloced.
- */
-
- memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
- currBytes);
+
if (envPtr->mallocedAuxDataArray) {
- ckfree((char *) envPtr->auxDataArrayPtr);
+ envPtr->auxDataArrayPtr = (AuxData *)
+ ckrealloc((char *)(envPtr->auxDataArrayPtr), newBytes);
+ } else {
+ /*
+ * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must
+ * code a ckrealloc equivalent for ourselves.
+ */
+ AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
+ memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes);
+ envPtr->auxDataArrayPtr = newPtr;
+ envPtr->mallocedAuxDataArray = 1;
}
- envPtr->auxDataArrayPtr = newPtr;
envPtr->auxDataArrayEnd = newElems;
- envPtr->mallocedAuxDataArray = 1;
}
envPtr->auxDataArrayNext++;
-
+
auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
auxDataPtr->clientData = clientData;
auxDataPtr->type = typePtr;
@@ -2830,8 +2740,8 @@ TclCreateAuxData(clientData, typePtr, envPtr)
*
* TclInitJumpFixupArray --
*
- * Initializes a JumpFixupArray structure to hold some number of
- * jump fixup entries.
+ * Initializes a JumpFixupArray structure to hold some number of jump
+ * fixup entries.
*
* Results:
* None.
@@ -2843,10 +2753,10 @@ TclCreateAuxData(clientData, typePtr, envPtr)
*/
void
-TclInitJumpFixupArray(fixupArrayPtr)
- register JumpFixupArray *fixupArrayPtr;
- /* Points to the JumpFixupArray structure
- * to initialize. */
+TclInitJumpFixupArray(
+ register JumpFixupArray *fixupArrayPtr)
+ /* Points to the JumpFixupArray structure to
+ * initialize. */
{
fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
fixupArrayPtr->next = 0;
@@ -2859,8 +2769,8 @@ TclInitJumpFixupArray(fixupArrayPtr)
*
* TclExpandJumpFixupArray --
*
- * Procedure that uses malloc to allocate more storage for a
- * jump fixup array.
+ * Procedure that uses malloc to allocate more storage for a jump fixup
+ * array.
*
* Results:
* None.
@@ -2868,41 +2778,42 @@ TclInitJumpFixupArray(fixupArrayPtr)
* Side effects:
* The jump fixup array in *fixupArrayPtr is reallocated to a new array
* of double the size, and if fixupArrayPtr->mallocedArray is non-zero
- * the old array is freed. Jump fixup structures are copied from the
- * old array to the new one.
+ * the old array is freed. Jump fixup structures are copied from the old
+ * array to the new one.
*
*----------------------------------------------------------------------
*/
void
-TclExpandJumpFixupArray(fixupArrayPtr)
- register JumpFixupArray *fixupArrayPtr;
- /* Points to the JumpFixupArray structure
- * to enlarge. */
+TclExpandJumpFixupArray(
+ register JumpFixupArray *fixupArrayPtr)
+ /* Points to the JumpFixupArray structure
+ * to enlarge. */
{
/*
- * The currently allocated jump fixup entries are stored from fixup[0]
- * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
+ * The currently allocated jump fixup entries are stored from fixup[0] up
+ * to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
* fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
*/
size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
int newElems = 2*(fixupArrayPtr->end + 1);
size_t newBytes = newElems * sizeof(JumpFixup);
- JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
- /*
- * Copy from the old array to new, free the old array if needed,
- * and mark the new array as malloced.
- */
-
- memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
if (fixupArrayPtr->mallocedArray) {
- ckfree((char *) fixupArrayPtr->fixup);
+ fixupArrayPtr->fixup = (JumpFixup *)
+ ckrealloc((char *)(fixupArrayPtr->fixup), newBytes);
+ } else {
+ /*
+ * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must
+ * code a ckrealloc equivalent for ourselves.
+ */
+ JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
+ memcpy(newPtr, fixupArrayPtr->fixup, currBytes);
+ fixupArrayPtr->fixup = newPtr;
+ fixupArrayPtr->mallocedArray = 1;
}
- fixupArrayPtr->fixup = (JumpFixup *) newPtr;
fixupArrayPtr->end = newElems;
- fixupArrayPtr->mallocedArray = 1;
}
/*
@@ -2922,10 +2833,10 @@ TclExpandJumpFixupArray(fixupArrayPtr)
*/
void
-TclFreeJumpFixupArray(fixupArrayPtr)
- register JumpFixupArray *fixupArrayPtr;
- /* Points to the JumpFixupArray structure
- * to free. */
+TclFreeJumpFixupArray(
+ register JumpFixupArray *fixupArrayPtr)
+ /* Points to the JumpFixupArray structure to
+ * free. */
{
if (fixupArrayPtr->mallocedArray) {
ckfree((char *) fixupArrayPtr->fixup);
@@ -2940,27 +2851,27 @@ TclFreeJumpFixupArray(fixupArrayPtr)
* Procedure to emit a two-byte forward jump of kind "jumpType". Since
* the jump may later have to be grown to five bytes if the jump target
* is more than, say, 127 bytes away, this procedure also initializes a
- * JumpFixup record with information about the jump.
+ * JumpFixup record with information about the jump.
*
* Results:
* None.
*
* Side effects:
- * The JumpFixup record pointed to by "jumpFixupPtr" is initialized
- * with information needed later if the jump is to be grown. Also,
- * a two byte jump of the designated type is emitted at the current
- * point in the bytecode stream.
+ * The JumpFixup record pointed to by "jumpFixupPtr" is initialized with
+ * information needed later if the jump is to be grown. Also, a two byte
+ * jump of the designated type is emitted at the current point in the
+ * bytecode stream.
*
*----------------------------------------------------------------------
*/
void
-TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
- CompileEnv *envPtr; /* Points to the CompileEnv structure that
+TclEmitForwardJump(
+ 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. */
{
@@ -2968,15 +2879,15 @@ TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
* Initialize the JumpFixup structure:
* - codeOffset is offset of first byte of jump below
* - cmdIndex is index of the command after the current one
- * - exceptIndex is the index of the first ExceptionRange after
- * the current one.
+ * - exceptIndex is the index of the first ExceptionRange after the
+ * current one.
*/
-
+
jumpFixupPtr->jumpType = jumpType;
jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
jumpFixupPtr->cmdIndex = envPtr->numCommands;
jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
-
+
switch (jumpType) {
case TCL_UNCONDITIONAL_JUMP:
TclEmitInstInt1(INST_JUMP1, 0, envPtr);
@@ -2995,43 +2906,41 @@ TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
*
* TclFixupForwardJump --
*
- * Procedure that updates a previously-emitted forward jump to jump
- * a specified number of bytes, "jumpDist". If necessary, the jump is
- * grown from two to five bytes; this is done if the jump distance is
- * greater than "distThreshold" (normally 127 bytes). The jump is
- * described by a JumpFixup record previously initialized by
- * TclEmitForwardJump.
+ * Procedure that updates a previously-emitted forward jump to jump a
+ * specified number of bytes, "jumpDist". If necessary, the jump is grown
+ * from two to five bytes; this is done if the jump distance is greater
+ * than "distThreshold" (normally 127 bytes). The jump is described by a
+ * JumpFixup record previously initialized by TclEmitForwardJump.
*
* Results:
* 1 if the jump was grown and subsequent instructions had to be moved;
- * otherwise 0. This result is returned to allow callers to update
- * any additional code offsets they may hold.
+ * otherwise 0. This result is returned to allow callers to update any
+ * additional code offsets they may hold.
*
* Side effects:
* The jump may be grown and subsequent instructions moved. If this
* happens, the code offsets for any commands and any ExceptionRange
- * records between the jump and the current code address will be
- * updated to reflect the moved code. Also, the bytecode instruction
- * array in the CompileEnv structure may be grown and reallocated.
+ * records between the jump and the current code address will be updated
+ * to reflect the moved code. Also, the bytecode instruction array in the
+ * CompileEnv structure may be grown and reallocated.
*
*----------------------------------------------------------------------
*/
int
-TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
- CompileEnv *envPtr; /* Points to the CompileEnv structure that
+TclFixupForwardJump(
+ 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
- * instruction. */
- int distThreshold; /* Maximum distance before the two byte
- * jump is grown to five bytes. */
+ int jumpDist, /* Jump distance to set in jump instr. */
+ int distThreshold) /* Maximum distance before the two byte jump
+ * is grown to five bytes. */
{
unsigned char *jumpPc, *p;
int firstCmd, lastCmd, firstRange, lastRange, k;
- unsigned int numBytes;
-
+ unsigned numBytes;
+
if (jumpDist <= distThreshold) {
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
switch (jumpFixupPtr->jumpType) {
@@ -3049,14 +2958,14 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
}
/*
- * We must grow the jump then move subsequent instructions down.
- * Note that if we expand the space for generated instructions,
- * code addresses might change; be careful about updating any of
- * these addresses held in variables.
+ * We must grow the jump then move subsequent instructions down. Note that
+ * if we expand the space for generated instructions, code addresses might
+ * change; be careful about updating any of these addresses held in
+ * variables.
*/
-
+
if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
- TclExpandCodeArray(envPtr);
+ TclExpandCodeArray(envPtr);
}
jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
numBytes = envPtr->codeNext-jumpPc-2;
@@ -3076,26 +2985,26 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
break;
}
-
+
/*
- * Adjust the code offsets for any commands and any ExceptionRange
- * records between the jump and the current code address.
+ * Adjust the code offsets for any commands and any ExceptionRange records
+ * between the jump and the current code address.
*/
-
+
firstCmd = jumpFixupPtr->cmdIndex;
- lastCmd = (envPtr->numCommands - 1);
+ lastCmd = (envPtr->numCommands - 1);
if (firstCmd < lastCmd) {
for (k = firstCmd; k <= lastCmd; k++) {
(envPtr->cmdMapPtr[k]).codeOffset += 3;
}
}
-
+
firstRange = jumpFixupPtr->exceptIndex;
- lastRange = (envPtr->exceptArrayNext - 1);
+ lastRange = (envPtr->exceptArrayNext - 1);
for (k = firstRange; k <= lastRange; k++) {
ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
rangePtr->codeOffset += 3;
-
+
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
rangePtr->breakOffset += 3;
@@ -3107,10 +3016,74 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
rangePtr->catchOffset += 3;
break;
default:
- panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
- rangePtr->type);
+ Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d",
+ 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 */
}
@@ -3119,9 +3092,9 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
*
* TclGetInstructionTable --
*
- * Returns a pointer to the table describing Tcl bytecode instructions.
- * This procedure is defined so that clients can access the pointer from
- * outside the TCL DLLs.
+ * Returns a pointer to the table describing Tcl bytecode instructions.
+ * This procedure is defined so that clients can access the pointer from
+ * outside the TCL DLLs.
*
* Results:
* Returns a pointer to the global instruction table, same as the
@@ -3134,7 +3107,7 @@ TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
*/
void * /* == InstructionDesc* == */
-TclGetInstructionTable()
+TclGetInstructionTable(void)
{
return &tclInstructionTable[0];
}
@@ -3144,32 +3117,32 @@ TclGetInstructionTable()
*
* TclRegisterAuxDataType --
*
- * This procedure is called to register a new AuxData type
- * in the table of all AuxData types supported by Tcl.
+ * This procedure is called to register a new AuxData type in the table
+ * of all AuxData types supported by Tcl.
*
* Results:
* None.
*
* Side effects:
* The type is registered in the AuxData type table. If there was already
- * a type with the same name as in typePtr, it is replaced with the
- * new type.
+ * a type with the same name as in typePtr, it is replaced with the new
+ * type.
*
*--------------------------------------------------------------
*/
void
-TclRegisterAuxDataType(typePtr)
- AuxDataType *typePtr; /* Information about object type;
- * storage must be statically
- * allocated (must live forever). */
+TclRegisterAuxDataType(
+ AuxDataType *typePtr) /* Information about object type; storage must
+ * be statically allocated (must live forever;
+ * will not be deallocated). */
{
register Tcl_HashEntry *hPtr;
- int new;
+ int isNew;
Tcl_MutexLock(&tableMutex);
if (!auxDataTypeTableInitialized) {
- TclInitAuxDataTypeTable();
+ TclInitAuxDataTypeTable();
}
/*
@@ -3177,17 +3150,17 @@ TclRegisterAuxDataType(typePtr)
*/
hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
- if (hPtr != (Tcl_HashEntry *) NULL) {
- Tcl_DeleteHashEntry(hPtr);
+ if (hPtr != NULL) {
+ Tcl_DeleteHashEntry(hPtr);
}
/*
* Now insert the new object type.
*/
- hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
- if (new) {
- Tcl_SetHashValue(hPtr, typePtr);
+ hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &isNew);
+ if (isNew) {
+ Tcl_SetHashValue(hPtr, typePtr);
}
Tcl_MutexUnlock(&tableMutex);
}
@@ -3210,20 +3183,20 @@ TclRegisterAuxDataType(typePtr)
*/
AuxDataType *
-TclGetAuxDataType(typeName)
- char *typeName; /* Name of AuxData type to look up. */
+TclGetAuxDataType(
+ 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 != (Tcl_HashEntry *) NULL) {
- typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
+ if (hPtr != NULL) {
+ typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
}
Tcl_MutexUnlock(&tableMutex);
@@ -3235,8 +3208,8 @@ TclGetAuxDataType(typeName)
*
* TclInitAuxDataTypeTable --
*
- * This procedure is invoked to perform once-only initialization of
- * the AuxData type table. It also registers the AuxData types defined in
+ * This procedure is invoked to perform once-only initialization of the
+ * AuxData type table. It also registers the AuxData types defined in
* this file.
*
* Results:
@@ -3250,7 +3223,7 @@ TclGetAuxDataType(typeName)
*/
void
-TclInitAuxDataTypeTable()
+TclInitAuxDataTypeTable(void)
{
/*
* The table mutex must already be held before this routine is invoked.
@@ -3260,10 +3233,11 @@ TclInitAuxDataTypeTable()
Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
/*
- * There is only one AuxData type at this time, so register it here.
+ * There are only two AuxData type at this time, so register them here.
*/
TclRegisterAuxDataType(&tclForeachInfoType);
+ TclRegisterAuxDataType(&tclJumptableInfoType);
}
/*
@@ -3271,10 +3245,10 @@ TclInitAuxDataTypeTable()
*
* TclFinalizeAuxDataTypeTable --
*
- * This procedure is called by Tcl_Finalize after all exit handlers
- * have been run to free up storage associated with the table of AuxData
- * types. This procedure is called by TclFinalizeExecution() which
- * is called by Tcl_Finalize().
+ * This procedure is called by Tcl_Finalize after all exit handlers have
+ * been run to free up storage associated with the table of AuxData
+ * types. This procedure is called by TclFinalizeExecution() which is
+ * called by Tcl_Finalize().
*
* Results:
* None.
@@ -3286,12 +3260,12 @@ TclInitAuxDataTypeTable()
*/
void
-TclFinalizeAuxDataTypeTable()
+TclFinalizeAuxDataTypeTable(void)
{
Tcl_MutexLock(&tableMutex);
if (auxDataTypeTableInitialized) {
- Tcl_DeleteHashTable(&auxDataTypeTable);
- auxDataTypeTableInitialized = 0;
+ Tcl_DeleteHashTable(&auxDataTypeTable);
+ auxDataTypeTableInitialized = 0;
}
Tcl_MutexUnlock(&tableMutex);
}
@@ -3314,18 +3288,18 @@ TclFinalizeAuxDataTypeTable()
*/
static int
-GetCmdLocEncodingSize(envPtr)
- CompileEnv *envPtr; /* Points to compilation environment
- * structure containing the CmdLocation
- * structure to encode. */
+GetCmdLocEncodingSize(
+ CompileEnv *envPtr) /* Points to compilation environment structure
+ * containing the CmdLocation structure to
+ * encode. */
{
register CmdLocation *mapPtr = envPtr->cmdMapPtr;
int numCmds = envPtr->numCommands;
int codeDelta, codeLen, srcDelta, srcLen;
int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
/* The offsets in their respective byte
- * sequences where the next encoded offset
- * or length should go. */
+ * sequences where the next encoded offset or
+ * length should go. */
int prevCodeOffset, prevSrcOffset, i;
codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
@@ -3333,7 +3307,7 @@ GetCmdLocEncodingSize(envPtr)
for (i = 0; i < numCmds; i++) {
codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
if (codeDelta < 0) {
- panic("GetCmdLocEncodingSize: bad code offset");
+ Tcl_Panic("GetCmdLocEncodingSize: bad code offset");
} else if (codeDelta <= 127) {
codeDeltaNext++;
} else {
@@ -3343,7 +3317,7 @@ GetCmdLocEncodingSize(envPtr)
codeLen = mapPtr[i].numCodeBytes;
if (codeLen < 0) {
- panic("GetCmdLocEncodingSize: bad code length");
+ Tcl_Panic("GetCmdLocEncodingSize: bad code length");
} else if (codeLen <= 127) {
codeLengthNext++;
} else {
@@ -3360,7 +3334,7 @@ GetCmdLocEncodingSize(envPtr)
srcLen = mapPtr[i].numSrcBytes;
if (srcLen < 0) {
- panic("GetCmdLocEncodingSize: bad source length");
+ Tcl_Panic("GetCmdLocEncodingSize: bad source length");
} else if (srcLen <= 127) {
srcLengthNext++;
} else {
@@ -3376,8 +3350,8 @@ GetCmdLocEncodingSize(envPtr)
*
* EncodeCmdLocMap --
*
- * Encode the command location information for some compiled code into
- * a ByteCode structure. The encoded command location map is stored as
+ * Encode the command location information for some compiled code into a
+ * ByteCode structure. The encoded command location map is stored as
* three adjacent byte sequences.
*
* Results:
@@ -3385,30 +3359,30 @@ GetCmdLocEncodingSize(envPtr)
* information.
*
* Side effects:
- * The encoded information is stored into the block of memory headed
- * by codePtr. Also records pointers to the start of the four byte
- * sequences in fields in codePtr's ByteCode header structure.
+ * The encoded information is stored into the block of memory headed by
+ * codePtr. Also records pointers to the start of the four byte sequences
+ * in fields in codePtr's ByteCode header structure.
*
*----------------------------------------------------------------------
*/
static unsigned char *
-EncodeCmdLocMap(envPtr, codePtr, startPtr)
- CompileEnv *envPtr; /* Points to compilation environment
- * structure containing the CmdLocation
- * structure to encode. */
- ByteCode *codePtr; /* ByteCode in which to encode envPtr's
+EncodeCmdLocMap(
+ CompileEnv *envPtr, /* Points to compilation environment structure
+ * containing the CmdLocation structure to
+ * encode. */
+ ByteCode *codePtr, /* ByteCode in which to encode envPtr's
* command location information. */
- unsigned char *startPtr; /* Points to the first byte in codePtr's
- * memory block where the location
- * information is to be stored. */
+ 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.
*/
@@ -3418,7 +3392,7 @@ EncodeCmdLocMap(envPtr, codePtr, startPtr)
for (i = 0; i < numCmds; i++) {
codeDelta = (mapPtr[i].codeOffset - prevOffset);
if (codeDelta < 0) {
- panic("EncodeCmdLocMap: bad code offset");
+ Tcl_Panic("EncodeCmdLocMap: bad code offset");
} else if (codeDelta <= 127) {
TclStoreInt1AtPtr(codeDelta, p);
p++;
@@ -3439,7 +3413,7 @@ EncodeCmdLocMap(envPtr, codePtr, startPtr)
for (i = 0; i < numCmds; i++) {
codeLen = mapPtr[i].numCodeBytes;
if (codeLen < 0) {
- panic("EncodeCmdLocMap: bad code length");
+ Tcl_Panic("EncodeCmdLocMap: bad code length");
} else if (codeLen <= 127) {
TclStoreInt1AtPtr(codeLen, p);
p++;
@@ -3479,7 +3453,7 @@ EncodeCmdLocMap(envPtr, codePtr, startPtr)
for (i = 0; i < numCmds; i++) {
srcLen = mapPtr[i].numSrcBytes;
if (srcLen < 0) {
- panic("EncodeCmdLocMap: bad source length");
+ Tcl_Panic("EncodeCmdLocMap: bad source length");
} else if (srcLen <= 127) {
TclStoreInt1AtPtr(srcLen, p);
p++;
@@ -3490,7 +3464,7 @@ EncodeCmdLocMap(envPtr, codePtr, startPtr)
p += 4;
}
}
-
+
return p;
}
@@ -3500,8 +3474,8 @@ EncodeCmdLocMap(envPtr, codePtr, startPtr)
*
* TclPrintByteCodeObj --
*
- * This procedure prints ("disassembles") the instructions of a
- * bytecode object to stdout.
+ * This procedure prints ("disassembles") the instructions of a bytecode
+ * object to stdout.
*
* Results:
* None.
@@ -3513,19 +3487,140 @@ EncodeCmdLocMap(envPtr, codePtr, startPtr)
*/
void
-TclPrintByteCodeObj(interp, objPtr)
- Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
- Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
+TclPrintByteCodeObj(
+ Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */
+ Tcl_Obj *objPtr) /* The bytecode object to disassemble. */
{
- ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ 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;
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; /* already freed */
+ return bufferObj; /* Already freed. */
}
codeStart = codePtr->codeStart;
@@ -3536,62 +3631,70 @@ TclPrintByteCodeObj(interp, objPtr)
* Print header lines describing the ByteCode.
*/
- fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
- (unsigned int) codePtr, codePtr->refCount,
- codePtr->compileEpoch, (unsigned int) iPtr,
+ sprintf(ptrBuf1, "%p", codePtr);
+ sprintf(ptrBuf2, "%p", iPtr);
+ Tcl_AppendPrintfToObj(bufferObj,
+ "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n",
+ ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2,
iPtr->compileEpoch);
- fprintf(stdout, " Source ");
- TclPrintSource(stdout, codePtr->source,
+ Tcl_AppendToObj(bufferObj, " Source ", -1);
+ PrintSourceToObj(bufferObj, codePtr->source,
TclMin(codePtr->numSrcBytes, 55));
- fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
+ Tcl_AppendPrintfToObj(bufferObj,
+ "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
codePtr->numLitObjects, codePtr->numAuxDataItems,
codePtr->maxStackDepth,
#ifdef TCL_COMPILE_STATS
- (codePtr->numSrcBytes?
- ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
-#else
- 0.0);
+ codePtr->numSrcBytes?
+ codePtr->structureSize/(float)codePtr->numSrcBytes :
#endif
+ 0.0);
+
#ifdef TCL_COMPILE_STATS
- fprintf(stdout,
- " Code %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))),
+ Tcl_AppendPrintfToObj(bufferObj,
+ " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
+ (unsigned long) codePtr->structureSize,
+ (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)),
codePtr->numCodeBytes,
- (unsigned long)(codePtr->numLitObjects * sizeof(Tcl_Obj *)),
- (unsigned long)(codePtr->numExceptRanges * sizeof(ExceptionRange)),
- (unsigned long)(codePtr->numAuxDataItems * sizeof(AuxData)),
+ (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;
- fprintf(stdout,
- " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
- (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
+
+ sprintf(ptrBuf1, "%p", procPtr);
+ Tcl_AppendPrintfToObj(bufferObj,
+ " Proc 0x%s, refCt %d, args %d, compiled locals %d\n",
+ ptrBuf1, procPtr->refCount, procPtr->numArgs,
numCompiledLocals);
if (numCompiledLocals > 0) {
CompiledLocal *localPtr = procPtr->firstLocalPtr;
+
for (i = 0; i < numCompiledLocals; i++) {
- 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" : ""));
+ Tcl_AppendPrintfToObj(bufferObj,
+ " slot %d%s%s%s%s%s%s", i,
+ (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar",
+ (localPtr->flags & VAR_ARRAY) ? ", array" : "",
+ (localPtr->flags & VAR_LINK) ? ", link" : "",
+ (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "",
+ (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "",
+ (localPtr->flags & VAR_RESOLVED) ? ", resolved" : "");
if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
} else {
- fprintf(stdout, ", \"%s\"\n", localPtr->name);
+ Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n",
+ localPtr->name);
}
localPtr = localPtr->nextPtr;
}
@@ -3603,58 +3706,60 @@ TclPrintByteCodeObj(interp, objPtr)
*/
if (codePtr->numExceptRanges > 0) {
- fprintf(stdout, " Exception ranges %d, depth %d:\n",
- codePtr->numExceptRanges, codePtr->maxExceptDepth);
+ Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n",
+ codePtr->numExceptRanges, codePtr->maxExceptDepth);
for (i = 0; i < codePtr->numExceptRanges; i++) {
ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
- fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
+
+ Tcl_AppendPrintfToObj(bufferObj,
+ " %d: level %d, %s, pc %d-%d, ",
i, rangePtr->nestingLevel,
- ((rangePtr->type == LOOP_EXCEPTION_RANGE)
- ? "loop" : "catch"),
+ (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"),
rangePtr->codeOffset,
(rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
switch (rangePtr->type) {
case LOOP_EXCEPTION_RANGE:
- fprintf(stdout, "continue %d, break %d\n",
- rangePtr->continueOffset, rangePtr->breakOffset);
+ Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n",
+ rangePtr->continueOffset, rangePtr->breakOffset);
break;
case CATCH_EXCEPTION_RANGE:
- fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
+ Tcl_AppendPrintfToObj(bufferObj, "catch %d\n",
+ rangePtr->catchOffset);
break;
default:
- panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
- rangePtr->type);
+ Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d",
+ rangePtr->type);
}
}
}
-
+
/*
- * If there were no commands (e.g., an expression or an empty string
- * was compiled), just print all instructions and return.
+ * If there were no commands (e.g., an expression or an empty string was
+ * compiled), just print all instructions and return.
*/
if (numCmds == 0) {
pc = codeStart;
while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
- return;
+ return bufferObj;
}
-
+
/*
- * Print table showing the code offset, source offset, and source
- * length for each command. These are encoded as a sequence of bytes.
+ * Print table showing the code offset, source offset, and source length
+ * for each command. These are encoded as a sequence of bytes.
*/
- fprintf(stdout, " Commands %d:", numCmds);
+ Tcl_AppendPrintfToObj(bufferObj, " 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 int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
@@ -3664,7 +3769,7 @@ TclPrintByteCodeObj(interp, objPtr)
}
codeOffset += delta;
- if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
+ if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
codeLengthNext++;
codeLen = TclGetInt4AtPtr(codeLengthNext);
codeLengthNext += 4;
@@ -3672,8 +3777,8 @@ TclPrintByteCodeObj(interp, objPtr)
codeLen = TclGetInt1AtPtr(codeLengthNext);
codeLengthNext++;
}
-
- if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+
+ if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
@@ -3683,7 +3788,7 @@ TclPrintByteCodeObj(interp, objPtr)
}
srcOffset += delta;
- if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
@@ -3691,29 +3796,29 @@ TclPrintByteCodeObj(interp, objPtr)
srcLen = TclGetInt1AtPtr(srcLengthNext);
srcLengthNext++;
}
-
- fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
+
+ Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d",
((i % 2)? " " : "\n "),
(i+1), codeOffset, (codeOffset + codeLen - 1),
srcOffset, (srcOffset + srcLen - 1));
}
if (numCmds > 0) {
- fprintf(stdout, "\n");
+ Tcl_AppendToObj(bufferObj, "\n", -1);
}
-
+
/*
- * Print each instruction. If the instruction corresponds to the start
- * of a command, print the command's source. Note that we don't need
- * the code length here.
+ * 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 int) (*codeDeltaNext) == (unsigned int) 0xFF) {
+ if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
codeDeltaNext++;
delta = TclGetInt4AtPtr(codeDeltaNext);
codeDeltaNext += 4;
@@ -3723,7 +3828,7 @@ TclPrintByteCodeObj(interp, objPtr)
}
codeOffset += delta;
- if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
+ if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
srcDeltaNext++;
delta = TclGetInt4AtPtr(srcDeltaNext);
srcDeltaNext += 4;
@@ -3733,7 +3838,7 @@ TclPrintByteCodeObj(interp, objPtr)
}
srcOffset += delta;
- if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
+ if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
srcLengthNext++;
srcLen = TclGetInt4AtPtr(srcLengthNext);
srcLengthNext += 4;
@@ -3745,16 +3850,16 @@ TclPrintByteCodeObj(interp, objPtr)
/*
* Print instructions before command i.
*/
-
+
while ((pc-codeStart) < codeOffset) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
- fprintf(stdout, " Command %d: ", (i+1));
- TclPrintSource(stdout, (codePtr->source + srcOffset),
- TclMin(srcLen, 55));
- fprintf(stdout, "\n");
+ Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1);
+ PrintSourceToObj(bufferObj, (codePtr->source + srcOffset),
+ TclMin(srcLen, 55));
+ Tcl_AppendToObj(bufferObj, "\n", -1);
}
if (pc < codeLimit) {
/*
@@ -3762,225 +3867,201 @@ TclPrintByteCodeObj(interp, objPtr)
*/
while (pc < codeLimit) {
- fprintf(stdout, " ");
- pc += TclPrintInstruction(codePtr, pc);
+ Tcl_AppendToObj(bufferObj, " ", -1);
+ pc += FormatInstruction(codePtr, pc, bufferObj);
}
}
+ return bufferObj;
}
-#endif /* TCL_COMPILE_DEBUG */
/*
*----------------------------------------------------------------------
*
- * TclPrintInstruction --
- *
- * This procedure prints ("disassembles") one instruction from a
- * bytecode object to stdout.
- *
- * Results:
- * Returns the length in bytes of the current instruiction.
+ * FormatInstruction --
*
- * Side effects:
- * None.
+ * Appends a representation of a bytecode instruction to a Tcl_Obj.
*
*----------------------------------------------------------------------
*/
-int
-TclPrintInstruction(codePtr, pc)
- ByteCode* codePtr; /* Bytecode containing the instruction. */
- unsigned char *pc; /* Points to first byte of instruction. */
+static int
+FormatInstruction(
+ ByteCode *codePtr, /* Bytecode containing the instruction. */
+ unsigned char *pc, /* Points to first byte of instruction. */
+ Tcl_Obj *bufferObj) /* Object to append instruction info to. */
{
Proc *procPtr = codePtr->procPtr;
unsigned char opCode = *pc;
register InstructionDesc *instDesc = &tclInstructionTable[opCode];
unsigned char *codeStart = codePtr->codeStart;
- unsigned int pcOffset = (pc - codeStart);
- int opnd, i, j;
-
- fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+ unsigned pcOffset = pc - codeStart;
+ int opnd = 0, i, j, numBytes = 1;
+ int localCt = procPtr ? procPtr->numCompiledLocals : 0;
+ CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL;
+ char suffixBuffer[128]; /* Additional info to print after main opcode
+ * and immediates. */
+ char *suffixSrc = NULL;
+ Tcl_Obj *suffixObj = NULL;
+ AuxData *auxPtr = NULL;
+
+ suffixBuffer[0] = '\0';
+ Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name);
for (i = 0; i < instDesc->numOperands; i++) {
switch (instDesc->opTypes[i]) {
case OPERAND_INT1:
- opnd = TclGetInt1AtPtr(pc+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);
+ opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++;
+ if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1
+ || opCode == INST_JUMP_FALSE1) {
+ sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
}
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_INT4:
- opnd = TclGetInt4AtPtr(pc+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);
+ opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
+ if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4
+ || opCode == INST_JUMP_FALSE4) {
+ sprintf(suffixBuffer, "pc %u", pcOffset+opnd);
+ } else if (opCode == INST_START_CMD) {
+ sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd);
}
+ Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd);
break;
case OPERAND_UINT1:
- opnd = TclGetUInt1AtPtr(pc+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);
+ opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++;
+ if (opCode == INST_PUSH1) {
+ suffixObj = codePtr->objArrayPtr[opnd];
}
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
break;
+ case OPERAND_AUX4:
case OPERAND_UINT4:
- opnd = TclGetUInt4AtPtr(pc+1+i);
+ opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4;
if (opCode == INST_PUSH4) {
- fprintf(stdout, "%u # ", opnd);
- TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
- } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
- || (opCode == INST_LOAD_ARRAY4)
- || (opCode == INST_STORE_SCALAR4)
- || (opCode == INST_STORE_ARRAY4))) {
- int localCt = procPtr->numCompiledLocals;
- CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ suffixObj = codePtr->objArrayPtr[opnd];
+ } else if (opCode == INST_START_CMD && opnd != 1) {
+ sprintf(suffixBuffer+strlen(suffixBuffer),
+ ", %u cmds start here", opnd);
+ }
+ Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd);
+ if (instDesc->opTypes[i] == OPERAND_AUX4) {
+ auxPtr = &codePtr->auxDataArrayPtr[opnd];
+ }
+ break;
+ case OPERAND_IDX4:
+ opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4;
+ if (opnd >= -1) {
+ Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd);
+ } else if (opnd == -2) {
+ Tcl_AppendPrintfToObj(bufferObj, "end ");
+ } else {
+ Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd);
+ }
+ break;
+ case OPERAND_LVT1:
+ opnd = TclGetUInt1AtPtr(pc+numBytes);
+ numBytes++;
+ goto printLVTindex;
+ case OPERAND_LVT4:
+ opnd = TclGetUInt4AtPtr(pc+numBytes);
+ numBytes += 4;
+ printLVTindex:
+ if (localPtr != NULL) {
if (opnd >= localCt) {
- panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
- (unsigned int) opnd, localCt);
- return instDesc->numBytes;
+ Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)",
+ (unsigned) opnd, localCt);
}
for (j = 0; j < opnd; j++) {
localPtr = localPtr->nextPtr;
}
if (TclIsVarTemporary(localPtr)) {
- fprintf(stdout, "%u # temp var %u",
- (unsigned int) opnd, (unsigned int) opnd);
+ sprintf(suffixBuffer, "temp var %u", (unsigned) opnd);
} else {
- fprintf(stdout, "%u # var ", (unsigned int) opnd);
- TclPrintSource(stdout, localPtr->name, 40);
+ sprintf(suffixBuffer, "var ");
+ suffixSrc = localPtr->name;
}
- } else {
- fprintf(stdout, "%u ", (unsigned int) opnd);
}
+ Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd);
break;
case OPERAND_NONE:
default:
break;
}
}
- fprintf(stdout, "\n");
- return instDesc->numBytes;
-}
-
-/*
- *----------------------------------------------------------------------
- *
- * TclPrintObject --
- *
- * This procedure prints up to a specified number of characters from
- * the argument Tcl object's string representation to a specified file.
- *
- * Results:
- * None.
- *
- * Side effects:
- * Outputs characters to the specified file.
- *
- *----------------------------------------------------------------------
- */
-
-void
-TclPrintObject(outFile, objPtr, maxChars)
- FILE *outFile; /* The file to print the source to. */
- Tcl_Obj *objPtr; /* Points to the Tcl object whose string
- * representation should be printed. */
- int maxChars; /* Maximum number of chars to print. */
-{
- char *bytes;
- int length;
-
- bytes = Tcl_GetStringFromObj(objPtr, &length);
- TclPrintSource(outFile, bytes, TclMin(length, maxChars));
+ 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;
}
/*
*----------------------------------------------------------------------
*
- * TclPrintSource --
+ * PrintSourceToObj --
*
- * 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.
+ * Appends a quoted representation of a string to a Tcl_Obj.
*
*----------------------------------------------------------------------
*/
-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. */
+static void
+PrintSourceToObj(
+ Tcl_Obj *appendObj, /* The object to print the source to. */
+ const char *stringPtr, /* The string to print. */
+ int maxChars) /* Maximum number of chars to print. */
{
- register CONST char *p;
+ register const char *p;
register int i = 0;
- if (string == NULL) {
- fprintf(outFile, "\"\"");
+ if (stringPtr == NULL) {
+ Tcl_AppendToObj(appendObj, "\"\"", -1);
return;
}
- fprintf(outFile, "\"");
- p = string;
+ Tcl_AppendToObj(appendObj, "\"", -1);
+ p = stringPtr;
for (; (*p != '\0') && (i < maxChars); p++, i++) {
switch (*p) {
- case '"':
- fprintf(outFile, "\\\"");
- continue;
- case '\f':
- fprintf(outFile, "\\f");
- continue;
- case '\n':
- fprintf(outFile, "\\n");
- continue;
- case '\r':
- fprintf(outFile, "\\r");
- continue;
- case '\t':
- fprintf(outFile, "\\t");
- continue;
- case '\v':
- fprintf(outFile, "\\v");
- continue;
- default:
- fprintf(outFile, "%c", *p);
- continue;
+ case '"':
+ 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;
}
}
- fprintf(outFile, "\"");
+ Tcl_AppendToObj(appendObj, "\"", -1);
}
#ifdef TCL_COMPILE_STATS
@@ -3998,41 +4079,42 @@ TclPrintSource(outFile, string, maxChars)
*
* Side effects:
* Accumulates aggregate code-related statistics in the interpreter's
- * ByteCodeStats structure. Records statistics specific to a ByteCode
- * in its ByteCode structure.
+ * ByteCodeStats structure. Records statistics specific to a ByteCode in
+ * its ByteCode structure.
*
*----------------------------------------------------------------------
*/
void
-RecordByteCodeStats(codePtr)
- ByteCode *codePtr; /* Points to ByteCode structure with info
+RecordByteCodeStats(
+ ByteCode *codePtr) /* Points to ByteCode structure with info
* to add to accumulated statistics. */
{
Interp *iPtr = (Interp *) *codePtr->interpHandle;
- register ByteCodeStats *statsPtr = &(iPtr->stats);
+ register ByteCodeStats *statsPtr;
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 */
@@ -4044,4 +4126,3 @@ RecordByteCodeStats(codePtr)
* fill-column: 78
* End:
*/
-