os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCompile.c
1.1 --- /dev/null Thu Jan 01 00:00:00 1970 +0000
1.2 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCompile.c Fri Jun 15 03:10:57 2012 +0200
1.3 @@ -0,0 +1,3826 @@
1.4 +/*
1.5 + * tclCompile.c --
1.6 + *
1.7 + * This file contains procedures that compile Tcl commands or parts
1.8 + * of commands (like quoted strings or nested sub-commands) into a
1.9 + * sequence of instructions ("bytecodes").
1.10 + *
1.11 + * Copyright (c) 1996-1998 Sun Microsystems, Inc.
1.12 + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
1.13 + * Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved.
1.14 + *
1.15 + * See the file "license.terms" for information on usage and redistribution
1.16 + * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
1.17 + *
1.18 + * RCS: @(#) $Id: tclCompile.c,v 1.43.2.7 2006/11/28 22:20:00 andreas_kupries Exp $
1.19 + */
1.20 +
1.21 +#include "tclInt.h"
1.22 +#include "tclCompile.h"
1.23 +#if defined(__SYMBIAN32__) && defined(__WINSCW__)
1.24 +#include "tclSymbianGlobals.h"
1.25 +#define dataKey getdataKey(0)
1.26 +#endif
1.27 +
1.28 +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__)
1.29 +/*
1.30 + * Table of all AuxData types.
1.31 + */
1.32 +
1.33 +static Tcl_HashTable auxDataTypeTable;
1.34 +static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
1.35 +#endif
1.36 +TCL_DECLARE_MUTEX(tableMutex)
1.37 +
1.38 +/*
1.39 + * Variable that controls whether compilation tracing is enabled and, if so,
1.40 + * what level of tracing is desired:
1.41 + * 0: no compilation tracing
1.42 + * 1: summarize compilation of top level cmds and proc bodies
1.43 + * 2: display all instructions of each ByteCode compiled
1.44 + * This variable is linked to the Tcl variable "tcl_traceCompile".
1.45 + */
1.46 +
1.47 +#ifdef TCL_COMPILE_DEBUG
1.48 +int tclTraceCompile = 0;
1.49 +static int traceInitialized = 0;
1.50 +#endif
1.51 +
1.52 +/*
1.53 + * A table describing the Tcl bytecode instructions. Entries in this table
1.54 + * must correspond to the instruction opcode definitions in tclCompile.h.
1.55 + * The names "op1" and "op4" refer to an instruction's one or four byte
1.56 + * first operand. Similarly, "stktop" and "stknext" refer to the topmost
1.57 + * and next to topmost stack elements.
1.58 + *
1.59 + * Note that the load, store, and incr instructions do not distinguish local
1.60 + * from global variables; the bytecode interpreter at runtime uses the
1.61 + * existence of a procedure call frame to distinguish these.
1.62 + */
1.63 +
1.64 +InstructionDesc tclInstructionTable[] = {
1.65 + /* Name Bytes stackEffect #Opnds Operand types Stack top, next */
1.66 + {"done", 1, -1, 0, {OPERAND_NONE}},
1.67 + /* Finish ByteCode execution and return stktop (top stack item) */
1.68 + {"push1", 2, +1, 1, {OPERAND_UINT1}},
1.69 + /* Push object at ByteCode objArray[op1] */
1.70 + {"push4", 5, +1, 1, {OPERAND_UINT4}},
1.71 + /* Push object at ByteCode objArray[op4] */
1.72 + {"pop", 1, -1, 0, {OPERAND_NONE}},
1.73 + /* Pop the topmost stack object */
1.74 + {"dup", 1, +1, 0, {OPERAND_NONE}},
1.75 + /* Duplicate the topmost stack object and push the result */
1.76 + {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}},
1.77 + /* Concatenate the top op1 items and push result */
1.78 + {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}},
1.79 + /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
1.80 + {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}},
1.81 + /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
1.82 + {"evalStk", 1, 0, 0, {OPERAND_NONE}},
1.83 + /* Evaluate command in stktop using Tcl_EvalObj. */
1.84 + {"exprStk", 1, 0, 0, {OPERAND_NONE}},
1.85 + /* Execute expression in stktop using Tcl_ExprStringObj. */
1.86 +
1.87 + {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}},
1.88 + /* Load scalar variable at index op1 <= 255 in call frame */
1.89 + {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}},
1.90 + /* Load scalar variable at index op1 >= 256 in call frame */
1.91 + {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}},
1.92 + /* Load scalar variable; scalar's name is stktop */
1.93 + {"loadArray1", 2, 0, 1, {OPERAND_UINT1}},
1.94 + /* Load array element; array at slot op1<=255, element is stktop */
1.95 + {"loadArray4", 5, 0, 1, {OPERAND_UINT4}},
1.96 + /* Load array element; array at slot op1 > 255, element is stktop */
1.97 + {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}},
1.98 + /* Load array element; element is stktop, array name is stknext */
1.99 + {"loadStk", 1, 0, 0, {OPERAND_NONE}},
1.100 + /* Load general variable; unparsed variable name is stktop */
1.101 + {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}},
1.102 + /* Store scalar variable at op1<=255 in frame; value is stktop */
1.103 + {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}},
1.104 + /* Store scalar variable at op1 > 255 in frame; value is stktop */
1.105 + {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}},
1.106 + /* Store scalar; value is stktop, scalar name is stknext */
1.107 + {"storeArray1", 2, -1, 1, {OPERAND_UINT1}},
1.108 + /* Store array element; array at op1<=255, value is top then elem */
1.109 + {"storeArray4", 5, -1, 1, {OPERAND_UINT4}},
1.110 + /* Store array element; array at op1>=256, value is top then elem */
1.111 + {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}},
1.112 + /* Store array element; value is stktop, then elem, array names */
1.113 + {"storeStk", 1, -1, 0, {OPERAND_NONE}},
1.114 + /* Store general variable; value is stktop, then unparsed name */
1.115 +
1.116 + {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}},
1.117 + /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
1.118 + {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}},
1.119 + /* Incr scalar; incr amount is stktop, scalar's name is stknext */
1.120 + {"incrArray1", 2, -1, 1, {OPERAND_UINT1}},
1.121 + /* Incr array elem; arr at slot op1<=255, amount is top then elem */
1.122 + {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}},
1.123 + /* Incr array element; amount is top then elem then array names */
1.124 + {"incrStk", 1, -1, 0, {OPERAND_NONE}},
1.125 + /* Incr general variable; amount is stktop then unparsed var name */
1.126 + {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}},
1.127 + /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
1.128 + {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}},
1.129 + /* Incr scalar; scalar name is stktop; incr amount is op1 */
1.130 + {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}},
1.131 + /* Incr array elem; array at slot op1 <= 255, elem is stktop,
1.132 + * amount is 2nd operand byte */
1.133 + {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}},
1.134 + /* Incr array element; elem is top then array name, amount is op1 */
1.135 + {"incrStkImm", 2, 0, 1, {OPERAND_INT1}},
1.136 + /* Incr general variable; unparsed name is top, amount is op1 */
1.137 +
1.138 + {"jump1", 2, 0, 1, {OPERAND_INT1}},
1.139 + /* Jump relative to (pc + op1) */
1.140 + {"jump4", 5, 0, 1, {OPERAND_INT4}},
1.141 + /* Jump relative to (pc + op4) */
1.142 + {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}},
1.143 + /* Jump relative to (pc + op1) if stktop expr object is true */
1.144 + {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}},
1.145 + /* Jump relative to (pc + op4) if stktop expr object is true */
1.146 + {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}},
1.147 + /* Jump relative to (pc + op1) if stktop expr object is false */
1.148 + {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}},
1.149 + /* Jump relative to (pc + op4) if stktop expr object is false */
1.150 +
1.151 + {"lor", 1, -1, 0, {OPERAND_NONE}},
1.152 + /* Logical or: push (stknext || stktop) */
1.153 + {"land", 1, -1, 0, {OPERAND_NONE}},
1.154 + /* Logical and: push (stknext && stktop) */
1.155 + {"bitor", 1, -1, 0, {OPERAND_NONE}},
1.156 + /* Bitwise or: push (stknext | stktop) */
1.157 + {"bitxor", 1, -1, 0, {OPERAND_NONE}},
1.158 + /* Bitwise xor push (stknext ^ stktop) */
1.159 + {"bitand", 1, -1, 0, {OPERAND_NONE}},
1.160 + /* Bitwise and: push (stknext & stktop) */
1.161 + {"eq", 1, -1, 0, {OPERAND_NONE}},
1.162 + /* Equal: push (stknext == stktop) */
1.163 + {"neq", 1, -1, 0, {OPERAND_NONE}},
1.164 + /* Not equal: push (stknext != stktop) */
1.165 + {"lt", 1, -1, 0, {OPERAND_NONE}},
1.166 + /* Less: push (stknext < stktop) */
1.167 + {"gt", 1, -1, 0, {OPERAND_NONE}},
1.168 + /* Greater: push (stknext || stktop) */
1.169 + {"le", 1, -1, 0, {OPERAND_NONE}},
1.170 + /* Logical or: push (stknext || stktop) */
1.171 + {"ge", 1, -1, 0, {OPERAND_NONE}},
1.172 + /* Logical or: push (stknext || stktop) */
1.173 + {"lshift", 1, -1, 0, {OPERAND_NONE}},
1.174 + /* Left shift: push (stknext << stktop) */
1.175 + {"rshift", 1, -1, 0, {OPERAND_NONE}},
1.176 + /* Right shift: push (stknext >> stktop) */
1.177 + {"add", 1, -1, 0, {OPERAND_NONE}},
1.178 + /* Add: push (stknext + stktop) */
1.179 + {"sub", 1, -1, 0, {OPERAND_NONE}},
1.180 + /* Sub: push (stkext - stktop) */
1.181 + {"mult", 1, -1, 0, {OPERAND_NONE}},
1.182 + /* Multiply: push (stknext * stktop) */
1.183 + {"div", 1, -1, 0, {OPERAND_NONE}},
1.184 + /* Divide: push (stknext / stktop) */
1.185 + {"mod", 1, -1, 0, {OPERAND_NONE}},
1.186 + /* Mod: push (stknext % stktop) */
1.187 + {"uplus", 1, 0, 0, {OPERAND_NONE}},
1.188 + /* Unary plus: push +stktop */
1.189 + {"uminus", 1, 0, 0, {OPERAND_NONE}},
1.190 + /* Unary minus: push -stktop */
1.191 + {"bitnot", 1, 0, 0, {OPERAND_NONE}},
1.192 + /* Bitwise not: push ~stktop */
1.193 + {"not", 1, 0, 0, {OPERAND_NONE}},
1.194 + /* Logical not: push !stktop */
1.195 + {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}},
1.196 + /* Call builtin math function with index op1; any args are on stk */
1.197 + {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}},
1.198 + /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
1.199 + {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}},
1.200 + /* Try converting stktop to first int then double if possible. */
1.201 +
1.202 + {"break", 1, 0, 0, {OPERAND_NONE}},
1.203 + /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
1.204 + {"continue", 1, 0, 0, {OPERAND_NONE}},
1.205 + /* Skip to next iteration of closest enclosing loop; if none,
1.206 + * return TCL_CONTINUE code. */
1.207 +
1.208 + {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}},
1.209 + /* Initialize execution of a foreach loop. Operand is aux data index
1.210 + * of the ForeachInfo structure for the foreach command. */
1.211 + {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}},
1.212 + /* "Step" or begin next iteration of foreach loop. Push 0 if to
1.213 + * terminate loop, else push 1. */
1.214 +
1.215 + {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}},
1.216 + /* Record start of catch with the operand's exception index.
1.217 + * Push the current stack depth onto a special catch stack. */
1.218 + {"endCatch", 1, 0, 0, {OPERAND_NONE}},
1.219 + /* End of last catch. Pop the bytecode interpreter's catch stack. */
1.220 + {"pushResult", 1, +1, 0, {OPERAND_NONE}},
1.221 + /* Push the interpreter's object result onto the stack. */
1.222 + {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}},
1.223 + /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
1.224 + * a new object onto the stack. */
1.225 + {"streq", 1, -1, 0, {OPERAND_NONE}},
1.226 + /* Str Equal: push (stknext eq stktop) */
1.227 + {"strneq", 1, -1, 0, {OPERAND_NONE}},
1.228 + /* Str !Equal: push (stknext neq stktop) */
1.229 + {"strcmp", 1, -1, 0, {OPERAND_NONE}},
1.230 + /* Str Compare: push (stknext cmp stktop) */
1.231 + {"strlen", 1, 0, 0, {OPERAND_NONE}},
1.232 + /* Str Length: push (strlen stktop) */
1.233 + {"strindex", 1, -1, 0, {OPERAND_NONE}},
1.234 + /* Str Index: push (strindex stknext stktop) */
1.235 + {"strmatch", 2, -1, 1, {OPERAND_INT1}},
1.236 + /* Str Match: push (strmatch stknext stktop) opnd == nocase */
1.237 + {"list", 5, INT_MIN, 1, {OPERAND_UINT4}},
1.238 + /* List: push (stk1 stk2 ... stktop) */
1.239 + {"listindex", 1, -1, 0, {OPERAND_NONE}},
1.240 + /* List Index: push (listindex stknext stktop) */
1.241 + {"listlength", 1, 0, 0, {OPERAND_NONE}},
1.242 + /* List Len: push (listlength stktop) */
1.243 + {"appendScalar1", 2, 0, 1, {OPERAND_UINT1}},
1.244 + /* Append scalar variable at op1<=255 in frame; value is stktop */
1.245 + {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}},
1.246 + /* Append scalar variable at op1 > 255 in frame; value is stktop */
1.247 + {"appendArray1", 2, -1, 1, {OPERAND_UINT1}},
1.248 + /* Append array element; array at op1<=255, value is top then elem */
1.249 + {"appendArray4", 5, -1, 1, {OPERAND_UINT4}},
1.250 + /* Append array element; array at op1>=256, value is top then elem */
1.251 + {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}},
1.252 + /* Append array element; value is stktop, then elem, array names */
1.253 + {"appendStk", 1, -1, 0, {OPERAND_NONE}},
1.254 + /* Append general variable; value is stktop, then unparsed name */
1.255 + {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}},
1.256 + /* Lappend scalar variable at op1<=255 in frame; value is stktop */
1.257 + {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}},
1.258 + /* Lappend scalar variable at op1 > 255 in frame; value is stktop */
1.259 + {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}},
1.260 + /* Lappend array element; array at op1<=255, value is top then elem */
1.261 + {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}},
1.262 + /* Lappend array element; array at op1>=256, value is top then elem */
1.263 + {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}},
1.264 + /* Lappend array element; value is stktop, then elem, array names */
1.265 + {"lappendStk", 1, -1, 0, {OPERAND_NONE}},
1.266 + /* Lappend general variable; value is stktop, then unparsed name */
1.267 + {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}},
1.268 + /* Lindex with generalized args, operand is number of stacked objs
1.269 + * used: (operand-1) entries from stktop are the indices; then list
1.270 + * to process. */
1.271 + {"over", 5, +1, 1, {OPERAND_UINT4}},
1.272 + /* Duplicate the arg-th element from top of stack (TOS=0) */
1.273 + {"lsetList", 1, -2, 0, {OPERAND_NONE}},
1.274 + /* Four-arg version of 'lset'. stktop is old value; next is
1.275 + * new element value, next is the index list; pushes new value */
1.276 + {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}},
1.277 + /* Three- or >=5-arg version of 'lset', operand is number of
1.278 + * stacked objs: stktop is old value, next is new element value, next
1.279 + * come (operand-2) indices; pushes the new value.
1.280 + */
1.281 + {0}
1.282 +};
1.283 +
1.284 +/*
1.285 + * Prototypes for procedures defined later in this file:
1.286 + */
1.287 +
1.288 +static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
1.289 + Tcl_Obj *copyPtr));
1.290 +static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
1.291 + CompileEnv *envPtr, ByteCode *codePtr,
1.292 + unsigned char *startPtr));
1.293 +static void EnterCmdExtentData _ANSI_ARGS_((
1.294 + CompileEnv *envPtr, int cmdNumber,
1.295 + int numSrcBytes, int numCodeBytes));
1.296 +static void EnterCmdStartData _ANSI_ARGS_((
1.297 + CompileEnv *envPtr, int cmdNumber,
1.298 + int srcOffset, int codeOffset));
1.299 +static void FreeByteCodeInternalRep _ANSI_ARGS_((
1.300 + Tcl_Obj *objPtr));
1.301 +static int GetCmdLocEncodingSize _ANSI_ARGS_((
1.302 + CompileEnv *envPtr));
1.303 +static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
1.304 + CONST char *script, CONST char *command,
1.305 + int length));
1.306 +#ifdef TCL_COMPILE_STATS
1.307 +static void RecordByteCodeStats _ANSI_ARGS_((
1.308 + ByteCode *codePtr));
1.309 +#endif /* TCL_COMPILE_STATS */
1.310 +static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
1.311 + Tcl_Obj *objPtr));
1.312 +
1.313 +#ifdef TCL_TIP280
1.314 +/* TIP #280 : Helper for building the per-word line information of all
1.315 + * compiled commands */
1.316 +static void EnterCmdWordData _ANSI_ARGS_((
1.317 + ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr,
1.318 + CONST char* cmd, int len, int numWords, int line,
1.319 + int** lines));
1.320 +#endif
1.321 +
1.322 +
1.323 +/*
1.324 + * The structure below defines the bytecode Tcl object type by
1.325 + * means of procedures that can be invoked by generic object code.
1.326 + */
1.327 +
1.328 +Tcl_ObjType tclByteCodeType = {
1.329 + "bytecode", /* name */
1.330 + FreeByteCodeInternalRep, /* freeIntRepProc */
1.331 + DupByteCodeInternalRep, /* dupIntRepProc */
1.332 + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
1.333 + SetByteCodeFromAny /* setFromAnyProc */
1.334 +};
1.335 +
1.336 +/*
1.337 + *----------------------------------------------------------------------
1.338 + *
1.339 + * TclSetByteCodeFromAny --
1.340 + *
1.341 + * Part of the bytecode Tcl object type implementation. Attempts to
1.342 + * generate an byte code internal form for the Tcl object "objPtr" by
1.343 + * compiling its string representation. This function also takes
1.344 + * a hook procedure that will be invoked to perform any needed post
1.345 + * processing on the compilation results before generating byte
1.346 + * codes.
1.347 + *
1.348 + * Results:
1.349 + * The return value is a standard Tcl object result. If an error occurs
1.350 + * during compilation, an error message is left in the interpreter's
1.351 + * result unless "interp" is NULL.
1.352 + *
1.353 + * Side effects:
1.354 + * Frees the old internal representation. If no error occurs, then the
1.355 + * compiled code is stored as "objPtr"s bytecode representation.
1.356 + * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
1.357 + * used to trace compilations.
1.358 + *
1.359 + *----------------------------------------------------------------------
1.360 + */
1.361 +
1.362 +int
1.363 +TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
1.364 + Tcl_Interp *interp; /* The interpreter for which the code is
1.365 + * being compiled. Must not be NULL. */
1.366 + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
1.367 + CompileHookProc *hookProc; /* Procedure to invoke after compilation. */
1.368 + ClientData clientData; /* Hook procedure private data. */
1.369 +{
1.370 + Interp *iPtr = (Interp *) interp;
1.371 + CompileEnv compEnv; /* Compilation environment structure
1.372 + * allocated in frame. */
1.373 + LiteralTable *localTablePtr = &(compEnv.localLitTable);
1.374 + register AuxData *auxDataPtr;
1.375 + LiteralEntry *entryPtr;
1.376 + register int i;
1.377 + int length, nested, result;
1.378 + char *string;
1.379 +
1.380 +#ifdef TCL_COMPILE_DEBUG
1.381 + if (!traceInitialized) {
1.382 + if (Tcl_LinkVar(interp, "tcl_traceCompile",
1.383 + (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
1.384 + panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
1.385 + }
1.386 + traceInitialized = 1;
1.387 + }
1.388 +#endif
1.389 +
1.390 + if (iPtr->evalFlags & TCL_BRACKET_TERM) {
1.391 + nested = 1;
1.392 + } else {
1.393 + nested = 0;
1.394 + }
1.395 + string = Tcl_GetStringFromObj(objPtr, &length);
1.396 +#ifndef TCL_TIP280
1.397 + TclInitCompileEnv(interp, &compEnv, string, length);
1.398 +#else
1.399 + /*
1.400 + * TIP #280. Pick up the CmdFrame in which the BC compiler was invoked
1.401 + * and use to initialize the tracking in the compiler. This information
1.402 + * was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc
1.403 + * (tclProc.c).
1.404 + */
1.405 +
1.406 + TclInitCompileEnv(interp, &compEnv, string, length,
1.407 + iPtr->invokeCmdFramePtr, iPtr->invokeWord);
1.408 +#endif
1.409 + result = TclCompileScript(interp, string, length, nested, &compEnv);
1.410 +
1.411 + if (result == TCL_OK) {
1.412 + /*
1.413 + * Successful compilation. Add a "done" instruction at the end.
1.414 + */
1.415 +
1.416 + compEnv.numSrcBytes = iPtr->termOffset;
1.417 + TclEmitOpcode(INST_DONE, &compEnv);
1.418 +
1.419 + /*
1.420 + * Invoke the compilation hook procedure if one exists.
1.421 + */
1.422 +
1.423 + if (hookProc) {
1.424 + result = (*hookProc)(interp, &compEnv, clientData);
1.425 + }
1.426 +
1.427 + /*
1.428 + * Change the object into a ByteCode object. Ownership of the literal
1.429 + * objects and aux data items is given to the ByteCode object.
1.430 + */
1.431 +
1.432 +#ifdef TCL_COMPILE_DEBUG
1.433 + TclVerifyLocalLiteralTable(&compEnv);
1.434 +#endif /*TCL_COMPILE_DEBUG*/
1.435 +
1.436 + TclInitByteCodeObj(objPtr, &compEnv);
1.437 +#ifdef TCL_COMPILE_DEBUG
1.438 + if (tclTraceCompile >= 2) {
1.439 + TclPrintByteCodeObj(interp, objPtr);
1.440 + }
1.441 +#endif /* TCL_COMPILE_DEBUG */
1.442 + }
1.443 +
1.444 + if (result != TCL_OK) {
1.445 + /*
1.446 + * Compilation errors.
1.447 + */
1.448 +
1.449 + entryPtr = compEnv.literalArrayPtr;
1.450 + for (i = 0; i < compEnv.literalArrayNext; i++) {
1.451 + TclReleaseLiteral(interp, entryPtr->objPtr);
1.452 + entryPtr++;
1.453 + }
1.454 +#ifdef TCL_COMPILE_DEBUG
1.455 + TclVerifyGlobalLiteralTable(iPtr);
1.456 +#endif /*TCL_COMPILE_DEBUG*/
1.457 +
1.458 + auxDataPtr = compEnv.auxDataArrayPtr;
1.459 + for (i = 0; i < compEnv.auxDataArrayNext; i++) {
1.460 + if (auxDataPtr->type->freeProc != NULL) {
1.461 + auxDataPtr->type->freeProc(auxDataPtr->clientData);
1.462 + }
1.463 + auxDataPtr++;
1.464 + }
1.465 + }
1.466 +
1.467 +
1.468 + /*
1.469 + * Free storage allocated during compilation.
1.470 + */
1.471 +
1.472 + if (localTablePtr->buckets != localTablePtr->staticBuckets) {
1.473 + ckfree((char *) localTablePtr->buckets);
1.474 + }
1.475 + TclFreeCompileEnv(&compEnv);
1.476 + return result;
1.477 +}
1.478 +
1.479 +/*
1.480 + *-----------------------------------------------------------------------
1.481 + *
1.482 + * SetByteCodeFromAny --
1.483 + *
1.484 + * Part of the bytecode Tcl object type implementation. Attempts to
1.485 + * generate an byte code internal form for the Tcl object "objPtr" by
1.486 + * compiling its string representation.
1.487 + *
1.488 + * Results:
1.489 + * The return value is a standard Tcl object result. If an error occurs
1.490 + * during compilation, an error message is left in the interpreter's
1.491 + * result unless "interp" is NULL.
1.492 + *
1.493 + * Side effects:
1.494 + * Frees the old internal representation. If no error occurs, then the
1.495 + * compiled code is stored as "objPtr"s bytecode representation.
1.496 + * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
1.497 + * used to trace compilations.
1.498 + *
1.499 + *----------------------------------------------------------------------
1.500 + */
1.501 +
1.502 +static int
1.503 +SetByteCodeFromAny(interp, objPtr)
1.504 + Tcl_Interp *interp; /* The interpreter for which the code is
1.505 + * being compiled. Must not be NULL. */
1.506 + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
1.507 +{
1.508 + return TclSetByteCodeFromAny(interp, objPtr,
1.509 + (CompileHookProc *) NULL, (ClientData) NULL);
1.510 +}
1.511 +
1.512 +/*
1.513 + *----------------------------------------------------------------------
1.514 + *
1.515 + * DupByteCodeInternalRep --
1.516 + *
1.517 + * Part of the bytecode Tcl object type implementation. However, it
1.518 + * does not copy the internal representation of a bytecode Tcl_Obj, but
1.519 + * instead leaves the new object untyped (with a NULL type pointer).
1.520 + * Code will be compiled for the new object only if necessary.
1.521 + *
1.522 + * Results:
1.523 + * None.
1.524 + *
1.525 + * Side effects:
1.526 + * None.
1.527 + *
1.528 + *----------------------------------------------------------------------
1.529 + */
1.530 +
1.531 +static void
1.532 +DupByteCodeInternalRep(srcPtr, copyPtr)
1.533 + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
1.534 + Tcl_Obj *copyPtr; /* Object with internal rep to set. */
1.535 +{
1.536 + return;
1.537 +}
1.538 +
1.539 +/*
1.540 + *----------------------------------------------------------------------
1.541 + *
1.542 + * FreeByteCodeInternalRep --
1.543 + *
1.544 + * Part of the bytecode Tcl object type implementation. Frees the
1.545 + * storage associated with a bytecode object's internal representation
1.546 + * unless its code is actively being executed.
1.547 + *
1.548 + * Results:
1.549 + * None.
1.550 + *
1.551 + * Side effects:
1.552 + * The bytecode object's internal rep is marked invalid and its
1.553 + * code gets freed unless the code is actively being executed.
1.554 + * In that case the cleanup is delayed until the last execution
1.555 + * of the code completes.
1.556 + *
1.557 + *----------------------------------------------------------------------
1.558 + */
1.559 +
1.560 +static void
1.561 +FreeByteCodeInternalRep(objPtr)
1.562 + register Tcl_Obj *objPtr; /* Object whose internal rep to free. */
1.563 +{
1.564 + register ByteCode *codePtr =
1.565 + (ByteCode *) objPtr->internalRep.otherValuePtr;
1.566 +
1.567 + codePtr->refCount--;
1.568 + if (codePtr->refCount <= 0) {
1.569 + TclCleanupByteCode(codePtr);
1.570 + }
1.571 + objPtr->typePtr = NULL;
1.572 + objPtr->internalRep.otherValuePtr = NULL;
1.573 +}
1.574 +
1.575 +/*
1.576 + *----------------------------------------------------------------------
1.577 + *
1.578 + * TclCleanupByteCode --
1.579 + *
1.580 + * This procedure does all the real work of freeing up a bytecode
1.581 + * object's ByteCode structure. It's called only when the structure's
1.582 + * reference count becomes zero.
1.583 + *
1.584 + * Results:
1.585 + * None.
1.586 + *
1.587 + * Side effects:
1.588 + * Frees objPtr's bytecode internal representation and sets its type
1.589 + * and objPtr->internalRep.otherValuePtr NULL. Also releases its
1.590 + * literals and frees its auxiliary data items.
1.591 + *
1.592 + *----------------------------------------------------------------------
1.593 + */
1.594 +
1.595 +void
1.596 +TclCleanupByteCode(codePtr)
1.597 + register ByteCode *codePtr; /* Points to the ByteCode to free. */
1.598 +{
1.599 + Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
1.600 +#ifdef TCL_TIP280
1.601 + Interp* iPtr = (Interp*) interp;
1.602 +#endif
1.603 + int numLitObjects = codePtr->numLitObjects;
1.604 + int numAuxDataItems = codePtr->numAuxDataItems;
1.605 + register Tcl_Obj **objArrayPtr;
1.606 + register AuxData *auxDataPtr;
1.607 + int i;
1.608 +#ifdef TCL_COMPILE_STATS
1.609 +
1.610 + if (interp != NULL) {
1.611 + ByteCodeStats *statsPtr;
1.612 + Tcl_Time destroyTime;
1.613 + int lifetimeSec, lifetimeMicroSec, log2;
1.614 +
1.615 + statsPtr = &((Interp *) interp)->stats;
1.616 +
1.617 + statsPtr->numByteCodesFreed++;
1.618 + statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
1.619 + statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
1.620 +
1.621 + statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
1.622 + statsPtr->currentLitBytes -=
1.623 + (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
1.624 + statsPtr->currentExceptBytes -=
1.625 + (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
1.626 + statsPtr->currentAuxBytes -=
1.627 + (double) (codePtr->numAuxDataItems * sizeof(AuxData));
1.628 + statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
1.629 +
1.630 + Tcl_GetTime(&destroyTime);
1.631 + lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
1.632 + if (lifetimeSec > 2000) { /* avoid overflow */
1.633 + lifetimeSec = 2000;
1.634 + }
1.635 + lifetimeMicroSec =
1.636 + 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
1.637 +
1.638 + log2 = TclLog2(lifetimeMicroSec);
1.639 + if (log2 > 31) {
1.640 + log2 = 31;
1.641 + }
1.642 + statsPtr->lifetimeCount[log2]++;
1.643 + }
1.644 +#endif /* TCL_COMPILE_STATS */
1.645 +
1.646 + /*
1.647 + * A single heap object holds the ByteCode structure and its code,
1.648 + * object, command location, and auxiliary data arrays. This means we
1.649 + * only need to 1) decrement the ref counts of the LiteralEntry's in
1.650 + * its literal array, 2) call the free procs for the auxiliary data
1.651 + * items, and 3) free the ByteCode structure's heap object.
1.652 + *
1.653 + * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,
1.654 + * like those generated from tbcload) is special, as they doesn't
1.655 + * make use of the global literal table. They instead maintain
1.656 + * private references to their literals which must be decremented.
1.657 + */
1.658 +
1.659 + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1.660 + register Tcl_Obj *objPtr;
1.661 +
1.662 + objArrayPtr = codePtr->objArrayPtr;
1.663 + for (i = 0; i < numLitObjects; i++) {
1.664 + objPtr = *objArrayPtr;
1.665 + if (objPtr) {
1.666 + Tcl_DecrRefCount(objPtr);
1.667 + }
1.668 + objArrayPtr++;
1.669 + }
1.670 + codePtr->numLitObjects = 0;
1.671 + } else if (interp != NULL) {
1.672 + /*
1.673 + * If the interp has already been freed, then Tcl will have already
1.674 + * forcefully released all the literals used by ByteCodes compiled
1.675 + * with respect to that interp.
1.676 + */
1.677 +
1.678 + objArrayPtr = codePtr->objArrayPtr;
1.679 + for (i = 0; i < numLitObjects; i++) {
1.680 + /*
1.681 + * TclReleaseLiteral sets a ByteCode's object array entry NULL to
1.682 + * indicate that it has already freed the literal.
1.683 + */
1.684 +
1.685 + if (*objArrayPtr != NULL) {
1.686 + TclReleaseLiteral(interp, *objArrayPtr);
1.687 + }
1.688 + objArrayPtr++;
1.689 + }
1.690 + }
1.691 +
1.692 + auxDataPtr = codePtr->auxDataArrayPtr;
1.693 + for (i = 0; i < numAuxDataItems; i++) {
1.694 + if (auxDataPtr->type->freeProc != NULL) {
1.695 + (*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
1.696 + }
1.697 + auxDataPtr++;
1.698 + }
1.699 +
1.700 +#ifdef TCL_TIP280
1.701 + /*
1.702 + * TIP #280. Release the location data associated with this byte code
1.703 + * structure, if any. NOTE: The interp we belong to may be gone already,
1.704 + * and the data with it.
1.705 + *
1.706 + * See also tclBasic.c, DeleteInterpProc
1.707 + */
1.708 +
1.709 + if (iPtr) {
1.710 + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr);
1.711 + if (hePtr) {
1.712 + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr);
1.713 + int i;
1.714 +
1.715 + if (eclPtr->type == TCL_LOCATION_SOURCE) {
1.716 + Tcl_DecrRefCount (eclPtr->path);
1.717 + }
1.718 + for (i=0; i< eclPtr->nuloc; i++) {
1.719 + ckfree ((char*) eclPtr->loc[i].line);
1.720 + }
1.721 +
1.722 + if (eclPtr->loc != NULL) {
1.723 + ckfree ((char*) eclPtr->loc);
1.724 + }
1.725 +
1.726 + ckfree ((char*) eclPtr);
1.727 + Tcl_DeleteHashEntry (hePtr);
1.728 + }
1.729 + }
1.730 +#endif
1.731 +
1.732 + TclHandleRelease(codePtr->interpHandle);
1.733 + ckfree((char *) codePtr);
1.734 +}
1.735 +
1.736 +/*
1.737 + *----------------------------------------------------------------------
1.738 + *
1.739 + * TclInitCompileEnv --
1.740 + *
1.741 + * Initializes a CompileEnv compilation environment structure for the
1.742 + * compilation of a string in an interpreter.
1.743 + *
1.744 + * Results:
1.745 + * None.
1.746 + *
1.747 + * Side effects:
1.748 + * The CompileEnv structure is initialized.
1.749 + *
1.750 + *----------------------------------------------------------------------
1.751 + */
1.752 +
1.753 +void
1.754 +#ifndef TCL_TIP280
1.755 +TclInitCompileEnv(interp, envPtr, string, numBytes)
1.756 +#else
1.757 +TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word)
1.758 +#endif
1.759 + Tcl_Interp *interp; /* The interpreter for which a CompileEnv
1.760 + * structure is initialized. */
1.761 + register CompileEnv *envPtr; /* Points to the CompileEnv structure to
1.762 + * initialize. */
1.763 + char *string; /* The source string to be compiled. */
1.764 + int numBytes; /* Number of bytes in source string. */
1.765 +#ifdef TCL_TIP280
1.766 + CONST CmdFrame* invoker; /* Location context invoking the bcc */
1.767 + int word; /* Index of the word in that context
1.768 + * getting compiled */
1.769 +#endif
1.770 +{
1.771 + Interp *iPtr = (Interp *) interp;
1.772 +
1.773 + envPtr->iPtr = iPtr;
1.774 + envPtr->source = string;
1.775 + envPtr->numSrcBytes = numBytes;
1.776 + envPtr->procPtr = iPtr->compiledProcPtr;
1.777 + envPtr->numCommands = 0;
1.778 + envPtr->exceptDepth = 0;
1.779 + envPtr->maxExceptDepth = 0;
1.780 + envPtr->maxStackDepth = 0;
1.781 + envPtr->currStackDepth = 0;
1.782 + TclInitLiteralTable(&(envPtr->localLitTable));
1.783 +
1.784 + envPtr->codeStart = envPtr->staticCodeSpace;
1.785 + envPtr->codeNext = envPtr->codeStart;
1.786 + envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
1.787 + envPtr->mallocedCodeArray = 0;
1.788 +
1.789 + envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
1.790 + envPtr->literalArrayNext = 0;
1.791 + envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
1.792 + envPtr->mallocedLiteralArray = 0;
1.793 +
1.794 + envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
1.795 + envPtr->exceptArrayNext = 0;
1.796 + envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
1.797 + envPtr->mallocedExceptArray = 0;
1.798 +
1.799 + envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
1.800 + envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
1.801 + envPtr->mallocedCmdMap = 0;
1.802 +
1.803 +#ifdef TCL_TIP280
1.804 + /*
1.805 + * TIP #280: Set up the extended command location information, based on
1.806 + * the context invoking the byte code compiler. This structure is used to
1.807 + * keep the per-word line information for all compiled commands.
1.808 + *
1.809 + * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the
1.810 + * non-compiling evaluator
1.811 + */
1.812 +
1.813 + envPtr->extCmdMapPtr = (ExtCmdLoc*) ckalloc (sizeof (ExtCmdLoc));
1.814 + envPtr->extCmdMapPtr->loc = NULL;
1.815 + envPtr->extCmdMapPtr->nloc = 0;
1.816 + envPtr->extCmdMapPtr->nuloc = 0;
1.817 + envPtr->extCmdMapPtr->path = NULL;
1.818 +
1.819 + if (invoker == NULL) {
1.820 + /* Initialize the compiler for relative counting */
1.821 +
1.822 + envPtr->line = 1;
1.823 + envPtr->extCmdMapPtr->type = (envPtr->procPtr
1.824 + ? TCL_LOCATION_PROC
1.825 + : TCL_LOCATION_BC);
1.826 + } else {
1.827 + /* Initialize the compiler using the context, making counting absolute
1.828 + * to that context. Note that the context can be byte code
1.829 + * execution. In that case we have to fill out the missing pieces
1.830 + * (line, path, ...). Which may make change the type as well.
1.831 + */
1.832 +
1.833 + if ((invoker->nline <= word) || (invoker->line[word] < 0)) {
1.834 + /* Word is not a literal, relative counting */
1.835 +
1.836 + envPtr->line = 1;
1.837 + envPtr->extCmdMapPtr->type = (envPtr->procPtr
1.838 + ? TCL_LOCATION_PROC
1.839 + : TCL_LOCATION_BC);
1.840 + } else {
1.841 + CmdFrame ctx = *invoker;
1.842 + int pc = 0;
1.843 +
1.844 + if (invoker->type == TCL_LOCATION_BC) {
1.845 + /* Note: Type BC => ctx.data.eval.path is not used.
1.846 + * ctx.data.tebc.codePtr is used instead.
1.847 + */
1.848 + TclGetSrcInfoForPc (&ctx);
1.849 + pc = 1;
1.850 + }
1.851 +
1.852 + envPtr->line = ctx.line [word];
1.853 + envPtr->extCmdMapPtr->type = ctx.type;
1.854 +
1.855 + if (ctx.type == TCL_LOCATION_SOURCE) {
1.856 + if (pc) {
1.857 + /* The reference 'TclGetSrcInfoForPc' made is transfered */
1.858 + envPtr->extCmdMapPtr->path = ctx.data.eval.path;
1.859 + ctx.data.eval.path = NULL;
1.860 + } else {
1.861 + /* We have a new reference here */
1.862 + envPtr->extCmdMapPtr->path = ctx.data.eval.path;
1.863 + Tcl_IncrRefCount (envPtr->extCmdMapPtr->path);
1.864 + }
1.865 + }
1.866 + }
1.867 + }
1.868 +#endif
1.869 +
1.870 + envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
1.871 + envPtr->auxDataArrayNext = 0;
1.872 + envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
1.873 + envPtr->mallocedAuxDataArray = 0;
1.874 +}
1.875 +
1.876 +/*
1.877 + *----------------------------------------------------------------------
1.878 + *
1.879 + * TclFreeCompileEnv --
1.880 + *
1.881 + * Free the storage allocated in a CompileEnv compilation environment
1.882 + * structure.
1.883 + *
1.884 + * Results:
1.885 + * None.
1.886 + *
1.887 + * Side effects:
1.888 + * Allocated storage in the CompileEnv structure is freed. Note that
1.889 + * its local literal table is not deleted and its literal objects are
1.890 + * not released. In addition, storage referenced by its auxiliary data
1.891 + * items is not freed. This is done so that, when compilation is
1.892 + * successful, "ownership" of these objects and aux data items is
1.893 + * handed over to the corresponding ByteCode structure.
1.894 + *
1.895 + *----------------------------------------------------------------------
1.896 + */
1.897 +
1.898 +void
1.899 +TclFreeCompileEnv(envPtr)
1.900 + register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
1.901 +{
1.902 + if (envPtr->mallocedCodeArray) {
1.903 + ckfree((char *) envPtr->codeStart);
1.904 + }
1.905 + if (envPtr->mallocedLiteralArray) {
1.906 + ckfree((char *) envPtr->literalArrayPtr);
1.907 + }
1.908 + if (envPtr->mallocedExceptArray) {
1.909 + ckfree((char *) envPtr->exceptArrayPtr);
1.910 + }
1.911 + if (envPtr->mallocedCmdMap) {
1.912 + ckfree((char *) envPtr->cmdMapPtr);
1.913 + }
1.914 + if (envPtr->mallocedAuxDataArray) {
1.915 + ckfree((char *) envPtr->auxDataArrayPtr);
1.916 + }
1.917 +}
1.918 +
1.919 +#ifdef TCL_TIP280
1.920 +/*
1.921 + *----------------------------------------------------------------------
1.922 + *
1.923 + * TclWordKnownAtCompileTime --
1.924 + *
1.925 + * Test whether the value of a token is completely known at compile time.
1.926 + *
1.927 + * Results:
1.928 + * Returns true if the tokenPtr argument points to a word value that is
1.929 + * completely known at compile time. Generally, values that are known at
1.930 + * compile time can be compiled to their values, while values that cannot
1.931 + * be known until substitution at runtime must be compiled to bytecode
1.932 + * instructions that perform that substitution. For several commands,
1.933 + * whether or not arguments are known at compile time determine whether
1.934 + * it is worthwhile to compile at all.
1.935 + *
1.936 + * Side effects:
1.937 + * None.
1.938 + *
1.939 + * TIP #280
1.940 + *----------------------------------------------------------------------
1.941 + */
1.942 +
1.943 +int
1.944 +TclWordKnownAtCompileTime (tokenPtr)
1.945 + Tcl_Token* tokenPtr;
1.946 +{
1.947 + int i;
1.948 + Tcl_Token* sub;
1.949 +
1.950 + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;};
1.951 + if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;};
1.952 +
1.953 + /* Check the sub tokens of the word. It is a literal if we find
1.954 + * only BS and TEXT tokens */
1.955 +
1.956 + for (i=0, sub = tokenPtr + 1;
1.957 + i < tokenPtr->numComponents;
1.958 + i++, sub ++) {
1.959 + if (sub->type == TCL_TOKEN_TEXT) continue;
1.960 + if (sub->type == TCL_TOKEN_BS) continue;
1.961 + return 0;
1.962 + }
1.963 + return 1;
1.964 +}
1.965 +#endif
1.966 +
1.967 +/*
1.968 + *----------------------------------------------------------------------
1.969 + *
1.970 + * TclCompileScript --
1.971 + *
1.972 + * Compile a Tcl script in a string.
1.973 + *
1.974 + * Results:
1.975 + * The return value is TCL_OK on a successful compilation and TCL_ERROR
1.976 + * on failure. If TCL_ERROR is returned, then the interpreter's result
1.977 + * contains an error message.
1.978 + *
1.979 + * interp->termOffset is set to the offset of the character in the
1.980 + * script just after the last one successfully processed; this will be
1.981 + * the offset of the ']' if (flags & TCL_BRACKET_TERM).
1.982 + *
1.983 + * Side effects:
1.984 + * Adds instructions to envPtr to evaluate the script at runtime.
1.985 + *
1.986 + *----------------------------------------------------------------------
1.987 + */
1.988 +
1.989 +int
1.990 +TclCompileScript(interp, script, numBytes, nested, envPtr)
1.991 + Tcl_Interp *interp; /* Used for error and status reporting.
1.992 + * Also serves as context for finding and
1.993 + * compiling commands. May not be NULL. */
1.994 + CONST char *script; /* The source script to compile. */
1.995 + int numBytes; /* Number of bytes in script. If < 0, the
1.996 + * script consists of all bytes up to the
1.997 + * first null character. */
1.998 + int nested; /* Non-zero means this is a nested command:
1.999 + * close bracket ']' should be considered a
1.1000 + * command terminator. If zero, close
1.1001 + * bracket has no special meaning. */
1.1002 + CompileEnv *envPtr; /* Holds resulting instructions. */
1.1003 +{
1.1004 + Interp *iPtr = (Interp *) interp;
1.1005 + Tcl_Parse parse;
1.1006 + int lastTopLevelCmdIndex = -1;
1.1007 + /* Index of most recent toplevel command in
1.1008 + * the command location table. Initialized
1.1009 + * to avoid compiler warning. */
1.1010 + int startCodeOffset = -1; /* Offset of first byte of current command's
1.1011 + * code. Init. to avoid compiler warning. */
1.1012 + unsigned char *entryCodeNext = envPtr->codeNext;
1.1013 + CONST char *p, *next;
1.1014 + Namespace *cmdNsPtr;
1.1015 + Command *cmdPtr;
1.1016 + Tcl_Token *tokenPtr;
1.1017 + int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
1.1018 + int commandLength, objIndex, code;
1.1019 + Tcl_DString ds;
1.1020 +
1.1021 +#ifdef TCL_TIP280
1.1022 + /* TIP #280 */
1.1023 + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr;
1.1024 + int* wlines;
1.1025 + int wlineat, cmdLine;
1.1026 +#endif
1.1027 +
1.1028 + Tcl_DStringInit(&ds);
1.1029 +
1.1030 + if (numBytes < 0) {
1.1031 + numBytes = strlen(script);
1.1032 + }
1.1033 + Tcl_ResetResult(interp);
1.1034 + isFirstCmd = 1;
1.1035 +
1.1036 + /*
1.1037 + * Each iteration through the following loop compiles the next
1.1038 + * command from the script.
1.1039 + */
1.1040 +
1.1041 + p = script;
1.1042 + bytesLeft = numBytes;
1.1043 + gotParse = 0;
1.1044 +#ifdef TCL_TIP280
1.1045 + cmdLine = envPtr->line;
1.1046 +#endif
1.1047 +
1.1048 + do {
1.1049 + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
1.1050 + code = TCL_ERROR;
1.1051 + goto error;
1.1052 + }
1.1053 + gotParse = 1;
1.1054 + if (nested) {
1.1055 + /*
1.1056 + * This is an unusual situation where the caller has passed us
1.1057 + * a non-zero value for "nested". How unusual? Well, this
1.1058 + * procedure, TclCompileScript, is internal to Tcl, so all
1.1059 + * callers should be within Tcl itself. All but one of those
1.1060 + * callers explicitly pass in (nested = 0). The exceptional
1.1061 + * caller is TclSetByteCodeFromAny, which will pass in
1.1062 + * (nested = 1) if and only if the flag TCL_BRACKET_TERM
1.1063 + * is set in the evalFlags field of interp.
1.1064 + *
1.1065 + * It appears that the TCL_BRACKET_TERM flag is only ever set
1.1066 + * by Tcl_SubstObj, and it immediately calls Tcl_EvalEx
1.1067 + * which clears the flag before passing the interp along.
1.1068 + * So, I don't think this procedure, TclCompileScript, is
1.1069 + * **ever** called with (nested != 0).
1.1070 + * (The testsuite indeed doesn't exercise this code. MS)
1.1071 + *
1.1072 + * This means that the branches in this procedure that are
1.1073 + * only active when (nested != 0) are probably never exercised.
1.1074 + * This means that any bugs in them go unnoticed, and any bug
1.1075 + * fixes in them have a semi-theoretical nature.
1.1076 + *
1.1077 + * All that said, the spec for this procedure says it should
1.1078 + * handle the (nested != 0) case, so here's an attempt to fix
1.1079 + * bugs (Tcl Bug 681841) in that case. Just in case some
1.1080 + * callers eventually come along and expect it to work...
1.1081 + */
1.1082 +
1.1083 + if (parse.term == (script + numBytes)) {
1.1084 + /*
1.1085 + * The (nested != 0) case is meant to indicate that the
1.1086 + * caller found an open bracket ([) and asked us to
1.1087 + * parse and compile Tcl commands up to the matching
1.1088 + * close bracket (]). We have to detect and handle
1.1089 + * the case where the close bracket is missing.
1.1090 + */
1.1091 +
1.1092 + Tcl_SetObjResult(interp,
1.1093 + Tcl_NewStringObj("missing close-bracket", -1));
1.1094 + code = TCL_ERROR;
1.1095 + goto error;
1.1096 + }
1.1097 + }
1.1098 + if (parse.numWords > 0) {
1.1099 + /*
1.1100 + * If not the first command, pop the previous command's result
1.1101 + * and, if we're compiling a top level command, update the last
1.1102 + * command's code size to account for the pop instruction.
1.1103 + */
1.1104 +
1.1105 + if (!isFirstCmd) {
1.1106 + TclEmitOpcode(INST_POP, envPtr);
1.1107 + if (!nested) {
1.1108 + envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
1.1109 + (envPtr->codeNext - envPtr->codeStart)
1.1110 + - startCodeOffset;
1.1111 + }
1.1112 + }
1.1113 +
1.1114 + /*
1.1115 + * Determine the actual length of the command.
1.1116 + */
1.1117 +
1.1118 + commandLength = parse.commandSize;
1.1119 + if (parse.term == parse.commandStart + commandLength - 1) {
1.1120 + /*
1.1121 + * The command terminator character (such as ; or ]) is
1.1122 + * the last character in the parsed command. Reduce the
1.1123 + * length by one so that the trace message doesn't include
1.1124 + * the terminator character.
1.1125 + */
1.1126 +
1.1127 + commandLength -= 1;
1.1128 + }
1.1129 +
1.1130 +#ifdef TCL_COMPILE_DEBUG
1.1131 + /*
1.1132 + * If tracing, print a line for each top level command compiled.
1.1133 + */
1.1134 +
1.1135 + if ((tclTraceCompile >= 1)
1.1136 + && !nested && (envPtr->procPtr == NULL)) {
1.1137 + fprintf(stdout, " Compiling: ");
1.1138 + TclPrintSource(stdout, parse.commandStart,
1.1139 + TclMin(commandLength, 55));
1.1140 + fprintf(stdout, "\n");
1.1141 + }
1.1142 +#endif
1.1143 + /*
1.1144 + * Each iteration of the following loop compiles one word
1.1145 + * from the command.
1.1146 + */
1.1147 +
1.1148 + envPtr->numCommands++;
1.1149 + currCmdIndex = (envPtr->numCommands - 1);
1.1150 + if (!nested) {
1.1151 + lastTopLevelCmdIndex = currCmdIndex;
1.1152 + }
1.1153 + startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1.1154 + EnterCmdStartData(envPtr, currCmdIndex,
1.1155 + (parse.commandStart - envPtr->source), startCodeOffset);
1.1156 +
1.1157 +#ifdef TCL_TIP280
1.1158 + /* TIP #280. Scan the words and compute the extended location
1.1159 + * information. The map first contain full per-word line
1.1160 + * information for use by the compiler. This is later replaced by
1.1161 + * a reduced form which signals non-literal words, stored in
1.1162 + * 'wlines'.
1.1163 + */
1.1164 +
1.1165 + TclAdvanceLines (&cmdLine, p, parse.commandStart);
1.1166 + EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source),
1.1167 + parse.tokenPtr, parse.commandStart, parse.commandSize,
1.1168 + parse.numWords, cmdLine, &wlines);
1.1169 + wlineat = eclPtr->nuloc - 1;
1.1170 +#endif
1.1171 +
1.1172 + for (wordIdx = 0, tokenPtr = parse.tokenPtr;
1.1173 + wordIdx < parse.numWords;
1.1174 + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
1.1175 +#ifdef TCL_TIP280
1.1176 + envPtr->line = eclPtr->loc [wlineat].line [wordIdx];
1.1177 +#endif
1.1178 + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
1.1179 + /*
1.1180 + * If this is the first word and the command has a
1.1181 + * compile procedure, let it compile the command.
1.1182 + */
1.1183 +
1.1184 + if (wordIdx == 0) {
1.1185 + if (envPtr->procPtr != NULL) {
1.1186 + cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
1.1187 + } else {
1.1188 + cmdNsPtr = NULL; /* use current NS */
1.1189 + }
1.1190 +
1.1191 + /*
1.1192 + * We copy the string before trying to find the command
1.1193 + * by name. We used to modify the string in place, but
1.1194 + * this is not safe because the name resolution
1.1195 + * handlers could have side effects that rely on the
1.1196 + * unmodified string.
1.1197 + */
1.1198 +
1.1199 + Tcl_DStringSetLength(&ds, 0);
1.1200 + Tcl_DStringAppend(&ds, tokenPtr[1].start,
1.1201 + tokenPtr[1].size);
1.1202 +
1.1203 + cmdPtr = (Command *) Tcl_FindCommand(interp,
1.1204 + Tcl_DStringValue(&ds),
1.1205 + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
1.1206 +
1.1207 + if ((cmdPtr != NULL)
1.1208 + && (cmdPtr->compileProc != NULL)
1.1209 + && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES)
1.1210 + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
1.1211 + int savedNumCmds = envPtr->numCommands;
1.1212 + unsigned int savedCodeNext =
1.1213 + envPtr->codeNext - envPtr->codeStart;
1.1214 +
1.1215 + code = (*(cmdPtr->compileProc))(interp, &parse,
1.1216 + envPtr);
1.1217 + if (code == TCL_OK) {
1.1218 + goto finishCommand;
1.1219 + } else if (code == TCL_OUT_LINE_COMPILE) {
1.1220 + /*
1.1221 + * Restore numCommands and codeNext to their correct
1.1222 + * values, removing any commands compiled before
1.1223 + * TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055]
1.1224 + */
1.1225 + envPtr->numCommands = savedNumCmds;
1.1226 + envPtr->codeNext = envPtr->codeStart + savedCodeNext;
1.1227 + } else { /* an error */
1.1228 + /*
1.1229 + * There was a compilation error, the last
1.1230 + * command did not get compiled into (*envPtr).
1.1231 + * Decrement the number of commands
1.1232 + * claimed to be in (*envPtr).
1.1233 + */
1.1234 + envPtr->numCommands--;
1.1235 + goto log;
1.1236 + }
1.1237 + }
1.1238 +
1.1239 + /*
1.1240 + * No compile procedure so push the word. If the
1.1241 + * command was found, push a CmdName object to
1.1242 + * reduce runtime lookups.
1.1243 + */
1.1244 +
1.1245 + objIndex = TclRegisterNewLiteral(envPtr,
1.1246 + tokenPtr[1].start, tokenPtr[1].size);
1.1247 + if (cmdPtr != NULL) {
1.1248 + TclSetCmdNameObj(interp,
1.1249 + envPtr->literalArrayPtr[objIndex].objPtr,
1.1250 + cmdPtr);
1.1251 + }
1.1252 + } else {
1.1253 + objIndex = TclRegisterNewLiteral(envPtr,
1.1254 + tokenPtr[1].start, tokenPtr[1].size);
1.1255 + }
1.1256 + TclEmitPush(objIndex, envPtr);
1.1257 + } else {
1.1258 + /*
1.1259 + * The word is not a simple string of characters.
1.1260 + */
1.1261 + code = TclCompileTokens(interp, tokenPtr+1,
1.1262 + tokenPtr->numComponents, envPtr);
1.1263 + if (code != TCL_OK) {
1.1264 + goto log;
1.1265 + }
1.1266 + }
1.1267 + }
1.1268 +
1.1269 + /*
1.1270 + * Emit an invoke instruction for the command. We skip this
1.1271 + * if a compile procedure was found for the command.
1.1272 + */
1.1273 +
1.1274 + if (wordIdx > 0) {
1.1275 + if (wordIdx <= 255) {
1.1276 + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
1.1277 + } else {
1.1278 + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
1.1279 + }
1.1280 + }
1.1281 +
1.1282 + /*
1.1283 + * Update the compilation environment structure and record the
1.1284 + * offsets of the source and code for the command.
1.1285 + */
1.1286 +
1.1287 + finishCommand:
1.1288 + EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
1.1289 + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
1.1290 + isFirstCmd = 0;
1.1291 +
1.1292 +#ifdef TCL_TIP280
1.1293 + /* TIP #280: Free full form of per-word line data and insert
1.1294 + * the reduced form now
1.1295 + */
1.1296 + ckfree ((char*) eclPtr->loc [wlineat].line);
1.1297 + eclPtr->loc [wlineat].line = wlines;
1.1298 +#endif
1.1299 + } /* end if parse.numWords > 0 */
1.1300 +
1.1301 + /*
1.1302 + * Advance to the next command in the script.
1.1303 + */
1.1304 +
1.1305 + next = parse.commandStart + parse.commandSize;
1.1306 + bytesLeft -= (next - p);
1.1307 + p = next;
1.1308 +#ifdef TCL_TIP280
1.1309 + /* TIP #280 : Track lines in the just compiled command */
1.1310 + TclAdvanceLines (&cmdLine, parse.commandStart, p);
1.1311 +#endif
1.1312 + Tcl_FreeParse(&parse);
1.1313 + gotParse = 0;
1.1314 + if (nested && (*parse.term == ']')) {
1.1315 + /*
1.1316 + * We get here in the special case where TCL_BRACKET_TERM was
1.1317 + * set in the interpreter and the latest parsed command was
1.1318 + * terminated by the matching close-bracket we were looking for.
1.1319 + * Stop compilation.
1.1320 + */
1.1321 +
1.1322 + break;
1.1323 + }
1.1324 + } while (bytesLeft > 0);
1.1325 +
1.1326 + /*
1.1327 + * If the source script yielded no instructions (e.g., if it was empty),
1.1328 + * push an empty string as the command's result.
1.1329 + */
1.1330 +
1.1331 + if (envPtr->codeNext == entryCodeNext) {
1.1332 + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
1.1333 + envPtr);
1.1334 + }
1.1335 +
1.1336 + if (nested) {
1.1337 + /*
1.1338 + * When (nested != 0) back up 1 character to have
1.1339 + * iPtr->termOffset indicate the offset to the matching
1.1340 + * close-bracket.
1.1341 + */
1.1342 +
1.1343 + iPtr->termOffset = (p - 1) - script;
1.1344 + } else {
1.1345 + iPtr->termOffset = (p - script);
1.1346 + }
1.1347 + Tcl_DStringFree(&ds);
1.1348 + return TCL_OK;
1.1349 +
1.1350 + error:
1.1351 + /*
1.1352 + * Generate various pieces of error information, such as the line
1.1353 + * number where the error occurred and information to add to the
1.1354 + * errorInfo variable. Then free resources that had been allocated
1.1355 + * to the command.
1.1356 + */
1.1357 +
1.1358 + commandLength = parse.commandSize;
1.1359 + if (parse.term == parse.commandStart + commandLength - 1) {
1.1360 + /*
1.1361 + * The terminator character (such as ; or ]) of the command where
1.1362 + * the error occurred is the last character in the parsed command.
1.1363 + * Reduce the length by one so that the error message doesn't
1.1364 + * include the terminator character.
1.1365 + */
1.1366 +
1.1367 + commandLength -= 1;
1.1368 + }
1.1369 +
1.1370 + log:
1.1371 + LogCompilationInfo(interp, script, parse.commandStart, commandLength);
1.1372 + if (gotParse) {
1.1373 + Tcl_FreeParse(&parse);
1.1374 + }
1.1375 + iPtr->termOffset = (p - script);
1.1376 + Tcl_DStringFree(&ds);
1.1377 + return code;
1.1378 +}
1.1379 +
1.1380 +/*
1.1381 + *----------------------------------------------------------------------
1.1382 + *
1.1383 + * TclCompileTokens --
1.1384 + *
1.1385 + * Given an array of tokens parsed from a Tcl command (e.g., the tokens
1.1386 + * that make up a word) this procedure emits instructions to evaluate
1.1387 + * the tokens and concatenate their values to form a single result
1.1388 + * value on the interpreter's runtime evaluation stack.
1.1389 + *
1.1390 + * Results:
1.1391 + * The return value is a standard Tcl result. If an error occurs, an
1.1392 + * error message is left in the interpreter's result.
1.1393 + *
1.1394 + * Side effects:
1.1395 + * Instructions are added to envPtr to push and evaluate the tokens
1.1396 + * at runtime.
1.1397 + *
1.1398 + *----------------------------------------------------------------------
1.1399 + */
1.1400 +
1.1401 +int
1.1402 +TclCompileTokens(interp, tokenPtr, count, envPtr)
1.1403 + Tcl_Interp *interp; /* Used for error and status reporting. */
1.1404 + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
1.1405 + * to compile. */
1.1406 + int count; /* Number of tokens to consider at tokenPtr.
1.1407 + * Must be at least 1. */
1.1408 + CompileEnv *envPtr; /* Holds the resulting instructions. */
1.1409 +{
1.1410 + Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
1.1411 + * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
1.1412 + char buffer[TCL_UTF_MAX];
1.1413 + CONST char *name, *p;
1.1414 + int numObjsToConcat, nameBytes, localVarName, localVar;
1.1415 + int length, i, code;
1.1416 + unsigned char *entryCodeNext = envPtr->codeNext;
1.1417 +
1.1418 + Tcl_DStringInit(&textBuffer);
1.1419 + numObjsToConcat = 0;
1.1420 + for ( ; count > 0; count--, tokenPtr++) {
1.1421 + switch (tokenPtr->type) {
1.1422 + case TCL_TOKEN_TEXT:
1.1423 + Tcl_DStringAppend(&textBuffer, tokenPtr->start,
1.1424 + tokenPtr->size);
1.1425 + break;
1.1426 +
1.1427 + case TCL_TOKEN_BS:
1.1428 + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
1.1429 + buffer);
1.1430 + Tcl_DStringAppend(&textBuffer, buffer, length);
1.1431 + break;
1.1432 +
1.1433 + case TCL_TOKEN_COMMAND:
1.1434 + /*
1.1435 + * Push any accumulated chars appearing before the command.
1.1436 + */
1.1437 +
1.1438 + if (Tcl_DStringLength(&textBuffer) > 0) {
1.1439 + int literal;
1.1440 +
1.1441 + literal = TclRegisterLiteral(envPtr,
1.1442 + Tcl_DStringValue(&textBuffer),
1.1443 + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1.1444 + TclEmitPush(literal, envPtr);
1.1445 + numObjsToConcat++;
1.1446 + Tcl_DStringFree(&textBuffer);
1.1447 + }
1.1448 +
1.1449 + code = TclCompileScript(interp, tokenPtr->start+1,
1.1450 + tokenPtr->size-2, /*nested*/ 0, envPtr);
1.1451 + if (code != TCL_OK) {
1.1452 + goto error;
1.1453 + }
1.1454 + numObjsToConcat++;
1.1455 + break;
1.1456 +
1.1457 + case TCL_TOKEN_VARIABLE:
1.1458 + /*
1.1459 + * Push any accumulated chars appearing before the $<var>.
1.1460 + */
1.1461 +
1.1462 + if (Tcl_DStringLength(&textBuffer) > 0) {
1.1463 + int literal;
1.1464 +
1.1465 + literal = TclRegisterLiteral(envPtr,
1.1466 + Tcl_DStringValue(&textBuffer),
1.1467 + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1.1468 + TclEmitPush(literal, envPtr);
1.1469 + numObjsToConcat++;
1.1470 + Tcl_DStringFree(&textBuffer);
1.1471 + }
1.1472 +
1.1473 + /*
1.1474 + * Determine how the variable name should be handled: if it contains
1.1475 + * any namespace qualifiers it is not a local variable (localVarName=-1);
1.1476 + * if it looks like an array element and the token has a single component,
1.1477 + * it should not be created here [Bug 569438] (localVarName=0); otherwise,
1.1478 + * the local variable can safely be created (localVarName=1).
1.1479 + */
1.1480 +
1.1481 + name = tokenPtr[1].start;
1.1482 + nameBytes = tokenPtr[1].size;
1.1483 + localVarName = -1;
1.1484 + if (envPtr->procPtr != NULL) {
1.1485 + localVarName = 1;
1.1486 + for (i = 0, p = name; i < nameBytes; i++, p++) {
1.1487 + if ((*p == ':') && (i < (nameBytes-1))
1.1488 + && (*(p+1) == ':')) {
1.1489 + localVarName = -1;
1.1490 + break;
1.1491 + } else if ((*p == '(')
1.1492 + && (tokenPtr->numComponents == 1)
1.1493 + && (*(name + nameBytes - 1) == ')')) {
1.1494 + localVarName = 0;
1.1495 + break;
1.1496 + }
1.1497 + }
1.1498 + }
1.1499 +
1.1500 + /*
1.1501 + * Either push the variable's name, or find its index in
1.1502 + * the array of local variables in a procedure frame.
1.1503 + */
1.1504 +
1.1505 + localVar = -1;
1.1506 + if (localVarName != -1) {
1.1507 + localVar = TclFindCompiledLocal(name, nameBytes,
1.1508 + localVarName, /*flags*/ 0, envPtr->procPtr);
1.1509 + }
1.1510 + if (localVar < 0) {
1.1511 + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes),
1.1512 + envPtr);
1.1513 + }
1.1514 +
1.1515 + /*
1.1516 + * Emit instructions to load the variable.
1.1517 + */
1.1518 +
1.1519 + if (tokenPtr->numComponents == 1) {
1.1520 + if (localVar < 0) {
1.1521 + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
1.1522 + } else if (localVar <= 255) {
1.1523 + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
1.1524 + envPtr);
1.1525 + } else {
1.1526 + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
1.1527 + envPtr);
1.1528 + }
1.1529 + } else {
1.1530 + code = TclCompileTokens(interp, tokenPtr+2,
1.1531 + tokenPtr->numComponents-1, envPtr);
1.1532 + if (code != TCL_OK) {
1.1533 + char errorBuffer[150];
1.1534 + sprintf(errorBuffer,
1.1535 + "\n (parsing index for array \"%.*s\")",
1.1536 + ((nameBytes > 100)? 100 : nameBytes), name);
1.1537 + Tcl_AddObjErrorInfo(interp, errorBuffer, -1);
1.1538 + goto error;
1.1539 + }
1.1540 + if (localVar < 0) {
1.1541 + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
1.1542 + } else if (localVar <= 255) {
1.1543 + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
1.1544 + envPtr);
1.1545 + } else {
1.1546 + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
1.1547 + envPtr);
1.1548 + }
1.1549 + }
1.1550 + numObjsToConcat++;
1.1551 + count -= tokenPtr->numComponents;
1.1552 + tokenPtr += tokenPtr->numComponents;
1.1553 + break;
1.1554 +
1.1555 + default:
1.1556 + panic("Unexpected token type in TclCompileTokens");
1.1557 + }
1.1558 + }
1.1559 +
1.1560 + /*
1.1561 + * Push any accumulated characters appearing at the end.
1.1562 + */
1.1563 +
1.1564 + if (Tcl_DStringLength(&textBuffer) > 0) {
1.1565 + int literal;
1.1566 +
1.1567 + literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
1.1568 + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1.1569 + TclEmitPush(literal, envPtr);
1.1570 + numObjsToConcat++;
1.1571 + }
1.1572 +
1.1573 + /*
1.1574 + * If necessary, concatenate the parts of the word.
1.1575 + */
1.1576 +
1.1577 + while (numObjsToConcat > 255) {
1.1578 + TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
1.1579 + numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
1.1580 + }
1.1581 + if (numObjsToConcat > 1) {
1.1582 + TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
1.1583 + }
1.1584 +
1.1585 + /*
1.1586 + * If the tokens yielded no instructions, push an empty string.
1.1587 + */
1.1588 +
1.1589 + if (envPtr->codeNext == entryCodeNext) {
1.1590 + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
1.1591 + envPtr);
1.1592 + }
1.1593 + Tcl_DStringFree(&textBuffer);
1.1594 + return TCL_OK;
1.1595 +
1.1596 + error:
1.1597 + Tcl_DStringFree(&textBuffer);
1.1598 + return code;
1.1599 +}
1.1600 +
1.1601 +/*
1.1602 + *----------------------------------------------------------------------
1.1603 + *
1.1604 + * TclCompileCmdWord --
1.1605 + *
1.1606 + * Given an array of parse tokens for a word containing one or more Tcl
1.1607 + * commands, emit inline instructions to execute them. This procedure
1.1608 + * differs from TclCompileTokens in that a simple word such as a loop
1.1609 + * body enclosed in braces is not just pushed as a string, but is
1.1610 + * itself parsed into tokens and compiled.
1.1611 + *
1.1612 + * Results:
1.1613 + * The return value is a standard Tcl result. If an error occurs, an
1.1614 + * error message is left in the interpreter's result.
1.1615 + *
1.1616 + * Side effects:
1.1617 + * Instructions are added to envPtr to execute the tokens at runtime.
1.1618 + *
1.1619 + *----------------------------------------------------------------------
1.1620 + */
1.1621 +
1.1622 +int
1.1623 +TclCompileCmdWord(interp, tokenPtr, count, envPtr)
1.1624 + Tcl_Interp *interp; /* Used for error and status reporting. */
1.1625 + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
1.1626 + * for a command word to compile inline. */
1.1627 + int count; /* Number of tokens to consider at tokenPtr.
1.1628 + * Must be at least 1. */
1.1629 + CompileEnv *envPtr; /* Holds the resulting instructions. */
1.1630 +{
1.1631 + int code;
1.1632 +
1.1633 + /*
1.1634 + * Handle the common case: if there is a single text token, compile it
1.1635 + * into an inline sequence of instructions.
1.1636 + */
1.1637 +
1.1638 + if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
1.1639 + code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
1.1640 + /*nested*/ 0, envPtr);
1.1641 + return code;
1.1642 + }
1.1643 +
1.1644 + /*
1.1645 + * Multiple tokens or the single token involves substitutions. Emit
1.1646 + * instructions to invoke the eval command procedure at runtime on the
1.1647 + * result of evaluating the tokens.
1.1648 + */
1.1649 +
1.1650 + code = TclCompileTokens(interp, tokenPtr, count, envPtr);
1.1651 + if (code != TCL_OK) {
1.1652 + return code;
1.1653 + }
1.1654 + TclEmitOpcode(INST_EVAL_STK, envPtr);
1.1655 + return TCL_OK;
1.1656 +}
1.1657 +
1.1658 +/*
1.1659 + *----------------------------------------------------------------------
1.1660 + *
1.1661 + * TclCompileExprWords --
1.1662 + *
1.1663 + * Given an array of parse tokens representing one or more words that
1.1664 + * contain a Tcl expression, emit inline instructions to execute the
1.1665 + * expression. This procedure differs from TclCompileExpr in that it
1.1666 + * supports Tcl's two-level substitution semantics for expressions that
1.1667 + * appear as command words.
1.1668 + *
1.1669 + * Results:
1.1670 + * The return value is a standard Tcl result. If an error occurs, an
1.1671 + * error message is left in the interpreter's result.
1.1672 + *
1.1673 + * Side effects:
1.1674 + * Instructions are added to envPtr to execute the expression.
1.1675 + *
1.1676 + *----------------------------------------------------------------------
1.1677 + */
1.1678 +
1.1679 +int
1.1680 +TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
1.1681 + Tcl_Interp *interp; /* Used for error and status reporting. */
1.1682 + Tcl_Token *tokenPtr; /* Points to first in an array of word
1.1683 + * tokens tokens for the expression to
1.1684 + * compile inline. */
1.1685 + int numWords; /* Number of word tokens starting at
1.1686 + * tokenPtr. Must be at least 1. Each word
1.1687 + * token contains one or more subtokens. */
1.1688 + CompileEnv *envPtr; /* Holds the resulting instructions. */
1.1689 +{
1.1690 + Tcl_Token *wordPtr;
1.1691 + int numBytes, i, code;
1.1692 + CONST char *script;
1.1693 +
1.1694 + code = TCL_OK;
1.1695 +
1.1696 + /*
1.1697 + * If the expression is a single word that doesn't require
1.1698 + * substitutions, just compile its string into inline instructions.
1.1699 + */
1.1700 +
1.1701 + if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
1.1702 + script = tokenPtr[1].start;
1.1703 + numBytes = tokenPtr[1].size;
1.1704 + code = TclCompileExpr(interp, script, numBytes, envPtr);
1.1705 + return code;
1.1706 + }
1.1707 +
1.1708 + /*
1.1709 + * Emit code to call the expr command proc at runtime. Concatenate the
1.1710 + * (already substituted once) expr tokens with a space between each.
1.1711 + */
1.1712 +
1.1713 + wordPtr = tokenPtr;
1.1714 + for (i = 0; i < numWords; i++) {
1.1715 + code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
1.1716 + envPtr);
1.1717 + if (code != TCL_OK) {
1.1718 + break;
1.1719 + }
1.1720 + if (i < (numWords - 1)) {
1.1721 + TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
1.1722 + envPtr);
1.1723 + }
1.1724 + wordPtr += (wordPtr->numComponents + 1);
1.1725 + }
1.1726 + if (code == TCL_OK) {
1.1727 + int concatItems = 2*numWords - 1;
1.1728 + while (concatItems > 255) {
1.1729 + TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
1.1730 + concatItems -= 254;
1.1731 + }
1.1732 + if (concatItems > 1) {
1.1733 + TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
1.1734 + }
1.1735 + TclEmitOpcode(INST_EXPR_STK, envPtr);
1.1736 + }
1.1737 +
1.1738 + return code;
1.1739 +}
1.1740 +
1.1741 +/*
1.1742 + *----------------------------------------------------------------------
1.1743 + *
1.1744 + * TclInitByteCodeObj --
1.1745 + *
1.1746 + * Create a ByteCode structure and initialize it from a CompileEnv
1.1747 + * compilation environment structure. The ByteCode structure is
1.1748 + * smaller and contains just that information needed to execute
1.1749 + * the bytecode instructions resulting from compiling a Tcl script.
1.1750 + * The resulting structure is placed in the specified object.
1.1751 + *
1.1752 + * Results:
1.1753 + * A newly constructed ByteCode object is stored in the internal
1.1754 + * representation of the objPtr.
1.1755 + *
1.1756 + * Side effects:
1.1757 + * A single heap object is allocated to hold the new ByteCode structure
1.1758 + * and its code, object, command location, and aux data arrays. Note
1.1759 + * that "ownership" (i.e., the pointers to) the Tcl objects and aux
1.1760 + * data items will be handed over to the new ByteCode structure from
1.1761 + * the CompileEnv structure.
1.1762 + *
1.1763 + *----------------------------------------------------------------------
1.1764 + */
1.1765 +
1.1766 +void
1.1767 +TclInitByteCodeObj(objPtr, envPtr)
1.1768 + Tcl_Obj *objPtr; /* Points object that should be
1.1769 + * initialized, and whose string rep
1.1770 + * contains the source code. */
1.1771 + register CompileEnv *envPtr; /* Points to the CompileEnv structure from
1.1772 + * which to create a ByteCode structure. */
1.1773 +{
1.1774 + register ByteCode *codePtr;
1.1775 + size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
1.1776 + size_t auxDataArrayBytes, structureSize;
1.1777 + register unsigned char *p;
1.1778 +#ifdef TCL_COMPILE_DEBUG
1.1779 + unsigned char *nextPtr;
1.1780 +#endif
1.1781 + int numLitObjects = envPtr->literalArrayNext;
1.1782 + Namespace *namespacePtr;
1.1783 + int i;
1.1784 +#ifdef TCL_TIP280
1.1785 + int new;
1.1786 +#endif
1.1787 + Interp *iPtr;
1.1788 +
1.1789 + iPtr = envPtr->iPtr;
1.1790 +
1.1791 + codeBytes = (envPtr->codeNext - envPtr->codeStart);
1.1792 + objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
1.1793 + exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
1.1794 + auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
1.1795 + cmdLocBytes = GetCmdLocEncodingSize(envPtr);
1.1796 +
1.1797 + /*
1.1798 + * Compute the total number of bytes needed for this bytecode.
1.1799 + */
1.1800 +
1.1801 + structureSize = sizeof(ByteCode);
1.1802 + structureSize += TCL_ALIGN(codeBytes); /* align object array */
1.1803 + structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
1.1804 + structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
1.1805 + structureSize += auxDataArrayBytes;
1.1806 + structureSize += cmdLocBytes;
1.1807 +
1.1808 + if (envPtr->iPtr->varFramePtr != NULL) {
1.1809 + namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
1.1810 + } else {
1.1811 + namespacePtr = envPtr->iPtr->globalNsPtr;
1.1812 + }
1.1813 +
1.1814 + p = (unsigned char *) ckalloc((size_t) structureSize);
1.1815 + codePtr = (ByteCode *) p;
1.1816 + codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
1.1817 + codePtr->compileEpoch = iPtr->compileEpoch;
1.1818 + codePtr->nsPtr = namespacePtr;
1.1819 + codePtr->nsEpoch = namespacePtr->resolverEpoch;
1.1820 + codePtr->refCount = 1;
1.1821 + codePtr->flags = 0;
1.1822 + codePtr->source = envPtr->source;
1.1823 + codePtr->procPtr = envPtr->procPtr;
1.1824 +
1.1825 + codePtr->numCommands = envPtr->numCommands;
1.1826 + codePtr->numSrcBytes = envPtr->numSrcBytes;
1.1827 + codePtr->numCodeBytes = codeBytes;
1.1828 + codePtr->numLitObjects = numLitObjects;
1.1829 + codePtr->numExceptRanges = envPtr->exceptArrayNext;
1.1830 + codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
1.1831 + codePtr->numCmdLocBytes = cmdLocBytes;
1.1832 + codePtr->maxExceptDepth = envPtr->maxExceptDepth;
1.1833 + codePtr->maxStackDepth = envPtr->maxStackDepth;
1.1834 +
1.1835 + p += sizeof(ByteCode);
1.1836 + codePtr->codeStart = p;
1.1837 + memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);
1.1838 +
1.1839 + p += TCL_ALIGN(codeBytes); /* align object array */
1.1840 + codePtr->objArrayPtr = (Tcl_Obj **) p;
1.1841 + for (i = 0; i < numLitObjects; i++) {
1.1842 + codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
1.1843 + }
1.1844 +
1.1845 + p += TCL_ALIGN(objArrayBytes); /* align exception range array */
1.1846 + if (exceptArrayBytes > 0) {
1.1847 + codePtr->exceptArrayPtr = (ExceptionRange *) p;
1.1848 + memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,
1.1849 + (size_t) exceptArrayBytes);
1.1850 + } else {
1.1851 + codePtr->exceptArrayPtr = NULL;
1.1852 + }
1.1853 +
1.1854 + p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
1.1855 + if (auxDataArrayBytes > 0) {
1.1856 + codePtr->auxDataArrayPtr = (AuxData *) p;
1.1857 + memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
1.1858 + (size_t) auxDataArrayBytes);
1.1859 + } else {
1.1860 + codePtr->auxDataArrayPtr = NULL;
1.1861 + }
1.1862 +
1.1863 + p += auxDataArrayBytes;
1.1864 +#ifndef TCL_COMPILE_DEBUG
1.1865 + EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
1.1866 +#else
1.1867 + nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
1.1868 + if (((size_t)(nextPtr - p)) != cmdLocBytes) {
1.1869 + panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
1.1870 + }
1.1871 +#endif
1.1872 +
1.1873 + /*
1.1874 + * Record various compilation-related statistics about the new ByteCode
1.1875 + * structure. Don't include overhead for statistics-related fields.
1.1876 + */
1.1877 +
1.1878 +#ifdef TCL_COMPILE_STATS
1.1879 + codePtr->structureSize = structureSize
1.1880 + - (sizeof(size_t) + sizeof(Tcl_Time));
1.1881 + Tcl_GetTime(&(codePtr->createTime));
1.1882 +
1.1883 + RecordByteCodeStats(codePtr);
1.1884 +#endif /* TCL_COMPILE_STATS */
1.1885 +
1.1886 + /*
1.1887 + * Free the old internal rep then convert the object to a
1.1888 + * bytecode object by making its internal rep point to the just
1.1889 + * compiled ByteCode.
1.1890 + */
1.1891 +
1.1892 + if ((objPtr->typePtr != NULL) &&
1.1893 + (objPtr->typePtr->freeIntRepProc != NULL)) {
1.1894 + (*objPtr->typePtr->freeIntRepProc)(objPtr);
1.1895 + }
1.1896 + objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
1.1897 + objPtr->typePtr = &tclByteCodeType;
1.1898 +
1.1899 +#ifdef TCL_TIP280
1.1900 + /* TIP #280. Associate the extended per-word line information with the
1.1901 + * byte code object (internal rep), for use with the bc compiler.
1.1902 + */
1.1903 +
1.1904 + Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->lineBCPtr, (char*) codePtr, &new),
1.1905 + envPtr->extCmdMapPtr);
1.1906 + envPtr->extCmdMapPtr = NULL;
1.1907 +#endif
1.1908 +}
1.1909 +
1.1910 +/*
1.1911 + *----------------------------------------------------------------------
1.1912 + *
1.1913 + * LogCompilationInfo --
1.1914 + *
1.1915 + * This procedure is invoked after an error occurs during compilation.
1.1916 + * It adds information to the "errorInfo" variable to describe the
1.1917 + * command that was being compiled when the error occurred.
1.1918 + *
1.1919 + * Results:
1.1920 + * None.
1.1921 + *
1.1922 + * Side effects:
1.1923 + * Information about the command is added to errorInfo and the
1.1924 + * line number stored internally in the interpreter is set. If this
1.1925 + * is the first call to this procedure or Tcl_AddObjErrorInfo since
1.1926 + * an error occurred, then old information in errorInfo is
1.1927 + * deleted.
1.1928 + *
1.1929 + *----------------------------------------------------------------------
1.1930 + */
1.1931 +
1.1932 +static void
1.1933 +LogCompilationInfo(interp, script, command, length)
1.1934 + Tcl_Interp *interp; /* Interpreter in which to log the
1.1935 + * information. */
1.1936 + CONST char *script; /* First character in script containing
1.1937 + * command (must be <= command). */
1.1938 + CONST char *command; /* First character in command that
1.1939 + * generated the error. */
1.1940 + int length; /* Number of bytes in command (-1 means
1.1941 + * use all bytes up to first null byte). */
1.1942 +{
1.1943 + char buffer[200];
1.1944 + register CONST char *p;
1.1945 + char *ellipsis = "";
1.1946 + Interp *iPtr = (Interp *) interp;
1.1947 +
1.1948 + if (iPtr->flags & ERR_ALREADY_LOGGED) {
1.1949 + /*
1.1950 + * Someone else has already logged error information for this
1.1951 + * command; we shouldn't add anything more.
1.1952 + */
1.1953 +
1.1954 + return;
1.1955 + }
1.1956 +
1.1957 + /*
1.1958 + * Compute the line number where the error occurred.
1.1959 + */
1.1960 +
1.1961 + iPtr->errorLine = 1;
1.1962 + for (p = script; p != command; p++) {
1.1963 + if (*p == '\n') {
1.1964 + iPtr->errorLine++;
1.1965 + }
1.1966 + }
1.1967 +
1.1968 + /*
1.1969 + * Create an error message to add to errorInfo, including up to a
1.1970 + * maximum number of characters of the command.
1.1971 + */
1.1972 +
1.1973 + if (length < 0) {
1.1974 + length = strlen(command);
1.1975 + }
1.1976 + if (length > 150) {
1.1977 + length = 150;
1.1978 + ellipsis = "...";
1.1979 + }
1.1980 + while ( (command[length] & 0xC0) == 0x80 ) {
1.1981 + /*
1.1982 + * Back up truncation point so that we don't truncate in the
1.1983 + * middle of a multi-byte character (in UTF-8)
1.1984 + */
1.1985 + length--;
1.1986 + ellipsis = "...";
1.1987 + }
1.1988 + sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
1.1989 + length, command, ellipsis);
1.1990 + Tcl_AddObjErrorInfo(interp, buffer, -1);
1.1991 +}
1.1992 +
1.1993 +/*
1.1994 + *----------------------------------------------------------------------
1.1995 + *
1.1996 + * TclFindCompiledLocal --
1.1997 + *
1.1998 + * This procedure is called at compile time to look up and optionally
1.1999 + * allocate an entry ("slot") for a variable in a procedure's array of
1.2000 + * local variables. If the variable's name is NULL, a new temporary
1.2001 + * variable is always created. (Such temporary variables can only be
1.2002 + * referenced using their slot index.)
1.2003 + *
1.2004 + * Results:
1.2005 + * If create is 0 and the name is non-NULL, then if the variable is
1.2006 + * found, the index of its entry in the procedure's array of local
1.2007 + * variables is returned; otherwise -1 is returned. If name is NULL,
1.2008 + * the index of a new temporary variable is returned. Finally, if
1.2009 + * create is 1 and name is non-NULL, the index of a new entry is
1.2010 + * returned.
1.2011 + *
1.2012 + * Side effects:
1.2013 + * Creates and registers a new local variable if create is 1 and
1.2014 + * the variable is unknown, or if the name is NULL.
1.2015 + *
1.2016 + *----------------------------------------------------------------------
1.2017 + */
1.2018 +
1.2019 +int
1.2020 +TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
1.2021 + register CONST char *name; /* Points to first character of the name of
1.2022 + * a scalar or array variable. If NULL, a
1.2023 + * temporary var should be created. */
1.2024 + int nameBytes; /* Number of bytes in the name. */
1.2025 + int create; /* If 1, allocate a local frame entry for
1.2026 + * the variable if it is new. */
1.2027 + int flags; /* Flag bits for the compiled local if
1.2028 + * created. Only VAR_SCALAR, VAR_ARRAY, and
1.2029 + * VAR_LINK make sense. */
1.2030 + register Proc *procPtr; /* Points to structure describing procedure
1.2031 + * containing the variable reference. */
1.2032 +{
1.2033 + register CompiledLocal *localPtr;
1.2034 + int localVar = -1;
1.2035 + register int i;
1.2036 +
1.2037 + /*
1.2038 + * If not creating a temporary, does a local variable of the specified
1.2039 + * name already exist?
1.2040 + */
1.2041 +
1.2042 + if (name != NULL) {
1.2043 + int localCt = procPtr->numCompiledLocals;
1.2044 + localPtr = procPtr->firstLocalPtr;
1.2045 + for (i = 0; i < localCt; i++) {
1.2046 + if (!TclIsVarTemporary(localPtr)) {
1.2047 + char *localName = localPtr->name;
1.2048 + if ((nameBytes == localPtr->nameLength)
1.2049 + && (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
1.2050 + return i;
1.2051 + }
1.2052 + }
1.2053 + localPtr = localPtr->nextPtr;
1.2054 + }
1.2055 + }
1.2056 +
1.2057 + /*
1.2058 + * Create a new variable if appropriate.
1.2059 + */
1.2060 +
1.2061 + if (create || (name == NULL)) {
1.2062 + localVar = procPtr->numCompiledLocals;
1.2063 + localPtr = (CompiledLocal *) ckalloc((unsigned)
1.2064 + (sizeof(CompiledLocal) - sizeof(localPtr->name)
1.2065 + + nameBytes+1));
1.2066 + if (procPtr->firstLocalPtr == NULL) {
1.2067 + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
1.2068 + } else {
1.2069 + procPtr->lastLocalPtr->nextPtr = localPtr;
1.2070 + procPtr->lastLocalPtr = localPtr;
1.2071 + }
1.2072 + localPtr->nextPtr = NULL;
1.2073 + localPtr->nameLength = nameBytes;
1.2074 + localPtr->frameIndex = localVar;
1.2075 + localPtr->flags = flags | VAR_UNDEFINED;
1.2076 + if (name == NULL) {
1.2077 + localPtr->flags |= VAR_TEMPORARY;
1.2078 + }
1.2079 + localPtr->defValuePtr = NULL;
1.2080 + localPtr->resolveInfo = NULL;
1.2081 +
1.2082 + if (name != NULL) {
1.2083 + memcpy((VOID *) localPtr->name, (VOID *) name,
1.2084 + (size_t) nameBytes);
1.2085 + }
1.2086 + localPtr->name[nameBytes] = '\0';
1.2087 + procPtr->numCompiledLocals++;
1.2088 + }
1.2089 + return localVar;
1.2090 +}
1.2091 +
1.2092 +/*
1.2093 + *----------------------------------------------------------------------
1.2094 + *
1.2095 + * TclInitCompiledLocals --
1.2096 + *
1.2097 + * This routine is invoked in order to initialize the compiled
1.2098 + * locals table for a new call frame.
1.2099 + *
1.2100 + * Results:
1.2101 + * None.
1.2102 + *
1.2103 + * Side effects:
1.2104 + * May invoke various name resolvers in order to determine which
1.2105 + * variables are being referenced at runtime.
1.2106 + *
1.2107 + *----------------------------------------------------------------------
1.2108 + */
1.2109 +
1.2110 +void
1.2111 +TclInitCompiledLocals(interp, framePtr, nsPtr)
1.2112 + Tcl_Interp *interp; /* Current interpreter. */
1.2113 + CallFrame *framePtr; /* Call frame to initialize. */
1.2114 + Namespace *nsPtr; /* Pointer to current namespace. */
1.2115 +{
1.2116 + register CompiledLocal *localPtr;
1.2117 + Interp *iPtr = (Interp*) interp;
1.2118 + Tcl_ResolvedVarInfo *vinfo, *resVarInfo;
1.2119 + Var *varPtr = framePtr->compiledLocals;
1.2120 + Var *resolvedVarPtr;
1.2121 + ResolverScheme *resPtr;
1.2122 + int result;
1.2123 +
1.2124 + /*
1.2125 + * Initialize the array of local variables stored in the call frame.
1.2126 + * Some variables may have special resolution rules. In that case,
1.2127 + * we call their "resolver" procs to get our hands on the variable,
1.2128 + * and we make the compiled local a link to the real variable.
1.2129 + */
1.2130 +
1.2131 + for (localPtr = framePtr->procPtr->firstLocalPtr;
1.2132 + localPtr != NULL;
1.2133 + localPtr = localPtr->nextPtr) {
1.2134 +
1.2135 + /*
1.2136 + * Check to see if this local is affected by namespace or
1.2137 + * interp resolvers. The resolver to use is cached for the
1.2138 + * next invocation of the procedure.
1.2139 + */
1.2140 +
1.2141 + if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))
1.2142 + && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {
1.2143 + resPtr = iPtr->resolverPtr;
1.2144 +
1.2145 + if (nsPtr->compiledVarResProc) {
1.2146 + result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
1.2147 + localPtr->name, localPtr->nameLength,
1.2148 + (Tcl_Namespace *) nsPtr, &vinfo);
1.2149 + } else {
1.2150 + result = TCL_CONTINUE;
1.2151 + }
1.2152 +
1.2153 + while ((result == TCL_CONTINUE) && resPtr) {
1.2154 + if (resPtr->compiledVarResProc) {
1.2155 + result = (*resPtr->compiledVarResProc)(nsPtr->interp,
1.2156 + localPtr->name, localPtr->nameLength,
1.2157 + (Tcl_Namespace *) nsPtr, &vinfo);
1.2158 + }
1.2159 + resPtr = resPtr->nextPtr;
1.2160 + }
1.2161 + if (result == TCL_OK) {
1.2162 + localPtr->resolveInfo = vinfo;
1.2163 + localPtr->flags |= VAR_RESOLVED;
1.2164 + }
1.2165 + }
1.2166 +
1.2167 + /*
1.2168 + * Now invoke the resolvers to determine the exact variables that
1.2169 + * should be used.
1.2170 + */
1.2171 +
1.2172 + resVarInfo = localPtr->resolveInfo;
1.2173 + resolvedVarPtr = NULL;
1.2174 +
1.2175 + if (resVarInfo && resVarInfo->fetchProc) {
1.2176 + resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
1.2177 + resVarInfo);
1.2178 + }
1.2179 +
1.2180 + if (resolvedVarPtr) {
1.2181 + varPtr->name = localPtr->name; /* will be just '\0' if temp var */
1.2182 + varPtr->nsPtr = NULL;
1.2183 + varPtr->hPtr = NULL;
1.2184 + varPtr->refCount = 0;
1.2185 + varPtr->tracePtr = NULL;
1.2186 + varPtr->searchPtr = NULL;
1.2187 + varPtr->flags = 0;
1.2188 + TclSetVarLink(varPtr);
1.2189 + varPtr->value.linkPtr = resolvedVarPtr;
1.2190 + resolvedVarPtr->refCount++;
1.2191 + } else {
1.2192 + varPtr->value.objPtr = NULL;
1.2193 + varPtr->name = localPtr->name; /* will be just '\0' if temp var */
1.2194 + varPtr->nsPtr = NULL;
1.2195 + varPtr->hPtr = NULL;
1.2196 + varPtr->refCount = 0;
1.2197 + varPtr->tracePtr = NULL;
1.2198 + varPtr->searchPtr = NULL;
1.2199 + varPtr->flags = localPtr->flags;
1.2200 + }
1.2201 + varPtr++;
1.2202 + }
1.2203 +}
1.2204 +
1.2205 +/*
1.2206 + *----------------------------------------------------------------------
1.2207 + *
1.2208 + * TclExpandCodeArray --
1.2209 + *
1.2210 + * Procedure that uses malloc to allocate more storage for a
1.2211 + * CompileEnv's code array.
1.2212 + *
1.2213 + * Results:
1.2214 + * None.
1.2215 + *
1.2216 + * Side effects:
1.2217 + * The byte code array in *envPtr is reallocated to a new array of
1.2218 + * double the size, and if envPtr->mallocedCodeArray is non-zero the
1.2219 + * old array is freed. Byte codes are copied from the old array to the
1.2220 + * new one.
1.2221 + *
1.2222 + *----------------------------------------------------------------------
1.2223 + */
1.2224 +
1.2225 +void
1.2226 +TclExpandCodeArray(envArgPtr)
1.2227 + void *envArgPtr; /* Points to the CompileEnv whose code array
1.2228 + * must be enlarged. */
1.2229 +{
1.2230 + CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* Points to the CompileEnv whose code array
1.2231 + * must be enlarged. */
1.2232 +
1.2233 + /*
1.2234 + * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
1.2235 + * code bytes are stored between envPtr->codeStart and
1.2236 + * (envPtr->codeNext - 1) [inclusive].
1.2237 + */
1.2238 +
1.2239 + size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
1.2240 + size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
1.2241 + unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
1.2242 +
1.2243 + /*
1.2244 + * Copy from old code array to new, free old code array if needed, and
1.2245 + * mark new code array as malloced.
1.2246 + */
1.2247 +
1.2248 + memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
1.2249 + if (envPtr->mallocedCodeArray) {
1.2250 + ckfree((char *) envPtr->codeStart);
1.2251 + }
1.2252 + envPtr->codeStart = newPtr;
1.2253 + envPtr->codeNext = (newPtr + currBytes);
1.2254 + envPtr->codeEnd = (newPtr + newBytes);
1.2255 + envPtr->mallocedCodeArray = 1;
1.2256 +}
1.2257 +
1.2258 +/*
1.2259 + *----------------------------------------------------------------------
1.2260 + *
1.2261 + * EnterCmdStartData --
1.2262 + *
1.2263 + * Registers the starting source and bytecode location of a
1.2264 + * command. This information is used at runtime to map between
1.2265 + * instruction pc and source locations.
1.2266 + *
1.2267 + * Results:
1.2268 + * None.
1.2269 + *
1.2270 + * Side effects:
1.2271 + * Inserts source and code location information into the compilation
1.2272 + * environment envPtr for the command at index cmdIndex. The
1.2273 + * compilation environment's CmdLocation array is grown if necessary.
1.2274 + *
1.2275 + *----------------------------------------------------------------------
1.2276 + */
1.2277 +
1.2278 +static void
1.2279 +EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
1.2280 + CompileEnv *envPtr; /* Points to the compilation environment
1.2281 + * structure in which to enter command
1.2282 + * location information. */
1.2283 + int cmdIndex; /* Index of the command whose start data
1.2284 + * is being set. */
1.2285 + int srcOffset; /* Offset of first char of the command. */
1.2286 + int codeOffset; /* Offset of first byte of command code. */
1.2287 +{
1.2288 + CmdLocation *cmdLocPtr;
1.2289 +
1.2290 + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
1.2291 + panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
1.2292 + }
1.2293 +
1.2294 + if (cmdIndex >= envPtr->cmdMapEnd) {
1.2295 + /*
1.2296 + * Expand the command location array by allocating more storage from
1.2297 + * the heap. The currently allocated CmdLocation entries are stored
1.2298 + * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
1.2299 + */
1.2300 +
1.2301 + size_t currElems = envPtr->cmdMapEnd;
1.2302 + size_t newElems = 2*currElems;
1.2303 + size_t currBytes = currElems * sizeof(CmdLocation);
1.2304 + size_t newBytes = newElems * sizeof(CmdLocation);
1.2305 + CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
1.2306 +
1.2307 + /*
1.2308 + * Copy from old command location array to new, free old command
1.2309 + * location array if needed, and mark new array as malloced.
1.2310 + */
1.2311 +
1.2312 + memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
1.2313 + if (envPtr->mallocedCmdMap) {
1.2314 + ckfree((char *) envPtr->cmdMapPtr);
1.2315 + }
1.2316 + envPtr->cmdMapPtr = (CmdLocation *) newPtr;
1.2317 + envPtr->cmdMapEnd = newElems;
1.2318 + envPtr->mallocedCmdMap = 1;
1.2319 + }
1.2320 +
1.2321 + if (cmdIndex > 0) {
1.2322 + if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
1.2323 + panic("EnterCmdStartData: cmd map not sorted by code offset");
1.2324 + }
1.2325 + }
1.2326 +
1.2327 + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
1.2328 + cmdLocPtr->codeOffset = codeOffset;
1.2329 + cmdLocPtr->srcOffset = srcOffset;
1.2330 + cmdLocPtr->numSrcBytes = -1;
1.2331 + cmdLocPtr->numCodeBytes = -1;
1.2332 +}
1.2333 +
1.2334 +/*
1.2335 + *----------------------------------------------------------------------
1.2336 + *
1.2337 + * EnterCmdExtentData --
1.2338 + *
1.2339 + * Registers the source and bytecode length for a command. This
1.2340 + * information is used at runtime to map between instruction pc and
1.2341 + * source locations.
1.2342 + *
1.2343 + * Results:
1.2344 + * None.
1.2345 + *
1.2346 + * Side effects:
1.2347 + * Inserts source and code length information into the compilation
1.2348 + * environment envPtr for the command at index cmdIndex. Starting
1.2349 + * source and bytecode information for the command must already
1.2350 + * have been registered.
1.2351 + *
1.2352 + *----------------------------------------------------------------------
1.2353 + */
1.2354 +
1.2355 +static void
1.2356 +EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
1.2357 + CompileEnv *envPtr; /* Points to the compilation environment
1.2358 + * structure in which to enter command
1.2359 + * location information. */
1.2360 + int cmdIndex; /* Index of the command whose source and
1.2361 + * code length data is being set. */
1.2362 + int numSrcBytes; /* Number of command source chars. */
1.2363 + int numCodeBytes; /* Offset of last byte of command code. */
1.2364 +{
1.2365 + CmdLocation *cmdLocPtr;
1.2366 +
1.2367 + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
1.2368 + panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
1.2369 + }
1.2370 +
1.2371 + if (cmdIndex > envPtr->cmdMapEnd) {
1.2372 + panic("EnterCmdExtentData: missing start data for command %d\n",
1.2373 + cmdIndex);
1.2374 + }
1.2375 +
1.2376 + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
1.2377 + cmdLocPtr->numSrcBytes = numSrcBytes;
1.2378 + cmdLocPtr->numCodeBytes = numCodeBytes;
1.2379 +}
1.2380 +
1.2381 +#ifdef TCL_TIP280
1.2382 +/*
1.2383 + *----------------------------------------------------------------------
1.2384 + * TIP #280
1.2385 + *
1.2386 + * EnterCmdWordData --
1.2387 + *
1.2388 + * Registers the lines for the words of a command. This information
1.2389 + * is used at runtime by 'info frame'.
1.2390 + *
1.2391 + * Results:
1.2392 + * None.
1.2393 + *
1.2394 + * Side effects:
1.2395 + * Inserts word location information into the compilation
1.2396 + * environment envPtr for the command at index cmdIndex. The
1.2397 + * compilation environment's ExtCmdLoc.ECL array is grown if necessary.
1.2398 + *
1.2399 + *----------------------------------------------------------------------
1.2400 + */
1.2401 +
1.2402 +static void
1.2403 +EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines)
1.2404 + ExtCmdLoc *eclPtr; /* Points to the map environment
1.2405 + * structure in which to enter command
1.2406 + * location information. */
1.2407 + int srcOffset; /* Offset of first char of the command. */
1.2408 + Tcl_Token* tokenPtr;
1.2409 + CONST char* cmd;
1.2410 + int len;
1.2411 + int numWords;
1.2412 + int line;
1.2413 + int** wlines;
1.2414 +{
1.2415 + ECL* ePtr;
1.2416 + int wordIdx;
1.2417 + CONST char* last;
1.2418 + int wordLine;
1.2419 + int* wwlines;
1.2420 +
1.2421 + if (eclPtr->nuloc >= eclPtr->nloc) {
1.2422 + /*
1.2423 + * Expand the ECL array by allocating more storage from the
1.2424 + * heap. The currently allocated ECL entries are stored from
1.2425 + * eclPtr->loc[0] up to eclPtr->loc[eclPtr->nuloc-1] (inclusive).
1.2426 + */
1.2427 +
1.2428 + size_t currElems = eclPtr->nloc;
1.2429 + size_t newElems = (currElems ? 2*currElems : 1);
1.2430 + size_t currBytes = currElems * sizeof(ECL);
1.2431 + size_t newBytes = newElems * sizeof(ECL);
1.2432 + ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes);
1.2433 +
1.2434 + /*
1.2435 + * Copy from old ECL array to new, free old ECL array if
1.2436 + * needed.
1.2437 + */
1.2438 +
1.2439 + if (currBytes) {
1.2440 + memcpy((VOID *) newPtr, (VOID *) eclPtr->loc, currBytes);
1.2441 + }
1.2442 + if (eclPtr->loc != NULL) {
1.2443 + ckfree((char *) eclPtr->loc);
1.2444 + }
1.2445 + eclPtr->loc = (ECL *) newPtr;
1.2446 + eclPtr->nloc = newElems;
1.2447 + }
1.2448 +
1.2449 + ePtr = &eclPtr->loc [eclPtr->nuloc];
1.2450 + ePtr->srcOffset = srcOffset;
1.2451 + ePtr->line = (int*) ckalloc (numWords * sizeof (int));
1.2452 + ePtr->nline = numWords;
1.2453 + wwlines = (int*) ckalloc (numWords * sizeof (int));
1.2454 +
1.2455 + last = cmd;
1.2456 + wordLine = line;
1.2457 + for (wordIdx = 0;
1.2458 + wordIdx < numWords;
1.2459 + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
1.2460 + TclAdvanceLines (&wordLine, last, tokenPtr->start);
1.2461 + wwlines [wordIdx] = (TclWordKnownAtCompileTime (tokenPtr)
1.2462 + ? wordLine
1.2463 + : -1);
1.2464 + ePtr->line [wordIdx] = wordLine;
1.2465 + last = tokenPtr->start;
1.2466 + }
1.2467 +
1.2468 + *wlines = wwlines;
1.2469 + eclPtr->nuloc ++;
1.2470 +}
1.2471 +#endif
1.2472 +
1.2473 +/*
1.2474 + *----------------------------------------------------------------------
1.2475 + *
1.2476 + * TclCreateExceptRange --
1.2477 + *
1.2478 + * Procedure that allocates and initializes a new ExceptionRange
1.2479 + * structure of the specified kind in a CompileEnv.
1.2480 + *
1.2481 + * Results:
1.2482 + * Returns the index for the newly created ExceptionRange.
1.2483 + *
1.2484 + * Side effects:
1.2485 + * If there is not enough room in the CompileEnv's ExceptionRange
1.2486 + * array, the array in expanded: a new array of double the size is
1.2487 + * allocated, if envPtr->mallocedExceptArray is non-zero the old
1.2488 + * array is freed, and ExceptionRange entries are copied from the old
1.2489 + * array to the new one.
1.2490 + *
1.2491 + *----------------------------------------------------------------------
1.2492 + */
1.2493 +
1.2494 +int
1.2495 +TclCreateExceptRange(type, envPtr)
1.2496 + ExceptionRangeType type; /* The kind of ExceptionRange desired. */
1.2497 + register CompileEnv *envPtr;/* Points to CompileEnv for which to
1.2498 + * create a new ExceptionRange structure. */
1.2499 +{
1.2500 + register ExceptionRange *rangePtr;
1.2501 + int index = envPtr->exceptArrayNext;
1.2502 +
1.2503 + if (index >= envPtr->exceptArrayEnd) {
1.2504 + /*
1.2505 + * Expand the ExceptionRange array. The currently allocated entries
1.2506 + * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
1.2507 + * [inclusive].
1.2508 + */
1.2509 +
1.2510 + size_t currBytes =
1.2511 + envPtr->exceptArrayNext * sizeof(ExceptionRange);
1.2512 + int newElems = 2*envPtr->exceptArrayEnd;
1.2513 + size_t newBytes = newElems * sizeof(ExceptionRange);
1.2514 + ExceptionRange *newPtr = (ExceptionRange *)
1.2515 + ckalloc((unsigned) newBytes);
1.2516 +
1.2517 + /*
1.2518 + * Copy from old ExceptionRange array to new, free old
1.2519 + * ExceptionRange array if needed, and mark the new ExceptionRange
1.2520 + * array as malloced.
1.2521 + */
1.2522 +
1.2523 + memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr,
1.2524 + currBytes);
1.2525 + if (envPtr->mallocedExceptArray) {
1.2526 + ckfree((char *) envPtr->exceptArrayPtr);
1.2527 + }
1.2528 + envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
1.2529 + envPtr->exceptArrayEnd = newElems;
1.2530 + envPtr->mallocedExceptArray = 1;
1.2531 + }
1.2532 + envPtr->exceptArrayNext++;
1.2533 +
1.2534 + rangePtr = &(envPtr->exceptArrayPtr[index]);
1.2535 + rangePtr->type = type;
1.2536 + rangePtr->nestingLevel = envPtr->exceptDepth;
1.2537 + rangePtr->codeOffset = -1;
1.2538 + rangePtr->numCodeBytes = -1;
1.2539 + rangePtr->breakOffset = -1;
1.2540 + rangePtr->continueOffset = -1;
1.2541 + rangePtr->catchOffset = -1;
1.2542 + return index;
1.2543 +}
1.2544 +
1.2545 +/*
1.2546 + *----------------------------------------------------------------------
1.2547 + *
1.2548 + * TclCreateAuxData --
1.2549 + *
1.2550 + * Procedure that allocates and initializes a new AuxData structure in
1.2551 + * a CompileEnv's array of compilation auxiliary data records. These
1.2552 + * AuxData records hold information created during compilation by
1.2553 + * CompileProcs and used by instructions during execution.
1.2554 + *
1.2555 + * Results:
1.2556 + * Returns the index for the newly created AuxData structure.
1.2557 + *
1.2558 + * Side effects:
1.2559 + * If there is not enough room in the CompileEnv's AuxData array,
1.2560 + * the AuxData array in expanded: a new array of double the size
1.2561 + * is allocated, if envPtr->mallocedAuxDataArray is non-zero
1.2562 + * the old array is freed, and AuxData entries are copied from
1.2563 + * the old array to the new one.
1.2564 + *
1.2565 + *----------------------------------------------------------------------
1.2566 + */
1.2567 +
1.2568 +int
1.2569 +TclCreateAuxData(clientData, typePtr, envPtr)
1.2570 + ClientData clientData; /* The compilation auxiliary data to store
1.2571 + * in the new aux data record. */
1.2572 + AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */
1.2573 + register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
1.2574 + * aux data structure is to be allocated. */
1.2575 +{
1.2576 + int index; /* Index for the new AuxData structure. */
1.2577 + register AuxData *auxDataPtr;
1.2578 + /* Points to the new AuxData structure */
1.2579 +
1.2580 + index = envPtr->auxDataArrayNext;
1.2581 + if (index >= envPtr->auxDataArrayEnd) {
1.2582 + /*
1.2583 + * Expand the AuxData array. The currently allocated entries are
1.2584 + * stored between elements 0 and (envPtr->auxDataArrayNext - 1)
1.2585 + * [inclusive].
1.2586 + */
1.2587 +
1.2588 + size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
1.2589 + int newElems = 2*envPtr->auxDataArrayEnd;
1.2590 + size_t newBytes = newElems * sizeof(AuxData);
1.2591 + AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
1.2592 +
1.2593 + /*
1.2594 + * Copy from old AuxData array to new, free old AuxData array if
1.2595 + * needed, and mark the new AuxData array as malloced.
1.2596 + */
1.2597 +
1.2598 + memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
1.2599 + currBytes);
1.2600 + if (envPtr->mallocedAuxDataArray) {
1.2601 + ckfree((char *) envPtr->auxDataArrayPtr);
1.2602 + }
1.2603 + envPtr->auxDataArrayPtr = newPtr;
1.2604 + envPtr->auxDataArrayEnd = newElems;
1.2605 + envPtr->mallocedAuxDataArray = 1;
1.2606 + }
1.2607 + envPtr->auxDataArrayNext++;
1.2608 +
1.2609 + auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
1.2610 + auxDataPtr->clientData = clientData;
1.2611 + auxDataPtr->type = typePtr;
1.2612 + return index;
1.2613 +}
1.2614 +
1.2615 +/*
1.2616 + *----------------------------------------------------------------------
1.2617 + *
1.2618 + * TclInitJumpFixupArray --
1.2619 + *
1.2620 + * Initializes a JumpFixupArray structure to hold some number of
1.2621 + * jump fixup entries.
1.2622 + *
1.2623 + * Results:
1.2624 + * None.
1.2625 + *
1.2626 + * Side effects:
1.2627 + * The JumpFixupArray structure is initialized.
1.2628 + *
1.2629 + *----------------------------------------------------------------------
1.2630 + */
1.2631 +
1.2632 +void
1.2633 +TclInitJumpFixupArray(fixupArrayPtr)
1.2634 + register JumpFixupArray *fixupArrayPtr;
1.2635 + /* Points to the JumpFixupArray structure
1.2636 + * to initialize. */
1.2637 +{
1.2638 + fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
1.2639 + fixupArrayPtr->next = 0;
1.2640 + fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
1.2641 + fixupArrayPtr->mallocedArray = 0;
1.2642 +}
1.2643 +
1.2644 +/*
1.2645 + *----------------------------------------------------------------------
1.2646 + *
1.2647 + * TclExpandJumpFixupArray --
1.2648 + *
1.2649 + * Procedure that uses malloc to allocate more storage for a
1.2650 + * jump fixup array.
1.2651 + *
1.2652 + * Results:
1.2653 + * None.
1.2654 + *
1.2655 + * Side effects:
1.2656 + * The jump fixup array in *fixupArrayPtr is reallocated to a new array
1.2657 + * of double the size, and if fixupArrayPtr->mallocedArray is non-zero
1.2658 + * the old array is freed. Jump fixup structures are copied from the
1.2659 + * old array to the new one.
1.2660 + *
1.2661 + *----------------------------------------------------------------------
1.2662 + */
1.2663 +
1.2664 +void
1.2665 +TclExpandJumpFixupArray(fixupArrayPtr)
1.2666 + register JumpFixupArray *fixupArrayPtr;
1.2667 + /* Points to the JumpFixupArray structure
1.2668 + * to enlarge. */
1.2669 +{
1.2670 + /*
1.2671 + * The currently allocated jump fixup entries are stored from fixup[0]
1.2672 + * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
1.2673 + * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
1.2674 + */
1.2675 +
1.2676 + size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
1.2677 + int newElems = 2*(fixupArrayPtr->end + 1);
1.2678 + size_t newBytes = newElems * sizeof(JumpFixup);
1.2679 + JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
1.2680 +
1.2681 + /*
1.2682 + * Copy from the old array to new, free the old array if needed,
1.2683 + * and mark the new array as malloced.
1.2684 + */
1.2685 +
1.2686 + memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
1.2687 + if (fixupArrayPtr->mallocedArray) {
1.2688 + ckfree((char *) fixupArrayPtr->fixup);
1.2689 + }
1.2690 + fixupArrayPtr->fixup = (JumpFixup *) newPtr;
1.2691 + fixupArrayPtr->end = newElems;
1.2692 + fixupArrayPtr->mallocedArray = 1;
1.2693 +}
1.2694 +
1.2695 +/*
1.2696 + *----------------------------------------------------------------------
1.2697 + *
1.2698 + * TclFreeJumpFixupArray --
1.2699 + *
1.2700 + * Free any storage allocated in a jump fixup array structure.
1.2701 + *
1.2702 + * Results:
1.2703 + * None.
1.2704 + *
1.2705 + * Side effects:
1.2706 + * Allocated storage in the JumpFixupArray structure is freed.
1.2707 + *
1.2708 + *----------------------------------------------------------------------
1.2709 + */
1.2710 +
1.2711 +void
1.2712 +TclFreeJumpFixupArray(fixupArrayPtr)
1.2713 + register JumpFixupArray *fixupArrayPtr;
1.2714 + /* Points to the JumpFixupArray structure
1.2715 + * to free. */
1.2716 +{
1.2717 + if (fixupArrayPtr->mallocedArray) {
1.2718 + ckfree((char *) fixupArrayPtr->fixup);
1.2719 + }
1.2720 +}
1.2721 +
1.2722 +/*
1.2723 + *----------------------------------------------------------------------
1.2724 + *
1.2725 + * TclEmitForwardJump --
1.2726 + *
1.2727 + * Procedure to emit a two-byte forward jump of kind "jumpType". Since
1.2728 + * the jump may later have to be grown to five bytes if the jump target
1.2729 + * is more than, say, 127 bytes away, this procedure also initializes a
1.2730 + * JumpFixup record with information about the jump.
1.2731 + *
1.2732 + * Results:
1.2733 + * None.
1.2734 + *
1.2735 + * Side effects:
1.2736 + * The JumpFixup record pointed to by "jumpFixupPtr" is initialized
1.2737 + * with information needed later if the jump is to be grown. Also,
1.2738 + * a two byte jump of the designated type is emitted at the current
1.2739 + * point in the bytecode stream.
1.2740 + *
1.2741 + *----------------------------------------------------------------------
1.2742 + */
1.2743 +
1.2744 +void
1.2745 +TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
1.2746 + CompileEnv *envPtr; /* Points to the CompileEnv structure that
1.2747 + * holds the resulting instruction. */
1.2748 + TclJumpType jumpType; /* Indicates the kind of jump: if true or
1.2749 + * false or unconditional. */
1.2750 + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to
1.2751 + * initialize with information about this
1.2752 + * forward jump. */
1.2753 +{
1.2754 + /*
1.2755 + * Initialize the JumpFixup structure:
1.2756 + * - codeOffset is offset of first byte of jump below
1.2757 + * - cmdIndex is index of the command after the current one
1.2758 + * - exceptIndex is the index of the first ExceptionRange after
1.2759 + * the current one.
1.2760 + */
1.2761 +
1.2762 + jumpFixupPtr->jumpType = jumpType;
1.2763 + jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
1.2764 + jumpFixupPtr->cmdIndex = envPtr->numCommands;
1.2765 + jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
1.2766 +
1.2767 + switch (jumpType) {
1.2768 + case TCL_UNCONDITIONAL_JUMP:
1.2769 + TclEmitInstInt1(INST_JUMP1, 0, envPtr);
1.2770 + break;
1.2771 + case TCL_TRUE_JUMP:
1.2772 + TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
1.2773 + break;
1.2774 + default:
1.2775 + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
1.2776 + break;
1.2777 + }
1.2778 +}
1.2779 +
1.2780 +/*
1.2781 + *----------------------------------------------------------------------
1.2782 + *
1.2783 + * TclFixupForwardJump --
1.2784 + *
1.2785 + * Procedure that updates a previously-emitted forward jump to jump
1.2786 + * a specified number of bytes, "jumpDist". If necessary, the jump is
1.2787 + * grown from two to five bytes; this is done if the jump distance is
1.2788 + * greater than "distThreshold" (normally 127 bytes). The jump is
1.2789 + * described by a JumpFixup record previously initialized by
1.2790 + * TclEmitForwardJump.
1.2791 + *
1.2792 + * Results:
1.2793 + * 1 if the jump was grown and subsequent instructions had to be moved;
1.2794 + * otherwise 0. This result is returned to allow callers to update
1.2795 + * any additional code offsets they may hold.
1.2796 + *
1.2797 + * Side effects:
1.2798 + * The jump may be grown and subsequent instructions moved. If this
1.2799 + * happens, the code offsets for any commands and any ExceptionRange
1.2800 + * records between the jump and the current code address will be
1.2801 + * updated to reflect the moved code. Also, the bytecode instruction
1.2802 + * array in the CompileEnv structure may be grown and reallocated.
1.2803 + *
1.2804 + *----------------------------------------------------------------------
1.2805 + */
1.2806 +
1.2807 +int
1.2808 +TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
1.2809 + CompileEnv *envPtr; /* Points to the CompileEnv structure that
1.2810 + * holds the resulting instruction. */
1.2811 + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that
1.2812 + * describes the forward jump. */
1.2813 + int jumpDist; /* Jump distance to set in jump
1.2814 + * instruction. */
1.2815 + int distThreshold; /* Maximum distance before the two byte
1.2816 + * jump is grown to five bytes. */
1.2817 +{
1.2818 + unsigned char *jumpPc, *p;
1.2819 + int firstCmd, lastCmd, firstRange, lastRange, k;
1.2820 + unsigned int numBytes;
1.2821 +
1.2822 + if (jumpDist <= distThreshold) {
1.2823 + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
1.2824 + switch (jumpFixupPtr->jumpType) {
1.2825 + case TCL_UNCONDITIONAL_JUMP:
1.2826 + TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
1.2827 + break;
1.2828 + case TCL_TRUE_JUMP:
1.2829 + TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
1.2830 + break;
1.2831 + default:
1.2832 + TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
1.2833 + break;
1.2834 + }
1.2835 + return 0;
1.2836 + }
1.2837 +
1.2838 + /*
1.2839 + * We must grow the jump then move subsequent instructions down.
1.2840 + * Note that if we expand the space for generated instructions,
1.2841 + * code addresses might change; be careful about updating any of
1.2842 + * these addresses held in variables.
1.2843 + */
1.2844 +
1.2845 + if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
1.2846 + TclExpandCodeArray(envPtr);
1.2847 + }
1.2848 + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
1.2849 + for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
1.2850 + numBytes > 0; numBytes--, p--) {
1.2851 + p[3] = p[0];
1.2852 + }
1.2853 + envPtr->codeNext += 3;
1.2854 + jumpDist += 3;
1.2855 + switch (jumpFixupPtr->jumpType) {
1.2856 + case TCL_UNCONDITIONAL_JUMP:
1.2857 + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
1.2858 + break;
1.2859 + case TCL_TRUE_JUMP:
1.2860 + TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
1.2861 + break;
1.2862 + default:
1.2863 + TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
1.2864 + break;
1.2865 + }
1.2866 +
1.2867 + /*
1.2868 + * Adjust the code offsets for any commands and any ExceptionRange
1.2869 + * records between the jump and the current code address.
1.2870 + */
1.2871 +
1.2872 + firstCmd = jumpFixupPtr->cmdIndex;
1.2873 + lastCmd = (envPtr->numCommands - 1);
1.2874 + if (firstCmd < lastCmd) {
1.2875 + for (k = firstCmd; k <= lastCmd; k++) {
1.2876 + (envPtr->cmdMapPtr[k]).codeOffset += 3;
1.2877 + }
1.2878 + }
1.2879 +
1.2880 + firstRange = jumpFixupPtr->exceptIndex;
1.2881 + lastRange = (envPtr->exceptArrayNext - 1);
1.2882 + for (k = firstRange; k <= lastRange; k++) {
1.2883 + ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
1.2884 + rangePtr->codeOffset += 3;
1.2885 +
1.2886 + switch (rangePtr->type) {
1.2887 + case LOOP_EXCEPTION_RANGE:
1.2888 + rangePtr->breakOffset += 3;
1.2889 + if (rangePtr->continueOffset != -1) {
1.2890 + rangePtr->continueOffset += 3;
1.2891 + }
1.2892 + break;
1.2893 + case CATCH_EXCEPTION_RANGE:
1.2894 + rangePtr->catchOffset += 3;
1.2895 + break;
1.2896 + default:
1.2897 + panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
1.2898 + rangePtr->type);
1.2899 + }
1.2900 + }
1.2901 + return 1; /* the jump was grown */
1.2902 +}
1.2903 +
1.2904 +/*
1.2905 + *----------------------------------------------------------------------
1.2906 + *
1.2907 + * TclGetInstructionTable --
1.2908 + *
1.2909 + * Returns a pointer to the table describing Tcl bytecode instructions.
1.2910 + * This procedure is defined so that clients can access the pointer from
1.2911 + * outside the TCL DLLs.
1.2912 + *
1.2913 + * Results:
1.2914 + * Returns a pointer to the global instruction table, same as the
1.2915 + * expression (&tclInstructionTable[0]).
1.2916 + *
1.2917 + * Side effects:
1.2918 + * None.
1.2919 + *
1.2920 + *----------------------------------------------------------------------
1.2921 + */
1.2922 +
1.2923 +void * /* == InstructionDesc* == */
1.2924 +TclGetInstructionTable()
1.2925 +{
1.2926 + return &tclInstructionTable[0];
1.2927 +}
1.2928 +
1.2929 +/*
1.2930 + *--------------------------------------------------------------
1.2931 + *
1.2932 + * TclRegisterAuxDataType --
1.2933 + *
1.2934 + * This procedure is called to register a new AuxData type
1.2935 + * in the table of all AuxData types supported by Tcl.
1.2936 + *
1.2937 + * Results:
1.2938 + * None.
1.2939 + *
1.2940 + * Side effects:
1.2941 + * The type is registered in the AuxData type table. If there was already
1.2942 + * a type with the same name as in typePtr, it is replaced with the
1.2943 + * new type.
1.2944 + *
1.2945 + *--------------------------------------------------------------
1.2946 + */
1.2947 +
1.2948 +void
1.2949 +TclRegisterAuxDataType(typePtr)
1.2950 + AuxDataType *typePtr; /* Information about object type;
1.2951 + * storage must be statically
1.2952 + * allocated (must live forever). */
1.2953 +{
1.2954 + register Tcl_HashEntry *hPtr;
1.2955 + int new;
1.2956 +
1.2957 + Tcl_MutexLock(&tableMutex);
1.2958 + if (!auxDataTypeTableInitialized) {
1.2959 + TclInitAuxDataTypeTable();
1.2960 + }
1.2961 +
1.2962 + /*
1.2963 + * If there's already a type with the given name, remove it.
1.2964 + */
1.2965 +
1.2966 + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
1.2967 + if (hPtr != (Tcl_HashEntry *) NULL) {
1.2968 + Tcl_DeleteHashEntry(hPtr);
1.2969 + }
1.2970 +
1.2971 + /*
1.2972 + * Now insert the new object type.
1.2973 + */
1.2974 +
1.2975 + hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
1.2976 + if (new) {
1.2977 + Tcl_SetHashValue(hPtr, typePtr);
1.2978 + }
1.2979 + Tcl_MutexUnlock(&tableMutex);
1.2980 +}
1.2981 +
1.2982 +/*
1.2983 + *----------------------------------------------------------------------
1.2984 + *
1.2985 + * TclGetAuxDataType --
1.2986 + *
1.2987 + * This procedure looks up an Auxdata type by name.
1.2988 + *
1.2989 + * Results:
1.2990 + * If an AuxData type with name matching "typeName" is found, a pointer
1.2991 + * to its AuxDataType structure is returned; otherwise, NULL is returned.
1.2992 + *
1.2993 + * Side effects:
1.2994 + * None.
1.2995 + *
1.2996 + *----------------------------------------------------------------------
1.2997 + */
1.2998 +
1.2999 +AuxDataType *
1.3000 +TclGetAuxDataType(typeName)
1.3001 + char *typeName; /* Name of AuxData type to look up. */
1.3002 +{
1.3003 + register Tcl_HashEntry *hPtr;
1.3004 + AuxDataType *typePtr = NULL;
1.3005 +
1.3006 + Tcl_MutexLock(&tableMutex);
1.3007 + if (!auxDataTypeTableInitialized) {
1.3008 + TclInitAuxDataTypeTable();
1.3009 + }
1.3010 +
1.3011 + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
1.3012 + if (hPtr != (Tcl_HashEntry *) NULL) {
1.3013 + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
1.3014 + }
1.3015 + Tcl_MutexUnlock(&tableMutex);
1.3016 +
1.3017 + return typePtr;
1.3018 +}
1.3019 +
1.3020 +/*
1.3021 + *--------------------------------------------------------------
1.3022 + *
1.3023 + * TclInitAuxDataTypeTable --
1.3024 + *
1.3025 + * This procedure is invoked to perform once-only initialization of
1.3026 + * the AuxData type table. It also registers the AuxData types defined in
1.3027 + * this file.
1.3028 + *
1.3029 + * Results:
1.3030 + * None.
1.3031 + *
1.3032 + * Side effects:
1.3033 + * Initializes the table of defined AuxData types "auxDataTypeTable" with
1.3034 + * builtin AuxData types defined in this file.
1.3035 + *
1.3036 + *--------------------------------------------------------------
1.3037 + */
1.3038 +
1.3039 +void
1.3040 +TclInitAuxDataTypeTable()
1.3041 +{
1.3042 + /*
1.3043 + * The table mutex must already be held before this routine is invoked.
1.3044 + */
1.3045 +
1.3046 + auxDataTypeTableInitialized = 1;
1.3047 + Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
1.3048 +
1.3049 + /*
1.3050 + * There is only one AuxData type at this time, so register it here.
1.3051 + */
1.3052 +
1.3053 + TclRegisterAuxDataType(&tclForeachInfoType);
1.3054 +}
1.3055 +
1.3056 +/*
1.3057 + *----------------------------------------------------------------------
1.3058 + *
1.3059 + * TclFinalizeAuxDataTypeTable --
1.3060 + *
1.3061 + * This procedure is called by Tcl_Finalize after all exit handlers
1.3062 + * have been run to free up storage associated with the table of AuxData
1.3063 + * types. This procedure is called by TclFinalizeExecution() which
1.3064 + * is called by Tcl_Finalize().
1.3065 + *
1.3066 + * Results:
1.3067 + * None.
1.3068 + *
1.3069 + * Side effects:
1.3070 + * Deletes all entries in the hash table of AuxData types.
1.3071 + *
1.3072 + *----------------------------------------------------------------------
1.3073 + */
1.3074 +
1.3075 +void
1.3076 +TclFinalizeAuxDataTypeTable()
1.3077 +{
1.3078 + Tcl_MutexLock(&tableMutex);
1.3079 + if (auxDataTypeTableInitialized) {
1.3080 + Tcl_DeleteHashTable(&auxDataTypeTable);
1.3081 + auxDataTypeTableInitialized = 0;
1.3082 + }
1.3083 + Tcl_MutexUnlock(&tableMutex);
1.3084 +}
1.3085 +
1.3086 +/*
1.3087 + *----------------------------------------------------------------------
1.3088 + *
1.3089 + * GetCmdLocEncodingSize --
1.3090 + *
1.3091 + * Computes the total number of bytes needed to encode the command
1.3092 + * location information for some compiled code.
1.3093 + *
1.3094 + * Results:
1.3095 + * The byte count needed to encode the compiled location information.
1.3096 + *
1.3097 + * Side effects:
1.3098 + * None.
1.3099 + *
1.3100 + *----------------------------------------------------------------------
1.3101 + */
1.3102 +
1.3103 +static int
1.3104 +GetCmdLocEncodingSize(envPtr)
1.3105 + CompileEnv *envPtr; /* Points to compilation environment
1.3106 + * structure containing the CmdLocation
1.3107 + * structure to encode. */
1.3108 +{
1.3109 + register CmdLocation *mapPtr = envPtr->cmdMapPtr;
1.3110 + int numCmds = envPtr->numCommands;
1.3111 + int codeDelta, codeLen, srcDelta, srcLen;
1.3112 + int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
1.3113 + /* The offsets in their respective byte
1.3114 + * sequences where the next encoded offset
1.3115 + * or length should go. */
1.3116 + int prevCodeOffset, prevSrcOffset, i;
1.3117 +
1.3118 + codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
1.3119 + prevCodeOffset = prevSrcOffset = 0;
1.3120 + for (i = 0; i < numCmds; i++) {
1.3121 + codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
1.3122 + if (codeDelta < 0) {
1.3123 + panic("GetCmdLocEncodingSize: bad code offset");
1.3124 + } else if (codeDelta <= 127) {
1.3125 + codeDeltaNext++;
1.3126 + } else {
1.3127 + codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
1.3128 + }
1.3129 + prevCodeOffset = mapPtr[i].codeOffset;
1.3130 +
1.3131 + codeLen = mapPtr[i].numCodeBytes;
1.3132 + if (codeLen < 0) {
1.3133 + panic("GetCmdLocEncodingSize: bad code length");
1.3134 + } else if (codeLen <= 127) {
1.3135 + codeLengthNext++;
1.3136 + } else {
1.3137 + codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
1.3138 + }
1.3139 +
1.3140 + srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
1.3141 + if ((-127 <= srcDelta) && (srcDelta <= 127)) {
1.3142 + srcDeltaNext++;
1.3143 + } else {
1.3144 + srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
1.3145 + }
1.3146 + prevSrcOffset = mapPtr[i].srcOffset;
1.3147 +
1.3148 + srcLen = mapPtr[i].numSrcBytes;
1.3149 + if (srcLen < 0) {
1.3150 + panic("GetCmdLocEncodingSize: bad source length");
1.3151 + } else if (srcLen <= 127) {
1.3152 + srcLengthNext++;
1.3153 + } else {
1.3154 + srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
1.3155 + }
1.3156 + }
1.3157 +
1.3158 + return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
1.3159 +}
1.3160 +
1.3161 +/*
1.3162 + *----------------------------------------------------------------------
1.3163 + *
1.3164 + * EncodeCmdLocMap --
1.3165 + *
1.3166 + * Encode the command location information for some compiled code into
1.3167 + * a ByteCode structure. The encoded command location map is stored as
1.3168 + * three adjacent byte sequences.
1.3169 + *
1.3170 + * Results:
1.3171 + * Pointer to the first byte after the encoded command location
1.3172 + * information.
1.3173 + *
1.3174 + * Side effects:
1.3175 + * The encoded information is stored into the block of memory headed
1.3176 + * by codePtr. Also records pointers to the start of the four byte
1.3177 + * sequences in fields in codePtr's ByteCode header structure.
1.3178 + *
1.3179 + *----------------------------------------------------------------------
1.3180 + */
1.3181 +
1.3182 +static unsigned char *
1.3183 +EncodeCmdLocMap(envPtr, codePtr, startPtr)
1.3184 + CompileEnv *envPtr; /* Points to compilation environment
1.3185 + * structure containing the CmdLocation
1.3186 + * structure to encode. */
1.3187 + ByteCode *codePtr; /* ByteCode in which to encode envPtr's
1.3188 + * command location information. */
1.3189 + unsigned char *startPtr; /* Points to the first byte in codePtr's
1.3190 + * memory block where the location
1.3191 + * information is to be stored. */
1.3192 +{
1.3193 + register CmdLocation *mapPtr = envPtr->cmdMapPtr;
1.3194 + int numCmds = envPtr->numCommands;
1.3195 + register unsigned char *p = startPtr;
1.3196 + int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
1.3197 + register int i;
1.3198 +
1.3199 + /*
1.3200 + * Encode the code offset for each command as a sequence of deltas.
1.3201 + */
1.3202 +
1.3203 + codePtr->codeDeltaStart = p;
1.3204 + prevOffset = 0;
1.3205 + for (i = 0; i < numCmds; i++) {
1.3206 + codeDelta = (mapPtr[i].codeOffset - prevOffset);
1.3207 + if (codeDelta < 0) {
1.3208 + panic("EncodeCmdLocMap: bad code offset");
1.3209 + } else if (codeDelta <= 127) {
1.3210 + TclStoreInt1AtPtr(codeDelta, p);
1.3211 + p++;
1.3212 + } else {
1.3213 + TclStoreInt1AtPtr(0xFF, p);
1.3214 + p++;
1.3215 + TclStoreInt4AtPtr(codeDelta, p);
1.3216 + p += 4;
1.3217 + }
1.3218 + prevOffset = mapPtr[i].codeOffset;
1.3219 + }
1.3220 +
1.3221 + /*
1.3222 + * Encode the code length for each command.
1.3223 + */
1.3224 +
1.3225 + codePtr->codeLengthStart = p;
1.3226 + for (i = 0; i < numCmds; i++) {
1.3227 + codeLen = mapPtr[i].numCodeBytes;
1.3228 + if (codeLen < 0) {
1.3229 + panic("EncodeCmdLocMap: bad code length");
1.3230 + } else if (codeLen <= 127) {
1.3231 + TclStoreInt1AtPtr(codeLen, p);
1.3232 + p++;
1.3233 + } else {
1.3234 + TclStoreInt1AtPtr(0xFF, p);
1.3235 + p++;
1.3236 + TclStoreInt4AtPtr(codeLen, p);
1.3237 + p += 4;
1.3238 + }
1.3239 + }
1.3240 +
1.3241 + /*
1.3242 + * Encode the source offset for each command as a sequence of deltas.
1.3243 + */
1.3244 +
1.3245 + codePtr->srcDeltaStart = p;
1.3246 + prevOffset = 0;
1.3247 + for (i = 0; i < numCmds; i++) {
1.3248 + srcDelta = (mapPtr[i].srcOffset - prevOffset);
1.3249 + if ((-127 <= srcDelta) && (srcDelta <= 127)) {
1.3250 + TclStoreInt1AtPtr(srcDelta, p);
1.3251 + p++;
1.3252 + } else {
1.3253 + TclStoreInt1AtPtr(0xFF, p);
1.3254 + p++;
1.3255 + TclStoreInt4AtPtr(srcDelta, p);
1.3256 + p += 4;
1.3257 + }
1.3258 + prevOffset = mapPtr[i].srcOffset;
1.3259 + }
1.3260 +
1.3261 + /*
1.3262 + * Encode the source length for each command.
1.3263 + */
1.3264 +
1.3265 + codePtr->srcLengthStart = p;
1.3266 + for (i = 0; i < numCmds; i++) {
1.3267 + srcLen = mapPtr[i].numSrcBytes;
1.3268 + if (srcLen < 0) {
1.3269 + panic("EncodeCmdLocMap: bad source length");
1.3270 + } else if (srcLen <= 127) {
1.3271 + TclStoreInt1AtPtr(srcLen, p);
1.3272 + p++;
1.3273 + } else {
1.3274 + TclStoreInt1AtPtr(0xFF, p);
1.3275 + p++;
1.3276 + TclStoreInt4AtPtr(srcLen, p);
1.3277 + p += 4;
1.3278 + }
1.3279 + }
1.3280 +
1.3281 + return p;
1.3282 +}
1.3283 +
1.3284 +#ifdef TCL_COMPILE_DEBUG
1.3285 +/*
1.3286 + *----------------------------------------------------------------------
1.3287 + *
1.3288 + * TclPrintByteCodeObj --
1.3289 + *
1.3290 + * This procedure prints ("disassembles") the instructions of a
1.3291 + * bytecode object to stdout.
1.3292 + *
1.3293 + * Results:
1.3294 + * None.
1.3295 + *
1.3296 + * Side effects:
1.3297 + * None.
1.3298 + *
1.3299 + *----------------------------------------------------------------------
1.3300 + */
1.3301 +
1.3302 +void
1.3303 +TclPrintByteCodeObj(interp, objPtr)
1.3304 + Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
1.3305 + Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
1.3306 +{
1.3307 + ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
1.3308 + unsigned char *codeStart, *codeLimit, *pc;
1.3309 + unsigned char *codeDeltaNext, *codeLengthNext;
1.3310 + unsigned char *srcDeltaNext, *srcLengthNext;
1.3311 + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
1.3312 + Interp *iPtr = (Interp *) *codePtr->interpHandle;
1.3313 +
1.3314 + if (codePtr->refCount <= 0) {
1.3315 + return; /* already freed */
1.3316 + }
1.3317 +
1.3318 + codeStart = codePtr->codeStart;
1.3319 + codeLimit = (codeStart + codePtr->numCodeBytes);
1.3320 + numCmds = codePtr->numCommands;
1.3321 +
1.3322 + /*
1.3323 + * Print header lines describing the ByteCode.
1.3324 + */
1.3325 +
1.3326 + fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
1.3327 + (unsigned int) codePtr, codePtr->refCount,
1.3328 + codePtr->compileEpoch, (unsigned int) iPtr,
1.3329 + iPtr->compileEpoch);
1.3330 + fprintf(stdout, " Source ");
1.3331 + TclPrintSource(stdout, codePtr->source,
1.3332 + TclMin(codePtr->numSrcBytes, 55));
1.3333 + fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
1.3334 + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
1.3335 + codePtr->numLitObjects, codePtr->numAuxDataItems,
1.3336 + codePtr->maxStackDepth,
1.3337 +#ifdef TCL_COMPILE_STATS
1.3338 + (codePtr->numSrcBytes?
1.3339 + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
1.3340 +#else
1.3341 + 0.0);
1.3342 +#endif
1.3343 +#ifdef TCL_COMPILE_STATS
1.3344 + fprintf(stdout,
1.3345 + " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
1.3346 + codePtr->structureSize,
1.3347 + (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
1.3348 + codePtr->numCodeBytes,
1.3349 + (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
1.3350 + (codePtr->numExceptRanges * sizeof(ExceptionRange)),
1.3351 + (codePtr->numAuxDataItems * sizeof(AuxData)),
1.3352 + codePtr->numCmdLocBytes);
1.3353 +#endif /* TCL_COMPILE_STATS */
1.3354 +
1.3355 + /*
1.3356 + * If the ByteCode is the compiled body of a Tcl procedure, print
1.3357 + * information about that procedure. Note that we don't know the
1.3358 + * procedure's name since ByteCode's can be shared among procedures.
1.3359 + */
1.3360 +
1.3361 + if (codePtr->procPtr != NULL) {
1.3362 + Proc *procPtr = codePtr->procPtr;
1.3363 + int numCompiledLocals = procPtr->numCompiledLocals;
1.3364 + fprintf(stdout,
1.3365 + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
1.3366 + (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
1.3367 + numCompiledLocals);
1.3368 + if (numCompiledLocals > 0) {
1.3369 + CompiledLocal *localPtr = procPtr->firstLocalPtr;
1.3370 + for (i = 0; i < numCompiledLocals; i++) {
1.3371 + fprintf(stdout, " slot %d%s%s%s%s%s%s", i,
1.3372 + ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
1.3373 + ((localPtr->flags & VAR_ARRAY)? ", array" : ""),
1.3374 + ((localPtr->flags & VAR_LINK)? ", link" : ""),
1.3375 + ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),
1.3376 + ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
1.3377 + ((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
1.3378 + if (TclIsVarTemporary(localPtr)) {
1.3379 + fprintf(stdout, "\n");
1.3380 + } else {
1.3381 + fprintf(stdout, ", \"%s\"\n", localPtr->name);
1.3382 + }
1.3383 + localPtr = localPtr->nextPtr;
1.3384 + }
1.3385 + }
1.3386 + }
1.3387 +
1.3388 + /*
1.3389 + * Print the ExceptionRange array.
1.3390 + */
1.3391 +
1.3392 + if (codePtr->numExceptRanges > 0) {
1.3393 + fprintf(stdout, " Exception ranges %d, depth %d:\n",
1.3394 + codePtr->numExceptRanges, codePtr->maxExceptDepth);
1.3395 + for (i = 0; i < codePtr->numExceptRanges; i++) {
1.3396 + ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
1.3397 + fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
1.3398 + i, rangePtr->nestingLevel,
1.3399 + ((rangePtr->type == LOOP_EXCEPTION_RANGE)
1.3400 + ? "loop" : "catch"),
1.3401 + rangePtr->codeOffset,
1.3402 + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
1.3403 + switch (rangePtr->type) {
1.3404 + case LOOP_EXCEPTION_RANGE:
1.3405 + fprintf(stdout, "continue %d, break %d\n",
1.3406 + rangePtr->continueOffset, rangePtr->breakOffset);
1.3407 + break;
1.3408 + case CATCH_EXCEPTION_RANGE:
1.3409 + fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
1.3410 + break;
1.3411 + default:
1.3412 + panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
1.3413 + rangePtr->type);
1.3414 + }
1.3415 + }
1.3416 + }
1.3417 +
1.3418 + /*
1.3419 + * If there were no commands (e.g., an expression or an empty string
1.3420 + * was compiled), just print all instructions and return.
1.3421 + */
1.3422 +
1.3423 + if (numCmds == 0) {
1.3424 + pc = codeStart;
1.3425 + while (pc < codeLimit) {
1.3426 + fprintf(stdout, " ");
1.3427 + pc += TclPrintInstruction(codePtr, pc);
1.3428 + }
1.3429 + return;
1.3430 + }
1.3431 +
1.3432 + /*
1.3433 + * Print table showing the code offset, source offset, and source
1.3434 + * length for each command. These are encoded as a sequence of bytes.
1.3435 + */
1.3436 +
1.3437 + fprintf(stdout, " Commands %d:", numCmds);
1.3438 + codeDeltaNext = codePtr->codeDeltaStart;
1.3439 + codeLengthNext = codePtr->codeLengthStart;
1.3440 + srcDeltaNext = codePtr->srcDeltaStart;
1.3441 + srcLengthNext = codePtr->srcLengthStart;
1.3442 + codeOffset = srcOffset = 0;
1.3443 + for (i = 0; i < numCmds; i++) {
1.3444 + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
1.3445 + codeDeltaNext++;
1.3446 + delta = TclGetInt4AtPtr(codeDeltaNext);
1.3447 + codeDeltaNext += 4;
1.3448 + } else {
1.3449 + delta = TclGetInt1AtPtr(codeDeltaNext);
1.3450 + codeDeltaNext++;
1.3451 + }
1.3452 + codeOffset += delta;
1.3453 +
1.3454 + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
1.3455 + codeLengthNext++;
1.3456 + codeLen = TclGetInt4AtPtr(codeLengthNext);
1.3457 + codeLengthNext += 4;
1.3458 + } else {
1.3459 + codeLen = TclGetInt1AtPtr(codeLengthNext);
1.3460 + codeLengthNext++;
1.3461 + }
1.3462 +
1.3463 + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
1.3464 + srcDeltaNext++;
1.3465 + delta = TclGetInt4AtPtr(srcDeltaNext);
1.3466 + srcDeltaNext += 4;
1.3467 + } else {
1.3468 + delta = TclGetInt1AtPtr(srcDeltaNext);
1.3469 + srcDeltaNext++;
1.3470 + }
1.3471 + srcOffset += delta;
1.3472 +
1.3473 + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
1.3474 + srcLengthNext++;
1.3475 + srcLen = TclGetInt4AtPtr(srcLengthNext);
1.3476 + srcLengthNext += 4;
1.3477 + } else {
1.3478 + srcLen = TclGetInt1AtPtr(srcLengthNext);
1.3479 + srcLengthNext++;
1.3480 + }
1.3481 +
1.3482 + fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
1.3483 + ((i % 2)? " " : "\n "),
1.3484 + (i+1), codeOffset, (codeOffset + codeLen - 1),
1.3485 + srcOffset, (srcOffset + srcLen - 1));
1.3486 + }
1.3487 + if (numCmds > 0) {
1.3488 + fprintf(stdout, "\n");
1.3489 + }
1.3490 +
1.3491 + /*
1.3492 + * Print each instruction. If the instruction corresponds to the start
1.3493 + * of a command, print the command's source. Note that we don't need
1.3494 + * the code length here.
1.3495 + */
1.3496 +
1.3497 + codeDeltaNext = codePtr->codeDeltaStart;
1.3498 + srcDeltaNext = codePtr->srcDeltaStart;
1.3499 + srcLengthNext = codePtr->srcLengthStart;
1.3500 + codeOffset = srcOffset = 0;
1.3501 + pc = codeStart;
1.3502 + for (i = 0; i < numCmds; i++) {
1.3503 + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
1.3504 + codeDeltaNext++;
1.3505 + delta = TclGetInt4AtPtr(codeDeltaNext);
1.3506 + codeDeltaNext += 4;
1.3507 + } else {
1.3508 + delta = TclGetInt1AtPtr(codeDeltaNext);
1.3509 + codeDeltaNext++;
1.3510 + }
1.3511 + codeOffset += delta;
1.3512 +
1.3513 + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
1.3514 + srcDeltaNext++;
1.3515 + delta = TclGetInt4AtPtr(srcDeltaNext);
1.3516 + srcDeltaNext += 4;
1.3517 + } else {
1.3518 + delta = TclGetInt1AtPtr(srcDeltaNext);
1.3519 + srcDeltaNext++;
1.3520 + }
1.3521 + srcOffset += delta;
1.3522 +
1.3523 + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
1.3524 + srcLengthNext++;
1.3525 + srcLen = TclGetInt4AtPtr(srcLengthNext);
1.3526 + srcLengthNext += 4;
1.3527 + } else {
1.3528 + srcLen = TclGetInt1AtPtr(srcLengthNext);
1.3529 + srcLengthNext++;
1.3530 + }
1.3531 +
1.3532 + /*
1.3533 + * Print instructions before command i.
1.3534 + */
1.3535 +
1.3536 + while ((pc-codeStart) < codeOffset) {
1.3537 + fprintf(stdout, " ");
1.3538 + pc += TclPrintInstruction(codePtr, pc);
1.3539 + }
1.3540 +
1.3541 + fprintf(stdout, " Command %d: ", (i+1));
1.3542 + TclPrintSource(stdout, (codePtr->source + srcOffset),
1.3543 + TclMin(srcLen, 55));
1.3544 + fprintf(stdout, "\n");
1.3545 + }
1.3546 + if (pc < codeLimit) {
1.3547 + /*
1.3548 + * Print instructions after the last command.
1.3549 + */
1.3550 +
1.3551 + while (pc < codeLimit) {
1.3552 + fprintf(stdout, " ");
1.3553 + pc += TclPrintInstruction(codePtr, pc);
1.3554 + }
1.3555 + }
1.3556 +}
1.3557 +#endif /* TCL_COMPILE_DEBUG */
1.3558 +
1.3559 +/*
1.3560 + *----------------------------------------------------------------------
1.3561 + *
1.3562 + * TclPrintInstruction --
1.3563 + *
1.3564 + * This procedure prints ("disassembles") one instruction from a
1.3565 + * bytecode object to stdout.
1.3566 + *
1.3567 + * Results:
1.3568 + * Returns the length in bytes of the current instruiction.
1.3569 + *
1.3570 + * Side effects:
1.3571 + * None.
1.3572 + *
1.3573 + *----------------------------------------------------------------------
1.3574 + */
1.3575 +
1.3576 +int
1.3577 +TclPrintInstruction(codePtr, pc)
1.3578 + ByteCode* codePtr; /* Bytecode containing the instruction. */
1.3579 + unsigned char *pc; /* Points to first byte of instruction. */
1.3580 +{
1.3581 + Proc *procPtr = codePtr->procPtr;
1.3582 + unsigned char opCode = *pc;
1.3583 + register InstructionDesc *instDesc = &tclInstructionTable[opCode];
1.3584 + unsigned char *codeStart = codePtr->codeStart;
1.3585 + unsigned int pcOffset = (pc - codeStart);
1.3586 + int opnd, i, j;
1.3587 +
1.3588 + fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
1.3589 + for (i = 0; i < instDesc->numOperands; i++) {
1.3590 + switch (instDesc->opTypes[i]) {
1.3591 + case OPERAND_INT1:
1.3592 + opnd = TclGetInt1AtPtr(pc+1+i);
1.3593 + if ((i == 0) && ((opCode == INST_JUMP1)
1.3594 + || (opCode == INST_JUMP_TRUE1)
1.3595 + || (opCode == INST_JUMP_FALSE1))) {
1.3596 + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
1.3597 + } else {
1.3598 + fprintf(stdout, "%d", opnd);
1.3599 + }
1.3600 + break;
1.3601 + case OPERAND_INT4:
1.3602 + opnd = TclGetInt4AtPtr(pc+1+i);
1.3603 + if ((i == 0) && ((opCode == INST_JUMP4)
1.3604 + || (opCode == INST_JUMP_TRUE4)
1.3605 + || (opCode == INST_JUMP_FALSE4))) {
1.3606 + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
1.3607 + } else {
1.3608 + fprintf(stdout, "%d", opnd);
1.3609 + }
1.3610 + break;
1.3611 + case OPERAND_UINT1:
1.3612 + opnd = TclGetUInt1AtPtr(pc+1+i);
1.3613 + if ((i == 0) && (opCode == INST_PUSH1)) {
1.3614 + fprintf(stdout, "%u # ", (unsigned int) opnd);
1.3615 + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
1.3616 + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
1.3617 + || (opCode == INST_LOAD_ARRAY1)
1.3618 + || (opCode == INST_STORE_SCALAR1)
1.3619 + || (opCode == INST_STORE_ARRAY1))) {
1.3620 + int localCt = procPtr->numCompiledLocals;
1.3621 + CompiledLocal *localPtr = procPtr->firstLocalPtr;
1.3622 + if (opnd >= localCt) {
1.3623 + panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
1.3624 + (unsigned int) opnd, localCt);
1.3625 + return instDesc->numBytes;
1.3626 + }
1.3627 + for (j = 0; j < opnd; j++) {
1.3628 + localPtr = localPtr->nextPtr;
1.3629 + }
1.3630 + if (TclIsVarTemporary(localPtr)) {
1.3631 + fprintf(stdout, "%u # temp var %u",
1.3632 + (unsigned int) opnd, (unsigned int) opnd);
1.3633 + } else {
1.3634 + fprintf(stdout, "%u # var ", (unsigned int) opnd);
1.3635 + TclPrintSource(stdout, localPtr->name, 40);
1.3636 + }
1.3637 + } else {
1.3638 + fprintf(stdout, "%u ", (unsigned int) opnd);
1.3639 + }
1.3640 + break;
1.3641 + case OPERAND_UINT4:
1.3642 + opnd = TclGetUInt4AtPtr(pc+1+i);
1.3643 + if (opCode == INST_PUSH4) {
1.3644 + fprintf(stdout, "%u # ", opnd);
1.3645 + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
1.3646 + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
1.3647 + || (opCode == INST_LOAD_ARRAY4)
1.3648 + || (opCode == INST_STORE_SCALAR4)
1.3649 + || (opCode == INST_STORE_ARRAY4))) {
1.3650 + int localCt = procPtr->numCompiledLocals;
1.3651 + CompiledLocal *localPtr = procPtr->firstLocalPtr;
1.3652 + if (opnd >= localCt) {
1.3653 + panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
1.3654 + (unsigned int) opnd, localCt);
1.3655 + return instDesc->numBytes;
1.3656 + }
1.3657 + for (j = 0; j < opnd; j++) {
1.3658 + localPtr = localPtr->nextPtr;
1.3659 + }
1.3660 + if (TclIsVarTemporary(localPtr)) {
1.3661 + fprintf(stdout, "%u # temp var %u",
1.3662 + (unsigned int) opnd, (unsigned int) opnd);
1.3663 + } else {
1.3664 + fprintf(stdout, "%u # var ", (unsigned int) opnd);
1.3665 + TclPrintSource(stdout, localPtr->name, 40);
1.3666 + }
1.3667 + } else {
1.3668 + fprintf(stdout, "%u ", (unsigned int) opnd);
1.3669 + }
1.3670 + break;
1.3671 + case OPERAND_NONE:
1.3672 + default:
1.3673 + break;
1.3674 + }
1.3675 + }
1.3676 + fprintf(stdout, "\n");
1.3677 + return instDesc->numBytes;
1.3678 +}
1.3679 +
1.3680 +/*
1.3681 + *----------------------------------------------------------------------
1.3682 + *
1.3683 + * TclPrintObject --
1.3684 + *
1.3685 + * This procedure prints up to a specified number of characters from
1.3686 + * the argument Tcl object's string representation to a specified file.
1.3687 + *
1.3688 + * Results:
1.3689 + * None.
1.3690 + *
1.3691 + * Side effects:
1.3692 + * Outputs characters to the specified file.
1.3693 + *
1.3694 + *----------------------------------------------------------------------
1.3695 + */
1.3696 +
1.3697 +void
1.3698 +TclPrintObject(outFile, objPtr, maxChars)
1.3699 + FILE *outFile; /* The file to print the source to. */
1.3700 + Tcl_Obj *objPtr; /* Points to the Tcl object whose string
1.3701 + * representation should be printed. */
1.3702 + int maxChars; /* Maximum number of chars to print. */
1.3703 +{
1.3704 + char *bytes;
1.3705 + int length;
1.3706 +
1.3707 + bytes = Tcl_GetStringFromObj(objPtr, &length);
1.3708 + TclPrintSource(outFile, bytes, TclMin(length, maxChars));
1.3709 +}
1.3710 +
1.3711 +/*
1.3712 + *----------------------------------------------------------------------
1.3713 + *
1.3714 + * TclPrintSource --
1.3715 + *
1.3716 + * This procedure prints up to a specified number of characters from
1.3717 + * the argument string to a specified file. It tries to produce legible
1.3718 + * output by adding backslashes as necessary.
1.3719 + *
1.3720 + * Results:
1.3721 + * None.
1.3722 + *
1.3723 + * Side effects:
1.3724 + * Outputs characters to the specified file.
1.3725 + *
1.3726 + *----------------------------------------------------------------------
1.3727 + */
1.3728 +
1.3729 +void
1.3730 +TclPrintSource(outFile, string, maxChars)
1.3731 + FILE *outFile; /* The file to print the source to. */
1.3732 + CONST char *string; /* The string to print. */
1.3733 + int maxChars; /* Maximum number of chars to print. */
1.3734 +{
1.3735 + register CONST char *p;
1.3736 + register int i = 0;
1.3737 +
1.3738 + if (string == NULL) {
1.3739 + fprintf(outFile, "\"\"");
1.3740 + return;
1.3741 + }
1.3742 +
1.3743 + fprintf(outFile, "\"");
1.3744 + p = string;
1.3745 + for (; (*p != '\0') && (i < maxChars); p++, i++) {
1.3746 + switch (*p) {
1.3747 + case '"':
1.3748 + fprintf(outFile, "\\\"");
1.3749 + continue;
1.3750 + case '\f':
1.3751 + fprintf(outFile, "\\f");
1.3752 + continue;
1.3753 + case '\n':
1.3754 + fprintf(outFile, "\\n");
1.3755 + continue;
1.3756 + case '\r':
1.3757 + fprintf(outFile, "\\r");
1.3758 + continue;
1.3759 + case '\t':
1.3760 + fprintf(outFile, "\\t");
1.3761 + continue;
1.3762 + case '\v':
1.3763 + fprintf(outFile, "\\v");
1.3764 + continue;
1.3765 + default:
1.3766 + fprintf(outFile, "%c", *p);
1.3767 + continue;
1.3768 + }
1.3769 + }
1.3770 + fprintf(outFile, "\"");
1.3771 +}
1.3772 +
1.3773 +#ifdef TCL_COMPILE_STATS
1.3774 +/*
1.3775 + *----------------------------------------------------------------------
1.3776 + *
1.3777 + * RecordByteCodeStats --
1.3778 + *
1.3779 + * Accumulates various compilation-related statistics for each newly
1.3780 + * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
1.3781 + * compiled with the -DTCL_COMPILE_STATS flag
1.3782 + *
1.3783 + * Results:
1.3784 + * None.
1.3785 + *
1.3786 + * Side effects:
1.3787 + * Accumulates aggregate code-related statistics in the interpreter's
1.3788 + * ByteCodeStats structure. Records statistics specific to a ByteCode
1.3789 + * in its ByteCode structure.
1.3790 + *
1.3791 + *----------------------------------------------------------------------
1.3792 + */
1.3793 +
1.3794 +void
1.3795 +RecordByteCodeStats(codePtr)
1.3796 + ByteCode *codePtr; /* Points to ByteCode structure with info
1.3797 + * to add to accumulated statistics. */
1.3798 +{
1.3799 + Interp *iPtr = (Interp *) *codePtr->interpHandle;
1.3800 + register ByteCodeStats *statsPtr = &(iPtr->stats);
1.3801 +
1.3802 + statsPtr->numCompilations++;
1.3803 + statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
1.3804 + statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
1.3805 + statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
1.3806 + statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
1.3807 +
1.3808 + statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
1.3809 + statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++;
1.3810 +
1.3811 + statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
1.3812 + statsPtr->currentLitBytes +=
1.3813 + (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
1.3814 + statsPtr->currentExceptBytes +=
1.3815 + (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
1.3816 + statsPtr->currentAuxBytes +=
1.3817 + (double) (codePtr->numAuxDataItems * sizeof(AuxData));
1.3818 + statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
1.3819 +}
1.3820 +#endif /* TCL_COMPILE_STATS */
1.3821 +
1.3822 +/*
1.3823 + * Local Variables:
1.3824 + * mode: c
1.3825 + * c-basic-offset: 4
1.3826 + * fill-column: 78
1.3827 + * End:
1.3828 + */
1.3829 +