aboutsummaryrefslogtreecommitdiffstats
path: root/contrib/tcl/generic/tclCompile.c
diff options
context:
space:
mode:
authorPoul-Henning Kamp <phk@FreeBSD.org>1997-07-25 19:27:55 +0000
committerPoul-Henning Kamp <phk@FreeBSD.org>1997-07-25 19:27:55 +0000
commit3d33409926539d866dcea9fc5cb14113b312adf0 (patch)
treed2f88b3e9ffa79ffb2cc1a0699dd3ee96c47c3e5 /contrib/tcl/generic/tclCompile.c
parent8569730d6bc2e4cb5e784997313325b13518e066 (diff)
downloadsrc-3d33409926539d866dcea9fc5cb14113b312adf0.tar.gz
src-3d33409926539d866dcea9fc5cb14113b312adf0.zip
Import TCL release 8.0 beta 2.
Notes
Notes: svn path=/vendor/tcl/dist/; revision=27676
Diffstat (limited to 'contrib/tcl/generic/tclCompile.c')
-rw-r--r--contrib/tcl/generic/tclCompile.c7464
1 files changed, 7464 insertions, 0 deletions
diff --git a/contrib/tcl/generic/tclCompile.c b/contrib/tcl/generic/tclCompile.c
new file mode 100644
index 000000000000..e8aa99cc747a
--- /dev/null
+++ b/contrib/tcl/generic/tclCompile.c
@@ -0,0 +1,7464 @@
+/*
+ * tclCompile.c --
+ *
+ * This file contains procedures that compile Tcl commands or parts
+ * of commands (like quoted strings or nested sub-commands) into a
+ * sequence of instructions ("bytecodes").
+ *
+ * Copyright (c) 1996-1997 Sun Microsystems, Inc.
+ *
+ * See the file "license.terms" for information on usage and redistribution
+ * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
+ *
+ * SCCS: @(#) tclCompile.c 1.61 97/06/23 18:43:46
+ */
+
+#include "tclInt.h"
+#include "tclCompile.h"
+
+/*
+ * Variable that controls whether compilation tracing is enabled and, if so,
+ * what level of tracing is desired:
+ * 0: no compilation tracing
+ * 1: summarize compilation of top level cmds and proc bodies
+ * 2: display all instructions of each ByteCode compiled
+ * This variable is linked to the Tcl variable "tcl_traceCompile".
+ */
+
+int tclTraceCompile = 0;
+static int traceInitialized = 0;
+
+/*
+ * Count of the number of compilations.
+ */
+
+#ifdef TCL_COMPILE_STATS
+long tclNumCompilations = 0;
+#endif /* TCL_COMPILE_STATS */
+
+/*
+ * A table describing the Tcl bytecode instructions. The entries in this
+ * table must correspond to the list of instructions in tclInt.h. The names
+ * "op1" and "op4" refer to an instruction's one or four byte first operand.
+ * Similarly, "stktop" and "stknext" refer to the topmost and next to
+ * topmost stack elements.
+ *
+ * Note that the load, store, and incr instructions do not distinguish local
+ * from global variables; the bytecode interpreter at runtime uses the
+ * existence of a procedure call frame to distinguish these.
+ */
+
+InstructionDesc instructionTable[] = {
+ /* Name Bytes #Opnds Operand types Stack top, next */
+ {"done", 1, 0, {OPERAND_NONE}},
+ /* Finish ByteCode execution and return stktop (top stack item) */
+ {"push1", 2, 1, {OPERAND_UINT1}},
+ /* Push object at ByteCode objArray[op1] */
+ {"push4", 5, 1, {OPERAND_UINT4}},
+ /* Push object at ByteCode objArray[op4] */
+ {"pop", 1, 0, {OPERAND_NONE}},
+ /* Pop the topmost stack object */
+ {"dup", 1, 0, {OPERAND_NONE}},
+ /* Duplicate the topmost stack object and push the result */
+ {"concat1", 2, 1, {OPERAND_UINT1}},
+ /* Concatenate the top op1 items and push result */
+ {"invokeStk1", 2, 1, {OPERAND_UINT1}},
+ /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
+ {"invokeStk4", 5, 1, {OPERAND_UINT4}},
+ /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
+ {"evalStk", 1, 0, {OPERAND_NONE}},
+ /* Evaluate command in stktop using Tcl_EvalObj. */
+ {"exprStk", 1, 0, {OPERAND_NONE}},
+ /* Execute expression in stktop using Tcl_ExprStringObj. */
+
+ {"loadScalar1", 2, 1, {OPERAND_UINT1}},
+ /* Load scalar variable at index op1 <= 255 in call frame */
+ {"loadScalar4", 5, 1, {OPERAND_UINT4}},
+ /* Load scalar variable at index op1 >= 256 in call frame */
+ {"loadScalarStk", 1, 0, {OPERAND_NONE}},
+ /* Load scalar variable; scalar's name is stktop */
+ {"loadArray1", 2, 1, {OPERAND_UINT1}},
+ /* Load array element; array at slot op1<=255, element is stktop */
+ {"loadArray4", 5, 1, {OPERAND_UINT4}},
+ /* Load array element; array at slot op1 > 255, element is stktop */
+ {"loadArrayStk", 1, 0, {OPERAND_NONE}},
+ /* Load array element; element is stktop, array name is stknext */
+ {"loadStk", 1, 0, {OPERAND_NONE}},
+ /* Load general variable; unparsed variable name is stktop */
+ {"storeScalar1", 2, 1, {OPERAND_UINT1}},
+ /* Store scalar variable at op1<=255 in frame; value is stktop */
+ {"storeScalar4", 5, 1, {OPERAND_UINT4}},
+ /* Store scalar variable at op1 > 255 in frame; value is stktop */
+ {"storeScalarStk", 1, 0, {OPERAND_NONE}},
+ /* Store scalar; value is stktop, scalar name is stknext */
+ {"storeArray1", 2, 1, {OPERAND_UINT1}},
+ /* Store array element; array at op1<=255, value is top then elem */
+ {"storeArray4", 5, 1, {OPERAND_UINT4}},
+ /* Store array element; array at op1>=256, value is top then elem */
+ {"storeArrayStk", 1, 0, {OPERAND_NONE}},
+ /* Store array element; value is stktop, then elem, array names */
+ {"storeStk", 1, 0, {OPERAND_NONE}},
+ /* Store general variable; value is stktop, then unparsed name */
+
+ {"incrScalar1", 2, 1, {OPERAND_UINT1}},
+ /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
+ {"incrScalarStk", 1, 0, {OPERAND_NONE}},
+ /* Incr scalar; incr amount is stktop, scalar's name is stknext */
+ {"incrArray1", 2, 1, {OPERAND_UINT1}},
+ /* Incr array elem; arr at slot op1<=255, amount is top then elem */
+ {"incrArrayStk", 1, 0, {OPERAND_NONE}},
+ /* Incr array element; amount is top then elem then array names */
+ {"incrStk", 1, 0, {OPERAND_NONE}},
+ /* Incr general variable; amount is stktop then unparsed var name */
+ {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
+ /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
+ {"incrScalarStkImm", 2, 1, {OPERAND_INT1}},
+ /* Incr scalar; scalar name is stktop; incr amount is op1 */
+ {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
+ /* Incr array elem; array at slot op1 <= 255, elem is stktop,
+ * amount is 2nd operand byte */
+ {"incrArrayStkImm", 2, 1, {OPERAND_INT1}},
+ /* Incr array element; elem is top then array name, amount is op1 */
+ {"incrStkImm", 2, 1, {OPERAND_INT1}},
+ /* Incr general variable; unparsed name is top, amount is op1 */
+
+ {"jump1", 2, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) */
+ {"jump4", 5, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) */
+ {"jumpTrue1", 2, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) if stktop expr object is true */
+ {"jumpTrue4", 5, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) if stktop expr object is true */
+ {"jumpFalse1", 2, 1, {OPERAND_INT1}},
+ /* Jump relative to (pc + op1) if stktop expr object is false */
+ {"jumpFalse4", 5, 1, {OPERAND_INT4}},
+ /* Jump relative to (pc + op4) if stktop expr object is false */
+
+ {"lor", 1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"land", 1, 0, {OPERAND_NONE}},
+ /* Logical and: push (stknext && stktop) */
+ {"bitor", 1, 0, {OPERAND_NONE}},
+ /* Bitwise or: push (stknext | stktop) */
+ {"bitxor", 1, 0, {OPERAND_NONE}},
+ /* Bitwise xor push (stknext ^ stktop) */
+ {"bitand", 1, 0, {OPERAND_NONE}},
+ /* Bitwise and: push (stknext & stktop) */
+ {"eq", 1, 0, {OPERAND_NONE}},
+ /* Equal: push (stknext == stktop) */
+ {"neq", 1, 0, {OPERAND_NONE}},
+ /* Not equal: push (stknext != stktop) */
+ {"lt", 1, 0, {OPERAND_NONE}},
+ /* Less: push (stknext < stktop) */
+ {"gt", 1, 0, {OPERAND_NONE}},
+ /* Greater: push (stknext || stktop) */
+ {"le", 1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"ge", 1, 0, {OPERAND_NONE}},
+ /* Logical or: push (stknext || stktop) */
+ {"lshift", 1, 0, {OPERAND_NONE}},
+ /* Left shift: push (stknext << stktop) */
+ {"rshift", 1, 0, {OPERAND_NONE}},
+ /* Right shift: push (stknext >> stktop) */
+ {"add", 1, 0, {OPERAND_NONE}},
+ /* Add: push (stknext + stktop) */
+ {"sub", 1, 0, {OPERAND_NONE}},
+ /* Sub: push (stkext - stktop) */
+ {"mult", 1, 0, {OPERAND_NONE}},
+ /* Multiply: push (stknext * stktop) */
+ {"div", 1, 0, {OPERAND_NONE}},
+ /* Divide: push (stknext / stktop) */
+ {"mod", 1, 0, {OPERAND_NONE}},
+ /* Mod: push (stknext % stktop) */
+ {"uplus", 1, 0, {OPERAND_NONE}},
+ /* Unary plus: push +stktop */
+ {"uminus", 1, 0, {OPERAND_NONE}},
+ /* Unary minus: push -stktop */
+ {"bitnot", 1, 0, {OPERAND_NONE}},
+ /* Bitwise not: push ~stktop */
+ {"not", 1, 0, {OPERAND_NONE}},
+ /* Logical not: push !stktop */
+ {"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}},
+ /* Call builtin math function with index op1; any args are on stk */
+ {"callFunc1", 2, 1, {OPERAND_UINT1}},
+ /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
+ {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}},
+ /* Try converting stktop to first int then double if possible. */
+
+ {"break", 1, 0, {OPERAND_NONE}},
+ /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
+ {"continue", 1, 0, {OPERAND_NONE}},
+ /* Skip to next iteration of closest enclosing loop; if none,
+ * return TCL_CONTINUE code. */
+
+ {"foreach_start4", 5, 1, {OPERAND_UINT4}},
+ /* Initialize execution of a foreach loop. Operand is aux data index
+ * of the ForeachInfo structure for the foreach command. */
+ {"foreach_step4", 5, 1, {OPERAND_UINT4}},
+ /* "Step" or begin next iteration of foreach loop. Push 0 if to
+ * terminate loop, else push 1. */
+
+ {"beginCatch4", 5, 1, {OPERAND_UINT4}},
+ /* Record start of catch with the operand's exception range index.
+ * Push the current stack depth onto a special catch stack. */
+ {"endCatch", 1, 0, {OPERAND_NONE}},
+ /* End of last catch. Pop the bytecode interpreter's catch stack. */
+ {"pushResult", 1, 0, {OPERAND_NONE}},
+ /* Push the interpreter's object result onto the stack. */
+ {"pushReturnCode", 1, 0, {OPERAND_NONE}},
+ /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
+ * a new object onto the stack. */
+ {0}
+};
+
+/*
+ * The following table assigns a type to each character. Only types
+ * meaningful to Tcl parsing are represented here. The table is
+ * designed to be referenced with either signed or unsigned characters,
+ * so it has 384 entries. The first 128 entries correspond to negative
+ * character values, the next 256 correspond to positive character
+ * values. The last 128 entries are identical to the first 128. The
+ * table is always indexed with a 128-byte offset (the 128th entry
+ * corresponds to a 0 character value).
+ */
+
+unsigned char tclTypeTable[] = {
+ /*
+ * Negative character values, from -128 to -1:
+ */
+
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+
+ /*
+ * Positive character values, from 0-127:
+ */
+
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE,
+ TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL,
+ TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET,
+ TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE,
+ TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL,
+
+ /*
+ * Large unsigned character values, from 128-255:
+ */
+
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+ TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
+};
+
+/*
+ * Prototypes for procedures defined later in this file:
+ */
+
+static void AdvanceToNextWord _ANSI_ARGS_((char *string,
+ CompileEnv *envPtr));
+static int CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *lastChar, int flags,
+ ArgInfo *argInfoPtr));
+static int CompileBraces _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *lastChar, int flags,
+ CompileEnv *envPtr));
+static int CompileCmdWordInline _ANSI_ARGS_((
+ Tcl_Interp *interp, char *string,
+ char *lastChar, int flags, CompileEnv *envPtr));
+static int CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *lastChar, int flags,
+ CompileEnv *envPtr));
+static int CompileMultipartWord _ANSI_ARGS_((
+ Tcl_Interp *interp, char *string,
+ char *lastChar, int flags, CompileEnv *envPtr));
+static int CompileWord _ANSI_ARGS_((Tcl_Interp *interp,
+ char *string, char *lastChar, int flags,
+ CompileEnv *envPtr));
+static int CreateExceptionRange _ANSI_ARGS_((
+ ExceptionRangeType type, CompileEnv *envPtr));
+static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
+ Tcl_Obj *copyPtr));
+static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
+static void EnterCmdExtentData _ANSI_ARGS_((
+ CompileEnv *envPtr, int cmdNumber,
+ int numSrcChars, int numCodeBytes));
+static void EnterCmdStartData _ANSI_ARGS_((
+ CompileEnv *envPtr, int cmdNumber,
+ int srcOffset, int codeOffset));
+static void ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr));
+static void FreeForeachInfo _ANSI_ARGS_((
+ ClientData clientData));
+static void FreeByteCodeInternalRep _ANSI_ARGS_((
+ Tcl_Obj *objPtr));
+static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
+static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
+static int LookupCompiledLocal _ANSI_ARGS_((
+ char *name, int nameChars, int createIfNew,
+ int flagsIfCreated, Proc *procPtr));
+static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
+ Tcl_Obj *objPtr));
+static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr));
+
+/*
+ * The structure below defines the bytecode Tcl object type by
+ * means of procedures that can be invoked by generic object code.
+ */
+
+Tcl_ObjType tclByteCodeType = {
+ "bytecode", /* name */
+ FreeByteCodeInternalRep, /* freeIntRepProc */
+ DupByteCodeInternalRep, /* dupIntRepProc */
+ UpdateStringOfByteCode, /* updateStringProc */
+ SetByteCodeFromAny /* setFromAnyProc */
+};
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintByteCodeObj --
+ *
+ * This procedure prints ("disassembles") the instructions of a
+ * bytecode object to stdout.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintByteCodeObj(interp, objPtr)
+ Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
+ Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
+{
+ ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
+ Proc *procPtr;
+ CmdLocation *mapPtr;
+ ExceptionRange *excRangeArrayPtr;
+ unsigned char *codeStart, *codeLimit, *pc, *start;
+ int numCmds, numRanges, cmd, maxChars, i;
+ char *source;
+
+ if (codePtr->refCount <= 0) {
+ return; /* already freed */
+ }
+
+ codeStart = codePtr->codeStart;
+ codeLimit = (codeStart + codePtr->numCodeBytes);
+ source = codePtr->source;
+ procPtr = codePtr->procPtr;
+ numCmds = codePtr->numCommands;
+ numRanges = codePtr->numExcRanges;
+ mapPtr = codePtr->cmdMapPtr;
+ excRangeArrayPtr = codePtr->excRangeArrayPtr;
+
+ fprintf(stdout, "\nByteCode 0x%x, ref ct %u, epoch %u, interp 0x%x, interp epoch %u\n",
+ (unsigned int) codePtr, codePtr->refCount,
+ codePtr->compileEpoch, (unsigned int) codePtr->iPtr,
+ codePtr->iPtr->compileEpoch);
+ if (procPtr != NULL) {
+ int numCompiledLocals = procPtr->numCompiledLocals;
+ fprintf(stdout,
+ " Proc 0x%x, ref ct=%d, %d args, %d compiled locals\n",
+ (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
+ numCompiledLocals);
+ if (numCompiledLocals > 0) {
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ for (i = 0; i < numCompiledLocals; i++) {
+ fprintf(stdout, " %d: frame index=%d, flags=0x%x%s%s",
+ i, localPtr->frameIndex, localPtr->flags,
+ (localPtr->isArg? ", arg" : ""),
+ (localPtr->isTemp? ", temp" : ""));
+ if (localPtr->isTemp) {
+ fprintf(stdout, "\n");
+ } else {
+ fprintf(stdout, ", name=\"%s\"\n", localPtr->name);
+ }
+ localPtr = localPtr->nextPtr;
+ }
+ }
+ }
+ fprintf(stdout, " Source: ");
+ TclPrintSource(stdout, source, TclMin(codePtr->numSrcChars, 70));
+ fprintf(stdout, "\n Chars=%d, bytes=%u, objs=%u, stk depth=%u, exc depth=%d, aux items=%d\n",
+ codePtr->numSrcChars, codePtr->numCodeBytes,
+ codePtr->numObjects, codePtr->maxStackDepth,
+ codePtr->maxExcRangeDepth, codePtr->numAuxDataItems);
+
+ /*
+ * If there were no commands (e.g., an expression or an empty string
+ * was compiled), just print all instructions.
+ */
+
+ if (numCmds == 0) {
+ start = codeStart;
+ pc = start;
+ while (pc < codeLimit) {
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+ return;
+ }
+
+ /*
+ * Print table giving the source and object locations for each command.
+ */
+
+ fprintf(stdout, " Commands=%d\n", numCmds);
+ for (i = 0; i < numCmds; i++) {
+ fprintf(stdout, " %d: source=%d-%d, code=%d-%d\n",
+ (i+1), mapPtr[i].srcOffset,
+ (mapPtr[i].srcOffset + mapPtr[i].numSrcChars - 1),
+ mapPtr[i].codeOffset,
+ (mapPtr[i].codeOffset + mapPtr[i].numCodeBytes - 1));
+ }
+
+ /*
+ * Print the ExceptionRange array.
+ */
+
+ fprintf(stdout, " Exception ranges=%d\n", numRanges);
+ for (i = 0; i < numRanges; i++) {
+ ExceptionRange *rangePtr = &(excRangeArrayPtr[i]);
+ fprintf(stdout, " %d: level=%d, type=%s, pc range=%d-%d, ",
+ i, rangePtr->nestingLevel,
+ ((rangePtr->type == LOOP_EXCEPTION_RANGE)? "loop" : "catch"),
+ rangePtr->codeOffset,
+ (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
+ switch (rangePtr->type) {
+ case LOOP_EXCEPTION_RANGE:
+ fprintf(stdout, "continue=%d, break=%d\n",
+ rangePtr->continueOffset, rangePtr->breakOffset);
+ break;
+ case CATCH_EXCEPTION_RANGE:
+ fprintf(stdout, "catch=%d\n", rangePtr->catchOffset);
+ break;
+ default:
+ fprintf(stdout, "unrecognized ExceptionRange type %d\n",
+ rangePtr->type);
+ }
+ }
+
+ /*
+ * Print each instruction. If the instruction corresponds to the start
+ * of a command, print the command's source.
+ */
+
+ start = codeStart;
+ cmd = 0;
+ pc = start;
+ while (pc < codeLimit) {
+ int pcOffset = (pc - start);
+ while ((cmd < numCmds) && (pcOffset >= mapPtr[cmd].codeOffset)) {
+ /*
+ * The start of the command with index cmd.
+ */
+
+ maxChars = TclMin(mapPtr[cmd].numSrcChars, 70);
+ fprintf(stdout, " Command %d: ", (cmd+1));
+ TclPrintSource(stdout, (source + mapPtr[cmd].srcOffset),
+ maxChars);
+ fprintf(stdout, "\n");
+ cmd++;
+ }
+ fprintf(stdout, " ");
+ pc += TclPrintInstruction(codePtr, pc);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintInstruction --
+ *
+ * This procedure prints ("disassembles") one instruction from a
+ * bytecode object to stdout.
+ *
+ * Results:
+ * Returns the length in bytes of the current instruiction.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclPrintInstruction(codePtr, pc)
+ ByteCode* codePtr; /* Bytecode containing the instruction. */
+ unsigned char *pc; /* Points to first byte of instruction. */
+{
+ Proc *procPtr = codePtr->procPtr;
+ unsigned char opCode = *pc;
+ register InstructionDesc *instDesc = &instructionTable[opCode];
+ unsigned char *codeStart = codePtr->codeStart;
+ unsigned int pcOffset = (pc - codeStart);
+ int opnd, elemLen, i, j;
+ Tcl_Obj *elemPtr;
+ char *string;
+
+ fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
+ for (i = 0; i < instDesc->numOperands; i++) {
+ switch (instDesc->opTypes[i]) {
+ case OPERAND_INT1:
+ opnd = TclGetInt1AtPc(pc+1+i);
+ if ((i == 0) && ((opCode == INST_JUMP1)
+ || (opCode == INST_JUMP_TRUE1)
+ || (opCode == INST_JUMP_FALSE1))) {
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ } else {
+ fprintf(stdout, "%d", opnd);
+ }
+ break;
+ case OPERAND_INT4:
+ opnd = TclGetInt4AtPc(pc+1+i);
+ if ((i == 0) && ((opCode == INST_JUMP4)
+ || (opCode == INST_JUMP_TRUE4)
+ || (opCode == INST_JUMP_FALSE4))) {
+ fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
+ } else {
+ fprintf(stdout, "%d", opnd);
+ }
+ break;
+ case OPERAND_UINT1:
+ opnd = TclGetUInt1AtPc(pc+1+i);
+ if ((i == 0) && (opCode == INST_PUSH1)) {
+ elemPtr = codePtr->objArrayPtr[opnd];
+ string = Tcl_GetStringFromObj(elemPtr, &elemLen);
+ fprintf(stdout, "%u # ", (unsigned int) opnd);
+ TclPrintSource(stdout, string, TclMin(elemLen, 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 (localPtr->isTemp) {
+ fprintf(stdout, "%u # temp var %u",
+ (unsigned int) opnd, (unsigned int) opnd);
+ } else {
+ fprintf(stdout, "%u # var ", (unsigned int) opnd);
+ TclPrintSource(stdout, localPtr->name, 40);
+ }
+ } else {
+ fprintf(stdout, "%u ", (unsigned int) opnd);
+ }
+ break;
+ case OPERAND_UINT4:
+ opnd = TclGetUInt4AtPc(pc+1+i);
+ if (opCode == INST_PUSH4) {
+ elemPtr = codePtr->objArrayPtr[opnd];
+ string = Tcl_GetStringFromObj(elemPtr, &elemLen);
+ fprintf(stdout, "%u # ", opnd);
+ TclPrintSource(stdout, string, TclMin(elemLen, 40));
+ } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
+ || (opCode == INST_LOAD_ARRAY4)
+ || (opCode == INST_STORE_SCALAR4)
+ || (opCode == INST_STORE_ARRAY4))) {
+ int localCt = procPtr->numCompiledLocals;
+ CompiledLocal *localPtr = procPtr->firstLocalPtr;
+ if (opnd >= localCt) {
+ panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
+ (unsigned int) opnd, localCt);
+ return instDesc->numBytes;
+ }
+ for (j = 0; j < opnd; j++) {
+ localPtr = localPtr->nextPtr;
+ }
+ if (localPtr->isTemp) {
+ fprintf(stdout, "%u # temp var %u",
+ (unsigned int) opnd, (unsigned int) opnd);
+ } else {
+ fprintf(stdout, "%u # var ", (unsigned int) opnd);
+ TclPrintSource(stdout, localPtr->name, 40);
+ }
+ } else {
+ fprintf(stdout, "%u ", (unsigned int) opnd);
+ }
+ break;
+ case OPERAND_NONE:
+ default:
+ break;
+ }
+ }
+ fprintf(stdout, "\n");
+ return instDesc->numBytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclPrintSource --
+ *
+ * This procedure prints up to a specified number of characters from
+ * the argument string to a specified file. It tries to produce legible
+ * output by adding backslashes as necessary.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Outputs characters to the specified file.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclPrintSource(outFile, string, maxChars)
+ FILE *outFile; /* The file to print the source to. */
+ char *string; /* The string to print. */
+ int maxChars; /* Maximum number of chars to print. */
+{
+ register char *p;
+ register int i = 0;
+
+ if (string == NULL) {
+ fprintf(outFile, "\"\"");
+ return;
+ }
+
+ fprintf(outFile, "\"");
+ p = string;
+ for (; (*p != '\0') && (i < maxChars); p++, i++) {
+ switch (*p) {
+ case '"':
+ fprintf(outFile, "\\\"");
+ continue;
+ case '\f':
+ fprintf(outFile, "\\f");
+ continue;
+ case '\n':
+ fprintf(outFile, "\\n");
+ continue;
+ case '\r':
+ fprintf(outFile, "\\r");
+ continue;
+ case '\t':
+ fprintf(outFile, "\\t");
+ continue;
+ case '\v':
+ fprintf(outFile, "\\v");
+ continue;
+ default:
+ fprintf(outFile, "%c", *p);
+ continue;
+ }
+ }
+ fprintf(outFile, "\"");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeByteCodeInternalRep --
+ *
+ * Part of the bytecode Tcl object type implementation. Frees the
+ * storage associated with a bytecode object's internal representation
+ * unless its code is actively being executed.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The bytecode object's internal rep is marked invalid and its
+ * code gets freed unless the code is actively being executed.
+ * In that case the cleanup is delayed until the last execution
+ * of the code completes.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeByteCodeInternalRep(objPtr)
+ register Tcl_Obj *objPtr; /* Object whose internal rep to free. */
+{
+ register ByteCode *codePtr =
+ (ByteCode *) objPtr->internalRep.otherValuePtr;
+
+ codePtr->refCount--;
+ if (codePtr->refCount <= 0) {
+ TclCleanupByteCode(codePtr);
+ }
+ objPtr->typePtr = NULL;
+ objPtr->internalRep.otherValuePtr = NULL;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CleanupByteCode --
+ *
+ * This procedure does all the real work of freeing up a bytecode
+ * object's ByteCode structure. It's called only when the structure's
+ * reference count becomes zero.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Frees objPtr's bytecode internal representation and sets
+ * its type and objPtr->internalRep.otherValuePtr NULL. Also
+ * decrements the ref counts on each object in its object array,
+ * and frees its auxiliary data items.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclCleanupByteCode(codePtr)
+ ByteCode *codePtr; /* ByteCode to free. */
+{
+ Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
+ int numObjects = codePtr->numObjects;
+ int numAuxDataItems = codePtr->numAuxDataItems;
+ register AuxData *auxDataPtr;
+ register Tcl_Obj *elemPtr;
+ register int i;
+
+ /*
+ * 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 on the objects in its
+ * object array, 2) call the free procs for the auxiliary data items,
+ * and 3) free the ByteCode structure's heap object.
+ */
+
+ for (i = 0; i < numObjects; i++) {
+ elemPtr = objArrayPtr[i];
+ TclDecrRefCount(elemPtr);
+ }
+
+ auxDataPtr = codePtr->auxDataArrayPtr;
+ for (i = 0; i < numAuxDataItems; i++) {
+ if (auxDataPtr->freeProc != NULL) {
+ auxDataPtr->freeProc(auxDataPtr->clientData);
+ }
+ auxDataPtr++;
+ }
+
+ ckfree((char *) codePtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupByteCodeInternalRep --
+ *
+ * Part of the bytecode Tcl object type implementation. Initializes the
+ * internal representation of a bytecode Tcl_Obj to a copy of the
+ * internal representation of an existing bytecode object.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * "copyPtr"s internal rep is set to the bytecode sequence
+ * corresponding to "srcPtr"s internal rep. Ref counts for objects
+ * in the existing bytecode object's object array are incremented
+ * the bytecode copy now also refers to them.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+DupByteCodeInternalRep(srcPtr, copyPtr)
+ Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
+ Tcl_Obj *copyPtr; /* Object with internal rep to set. */
+{
+ ByteCode *codePtr = (ByteCode *) srcPtr->internalRep.otherValuePtr;
+ register ByteCode *dupPtr;
+ int codeBytes = codePtr->numCodeBytes;
+ int numObjects = codePtr->numObjects;
+ int numAuxDataItems = codePtr->numAuxDataItems;
+ register AuxData *srcAuxDataPtr, *dupAuxDataPtr;
+ size_t objArrayBytes, rangeArrayBytes, cmdLocBytes, auxDataBytes;
+ register size_t size;
+ register char *p;
+ int i;
+
+ /*
+ * Allocate a single heap object to hold the copied ByteCode structure
+ * and its code, object, command location, and auxiliary data arrays.
+ */
+
+ objArrayBytes = numObjects * sizeof(Tcl_Obj *);
+ rangeArrayBytes = (codePtr->numExcRanges * sizeof(ExceptionRange));
+ cmdLocBytes = codePtr->numCommands * sizeof(CmdLocation);
+ auxDataBytes = numAuxDataItems * sizeof(AuxData);
+
+ size = TCL_ALIGN(sizeof(ByteCode));
+ size += TCL_ALIGN(codeBytes);
+ size += TCL_ALIGN(objArrayBytes);
+ size += TCL_ALIGN(rangeArrayBytes);
+ size += TCL_ALIGN(cmdLocBytes);
+ size += TCL_ALIGN(auxDataBytes);
+
+ p = (char *) ckalloc(size);
+ dupPtr = (ByteCode *) p;
+ memcpy((VOID *) dupPtr, (VOID *) codePtr, size);
+
+ p += TCL_ALIGN(sizeof(ByteCode));
+ dupPtr->codeStart = (unsigned char *) p;
+
+ p += TCL_ALIGN(codeBytes);
+ dupPtr->objArrayPtr = (Tcl_Obj **) p;
+
+ p += TCL_ALIGN(objArrayBytes);
+ dupPtr->excRangeArrayPtr = (ExceptionRange *) p;
+
+ p += TCL_ALIGN(rangeArrayBytes);
+ dupPtr->cmdMapPtr = (CmdLocation *) p;
+
+ p += TCL_ALIGN(cmdLocBytes);
+ dupPtr->auxDataArrayPtr = (AuxData *) p;
+
+ /*
+ * Increment the ref counts for objects in the object array since we are
+ * creating new references for them in the copied object array.
+ */
+
+ for (i = 0; i < numObjects; i++) {
+ Tcl_IncrRefCount(dupPtr->objArrayPtr[i]);
+ }
+
+ /*
+ * Duplicate any auxiliary data items.
+ */
+
+ srcAuxDataPtr = codePtr->auxDataArrayPtr;
+ dupAuxDataPtr = dupPtr->auxDataArrayPtr;
+ for (i = 0; i < numAuxDataItems; i++) {
+ if (srcAuxDataPtr->dupProc != NULL) {
+ dupAuxDataPtr->clientData =
+ srcAuxDataPtr->dupProc(srcAuxDataPtr->clientData);
+ } else {
+ dupAuxDataPtr->clientData = srcAuxDataPtr->clientData;
+ }
+ srcAuxDataPtr++;
+ dupAuxDataPtr++;
+ }
+
+ copyPtr->internalRep.otherValuePtr = (VOID *) dupPtr;
+ copyPtr->typePtr = &tclByteCodeType;
+}
+
+/*
+ *-----------------------------------------------------------------------
+ *
+ * SetByteCodeFromAny --
+ *
+ * Part of the bytecode Tcl object type implementation. Attempts to
+ * generate an byte code internal form for the Tcl object "objPtr" by
+ * compiling its string representation.
+ *
+ * Results:
+ * The return value is a standard Tcl object result. If an error occurs
+ * during compilation, an error message is left in the interpreter's
+ * result unless "interp" is NULL.
+ *
+ * Side effects:
+ * Frees the old internal representation. If no error occurs, then the
+ * compiled code is stored as "objPtr"s bytecode representation.
+ * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
+ * used to trace compilations.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+SetByteCodeFromAny(interp, objPtr)
+ Tcl_Interp *interp; /* The interpreter for which the code is
+ * compiled. */
+ Tcl_Obj *objPtr; /* The object to convert. */
+{
+ Interp *iPtr = (Interp *) interp;
+ char *string;
+ CompileEnv compEnv; /* Compilation environment structure
+ * allocated in frame. */
+ AuxData *auxDataPtr;
+ register int i;
+ int length, result;
+
+ 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;
+ }
+
+#ifdef TCL_COMPILE_STATS
+ tclNumCompilations++;
+#endif /* TCL_COMPILE_STATS */
+
+ string = Tcl_GetStringFromObj(objPtr, &length);
+ TclInitCompileEnv(interp, &compEnv, string);
+ result = TclCompileString(interp, string, string+length,
+ iPtr->evalFlags, &compEnv);
+ if (result == TCL_OK) {
+ /*
+ * Add a "done" instruction at the end of the instruction sequence.
+ */
+
+ TclEmitOpcode(INST_DONE, &compEnv);
+
+ /*
+ * Convert the object to a ByteCode object.
+ */
+
+ TclInitByteCodeObj(objPtr, &compEnv);
+ } else {
+ /*
+ * Compilation errors. Decrement the ref counts on any objects in
+ * the object array and free any aux data items prior to freeing
+ * the compilation environment.
+ */
+
+ for (i = 0; i < compEnv.objArrayNext; i++) {
+ Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
+ Tcl_DecrRefCount(elemPtr);
+ }
+
+ auxDataPtr = compEnv.auxDataArrayPtr;
+ for (i = 0; i < compEnv.auxDataArrayNext; i++) {
+ if (auxDataPtr->freeProc != NULL) {
+ auxDataPtr->freeProc(auxDataPtr->clientData);
+ }
+ auxDataPtr++;
+ }
+ }
+ TclFreeCompileEnv(&compEnv);
+
+ if (result == TCL_OK) {
+ if (tclTraceCompile == 2) {
+ TclPrintByteCodeObj(interp, objPtr);
+ }
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * UpdateStringOfByteCode --
+ *
+ * Part of the bytecode Tcl object type implementation. Called to
+ * update the string representation for a byte code object.
+ * Note: This procedure does not free an existing old string rep
+ * so storage will be lost if this has not already been done.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Generates a panic.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+UpdateStringOfByteCode(objPtr)
+ register Tcl_Obj *objPtr; /* ByteCode object with string rep that
+ * needs updating. */
+{
+ /*
+ * This procedure is never invoked since the internal representation of
+ * a bytecode object is never modified.
+ */
+
+ panic("UpdateStringOfByteCode should never be called.");
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitCompileEnv --
+ *
+ * Initializes a CompileEnv compilation environment structure for the
+ * compilation of a string in an interpreter.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The CompileEnv structure is initialized.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitCompileEnv(interp, envPtr, string)
+ 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. */
+{
+ Interp *iPtr = (Interp *) interp;
+
+ envPtr->iPtr = iPtr;
+ envPtr->source = string;
+ envPtr->procPtr = iPtr->compiledProcPtr;
+ envPtr->numCommands = 0;
+ envPtr->excRangeDepth = 0;
+ envPtr->maxExcRangeDepth = 0;
+ envPtr->maxStackDepth = 0;
+ Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS);
+ envPtr->pushSimpleWords = 1;
+ envPtr->wordIsSimple = 0;
+ envPtr->numSimpleWordChars = 0;
+ envPtr->exprIsJustVarRef = 0;
+ envPtr->termOffset = 0;
+
+ envPtr->codeStart = envPtr->staticCodeSpace;
+ envPtr->codeNext = envPtr->codeStart;
+ envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
+ envPtr->mallocedCodeArray = 0;
+
+ envPtr->objArrayPtr = envPtr->staticObjArraySpace;
+ envPtr->objArrayNext = 0;
+ envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
+ envPtr->mallocedObjArray = 0;
+
+ envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace;
+ envPtr->excRangeArrayNext = 0;
+ envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
+ envPtr->mallocedExcRangeArray = 0;
+
+ envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
+ envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
+ envPtr->mallocedCmdMap = 0;
+
+ envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
+ envPtr->auxDataArrayNext = 0;
+ envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
+ envPtr->mallocedAuxDataArray = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFreeCompileEnv --
+ *
+ * Free the storage allocated in a CompileEnv compilation environment
+ * structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocated storage in the CompileEnv structure is freed. Note that
+ * ref counts for Tcl objects in its object table are not decremented.
+ * In addition, any storage referenced by any auxiliary data items
+ * in the CompileEnv structure are not freed either. The expectation
+ * is that when compilation is successful, "ownership" (i.e., the
+ * pointers to) these objects and aux data items will just be handed
+ * over to the corresponding ByteCode structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFreeCompileEnv(envPtr)
+ register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
+{
+ Tcl_DeleteHashTable(&(envPtr->objTable));
+ if (envPtr->mallocedCodeArray) {
+ ckfree((char *) envPtr->codeStart);
+ }
+ if (envPtr->mallocedObjArray) {
+ ckfree((char *) envPtr->objArrayPtr);
+ }
+ if (envPtr->mallocedExcRangeArray) {
+ ckfree((char *) envPtr->excRangeArrayPtr);
+ }
+ if (envPtr->mallocedCmdMap) {
+ ckfree((char *) envPtr->cmdMapPtr);
+ }
+ if (envPtr->mallocedAuxDataArray) {
+ ckfree((char *) envPtr->auxDataArrayPtr);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitByteCodeObj --
+ *
+ * Create a ByteCode structure and initialize it from a CompileEnv
+ * compilation environment structure. The ByteCode structure is
+ * smaller and contains just that information needed to execute
+ * the bytecode instructions resulting from compiling a Tcl script.
+ * The resulting structure is placed in the specified object.
+ *
+ * Results:
+ * A newly constructed ByteCode object is stored in the internal
+ * representation of the objPtr.
+ *
+ * Side effects:
+ * A single heap object is allocated to hold the new ByteCode structure
+ * and its code, object, command location, and aux data arrays. Note
+ * that "ownership" (i.e., the pointers to) the Tcl objects and aux
+ * data items will be handed over to the new ByteCode structure from
+ * the CompileEnv structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitByteCodeObj(objPtr, envPtr)
+ Tcl_Obj *objPtr; /* Points object that should be
+ * initialized, and whose string rep
+ * contains the source code. */
+ register CompileEnv *envPtr; /* Points to the CompileEnv structure from
+ * which to create a ByteCode structure. */
+{
+ register ByteCode *codePtr;
+ size_t codeBytes, objArrayBytes, rangeArrayBytes, cmdLocBytes;
+ size_t auxDataArrayBytes;
+ register size_t size;
+ register char *p;
+
+ codeBytes = envPtr->codeNext - envPtr->codeStart;
+ objArrayBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
+ rangeArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
+ cmdLocBytes = envPtr->numCommands * sizeof(CmdLocation);
+ auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
+
+ size = TCL_ALIGN(sizeof(ByteCode));
+ size += TCL_ALIGN(codeBytes);
+ size += TCL_ALIGN(objArrayBytes);
+ size += TCL_ALIGN(rangeArrayBytes);
+ size += TCL_ALIGN(cmdLocBytes);
+ size += TCL_ALIGN(auxDataArrayBytes);
+
+ p = (char *) ckalloc(size);
+ codePtr = (ByteCode *) p;
+ codePtr->iPtr = envPtr->iPtr;
+ codePtr->compileEpoch = envPtr->iPtr->compileEpoch;
+ codePtr->refCount = 1;
+ codePtr->source = envPtr->source;
+ codePtr->procPtr = envPtr->procPtr;
+ codePtr->numCommands = envPtr->numCommands;
+ codePtr->numSrcChars = envPtr->termOffset;
+ codePtr->numCodeBytes = codeBytes;
+ codePtr->numObjects = envPtr->objArrayNext;
+ codePtr->numExcRanges = envPtr->excRangeArrayNext;
+ codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
+ codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
+ codePtr->maxStackDepth = envPtr->maxStackDepth;
+
+ p += TCL_ALIGN(sizeof(ByteCode));
+ codePtr->codeStart = (unsigned char *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes);
+
+ p += TCL_ALIGN(codeBytes);
+ codePtr->objArrayPtr = (Tcl_Obj **) p;
+ memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes);
+
+ p += TCL_ALIGN(objArrayBytes);
+ codePtr->excRangeArrayPtr = (ExceptionRange *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr, rangeArrayBytes);
+
+ p += TCL_ALIGN(rangeArrayBytes);
+ codePtr->cmdMapPtr = (CmdLocation *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->cmdMapPtr, cmdLocBytes);
+
+ p += TCL_ALIGN(cmdLocBytes);
+ codePtr->auxDataArrayPtr = (AuxData *) p;
+ memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, auxDataArrayBytes);
+
+ /*
+ * Free the old internal rep then convert the object to a
+ * bytecode object by making its internal rep point to the just
+ * compiled ByteCode.
+ */
+
+ if ((objPtr->typePtr != NULL) &&
+ (objPtr->typePtr->freeIntRepProc != NULL)) {
+ objPtr->typePtr->freeIntRepProc(objPtr);
+ }
+ objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
+ objPtr->typePtr = &tclByteCodeType;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileString --
+ *
+ * Compile a Tcl script in a null-terminated binary string.
+ *
+ * Results:
+ * The return value is TCL_OK on a successful compilation and TCL_ERROR
+ * on failure. If TCL_ERROR is returned, then the interpreter's result
+ * contains an error message.
+ *
+ * envPtr->termOffset and interp->termOffset are filled in with the
+ * offset of the character in the string just after the last one
+ * successfully processed; this might be the offset of the ']' (if
+ * flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of
+ * the string. Also updates envPtr->maxStackDepth with the maximum
+ * number of stack elements needed to execute the string's commands.
+ *
+ * Side effects:
+ * Adds instructions to envPtr to evaluate the string at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileString(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Interp *iPtr = (Interp *) interp;
+ register char *src = string;/* Points to current source char. */
+ register char c = *src; /* The current char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0');
+ /* Return when this character is found
+ * (either ']' or '\0'). Zero means newlines
+ * terminate cmds. */
+ int isFirstCmd = 1; /* 1 if compiling the first cmd. */
+ char *cmdSrcStart = NULL; /* Points to first non-blank char in each
+ * command. Initialized to avoid compiler
+ * warning. */
+ int cmdIndex = -1; /* The index of the current command in the
+ * compilation environment's command
+ * location table. Initialized to avoid
+ * compiler warning. */
+ int cmdCodeOffset = -1; /* Offset of first byte of current command's
+ * code. Initialized to avoid compiler
+ * warning. */
+ int cmdCodeBytes; /* Number of code bytes for current
+ * command. */
+ int cmdWords; /* Number of words in current command. */
+ Tcl_Command cmd; /* Used to search for commands. */
+ Command *cmdPtr; /* Points to command's Command structure if
+ * first word is simple and command was
+ * found; else NULL. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute all cmds. */
+ char *termPtr; /* Points to char that terminated word. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null character
+ * during processing of words. */
+ int objIndex = -1; /* The object array index for a pushed
+ * object holding a word or word part
+ * Initialized to avoid compiler warning. */
+ unsigned char *entryCodeNext = envPtr->codeNext;
+ /* Value of envPtr's current instruction
+ * pointer at entry. Used to tell if any
+ * instructions generated. */
+ char *ellipsis = ""; /* Used to set errorInfo variable; "..."
+ * indicates that not all of offending
+ * command is included in errorInfo. ""
+ * means that the command is all there. */
+ Tcl_Obj *objPtr;
+ int numChars;
+ int result = TCL_OK;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+
+ /*
+ * commands: command {(';' | '\n') command}
+ */
+
+ while ((src != lastChar) && (c != termChar)) {
+ /*
+ * Skip white space, semicolons, backslash-newlines (treated as
+ * spaces), and comments before command.
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ while ((type & (TCL_SPACE | TCL_BACKSLASH))
+ || (c == '\n') || (c == ';')) {
+ if (type == TCL_BACKSLASH) {
+ if (src[1] == '\n') {
+ src += 2;
+ } else {
+ break; /* no longer white space */
+ }
+ } else {
+ src++;
+ }
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ }
+
+ if (c == '#') {
+ while (src != lastChar) {
+ if (c == '\\') {
+ int numRead;
+ Tcl_Backslash(src, &numRead);
+ src += numRead;
+ } else if (c == '\n') {
+ src++;
+ c = *src;
+ envPtr->termOffset = (src - string);
+ break;
+ } else {
+ src++;
+ }
+ c = *src;
+ }
+ continue; /* end of comment, restart outer command loop */
+ }
+
+ /*
+ * Compile one command: zero or more words terminated by a '\n',
+ * ';', ']' (if command is terminated by close bracket), or
+ * the end of string.
+ *
+ * command: word*
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ if ((type == TCL_COMMAND_END)
+ && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
+ continue; /* ignore empty command; restart outer cmd loop */
+ }
+
+ /*
+ * If not the first command, discard the previous command's result.
+ */
+
+ if (!isFirstCmd) {
+ TclEmitOpcode(INST_POP, envPtr);
+ if (!(flags & TCL_BRACKET_TERM)) {
+ /*
+ * We are compiling a top level command. Update the number
+ * of code bytes for the last command to account for the pop
+ * instruction we just emitted.
+ */
+
+ int lastCmdIndex = (envPtr->numCommands - 1);
+ cmdCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
+ (envPtr->cmdMapPtr[lastCmdIndex]).numCodeBytes =
+ cmdCodeBytes;
+ }
+ }
+
+ /*
+ * Compile the words of the command. Process the first word
+ * specially, since it is the name of a command. If it is a "simple"
+ * string (just a sequence of characters), look it up in the table
+ * of compilation procedures. If a word other than the first is
+ * simple and represents an integer whose formatted representation
+ * is the same as the word, just push an integer object. Also record
+ * starting source and object information for the command if we are
+ * at the top level (i.e. we were called directly from
+ * SetByteCodeFromAny and are not compiling a substring enclosed in
+ * square brackets).
+ */
+
+ cmdSrcStart = src;
+ cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ cmdWords = 0;
+ if (!(flags & TCL_BRACKET_TERM)) {
+ envPtr->numCommands++;
+ cmdIndex = (envPtr->numCommands - 1);
+ EnterCmdStartData(envPtr, cmdIndex,
+ (cmdSrcStart - envPtr->source), cmdCodeOffset);
+
+ if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) {
+ /*
+ * Display a line summarizing the top level command we
+ * are about to compile.
+ */
+
+ char *p = cmdSrcStart;
+ int numChars;
+ char *ellipsis = "";
+
+ while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
+ || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
+ p++;
+ }
+ numChars = (p - cmdSrcStart);
+ if (numChars > 60) {
+ numChars = 60;
+ ellipsis = " ...";
+ } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
+ ellipsis = " ...";
+ }
+ fprintf(stdout, "Compiling: %.*s%s\n",
+ numChars, cmdSrcStart, ellipsis);
+ }
+ }
+
+ while ((type != TCL_COMMAND_END)
+ || ((c == ']') && !(flags & TCL_BRACKET_TERM))) {
+ /*
+ * Skip any leading white space at the start of a word. Note
+ * that a backslash-newline is treated as a space.
+ */
+
+ while (type & (TCL_SPACE | TCL_BACKSLASH)) {
+ if (type == TCL_BACKSLASH) {
+ if (src[1] == '\n') {
+ src += 2;
+ } else {
+ break; /* no longer white space */
+ }
+ } else {
+ src++;
+ }
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ }
+ if ((type == TCL_COMMAND_END)
+ && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
+ break; /* no words remain for command. */
+ }
+
+ /*
+ * Compile one word. We use an inline version of CompileWord to
+ * avoid an extra procedure call.
+ */
+
+ envPtr->pushSimpleWords = 0; /* we will handle simple words */
+ if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
+ src++; /* advance over the " or { */
+ if (type == TCL_QUOTE) {
+ result = TclCompileQuotes(interp, src, lastChar,
+ '"', flags, envPtr);
+ } else {
+ result = CompileBraces(interp, src, lastChar,
+ flags, envPtr);
+ }
+ termPtr = (src + envPtr->termOffset);
+ if (result != TCL_OK) {
+ src = termPtr;
+ goto done;
+ }
+
+ /*
+ * Make sure terminating character of the quoted or braced
+ * string is the end of word.
+ */
+
+ c = *termPtr;
+ if ((c == '\\') && (*(termPtr+1) == '\n')) {
+ /*
+ * Line is continued on next line; the backslash-
+ * newline turns into space, which terminates the word.
+ */
+ } else {
+ type = CHAR_TYPE(termPtr, lastChar);
+ if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
+ Tcl_ResetResult(interp);
+ if (*(src-1) == '"') {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-quote", -1);
+ } else {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-brace", -1);
+ }
+ result = TCL_ERROR;
+ }
+ }
+ } else {
+ result = CompileMultipartWord(interp, src, lastChar,
+ flags, envPtr);
+ termPtr = (src + envPtr->termOffset);
+ }
+ if (result != TCL_OK) {
+ ellipsis = "...";
+ src = termPtr;
+ goto done;
+ }
+
+ if (envPtr->wordIsSimple) {
+ /*
+ * A simple word. Temporarily replace the terminating
+ * character with a null character.
+ */
+
+ numChars = envPtr->numSimpleWordChars;
+ savedChar = src[numChars];
+ src[numChars] = '\0';
+
+ if ((cmdWords == 0)
+ && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) {
+ /*
+ * The first word of a command and inline command
+ * compilation has not been disabled (e.g., by command
+ * traces). Look up the first word in the interpreter's
+ * hashtable of commands. If a compilation procedure is
+ * found, let it compile the command after resetting
+ * error logging information.
+ */
+
+ cmdPtr = NULL;
+ cmd = Tcl_FindCommand(interp, src,
+ (Tcl_Namespace *) NULL, /*flags*/ 0);
+ if (cmd != (Tcl_Command) NULL) {
+ cmdPtr = (Command *) cmd;
+ }
+ if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) {
+ char *firstArg = termPtr;
+ src[numChars] = savedChar; /* restore chr */
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
+ | ERROR_CODE_SET);
+ result = (*(cmdPtr->compileProc))(interp,
+ firstArg, lastChar, flags, envPtr);
+ if (result == TCL_OK) {
+ src = (firstArg + envPtr->termOffset);
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ goto finishCommand; /* done with command */
+ } else if (result == TCL_OUT_LINE_COMPILE) {
+ result = TCL_OK; /* reset result */
+ src[numChars] = '\0';
+ } else {
+ src = firstArg;
+ goto done; /* an error */
+ }
+ }
+
+ /*
+ * No compile procedure was found for the command: push
+ * the word and continue to compile the remaining
+ * words. If a hashtable entry was found for the
+ * command, push a CmdName object instead to avoid
+ * runtime lookups. If necessary, convert the pushed
+ * object to be a CmdName object. If this is the first
+ * CmdName object in this code unit that refers to the
+ * command, increment the reference count in the
+ * Command structure to reflect the new reference from
+ * the CmdName object and, if the command is deleted
+ * later, to keep the Command structure from being freed
+ * until TclExecuteByteCode has a chance to recognize
+ * that the command was deleted.
+ */
+
+ objIndex = TclObjIndexForString(src, numChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ if (cmdPtr != NULL) {
+ objPtr = envPtr->objArrayPtr[objIndex];
+ if ((objPtr->typePtr != &tclCmdNameType)
+ && (objPtr->bytes != NULL)) {
+ ResolvedCmdName *resPtr = (ResolvedCmdName *)
+ ckalloc(sizeof(ResolvedCmdName));
+ Namespace *nsPtr = (Namespace *)
+ Tcl_GetCurrentNamespace(interp);
+
+ resPtr->cmdPtr = cmdPtr;
+ resPtr->refNsPtr = nsPtr;
+ resPtr->refNsId = nsPtr->nsId;
+ resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch;
+ resPtr->cmdEpoch = cmdPtr->cmdEpoch;
+ resPtr->refCount = 1;
+ objPtr->internalRep.otherValuePtr =
+ (VOID *) resPtr;
+ objPtr->typePtr = &tclCmdNameType;
+ cmdPtr->refCount++;
+ }
+ }
+ } else {
+ /*
+ * See if the word represents an integer whose formatted
+ * representation is the same as the word (e.g., this is
+ * true for 123 and -1 but not for 00005). If so, just
+ * push an integer object.
+ */
+
+ int isCompilableInt = 0;
+ long n;
+ char buf[40];
+
+ if (TclLooksLikeInt(src)) {
+ if (TclGetLong(interp, src, &n) == TCL_OK) {
+ TclFormatInt(buf, n);
+ if (strcmp(src, buf) == 0) {
+ isCompilableInt = 1;
+ objIndex = TclObjIndexForString(src,
+ numChars, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = n;
+ objPtr->typePtr = &tclIntType;
+ }
+ }
+ }
+ if (!isCompilableInt) {
+ objIndex = TclObjIndexForString(src, numChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ }
+ }
+ src[numChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = TclMax((cmdWords + 1), maxDepth);
+ } else { /* not a simple word */
+ maxDepth = TclMax((cmdWords + envPtr->maxStackDepth),
+ maxDepth);
+ }
+ src = termPtr;
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ cmdWords++;
+ }
+
+ /*
+ * Emit an invoke instruction for the command. If a compile command
+ * was found for the command we called it and skipped this.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if ((cmdWords < 0) || (cmdWords > 10000)) {
+ fprintf(stderr, "\nTclCompileString: bad cmdWords value %d\n",
+ cmdWords);
+ panic("TclCompileString: bad cmdWords value %d");
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ if (cmdWords > 0) {
+ if (cmdWords <= 255) {
+ TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr);
+ } else {
+ TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr);
+ }
+ }
+
+ /*
+ * Update the compilation environment structure. Record
+ * source/object information for the command if we are at the top
+ * level (i.e. we we called directly from SetByteCodeFromAny and are
+ * not compiling a substring enclosed in square brackets).
+ */
+
+ finishCommand:
+ if (!(flags & TCL_BRACKET_TERM)) {
+ int cmdSrcChars = (src - cmdSrcStart);
+ cmdCodeBytes =
+ (envPtr->codeNext - envPtr->codeStart - cmdCodeOffset);
+ EnterCmdExtentData(envPtr, cmdIndex, cmdSrcChars, cmdCodeBytes);
+ }
+ isFirstCmd = 0;
+ envPtr->termOffset = (src - string);
+ c = *src;
+ }
+
+ done:
+ if (result == TCL_OK) {
+ /*
+ * If the source string yielded no instructions (e.g., if it was
+ * empty), push an empty string object as the command's result.
+ */
+
+ if (entryCodeNext == envPtr->codeNext) {
+ int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1; /* we pushed 1 word for the empty string */
+ }
+ } else {
+ /*
+ * Add additional error information. First compute the line number
+ * where the error occurred.
+ */
+
+ int numChars;
+ register char *p;
+ char buf[200];
+
+ iPtr->errorLine = 1;
+ for (p = string; p != cmdSrcStart; p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+ for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
+ if (*p == '\n') {
+ iPtr->errorLine++;
+ }
+ }
+
+ /*
+ * Figure out how much of the command to print (up to a certain
+ * number of characters, or up to the first newline).
+ */
+
+ numChars = (src - cmdSrcStart);
+ if (numChars > 150) {
+ numChars = 150;
+ ellipsis = " ...";
+ }
+ sprintf(buf, "\n while compiling\n\"%.*s%s\"",
+ numChars, cmdSrcStart, ellipsis);
+ Tcl_AddObjErrorInfo(interp, buf, -1);
+ }
+
+ envPtr->termOffset = (src - string);
+ iPtr->termOffset = envPtr->termOffset;
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileWord --
+ *
+ * This procedure compiles one word from a command string. It skips
+ * any leading white space.
+ *
+ * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
+ * procedure emits push and other instructions to compute the
+ * word on the Tcl evaluation stack at execution time. If a caller sets
+ * envPtr->pushSimpleWords to 0, CompileWord will _not_ compile
+ * "simple" words: words that are just a sequence of characters without
+ * backslashes. It will leave their compilation up to the caller.
+ *
+ * As an important special case, if the word is simple, this procedure
+ * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
+ * number of characters in the simple word. This allows the caller to
+ * process these words specially.
+ *
+ * Results:
+ * The return value is a standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed in the last
+ * word. This is normally the character just after the last one in a
+ * word (perhaps the command terminator), or the vicinity of an error
+ * (if the result is not TCL_OK).
+ *
+ * envPtr->wordIsSimple is set 1 if the word is simple: just a
+ * sequence of characters without backslashes. If so, the word's
+ * characters are the envPtr->numSimpleWordChars characters starting
+ * at string.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to evaluate the word. This is not changed if
+ * the word is simple and envPtr->pushSimpleWords was 0 (false).
+ *
+ * Side effects:
+ * Instructions are added to envPtr to compute and push the word
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileWord(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Interpreter to use for nested command
+ * evaluations and error messages. */
+ char *string; /* First character of word. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same values
+ * passed to Tcl_EvalObj). */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
+{
+ /*
+ * Compile one word: approximately
+ *
+ * word: quoted_string | braced_string | multipart_word
+ * quoted_string: '"' char* '"'
+ * braced_string: '{' char* '}'
+ * multipart_word (see CompileMultipartWord below)
+ */
+
+ register char *src = string; /* Points to current source char. */
+ register int type = CHAR_TYPE(src, lastChar);
+ /* Current char's CHAR_TYPE type. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to compute and push the word. */
+ char *termPtr = src; /* Points to the character that terminated
+ * the word. */
+ int result = TCL_OK;
+
+ /*
+ * Skip any leading white space at the start of a word. Note that a
+ * backslash-newline is treated as a space.
+ */
+
+ while (type & (TCL_SPACE | TCL_BACKSLASH)) {
+ if (type == TCL_BACKSLASH) {
+ if (src[1] == '\n') {
+ src += 2;
+ } else {
+ break; /* no longer white space */
+ }
+ } else {
+ src++;
+ }
+ type = CHAR_TYPE(src, lastChar);
+ }
+ if (type == TCL_COMMAND_END) {
+ goto done;
+ }
+
+ /*
+ * Compile the word. Handle quoted and braced string words here in order
+ * to avoid an extra procedure call.
+ */
+
+ if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
+ src++; /* advance over the " or { */
+ if (type == TCL_QUOTE) {
+ result = TclCompileQuotes(interp, src, lastChar, '"', flags,
+ envPtr);
+ } else {
+ result = CompileBraces(interp, src, lastChar, flags, envPtr);
+ }
+ termPtr = (src + envPtr->termOffset);
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * Make sure terminating character of the quoted or braced string is
+ * the end of word.
+ */
+
+ if ((*termPtr == '\\') && (*(termPtr+1) == '\n')) {
+ /*
+ * Line is continued on next line; the backslash-newline turns
+ * into space, which terminates the word.
+ */
+ } else {
+ type = CHAR_TYPE(termPtr, lastChar);
+ if (!(type & (TCL_SPACE | TCL_COMMAND_END))) {
+ Tcl_ResetResult(interp);
+ if (*(src-1) == '"') {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-quote", -1);
+ } else {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-brace", -1);
+ }
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+ maxDepth = envPtr->maxStackDepth;
+ } else {
+ result = CompileMultipartWord(interp, src, lastChar, flags, envPtr);
+ termPtr = (src + envPtr->termOffset);
+ maxDepth = envPtr->maxStackDepth;
+ }
+
+ /*
+ * Done processing the word. The values of envPtr->wordIsSimple and
+ * envPtr->numSimpleWordChars are left at the values returned by
+ * TclCompileQuotes/Braces/MultipartWord.
+ */
+
+ done:
+ envPtr->termOffset = (termPtr - string);
+ envPtr->maxStackDepth = maxDepth;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileMultipartWord --
+ *
+ * This procedure compiles one multipart word: a word comprised of some
+ * number of nested commands, variable references, or arbitrary
+ * characters. This procedure assumes that quoted string and braced
+ * string words and the end of command have already been handled by its
+ * caller. It also assumes that any leading white space has already
+ * been consumed.
+ *
+ * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
+ * procedure emits push and other instructions to compute the word on
+ * the Tcl evaluation stack at execution time. If a caller sets
+ * envPtr->pushSimpleWords to 0, it will _not_ compile "simple" words:
+ * words that are just a sequence of characters without backslashes.
+ * It will leave their compilation up to the caller. This is done, for
+ * example, to provide special support for the first word of commands,
+ * which are almost always the (simple) name of a command.
+ *
+ * As an important special case, if the word is simple, this procedure
+ * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
+ * number of characters in the simple word. This allows the caller to
+ * process these words specially.
+ *
+ * Results:
+ * The return value is a standard Tcl result. If an error occurs, an
+ * error message is left in the interpreter's result.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed in the last
+ * word. This is normally the character just after the last one in a
+ * word (perhaps the command terminator), or the vicinity of an error
+ * (if the result is not TCL_OK).
+ *
+ * envPtr->wordIsSimple is set 1 if the word is simple: just a
+ * sequence of characters without backslashes. If so, the word's
+ * characters are the envPtr->numSimpleWordChars characters starting
+ * at string.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to evaluate the word. This is not changed if
+ * the word is simple and envPtr->pushSimpleWords was 0 (false).
+ *
+ * Side effects:
+ * Instructions are added to envPtr to compute and push the word
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileMultipartWord(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Interpreter to use for nested command
+ * evaluations and error messages. */
+ char *string; /* First character of word. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same values
+ * passed to Tcl_EvalObj). */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
+{
+ /*
+ * Compile one multi_part word:
+ *
+ * multi_part_word: word_part+
+ * word_part: nested_cmd | var_reference | char+
+ * nested_cmd: '[' command ']'
+ * var_reference: '$' name | '$' name '(' index_string ')' |
+ * '$' '{' braced_name '}')
+ * name: (letter | digit | underscore)+
+ * braced_name: (non_close_brace_char)*
+ * index_string: (non_close_paren_char)*
+ */
+
+ register char *src = string; /* Points to current source char. */
+ register char c = *src; /* The current char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int bracketNormal = !(flags & TCL_BRACKET_TERM);
+ int simpleWord = 0; /* Set 1 if word is simple. */
+ int numParts = 0; /* Count of word_part objs pushed. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to compute and push the word. */
+ char *start; /* Starting position of char+ word_part. */
+ int hasBackslash; /* Nonzero if '\' in char+ word_part. */
+ int numChars; /* Number of chars in char+ word_part. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null character
+ * during word_part processing. */
+ int objIndex; /* The object array index for a pushed
+ * object holding a word_part. */
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+ int result = TCL_OK;
+ int numRead;
+
+ type = CHAR_TYPE(src, lastChar);
+ while (1) {
+ /*
+ * Process a word_part: a sequence of chars, a var reference, or
+ * a nested command.
+ */
+
+ if ((type & (TCL_NORMAL | TCL_CLOSE_BRACE | TCL_BACKSLASH |
+ TCL_QUOTE | TCL_OPEN_BRACE)) ||
+ ((c == ']') && bracketNormal)) {
+ /*
+ * A char+ word part. Scan first looking for any backslashes.
+ * Note that a backslash-newline must be treated as a word
+ * separator, as if the backslash-newline had been collapsed
+ * before command parsing began.
+ */
+
+ start = src;
+ hasBackslash = 0;
+ do {
+ if (type == TCL_BACKSLASH) {
+ hasBackslash = 1;
+ Tcl_Backslash(src, &numRead);
+ if (src[1] == '\n') {
+ src += numRead;
+ type = TCL_SPACE; /* force word end */
+ break; /* exit loop: \newline is word separator */
+ }
+ src += numRead;
+ } else {
+ src++;
+ }
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ } while (type & (TCL_NORMAL | TCL_BACKSLASH | TCL_QUOTE |
+ TCL_OPEN_BRACE | TCL_CLOSE_BRACE)
+ || ((c == ']') && bracketNormal));
+
+ if ((numParts == 0) && !hasBackslash
+ && (type & (TCL_SPACE | TCL_COMMAND_END))) {
+ /*
+ * The word is "simple": just a sequence of characters
+ * without backslashes terminated by a TCL_SPACE or
+ * TCL_COMMAND_END. Just return if we are not to compile
+ * simple words.
+ */
+
+ simpleWord = 1;
+ if (!envPtr->pushSimpleWords) {
+ envPtr->wordIsSimple = 1;
+ envPtr->numSimpleWordChars = (src - string);
+ envPtr->termOffset = envPtr->numSimpleWordChars;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return TCL_OK;
+ }
+ }
+
+ /*
+ * Create and push a string object for the char+ word_part,
+ * which starts at "start" and ends at the char just before
+ * src. If backslashes were found, copy the word_part's
+ * characters with substituted backslashes into a heap-allocated
+ * buffer and use it to create the string object. Temporarily
+ * replace the terminating character with a null character.
+ */
+
+ numChars = (src - start);
+ savedChar = start[numChars];
+ start[numChars] = '\0';
+ if ((numChars > 0) && (hasBackslash)) {
+ char *buffer = ckalloc((unsigned) numChars + 1);
+ register char *dst = buffer;
+ register char *p = start;
+ while (p < src) {
+ if (*p == '\\') {
+ *dst = Tcl_Backslash(p, &numRead);
+ if (p[1] == '\n') {
+ break; /* end of word */
+ }
+ p += numRead;
+ dst++;
+ } else {
+ *dst++ = *p++;
+ }
+ }
+ *dst = '\0';
+ objIndex = TclObjIndexForString(buffer, dst-buffer,
+ /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
+ } else {
+ objIndex = TclObjIndexForString(start, numChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ }
+ start[numChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = TclMax((numParts + 1), maxDepth);
+ } else if (type == TCL_DOLLAR) {
+ result = TclCompileDollarVar(interp, src, lastChar,
+ flags, envPtr);
+ src += envPtr->termOffset;
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ } else if (type == TCL_OPEN_BRACKET) {
+ char *termPtr;
+ envPtr->pushSimpleWords = 1;
+ src++;
+ result = TclCompileString(interp, src, lastChar,
+ (flags | TCL_BRACKET_TERM), envPtr);
+ termPtr = (src + envPtr->termOffset);
+ if (*termPtr == ']') {
+ termPtr++; /* advance over the ']'. */
+ } else if (*termPtr == '\0') {
+ /*
+ * Missing ] at end of nested command.
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "missing close-bracket", -1);
+ result = TCL_ERROR;
+ }
+ src = termPtr;
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
+ c = *src;
+ type = CHAR_TYPE(src, lastChar);
+ } else if (type & (TCL_SPACE | TCL_COMMAND_END)) {
+ goto wordEnd;
+ }
+ numParts++;
+ } /* end of infinite loop */
+
+ wordEnd:
+ /*
+ * End of a non-simple word: TCL_SPACE, TCL_COMMAND_END, or
+ * backslash-newline. Concatenate the word_parts if necessary.
+ */
+
+ while (numParts > 255) {
+ TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
+ numParts -= 254; /* concat pushes 1 obj, the result */
+ }
+ if (numParts > 1) {
+ TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
+ }
+
+ done:
+ if (simpleWord) {
+ envPtr->wordIsSimple = 1;
+ envPtr->numSimpleWordChars = (src - string);
+ } else {
+ envPtr->wordIsSimple = 0;
+ envPtr->numSimpleWordChars = 0;
+ }
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileQuotes --
+ *
+ * This procedure compiles a double-quoted string such as a quoted Tcl
+ * command argument or a quoted value in a Tcl expression. This
+ * procedure is also used to compile array element names within
+ * parentheses (where the termChar will be ')' instead of '"'), or
+ * anything else that needs the substitutions that happen in quotes.
+ *
+ * Ordinarily, callers set envPtr->pushSimpleWords to 1 and
+ * TclCompileQuotes always emits push and other instructions to compute
+ * the word on the Tcl evaluation stack at execution time. If a caller
+ * sets envPtr->pushSimpleWords to 0, TclCompileQuotes will not compile
+ * "simple" words: words that are just a sequence of characters without
+ * backslashes. It will leave their compilation up to the caller. This
+ * is done to provide special support for the first word of commands,
+ * which are almost always the (simple) name of a command.
+ *
+ * As an important special case, if the word is simple, this procedure
+ * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
+ * number of characters in the simple word. This allows the caller to
+ * process these words specially.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing the quoted string. If an error
+ * occurs then the interpreter's result contains a standard error
+ * message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed; this is
+ * usually the character just after the matching close-quote.
+ *
+ * envPtr->wordIsSimple is set 1 if the word is simple: just a
+ * sequence of characters without backslashes. If so, the word's
+ * characters are the envPtr->numSimpleWordChars characters starting
+ * at string.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to evaluate the word. This is not changed if
+ * the word is simple and envPtr->pushSimpleWords was 0 (false).
+ *
+ * Side effects:
+ * Instructions are added to envPtr to push the quoted-string
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
+ Tcl_Interp *interp; /* Interpreter to use for nested command
+ * evaluations and error messages. */
+ char *string; /* Points to the character just after
+ * the opening '"' or '('. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int termChar; /* Character that terminates the "quoted"
+ * string (usually double-quote, but might
+ * be right-paren or something else). */
+ int flags; /* Flags to control compilation (same
+ * values passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
+{
+ register char *src = string; /* Points to current source char. */
+ register char c = *src; /* The current char. */
+ int simpleWord = 0; /* Set 1 if a simple quoted string word. */
+ char *start; /* Start position of char+ string_part. */
+ int hasBackslash; /* 1 if '\' found in char+ string_part. */
+ int numRead; /* Count of chars read by Tcl_Backslash. */
+ int numParts = 0; /* Count of string_part objs pushed. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to compute and push the string. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null
+ * char during string_part processing. */
+ int objIndex; /* The object array index for a pushed
+ * object holding a string_part. */
+ int numChars; /* Number of chars in string_part. */
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+ int result = TCL_OK;
+
+ /*
+ * quoted_string: '"' string_part* '"' (or termChar instead of ")
+ * string_part: var_reference | nested_cmd | char+
+ */
+
+
+ while ((src != lastChar) && (c != termChar)) {
+ if (c == '$') {
+ result = TclCompileDollarVar(interp, src, lastChar, flags,
+ envPtr);
+ src += envPtr->termOffset;
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
+ c = *src;
+ } else if (c == '[') {
+ char *termPtr;
+ envPtr->pushSimpleWords = 1;
+ src++;
+ result = TclCompileString(interp, src, lastChar,
+ (flags | TCL_BRACKET_TERM), envPtr);
+ termPtr = (src + envPtr->termOffset);
+ if (*termPtr == ']') {
+ termPtr++; /* advance over the ']'. */
+ }
+ src = termPtr;
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if (termPtr == lastChar) {
+ /*
+ * Missing ] at end of nested command.
+ */
+
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "missing close-bracket", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
+ c = *src;
+ } else {
+ /*
+ * Start of a char+ string_part. Scan first looking for any
+ * backslashes.
+ */
+
+ start = src;
+ hasBackslash = 0;
+ do {
+ if (c == '\\') {
+ hasBackslash = 1;
+ Tcl_Backslash(src, &numRead);
+ src += numRead;
+ } else {
+ src++;
+ }
+ c = *src;
+ } while ((src != lastChar) && (c != '$') && (c != '[')
+ && (c != termChar));
+
+ if ((numParts == 0) && !hasBackslash
+ && ((src == lastChar) && (c == termChar))) {
+ /*
+ * The quoted string is "simple": just a sequence of
+ * characters without backslashes terminated by termChar or
+ * a null character. Just return if we are not to compile
+ * simple words.
+ */
+
+ simpleWord = 1;
+ if (!envPtr->pushSimpleWords) {
+ if ((src == lastChar) && (termChar != '\0')) {
+ char buf[40];
+ sprintf(buf, "missing %c", termChar);
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ result = TCL_ERROR;
+ } else {
+ src++; /* advance over termChar */
+ }
+ envPtr->wordIsSimple = 1;
+ envPtr->numSimpleWordChars = (src - string - 1);
+ envPtr->termOffset = (src - string);
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+ }
+ }
+
+ /*
+ * Create and push a string object for the char+ string_part
+ * that starts at "start" and ends at the char just before
+ * src. If backslashes were found, copy the string_part's
+ * characters with substituted backslashes into a heap-allocated
+ * buffer and use it to create the string object. Temporarily
+ * replace the terminating character with a null character.
+ */
+
+ numChars = (src - start);
+ savedChar = start[numChars];
+ start[numChars] = '\0';
+ if ((numChars > 0) && (hasBackslash)) {
+ char *buffer = ckalloc((unsigned) numChars + 1);
+ register char *dst = buffer;
+ register char *p = start;
+ while (p < src) {
+ if (*p == '\\') {
+ *dst++ = Tcl_Backslash(p, &numRead);
+ p += numRead;
+ } else {
+ *dst++ = *p++;
+ }
+ }
+ *dst = '\0';
+ objIndex = TclObjIndexForString(buffer, (dst - buffer),
+ /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
+ } else {
+ objIndex = TclObjIndexForString(start, numChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ }
+ start[numChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = TclMax((numParts + 1), maxDepth);
+ }
+ numParts++;
+ }
+
+ /*
+ * End of the quoted string: src points at termChar or '\0'. If
+ * necessary, concatenate the string_part objects on the stack.
+ */
+
+ if ((src == lastChar) && (termChar != '\0')) {
+ char buf[40];
+ sprintf(buf, "missing %c", termChar);
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ result = TCL_ERROR;
+ goto done;
+ } else {
+ src++; /* advance over termChar */
+ }
+
+ if (numParts == 0) {
+ /*
+ * The quoted string was empty. Push an empty string object.
+ */
+
+ int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ TclEmitPush(objIndex, envPtr);
+ } else {
+ /*
+ * Emit any needed concat instructions.
+ */
+
+ while (numParts > 255) {
+ TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
+ numParts -= 254; /* concat pushes 1 obj, the result */
+ }
+ if (numParts > 1) {
+ TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
+ }
+ }
+
+ done:
+ if (simpleWord) {
+ envPtr->wordIsSimple = 1;
+ envPtr->numSimpleWordChars = (src - string - 1);
+ } else {
+ envPtr->wordIsSimple = 0;
+ envPtr->numSimpleWordChars = 0;
+ }
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+}
+
+/*
+ *--------------------------------------------------------------
+ *
+ * CompileBraces --
+ *
+ * This procedure compiles characters between matching curly braces.
+ *
+ * Ordinarily, callers set envPtr->pushSimpleWords to 1 and
+ * CompileBraces always emits a push instruction to compute the word on
+ * the Tcl evaluation stack at execution time. However, if a caller
+ * sets envPtr->pushSimpleWords to 0, CompileBraces will _not_ compile
+ * "simple" words: words that are just a sequence of characters without
+ * backslash-newlines. It will leave their compilation up to the
+ * caller.
+ *
+ * As an important special case, if the word is simple, this procedure
+ * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
+ * number of characters in the simple word. This allows the caller to
+ * process these words specially.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed. This is
+ * usually the character just after the matching close-brace.
+ *
+ * envPtr->wordIsSimple is set 1 if the word is simple: just a
+ * sequence of characters without backslash-newlines. If so, the word's
+ * characters are the envPtr->numSimpleWordChars characters starting
+ * at string.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to evaluate the word. This is not changed if
+ * the word is simple and envPtr->pushSimpleWords was 0 (false).
+ *
+ * Side effects:
+ * Instructions are added to envPtr to push the braced string
+ * at runtime.
+ *
+ *--------------------------------------------------------------
+ */
+
+static int
+CompileBraces(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Interpreter to use for nested command
+ * evaluations and error messages. */
+ char *string; /* Character just after opening bracket. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same
+ * values passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
+{
+ register char *src = string; /* Points to current source char. */
+ register char c; /* The current char. */
+ int simpleWord = 0; /* Set 1 if a simple braced string word. */
+ int level = 1; /* {} nesting level. Initially 1 since {
+ * was parsed before we were called. */
+ int hasBackslashNewline = 0; /* Nonzero if '\' found. */
+ char *last; /* Points just before terminating '}'. */
+ int numChars; /* Number of chars in braced string. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null
+ * char during braced string processing. */
+ int objIndex; /* The object array index for a pushed
+ * object holding a braced string. */
+ int numRead;
+ int result = TCL_OK;
+
+ /*
+ * Check for any backslash-newlines, since we must treat
+ * backslash-newlines specially (they must be replaced by spaces).
+ */
+
+ while (1) {
+ c = *src;
+ if (src == lastChar) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "missing close-brace", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if (CHAR_TYPE(src, lastChar) != TCL_NORMAL) {
+ if (c == '{') {
+ level++;
+ } else if (c == '}') {
+ --level;
+ if (level == 0) {
+ src++;
+ last = (src - 2); /* i.e. point just before
+ * terminating } */
+ break;
+ }
+ } else if (c == '\\') {
+ if (*(src+1) == '\n') {
+ hasBackslashNewline = 1;
+ }
+ (void) Tcl_Backslash(src, &numRead);
+ src += numRead - 1;
+ }
+ }
+ src++;
+ }
+
+ if (!hasBackslashNewline) {
+ /*
+ * The braced word is "simple": just a sequence of characters
+ * without backslash-newlines. Just return if we are not to compile
+ * simple words.
+ */
+
+ simpleWord = 1;
+ if (!envPtr->pushSimpleWords) {
+ envPtr->wordIsSimple = 1;
+ envPtr->numSimpleWordChars = (src - string - 1);
+ envPtr->termOffset = (src - string);
+ return TCL_OK;
+ }
+ }
+
+ /*
+ * Create and push a string object for the braced string. This starts at
+ * "string" and ends just after "last" (which points to the final
+ * character before the terminating '}'). If backslash-newlines were
+ * found, we copy characters one at a time into a heap-allocated buffer
+ * and do backslash-newline substitutions.
+ */
+
+ numChars = (last - string + 1);
+ savedChar = string[numChars];
+ string[numChars] = '\0';
+ if ((numChars > 0) && (hasBackslashNewline)) {
+ char *buffer = ckalloc((unsigned) numChars + 1);
+ register char *dst = buffer;
+ register char *p = string;
+ while (p <= last) {
+ c = *dst++ = *p++;
+ if (c == '\\') {
+ if (*p == '\n') {
+ dst[-1] = Tcl_Backslash(p-1, &numRead);
+ p += numRead - 1;
+ } else {
+ (void) Tcl_Backslash(p-1, &numRead);
+ while (numRead > 1) {
+ *dst++ = *p++;
+ numRead--;
+ }
+ }
+ }
+ }
+ *dst = '\0';
+ objIndex = TclObjIndexForString(buffer, (dst - buffer),
+ /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
+ } else {
+ objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1,
+ /*inHeap*/ 0, envPtr);
+ }
+ string[numChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+
+ done:
+ if (simpleWord) {
+ envPtr->wordIsSimple = 1;
+ envPtr->numSimpleWordChars = (src - string - 1);
+ } else {
+ envPtr->wordIsSimple = 0;
+ envPtr->numSimpleWordChars = 0;
+ }
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = 1;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileDollarVar --
+ *
+ * Given a string starting with a $ sign, parse a variable name
+ * and compile instructions to push its value. If the variable
+ * reference is just a '$' (i.e. the '$' isn't followed by anything
+ * that could possibly be a variable name), just push a string object
+ * containing '$'.
+ *
+ * Results:
+ * The return value is a standard Tcl result. If an error occurs
+ * then an error message is left in the interpreter's result.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one in the variable reference.
+ *
+ * envPtr->wordIsSimple is set 0 (false) because the word is not
+ * simple: it is not just a sequence of characters without backslashes.
+ * For the same reason, envPtr->numSimpleWordChars is set 0.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the string's commands.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to look up the variable and
+ * push its value at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Interpreter to use for nested command
+ * evaluations and error messages. */
+ char *string; /* First char (i.e. $) of var reference. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same
+ * values passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds the resulting instructions. */
+{
+ register char *src = string; /* Points to current source char. */
+ register char c; /* The current char. */
+ char *name; /* Start of 1st part of variable name. */
+ int nameChars; /* Count of chars in name. */
+ int nameHasNsSeparators = 0; /* Set 1 if name contains "::"s. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null
+ * char during name processing. */
+ int objIndex; /* The object array index for a pushed
+ * object holding a name part. */
+ int isArrayRef = 0; /* 1 if reference to array element. */
+ int localIndex = -1; /* Frame index of local if found. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to push the variable. */
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+ int result = TCL_OK;
+
+ /*
+ * var_reference: '$' '{' braced_name '}' |
+ * '$' name ['(' index_string ')']
+ *
+ * There are three cases:
+ * 1. The $ sign is followed by an open curly brace. Then the variable
+ * name is everything up to the next close curly brace, and the
+ * variable is a scalar variable.
+ * 2. The $ sign is not followed by an open curly brace. Then the
+ * variable name is everything up to the next character that isn't
+ * a letter, digit, underscore, or a "::" namespace separator. If the
+ * following character is an open parenthesis, then the information
+ * between parentheses is the array element name, which can include
+ * any of the substitutions permissible between quotes.
+ * 3. The $ sign is followed by something that isn't a letter, digit,
+ * underscore, or a "::" namespace separator: in this case,
+ * there is no variable name, and "$" is pushed.
+ */
+
+ src++; /* advance over the '$'. */
+
+ /*
+ * Collect the first part of the variable's name into "name" and
+ * determine if it is an array reference and if it contains any
+ * namespace separator (::'s).
+ */
+
+ if (*src == '{') {
+ /*
+ * A scalar name in braces.
+ */
+
+ char *p;
+
+ src++; /* advance over the '{'. */
+ name = src;
+ c = *src;
+ while (c != '}') {
+ if (src == lastChar) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "missing close-brace for variable name", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ src++;
+ c = *src;
+ }
+ nameChars = (src - name);
+ for (p = name; p < src; p++) {
+ if ((*p == ':') && (*(p+1) == ':')) {
+ nameHasNsSeparators = 1;
+ break;
+ }
+ }
+ src++; /* advance over the '}'. */
+ } else {
+ /*
+ * Scalar name or array reference not in braces.
+ */
+
+ name = src;
+ c = *src;
+ while (isalnum(UCHAR(c)) || (c == '_') || (c == ':')) {
+ if (c == ':') {
+ if (*(src+1) == ':') {
+ nameHasNsSeparators = 1;
+ src += 2; /* skip over the initial :: */
+ while (*src == ':') {
+ src++; /* skip over a subsequent : */
+ }
+ c = *src;
+ } else {
+ break; /* : by itself */
+ }
+ } else {
+ src++;
+ c = *src;
+ }
+ }
+ if (src == name) {
+ /*
+ * A '$' by itself, not a name reference. Push a "$" string.
+ */
+
+ objIndex = TclObjIndexForString("$", 1, /*allocStrRep*/ 1,
+ /*inHeap*/ 0, envPtr);
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ goto done;
+ }
+ nameChars = (src - name);
+ isArrayRef = (c == '(');
+ }
+
+ /*
+ * Now emit instructions to load the variable. First either push the
+ * name of the scalar or array, or determine its index in the array of
+ * local variables in a procedure frame. Push the name if we are not
+ * compiling a procedure body or if the name has namespace
+ * qualifiers ("::"s).
+ */
+
+ if (!isArrayRef) { /* scalar reference */
+ if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
+ savedChar = name[nameChars]; /* save char just after name */
+ name[nameChars] = '\0';
+ objIndex = TclObjIndexForString(name, nameChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ name[nameChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ maxDepth = 1;
+ } else {
+ localIndex = LookupCompiledLocal(name, nameChars,
+ /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
+ envPtr->procPtr);
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstUInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstUInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
+ }
+ maxDepth = 0;
+ } else {
+ savedChar = name[nameChars]; /* save char after name */
+ name[nameChars] = '\0';
+ objIndex = TclObjIndexForString(name, nameChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ name[nameChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
+ maxDepth = 1;
+ }
+ }
+ } else { /* array reference */
+ if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
+ savedChar = name[nameChars]; /* save char after name */
+ name[nameChars] = '\0';
+ objIndex = TclObjIndexForString(name, nameChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ name[nameChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ } else {
+ localIndex = LookupCompiledLocal(name, nameChars,
+ /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
+ envPtr->procPtr);
+ if (localIndex < 0) {
+ savedChar = name[nameChars]; /* save char after name */
+ name[nameChars] = '\0';
+ objIndex = TclObjIndexForString(name, nameChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ name[nameChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ }
+ }
+
+ /*
+ * Parse and push the array element. Perform substitutions on it,
+ * just as is done for quoted strings.
+ */
+
+ src++; /* advance over the '(' */
+ envPtr->pushSimpleWords = 1;
+ result = TclCompileQuotes(interp, src, lastChar, ')', flags,
+ envPtr);
+ src += envPtr->termOffset; /* advance beyond the terminating ) */
+ if (result != TCL_OK) {
+ char msg[200];
+ sprintf(msg, "\n (parsing index for array \"%.*s\")",
+ (nameChars > 100? 100 : nameChars), name);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ goto done;
+ }
+ maxDepth += envPtr->maxStackDepth;
+
+ /*
+ * Now emit the appropriate load instruction for the array element.
+ */
+
+ if (localIndex < 0) { /* a global or an unknown local */
+ TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
+ } else {
+ if (localIndex <= 255) {
+ TclEmitInstUInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
+ } else {
+ TclEmitInstUInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
+ }
+ }
+ }
+
+ done:
+ envPtr->termOffset = (src - string);
+ envPtr->wordIsSimple = 0;
+ envPtr->numSimpleWordChars = 0;
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileBreakCmd --
+ *
+ * Procedure called to compile the "break" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "break" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileBreakCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ register char *src = string;/* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int result = TCL_OK;
+
+ /*
+ * There should be no argument after the "break".
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"break\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+
+ /*
+ * Emit a break instruction.
+ */
+
+ TclEmitOpcode(INST_BREAK, envPtr);
+
+ done:
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = 0;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileCatchCmd --
+ *
+ * Procedure called to compile the "catch" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If compilation failed because the command is too
+ * complex for TclCompileCatchCmd, TCL_OUT_LINE_COMPILE is returned
+ * indicating that the catch command should be compiled "out of line"
+ * by emitting code to invoke its command procedure at runtime.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "catch" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ /* Points to structure describing procedure
+ * containing the catch cmd, else NULL. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ ArgInfo argInfo; /* Structure holding information about the
+ * start and end of each argument word. */
+ int range = -1; /* If we compile the catch command, the
+ * index for its catch range record in the
+ * ExceptionRange array. -1 if we are not
+ * compiling the command. */
+ char *name; /* If a var name appears for a scalar local
+ * to a procedure, this points to the name's
+ * 1st char and nameChars is its length. */
+ int nameChars; /* Length of the variable name, if any. */
+ int localIndex = -1; /* Index of the variable in the current
+ * procedure's array of local variables.
+ * Otherwise -1 if not in a procedure or
+ * the variable wasn't found. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null character
+ * during processing of words. */
+ JumpFixup jumpFixup; /* Used to emit the jump after the "no
+ * errors" epilogue code. */
+ int numWords, objIndex, jumpDist, result;
+ char *bodyStart, *bodyEnd;
+ Tcl_Obj *objPtr;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+
+ /*
+ * Scan the words of the command and record the start and finish of
+ * each argument word.
+ */
+
+ InitArgInfo(&argInfo);
+ result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
+ numWords = argInfo.numArgs; /* i.e., the # after the command name */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if ((numWords != 1) && (numWords != 2)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"catch command ?varName?\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * If a variable was specified and the catch command is at global level
+ * (not in a procedure), don't compile it inline: the payoff is
+ * too small.
+ */
+
+ if ((numWords == 2) && (procPtr == NULL)) {
+ result = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+
+ /*
+ * Make sure the variable name, if any, has no substitutions and just
+ * refers to a local scaler.
+ */
+
+ if (numWords == 2) {
+ char *firstChar = argInfo.startArray[1];
+ char *lastChar = argInfo.endArray[1];
+
+ if (*firstChar == '{') {
+ if (*lastChar != '}') {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-brace", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ firstChar++;
+ lastChar--;
+ }
+
+ nameChars = (lastChar - firstChar + 1);
+ if (nameChars > 0) {
+ char *p = firstChar;
+ while (p != lastChar) {
+ if (CHAR_TYPE(p, lastChar) != TCL_NORMAL) {
+ result = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+ if (*p == '(') {
+ if (*lastChar == ')') { /* we have an array element */
+ result = TCL_OUT_LINE_COMPILE;
+ goto done; /* only scalar loop vars for now */
+ }
+ }
+ p++;
+ }
+ }
+
+ name = firstChar;
+ localIndex = LookupCompiledLocal(name, nameChars,
+ /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR,
+ procPtr);
+ }
+
+ /*
+ *==== At this point we believe we can compile the catch command ====
+ */
+
+ /*
+ * Create and initialize a ExceptionRange record to hold information
+ * about this catch command.
+ */
+
+ envPtr->excRangeDepth++;
+ envPtr->maxExcRangeDepth =
+ TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
+ range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
+
+ /*
+ * Emit the instruction to mark the start of the catch command.
+ */
+
+ TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
+
+ /*
+ * Inline compile the catch's body word: the command it controls. Also
+ * register the body's starting PC offset and byte length in the
+ * ExceptionRange record.
+ */
+
+ envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
+
+ bodyStart = argInfo.startArray[0];
+ bodyEnd = argInfo.endArray[0];
+ savedChar = *(bodyEnd+1); /* save char after body */
+ *(bodyEnd+1) = '\0';
+ result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1),
+ flags, envPtr);
+ *(bodyEnd+1) = savedChar; /* restore the saved char */
+
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ char msg[60];
+ sprintf(msg, "\n (\"catch\" body line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ envPtr->excRangeArrayPtr[range].numCodeBytes =
+ TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
+
+ /*
+ * Now emit the "no errors" epilogue code for the catch. First, if a
+ * variable was specified, store the body's result into the
+ * variable; otherwise, just discard the body's result. Then push
+ * a "0" object as the catch command's "no error" TCL_OK result,
+ * and jump around the "error case" epilogue code.
+ */
+
+ if (localIndex != -1) {
+ if (localIndex <= 255) {
+ TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+ }
+ }
+ TclEmitOpcode(INST_POP, envPtr); /* pop the result */
+
+ objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0,
+ envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = 0;
+ objPtr->typePtr = &tclIntType;
+
+ TclEmitPush(objIndex, envPtr);
+ if (maxDepth == 0) {
+ maxDepth = 1; /* since we just pushed one object */
+ }
+
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+
+ /*
+ * Now emit the "error case" epilogue code. First, if a variable was
+ * specified, emit instructions to push the interpreter's object result
+ * and store it into the variable. Then emit an instruction to push the
+ * nonzero error result. Note that the initial PC offset here is the
+ * catch's error target.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
+ panic("TclCompileCatchCmd: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range].type);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
+
+ if (localIndex != -1) {
+ TclEmitOpcode(INST_PUSH_RESULT, envPtr);
+ if (localIndex <= 255) {
+ TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
+ } else {
+ TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
+ }
+ TclEmitOpcode(INST_POP, envPtr); /* pop the result */
+ }
+ TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
+
+ /*
+ * Now that we know the target of the jump after the "no errors"
+ * epilogue, update it with the correct distance. This is less
+ * than 127 bytes.
+ */
+
+ jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
+ panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
+ }
+
+ /*
+ * Emit the instruction to mark the end of the catch command.
+ */
+
+ TclEmitOpcode(INST_END_CATCH, envPtr);
+
+ done:
+ if (numWords == 0) {
+ envPtr->termOffset = 0;
+ } else {
+ envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ }
+ if (range != -1) { /* we compiled the catch command */
+ envPtr->excRangeDepth--;
+ }
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ envPtr->maxStackDepth = maxDepth;
+ FreeArgInfo(&argInfo);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileContinueCmd --
+ *
+ * Procedure called to compile the "continue" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "continue" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileContinueCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ register char *src = string;/* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int result = TCL_OK;
+
+ /*
+ * There should be no argument after the "continue".
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"continue\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+
+ /*
+ * Emit a continue instruction.
+ */
+
+ TclEmitOpcode(INST_CONTINUE, envPtr);
+
+ done:
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = 0;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileExprCmd --
+ *
+ * Procedure called to compile the "expr" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK
+ * unless there was an error while parsing string. If an error occurs
+ * then the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "expr" command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "expr" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ ArgInfo argInfo; /* Structure holding information about the
+ * start and end of each argument word. */
+ Tcl_DString buffer; /* Holds the concatenated expr command
+ * argument words. */
+ int firstWord; /* 1 if processing the first word; 0 if
+ * processing subsequent words. */
+ char *first, *last; /* Points to the first and last significant
+ * chars of the concatenated expression. */
+ int inlineCode; /* 1 if inline "optimistic" code is
+ * emitted for the expression; else 0. */
+ int range = -1; /* If we inline compile the concatenated
+ * expression, the index for its catch range
+ * record in the ExceptionRange array.
+ * Initialized to avoid compile warning. */
+ JumpFixup jumpFixup; /* Used to emit the "success" jump after
+ * the inline concat. expression's code. */
+ char savedChar; /* Holds the character termporarily replaced
+ * by a null character during compilation
+ * of the concatenated expression. */
+ int numWords, objIndex, i, result;
+ char *wordStart, *wordEnd, *p;
+ char c;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+ int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
+
+ /*
+ * Scan the words of the command and record the start and finish of
+ * each argument word.
+ */
+
+ InitArgInfo(&argInfo);
+ result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
+ numWords = argInfo.numArgs; /* i.e., the # after the command name */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if (numWords == 0) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"expr arg ?arg ...?\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * If there is a single argument word and it is enclosed in {}s, we may
+ * strip them off and safely compile the expr command into an inline
+ * sequence of instructions using TclCompileExpr. We know these
+ * instructions will have the right Tcl7.x expression semantics.
+ *
+ * Otherwise, if the word is not enclosed in {}s, or there are multiple
+ * words, we may need to call the expr command (Tcl_ExprObjCmd) at
+ * runtime. This recompiles the expression each time (typically) and so
+ * is slow. However, there are some circumstances where we can still
+ * compile inline instructions "optimistically" and check, during their
+ * execution, for double substitutions (these appear as nonnumeric
+ * operands). We check for any backslash or command substitutions. If
+ * none appear, and only variable substitutions are found, we generate
+ * inline instructions. If there is a compilation error, we must emit
+ * instructions that return the error at runtime, since this is when
+ * scripts in Tcl7.x would "see" the error.
+ *
+ * For now, if there are multiple words, or the single argument word is
+ * not in {}s, we concatenate the argument words and strip off any
+ * enclosing {}s or ""s. We call the expr command at runtime if
+ * either command or backslash substitutions appear (but not if
+ * only variable substitutions appear).
+ */
+
+ if (numWords == 1) {
+ wordStart = argInfo.startArray[0]; /* start of 1st arg word */
+ wordEnd = argInfo.endArray[0]; /* last char of 1st arg word */
+ if ((*wordStart == '{') && (*wordEnd == '}')) {
+ /*
+ * Simple case: a single argument word in {}'s.
+ */
+
+ *wordEnd = '\0'; /* temporarily replace the '}' by a null */
+ result = TclCompileExpr(interp, (wordStart + 1), wordEnd,
+ flags, envPtr);
+ *wordEnd = '}'; /* restore the '}' */
+
+ envPtr->termOffset = (wordEnd + 1) - string;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ FreeArgInfo(&argInfo);
+ return result;
+ }
+ }
+
+ /*
+ * There are multiple words or no braces around the single word.
+ * Concatenate the expression's argument words while stripping off
+ * any enclosing {}s or ""s.
+ */
+
+ Tcl_DStringInit(&buffer);
+ firstWord = 1;
+ for (i = 0; i < numWords; i++) {
+ wordStart = argInfo.startArray[i];
+ wordEnd = argInfo.endArray[i];
+ if (((*wordStart == '{') && (*wordEnd == '}'))
+ || ((*wordStart == '"') && (*wordEnd == '"'))) {
+ wordStart++;
+ wordEnd--;
+ }
+ if (!firstWord) {
+ Tcl_DStringAppend(&buffer, " ", 1);
+ }
+ firstWord = 0;
+ if (wordEnd >= wordStart) {
+ Tcl_DStringAppend(&buffer, wordStart, (wordEnd-wordStart+1));
+ }
+ }
+
+ /*
+ * Scan the concatenated expression's characters looking for any
+ * '['s or (for now) '\'s. If any are found, just call the expr cmd
+ * at runtime.
+ */
+
+ inlineCode = 1;
+ first = Tcl_DStringValue(&buffer);
+ last = first + (Tcl_DStringLength(&buffer) - 1);
+ for (p = first; p <= last; p++) {
+ c = *p;
+ if ((c == '[') || (c == '\\')) {
+ inlineCode = 0;
+ break;
+ }
+ }
+
+ if (inlineCode) {
+ /*
+ * Inline compile the concatenated expression inside a "catch"
+ * so that a runtime error will back off to a (slow) call on expr.
+ */
+
+ int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ int startRangeNext = envPtr->excRangeArrayNext;
+
+ /*
+ * Create a ExceptionRange record to hold information about the
+ * "catch" range for the expression's inline code. Also emit the
+ * instruction to mark the start of the range.
+ */
+
+ envPtr->excRangeDepth++;
+ envPtr->maxExcRangeDepth =
+ TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
+ range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
+ TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
+
+ /*
+ * Inline compile the concatenated expression.
+ */
+
+ envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
+ savedChar = *(last + 1);
+ *(last + 1) = '\0'; /* replace term. char with null */
+ result = TclCompileExpr(interp, first, last + 1, flags, envPtr);
+ *(last + 1) = savedChar; /* restore the saved char */
+
+ maxDepth = envPtr->maxStackDepth;
+ envPtr->excRangeArrayPtr[range].numCodeBytes =
+ TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
+
+ if ((envPtr->exprIsJustVarRef) || (result != TCL_OK)) {
+ /*
+ * We must call the expr command at runtime since the expression
+ * consisted of just a single variable reference (and a second
+ * round of substitutions might be needed) or there was a
+ * compilation error. Delete the inline code by backing up the
+ * code pc and catch index. Note that if there was a compilation
+ * error, we can't report the error yet since the expression
+ * might be valid after the second round of substitutions.
+ */
+
+ envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
+ envPtr->excRangeArrayNext = startRangeNext;
+ inlineCode = 0;
+ } else {
+ TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+ envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
+ TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */
+ }
+ }
+
+ /*
+ * Emit code for the (slow) call on the expr command at runtime.
+ * Generate code to concatenate the (already substituted once)
+ * expression words with a space between each word.
+ */
+
+ for (i = 0; i < numWords; i++) {
+ wordStart = argInfo.startArray[i];
+ wordEnd = argInfo.endArray[i];
+ savedChar = *(wordEnd + 1);
+ *(wordEnd + 1) = '\0'; /* replace term. char with null */
+ envPtr->pushSimpleWords = 1;
+ result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr);
+ *(wordEnd + 1) = savedChar; /* restore the saved char */
+ if (result != TCL_OK) {
+ break;
+ }
+ if (i != (numWords - 1)) {
+ objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1,
+ /*inHeap*/ 0, envPtr);
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
+ } else {
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ }
+ }
+ if (result == TCL_OK) {
+ int concatItems = 2*numWords - 1;
+ while (concatItems > 255) {
+ TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
+ concatItems -= 254; /* concat pushes 1 obj, the result */
+ }
+ if (concatItems > 1) {
+ TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr);
+ }
+ TclEmitOpcode(INST_EXPR_STK, envPtr);
+ }
+
+ /*
+ * If emitting inline code, update the target of the jump after
+ * that inline code.
+ */
+
+ if (inlineCode) {
+ int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
+ /*
+ * Update the inline expression code's catch ExceptionRange
+ * target since it, being after the jump, also moved down.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
+ panic("TclCompileExprCmd: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range].type);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+
+ envPtr->excRangeArrayPtr[range].catchOffset += 3;
+ }
+ }
+ Tcl_DStringFree(&buffer);
+
+ done:
+ if (numWords == 0) {
+ envPtr->termOffset = 0;
+ } else {
+ envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ }
+ if (range != -1) { /* we inline compiled the expr */
+ envPtr->excRangeDepth--;
+ }
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
+ envPtr->maxStackDepth = maxDepth;
+ FreeArgInfo(&argInfo);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileForCmd --
+ *
+ * Procedure called to compile the "for" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "for" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileForCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ ArgInfo argInfo; /* Structure holding information about the
+ * start and end of each argument word. */
+ int range1, range2; /* Indexes in the ExceptionRange array of
+ * the loop ranges for this loop: one for
+ * its body and one for its "next" cmd. */
+ JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
+ * jump after the "for" test when its target
+ * PC is determined. */
+ int jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist, objIndex;
+ unsigned char *jumpPc;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+ int numWords, result;
+
+ /*
+ * Scan the words of the command and record the start and finish of
+ * each argument word.
+ */
+
+ InitArgInfo(&argInfo);
+ result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
+ numWords = argInfo.numArgs; /* i.e., the # after the command name */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if (numWords != 4) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"for start test next command\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * If the test expression is enclosed in quotes (""s), don't compile
+ * the for inline. As a result of Tcl's two level substitution
+ * semantics for expressions, the expression might have a constant
+ * value that results in the loop never executing, or executing forever.
+ * Consider "set x 0; for {} "$x > 5" {incr x} {}": the loop body
+ * should never be executed.
+ */
+
+ if (*(argInfo.startArray[1]) == '"') {
+ result = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+
+ /*
+ * Create a ExceptionRange record for the for loop's body. This is used
+ * to implement break and continue commands inside the body.
+ * Then create a second ExceptionRange record for the "next" command in
+ * order to implement break (but not continue) inside it. The second,
+ * "next" ExceptionRange will always have a -1 continueOffset.
+ */
+
+ envPtr->excRangeDepth++;
+ envPtr->maxExcRangeDepth =
+ TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
+ range1 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
+ range2 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
+
+ /*
+ * Compile inline the next word: the initial command.
+ */
+
+ result = CompileCmdWordInline(interp, argInfo.startArray[0],
+ (argInfo.endArray[0] + 1), flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp, "\n (\"for\" initial command)", -1);
+ }
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+
+ /*
+ * Discard the start command's result.
+ */
+
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Compile the next word: the test expression.
+ */
+
+ testCodeOffset = TclCurrCodeOffset();
+ envPtr->pushSimpleWords = 1; /* process words normally */
+ result = CompileExprWord(interp, argInfo.startArray[1],
+ (argInfo.endArray[1] + 1), flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp, "\n (\"for\" test expression)", -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+
+ /*
+ * Emit the jump that terminates the for command if the test was
+ * false. We emit a one byte (relative) jump here, and replace it later
+ * with a four byte jump if the jump target is > 127 bytes away.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+
+ /*
+ * Compile the loop body word inline. Also register the loop body's
+ * starting PC offset and byte length in the its ExceptionRange record.
+ */
+
+ envPtr->excRangeArrayPtr[range1].codeOffset = TclCurrCodeOffset();
+ result = CompileCmdWordInline(interp, argInfo.startArray[3],
+ (argInfo.endArray[3] + 1), flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ char msg[60];
+ sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ envPtr->excRangeArrayPtr[range1].numCodeBytes =
+ (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range1].codeOffset);
+
+ /*
+ * Discard the loop body's result.
+ */
+
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Finally, compile the "next" subcommand word inline.
+ */
+
+ envPtr->excRangeArrayPtr[range1].continueOffset = TclCurrCodeOffset();
+ envPtr->excRangeArrayPtr[range2].codeOffset = TclCurrCodeOffset();
+ result = CompileCmdWordInline(interp, argInfo.startArray[2],
+ (argInfo.endArray[2] + 1), flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp, "\n (\"for\" loop-end command)", -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ envPtr->excRangeArrayPtr[range2].numCodeBytes =
+ TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range2].codeOffset;
+
+ /*
+ * Discard the "next" subcommand's result.
+ */
+
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Emit the unconditional jump back to the test at the top of the for
+ * loop. We generate a four byte jump if the distance to the test is
+ * greater than 120 bytes. This is conservative, and ensures that we
+ * won't have to replace this unconditional jump if we later need to
+ * replace the ifFalse jump with a four-byte jump.
+ */
+
+ jumpBackOffset = TclCurrCodeOffset();
+ jumpBackDist = (jumpBackOffset - testCodeOffset);
+#ifdef TCL_COMPILE_DEBUG
+ if (jumpBackDist > MAX_JUMP_DIST) {
+ fprintf(stderr, "\nTclCompileForCmd: bad distance %u for unconditional jump\n",
+ jumpBackDist);
+ panic("TclCompileForCmd: bad distance for unconditional jump");
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ if (jumpBackDist > 120) {
+ TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
+ }
+
+ /*
+ * Now that we know the target of the jumpFalse after the test, update
+ * it with the correct distance. If the distance is too great (more
+ * than 127 bytes), replace that jump with a four byte instruction and
+ * move the instructions after the jump down.
+ */
+
+ jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
+ /*
+ * Update the loop body's ExceptionRange record since it moved down:
+ * i.e., increment both its start and continue PC offsets. Also,
+ * update the "next" command's start PC offset in its ExceptionRange
+ * record since it also moved down.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range1].type != LOOP_EXCEPTION_RANGE) {
+ panic("TclCompileForCmd: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range1].type);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+ envPtr->excRangeArrayPtr[range1].codeOffset += 3;
+ envPtr->excRangeArrayPtr[range1].continueOffset += 3;
+ envPtr->excRangeArrayPtr[range2].codeOffset += 3;
+
+ /*
+ * Update the distance for the unconditional jump back to the test
+ * at the top of the loop since it moved down 3 bytes too.
+ */
+
+ jumpBackOffset += 3;
+ jumpPc = (envPtr->codeStart + jumpBackOffset);
+ if (jumpBackDist > 120) {
+ jumpBackDist += 3;
+ TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
+ jumpPc);
+ } else {
+ jumpBackDist += 3;
+ TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
+ jumpPc);
+ }
+ }
+
+ /*
+ * The current PC offset (after the loop's body and "next" subcommand)
+ * is the loop's break target.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range1].type != LOOP_EXCEPTION_RANGE) {
+ panic("TclCompileForCmd: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range1].type);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+ envPtr->excRangeArrayPtr[range1].breakOffset =
+ envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset();
+
+ /*
+ * Push an empty string object as the for command's result.
+ */
+
+ objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
+ envPtr);
+ TclEmitPush(objIndex, envPtr);
+ if (maxDepth == 0) {
+ maxDepth = 1; /* since we just pushed one object */
+ }
+
+ done:
+ if (numWords == 0) {
+ envPtr->termOffset = 0;
+ } else {
+ envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ }
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->excRangeDepth--;
+ FreeArgInfo(&argInfo);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileForeachCmd --
+ *
+ * Procedure called to compile the "foreach" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If complation failed because the command is too complex
+ * for TclCompileForeachCmd, TCL_OUT_LINE_COMPILE is returned
+ * indicating that the foreach command should be compiled "out of line"
+ * by emitting code to invoke its command procedure at runtime.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "while" command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "foreach" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ /* Points to structure describing procedure
+ * containing foreach command, else NULL. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ ArgInfo argInfo; /* Structure holding information about the
+ * start and end of each argument word. */
+ int numLists = 0; /* Count of variable (and value) lists. */
+ int range; /* Index in the ExceptionRange array of the
+ * ExceptionRange record for this loop. */
+ ForeachInfo *infoPtr; /* Points to the structure describing this
+ * foreach command. Stored in a AuxData
+ * record in the ByteCode. */
+ JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
+ * jump after test when its target PC is
+ * determined. */
+ char savedChar; /* Holds the char from string termporarily
+ * replaced by a null character during
+ * processing of argument words. */
+ int firstListTmp = -1; /* If we decide to compile this foreach
+ * command, this is the index or "slot
+ * number" for the first temp var allocated
+ * in the proc frame that holds a pointer to
+ * a value list. Initialized to avoid a
+ * compiler warning. */
+ int loopIterNumTmp; /* If we decide to compile this foreach
+ * command, the index for the temp var that
+ * holds the current iteration count. */
+ char *varListStart, *varListEnd, *valueListStart, *bodyStart, *bodyEnd;
+ unsigned char *jumpPc;
+ int jumpDist, jumpBackDist, jumpBackOffset;
+ int numWords, numVars, infoIndex, tmpIndex, objIndex, i, j, result;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+
+ /*
+ * We parse the variable list argument words and create two arrays:
+ * varcList[i] gives the number of variables in the i-th var list
+ * varvList[i] points to an array of the names in the i-th var list
+ * These are initially allocated on the stack, and are allocated on
+ * the heap if necessary.
+ */
+
+#define STATIC_VAR_LIST_SIZE 4
+ int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
+ char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
+
+ int *varcList = varcListStaticSpace;
+ char ***varvList = varvListStaticSpace;
+
+ /*
+ * If the foreach command is at global level (not in a procedure),
+ * don't compile it inline: the payoff is too small.
+ */
+
+ if (procPtr == NULL) {
+ return TCL_OUT_LINE_COMPILE;
+ }
+
+ /*
+ * Scan the words of the command and record the start and finish of
+ * each argument word.
+ */
+
+ InitArgInfo(&argInfo);
+ result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
+ numWords = argInfo.numArgs;
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if ((numWords < 3) || (numWords%2 != 1)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Initialize the varcList and varvList arrays; allocate heap storage,
+ * if necessary, for them. Also make sure the variable names
+ * have no substitutions: that they're just "var" or "var(elem)"
+ */
+
+ numLists = (numWords - 1)/2;
+ if (numLists > STATIC_VAR_LIST_SIZE) {
+ varcList = (int *) ckalloc(numLists * sizeof(int));
+ varvList = (char ***) ckalloc(numLists * sizeof(char **));
+ }
+ for (i = 0; i < numLists; i++) {
+ varcList[i] = 0;
+ varvList[i] = (char **) NULL;
+ }
+ for (i = 0; i < numLists; i++) {
+ /*
+ * Break each variable list into its component variables. If the
+ * lists is enclosed in {}s or ""s, strip them off first.
+ */
+
+ varListStart = argInfo.startArray[i*2];
+ varListEnd = argInfo.endArray[i*2];
+ if ((*varListStart == '{') || (*varListStart == '"')) {
+ if ((*varListEnd != '}') && (*varListEnd != '"')) {
+ Tcl_ResetResult(interp);
+ if (*varListStart == '"') {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-quote", -1);
+ } else {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-brace", -1);
+ }
+ result = TCL_ERROR;
+ goto done;
+ }
+ varListStart++;
+ varListEnd--;
+ }
+
+ /*
+ * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST.
+ */
+
+ savedChar = *(varListEnd+1); /* save char after var list */
+ *(varListEnd+1) = '\0';
+ result = Tcl_SplitList(interp, varListStart,
+ &varcList[i], &varvList[i]);
+ *(varListEnd+1) = savedChar; /* restore the saved char */
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * Check that each variable name has no substitutions and that
+ * it is a scalar name.
+ */
+
+ numVars = varcList[i];
+ for (j = 0; j < numVars; j++) {
+ char *varName = varvList[i][j];
+ char *p = varName;
+ while (*p != '\0') {
+ if (CHAR_TYPE(p, p+1) != TCL_NORMAL) {
+ result = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+ if (*p == '(') {
+ char *q = p;
+ do {
+ q++;
+ } while (*q != '\0');
+ q--;
+ if (*q == ')') { /* we have an array element */
+ result = TCL_OUT_LINE_COMPILE;
+ goto done; /* only scalar loop vars for now */
+ }
+ }
+ p++;
+ }
+ }
+ }
+
+ /*
+ *==== At this point we believe we can compile the foreach command ====
+ */
+
+ /*
+ * Create and initialize a ExceptionRange record to hold information
+ * about this loop. This is used to implement break and continue.
+ */
+
+ envPtr->excRangeDepth++;
+ envPtr->maxExcRangeDepth =
+ TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
+ range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
+
+ /*
+ * Reserve (numLists + 1) temporary variables:
+ * - numLists temps for each value list
+ * - a temp for the "next value" index into each value list
+ * At this time we don't try to reuse temporaries; if there are two
+ * nonoverlapping foreach loops, they don't share any temps.
+ */
+
+ for (i = 0; i < numLists; i++) {
+ tmpIndex = LookupCompiledLocal(NULL, /*nameChars*/ 0,
+ /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
+ if (i == 0) {
+ firstListTmp = tmpIndex;
+ }
+ }
+ loopIterNumTmp = LookupCompiledLocal(NULL, /*nameChars*/ 0,
+ /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
+
+ /*
+ * Create and initialize the ForeachInfo and ForeachVarList data
+ * structures describing this command. Then create a AuxData record
+ * pointing to the ForeachInfo structure in the compilation environment.
+ */
+
+ infoPtr = (ForeachInfo *) ckalloc((unsigned)
+ (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
+ infoPtr->numLists = numLists;
+ infoPtr->firstListTmp = firstListTmp;
+ infoPtr->loopIterNumTmp = loopIterNumTmp;
+ for (i = 0; i < numLists; i++) {
+ ForeachVarList *varListPtr;
+ numVars = varcList[i];
+ varListPtr = (ForeachVarList *) ckalloc((unsigned)
+ sizeof(ForeachVarList) + numVars*sizeof(int));
+ varListPtr->numVars = numVars;
+ for (j = 0; j < numVars; j++) {
+ char *varName = varvList[i][j];
+ int nameChars = strlen(varName);
+ varListPtr->varIndexes[j] = LookupCompiledLocal(varName,
+ nameChars, /*createIfNew*/ 1,
+ /*flagsIfCreated*/ VAR_SCALAR, procPtr);
+ }
+ infoPtr->varLists[i] = varListPtr;
+ }
+ infoIndex = TclCreateAuxData((ClientData) infoPtr,
+ DupForeachInfo, FreeForeachInfo, envPtr);
+
+ /*
+ * Emit code to store each value list into the associated temporary.
+ */
+
+ for (i = 0; i < numLists; i++) {
+ valueListStart = argInfo.startArray[2*i + 1];
+ envPtr->pushSimpleWords = 1;
+ result = CompileWord(interp, valueListStart, lastChar, flags,
+ envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+
+ tmpIndex = (firstListTmp + i);
+ if (tmpIndex <= 255) {
+ TclEmitInstUInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
+ } else {
+ TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
+ }
+ TclEmitOpcode(INST_POP, envPtr); /* no longer need list on the stk */
+ }
+
+ /*
+ * Emit the instruction to initialize the foreach loop's index temp var.
+ */
+
+ TclEmitInstUInt4(INST_FOREACH_START4, infoIndex, envPtr);
+
+ /*
+ * Emit the top of loop code that assigns each loop variable and checks
+ * whether to terminate the loop.
+ */
+
+ envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
+ TclEmitInstUInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
+
+ /*
+ * Emit the ifFalse jump that terminates the foreach if all value lists
+ * are exhausted. We emit a one byte (relative) jump here, and replace
+ * it later with a four byte jump if the jump target is more than
+ * 127 bytes away.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+
+ /*
+ * Compile the loop body word inline. Also register the loop body's
+ * starting PC offset and byte length in the ExceptionRange record.
+ */
+
+ bodyStart = argInfo.startArray[numWords - 1];
+ bodyEnd = argInfo.endArray[numWords - 1];
+ savedChar = *(bodyEnd+1); /* save char after body */
+ *(bodyEnd+1) = '\0';
+ envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
+ result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags,
+ envPtr);
+ *(bodyEnd+1) = savedChar; /* restore the saved char */
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ char msg[60];
+ sprintf(msg, "\n (\"foreach\" body line %d)",
+ interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ envPtr->excRangeArrayPtr[range].numCodeBytes =
+ TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
+
+ /*
+ * Discard the loop body's result.
+ */
+
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Emit the unconditional jump back to the test at the top of the
+ * loop. We generate a four byte jump if the distance to the to of
+ * the foreach is greater than 120 bytes. This is conservative and
+ * ensures that we won't have to replace this unconditional jump if
+ * we later need to replace the ifFalse jump with a four-byte jump.
+ */
+
+ jumpBackOffset = TclCurrCodeOffset();
+ jumpBackDist =
+ (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
+#ifdef TCL_COMPILE_DEBUG
+ if (jumpBackDist > MAX_JUMP_DIST) {
+ fprintf(stderr, "\nTclCompileForeachCmd: bad distance %u for unconditional jump\n", jumpBackDist);
+ panic("TclCompileForeachCmd: bad distance for unconditional jump");
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ if (jumpBackDist > 120) {
+ TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
+ }
+
+ /*
+ * Now that we know the target of the jumpFalse after the foreach_step
+ * test, update it with the correct distance. If the distance is too
+ * great (more than 127 bytes), replace that jump with a four byte
+ * instruction and move the instructions after the jump down.
+ */
+
+ jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
+ /*
+ * Update the loop body's starting PC offset since it moved down.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+ panic("TclCompileForeachCmd: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range].type);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ envPtr->excRangeArrayPtr[range].codeOffset += 3;
+
+ /*
+ * Update the distance for the unconditional jump back to the test
+ * at the top of the loop since it moved down 3 bytes too.
+ */
+
+ jumpBackOffset += 3;
+ jumpPc = (envPtr->codeStart + jumpBackOffset);
+ if (jumpBackDist > 120) {
+ jumpBackDist += 3;
+ TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
+ jumpPc);
+ } else {
+ jumpBackDist += 3;
+ TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
+ jumpPc);
+ }
+ }
+
+ /*
+ * The current PC offset (after the loop's body) is the loop's
+ * break target.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+ panic("TclCompileForeachCmd: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range].type);
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
+
+ /*
+ * Push an empty string object as the foreach command's result.
+ */
+
+ objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
+ envPtr);
+ TclEmitPush(objIndex, envPtr);
+ if (maxDepth == 0) {
+ maxDepth = 1; /* since we just pushed one object */
+ }
+
+ done:
+ for (i = 0; i < numLists; i++) {
+ if (varvList[i] != (char **) NULL) {
+ ckfree((char *) varvList[i]);
+ }
+ }
+ if (varcList != varcListStaticSpace) {
+ ckfree((char *) varcList);
+ ckfree((char *) varvList);
+ }
+ envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->excRangeDepth--;
+ FreeArgInfo(&argInfo);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * DupForeachInfo --
+ *
+ * This procedure duplicates a ForeachInfo structure created as
+ * auxiliary data during the compilation of a foreach command.
+ *
+ * Results:
+ * A pointer to a newly allocated copy of the existing ForeachInfo
+ * structure is returned.
+ *
+ * Side effects:
+ * Storage for the copied ForeachInfo record is allocated. If the
+ * original ForeachInfo structure pointed to any ForeachVarList
+ * records, these structures are also copied and pointers to them
+ * are stored in the new ForeachInfo record.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static ClientData
+DupForeachInfo(clientData)
+ ClientData clientData; /* The foreach command's compilation
+ * auxiliary data to duplicate. */
+{
+ register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
+ ForeachInfo *dupPtr;
+ register ForeachVarList *srcListPtr, *dupListPtr;
+ int numLists = srcPtr->numLists;
+ int numVars, i, j;
+
+ dupPtr = (ForeachInfo *) ckalloc((unsigned)
+ (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
+ dupPtr->numLists = numLists;
+ dupPtr->firstListTmp = srcPtr->firstListTmp;
+ dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp;
+
+ for (i = 0; i < numLists; i++) {
+ srcListPtr = srcPtr->varLists[i];
+ numVars = srcListPtr->numVars;
+ dupListPtr = (ForeachVarList *) ckalloc((unsigned)
+ sizeof(ForeachVarList) + numVars*sizeof(int));
+ dupListPtr->numVars = numVars;
+ for (j = 0; j < numVars; j++) {
+ dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
+ }
+ dupPtr->varLists[i] = dupListPtr;
+ }
+ return (ClientData) dupPtr;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeForeachInfo --
+ *
+ * Procedure to free a ForeachInfo structure created as auxiliary data
+ * during the compilation of a foreach command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Storage for the ForeachInfo structure pointed to by the ClientData
+ * argument is freed as is any ForeachVarList record pointed to by the
+ * ForeachInfo structure.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeForeachInfo(clientData)
+ ClientData clientData; /* The foreach command's compilation
+ * auxiliary data to free. */
+{
+ register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
+ register ForeachVarList *listPtr;
+ int numLists = infoPtr->numLists;
+ register int i;
+
+ for (i = 0; i < numLists; i++) {
+ listPtr = infoPtr->varLists[i];
+ ckfree((char *) listPtr);
+ }
+ ckfree((char *) infoPtr);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileIfCmd --
+ *
+ * Procedure called to compile the "if" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "if" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ register char *src = string;/* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ JumpFixupArray jumpFalseFixupArray;
+ /* Used to fix up the ifFalse jump after
+ * each "if"/"elseif" test when its target
+ * PC is determined. */
+ JumpFixupArray jumpEndFixupArray;
+ /* Used to fix up the unconditional jump
+ * after each "then" command to the end of
+ * the "if" when that PC is determined. */
+ char *testSrcStart;
+ int jumpDist, jumpFalseDist, jumpIndex, objIndex, j, result;
+ unsigned char *ifFalsePc;
+ unsigned char opCode;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+
+ /*
+ * Loop compiling "expr then body" clauses after an "if" or "elseif".
+ */
+
+ TclInitJumpFixupArray(&jumpFalseFixupArray);
+ TclInitJumpFixupArray(&jumpEndFixupArray);
+ while (1) {
+ /*
+ * At this point in the loop, we have an expression to test, either
+ * the main expression or an expression following an "elseif".
+ * The arguments after the expression must be "then" (optional) and
+ * a script to execute if the expression is true.
+ */
+
+ AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: no expression after \"if\" argument", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * Compile the "if"/"elseif" test expression.
+ */
+
+ testSrcStart = src;
+ envPtr->pushSimpleWords = 1; /* process words normally */
+ result = CompileExprWord(interp, src, lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (\"if\" test expression)", -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ src += envPtr->termOffset;
+
+ /*
+ * Emit the ifFalse jump around the "then" part if the test was
+ * false. We emit a one byte (relative) jump here, and replace it
+ * later with a four byte jump if the jump target is more than 127
+ * bytes away.
+ */
+
+ if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpFalseFixupArray);
+ }
+ jumpIndex = jumpFalseFixupArray.next;
+ jumpFalseFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
+ &(jumpFalseFixupArray.fixup[jumpIndex]));
+
+ /*
+ * Skip over the optional "then" before the then clause.
+ */
+
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ char buf[100];
+ sprintf(buf, "wrong # args: no script following \"%.20s\" argument", testSrcStart);
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ if ((*src == 't') && (strncmp(src, "then", 4) == 0)) {
+ type = CHAR_TYPE(src+4, lastChar);
+ if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
+ src += 4; /* skip over the "then" */
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: no script following \"then\" argument", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+ }
+
+ /*
+ * Compile the "then" command word inline.
+ */
+
+ result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp, "\n (\"if\" body script)", -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ src += envPtr->termOffset;
+
+ /*
+ * Emit an unconditional jump to the end of the "if" command. We
+ * emit a one byte jump here, and replace it later with a four byte
+ * jump if the jump target is more than 127 bytes away. Note that
+ * both the jumpFalseFixupArray and the jumpEndFixupArray are
+ * indexed by the same index, "jumpIndex".
+ */
+
+ if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
+ TclExpandJumpFixupArray(&jumpEndFixupArray);
+ }
+ jumpEndFixupArray.next++;
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
+ &(jumpEndFixupArray.fixup[jumpIndex]));
+
+ /*
+ * Now that we know the target of the jumpFalse after the if test,
+ * update it with the correct distance. We generate a four byte
+ * jump if the distance is greater than 120 bytes. This is
+ * conservative, and ensures that we won't have to replace this
+ * jump if we later also need to replace the preceeding
+ * unconditional jump to the end of the "if" with a four-byte jump.
+ */
+
+ jumpDist = (TclCurrCodeOffset() - jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
+ if (TclFixupForwardJump(envPtr,
+ &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
+ /*
+ * Adjust the code offset for the unconditional jump at the end
+ * of the last "then" clause.
+ */
+
+ jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
+ }
+
+ /*
+ * Check now for a "elseif" word. If we find one, keep looping.
+ */
+
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if ((type != TCL_COMMAND_END)
+ && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) {
+ type = CHAR_TYPE(src+6, lastChar);
+ if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
+ src += 6; /* skip over the "elseif" */
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: no expression after \"elseif\" argument", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ continue; /* continue the "expr then body" loop */
+ }
+ }
+ break; /* exit the loop */
+ } /* end of the "expr then body" loop */
+
+ /*
+ * No more "elseif expr then body" clauses. Check now for an "else"
+ * clause. If there is another word, we are at its start.
+ */
+
+ if (type != TCL_COMMAND_END) {
+ if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) {
+ type = CHAR_TYPE(src+4, lastChar);
+ if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
+ src += 4; /* skip over the "else" */
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: no script following \"else\" argument", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+ }
+
+ /*
+ * Compile the "else" command word inline.
+ */
+
+ result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp, "\n (\"if\" else script)", -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ src += envPtr->termOffset;
+
+ /*
+ * Skip over white space until the end of the command.
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+ } else {
+ /*
+ * The "if" command has no "else" clause: push an empty string
+ * object as its result.
+ */
+
+ objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
+ /*inHeap*/ 0, envPtr);
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = TclMax(1, maxDepth);
+ }
+
+ /*
+ * Now that we know the target of the unconditional jumps to the end of
+ * the "if" command, update them with the correct distance. If the
+ * distance is too great (> 127 bytes), replace the jump with a four
+ * byte instruction and move instructions after the jump down.
+ */
+
+ for (j = jumpEndFixupArray.next; j > 0; j--) {
+ jumpIndex = (j - 1); /* i.e. process the closest jump first */
+ jumpDist = (TclCurrCodeOffset() - jumpEndFixupArray.fixup[jumpIndex].codeOffset);
+ if (TclFixupForwardJump(envPtr,
+ &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
+ /*
+ * Adjust the jump distance for the "ifFalse" jump that
+ * immediately preceeds this jump. We've moved it's target
+ * (just after this unconditional jump) three bytes down.
+ */
+
+ ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
+ opCode = *ifFalsePc;
+ if (opCode == INST_JUMP_FALSE1) {
+ jumpFalseDist = TclGetInt1AtPc(ifFalsePc + 1);
+ jumpFalseDist += 3;
+ TclUpdateInt1AtPc(jumpFalseDist, (ifFalsePc + 1));
+ } else if (opCode == INST_JUMP_FALSE4) {
+ jumpFalseDist = TclGetInt4AtPc(ifFalsePc + 1);
+ jumpFalseDist += 3;
+ TclUpdateInt4AtPc(jumpFalseDist, (ifFalsePc + 1));
+ } else {
+ panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
+ }
+ }
+ }
+
+ /*
+ * Free the jumpFixupArray array if malloc'ed storage was used.
+ */
+
+ done:
+ TclFreeJumpFixupArray(&jumpFalseFixupArray);
+ TclFreeJumpFixupArray(&jumpEndFixupArray);
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileIncrCmd --
+ *
+ * Procedure called to compile the "incr" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while parsing string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "incr" command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "incr" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ /* Points to structure describing procedure
+ * containing incr command, else NULL. */
+ register char *src = string;
+ /* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int simpleVarName; /* 1 if name is just sequence of chars with
+ * an optional element name in parens. */
+ char *name = NULL; /* If simpleVarName, points to first char of
+ * variable name and nameChars is length.
+ * Otherwise NULL. */
+ char *elName = NULL; /* If simpleVarName, points to first char of
+ * element name and elNameChars is length.
+ * Otherwise NULL. */
+ int nameChars = 0; /* Length of the var name. Initialized to
+ * avoid a compiler warning. */
+ int elNameChars = 0; /* Length of array's element name, if any.
+ * Initialized to avoid a compiler
+ * warning. */
+ int incrementGiven; /* 1 if an increment amount was given. */
+ int isImmIncrValue = 0; /* 1 if increment amount is a literal
+ * integer in [-127..127]. */
+ int immIncrValue = 0; /* if isImmIncrValue is 1, the immediate
+ * integer value. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ int localIndex = -1; /* Index of the variable in the current
+ * procedure's array of local variables.
+ * Otherwise -1 if not in a procedure or
+ * the variable wasn't found. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null char
+ * during name processing. */
+ int objIndex; /* The object array index for a pushed
+ * object holding a name part. */
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+ char *p;
+ int i, result;
+
+ /*
+ * Parse the next word: the variable name. If it is "simple" (requires
+ * no substitutions at runtime), divide it up into a simple "name" plus
+ * an optional "elName". Otherwise, if not simple, just push the name.
+ */
+
+ AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ badArgs:
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"incr varName ?increment?\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ envPtr->pushSimpleWords = 0; /* we will process the varName */
+ result = CompileWord(interp, src, lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ simpleVarName = envPtr->wordIsSimple;
+ if (simpleVarName) {
+ name = src;
+ nameChars = envPtr->numSimpleWordChars;
+ if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
+ name++; /* advance over the " or { */
+ }
+ elName = NULL;
+ elNameChars = 0;
+ p = name;
+ for (i = 0; i < nameChars; i++) {
+ if (*p == '(') {
+ char *openParen = p;
+ p = (src + nameChars-1);
+ if (*p == ')') { /* last char is ')' => array reference */
+ nameChars = (openParen - name);
+ elName = openParen+1;
+ elNameChars = (p - elName);
+ }
+ break;
+ }
+ p++;
+ }
+ } else {
+ maxDepth = envPtr->maxStackDepth;
+ }
+ src += envPtr->termOffset;
+
+ /*
+ * See if there is a next word. If so, we are incrementing the variable
+ * by that value (which must be an integer).
+ */
+
+ incrementGiven = 0;
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ incrementGiven = (type != TCL_COMMAND_END);
+ }
+
+ /*
+ * Non-simple names have already been pushed. If this is a simple
+ * variable, either push its name (if a global or an unknown local
+ * variable) or look up the variable's local frame index. If a local is
+ * not found, push its name and do the lookup at runtime. If this is an
+ * array reference, also push the array element.
+ */
+
+ if (simpleVarName) {
+ if (procPtr == NULL) {
+ savedChar = name[nameChars]; /* save char after name */
+ name[nameChars] = '\0';
+ objIndex = TclObjIndexForString(name, nameChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ name[nameChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ } else {
+ localIndex = LookupCompiledLocal(name, nameChars,
+ /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
+ envPtr->procPtr);
+ if ((localIndex < 0) || (localIndex > 255)) {
+ if (localIndex > 255) { /* we'll push the name */
+ localIndex = -1;
+ }
+ savedChar = name[nameChars]; /* save char after name */
+ name[nameChars] = '\0';
+ objIndex = TclObjIndexForString(name, nameChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ name[nameChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ } else {
+ maxDepth = 0;
+ }
+ }
+
+ if (elName != NULL) {
+ /*
+ * Parse and push the array element's name. Perform
+ * substitutions on it, just as is done for quoted strings.
+ */
+
+ savedChar = elName[elNameChars]; /* save char after elName */
+ elName[elNameChars] = '\0';
+ envPtr->pushSimpleWords = 1;
+ result = TclCompileQuotes(interp, elName, elName+elNameChars,
+ 0, flags, envPtr);
+ elName[elNameChars] = savedChar; /* restore the saved char */
+ if (result != TCL_OK) {
+ char msg[200];
+ sprintf(msg, "\n (parsing index for array \"%.*s\")",
+ TclMin(nameChars, 100), name);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ goto done;
+ }
+ maxDepth += envPtr->maxStackDepth;
+ }
+ }
+
+ /*
+ * If an increment was given, push the new value.
+ */
+
+ if (incrementGiven) {
+ type = CHAR_TYPE(src, lastChar);
+ envPtr->pushSimpleWords = 0; /* we will handle simple words */
+ result = CompileWord(interp, src, lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp,
+ "\n (reading increment)", -1);
+ }
+ goto done;
+ }
+ if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
+ src++; /* advance over the " or { */
+ }
+ if (envPtr->wordIsSimple) {
+ /*
+ * See if the word represents an integer whose formatted
+ * representation is the same as the word (e.g., this is
+ * true for 123 and -1 but not for 00005). If so, just
+ * push an integer object.
+ */
+
+ int isCompilableInt = 0;
+ int numChars = envPtr->numSimpleWordChars;
+ char savedChar = src[numChars];
+ char buf[40];
+ Tcl_Obj *objPtr;
+ long n;
+
+ src[numChars] = '\0';
+ if (TclLooksLikeInt(src)) {
+ if (TclGetLong(interp, src, &n) == TCL_OK) {
+ if ((-127 <= n) && (n <= 127)) {
+ isCompilableInt = 1;
+ isImmIncrValue = 1;
+ immIncrValue = n;
+ } else {
+ TclFormatInt(buf, n);
+ if (strcmp(src, buf) == 0) {
+ isCompilableInt = 1;
+ isImmIncrValue = 0;
+ objIndex = TclObjIndexForString(src, numChars,
+ /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = n;
+ objPtr->typePtr = &tclIntType;
+
+ TclEmitPush(objIndex, envPtr);
+ maxDepth += 1;
+ }
+ }
+ }
+ }
+ if (!isCompilableInt) {
+ objIndex = TclObjIndexForString(src, numChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ TclEmitPush(objIndex, envPtr);
+ maxDepth += 1;
+ }
+ src[numChars] = savedChar; /* restore the saved char */
+ } else {
+ maxDepth += envPtr->maxStackDepth;
+ }
+ if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
+ src += (envPtr->termOffset - 1); /* already advanced 1 above */
+ } else {
+ src += envPtr->termOffset;
+ }
+ } else { /* no incr amount given so use 1 */
+ isImmIncrValue = 1;
+ immIncrValue = 1;
+ }
+
+ /*
+ * Now emit instructions to increment the variable.
+ */
+
+ if ((localIndex >= 0) && (localIndex > 255)) {
+ panic("TclCompileIncrCmd: bad localIndex %d\n", localIndex);
+ return TCL_ERROR;
+ }
+ if (simpleVarName) {
+ if (elName == NULL) { /* scalar */
+ if (localIndex >= 0) {
+ if (isImmIncrValue) {
+ TclEmitInstUInt1(INST_INCR_SCALAR1_IMM, localIndex,
+ envPtr);
+ TclEmitInt1(immIncrValue, envPtr);
+ } else {
+ TclEmitInstUInt1(INST_INCR_SCALAR1, localIndex, envPtr);
+ }
+ } else {
+ if (isImmIncrValue) {
+ TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immIncrValue,
+ envPtr);
+ } else {
+ TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
+ }
+ }
+ } else { /* array */
+ if (localIndex >= 0) {
+ if (isImmIncrValue) {
+ TclEmitInstUInt1(INST_INCR_ARRAY1_IMM, localIndex,
+ envPtr);
+ TclEmitInt1(immIncrValue, envPtr);
+ } else {
+ TclEmitInstUInt1(INST_INCR_ARRAY1, localIndex, envPtr);
+ }
+ } else {
+ if (isImmIncrValue) {
+ TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immIncrValue,
+ envPtr);
+ } else {
+ TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
+ }
+ }
+ }
+ } else { /* non-simple variable name */
+ if (isImmIncrValue) {
+ TclEmitInstInt1(INST_INCR_STK_IMM, immIncrValue, envPtr);
+ } else {
+ TclEmitOpcode(INST_INCR_STK, envPtr);
+ }
+ }
+
+ /*
+ * Skip over white space until the end of the command.
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ goto badArgs; /* too many arguments */
+ }
+ }
+
+ done:
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileSetCmd --
+ *
+ * Procedure called to compile the "set" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is normally TCL_OK
+ * unless there was an error while parsing string. If an error occurs
+ * then the interpreter's result contains a standard error message. If
+ * complation fails because the set command requires a second level of
+ * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
+ * set command should be compiled "out of line" by emitting code to
+ * invoke its command procedure (Tcl_SetCmd) at runtime.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the incr command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "set" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Proc *procPtr = envPtr->procPtr;
+ /* Points to structure describing procedure
+ * containing the set command, else NULL. */
+ ArgInfo argInfo; /* Structure holding information about the
+ * start and end of each argument word. */
+ int simpleVarName; /* 1 if name is just sequence of chars with
+ * an optional element name in parens. */
+ char *elName = NULL; /* If simpleVarName, points to first char of
+ * element name and elNameChars is length.
+ * Otherwise NULL. */
+ int isAssignment; /* 1 if assigning value to var, else 0. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ int localIndex = -1; /* Index of the variable in the current
+ * procedure's array of local variables.
+ * Otherwise -1 if not in a procedure, the
+ * name contains "::"s, or the variable
+ * wasn't found. */
+ char savedChar; /* Holds the character from string
+ * termporarily replaced by a null char
+ * during name processing. */
+ int objIndex = -1; /* The object array index for a pushed
+ * object holding a name part. Initialized
+ * to avoid a compiler warning. */
+ char *wordStart, *p;
+ int numWords, isCompilableInt, i, result;
+ Tcl_Obj *objPtr;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+
+ /*
+ * Scan the words of the command and record the start and finish of
+ * each argument word.
+ */
+
+ InitArgInfo(&argInfo);
+ result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
+ numWords = argInfo.numArgs; /* i.e., the # after the command name */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if ((numWords < 1) || (numWords > 2)) {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"set varName ?newValue?\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+ isAssignment = (numWords == 2);
+
+ /*
+ * Parse the next word: the variable name. If the name is enclosed in
+ * quotes or braces, we return TCL_OUT_LINE_COMPILE and call the set
+ * command procedure at runtime since this makes sure that a second
+ * round of substitutions is done properly.
+ */
+
+ wordStart = argInfo.startArray[0]; /* start of 1st arg word: varname */
+ if ((*wordStart == '{') || (*wordStart == '"')) {
+ result = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+
+ /*
+ * Check whether the name is "simple": requires no substitutions at
+ * runtime.
+ */
+
+ envPtr->pushSimpleWords = 0; /* we will process the varName */
+ result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1,
+ flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ simpleVarName = envPtr->wordIsSimple;
+
+ if (!simpleVarName) {
+ /*
+ * The name isn't simple. CompileWord already pushed it.
+ */
+
+ maxDepth = envPtr->maxStackDepth;
+ } else {
+ char *name; /* If simpleVarName, points to first char of
+ * variable name and nameChars is length.
+ * Otherwise NULL. */
+ int nameChars; /* Length of the var name. */
+ int nameHasNsSeparators = 0;
+ /* Set 1 if name contains "::"s. */
+ int elNameChars; /* Length of array's element name if any. */
+
+ /*
+ * A simple name. First divide it up into "name" plus "elName"
+ * for an array element name, if any.
+ */
+
+ name = wordStart;
+ nameChars = envPtr->numSimpleWordChars;
+ elName = NULL;
+ elNameChars = 0;
+
+ p = name;
+ for (i = 0; i < nameChars; i++) {
+ if (*p == '(') {
+ char *openParen = p;
+ p = (name + nameChars-1);
+ if (*p == ')') { /* last char is ')' => array reference */
+ nameChars = (openParen - name);
+ elName = openParen+1;
+ elNameChars = (p - elName);
+ }
+ break;
+ }
+ p++;
+ }
+
+ /*
+ * Determine if name has any namespace separators (::'s).
+ */
+
+ p = name;
+ for (i = 0; i < nameChars; i++) {
+ if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
+ nameHasNsSeparators = 1;
+ break;
+ }
+ p++;
+ }
+
+ /*
+ * Now either push the name or determine its index in the array of
+ * local variables in a procedure frame. Note that if we are
+ * compiling a procedure the variable must be local unless its
+ * name has namespace separators ("::"s). Note also that global
+ * variables are implemented by a local variable that "points" to
+ * the real global. There are two cases:
+ * 1) We are not compiling a procedure body. Push the global
+ * variable's name and do the lookup at runtime.
+ * 2) We are compiling a procedure and the name has "::"s.
+ * Push the namespace variable's name and do the lookup at
+ * runtime.
+ * 3) We are compiling a procedure and the name has no "::"s.
+ * If the variable has already been allocated an local index,
+ * just look it up. If the variable is unknown and we are
+ * doing an assignment, allocate a new index. Otherwise,
+ * push the name and try to do the lookup at runtime.
+ */
+
+ if ((procPtr == NULL) || nameHasNsSeparators) {
+ savedChar = name[nameChars]; /* save char after name */
+ name[nameChars] = '\0';
+ objIndex = TclObjIndexForString(name, nameChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ name[nameChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ } else {
+ localIndex = LookupCompiledLocal(name, nameChars,
+ /*createIfNew*/ isAssignment,
+ /*flagsIfCreated*/
+ ((elName == NULL)? VAR_SCALAR : VAR_ARRAY),
+ envPtr->procPtr);
+ if (localIndex >= 0) {
+ maxDepth = 0;
+ } else {
+ savedChar = name[nameChars]; /* save char after name */
+ name[nameChars] = '\0';
+ objIndex = TclObjIndexForString(name, nameChars,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ name[nameChars] = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth = 1;
+ }
+ }
+
+ /*
+ * If we are dealing with a reference to an array element, push the
+ * array element. Perform substitutions on it, just as is done
+ * for quoted strings.
+ */
+
+ if (elName != NULL) {
+ savedChar = elName[elNameChars]; /* save char after elName */
+ elName[elNameChars] = '\0';
+ envPtr->pushSimpleWords = 1;
+ result = TclCompileQuotes(interp, elName, elName+elNameChars,
+ 0, flags, envPtr);
+ elName[elNameChars] = savedChar; /* restore the saved char */
+ if (result != TCL_OK) {
+ char msg[200];
+ sprintf(msg, "\n (parsing index for array \"%.*s\")",
+ TclMin(nameChars, 100), name);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ goto done;
+ }
+ maxDepth += envPtr->maxStackDepth;
+ }
+ }
+
+ /*
+ * If we are doing an assignment, push the new value.
+ */
+
+ if (isAssignment) {
+ wordStart = argInfo.startArray[1]; /* start of 2nd arg word */
+ envPtr->pushSimpleWords = 0; /* we will handle simple words */
+ result = CompileWord(interp, wordStart, argInfo.endArray[1] + 1,
+ flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ if (!envPtr->wordIsSimple) {
+ /*
+ * The value isn't simple. CompileWord already pushed it.
+ */
+
+ maxDepth += envPtr->maxStackDepth;
+ } else {
+ /*
+ * The value is simple. See if the word represents an integer
+ * whose formatted representation is the same as the word (e.g.,
+ * this is true for 123 and -1 but not for 00005). If so, just
+ * push an integer object.
+ */
+
+ char buf[40];
+ long n;
+
+ p = wordStart;
+ if ((*wordStart == '"') || (*wordStart == '{')) {
+ p++; /* advance over the " or { */
+ }
+ savedChar = p[envPtr->numSimpleWordChars];
+ p[envPtr->numSimpleWordChars] = '\0';
+ isCompilableInt = 0;
+ if (TclLooksLikeInt(p)) {
+ if (TclGetLong(interp, p, &n) == TCL_OK) {
+ TclFormatInt(buf, n);
+ if (strcmp(p, buf) == 0) {
+ isCompilableInt = 1;
+ objIndex = TclObjIndexForString(p,
+ envPtr->numSimpleWordChars,
+ /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
+ objPtr = envPtr->objArrayPtr[objIndex];
+
+ Tcl_InvalidateStringRep(objPtr);
+ objPtr->internalRep.longValue = n;
+ objPtr->typePtr = &tclIntType;
+ }
+ }
+ }
+ if (!isCompilableInt) {
+ objIndex = TclObjIndexForString(p,
+ envPtr->numSimpleWordChars, /*allocStrRep*/ 1,
+ /*inHeap*/ 0, envPtr);
+ }
+ p[envPtr->numSimpleWordChars] = savedChar; /* restore char */
+ TclEmitPush(objIndex, envPtr);
+ maxDepth += 1;
+ }
+ }
+
+ /*
+ * Now emit instructions to set/retrieve the variable.
+ */
+
+ if (simpleVarName) {
+ if (elName == NULL) { /* scalar */
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstUInt1((isAssignment?
+ INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
+ localIndex, envPtr);
+ } else {
+ TclEmitInstUInt4((isAssignment?
+ INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
+ localIndex, envPtr);
+ }
+ } else {
+ TclEmitOpcode((isAssignment?
+ INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
+ envPtr);
+ }
+ } else { /* array */
+ if (localIndex >= 0) {
+ if (localIndex <= 255) {
+ TclEmitInstUInt1((isAssignment?
+ INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
+ localIndex, envPtr);
+ } else {
+ TclEmitInstUInt4((isAssignment?
+ INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
+ localIndex, envPtr);
+ }
+ } else {
+ TclEmitOpcode((isAssignment?
+ INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),
+ envPtr);
+ }
+ }
+ } else { /* non-simple variable name */
+ TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
+ }
+
+ done:
+ if (numWords == 0) {
+ envPtr->termOffset = 0;
+ } else {
+ envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
+ }
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ envPtr->maxStackDepth = maxDepth;
+ FreeArgInfo(&argInfo);
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCompileWhileCmd --
+ *
+ * Procedure called to compile the "while" command.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK if
+ * compilation was successful. If an error occurs then the
+ * interpreter's result contains a standard error message and TCL_ERROR
+ * is returned. If compilation failed because the command is too
+ * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
+ * indicating that the while command should be compiled "out of line"
+ * by emitting code to invoke its command procedure at runtime.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "while" command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the "while" command
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ register char *src = string;/* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ int range; /* Index in the ExceptionRange array of the
+ * ExceptionRange record for this loop. */
+ JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
+ * jump after test when its target PC is
+ * determined. */
+ unsigned char *jumpPc;
+ int jumpDist, jumpBackDist, jumpBackOffset, objIndex, result;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+
+ envPtr->excRangeDepth++;
+ envPtr->maxExcRangeDepth =
+ TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
+
+ /*
+ * Create and initialize a ExceptionRange record to hold information
+ * about this loop. This is used to implement break and continue.
+ */
+
+ range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
+ envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
+
+ AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ badArgs:
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "wrong # args: should be \"while test command\"", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * If the test expression is enclosed in quotes (""s), don't compile
+ * the while inline. As a result of Tcl's two level substitution
+ * semantics for expressions, the expression might have a constant
+ * value that results in the loop never executing, or executing forever.
+ * Consider "set x 0; while "$x < 5" {incr x}": the loop body should
+ * never be executed.
+ */
+
+ if (*src == '"') {
+ result = TCL_OUT_LINE_COMPILE;
+ goto done;
+ }
+
+ /*
+ * Compile the next word: the test expression.
+ */
+
+ envPtr->pushSimpleWords = 1; /* process words normally */
+ result = CompileExprWord(interp, src, lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ Tcl_AddObjErrorInfo(interp, "\n (\"while\" test expression)", -1);
+ }
+ goto done;
+ }
+ maxDepth = envPtr->maxStackDepth;
+ src += envPtr->termOffset;
+
+ /*
+ * Emit the ifFalse jump that terminates the while if the test was
+ * false. We emit a one byte (relative) jump here, and replace it
+ * later with a four byte jump if the jump target is more than
+ * 127 bytes away.
+ */
+
+ TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
+
+ /*
+ * Compile the loop body word inline. Also register the loop body's
+ * starting PC offset and byte length in the its ExceptionRange record.
+ */
+
+ AdvanceToNextWord(src, envPtr); /* make sure there is a next word */
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ goto badArgs;
+ }
+
+ envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
+ result = CompileCmdWordInline(interp, src, lastChar,
+ flags, envPtr);
+ if (result != TCL_OK) {
+ if (result == TCL_ERROR) {
+ char msg[60];
+ sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine);
+ Tcl_AddObjErrorInfo(interp, msg, -1);
+ }
+ goto done;
+ }
+ maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
+ src += envPtr->termOffset;
+ envPtr->excRangeArrayPtr[range].numCodeBytes =
+ (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset);
+
+ /*
+ * Discard the loop body's result.
+ */
+
+ TclEmitOpcode(INST_POP, envPtr);
+
+ /*
+ * Emit the unconditional jump back to the test at the top of the
+ * loop. We generate a four byte jump if the distance to the while's
+ * test is greater than 120 bytes. This is conservative, and ensures
+ * that we won't have to replace this unconditional jump if we later
+ * need to replace the ifFalse jump with a four-byte jump.
+ */
+
+ jumpBackOffset = TclCurrCodeOffset();
+ jumpBackDist =
+ (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
+#ifdef TCL_COMPILE_DEBUG
+ if (jumpBackDist > MAX_JUMP_DIST) {
+ fprintf(stderr, "\nTclCompileWhileCmd: bad distance %u for unconditional jump\n", jumpBackDist);
+ panic("TclCompileWhileCmd: bad distance for unconditional jump");
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+ if (jumpBackDist > 120) {
+ TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
+ } else {
+ TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
+ }
+
+ /*
+ * Now that we know the target of the jumpFalse after the test, update
+ * it with the correct distance. If the distance is too great (more
+ * than 127 bytes), replace that jump with a four byte instruction and
+ * move the instructions after the jump down.
+ */
+
+ jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
+ /*
+ * Update the loop body's starting PC offset since it moved down.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+ panic("TclCompileWhileCmd: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range].type);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+ envPtr->excRangeArrayPtr[range].codeOffset += 3;
+
+ /*
+ * Update the distance for the unconditional jump back to the test
+ * at the top of the loop since it moved down 3 bytes too.
+ */
+
+ jumpBackOffset += 3;
+ jumpPc = (envPtr->codeStart + jumpBackOffset);
+ if (jumpBackDist > 120) {
+ jumpBackDist += 3;
+ TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
+ jumpPc);
+ } else {
+ jumpBackDist += 3;
+ TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
+ jumpPc);
+ }
+ }
+
+ /*
+ * The current PC offset (after the loop's body) is the loop's
+ * break target.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range].type != LOOP_EXCEPTION_RANGE) {
+ panic("TclCompileWhileCmd: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range].type);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+ envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
+
+ /*
+ * Push an empty string object as the while command's result.
+ */
+
+ objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
+ envPtr);
+ TclEmitPush(objIndex, envPtr);
+ if (maxDepth == 0) {
+ maxDepth = 1; /* since we just pushed one object */
+ }
+
+ /*
+ * Skip over white space until the end of the command.
+ */
+
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type != TCL_COMMAND_END) {
+ goto badArgs; /* too many arguments */
+ }
+ }
+
+ done:
+ envPtr->termOffset = (src - string);
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->excRangeDepth--;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileExprWord --
+ *
+ * Procedure that compiles a Tcl expression in a command word.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while compiling string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the "expr" word.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to evaluate the expression word
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileExprWord(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ register char *src = string;/* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute the expression. */
+ int nestedCmd = (flags & TCL_BRACKET_TERM);
+ /* 1 if script being compiled is a nested
+ * command and is terminated by a ']';
+ * otherwise 0. */
+ char *first, *last; /* Points to the first and last significant
+ * characters of the word. */
+ char savedChar; /* Holds the character termporarily replaced
+ * by a null character during compilation
+ * of the expression. */
+ int inlineCode; /* 1 if inline "optimistic" code is
+ * emitted for the expression; else 0. */
+ int range = -1; /* If we inline compile an un-{}'d
+ * expression, the index for its catch range
+ * record in the ExceptionRange array.
+ * Initialized to avoid compile warning. */
+ JumpFixup jumpFixup; /* Used to emit the "success" jump after
+ * the inline expression code. */
+ char *p;
+ char c;
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+ int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
+ int numChars, result;
+
+ /*
+ * Skip over leading white space.
+ */
+
+ AdvanceToNextWord(src, envPtr);
+ src += envPtr->termOffset;
+ type = CHAR_TYPE(src, lastChar);
+ if (type == TCL_COMMAND_END) {
+ badArgs:
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "malformed expression word", -1);
+ result = TCL_ERROR;
+ goto done;
+ }
+
+ /*
+ * If the word is enclosed in {}s, we may strip them off and safely
+ * compile the expression into an inline sequence of instructions using
+ * TclCompileExpr. We know these instructions will have the right Tcl7.x
+ * expression semantics.
+ *
+ * Otherwise, if the word is not enclosed in {}s, we may need to call
+ * the expr command (Tcl_ExprObjCmd) at runtime. This recompiles the
+ * expression each time (typically) and so is slow. However, there are
+ * some circumstances where we can still compile inline instructions
+ * "optimistically" and check, during their execution, for double
+ * substitutions (these appear as nonnumeric operands). We check for any
+ * backslash or command substitutions. If none appear, and only variable
+ * substitutions are found, we generate inline instructions.
+ *
+ * For now, if the expression is not enclosed in {}s, we call the expr
+ * command at runtime if either command or backslash substitutions
+ * appear (but not if only variable substitutions appear).
+ */
+
+ if (*src == '{') {
+ /*
+ * Inline compile the expression inside {}s.
+ */
+
+ first = src+1;
+ src = TclWordEnd(src, lastChar, nestedCmd, NULL);
+ if (*src == 0) { /* word doesn't end properly. */
+ goto badArgs;
+ }
+ if (*src != '}') {
+ goto badArgs;
+ }
+ last = (src-1);
+
+ numChars = (last - first + 1);
+ savedChar = first[numChars];
+ first[numChars] = '\0'; /* replace term. char with null */
+ result = TclCompileExpr(interp, first, first+numChars,
+ flags, envPtr);
+ first[numChars] = savedChar; /* restore the saved char */
+
+ src++; /* advance src after terminating '}' */
+ maxDepth = envPtr->maxStackDepth;
+ } else {
+ /*
+ * No braces. If the expression is enclosed in '"'s, call the expr
+ * cmd at runtime. Otherwise, scan the word's characters looking for
+ * any '['s or (for now) '\'s. If any are found, just call expr cmd
+ * at runtime.
+ */
+
+ first = src;
+ last = TclWordEnd(first, lastChar, nestedCmd, NULL);
+ if (*last == 0) { /* word doesn't end properly. */
+ src = last;
+ goto badArgs;
+ }
+
+ inlineCode = 1;
+ if ((*first == '"') && (*last == '"')) {
+ inlineCode = 0;
+ } else {
+ for (p = first; p <= last; p++) {
+ c = *p;
+ if ((c == '[') || (c == '\\')) {
+ inlineCode = 0;
+ break;
+ }
+ }
+ }
+
+ if (inlineCode) {
+ /*
+ * Inline compile the expression inside a "catch" so that a
+ * runtime error will back off to make a (slow) call on expr.
+ */
+
+ int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
+ int startRangeNext = envPtr->excRangeArrayNext;
+
+ /*
+ * Create a ExceptionRange record to hold information about
+ * the "catch" range for the expression's inline code. Also
+ * emit the instruction to mark the start of the range.
+ */
+
+ envPtr->excRangeDepth++;
+ envPtr->maxExcRangeDepth =
+ TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
+ range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
+ TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
+
+ /*
+ * Inline compile the expression.
+ */
+
+ envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
+ numChars = (last - first + 1);
+ savedChar = first[numChars];
+ first[numChars] = '\0'; /* replace term. char with null */
+ result = TclCompileExpr(interp, first, first + numChars,
+ flags, envPtr);
+ first[numChars] = savedChar; /* restore the saved char */
+
+ envPtr->excRangeArrayPtr[range].numCodeBytes =
+ TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
+
+ if ((envPtr->exprIsJustVarRef) || (result != TCL_OK)) {
+ /*
+ * We must call the expr command at runtime since the
+ * expression consisted of just a single variable reference
+ * (and a second round of substitutions might be needed) or
+ * there was a compilation error. Delete the inline code by
+ * backing up the code pc and catch index. Note that if
+ * there was a compilation error, we can't report the error
+ * yet since the expression might be valid after the second
+ * round of substitutions.
+ */
+
+ envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
+ envPtr->excRangeArrayNext = startRangeNext;
+ inlineCode = 0;
+ } else {
+ TclEmitOpcode(INST_END_CATCH, envPtr);
+ TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
+ envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
+ }
+ }
+
+ /*
+ * Arrange to call expr at runtime with the (already substituted
+ * once) expression word on the stack.
+ */
+
+ envPtr->pushSimpleWords = 1;
+ result = CompileWord(interp, first, lastChar, flags, envPtr);
+ src += envPtr->termOffset;
+ maxDepth = envPtr->maxStackDepth;
+ if (result == TCL_OK) {
+ TclEmitOpcode(INST_EXPR_STK, envPtr);
+ }
+
+ /*
+ * If emitting inline code for this non-{}'d expression, update
+ * the target of the jump after that inline code.
+ */
+
+ if (inlineCode) {
+ int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
+ if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
+ /*
+ * Update the inline expression code's catch ExceptionRange
+ * target since it, being after the jump, also moved down.
+ */
+
+#ifdef TCL_COMPILE_DEBUG
+ if (envPtr->excRangeArrayPtr[range].type != CATCH_EXCEPTION_RANGE) {
+ panic("CompileExprWord: bad body ExceptionRange type %d\n",
+ envPtr->excRangeArrayPtr[range].type);
+ }
+#endif /* TCL_COMPILE_DEBUG */
+
+ envPtr->excRangeArrayPtr[range].catchOffset += 3;
+ }
+ }
+ } /* if expression isn't in {}s */
+
+ done:
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CompileCmdWordInline --
+ *
+ * Procedure that compiles a Tcl command word inline. If the word is
+ * enclosed in quotes or braces, we call TclCompileString to compile it
+ * after stripping them off. Otherwise, we normally push the word's
+ * value and call eval at runtime, but if the word is just a sequence
+ * of alphanumeric characters, we emit an invoke instruction
+ * directly. This procedure assumes that string points to the start of
+ * the word to compile.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while compiling string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * envPtr->termOffset is filled in with the offset of the character in
+ * "string" just after the last one successfully processed.
+ *
+ * envPtr->maxStackDepth is updated with the maximum number of stack
+ * elements needed to execute the command.
+ *
+ * Side effects:
+ * Instructions are added to envPtr to execute the command word
+ * at runtime.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source string to compile. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ Interp *iPtr = (Interp *) interp;
+ register char *src = string;/* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int maxDepth = 0; /* Maximum number of stack elements needed
+ * to execute cmd. */
+ char *termPtr; /* Points to char that terminated braced
+ * string. */
+ char savedChar; /* Holds the character termporarily replaced
+ * by a null character during compilation
+ * of the command. */
+ int savePushSimpleWords = envPtr->pushSimpleWords;
+ int objIndex;
+ int result = TCL_OK;
+ register char c;
+
+ type = CHAR_TYPE(src, lastChar);
+ if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
+ src++; /* advance over the " or { */
+ envPtr->pushSimpleWords = 0; /* we process a simple word below */
+ if (type == TCL_QUOTE) {
+ result = TclCompileQuotes(interp, src, lastChar,
+ '"', flags, envPtr);
+ } else {
+ result = CompileBraces(interp, src, lastChar, flags, envPtr);
+ }
+ if (result != TCL_OK) {
+ goto done;
+ }
+
+ /*
+ * Make sure the terminating character is the end of word.
+ */
+
+ termPtr = (src + envPtr->termOffset);
+ c = *termPtr;
+ if ((c == '\\') && (*(termPtr+1) == '\n')) {
+ /*
+ * Line is continued on next line; the backslash-newline turns
+ * into space, which terminates the word.
+ */
+ } else {
+ type = CHAR_TYPE(termPtr, lastChar);
+ if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
+ Tcl_ResetResult(interp);
+ if (*(src-1) == '"') {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-quote", -1);
+ } else {
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "extra characters after close-brace", -1);
+ }
+ result = TCL_ERROR;
+ goto done;
+ }
+ }
+
+ if (envPtr->wordIsSimple) {
+ /*
+ * A simple word enclosed in "" or {}s. Call TclCompileString to
+ * compile it inline. Add a null character after the end of the
+ * quoted or braced string: i.e., at the " or }. Turn the
+ * flag bit TCL_BRACKET_TERM off since the recursively
+ * compiled subcommand is now terminated by a null character.
+ */
+ char *closeCharPos = (termPtr - 1);
+
+ savedChar = *closeCharPos;
+ *closeCharPos = '\0';
+ result = TclCompileString(interp, src, closeCharPos,
+ (flags & ~TCL_BRACKET_TERM), envPtr);
+ *closeCharPos = savedChar; /* restore the saved char */
+ if (result != TCL_OK) {
+ goto done;
+ }
+ } else {
+ /*
+ * The braced string contained a backslash-newline. Call eval
+ * at runtime.
+ */
+ TclEmitOpcode(INST_EVAL_STK, envPtr);
+ }
+ src = termPtr;
+ maxDepth = envPtr->maxStackDepth;
+ } else {
+ /*
+ * Not a braced or quoted string. We normally push the word's
+ * value and call eval at runtime. However, if the word is just
+ * a sequence of alphanumeric characters, we call its compile
+ * procedure, if any, or otherwise just emit an invoke instruction.
+ */
+
+ char *p = src;
+ c = *p;
+ while (isalnum(UCHAR(c)) || (c == '_')) {
+ p++;
+ c = *p;
+ }
+ type = CHAR_TYPE(p, lastChar);
+ if ((p > src) && (type == TCL_COMMAND_END)) {
+ /*
+ * Look for a compile procedure and call it. Otherwise emit an
+ * invoke instruction to call the command at runtime.
+ */
+
+ Tcl_Command cmd;
+ Command *cmdPtr = NULL;
+ int wasCompiled = 0; /* set 1 if word has compile proc. */
+
+ savedChar = *p;
+ *p = '\0';
+
+ cmd = Tcl_FindCommand(interp, src, (Tcl_Namespace *) NULL,
+ /*flags*/ 0);
+ if (cmd != (Tcl_Command) NULL) {
+ cmdPtr = (Command *) cmd;
+ }
+ if (cmdPtr != NULL && cmdPtr->compileProc != NULL) {
+ *p = savedChar; /* restore the saved char */
+ src = p;
+ iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
+ | ERROR_CODE_SET);
+ result = (*(cmdPtr->compileProc))(interp, src, lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ wasCompiled = 1;
+ src += envPtr->termOffset;
+ maxDepth = envPtr->maxStackDepth;
+ }
+ if (!wasCompiled) {
+ objIndex = TclObjIndexForString(src, p-src,
+ /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
+ *p = savedChar; /* restore the saved char */
+ TclEmitPush(objIndex, envPtr);
+ TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr);
+ src = p;
+ maxDepth = 1;
+ }
+ } else {
+ /*
+ * Push the word and call eval at runtime.
+ */
+
+ envPtr->pushSimpleWords = 1; /* process words normally */
+ result = CompileWord(interp, src, lastChar, flags, envPtr);
+ if (result != TCL_OK) {
+ goto done;
+ }
+ TclEmitOpcode(INST_EVAL_STK, envPtr);
+ src += envPtr->termOffset;
+ maxDepth = envPtr->maxStackDepth;
+ }
+ }
+
+ done:
+ envPtr->termOffset = (src - string);
+ envPtr->maxStackDepth = maxDepth;
+ envPtr->pushSimpleWords = savePushSimpleWords;
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * LookupCompiledLocal --
+ *
+ * This procedure is called at compile time to look up and optionally
+ * allocate an entry ("slot") for a variable in a procedure's array of
+ * local variables. If the variable's name is NULL, a new temporary
+ * variable is always created. (Such temporary variables can only be
+ * referenced using their slot index.)
+ *
+ * Results:
+ * If createIfNew is 0 (false) 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 createIfNew 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 createIfNew is 1 and
+ * the variable is unknown, or if the name is NULL.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
+ register char *name; /* Points to first character of the name of
+ * a scalar or array variable. If NULL, a
+ * temporary var should be created. */
+ int nameChars; /* The length of the name excluding the
+ * terminating null character. */
+ int createIfNew; /* 1 to allocate a local frame entry for the
+ * variable if it is new. */
+ int flagsIfCreated; /* Flag bits for the compiled local if
+ * created. Only VAR_SCALAR, VAR_ARRAY, and
+ * VAR_LINK make sense. */
+ register Proc *procPtr; /* Points to structure describing procedure
+ * containing the variable reference. */
+{
+ register CompiledLocal *localPtr;
+ int localIndex = -1;
+ register int i;
+
+ /*
+ * If not creating a temporary, does a local variable of the specified
+ * name already exist?
+ */
+
+ if (name != NULL) {
+ int localCt = procPtr->numCompiledLocals;
+ localPtr = procPtr->firstLocalPtr;
+ for (i = 0; i < localCt; i++) {
+ if (!localPtr->isTemp) {
+ char *localName = localPtr->name;
+ if ((name[0] == localName[0])
+ && (nameChars == localPtr->nameLength)
+ && (strncmp(name, localName, (unsigned) nameChars) == 0)) {
+ return i;
+ }
+ }
+ localPtr = localPtr->nextPtr;
+ }
+ }
+
+ /*
+ * Create a new variable if appropriate.
+ */
+
+ if (createIfNew || (name == NULL)) {
+ localIndex = procPtr->numCompiledLocals;
+ localPtr = (CompiledLocal *) ckalloc((unsigned)
+ (sizeof(CompiledLocal) - sizeof(localPtr->name)
+ + nameChars+1));
+ if (procPtr->firstLocalPtr == NULL) {
+ procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
+ } else {
+ procPtr->lastLocalPtr->nextPtr = localPtr;
+ procPtr->lastLocalPtr = localPtr;
+ }
+ localPtr->nextPtr = NULL;
+ localPtr->nameLength = nameChars;
+ localPtr->frameIndex = localIndex;
+ localPtr->isArg = 0;
+ localPtr->isTemp = (name == NULL);
+ localPtr->flags = flagsIfCreated;
+ localPtr->defValuePtr = NULL;
+ if (name != NULL) {
+ strncpy(localPtr->name, name, (unsigned) nameChars);
+ }
+ localPtr->name[nameChars] = '\0';
+ procPtr->numCompiledLocals++;
+ }
+ return localIndex;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * AdvanceToNextWord --
+ *
+ * This procedure is called to skip over any leading white space at the
+ * start of a word. Note that a backslash-newline is treated as a
+ * space.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Updates envPtr->termOffset with the offset of the first
+ * character in "string" that was not white space or a
+ * backslash-newline. This might be the offset of the character that
+ * ends the command: a newline, null, semicolon, or close-bracket.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+AdvanceToNextWord(string, envPtr)
+ char *string; /* The source string to compile. */
+ CompileEnv *envPtr; /* Holds resulting instructions. */
+{
+ register char *src; /* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+
+ src = string;
+ type = CHAR_TYPE(src, src+1);
+ while (type & (TCL_SPACE | TCL_BACKSLASH)) {
+ if (type == TCL_BACKSLASH) {
+ if (src[1] == '\n') {
+ src += 2;
+ } else {
+ break; /* exit loop; no longer white space */
+ }
+ } else {
+ src++;
+ }
+ type = CHAR_TYPE(src, src+1);
+ }
+ envPtr->termOffset = (src - string);
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * Tcl_Backslash --
+ *
+ * Figure out how to handle a backslash sequence.
+ *
+ * Results:
+ * The return value is the character that should be substituted
+ * in place of the backslash sequence that starts at src. If
+ * readPtr isn't NULL then it is filled in with a count of the
+ * number of characters in the backslash sequence.
+ *
+ * Side effects:
+ * None.
+ *
+ *----------------------------------------------------------------------
+ */
+
+char
+Tcl_Backslash(src, readPtr)
+ char *src; /* Points to the backslash character of
+ * a backslash sequence. */
+ int *readPtr; /* Fill in with number of characters read
+ * from src, unless NULL. */
+{
+ register char *p = src+1;
+ char result;
+ int count;
+
+ count = 2;
+
+ switch (*p) {
+ /*
+ * Note: in the conversions below, use absolute values (e.g.,
+ * 0xa) rather than symbolic values (e.g. \n) that get converted
+ * by the compiler. It's possible that compilers on some
+ * platforms will do the symbolic conversions differently, which
+ * could result in non-portable Tcl scripts.
+ */
+
+ case 'a':
+ result = 0x7;
+ break;
+ case 'b':
+ result = 0x8;
+ break;
+ case 'f':
+ result = 0xc;
+ break;
+ case 'n':
+ result = 0xa;
+ break;
+ case 'r':
+ result = 0xd;
+ break;
+ case 't':
+ result = 0x9;
+ break;
+ case 'v':
+ result = 0xb;
+ break;
+ case 'x':
+ if (isxdigit(UCHAR(p[1]))) {
+ char *end;
+
+ result = (char) strtoul(p+1, &end, 16);
+ count = end - src;
+ } else {
+ count = 2;
+ result = 'x';
+ }
+ break;
+ case '\n':
+ do {
+ p++;
+ } while ((*p == ' ') || (*p == '\t'));
+ result = ' ';
+ count = p - src;
+ break;
+ case 0:
+ result = '\\';
+ count = 1;
+ break;
+ default:
+ if (isdigit(UCHAR(*p))) {
+ result = (char)(*p - '0');
+ p++;
+ if (!isdigit(UCHAR(*p))) {
+ break;
+ }
+ count = 3;
+ result = (char)((result << 3) + (*p - '0'));
+ p++;
+ if (!isdigit(UCHAR(*p))) {
+ break;
+ }
+ count = 4;
+ result = (char)((result << 3) + (*p - '0'));
+ break;
+ }
+ result = *p;
+ count = 2;
+ break;
+ }
+
+ if (readPtr != NULL) {
+ *readPtr = count;
+ }
+ return result;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclObjIndexForString --
+ *
+ * Procedure to find, or if necessary create, an object in a
+ * CompileEnv's object array that has a string representation
+ * matching the argument string.
+ *
+ * Results:
+ * The index in the CompileEnv's object array of an object with a
+ * string representation matching the argument "string". The object is
+ * created if necessary. If inHeap is 1, then string is heap allocated
+ * and ownership of the string is passed to TclObjIndexForString;
+ * otherwise, the string is owned by the caller and must not be
+ * modified or freed by TclObjIndexForString. Typically, a caller sets
+ * inHeap 1 if string is an already heap-allocated buffer holding the
+ * result of backslash substitutions.
+ *
+ * Side effects:
+ * A new Tcl object will be created if no existing object matches the
+ * input string. If allocStrRep is 1 then if a new object is created,
+ * its string representation is allocated in the heap, else it is left
+ * NULL. If inHeap is 1, this procedure is given ownership of the
+ * string: if an object is created and allocStrRep is 1 then its
+ * string representation is set directly from string, otherwise
+ * the string is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
+ register char *string; /* Points to string for which an object is
+ * found or created in CompileEnv's object
+ * array. */
+ int length; /* Length of string. */
+ int allocStrRep; /* If 1 then the object's string rep should
+ * be allocated in the heap. */
+ int inHeap; /* If 1 then string is heap allocated and
+ * its ownership is passed to
+ * TclObjIndexForString. */
+ CompileEnv *envPtr; /* Points to the CompileEnv in whose object
+ * array an object is found or created. */
+{
+ register Tcl_Obj *objPtr; /* Points to the object created for
+ * the string, if one was created. */
+ int objIndex; /* Index of matching object. */
+ Tcl_HashEntry *hPtr;
+ int strLength, new;
+
+ /*
+ * Look up the string in the code's object hashtable. If found, just
+ * return the associated object array index. Note that if the string
+ * has embedded nulls, we don't create a hash table entry. This
+ * should be fixed, but we need to update hash tables, first.
+ */
+
+ strLength = strlen(string);
+ if (length == -1) {
+ length = strLength;
+ }
+ if (strLength != length) {
+ hPtr = NULL;
+ } else {
+ hPtr = Tcl_CreateHashEntry(&envPtr->objTable, string, &new);
+ if (!new) { /* already in object table and array */
+ objIndex = (int) Tcl_GetHashValue(hPtr);
+ if (inHeap) {
+ ckfree(string); /* since we own the string */
+ }
+ return objIndex;
+ }
+ }
+
+ /*
+ * Create a new object holding the string, add it to the object array,
+ * and register its index in the object hashtable.
+ */
+
+ objPtr = Tcl_NewObj();
+ if (allocStrRep) {
+ if (inHeap) { /* use input string for obj's string rep */
+ objPtr->bytes = string;
+ } else { /* must allocate string rep */
+ if (length > 0) {
+ objPtr->bytes = ckalloc((unsigned) length + 1);
+ memcpy(objPtr->bytes, string, (size_t) length);
+ objPtr->bytes[length] = '\0';
+ }
+ }
+ objPtr->length = length;
+ } else { /* leave the string rep NULL */
+ if (inHeap) {
+ ckfree(string); /* since we own the string */
+ }
+ }
+
+ if (envPtr->objArrayNext >= envPtr->objArrayEnd) {
+ ExpandObjectArray(envPtr);
+ }
+ objIndex = envPtr->objArrayNext;
+ envPtr->objArrayPtr[objIndex] = objPtr;
+ Tcl_IncrRefCount(objPtr); /* since obj array now has a reference */
+ envPtr->objArrayNext++;
+
+ if (hPtr) {
+ Tcl_SetHashValue(hPtr, objIndex);
+ }
+ return objIndex;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclExpandCodeArray --
+ *
+ * Procedure that uses malloc to allocate more storage for a
+ * CompileEnv's code array.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The byte code array in *envPtr is reallocated to a new array of
+ * double the size, and if envPtr->mallocedCodeArray is non-zero the
+ * old array is freed. Byte codes are copied from the old array to the
+ * new one.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclExpandCodeArray(envPtr)
+ CompileEnv *envPtr; /* Points to the CompileEnv whose code array
+ * must be enlarged. */
+{
+ /*
+ * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
+ * code bytes are stored between envPtr->codeStart and
+ * (envPtr->codeNext - 1) [inclusive].
+ */
+
+ size_t currBytes = TclCurrCodeOffset();
+ size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
+ unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
+
+ /*
+ * Copy from old code array to new, free old code array if needed, and
+ * mark new code array as malloced.
+ */
+
+ memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
+ if (envPtr->mallocedCodeArray) {
+ ckfree((char *) envPtr->codeStart);
+ }
+ envPtr->codeStart = newPtr;
+ envPtr->codeNext = (newPtr + currBytes);
+ envPtr->codeEnd = (newPtr + newBytes);
+ envPtr->mallocedCodeArray = 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * ExpandObjectArray --
+ *
+ * Procedure that uses malloc to allocate more storage for a
+ * CompileEnv's object array.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The object array in *envPtr is reallocated to a new array of
+ * double the size, and if envPtr->mallocedObjArray is non-zero the
+ * old array is freed. Tcl_Obj pointers are copied from the old array
+ * to the new one.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+ExpandObjectArray(envPtr)
+ CompileEnv *envPtr; /* Points to the CompileEnv whose object
+ * array must be enlarged. */
+{
+ /*
+ * envPtr->objArrayNext is equal to envPtr->objArrayEnd. The currently
+ * allocated Tcl_Obj pointers are stored between elements
+ * 0 and (envPtr->objArrayNext - 1) [inclusive] in the object array
+ * pointed to by objArrayPtr.
+ */
+
+ size_t currBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
+ int newElems = 2*envPtr->objArrayEnd;
+ size_t newBytes = newElems * sizeof(Tcl_Obj *);
+ Tcl_Obj **newPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
+
+ /*
+ * Copy from old object array to new, free old object array if needed,
+ * and mark new object array as malloced.
+ */
+
+ memcpy((VOID *) newPtr, (VOID *) envPtr->objArrayPtr, currBytes);
+ if (envPtr->mallocedObjArray) {
+ ckfree((char *) envPtr->objArrayPtr);
+ }
+ envPtr->objArrayPtr = (Tcl_Obj **) newPtr;
+ envPtr->objArrayEnd = newElems;
+ envPtr->mallocedObjArray = 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EnterCmdStartData --
+ *
+ * Registers the starting source and bytecode location of a
+ * command. This information is used at runtime to map between
+ * instruction pc and source locations.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Inserts source and code location information into the compilation
+ * environment envPtr for the command at index cmdIndex. The
+ * compilation environment's CmdLocation array is grown if necessary.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
+ CompileEnv *envPtr; /* Points to the compilation environment
+ * structure in which to enter command
+ * location information. */
+ int cmdIndex; /* Index of the command whose start data
+ * is being set. */
+ int srcOffset; /* Offset of first char of the command. */
+ int codeOffset; /* Offset of first byte of command code. */
+{
+ CmdLocation *cmdLocPtr;
+
+ if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
+ panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
+ }
+
+ if (cmdIndex >= envPtr->cmdMapEnd) {
+ /*
+ * Expand the command location array by allocating more storage from
+ * the heap. The currently allocated CmdLocation entries are stored
+ * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
+ */
+
+ size_t currElems = envPtr->cmdMapEnd;
+ size_t newElems = 2*currElems;
+ size_t currBytes = currElems * sizeof(CmdLocation);
+ size_t newBytes = newElems * sizeof(CmdLocation);
+ CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
+
+ /*
+ * Copy from old command location array to new, free old command
+ * location array if needed, and mark new array as malloced.
+ */
+
+ memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
+ if (envPtr->mallocedCmdMap) {
+ ckfree((char *) envPtr->cmdMapPtr);
+ }
+ envPtr->cmdMapPtr = (CmdLocation *) newPtr;
+ envPtr->cmdMapEnd = newElems;
+ envPtr->mallocedCmdMap = 1;
+ }
+
+ cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
+ cmdLocPtr->srcOffset = srcOffset;
+ cmdLocPtr->numSrcChars = -1;
+ cmdLocPtr->codeOffset = codeOffset;
+ cmdLocPtr->numCodeBytes = -1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * EnterCmdExtentData --
+ *
+ * Registers the source and bytecode length 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 length information into the compilation
+ * environment envPtr for the command at index cmdIndex. Starting
+ * source and bytecode information for the command must already
+ * have been registered.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, numCodeBytes)
+ CompileEnv *envPtr; /* Points to the compilation environment
+ * structure in which to enter command
+ * location information. */
+ int cmdIndex; /* Index of the command whose source and
+ * code length data is being set. */
+ int numSrcChars; /* Number of command source chars. */
+ int numCodeBytes; /* Offset of last byte of command code. */
+{
+ CmdLocation *cmdLocPtr;
+
+ if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
+ panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
+ }
+
+ if (cmdIndex > envPtr->cmdMapEnd) {
+ panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex);
+ }
+
+ cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
+ cmdLocPtr->numSrcChars = numSrcChars;
+ cmdLocPtr->numCodeBytes = numCodeBytes;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * InitArgInfo --
+ *
+ * Initializes a ArgInfo structure to hold information about
+ * some number of argument words in a command.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The ArgInfo structure is initialized.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+InitArgInfo(argInfoPtr)
+ register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
+ * to initialize. */
+{
+ argInfoPtr->numArgs = 0;
+ argInfoPtr->startArray = argInfoPtr->staticStartSpace;
+ argInfoPtr->endArray = argInfoPtr->staticEndSpace;
+ argInfoPtr->allocArgs = ARGINFO_INIT_ENTRIES;
+ argInfoPtr->mallocedArrays = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CollectArgInfo --
+ *
+ * Procedure to scan the argument words of a command and record the
+ * start and finish of each argument word in a ArgInfo structure.
+ *
+ * Results:
+ * The return value is a standard Tcl result, which is TCL_OK unless
+ * there was an error while scanning string. If an error occurs then
+ * the interpreter's result contains a standard error message.
+ *
+ * Side effects:
+ * If necessary, the argument start and end arrays in *argInfoPtr
+ * are grown and reallocated to a new arrays of double the size, and
+ * if argInfoPtr->mallocedArray is non-zero the old arrays are freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
+ Tcl_Interp *interp; /* Used for error reporting. */
+ char *string; /* The source command string to scan. */
+ char *lastChar; /* Pointer to terminating character of
+ * string. */
+ int flags; /* Flags to control compilation (same as
+ * passed to Tcl_Eval). */
+ register ArgInfo *argInfoPtr;
+ /* Points to the ArgInfo structure in which
+ * to record the arg word information. */
+{
+ register char *src = string;/* Points to current source char. */
+ register int type; /* Current char's CHAR_TYPE type. */
+ int nestedCmd = (flags & TCL_BRACKET_TERM);
+ /* 1 if string being scanned is a nested
+ * command and is terminated by a ']';
+ * otherwise 0. */
+ int scanningArgs; /* 1 if still scanning argument words to
+ * determine their start and end. */
+ char *wordStart, *wordEnd; /* Points to the first and last significant
+ * characters of each word. */
+ CompileEnv tempCompEnv; /* Only used to hold the termOffset field
+ * updated by AdvanceToNextWord. */
+ char *prev;
+
+ argInfoPtr->numArgs = 0;
+ scanningArgs = 1;
+ while (scanningArgs) {
+ AdvanceToNextWord(src, &tempCompEnv);
+ src += tempCompEnv.termOffset;
+ type = CHAR_TYPE(src, lastChar);
+
+ if ((type == TCL_COMMAND_END) && ((*src != ']') || nestedCmd)) {
+ break; /* done collecting argument words */
+ } else if (*src == '"') {
+ wordStart = src;
+ src = TclWordEnd(src, lastChar, nestedCmd, NULL);
+ if (src == lastChar) { /* word doesn't end properly. */
+ badStringTermination:
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "quoted string doesn't terminate properly", -1);
+ return TCL_ERROR;
+ }
+ prev = (src-1);
+ if (*src == '"') {
+ wordEnd = src;
+ src++; /* skip over terminating '"' */
+ } else if ((*src == ';') && (*prev == '"')) {
+ scanningArgs = 0; /* found a terminating ';' */
+ wordEnd = prev;
+ } else {
+ goto badStringTermination;
+ }
+ } else if (*src == '{') {
+ wordStart = src;
+ src = TclWordEnd(src, lastChar, nestedCmd, NULL);
+ if (src == lastChar) { /* word doesn't end properly. */
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "missing close-brace", -1);
+ return TCL_ERROR;
+ }
+ prev = (src-1);
+ if (*src == '}') {
+ wordEnd = src;
+ src++; /* skip over terminating '}' */
+ } else if ((*src == ';') && (*prev == '}')) {
+ scanningArgs = 0; /* found a terminating ';' */
+ wordEnd = prev;
+ } else {
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "argument word in braces doesn't terminate properly", -1);
+ return TCL_ERROR;
+ }
+ } else {
+ wordStart = src;
+ src = TclWordEnd(src, lastChar, nestedCmd, NULL);
+ prev = (src-1);
+ if (src == lastChar) { /* word doesn't end properly. */
+ Tcl_ResetResult(interp);
+ Tcl_AppendToObj(Tcl_GetObjResult(interp),
+ "missing close-bracket or close-brace", -1);
+ return TCL_ERROR;
+ } else if (*src == ';') {
+ scanningArgs = 0; /* found a terminating ';' */
+ wordEnd = prev;
+ } else {
+ wordEnd = src;
+ src++; /* advance to char after word */
+ if ((src == lastChar) || (*src == '\n')
+ || ((*src == ']') && nestedCmd)) {
+ scanningArgs = 0;
+ }
+ }
+ } /* end of test on each kind of word */
+
+ if (argInfoPtr->numArgs == argInfoPtr->allocArgs) {
+ int newArgs = 2*argInfoPtr->numArgs;
+ size_t currBytes = argInfoPtr->numArgs * sizeof(char *);
+ size_t newBytes = newArgs * sizeof(char *);
+ char **newStartArrayPtr =
+ (char **) ckalloc((unsigned) newBytes);
+ char **newEndArrayPtr =
+ (char **) ckalloc((unsigned) newBytes);
+
+ /*
+ * Copy from the old arrays to the new, free the old arrays if
+ * needed, and mark the new arrays as malloc'ed.
+ */
+
+ memcpy((VOID *) newStartArrayPtr,
+ (VOID *) argInfoPtr->startArray, currBytes);
+ memcpy((VOID *) newEndArrayPtr,
+ (VOID *) argInfoPtr->endArray, currBytes);
+ if (argInfoPtr->mallocedArrays) {
+ ckfree((char *) argInfoPtr->startArray);
+ ckfree((char *) argInfoPtr->endArray);
+ }
+ argInfoPtr->startArray = newStartArrayPtr;
+ argInfoPtr->endArray = newEndArrayPtr;
+ argInfoPtr->allocArgs = newArgs;
+ argInfoPtr->mallocedArrays = 1;
+ }
+ argInfoPtr->startArray[argInfoPtr->numArgs] = wordStart;
+ argInfoPtr->endArray[argInfoPtr->numArgs] = wordEnd;
+ argInfoPtr->numArgs++;
+ }
+ return TCL_OK;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * FreeArgInfo --
+ *
+ * Free any storage allocated in a ArgInfo structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocated storage in the ArgInfo structure is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static void
+FreeArgInfo(argInfoPtr)
+ register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
+ * to free. */
+{
+ if (argInfoPtr->mallocedArrays) {
+ ckfree((char *) argInfoPtr->startArray);
+ ckfree((char *) argInfoPtr->endArray);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * CreateLoopExceptionRange --
+ *
+ * Procedure that allocates and initializes a new ExceptionRange
+ * structure of the specified kind in a CompileEnv's ExceptionRange
+ * array.
+ *
+ * Results:
+ * Returns the index for the newly created ExceptionRange.
+ *
+ * Side effects:
+ * If there is not enough room in the CompileEnv's ExceptionRange
+ * array, the array in expanded: a new array of double the size is
+ * allocated, if envPtr->mallocedExcRangeArray is non-zero the old
+ * array is freed, and ExceptionRange entries are copied from the old
+ * array to the new one.
+ *
+ *----------------------------------------------------------------------
+ */
+
+static int
+CreateExceptionRange(type, envPtr)
+ ExceptionRangeType type; /* The kind of ExceptionRange desired. */
+ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
+ * loop ExceptionRange structure is to be
+ * allocated. */
+{
+ int index; /* Index for the newly-allocated
+ * ExceptionRange structure. */
+ register ExceptionRange *rangePtr;
+ /* Points to the new ExceptionRange
+ * structure */
+
+ index = envPtr->excRangeArrayNext;
+ if (index >= envPtr->excRangeArrayEnd) {
+ /*
+ * Expand the ExceptionRange array. The currently allocated entries
+ * are stored between elements 0 and (envPtr->excRangeArrayNext - 1)
+ * [inclusive].
+ */
+
+ size_t currBytes =
+ envPtr->excRangeArrayNext * sizeof(ExceptionRange);
+ int newElems = 2*envPtr->excRangeArrayEnd;
+ 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->excRangeArrayPtr,
+ currBytes);
+ if (envPtr->mallocedExcRangeArray) {
+ ckfree((char *) envPtr->excRangeArrayPtr);
+ }
+ envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr;
+ envPtr->excRangeArrayEnd = newElems;
+ envPtr->mallocedExcRangeArray = 1;
+ }
+ envPtr->excRangeArrayNext++;
+
+ rangePtr = &(envPtr->excRangeArrayPtr[index]);
+ rangePtr->type = type;
+ rangePtr->nestingLevel = envPtr->excRangeDepth;
+ rangePtr->codeOffset = -1;
+ rangePtr->numCodeBytes = -1;
+ rangePtr->breakOffset = -1;
+ rangePtr->continueOffset = -1;
+ rangePtr->catchOffset = -1;
+ return index;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclCreateAuxData --
+ *
+ * Procedure that allocates and initializes a new AuxData structure in
+ * a CompileEnv's array of compilation auxiliary data records. These
+ * AuxData records hold information created during compilation by
+ * CompileProcs and used by instructions during execution.
+ *
+ * Results:
+ * Returns the index for the newly created AuxData structure.
+ *
+ * Side effects:
+ * If there is not enough room in the CompileEnv's AuxData array,
+ * the AuxData array in expanded: a new array of double the size
+ * is allocated, if envPtr->mallocedAuxDataArray is non-zero
+ * the old array is freed, and AuxData entries are copied from
+ * the old array to the new one.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclCreateAuxData(clientData, dupProc, freeProc, envPtr)
+ ClientData clientData; /* The compilation auxiliary data to store
+ * in the new aux data record. */
+ AuxDataDupProc *dupProc; /* Procedure to call to duplicate the
+ * compilation aux data when the containing
+ * ByteCode structure is duplicated. */
+ AuxDataFreeProc *freeProc; /* Procedure to call to free the
+ * compilation aux data when the containing
+ * ByteCode structure is freed. */
+ register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
+ * aux data structure is to be allocated. */
+{
+ int index; /* Index for the new AuxData structure. */
+ register AuxData *auxDataPtr;
+ /* Points to the new AuxData structure */
+
+ index = envPtr->auxDataArrayNext;
+ if (index >= envPtr->auxDataArrayEnd) {
+ /*
+ * Expand the AuxData array. The currently allocated entries are
+ * stored between elements 0 and (envPtr->auxDataArrayNext - 1)
+ * [inclusive].
+ */
+
+ size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
+ int newElems = 2*envPtr->auxDataArrayEnd;
+ size_t newBytes = newElems * sizeof(AuxData);
+ AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
+
+ /*
+ * Copy from old AuxData array to new, free old AuxData array if
+ * needed, and mark the new AuxData array as malloced.
+ */
+
+ memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
+ currBytes);
+ if (envPtr->mallocedAuxDataArray) {
+ ckfree((char *) envPtr->auxDataArrayPtr);
+ }
+ envPtr->auxDataArrayPtr = newPtr;
+ envPtr->auxDataArrayEnd = newElems;
+ envPtr->mallocedAuxDataArray = 1;
+ }
+ envPtr->auxDataArrayNext++;
+
+ auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
+ auxDataPtr->clientData = clientData;
+ auxDataPtr->dupProc = dupProc;
+ auxDataPtr->freeProc = freeProc;
+ return index;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclInitJumpFixupArray --
+ *
+ * Initializes a JumpFixupArray structure to hold some number of
+ * jump fixup entries.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The JumpFixupArray structure is initialized.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclInitJumpFixupArray(fixupArrayPtr)
+ register JumpFixupArray *fixupArrayPtr;
+ /* Points to the JumpFixupArray structure
+ * to initialize. */
+{
+ fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
+ fixupArrayPtr->next = 0;
+ fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
+ fixupArrayPtr->mallocedArray = 0;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclExpandJumpFixupArray --
+ *
+ * Procedure that uses malloc to allocate more storage for a
+ * jump fixup array.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The jump fixup array in *fixupArrayPtr is reallocated to a new array
+ * of double the size, and if fixupArrayPtr->mallocedArray is non-zero
+ * the old array is freed. Jump fixup structures are copied from the
+ * old array to the new one.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclExpandJumpFixupArray(fixupArrayPtr)
+ register JumpFixupArray *fixupArrayPtr;
+ /* Points to the JumpFixupArray structure
+ * to enlarge. */
+{
+ /*
+ * The currently allocated jump fixup entries are stored from fixup[0]
+ * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
+ * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
+ */
+
+ size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
+ int newElems = 2*(fixupArrayPtr->end + 1);
+ size_t newBytes = newElems * sizeof(JumpFixup);
+ JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
+
+ /*
+ * Copy from the old array to new, free the old array if needed,
+ * and mark the new array as malloced.
+ */
+
+ memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
+ if (fixupArrayPtr->mallocedArray) {
+ ckfree((char *) fixupArrayPtr->fixup);
+ }
+ fixupArrayPtr->fixup = (JumpFixup *) newPtr;
+ fixupArrayPtr->end = newElems;
+ fixupArrayPtr->mallocedArray = 1;
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFreeJumpFixupArray --
+ *
+ * Free any storage allocated in a jump fixup array structure.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * Allocated storage in the JumpFixupArray structure is freed.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclFreeJumpFixupArray(fixupArrayPtr)
+ register JumpFixupArray *fixupArrayPtr;
+ /* Points to the JumpFixupArray structure
+ * to free. */
+{
+ if (fixupArrayPtr->mallocedArray) {
+ ckfree((char *) fixupArrayPtr->fixup);
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclEmitForwardJump --
+ *
+ * Procedure to emit a two-byte forward jump of kind "jumpType". Since
+ * the jump may later have to be grown to five bytes if the jump target
+ * is more than, say, 127 bytes away, this procedure also initializes a
+ * JumpFixup record with information about the jump.
+ *
+ * Results:
+ * None.
+ *
+ * Side effects:
+ * The JumpFixup record pointed to by "jumpFixupPtr" is initialized
+ * with information needed later if the jump is to be grown. Also,
+ * a two byte jump of the designated type is emitted at the current
+ * point in the bytecode stream.
+ *
+ *----------------------------------------------------------------------
+ */
+
+void
+TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
+ CompileEnv *envPtr; /* Points to the CompileEnv structure that
+ * holds the resulting instruction. */
+ TclJumpType jumpType; /* Indicates the kind of jump: if true or
+ * false or unconditional. */
+ JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to
+ * initialize with information about this
+ * forward jump. */
+{
+ /*
+ * Initialize the JumpFixup structure:
+ * - codeOffset is offset of first byte of jump below
+ * - cmdIndex is index of the command after the current one
+ * - excRangeIndex is the index of the first ExceptionRange after
+ * the current one.
+ */
+
+ jumpFixupPtr->jumpType = jumpType;
+ jumpFixupPtr->codeOffset = TclCurrCodeOffset();
+ jumpFixupPtr->cmdIndex = envPtr->numCommands;
+ jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext;
+
+ switch (jumpType) {
+ case TCL_UNCONDITIONAL_JUMP:
+ TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr);
+ break;
+ case TCL_TRUE_JUMP:
+ TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr);
+ break;
+ default:
+ TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr);
+ break;
+ }
+}
+
+/*
+ *----------------------------------------------------------------------
+ *
+ * TclFixupForwardJump --
+ *
+ * Procedure that updates a previously-emitted forward jump to jump
+ * a specified number of bytes, "jumpDist". If necessary, the jump is
+ * grown from two to five bytes; this is done if the jump distance is
+ * greater than "distThreshold" (normally 127 bytes). The jump is
+ * described by a JumpFixup record previously initialized by
+ * TclEmitForwardJump.
+ *
+ * Results:
+ * 1 if the jump was grown and subsequent instructions had to be moved;
+ * otherwise 0. This result is returned to allow callers to update
+ * any additional code offsets they may hold.
+ *
+ * Side effects:
+ * The jump may be grown and subsequent instructions moved. If this
+ * happens, the code offsets for any commands and any ExceptionRange
+ * records between the jump and the current code address will be
+ * updated to reflect the moved code. Also, the bytecode instruction
+ * array in the CompileEnv structure may be grown and reallocated.
+ *
+ *----------------------------------------------------------------------
+ */
+
+int
+TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
+ CompileEnv *envPtr; /* Points to the CompileEnv structure that
+ * holds the resulting instruction. */
+ JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that
+ * describes the forward jump. */
+ int jumpDist; /* Jump distance to set in jump
+ * instruction. */
+ int distThreshold; /* Maximum distance before the two byte
+ * jump is grown to five bytes. */
+{
+ unsigned char *jumpPc, *p;
+ int firstCmd, lastCmd, firstRange, lastRange, k;
+ unsigned int numBytes;
+
+#ifdef TCL_COMPILE_DEBUG
+ if (jumpDist > MAX_JUMP_DIST) {
+ fprintf(stderr, "\nTclFixupForwardJump: bad jump distance %u\n", jumpDist);
+ panic("TclFixupForwardJump: bad jump distance");
+ }
+#endif /*TCL_COMPILE_DEBUG*/
+
+ if (jumpDist <= distThreshold) {
+ jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
+ switch (jumpFixupPtr->jumpType) {
+ case TCL_UNCONDITIONAL_JUMP:
+ TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
+ break;
+ case TCL_TRUE_JUMP:
+ TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
+ break;
+ default:
+ TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
+ break;
+ }
+ return 0; /* no need to grow the jump */
+ }
+
+ /*
+ * We must grow the jump then move subsequent instructions down.
+ */
+
+ TclEnsureCodeSpace(3, envPtr); /* NB: might change code addresses! */
+ jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
+ for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
+ numBytes > 0; numBytes--, p--) {
+ p[3] = p[0];
+ }
+ envPtr->codeNext += 3;
+ jumpDist += 3;
+ switch (jumpFixupPtr->jumpType) {
+ case TCL_UNCONDITIONAL_JUMP:
+ TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
+ break;
+ case TCL_TRUE_JUMP:
+ TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
+ break;
+ default:
+ TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
+ break;
+ }
+
+ /*
+ * Adjust the code offsets for any commands and any ExceptionRange
+ * records between the jump and the current code address.
+ */
+
+ firstCmd = jumpFixupPtr->cmdIndex;
+ lastCmd = (envPtr->numCommands - 1);
+ if (firstCmd < lastCmd) {
+ for (k = firstCmd; k <= lastCmd; k++) {
+ (envPtr->cmdMapPtr[k]).codeOffset += 3;
+ }
+ }
+
+ firstRange = jumpFixupPtr->excRangeIndex;
+ lastRange = (envPtr->excRangeArrayNext - 1);
+ for (k = firstRange; k <= lastRange; k++) {
+ ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]);
+ rangePtr->codeOffset += 3;
+
+ switch (rangePtr->type) {
+ case LOOP_EXCEPTION_RANGE:
+ rangePtr->breakOffset += 3;
+ if (rangePtr->continueOffset != -1) {
+ rangePtr->continueOffset += 3;
+ }
+ break;
+ case CATCH_EXCEPTION_RANGE:
+ rangePtr->catchOffset += 3;
+ break;
+ default:
+ panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type);
+ }
+ }
+ return 1; /* the jump was grown */
+}
+
+