diff -r 000000000000 -r bde4ae8d615e os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCompile.c --- /dev/null Thu Jan 01 00:00:00 1970 +0000 +++ b/os/persistentdata/persistentstorage/sqlite3api/TEST/TCL/tcldistribution/generic/tclCompile.c Fri Jun 15 03:10:57 2012 +0200 @@ -0,0 +1,3826 @@ +/* + * tclCompile.c -- + * + * This file contains procedures that compile Tcl commands or parts + * of commands (like quoted strings or nested sub-commands) into a + * sequence of instructions ("bytecodes"). + * + * Copyright (c) 1996-1998 Sun Microsystems, Inc. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Portions Copyright (c) 2007 Nokia Corporation and/or its subsidiaries. All rights reserved. + * + * See the file "license.terms" for information on usage and redistribution + * of this file, and for a DISCLAIMER OF ALL WARRANTIES. + * + * RCS: @(#) $Id: tclCompile.c,v 1.43.2.7 2006/11/28 22:20:00 andreas_kupries Exp $ + */ + +#include "tclInt.h" +#include "tclCompile.h" +#if defined(__SYMBIAN32__) && defined(__WINSCW__) +#include "tclSymbianGlobals.h" +#define dataKey getdataKey(0) +#endif + +#if !defined(__SYMBIAN32__) || !defined(__WINSCW__) +/* + * Table of all AuxData types. + */ + +static Tcl_HashTable auxDataTypeTable; +static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ +#endif +TCL_DECLARE_MUTEX(tableMutex) + +/* + * Variable that controls whether compilation tracing is enabled and, if so, + * what level of tracing is desired: + * 0: no compilation tracing + * 1: summarize compilation of top level cmds and proc bodies + * 2: display all instructions of each ByteCode compiled + * This variable is linked to the Tcl variable "tcl_traceCompile". + */ + +#ifdef TCL_COMPILE_DEBUG +int tclTraceCompile = 0; +static int traceInitialized = 0; +#endif + +/* + * A table describing the Tcl bytecode instructions. Entries in this table + * must correspond to the instruction opcode definitions in tclCompile.h. + * The names "op1" and "op4" refer to an instruction's one or four byte + * first operand. Similarly, "stktop" and "stknext" refer to the topmost + * and next to topmost stack elements. + * + * Note that the load, store, and incr instructions do not distinguish local + * from global variables; the bytecode interpreter at runtime uses the + * existence of a procedure call frame to distinguish these. + */ + +InstructionDesc tclInstructionTable[] = { + /* Name Bytes stackEffect #Opnds Operand types Stack top, next */ + {"done", 1, -1, 0, {OPERAND_NONE}}, + /* Finish ByteCode execution and return stktop (top stack item) */ + {"push1", 2, +1, 1, {OPERAND_UINT1}}, + /* Push object at ByteCode objArray[op1] */ + {"push4", 5, +1, 1, {OPERAND_UINT4}}, + /* Push object at ByteCode objArray[op4] */ + {"pop", 1, -1, 0, {OPERAND_NONE}}, + /* Pop the topmost stack object */ + {"dup", 1, +1, 0, {OPERAND_NONE}}, + /* Duplicate the topmost stack object and push the result */ + {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Concatenate the top op1 items and push result */ + {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Invoke command named objv[0]; = */ + {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Invoke command named objv[0]; = */ + {"evalStk", 1, 0, 0, {OPERAND_NONE}}, + /* Evaluate command in stktop using Tcl_EvalObj. */ + {"exprStk", 1, 0, 0, {OPERAND_NONE}}, + /* Execute expression in stktop using Tcl_ExprStringObj. */ + + {"loadScalar1", 2, 1, 1, {OPERAND_UINT1}}, + /* Load scalar variable at index op1 <= 255 in call frame */ + {"loadScalar4", 5, 1, 1, {OPERAND_UINT4}}, + /* Load scalar variable at index op1 >= 256 in call frame */ + {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, + /* Load scalar variable; scalar's name is stktop */ + {"loadArray1", 2, 0, 1, {OPERAND_UINT1}}, + /* Load array element; array at slot op1<=255, element is stktop */ + {"loadArray4", 5, 0, 1, {OPERAND_UINT4}}, + /* Load array element; array at slot op1 > 255, element is stktop */ + {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, + /* Load array element; element is stktop, array name is stknext */ + {"loadStk", 1, 0, 0, {OPERAND_NONE}}, + /* Load general variable; unparsed variable name is stktop */ + {"storeScalar1", 2, 0, 1, {OPERAND_UINT1}}, + /* Store scalar variable at op1<=255 in frame; value is stktop */ + {"storeScalar4", 5, 0, 1, {OPERAND_UINT4}}, + /* Store scalar variable at op1 > 255 in frame; value is stktop */ + {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, + /* Store scalar; value is stktop, scalar name is stknext */ + {"storeArray1", 2, -1, 1, {OPERAND_UINT1}}, + /* Store array element; array at op1<=255, value is top then elem */ + {"storeArray4", 5, -1, 1, {OPERAND_UINT4}}, + /* Store array element; array at op1>=256, value is top then elem */ + {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Store array element; value is stktop, then elem, array names */ + {"storeStk", 1, -1, 0, {OPERAND_NONE}}, + /* Store general variable; value is stktop, then unparsed name */ + + {"incrScalar1", 2, 0, 1, {OPERAND_UINT1}}, + /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ + {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, + /* Incr scalar; incr amount is stktop, scalar's name is stknext */ + {"incrArray1", 2, -1, 1, {OPERAND_UINT1}}, + /* Incr array elem; arr at slot op1<=255, amount is top then elem */ + {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Incr array element; amount is top then elem then array names */ + {"incrStk", 1, -1, 0, {OPERAND_NONE}}, + /* Incr general variable; amount is stktop then unparsed var name */ + {"incrScalar1Imm", 3, +1, 2, {OPERAND_UINT1, OPERAND_INT1}}, + /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ + {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, + /* Incr scalar; scalar name is stktop; incr amount is op1 */ + {"incrArray1Imm", 3, 0, 2, {OPERAND_UINT1, OPERAND_INT1}}, + /* Incr array elem; array at slot op1 <= 255, elem is stktop, + * amount is 2nd operand byte */ + {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, + /* Incr array element; elem is top then array name, amount is op1 */ + {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, + /* Incr general variable; unparsed name is top, amount is op1 */ + + {"jump1", 2, 0, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) */ + {"jump4", 5, 0, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) */ + {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) if stktop expr object is true */ + {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) if stktop expr object is true */ + {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, + /* Jump relative to (pc + op1) if stktop expr object is false */ + {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, + /* Jump relative to (pc + op4) if stktop expr object is false */ + + {"lor", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"land", 1, -1, 0, {OPERAND_NONE}}, + /* Logical and: push (stknext && stktop) */ + {"bitor", 1, -1, 0, {OPERAND_NONE}}, + /* Bitwise or: push (stknext | stktop) */ + {"bitxor", 1, -1, 0, {OPERAND_NONE}}, + /* Bitwise xor push (stknext ^ stktop) */ + {"bitand", 1, -1, 0, {OPERAND_NONE}}, + /* Bitwise and: push (stknext & stktop) */ + {"eq", 1, -1, 0, {OPERAND_NONE}}, + /* Equal: push (stknext == stktop) */ + {"neq", 1, -1, 0, {OPERAND_NONE}}, + /* Not equal: push (stknext != stktop) */ + {"lt", 1, -1, 0, {OPERAND_NONE}}, + /* Less: push (stknext < stktop) */ + {"gt", 1, -1, 0, {OPERAND_NONE}}, + /* Greater: push (stknext || stktop) */ + {"le", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"ge", 1, -1, 0, {OPERAND_NONE}}, + /* Logical or: push (stknext || stktop) */ + {"lshift", 1, -1, 0, {OPERAND_NONE}}, + /* Left shift: push (stknext << stktop) */ + {"rshift", 1, -1, 0, {OPERAND_NONE}}, + /* Right shift: push (stknext >> stktop) */ + {"add", 1, -1, 0, {OPERAND_NONE}}, + /* Add: push (stknext + stktop) */ + {"sub", 1, -1, 0, {OPERAND_NONE}}, + /* Sub: push (stkext - stktop) */ + {"mult", 1, -1, 0, {OPERAND_NONE}}, + /* Multiply: push (stknext * stktop) */ + {"div", 1, -1, 0, {OPERAND_NONE}}, + /* Divide: push (stknext / stktop) */ + {"mod", 1, -1, 0, {OPERAND_NONE}}, + /* Mod: push (stknext % stktop) */ + {"uplus", 1, 0, 0, {OPERAND_NONE}}, + /* Unary plus: push +stktop */ + {"uminus", 1, 0, 0, {OPERAND_NONE}}, + /* Unary minus: push -stktop */ + {"bitnot", 1, 0, 0, {OPERAND_NONE}}, + /* Bitwise not: push ~stktop */ + {"not", 1, 0, 0, {OPERAND_NONE}}, + /* Logical not: push !stktop */ + {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, + /* Call builtin math function with index op1; any args are on stk */ + {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call non-builtin func objv[0]; = */ + {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, + /* Try converting stktop to first int then double if possible. */ + + {"break", 1, 0, 0, {OPERAND_NONE}}, + /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ + {"continue", 1, 0, 0, {OPERAND_NONE}}, + /* Skip to next iteration of closest enclosing loop; if none, + * return TCL_CONTINUE code. */ + + {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. */ + {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, + /* "Step" or begin next iteration of foreach loop. Push 0 if to + * terminate loop, else push 1. */ + + {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, + /* Record start of catch with the operand's exception index. + * Push the current stack depth onto a special catch stack. */ + {"endCatch", 1, 0, 0, {OPERAND_NONE}}, + /* End of last catch. Pop the bytecode interpreter's catch stack. */ + {"pushResult", 1, +1, 0, {OPERAND_NONE}}, + /* Push the interpreter's object result onto the stack. */ + {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, + /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as + * a new object onto the stack. */ + {"streq", 1, -1, 0, {OPERAND_NONE}}, + /* Str Equal: push (stknext eq stktop) */ + {"strneq", 1, -1, 0, {OPERAND_NONE}}, + /* Str !Equal: push (stknext neq stktop) */ + {"strcmp", 1, -1, 0, {OPERAND_NONE}}, + /* Str Compare: push (stknext cmp stktop) */ + {"strlen", 1, 0, 0, {OPERAND_NONE}}, + /* Str Length: push (strlen stktop) */ + {"strindex", 1, -1, 0, {OPERAND_NONE}}, + /* Str Index: push (strindex stknext stktop) */ + {"strmatch", 2, -1, 1, {OPERAND_INT1}}, + /* Str Match: push (strmatch stknext stktop) opnd == nocase */ + {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* List: push (stk1 stk2 ... stktop) */ + {"listindex", 1, -1, 0, {OPERAND_NONE}}, + /* List Index: push (listindex stknext stktop) */ + {"listlength", 1, 0, 0, {OPERAND_NONE}}, + /* List Len: push (listlength stktop) */ + {"appendScalar1", 2, 0, 1, {OPERAND_UINT1}}, + /* Append scalar variable at op1<=255 in frame; value is stktop */ + {"appendScalar4", 5, 0, 1, {OPERAND_UINT4}}, + /* Append scalar variable at op1 > 255 in frame; value is stktop */ + {"appendArray1", 2, -1, 1, {OPERAND_UINT1}}, + /* Append array element; array at op1<=255, value is top then elem */ + {"appendArray4", 5, -1, 1, {OPERAND_UINT4}}, + /* Append array element; array at op1>=256, value is top then elem */ + {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Append array element; value is stktop, then elem, array names */ + {"appendStk", 1, -1, 0, {OPERAND_NONE}}, + /* Append general variable; value is stktop, then unparsed name */ + {"lappendScalar1", 2, 0, 1, {OPERAND_UINT1}}, + /* Lappend scalar variable at op1<=255 in frame; value is stktop */ + {"lappendScalar4", 5, 0, 1, {OPERAND_UINT4}}, + /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ + {"lappendArray1", 2, -1, 1, {OPERAND_UINT1}}, + /* Lappend array element; array at op1<=255, value is top then elem */ + {"lappendArray4", 5, -1, 1, {OPERAND_UINT4}}, + /* Lappend array element; array at op1>=256, value is top then elem */ + {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, + /* Lappend array element; value is stktop, then elem, array names */ + {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, + /* Lappend general variable; value is stktop, then unparsed name */ + {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Lindex with generalized args, operand is number of stacked objs + * used: (operand-1) entries from stktop are the indices; then list + * to process. */ + {"over", 5, +1, 1, {OPERAND_UINT4}}, + /* Duplicate the arg-th element from top of stack (TOS=0) */ + {"lsetList", 1, -2, 0, {OPERAND_NONE}}, + /* Four-arg version of 'lset'. stktop is old value; next is + * new element value, next is the index list; pushes new value */ + {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Three- or >=5-arg version of 'lset', operand is number of + * stacked objs: stktop is old value, next is new element value, next + * come (operand-2) indices; pushes the new value. + */ + {0} +}; + +/* + * Prototypes for procedures defined later in this file: + */ + +static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr, + Tcl_Obj *copyPtr)); +static unsigned char * EncodeCmdLocMap _ANSI_ARGS_(( + CompileEnv *envPtr, ByteCode *codePtr, + unsigned char *startPtr)); +static void EnterCmdExtentData _ANSI_ARGS_(( + CompileEnv *envPtr, int cmdNumber, + int numSrcBytes, int numCodeBytes)); +static void EnterCmdStartData _ANSI_ARGS_(( + CompileEnv *envPtr, int cmdNumber, + int srcOffset, int codeOffset)); +static void FreeByteCodeInternalRep _ANSI_ARGS_(( + Tcl_Obj *objPtr)); +static int GetCmdLocEncodingSize _ANSI_ARGS_(( + CompileEnv *envPtr)); +static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp, + CONST char *script, CONST char *command, + int length)); +#ifdef TCL_COMPILE_STATS +static void RecordByteCodeStats _ANSI_ARGS_(( + ByteCode *codePtr)); +#endif /* TCL_COMPILE_STATS */ +static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp, + Tcl_Obj *objPtr)); + +#ifdef TCL_TIP280 +/* TIP #280 : Helper for building the per-word line information of all + * compiled commands */ +static void EnterCmdWordData _ANSI_ARGS_(( + ExtCmdLoc *eclPtr, int srcOffset, Tcl_Token* tokenPtr, + CONST char* cmd, int len, int numWords, int line, + int** lines)); +#endif + + +/* + * The structure below defines the bytecode Tcl object type by + * means of procedures that can be invoked by generic object code. + */ + +Tcl_ObjType tclByteCodeType = { + "bytecode", /* name */ + FreeByteCodeInternalRep, /* freeIntRepProc */ + DupByteCodeInternalRep, /* dupIntRepProc */ + (Tcl_UpdateStringProc *) NULL, /* updateStringProc */ + SetByteCodeFromAny /* setFromAnyProc */ +}; + +/* + *---------------------------------------------------------------------- + * + * TclSetByteCodeFromAny -- + * + * Part of the bytecode Tcl object type implementation. Attempts to + * generate an byte code internal form for the Tcl object "objPtr" by + * compiling its string representation. This function also takes + * a hook procedure that will be invoked to perform any needed post + * processing on the compilation results before generating byte + * codes. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during compilation, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * Frees the old internal representation. If no error occurs, then the + * compiled code is stored as "objPtr"s bytecode representation. + * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable + * used to trace compilations. + * + *---------------------------------------------------------------------- + */ + +int +TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData) + Tcl_Interp *interp; /* The interpreter for which the code is + * being compiled. Must not be NULL. */ + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ + CompileHookProc *hookProc; /* Procedure to invoke after compilation. */ + ClientData clientData; /* Hook procedure private data. */ +{ + Interp *iPtr = (Interp *) interp; + CompileEnv compEnv; /* Compilation environment structure + * allocated in frame. */ + LiteralTable *localTablePtr = &(compEnv.localLitTable); + register AuxData *auxDataPtr; + LiteralEntry *entryPtr; + register int i; + int length, nested, result; + char *string; + +#ifdef TCL_COMPILE_DEBUG + if (!traceInitialized) { + if (Tcl_LinkVar(interp, "tcl_traceCompile", + (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { + panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); + } + traceInitialized = 1; + } +#endif + + if (iPtr->evalFlags & TCL_BRACKET_TERM) { + nested = 1; + } else { + nested = 0; + } + string = Tcl_GetStringFromObj(objPtr, &length); +#ifndef TCL_TIP280 + TclInitCompileEnv(interp, &compEnv, string, length); +#else + /* + * TIP #280. Pick up the CmdFrame in which the BC compiler was invoked + * and use to initialize the tracking in the compiler. This information + * was stored by TclCompEvalObj (tclExecute.c), and ProcCompileProc + * (tclProc.c). + */ + + TclInitCompileEnv(interp, &compEnv, string, length, + iPtr->invokeCmdFramePtr, iPtr->invokeWord); +#endif + result = TclCompileScript(interp, string, length, nested, &compEnv); + + if (result == TCL_OK) { + /* + * Successful compilation. Add a "done" instruction at the end. + */ + + compEnv.numSrcBytes = iPtr->termOffset; + TclEmitOpcode(INST_DONE, &compEnv); + + /* + * Invoke the compilation hook procedure if one exists. + */ + + if (hookProc) { + result = (*hookProc)(interp, &compEnv, clientData); + } + + /* + * Change the object into a ByteCode object. Ownership of the literal + * objects and aux data items is given to the ByteCode object. + */ + +#ifdef TCL_COMPILE_DEBUG + TclVerifyLocalLiteralTable(&compEnv); +#endif /*TCL_COMPILE_DEBUG*/ + + TclInitByteCodeObj(objPtr, &compEnv); +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + } +#endif /* TCL_COMPILE_DEBUG */ + } + + if (result != TCL_OK) { + /* + * Compilation errors. + */ + + entryPtr = compEnv.literalArrayPtr; + for (i = 0; i < compEnv.literalArrayNext; i++) { + TclReleaseLiteral(interp, entryPtr->objPtr); + entryPtr++; + } +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + + auxDataPtr = compEnv.auxDataArrayPtr; + for (i = 0; i < compEnv.auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + } + + + /* + * Free storage allocated during compilation. + */ + + if (localTablePtr->buckets != localTablePtr->staticBuckets) { + ckfree((char *) localTablePtr->buckets); + } + TclFreeCompileEnv(&compEnv); + return result; +} + +/* + *----------------------------------------------------------------------- + * + * SetByteCodeFromAny -- + * + * Part of the bytecode Tcl object type implementation. Attempts to + * generate an byte code internal form for the Tcl object "objPtr" by + * compiling its string representation. + * + * Results: + * The return value is a standard Tcl object result. If an error occurs + * during compilation, an error message is left in the interpreter's + * result unless "interp" is NULL. + * + * Side effects: + * Frees the old internal representation. If no error occurs, then the + * compiled code is stored as "objPtr"s bytecode representation. + * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable + * used to trace compilations. + * + *---------------------------------------------------------------------- + */ + +static int +SetByteCodeFromAny(interp, objPtr) + Tcl_Interp *interp; /* The interpreter for which the code is + * being compiled. Must not be NULL. */ + Tcl_Obj *objPtr; /* The object to make a ByteCode object. */ +{ + return TclSetByteCodeFromAny(interp, objPtr, + (CompileHookProc *) NULL, (ClientData) NULL); +} + +/* + *---------------------------------------------------------------------- + * + * DupByteCodeInternalRep -- + * + * Part of the bytecode Tcl object type implementation. However, it + * does not copy the internal representation of a bytecode Tcl_Obj, but + * instead leaves the new object untyped (with a NULL type pointer). + * Code will be compiled for the new object only if necessary. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static void +DupByteCodeInternalRep(srcPtr, copyPtr) + Tcl_Obj *srcPtr; /* Object with internal rep to copy. */ + Tcl_Obj *copyPtr; /* Object with internal rep to set. */ +{ + return; +} + +/* + *---------------------------------------------------------------------- + * + * FreeByteCodeInternalRep -- + * + * Part of the bytecode Tcl object type implementation. Frees the + * storage associated with a bytecode object's internal representation + * unless its code is actively being executed. + * + * Results: + * None. + * + * Side effects: + * The bytecode object's internal rep is marked invalid and its + * code gets freed unless the code is actively being executed. + * In that case the cleanup is delayed until the last execution + * of the code completes. + * + *---------------------------------------------------------------------- + */ + +static void +FreeByteCodeInternalRep(objPtr) + register Tcl_Obj *objPtr; /* Object whose internal rep to free. */ +{ + register ByteCode *codePtr = + (ByteCode *) objPtr->internalRep.otherValuePtr; + + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } + objPtr->typePtr = NULL; + objPtr->internalRep.otherValuePtr = NULL; +} + +/* + *---------------------------------------------------------------------- + * + * TclCleanupByteCode -- + * + * This procedure does all the real work of freeing up a bytecode + * object's ByteCode structure. It's called only when the structure's + * reference count becomes zero. + * + * Results: + * None. + * + * Side effects: + * Frees objPtr's bytecode internal representation and sets its type + * and objPtr->internalRep.otherValuePtr NULL. Also releases its + * literals and frees its auxiliary data items. + * + *---------------------------------------------------------------------- + */ + +void +TclCleanupByteCode(codePtr) + register ByteCode *codePtr; /* Points to the ByteCode to free. */ +{ + Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; +#ifdef TCL_TIP280 + Interp* iPtr = (Interp*) interp; +#endif + int numLitObjects = codePtr->numLitObjects; + int numAuxDataItems = codePtr->numAuxDataItems; + register Tcl_Obj **objArrayPtr; + register AuxData *auxDataPtr; + int i; +#ifdef TCL_COMPILE_STATS + + if (interp != NULL) { + ByteCodeStats *statsPtr; + Tcl_Time destroyTime; + int lifetimeSec, lifetimeMicroSec, log2; + + statsPtr = &((Interp *) interp)->stats; + + statsPtr->numByteCodesFreed++; + statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; + statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; + + statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; + statsPtr->currentLitBytes -= + (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); + statsPtr->currentExceptBytes -= + (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); + statsPtr->currentAuxBytes -= + (double) (codePtr->numAuxDataItems * sizeof(AuxData)); + statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; + + Tcl_GetTime(&destroyTime); + lifetimeSec = destroyTime.sec - codePtr->createTime.sec; + if (lifetimeSec > 2000) { /* avoid overflow */ + lifetimeSec = 2000; + } + lifetimeMicroSec = + 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec); + + log2 = TclLog2(lifetimeMicroSec); + if (log2 > 31) { + log2 = 31; + } + statsPtr->lifetimeCount[log2]++; + } +#endif /* TCL_COMPILE_STATS */ + + /* + * A single heap object holds the ByteCode structure and its code, + * object, command location, and auxiliary data arrays. This means we + * only need to 1) decrement the ref counts of the LiteralEntry's in + * its literal array, 2) call the free procs for the auxiliary data + * items, and 3) free the ByteCode structure's heap object. + * + * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, + * like those generated from tbcload) is special, as they doesn't + * make use of the global literal table. They instead maintain + * private references to their literals which must be decremented. + */ + + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { + register Tcl_Obj *objPtr; + + objArrayPtr = codePtr->objArrayPtr; + for (i = 0; i < numLitObjects; i++) { + objPtr = *objArrayPtr; + if (objPtr) { + Tcl_DecrRefCount(objPtr); + } + objArrayPtr++; + } + codePtr->numLitObjects = 0; + } else if (interp != NULL) { + /* + * If the interp has already been freed, then Tcl will have already + * forcefully released all the literals used by ByteCodes compiled + * with respect to that interp. + */ + + objArrayPtr = codePtr->objArrayPtr; + for (i = 0; i < numLitObjects; i++) { + /* + * TclReleaseLiteral sets a ByteCode's object array entry NULL to + * indicate that it has already freed the literal. + */ + + if (*objArrayPtr != NULL) { + TclReleaseLiteral(interp, *objArrayPtr); + } + objArrayPtr++; + } + } + + auxDataPtr = codePtr->auxDataArrayPtr; + for (i = 0; i < numAuxDataItems; i++) { + if (auxDataPtr->type->freeProc != NULL) { + (*auxDataPtr->type->freeProc)(auxDataPtr->clientData); + } + auxDataPtr++; + } + +#ifdef TCL_TIP280 + /* + * TIP #280. Release the location data associated with this byte code + * structure, if any. NOTE: The interp we belong to may be gone already, + * and the data with it. + * + * See also tclBasic.c, DeleteInterpProc + */ + + if (iPtr) { + Tcl_HashEntry* hePtr = Tcl_FindHashEntry (iPtr->lineBCPtr, (char *) codePtr); + if (hePtr) { + ExtCmdLoc* eclPtr = (ExtCmdLoc*) Tcl_GetHashValue (hePtr); + int i; + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount (eclPtr->path); + } + for (i=0; i< eclPtr->nuloc; i++) { + ckfree ((char*) eclPtr->loc[i].line); + } + + if (eclPtr->loc != NULL) { + ckfree ((char*) eclPtr->loc); + } + + ckfree ((char*) eclPtr); + Tcl_DeleteHashEntry (hePtr); + } + } +#endif + + TclHandleRelease(codePtr->interpHandle); + ckfree((char *) codePtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclInitCompileEnv -- + * + * Initializes a CompileEnv compilation environment structure for the + * compilation of a string in an interpreter. + * + * Results: + * None. + * + * Side effects: + * The CompileEnv structure is initialized. + * + *---------------------------------------------------------------------- + */ + +void +#ifndef TCL_TIP280 +TclInitCompileEnv(interp, envPtr, string, numBytes) +#else +TclInitCompileEnv(interp, envPtr, string, numBytes, invoker, word) +#endif + Tcl_Interp *interp; /* The interpreter for which a CompileEnv + * structure is initialized. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure to + * initialize. */ + char *string; /* The source string to be compiled. */ + int numBytes; /* Number of bytes in source string. */ +#ifdef TCL_TIP280 + CONST CmdFrame* invoker; /* Location context invoking the bcc */ + int word; /* Index of the word in that context + * getting compiled */ +#endif +{ + Interp *iPtr = (Interp *) interp; + + envPtr->iPtr = iPtr; + envPtr->source = string; + envPtr->numSrcBytes = numBytes; + envPtr->procPtr = iPtr->compiledProcPtr; + envPtr->numCommands = 0; + envPtr->exceptDepth = 0; + envPtr->maxExceptDepth = 0; + envPtr->maxStackDepth = 0; + envPtr->currStackDepth = 0; + TclInitLiteralTable(&(envPtr->localLitTable)); + + envPtr->codeStart = envPtr->staticCodeSpace; + envPtr->codeNext = envPtr->codeStart; + envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); + envPtr->mallocedCodeArray = 0; + + envPtr->literalArrayPtr = envPtr->staticLiteralSpace; + envPtr->literalArrayNext = 0; + envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; + envPtr->mallocedLiteralArray = 0; + + envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; + envPtr->exceptArrayNext = 0; + envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; + envPtr->mallocedExceptArray = 0; + + envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; + envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; + envPtr->mallocedCmdMap = 0; + +#ifdef TCL_TIP280 + /* + * TIP #280: Set up the extended command location information, based on + * the context invoking the byte code compiler. This structure is used to + * keep the per-word line information for all compiled commands. + * + * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the + * non-compiling evaluator + */ + + envPtr->extCmdMapPtr = (ExtCmdLoc*) ckalloc (sizeof (ExtCmdLoc)); + envPtr->extCmdMapPtr->loc = NULL; + envPtr->extCmdMapPtr->nloc = 0; + envPtr->extCmdMapPtr->nuloc = 0; + envPtr->extCmdMapPtr->path = NULL; + + if (invoker == NULL) { + /* Initialize the compiler for relative counting */ + + envPtr->line = 1; + envPtr->extCmdMapPtr->type = (envPtr->procPtr + ? TCL_LOCATION_PROC + : TCL_LOCATION_BC); + } else { + /* Initialize the compiler using the context, making counting absolute + * to that context. Note that the context can be byte code + * execution. In that case we have to fill out the missing pieces + * (line, path, ...). Which may make change the type as well. + */ + + if ((invoker->nline <= word) || (invoker->line[word] < 0)) { + /* Word is not a literal, relative counting */ + + envPtr->line = 1; + envPtr->extCmdMapPtr->type = (envPtr->procPtr + ? TCL_LOCATION_PROC + : TCL_LOCATION_BC); + } else { + CmdFrame ctx = *invoker; + int pc = 0; + + if (invoker->type == TCL_LOCATION_BC) { + /* Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + TclGetSrcInfoForPc (&ctx); + pc = 1; + } + + envPtr->line = ctx.line [word]; + envPtr->extCmdMapPtr->type = ctx.type; + + if (ctx.type == TCL_LOCATION_SOURCE) { + if (pc) { + /* The reference 'TclGetSrcInfoForPc' made is transfered */ + envPtr->extCmdMapPtr->path = ctx.data.eval.path; + ctx.data.eval.path = NULL; + } else { + /* We have a new reference here */ + envPtr->extCmdMapPtr->path = ctx.data.eval.path; + Tcl_IncrRefCount (envPtr->extCmdMapPtr->path); + } + } + } + } +#endif + + envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; + envPtr->auxDataArrayNext = 0; + envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; + envPtr->mallocedAuxDataArray = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreeCompileEnv -- + * + * Free the storage allocated in a CompileEnv compilation environment + * structure. + * + * Results: + * None. + * + * Side effects: + * Allocated storage in the CompileEnv structure is freed. Note that + * its local literal table is not deleted and its literal objects are + * not released. In addition, storage referenced by its auxiliary data + * items is not freed. This is done so that, when compilation is + * successful, "ownership" of these objects and aux data items is + * handed over to the corresponding ByteCode structure. + * + *---------------------------------------------------------------------- + */ + +void +TclFreeCompileEnv(envPtr) + register CompileEnv *envPtr; /* Points to the CompileEnv structure. */ +{ + if (envPtr->mallocedCodeArray) { + ckfree((char *) envPtr->codeStart); + } + if (envPtr->mallocedLiteralArray) { + ckfree((char *) envPtr->literalArrayPtr); + } + if (envPtr->mallocedExceptArray) { + ckfree((char *) envPtr->exceptArrayPtr); + } + if (envPtr->mallocedCmdMap) { + ckfree((char *) envPtr->cmdMapPtr); + } + if (envPtr->mallocedAuxDataArray) { + ckfree((char *) envPtr->auxDataArrayPtr); + } +} + +#ifdef TCL_TIP280 +/* + *---------------------------------------------------------------------- + * + * TclWordKnownAtCompileTime -- + * + * Test whether the value of a token is completely known at compile time. + * + * Results: + * Returns true if the tokenPtr argument points to a word value that is + * completely known at compile time. Generally, values that are known at + * compile time can be compiled to their values, while values that cannot + * be known until substitution at runtime must be compiled to bytecode + * instructions that perform that substitution. For several commands, + * whether or not arguments are known at compile time determine whether + * it is worthwhile to compile at all. + * + * Side effects: + * None. + * + * TIP #280 + *---------------------------------------------------------------------- + */ + +int +TclWordKnownAtCompileTime (tokenPtr) + Tcl_Token* tokenPtr; +{ + int i; + Tcl_Token* sub; + + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {return 1;}; + if (tokenPtr->type != TCL_TOKEN_WORD) {return 0;}; + + /* Check the sub tokens of the word. It is a literal if we find + * only BS and TEXT tokens */ + + for (i=0, sub = tokenPtr + 1; + i < tokenPtr->numComponents; + i++, sub ++) { + if (sub->type == TCL_TOKEN_TEXT) continue; + if (sub->type == TCL_TOKEN_BS) continue; + return 0; + } + return 1; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TclCompileScript -- + * + * Compile a Tcl script in a string. + * + * Results: + * The return value is TCL_OK on a successful compilation and TCL_ERROR + * on failure. If TCL_ERROR is returned, then the interpreter's result + * contains an error message. + * + * interp->termOffset is set to the offset of the character in the + * script just after the last one successfully processed; this will be + * the offset of the ']' if (flags & TCL_BRACKET_TERM). + * + * Side effects: + * Adds instructions to envPtr to evaluate the script at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileScript(interp, script, numBytes, nested, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. + * Also serves as context for finding and + * compiling commands. May not be NULL. */ + CONST char *script; /* The source script to compile. */ + int numBytes; /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + int nested; /* Non-zero means this is a nested command: + * close bracket ']' should be considered a + * command terminator. If zero, close + * bracket has no special meaning. */ + CompileEnv *envPtr; /* Holds resulting instructions. */ +{ + Interp *iPtr = (Interp *) interp; + Tcl_Parse parse; + int lastTopLevelCmdIndex = -1; + /* Index of most recent toplevel command in + * the command location table. Initialized + * to avoid compiler warning. */ + int startCodeOffset = -1; /* Offset of first byte of current command's + * code. Init. to avoid compiler warning. */ + unsigned char *entryCodeNext = envPtr->codeNext; + CONST char *p, *next; + Namespace *cmdNsPtr; + Command *cmdPtr; + Tcl_Token *tokenPtr; + int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex; + int commandLength, objIndex, code; + Tcl_DString ds; + +#ifdef TCL_TIP280 + /* TIP #280 */ + ExtCmdLoc* eclPtr = envPtr->extCmdMapPtr; + int* wlines; + int wlineat, cmdLine; +#endif + + Tcl_DStringInit(&ds); + + if (numBytes < 0) { + numBytes = strlen(script); + } + Tcl_ResetResult(interp); + isFirstCmd = 1; + + /* + * Each iteration through the following loop compiles the next + * command from the script. + */ + + p = script; + bytesLeft = numBytes; + gotParse = 0; +#ifdef TCL_TIP280 + cmdLine = envPtr->line; +#endif + + do { + if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) { + code = TCL_ERROR; + goto error; + } + gotParse = 1; + if (nested) { + /* + * This is an unusual situation where the caller has passed us + * a non-zero value for "nested". How unusual? Well, this + * procedure, TclCompileScript, is internal to Tcl, so all + * callers should be within Tcl itself. All but one of those + * callers explicitly pass in (nested = 0). The exceptional + * caller is TclSetByteCodeFromAny, which will pass in + * (nested = 1) if and only if the flag TCL_BRACKET_TERM + * is set in the evalFlags field of interp. + * + * It appears that the TCL_BRACKET_TERM flag is only ever set + * by Tcl_SubstObj, and it immediately calls Tcl_EvalEx + * which clears the flag before passing the interp along. + * So, I don't think this procedure, TclCompileScript, is + * **ever** called with (nested != 0). + * (The testsuite indeed doesn't exercise this code. MS) + * + * This means that the branches in this procedure that are + * only active when (nested != 0) are probably never exercised. + * This means that any bugs in them go unnoticed, and any bug + * fixes in them have a semi-theoretical nature. + * + * All that said, the spec for this procedure says it should + * handle the (nested != 0) case, so here's an attempt to fix + * bugs (Tcl Bug 681841) in that case. Just in case some + * callers eventually come along and expect it to work... + */ + + if (parse.term == (script + numBytes)) { + /* + * The (nested != 0) case is meant to indicate that the + * caller found an open bracket ([) and asked us to + * parse and compile Tcl commands up to the matching + * close bracket (]). We have to detect and handle + * the case where the close bracket is missing. + */ + + Tcl_SetObjResult(interp, + Tcl_NewStringObj("missing close-bracket", -1)); + code = TCL_ERROR; + goto error; + } + } + if (parse.numWords > 0) { + /* + * If not the first command, pop the previous command's result + * and, if we're compiling a top level command, update the last + * command's code size to account for the pop instruction. + */ + + if (!isFirstCmd) { + TclEmitOpcode(INST_POP, envPtr); + if (!nested) { + envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = + (envPtr->codeNext - envPtr->codeStart) + - startCodeOffset; + } + } + + /* + * Determine the actual length of the command. + */ + + commandLength = parse.commandSize; + if (parse.term == parse.commandStart + commandLength - 1) { + /* + * The command terminator character (such as ; or ]) is + * the last character in the parsed command. Reduce the + * length by one so that the trace message doesn't include + * the terminator character. + */ + + commandLength -= 1; + } + +#ifdef TCL_COMPILE_DEBUG + /* + * If tracing, print a line for each top level command compiled. + */ + + if ((tclTraceCompile >= 1) + && !nested && (envPtr->procPtr == NULL)) { + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(commandLength, 55)); + fprintf(stdout, "\n"); + } +#endif + /* + * Each iteration of the following loop compiles one word + * from the command. + */ + + envPtr->numCommands++; + currCmdIndex = (envPtr->numCommands - 1); + if (!nested) { + lastTopLevelCmdIndex = currCmdIndex; + } + startCodeOffset = (envPtr->codeNext - envPtr->codeStart); + EnterCmdStartData(envPtr, currCmdIndex, + (parse.commandStart - envPtr->source), startCodeOffset); + +#ifdef TCL_TIP280 + /* TIP #280. Scan the words and compute the extended location + * information. The map first contain full per-word line + * information for use by the compiler. This is later replaced by + * a reduced form which signals non-literal words, stored in + * 'wlines'. + */ + + TclAdvanceLines (&cmdLine, p, parse.commandStart); + EnterCmdWordData (eclPtr, (parse.commandStart - envPtr->source), + parse.tokenPtr, parse.commandStart, parse.commandSize, + parse.numWords, cmdLine, &wlines); + wlineat = eclPtr->nuloc - 1; +#endif + + for (wordIdx = 0, tokenPtr = parse.tokenPtr; + wordIdx < parse.numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { +#ifdef TCL_TIP280 + envPtr->line = eclPtr->loc [wlineat].line [wordIdx]; +#endif + if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { + /* + * If this is the first word and the command has a + * compile procedure, let it compile the command. + */ + + if (wordIdx == 0) { + if (envPtr->procPtr != NULL) { + cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; + } else { + cmdNsPtr = NULL; /* use current NS */ + } + + /* + * We copy the string before trying to find the command + * by name. We used to modify the string in place, but + * this is not safe because the name resolution + * handlers could have side effects that rely on the + * unmodified string. + */ + + Tcl_DStringSetLength(&ds, 0); + Tcl_DStringAppend(&ds, tokenPtr[1].start, + tokenPtr[1].size); + + cmdPtr = (Command *) Tcl_FindCommand(interp, + Tcl_DStringValue(&ds), + (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); + + if ((cmdPtr != NULL) + && (cmdPtr->compileProc != NULL) + && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) + && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + int savedNumCmds = envPtr->numCommands; + unsigned int savedCodeNext = + envPtr->codeNext - envPtr->codeStart; + + code = (*(cmdPtr->compileProc))(interp, &parse, + envPtr); + if (code == TCL_OK) { + goto finishCommand; + } else if (code == TCL_OUT_LINE_COMPILE) { + /* + * Restore numCommands and codeNext to their correct + * values, removing any commands compiled before + * TCL_OUT_LINE_COMPILE [Bugs 705406 and 735055] + */ + envPtr->numCommands = savedNumCmds; + envPtr->codeNext = envPtr->codeStart + savedCodeNext; + } else { /* an error */ + /* + * There was a compilation error, the last + * command did not get compiled into (*envPtr). + * Decrement the number of commands + * claimed to be in (*envPtr). + */ + envPtr->numCommands--; + goto log; + } + } + + /* + * No compile procedure so push the word. If the + * command was found, push a CmdName object to + * reduce runtime lookups. + */ + + objIndex = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (cmdPtr != NULL) { + TclSetCmdNameObj(interp, + envPtr->literalArrayPtr[objIndex].objPtr, + cmdPtr); + } + } else { + objIndex = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + } + TclEmitPush(objIndex, envPtr); + } else { + /* + * The word is not a simple string of characters. + */ + code = TclCompileTokens(interp, tokenPtr+1, + tokenPtr->numComponents, envPtr); + if (code != TCL_OK) { + goto log; + } + } + } + + /* + * Emit an invoke instruction for the command. We skip this + * if a compile procedure was found for the command. + */ + + if (wordIdx > 0) { + if (wordIdx <= 255) { + TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); + } else { + TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); + } + } + + /* + * Update the compilation environment structure and record the + * offsets of the source and code for the command. + */ + + finishCommand: + EnterCmdExtentData(envPtr, currCmdIndex, commandLength, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); + isFirstCmd = 0; + +#ifdef TCL_TIP280 + /* TIP #280: Free full form of per-word line data and insert + * the reduced form now + */ + ckfree ((char*) eclPtr->loc [wlineat].line); + eclPtr->loc [wlineat].line = wlines; +#endif + } /* end if parse.numWords > 0 */ + + /* + * Advance to the next command in the script. + */ + + next = parse.commandStart + parse.commandSize; + bytesLeft -= (next - p); + p = next; +#ifdef TCL_TIP280 + /* TIP #280 : Track lines in the just compiled command */ + TclAdvanceLines (&cmdLine, parse.commandStart, p); +#endif + Tcl_FreeParse(&parse); + gotParse = 0; + if (nested && (*parse.term == ']')) { + /* + * We get here in the special case where TCL_BRACKET_TERM was + * set in the interpreter and the latest parsed command was + * terminated by the matching close-bracket we were looking for. + * Stop compilation. + */ + + break; + } + } while (bytesLeft > 0); + + /* + * If the source script yielded no instructions (e.g., if it was empty), + * push an empty string as the command's result. + */ + + if (envPtr->codeNext == entryCodeNext) { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), + envPtr); + } + + if (nested) { + /* + * When (nested != 0) back up 1 character to have + * iPtr->termOffset indicate the offset to the matching + * close-bracket. + */ + + iPtr->termOffset = (p - 1) - script; + } else { + iPtr->termOffset = (p - script); + } + Tcl_DStringFree(&ds); + return TCL_OK; + + error: + /* + * Generate various pieces of error information, such as the line + * number where the error occurred and information to add to the + * errorInfo variable. Then free resources that had been allocated + * to the command. + */ + + commandLength = parse.commandSize; + if (parse.term == parse.commandStart + commandLength - 1) { + /* + * The terminator character (such as ; or ]) of the command where + * the error occurred is the last character in the parsed command. + * Reduce the length by one so that the error message doesn't + * include the terminator character. + */ + + commandLength -= 1; + } + + log: + LogCompilationInfo(interp, script, parse.commandStart, commandLength); + if (gotParse) { + Tcl_FreeParse(&parse); + } + iPtr->termOffset = (p - script); + Tcl_DStringFree(&ds); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileTokens -- + * + * Given an array of tokens parsed from a Tcl command (e.g., the tokens + * that make up a word) this procedure emits instructions to evaluate + * the tokens and concatenate their values to form a single result + * value on the interpreter's runtime evaluation stack. + * + * Results: + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * + * Side effects: + * Instructions are added to envPtr to push and evaluate the tokens + * at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileTokens(interp, tokenPtr, count, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * to compile. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + Tcl_DString textBuffer; /* Holds concatenated chars from adjacent + * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ + char buffer[TCL_UTF_MAX]; + CONST char *name, *p; + int numObjsToConcat, nameBytes, localVarName, localVar; + int length, i, code; + unsigned char *entryCodeNext = envPtr->codeNext; + + Tcl_DStringInit(&textBuffer); + numObjsToConcat = 0; + for ( ; count > 0; count--, tokenPtr++) { + switch (tokenPtr->type) { + case TCL_TOKEN_TEXT: + Tcl_DStringAppend(&textBuffer, tokenPtr->start, + tokenPtr->size); + break; + + case TCL_TOKEN_BS: + length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL, + buffer); + Tcl_DStringAppend(&textBuffer, buffer, length); + break; + + case TCL_TOKEN_COMMAND: + /* + * Push any accumulated chars appearing before the command. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + Tcl_DStringFree(&textBuffer); + } + + code = TclCompileScript(interp, tokenPtr->start+1, + tokenPtr->size-2, /*nested*/ 0, envPtr); + if (code != TCL_OK) { + goto error; + } + numObjsToConcat++; + break; + + case TCL_TOKEN_VARIABLE: + /* + * Push any accumulated chars appearing before the $. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, + Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + Tcl_DStringFree(&textBuffer); + } + + /* + * Determine how the variable name should be handled: if it contains + * any namespace qualifiers it is not a local variable (localVarName=-1); + * if it looks like an array element and the token has a single component, + * it should not be created here [Bug 569438] (localVarName=0); otherwise, + * the local variable can safely be created (localVarName=1). + */ + + name = tokenPtr[1].start; + nameBytes = tokenPtr[1].size; + localVarName = -1; + if (envPtr->procPtr != NULL) { + localVarName = 1; + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < (nameBytes-1)) + && (*(p+1) == ':')) { + localVarName = -1; + break; + } else if ((*p == '(') + && (tokenPtr->numComponents == 1) + && (*(name + nameBytes - 1) == ')')) { + localVarName = 0; + break; + } + } + } + + /* + * Either push the variable's name, or find its index in + * the array of local variables in a procedure frame. + */ + + localVar = -1; + if (localVarName != -1) { + localVar = TclFindCompiledLocal(name, nameBytes, + localVarName, /*flags*/ 0, envPtr->procPtr); + } + if (localVar < 0) { + TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), + envPtr); + } + + /* + * Emit instructions to load the variable. + */ + + if (tokenPtr->numComponents == 1) { + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, + envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, + envPtr); + } + } else { + code = TclCompileTokens(interp, tokenPtr+2, + tokenPtr->numComponents-1, envPtr); + if (code != TCL_OK) { + char errorBuffer[150]; + sprintf(errorBuffer, + "\n (parsing index for array \"%.*s\")", + ((nameBytes > 100)? 100 : nameBytes), name); + Tcl_AddObjErrorInfo(interp, errorBuffer, -1); + goto error; + } + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, + envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, + envPtr); + } + } + numObjsToConcat++; + count -= tokenPtr->numComponents; + tokenPtr += tokenPtr->numComponents; + break; + + default: + panic("Unexpected token type in TclCompileTokens"); + } + } + + /* + * Push any accumulated characters appearing at the end. + */ + + if (Tcl_DStringLength(&textBuffer) > 0) { + int literal; + + literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer), + Tcl_DStringLength(&textBuffer), /*onHeap*/ 0); + TclEmitPush(literal, envPtr); + numObjsToConcat++; + } + + /* + * If necessary, concatenate the parts of the word. + */ + + while (numObjsToConcat > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ + } + if (numObjsToConcat > 1) { + TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); + } + + /* + * If the tokens yielded no instructions, push an empty string. + */ + + if (envPtr->codeNext == entryCodeNext) { + TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0), + envPtr); + } + Tcl_DStringFree(&textBuffer); + return TCL_OK; + + error: + Tcl_DStringFree(&textBuffer); + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileCmdWord -- + * + * Given an array of parse tokens for a word containing one or more Tcl + * commands, emit inline instructions to execute them. This procedure + * differs from TclCompileTokens in that a simple word such as a loop + * body enclosed in braces is not just pushed as a string, but is + * itself parsed into tokens and compiled. + * + * Results: + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * + * Side effects: + * Instructions are added to envPtr to execute the tokens at runtime. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileCmdWord(interp, tokenPtr, count, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens + * for a command word to compile inline. */ + int count; /* Number of tokens to consider at tokenPtr. + * Must be at least 1. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + int code; + + /* + * Handle the common case: if there is a single text token, compile it + * into an inline sequence of instructions. + */ + + if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { + code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size, + /*nested*/ 0, envPtr); + return code; + } + + /* + * Multiple tokens or the single token involves substitutions. Emit + * instructions to invoke the eval command procedure at runtime on the + * result of evaluating the tokens. + */ + + code = TclCompileTokens(interp, tokenPtr, count, envPtr); + if (code != TCL_OK) { + return code; + } + TclEmitOpcode(INST_EVAL_STK, envPtr); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * + * TclCompileExprWords -- + * + * Given an array of parse tokens representing one or more words that + * contain a Tcl expression, emit inline instructions to execute the + * expression. This procedure differs from TclCompileExpr in that it + * supports Tcl's two-level substitution semantics for expressions that + * appear as command words. + * + * Results: + * The return value is a standard Tcl result. If an error occurs, an + * error message is left in the interpreter's result. + * + * Side effects: + * Instructions are added to envPtr to execute the expression. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileExprWords(interp, tokenPtr, numWords, envPtr) + Tcl_Interp *interp; /* Used for error and status reporting. */ + Tcl_Token *tokenPtr; /* Points to first in an array of word + * tokens tokens for the expression to + * compile inline. */ + int numWords; /* Number of word tokens starting at + * tokenPtr. Must be at least 1. Each word + * token contains one or more subtokens. */ + CompileEnv *envPtr; /* Holds the resulting instructions. */ +{ + Tcl_Token *wordPtr; + int numBytes, i, code; + CONST char *script; + + code = TCL_OK; + + /* + * If the expression is a single word that doesn't require + * substitutions, just compile its string into inline instructions. + */ + + if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { + script = tokenPtr[1].start; + numBytes = tokenPtr[1].size; + code = TclCompileExpr(interp, script, numBytes, envPtr); + return code; + } + + /* + * Emit code to call the expr command proc at runtime. Concatenate the + * (already substituted once) expr tokens with a space between each. + */ + + wordPtr = tokenPtr; + for (i = 0; i < numWords; i++) { + code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, + envPtr); + if (code != TCL_OK) { + break; + } + if (i < (numWords - 1)) { + TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0), + envPtr); + } + wordPtr += (wordPtr->numComponents + 1); + } + if (code == TCL_OK) { + int concatItems = 2*numWords - 1; + while (concatItems > 255) { + TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + concatItems -= 254; + } + if (concatItems > 1) { + TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + } + TclEmitOpcode(INST_EXPR_STK, envPtr); + } + + return code; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitByteCodeObj -- + * + * Create a ByteCode structure and initialize it from a CompileEnv + * compilation environment structure. The ByteCode structure is + * smaller and contains just that information needed to execute + * the bytecode instructions resulting from compiling a Tcl script. + * The resulting structure is placed in the specified object. + * + * Results: + * A newly constructed ByteCode object is stored in the internal + * representation of the objPtr. + * + * Side effects: + * A single heap object is allocated to hold the new ByteCode structure + * and its code, object, command location, and aux data arrays. Note + * that "ownership" (i.e., the pointers to) the Tcl objects and aux + * data items will be handed over to the new ByteCode structure from + * the CompileEnv structure. + * + *---------------------------------------------------------------------- + */ + +void +TclInitByteCodeObj(objPtr, envPtr) + Tcl_Obj *objPtr; /* Points object that should be + * initialized, and whose string rep + * contains the source code. */ + register CompileEnv *envPtr; /* Points to the CompileEnv structure from + * which to create a ByteCode structure. */ +{ + register ByteCode *codePtr; + size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; + size_t auxDataArrayBytes, structureSize; + register unsigned char *p; +#ifdef TCL_COMPILE_DEBUG + unsigned char *nextPtr; +#endif + int numLitObjects = envPtr->literalArrayNext; + Namespace *namespacePtr; + int i; +#ifdef TCL_TIP280 + int new; +#endif + Interp *iPtr; + + iPtr = envPtr->iPtr; + + codeBytes = (envPtr->codeNext - envPtr->codeStart); + objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); + exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); + auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); + cmdLocBytes = GetCmdLocEncodingSize(envPtr); + + /* + * Compute the total number of bytes needed for this bytecode. + */ + + structureSize = sizeof(ByteCode); + structureSize += TCL_ALIGN(codeBytes); /* align object array */ + structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ + structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + structureSize += auxDataArrayBytes; + structureSize += cmdLocBytes; + + if (envPtr->iPtr->varFramePtr != NULL) { + namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; + } else { + namespacePtr = envPtr->iPtr->globalNsPtr; + } + + p = (unsigned char *) ckalloc((size_t) structureSize); + codePtr = (ByteCode *) p; + codePtr->interpHandle = TclHandlePreserve(iPtr->handle); + codePtr->compileEpoch = iPtr->compileEpoch; + codePtr->nsPtr = namespacePtr; + codePtr->nsEpoch = namespacePtr->resolverEpoch; + codePtr->refCount = 1; + codePtr->flags = 0; + codePtr->source = envPtr->source; + codePtr->procPtr = envPtr->procPtr; + + codePtr->numCommands = envPtr->numCommands; + codePtr->numSrcBytes = envPtr->numSrcBytes; + codePtr->numCodeBytes = codeBytes; + codePtr->numLitObjects = numLitObjects; + codePtr->numExceptRanges = envPtr->exceptArrayNext; + codePtr->numAuxDataItems = envPtr->auxDataArrayNext; + codePtr->numCmdLocBytes = cmdLocBytes; + codePtr->maxExceptDepth = envPtr->maxExceptDepth; + codePtr->maxStackDepth = envPtr->maxStackDepth; + + p += sizeof(ByteCode); + codePtr->codeStart = p; + memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes); + + p += TCL_ALIGN(codeBytes); /* align object array */ + codePtr->objArrayPtr = (Tcl_Obj **) p; + for (i = 0; i < numLitObjects; i++) { + codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; + } + + p += TCL_ALIGN(objArrayBytes); /* align exception range array */ + if (exceptArrayBytes > 0) { + codePtr->exceptArrayPtr = (ExceptionRange *) p; + memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr, + (size_t) exceptArrayBytes); + } else { + codePtr->exceptArrayPtr = NULL; + } + + p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ + if (auxDataArrayBytes > 0) { + codePtr->auxDataArrayPtr = (AuxData *) p; + memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr, + (size_t) auxDataArrayBytes); + } else { + codePtr->auxDataArrayPtr = NULL; + } + + p += auxDataArrayBytes; +#ifndef TCL_COMPILE_DEBUG + EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); +#else + nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); + if (((size_t)(nextPtr - p)) != cmdLocBytes) { + panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); + } +#endif + + /* + * Record various compilation-related statistics about the new ByteCode + * structure. Don't include overhead for statistics-related fields. + */ + +#ifdef TCL_COMPILE_STATS + codePtr->structureSize = structureSize + - (sizeof(size_t) + sizeof(Tcl_Time)); + Tcl_GetTime(&(codePtr->createTime)); + + RecordByteCodeStats(codePtr); +#endif /* TCL_COMPILE_STATS */ + + /* + * Free the old internal rep then convert the object to a + * bytecode object by making its internal rep point to the just + * compiled ByteCode. + */ + + if ((objPtr->typePtr != NULL) && + (objPtr->typePtr->freeIntRepProc != NULL)) { + (*objPtr->typePtr->freeIntRepProc)(objPtr); + } + objPtr->internalRep.otherValuePtr = (VOID *) codePtr; + objPtr->typePtr = &tclByteCodeType; + +#ifdef TCL_TIP280 + /* TIP #280. Associate the extended per-word line information with the + * byte code object (internal rep), for use with the bc compiler. + */ + + Tcl_SetHashValue (Tcl_CreateHashEntry (iPtr->lineBCPtr, (char*) codePtr, &new), + envPtr->extCmdMapPtr); + envPtr->extCmdMapPtr = NULL; +#endif +} + +/* + *---------------------------------------------------------------------- + * + * LogCompilationInfo -- + * + * This procedure is invoked after an error occurs during compilation. + * It adds information to the "errorInfo" variable to describe the + * command that was being compiled when the error occurred. + * + * Results: + * None. + * + * Side effects: + * Information about the command is added to errorInfo and the + * line number stored internally in the interpreter is set. If this + * is the first call to this procedure or Tcl_AddObjErrorInfo since + * an error occurred, then old information in errorInfo is + * deleted. + * + *---------------------------------------------------------------------- + */ + +static void +LogCompilationInfo(interp, script, command, length) + Tcl_Interp *interp; /* Interpreter in which to log the + * information. */ + CONST char *script; /* First character in script containing + * command (must be <= command). */ + CONST char *command; /* First character in command that + * generated the error. */ + int length; /* Number of bytes in command (-1 means + * use all bytes up to first null byte). */ +{ + char buffer[200]; + register CONST char *p; + char *ellipsis = ""; + Interp *iPtr = (Interp *) interp; + + if (iPtr->flags & ERR_ALREADY_LOGGED) { + /* + * Someone else has already logged error information for this + * command; we shouldn't add anything more. + */ + + return; + } + + /* + * Compute the line number where the error occurred. + */ + + iPtr->errorLine = 1; + for (p = script; p != command; p++) { + if (*p == '\n') { + iPtr->errorLine++; + } + } + + /* + * Create an error message to add to errorInfo, including up to a + * maximum number of characters of the command. + */ + + if (length < 0) { + length = strlen(command); + } + if (length > 150) { + length = 150; + ellipsis = "..."; + } + while ( (command[length] & 0xC0) == 0x80 ) { + /* + * Back up truncation point so that we don't truncate in the + * middle of a multi-byte character (in UTF-8) + */ + length--; + ellipsis = "..."; + } + sprintf(buffer, "\n while compiling\n\"%.*s%s\"", + length, command, ellipsis); + Tcl_AddObjErrorInfo(interp, buffer, -1); +} + +/* + *---------------------------------------------------------------------- + * + * TclFindCompiledLocal -- + * + * This procedure is called at compile time to look up and optionally + * allocate an entry ("slot") for a variable in a procedure's array of + * local variables. If the variable's name is NULL, a new temporary + * variable is always created. (Such temporary variables can only be + * referenced using their slot index.) + * + * Results: + * If create is 0 and the name is non-NULL, then if the variable is + * found, the index of its entry in the procedure's array of local + * variables is returned; otherwise -1 is returned. If name is NULL, + * the index of a new temporary variable is returned. Finally, if + * create is 1 and name is non-NULL, the index of a new entry is + * returned. + * + * Side effects: + * Creates and registers a new local variable if create is 1 and + * the variable is unknown, or if the name is NULL. + * + *---------------------------------------------------------------------- + */ + +int +TclFindCompiledLocal(name, nameBytes, create, flags, procPtr) + register CONST char *name; /* Points to first character of the name of + * a scalar or array variable. If NULL, a + * temporary var should be created. */ + int nameBytes; /* Number of bytes in the name. */ + int create; /* If 1, allocate a local frame entry for + * the variable if it is new. */ + int flags; /* Flag bits for the compiled local if + * created. Only VAR_SCALAR, VAR_ARRAY, and + * VAR_LINK make sense. */ + register Proc *procPtr; /* Points to structure describing procedure + * containing the variable reference. */ +{ + register CompiledLocal *localPtr; + int localVar = -1; + register int i; + + /* + * If not creating a temporary, does a local variable of the specified + * name already exist? + */ + + if (name != NULL) { + int localCt = procPtr->numCompiledLocals; + localPtr = procPtr->firstLocalPtr; + for (i = 0; i < localCt; i++) { + if (!TclIsVarTemporary(localPtr)) { + char *localName = localPtr->name; + if ((nameBytes == localPtr->nameLength) + && (strncmp(name, localName, (unsigned) nameBytes) == 0)) { + return i; + } + } + localPtr = localPtr->nextPtr; + } + } + + /* + * Create a new variable if appropriate. + */ + + if (create || (name == NULL)) { + localVar = procPtr->numCompiledLocals; + localPtr = (CompiledLocal *) ckalloc((unsigned) + (sizeof(CompiledLocal) - sizeof(localPtr->name) + + nameBytes+1)); + if (procPtr->firstLocalPtr == NULL) { + procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; + } else { + procPtr->lastLocalPtr->nextPtr = localPtr; + procPtr->lastLocalPtr = localPtr; + } + localPtr->nextPtr = NULL; + localPtr->nameLength = nameBytes; + localPtr->frameIndex = localVar; + localPtr->flags = flags | VAR_UNDEFINED; + if (name == NULL) { + localPtr->flags |= VAR_TEMPORARY; + } + localPtr->defValuePtr = NULL; + localPtr->resolveInfo = NULL; + + if (name != NULL) { + memcpy((VOID *) localPtr->name, (VOID *) name, + (size_t) nameBytes); + } + localPtr->name[nameBytes] = '\0'; + procPtr->numCompiledLocals++; + } + return localVar; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitCompiledLocals -- + * + * This routine is invoked in order to initialize the compiled + * locals table for a new call frame. + * + * Results: + * None. + * + * Side effects: + * May invoke various name resolvers in order to determine which + * variables are being referenced at runtime. + * + *---------------------------------------------------------------------- + */ + +void +TclInitCompiledLocals(interp, framePtr, nsPtr) + Tcl_Interp *interp; /* Current interpreter. */ + CallFrame *framePtr; /* Call frame to initialize. */ + Namespace *nsPtr; /* Pointer to current namespace. */ +{ + register CompiledLocal *localPtr; + Interp *iPtr = (Interp*) interp; + Tcl_ResolvedVarInfo *vinfo, *resVarInfo; + Var *varPtr = framePtr->compiledLocals; + Var *resolvedVarPtr; + ResolverScheme *resPtr; + int result; + + /* + * Initialize the array of local variables stored in the call frame. + * Some variables may have special resolution rules. In that case, + * we call their "resolver" procs to get our hands on the variable, + * and we make the compiled local a link to the real variable. + */ + + for (localPtr = framePtr->procPtr->firstLocalPtr; + localPtr != NULL; + localPtr = localPtr->nextPtr) { + + /* + * Check to see if this local is affected by namespace or + * interp resolvers. The resolver to use is cached for the + * next invocation of the procedure. + */ + + if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED)) + && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) { + resPtr = iPtr->resolverPtr; + + if (nsPtr->compiledVarResProc) { + result = (*nsPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } else { + result = TCL_CONTINUE; + } + + while ((result == TCL_CONTINUE) && resPtr) { + if (resPtr->compiledVarResProc) { + result = (*resPtr->compiledVarResProc)(nsPtr->interp, + localPtr->name, localPtr->nameLength, + (Tcl_Namespace *) nsPtr, &vinfo); + } + resPtr = resPtr->nextPtr; + } + if (result == TCL_OK) { + localPtr->resolveInfo = vinfo; + localPtr->flags |= VAR_RESOLVED; + } + } + + /* + * Now invoke the resolvers to determine the exact variables that + * should be used. + */ + + resVarInfo = localPtr->resolveInfo; + resolvedVarPtr = NULL; + + if (resVarInfo && resVarInfo->fetchProc) { + resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp, + resVarInfo); + } + + if (resolvedVarPtr) { + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = 0; + TclSetVarLink(varPtr); + varPtr->value.linkPtr = resolvedVarPtr; + resolvedVarPtr->refCount++; + } else { + varPtr->value.objPtr = NULL; + varPtr->name = localPtr->name; /* will be just '\0' if temp var */ + varPtr->nsPtr = NULL; + varPtr->hPtr = NULL; + varPtr->refCount = 0; + varPtr->tracePtr = NULL; + varPtr->searchPtr = NULL; + varPtr->flags = localPtr->flags; + } + varPtr++; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclExpandCodeArray -- + * + * Procedure that uses malloc to allocate more storage for a + * CompileEnv's code array. + * + * Results: + * None. + * + * Side effects: + * The byte code array in *envPtr is reallocated to a new array of + * double the size, and if envPtr->mallocedCodeArray is non-zero the + * old array is freed. Byte codes are copied from the old array to the + * new one. + * + *---------------------------------------------------------------------- + */ + +void +TclExpandCodeArray(envArgPtr) + void *envArgPtr; /* Points to the CompileEnv whose code array + * must be enlarged. */ +{ + CompileEnv *envPtr = (CompileEnv*) envArgPtr; /* Points to the CompileEnv whose code array + * must be enlarged. */ + + /* + * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined + * code bytes are stored between envPtr->codeStart and + * (envPtr->codeNext - 1) [inclusive]. + */ + + size_t currBytes = (envPtr->codeNext - envPtr->codeStart); + size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); + unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); + + /* + * Copy from old code array to new, free old code array if needed, and + * mark new code array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes); + if (envPtr->mallocedCodeArray) { + ckfree((char *) envPtr->codeStart); + } + envPtr->codeStart = newPtr; + envPtr->codeNext = (newPtr + currBytes); + envPtr->codeEnd = (newPtr + newBytes); + envPtr->mallocedCodeArray = 1; +} + +/* + *---------------------------------------------------------------------- + * + * EnterCmdStartData -- + * + * Registers the starting source and bytecode location of a + * command. This information is used at runtime to map between + * instruction pc and source locations. + * + * Results: + * None. + * + * Side effects: + * Inserts source and code location information into the compilation + * environment envPtr for the command at index cmdIndex. The + * compilation environment's CmdLocation array is grown if necessary. + * + *---------------------------------------------------------------------- + */ + +static void +EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset) + CompileEnv *envPtr; /* Points to the compilation environment + * structure in which to enter command + * location information. */ + int cmdIndex; /* Index of the command whose start data + * is being set. */ + int srcOffset; /* Offset of first char of the command. */ + int codeOffset; /* Offset of first byte of command code. */ +{ + CmdLocation *cmdLocPtr; + + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + panic("EnterCmdStartData: bad command index %d\n", cmdIndex); + } + + if (cmdIndex >= envPtr->cmdMapEnd) { + /* + * Expand the command location array by allocating more storage from + * the heap. The currently allocated CmdLocation entries are stored + * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). + */ + + size_t currElems = envPtr->cmdMapEnd; + size_t newElems = 2*currElems; + size_t currBytes = currElems * sizeof(CmdLocation); + size_t newBytes = newElems * sizeof(CmdLocation); + CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); + + /* + * Copy from old command location array to new, free old command + * location array if needed, and mark new array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes); + if (envPtr->mallocedCmdMap) { + ckfree((char *) envPtr->cmdMapPtr); + } + envPtr->cmdMapPtr = (CmdLocation *) newPtr; + envPtr->cmdMapEnd = newElems; + envPtr->mallocedCmdMap = 1; + } + + if (cmdIndex > 0) { + if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { + panic("EnterCmdStartData: cmd map not sorted by code offset"); + } + } + + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr->codeOffset = codeOffset; + cmdLocPtr->srcOffset = srcOffset; + cmdLocPtr->numSrcBytes = -1; + cmdLocPtr->numCodeBytes = -1; +} + +/* + *---------------------------------------------------------------------- + * + * EnterCmdExtentData -- + * + * Registers the source and bytecode length for a command. This + * information is used at runtime to map between instruction pc and + * source locations. + * + * Results: + * None. + * + * Side effects: + * Inserts source and code length information into the compilation + * environment envPtr for the command at index cmdIndex. Starting + * source and bytecode information for the command must already + * have been registered. + * + *---------------------------------------------------------------------- + */ + +static void +EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes) + CompileEnv *envPtr; /* Points to the compilation environment + * structure in which to enter command + * location information. */ + int cmdIndex; /* Index of the command whose source and + * code length data is being set. */ + int numSrcBytes; /* Number of command source chars. */ + int numCodeBytes; /* Offset of last byte of command code. */ +{ + CmdLocation *cmdLocPtr; + + if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { + panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); + } + + if (cmdIndex > envPtr->cmdMapEnd) { + panic("EnterCmdExtentData: missing start data for command %d\n", + cmdIndex); + } + + cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr->numSrcBytes = numSrcBytes; + cmdLocPtr->numCodeBytes = numCodeBytes; +} + +#ifdef TCL_TIP280 +/* + *---------------------------------------------------------------------- + * TIP #280 + * + * EnterCmdWordData -- + * + * Registers the lines for the words of a command. This information + * is used at runtime by 'info frame'. + * + * Results: + * None. + * + * Side effects: + * Inserts word location information into the compilation + * environment envPtr for the command at index cmdIndex. The + * compilation environment's ExtCmdLoc.ECL array is grown if necessary. + * + *---------------------------------------------------------------------- + */ + +static void +EnterCmdWordData(eclPtr, srcOffset, tokenPtr, cmd, len, numWords, line, wlines) + ExtCmdLoc *eclPtr; /* Points to the map environment + * structure in which to enter command + * location information. */ + int srcOffset; /* Offset of first char of the command. */ + Tcl_Token* tokenPtr; + CONST char* cmd; + int len; + int numWords; + int line; + int** wlines; +{ + ECL* ePtr; + int wordIdx; + CONST char* last; + int wordLine; + int* wwlines; + + if (eclPtr->nuloc >= eclPtr->nloc) { + /* + * Expand the ECL array by allocating more storage from the + * heap. The currently allocated ECL entries are stored from + * eclPtr->loc[0] up to eclPtr->loc[eclPtr->nuloc-1] (inclusive). + */ + + size_t currElems = eclPtr->nloc; + size_t newElems = (currElems ? 2*currElems : 1); + size_t currBytes = currElems * sizeof(ECL); + size_t newBytes = newElems * sizeof(ECL); + ECL * newPtr = (ECL *) ckalloc((unsigned) newBytes); + + /* + * Copy from old ECL array to new, free old ECL array if + * needed. + */ + + if (currBytes) { + memcpy((VOID *) newPtr, (VOID *) eclPtr->loc, currBytes); + } + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); + } + eclPtr->loc = (ECL *) newPtr; + eclPtr->nloc = newElems; + } + + ePtr = &eclPtr->loc [eclPtr->nuloc]; + ePtr->srcOffset = srcOffset; + ePtr->line = (int*) ckalloc (numWords * sizeof (int)); + ePtr->nline = numWords; + wwlines = (int*) ckalloc (numWords * sizeof (int)); + + last = cmd; + wordLine = line; + for (wordIdx = 0; + wordIdx < numWords; + wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { + TclAdvanceLines (&wordLine, last, tokenPtr->start); + wwlines [wordIdx] = (TclWordKnownAtCompileTime (tokenPtr) + ? wordLine + : -1); + ePtr->line [wordIdx] = wordLine; + last = tokenPtr->start; + } + + *wlines = wwlines; + eclPtr->nuloc ++; +} +#endif + +/* + *---------------------------------------------------------------------- + * + * TclCreateExceptRange -- + * + * Procedure that allocates and initializes a new ExceptionRange + * structure of the specified kind in a CompileEnv. + * + * Results: + * Returns the index for the newly created ExceptionRange. + * + * Side effects: + * If there is not enough room in the CompileEnv's ExceptionRange + * array, the array in expanded: a new array of double the size is + * allocated, if envPtr->mallocedExceptArray is non-zero the old + * array is freed, and ExceptionRange entries are copied from the old + * array to the new one. + * + *---------------------------------------------------------------------- + */ + +int +TclCreateExceptRange(type, envPtr) + ExceptionRangeType type; /* The kind of ExceptionRange desired. */ + register CompileEnv *envPtr;/* Points to CompileEnv for which to + * create a new ExceptionRange structure. */ +{ + register ExceptionRange *rangePtr; + int index = envPtr->exceptArrayNext; + + if (index >= envPtr->exceptArrayEnd) { + /* + * Expand the ExceptionRange array. The currently allocated entries + * are stored between elements 0 and (envPtr->exceptArrayNext - 1) + * [inclusive]. + */ + + size_t currBytes = + envPtr->exceptArrayNext * sizeof(ExceptionRange); + int newElems = 2*envPtr->exceptArrayEnd; + size_t newBytes = newElems * sizeof(ExceptionRange); + ExceptionRange *newPtr = (ExceptionRange *) + ckalloc((unsigned) newBytes); + + /* + * Copy from old ExceptionRange array to new, free old + * ExceptionRange array if needed, and mark the new ExceptionRange + * array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr, + currBytes); + if (envPtr->mallocedExceptArray) { + ckfree((char *) envPtr->exceptArrayPtr); + } + envPtr->exceptArrayPtr = (ExceptionRange *) newPtr; + envPtr->exceptArrayEnd = newElems; + envPtr->mallocedExceptArray = 1; + } + envPtr->exceptArrayNext++; + + rangePtr = &(envPtr->exceptArrayPtr[index]); + rangePtr->type = type; + rangePtr->nestingLevel = envPtr->exceptDepth; + rangePtr->codeOffset = -1; + rangePtr->numCodeBytes = -1; + rangePtr->breakOffset = -1; + rangePtr->continueOffset = -1; + rangePtr->catchOffset = -1; + return index; +} + +/* + *---------------------------------------------------------------------- + * + * TclCreateAuxData -- + * + * Procedure that allocates and initializes a new AuxData structure in + * a CompileEnv's array of compilation auxiliary data records. These + * AuxData records hold information created during compilation by + * CompileProcs and used by instructions during execution. + * + * Results: + * Returns the index for the newly created AuxData structure. + * + * Side effects: + * If there is not enough room in the CompileEnv's AuxData array, + * the AuxData array in expanded: a new array of double the size + * is allocated, if envPtr->mallocedAuxDataArray is non-zero + * the old array is freed, and AuxData entries are copied from + * the old array to the new one. + * + *---------------------------------------------------------------------- + */ + +int +TclCreateAuxData(clientData, typePtr, envPtr) + ClientData clientData; /* The compilation auxiliary data to store + * in the new aux data record. */ + AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */ + register CompileEnv *envPtr;/* Points to the CompileEnv for which a new + * aux data structure is to be allocated. */ +{ + int index; /* Index for the new AuxData structure. */ + register AuxData *auxDataPtr; + /* Points to the new AuxData structure */ + + index = envPtr->auxDataArrayNext; + if (index >= envPtr->auxDataArrayEnd) { + /* + * Expand the AuxData array. The currently allocated entries are + * stored between elements 0 and (envPtr->auxDataArrayNext - 1) + * [inclusive]. + */ + + size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); + int newElems = 2*envPtr->auxDataArrayEnd; + size_t newBytes = newElems * sizeof(AuxData); + AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); + + /* + * Copy from old AuxData array to new, free old AuxData array if + * needed, and mark the new AuxData array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr, + currBytes); + if (envPtr->mallocedAuxDataArray) { + ckfree((char *) envPtr->auxDataArrayPtr); + } + envPtr->auxDataArrayPtr = newPtr; + envPtr->auxDataArrayEnd = newElems; + envPtr->mallocedAuxDataArray = 1; + } + envPtr->auxDataArrayNext++; + + auxDataPtr = &(envPtr->auxDataArrayPtr[index]); + auxDataPtr->clientData = clientData; + auxDataPtr->type = typePtr; + return index; +} + +/* + *---------------------------------------------------------------------- + * + * TclInitJumpFixupArray -- + * + * Initializes a JumpFixupArray structure to hold some number of + * jump fixup entries. + * + * Results: + * None. + * + * Side effects: + * The JumpFixupArray structure is initialized. + * + *---------------------------------------------------------------------- + */ + +void +TclInitJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to initialize. */ +{ + fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; + fixupArrayPtr->next = 0; + fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); + fixupArrayPtr->mallocedArray = 0; +} + +/* + *---------------------------------------------------------------------- + * + * TclExpandJumpFixupArray -- + * + * Procedure that uses malloc to allocate more storage for a + * jump fixup array. + * + * Results: + * None. + * + * Side effects: + * The jump fixup array in *fixupArrayPtr is reallocated to a new array + * of double the size, and if fixupArrayPtr->mallocedArray is non-zero + * the old array is freed. Jump fixup structures are copied from the + * old array to the new one. + * + *---------------------------------------------------------------------- + */ + +void +TclExpandJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to enlarge. */ +{ + /* + * The currently allocated jump fixup entries are stored from fixup[0] + * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume + * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. + */ + + size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); + int newElems = 2*(fixupArrayPtr->end + 1); + size_t newBytes = newElems * sizeof(JumpFixup); + JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); + + /* + * Copy from the old array to new, free the old array if needed, + * and mark the new array as malloced. + */ + + memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes); + if (fixupArrayPtr->mallocedArray) { + ckfree((char *) fixupArrayPtr->fixup); + } + fixupArrayPtr->fixup = (JumpFixup *) newPtr; + fixupArrayPtr->end = newElems; + fixupArrayPtr->mallocedArray = 1; +} + +/* + *---------------------------------------------------------------------- + * + * TclFreeJumpFixupArray -- + * + * Free any storage allocated in a jump fixup array structure. + * + * Results: + * None. + * + * Side effects: + * Allocated storage in the JumpFixupArray structure is freed. + * + *---------------------------------------------------------------------- + */ + +void +TclFreeJumpFixupArray(fixupArrayPtr) + register JumpFixupArray *fixupArrayPtr; + /* Points to the JumpFixupArray structure + * to free. */ +{ + if (fixupArrayPtr->mallocedArray) { + ckfree((char *) fixupArrayPtr->fixup); + } +} + +/* + *---------------------------------------------------------------------- + * + * TclEmitForwardJump -- + * + * Procedure to emit a two-byte forward jump of kind "jumpType". Since + * the jump may later have to be grown to five bytes if the jump target + * is more than, say, 127 bytes away, this procedure also initializes a + * JumpFixup record with information about the jump. + * + * Results: + * None. + * + * Side effects: + * The JumpFixup record pointed to by "jumpFixupPtr" is initialized + * with information needed later if the jump is to be grown. Also, + * a two byte jump of the designated type is emitted at the current + * point in the bytecode stream. + * + *---------------------------------------------------------------------- + */ + +void +TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr) + CompileEnv *envPtr; /* Points to the CompileEnv structure that + * holds the resulting instruction. */ + TclJumpType jumpType; /* Indicates the kind of jump: if true or + * false or unconditional. */ + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to + * initialize with information about this + * forward jump. */ +{ + /* + * Initialize the JumpFixup structure: + * - codeOffset is offset of first byte of jump below + * - cmdIndex is index of the command after the current one + * - exceptIndex is the index of the first ExceptionRange after + * the current one. + */ + + jumpFixupPtr->jumpType = jumpType; + jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); + jumpFixupPtr->cmdIndex = envPtr->numCommands; + jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; + + switch (jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclEmitInstInt1(INST_JUMP1, 0, envPtr); + break; + case TCL_TRUE_JUMP: + TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); + break; + default: + TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); + break; + } +} + +/* + *---------------------------------------------------------------------- + * + * TclFixupForwardJump -- + * + * Procedure that updates a previously-emitted forward jump to jump + * a specified number of bytes, "jumpDist". If necessary, the jump is + * grown from two to five bytes; this is done if the jump distance is + * greater than "distThreshold" (normally 127 bytes). The jump is + * described by a JumpFixup record previously initialized by + * TclEmitForwardJump. + * + * Results: + * 1 if the jump was grown and subsequent instructions had to be moved; + * otherwise 0. This result is returned to allow callers to update + * any additional code offsets they may hold. + * + * Side effects: + * The jump may be grown and subsequent instructions moved. If this + * happens, the code offsets for any commands and any ExceptionRange + * records between the jump and the current code address will be + * updated to reflect the moved code. Also, the bytecode instruction + * array in the CompileEnv structure may be grown and reallocated. + * + *---------------------------------------------------------------------- + */ + +int +TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold) + CompileEnv *envPtr; /* Points to the CompileEnv structure that + * holds the resulting instruction. */ + JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that + * describes the forward jump. */ + int jumpDist; /* Jump distance to set in jump + * instruction. */ + int distThreshold; /* Maximum distance before the two byte + * jump is grown to five bytes. */ +{ + unsigned char *jumpPc, *p; + int firstCmd, lastCmd, firstRange, lastRange, k; + unsigned int numBytes; + + if (jumpDist <= distThreshold) { + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); + switch (jumpFixupPtr->jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); + break; + case TCL_TRUE_JUMP: + TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); + break; + default: + TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); + break; + } + return 0; + } + + /* + * We must grow the jump then move subsequent instructions down. + * Note that if we expand the space for generated instructions, + * code addresses might change; be careful about updating any of + * these addresses held in variables. + */ + + if ((envPtr->codeNext + 3) > envPtr->codeEnd) { + TclExpandCodeArray(envPtr); + } + jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); + for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; + numBytes > 0; numBytes--, p--) { + p[3] = p[0]; + } + envPtr->codeNext += 3; + jumpDist += 3; + switch (jumpFixupPtr->jumpType) { + case TCL_UNCONDITIONAL_JUMP: + TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); + break; + case TCL_TRUE_JUMP: + TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); + break; + default: + TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); + break; + } + + /* + * Adjust the code offsets for any commands and any ExceptionRange + * records between the jump and the current code address. + */ + + firstCmd = jumpFixupPtr->cmdIndex; + lastCmd = (envPtr->numCommands - 1); + if (firstCmd < lastCmd) { + for (k = firstCmd; k <= lastCmd; k++) { + (envPtr->cmdMapPtr[k]).codeOffset += 3; + } + } + + firstRange = jumpFixupPtr->exceptIndex; + lastRange = (envPtr->exceptArrayNext - 1); + for (k = firstRange; k <= lastRange; k++) { + ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); + rangePtr->codeOffset += 3; + + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + rangePtr->breakOffset += 3; + if (rangePtr->continueOffset != -1) { + rangePtr->continueOffset += 3; + } + break; + case CATCH_EXCEPTION_RANGE: + rangePtr->catchOffset += 3; + break; + default: + panic("TclFixupForwardJump: bad ExceptionRange type %d\n", + rangePtr->type); + } + } + return 1; /* the jump was grown */ +} + +/* + *---------------------------------------------------------------------- + * + * TclGetInstructionTable -- + * + * Returns a pointer to the table describing Tcl bytecode instructions. + * This procedure is defined so that clients can access the pointer from + * outside the TCL DLLs. + * + * Results: + * Returns a pointer to the global instruction table, same as the + * expression (&tclInstructionTable[0]). + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void * /* == InstructionDesc* == */ +TclGetInstructionTable() +{ + return &tclInstructionTable[0]; +} + +/* + *-------------------------------------------------------------- + * + * TclRegisterAuxDataType -- + * + * This procedure is called to register a new AuxData type + * in the table of all AuxData types supported by Tcl. + * + * Results: + * None. + * + * Side effects: + * The type is registered in the AuxData type table. If there was already + * a type with the same name as in typePtr, it is replaced with the + * new type. + * + *-------------------------------------------------------------- + */ + +void +TclRegisterAuxDataType(typePtr) + AuxDataType *typePtr; /* Information about object type; + * storage must be statically + * allocated (must live forever). */ +{ + register Tcl_HashEntry *hPtr; + int new; + + Tcl_MutexLock(&tableMutex); + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + /* + * If there's already a type with the given name, remove it. + */ + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); + if (hPtr != (Tcl_HashEntry *) NULL) { + Tcl_DeleteHashEntry(hPtr); + } + + /* + * Now insert the new object type. + */ + + hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); + if (new) { + Tcl_SetHashValue(hPtr, typePtr); + } + Tcl_MutexUnlock(&tableMutex); +} + +/* + *---------------------------------------------------------------------- + * + * TclGetAuxDataType -- + * + * This procedure looks up an Auxdata type by name. + * + * Results: + * If an AuxData type with name matching "typeName" is found, a pointer + * to its AuxDataType structure is returned; otherwise, NULL is returned. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +AuxDataType * +TclGetAuxDataType(typeName) + char *typeName; /* Name of AuxData type to look up. */ +{ + register Tcl_HashEntry *hPtr; + AuxDataType *typePtr = NULL; + + Tcl_MutexLock(&tableMutex); + if (!auxDataTypeTableInitialized) { + TclInitAuxDataTypeTable(); + } + + hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); + if (hPtr != (Tcl_HashEntry *) NULL) { + typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + } + Tcl_MutexUnlock(&tableMutex); + + return typePtr; +} + +/* + *-------------------------------------------------------------- + * + * TclInitAuxDataTypeTable -- + * + * This procedure is invoked to perform once-only initialization of + * the AuxData type table. It also registers the AuxData types defined in + * this file. + * + * Results: + * None. + * + * Side effects: + * Initializes the table of defined AuxData types "auxDataTypeTable" with + * builtin AuxData types defined in this file. + * + *-------------------------------------------------------------- + */ + +void +TclInitAuxDataTypeTable() +{ + /* + * The table mutex must already be held before this routine is invoked. + */ + + auxDataTypeTableInitialized = 1; + Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); + + /* + * There is only one AuxData type at this time, so register it here. + */ + + TclRegisterAuxDataType(&tclForeachInfoType); +} + +/* + *---------------------------------------------------------------------- + * + * TclFinalizeAuxDataTypeTable -- + * + * This procedure is called by Tcl_Finalize after all exit handlers + * have been run to free up storage associated with the table of AuxData + * types. This procedure is called by TclFinalizeExecution() which + * is called by Tcl_Finalize(). + * + * Results: + * None. + * + * Side effects: + * Deletes all entries in the hash table of AuxData types. + * + *---------------------------------------------------------------------- + */ + +void +TclFinalizeAuxDataTypeTable() +{ + Tcl_MutexLock(&tableMutex); + if (auxDataTypeTableInitialized) { + Tcl_DeleteHashTable(&auxDataTypeTable); + auxDataTypeTableInitialized = 0; + } + Tcl_MutexUnlock(&tableMutex); +} + +/* + *---------------------------------------------------------------------- + * + * GetCmdLocEncodingSize -- + * + * Computes the total number of bytes needed to encode the command + * location information for some compiled code. + * + * Results: + * The byte count needed to encode the compiled location information. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +static int +GetCmdLocEncodingSize(envPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ +{ + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + int codeDelta, codeLen, srcDelta, srcLen; + int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; + /* The offsets in their respective byte + * sequences where the next encoded offset + * or length should go. */ + int prevCodeOffset, prevSrcOffset, i; + + codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; + prevCodeOffset = prevSrcOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); + if (codeDelta < 0) { + panic("GetCmdLocEncodingSize: bad code offset"); + } else if (codeDelta <= 127) { + codeDeltaNext++; + } else { + codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ + } + prevCodeOffset = mapPtr[i].codeOffset; + + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("GetCmdLocEncodingSize: bad code length"); + } else if (codeLen <= 127) { + codeLengthNext++; + } else { + codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + } + + srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + srcDeltaNext++; + } else { + srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ + } + prevSrcOffset = mapPtr[i].srcOffset; + + srcLen = mapPtr[i].numSrcBytes; + if (srcLen < 0) { + panic("GetCmdLocEncodingSize: bad source length"); + } else if (srcLen <= 127) { + srcLengthNext++; + } else { + srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + } + } + + return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); +} + +/* + *---------------------------------------------------------------------- + * + * EncodeCmdLocMap -- + * + * Encode the command location information for some compiled code into + * a ByteCode structure. The encoded command location map is stored as + * three adjacent byte sequences. + * + * Results: + * Pointer to the first byte after the encoded command location + * information. + * + * Side effects: + * The encoded information is stored into the block of memory headed + * by codePtr. Also records pointers to the start of the four byte + * sequences in fields in codePtr's ByteCode header structure. + * + *---------------------------------------------------------------------- + */ + +static unsigned char * +EncodeCmdLocMap(envPtr, codePtr, startPtr) + CompileEnv *envPtr; /* Points to compilation environment + * structure containing the CmdLocation + * structure to encode. */ + ByteCode *codePtr; /* ByteCode in which to encode envPtr's + * command location information. */ + unsigned char *startPtr; /* Points to the first byte in codePtr's + * memory block where the location + * information is to be stored. */ +{ + register CmdLocation *mapPtr = envPtr->cmdMapPtr; + int numCmds = envPtr->numCommands; + register unsigned char *p = startPtr; + int codeDelta, codeLen, srcDelta, srcLen, prevOffset; + register int i; + + /* + * Encode the code offset for each command as a sequence of deltas. + */ + + codePtr->codeDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + codeDelta = (mapPtr[i].codeOffset - prevOffset); + if (codeDelta < 0) { + panic("EncodeCmdLocMap: bad code offset"); + } else if (codeDelta <= 127) { + TclStoreInt1AtPtr(codeDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeDelta, p); + p += 4; + } + prevOffset = mapPtr[i].codeOffset; + } + + /* + * Encode the code length for each command. + */ + + codePtr->codeLengthStart = p; + for (i = 0; i < numCmds; i++) { + codeLen = mapPtr[i].numCodeBytes; + if (codeLen < 0) { + panic("EncodeCmdLocMap: bad code length"); + } else if (codeLen <= 127) { + TclStoreInt1AtPtr(codeLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(codeLen, p); + p += 4; + } + } + + /* + * Encode the source offset for each command as a sequence of deltas. + */ + + codePtr->srcDeltaStart = p; + prevOffset = 0; + for (i = 0; i < numCmds; i++) { + srcDelta = (mapPtr[i].srcOffset - prevOffset); + if ((-127 <= srcDelta) && (srcDelta <= 127)) { + TclStoreInt1AtPtr(srcDelta, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcDelta, p); + p += 4; + } + prevOffset = mapPtr[i].srcOffset; + } + + /* + * Encode the source length for each command. + */ + + codePtr->srcLengthStart = p; + for (i = 0; i < numCmds; i++) { + srcLen = mapPtr[i].numSrcBytes; + if (srcLen < 0) { + panic("EncodeCmdLocMap: bad source length"); + } else if (srcLen <= 127) { + TclStoreInt1AtPtr(srcLen, p); + p++; + } else { + TclStoreInt1AtPtr(0xFF, p); + p++; + TclStoreInt4AtPtr(srcLen, p); + p += 4; + } + } + + return p; +} + +#ifdef TCL_COMPILE_DEBUG +/* + *---------------------------------------------------------------------- + * + * TclPrintByteCodeObj -- + * + * This procedure prints ("disassembles") the instructions of a + * bytecode object to stdout. + * + * Results: + * None. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintByteCodeObj(interp, objPtr) + Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */ + Tcl_Obj *objPtr; /* The bytecode object to disassemble. */ +{ + ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + unsigned char *codeStart, *codeLimit, *pc; + unsigned char *codeDeltaNext, *codeLengthNext; + unsigned char *srcDeltaNext, *srcLengthNext; + int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; + Interp *iPtr = (Interp *) *codePtr->interpHandle; + + if (codePtr->refCount <= 0) { + return; /* already freed */ + } + + codeStart = codePtr->codeStart; + codeLimit = (codeStart + codePtr->numCodeBytes); + numCmds = codePtr->numCommands; + + /* + * Print header lines describing the ByteCode. + */ + + fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", + (unsigned int) codePtr, codePtr->refCount, + codePtr->compileEpoch, (unsigned int) iPtr, + iPtr->compileEpoch); + fprintf(stdout, " Source "); + TclPrintSource(stdout, codePtr->source, + TclMin(codePtr->numSrcBytes, 55)); + fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, + codePtr->numLitObjects, codePtr->numAuxDataItems, + codePtr->maxStackDepth, +#ifdef TCL_COMPILE_STATS + (codePtr->numSrcBytes? + ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0)); +#else + 0.0); +#endif +#ifdef TCL_COMPILE_STATS + fprintf(stdout, + " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", + codePtr->structureSize, + (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), + codePtr->numCodeBytes, + (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (codePtr->numExceptRanges * sizeof(ExceptionRange)), + (codePtr->numAuxDataItems * sizeof(AuxData)), + codePtr->numCmdLocBytes); +#endif /* TCL_COMPILE_STATS */ + + /* + * If the ByteCode is the compiled body of a Tcl procedure, print + * information about that procedure. Note that we don't know the + * procedure's name since ByteCode's can be shared among procedures. + */ + + if (codePtr->procPtr != NULL) { + Proc *procPtr = codePtr->procPtr; + int numCompiledLocals = procPtr->numCompiledLocals; + fprintf(stdout, + " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", + (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, + numCompiledLocals); + if (numCompiledLocals > 0) { + CompiledLocal *localPtr = procPtr->firstLocalPtr; + for (i = 0; i < numCompiledLocals; i++) { + fprintf(stdout, " slot %d%s%s%s%s%s%s", i, + ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""), + ((localPtr->flags & VAR_ARRAY)? ", array" : ""), + ((localPtr->flags & VAR_LINK)? ", link" : ""), + ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""), + ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""), + ((localPtr->flags & VAR_RESOLVED)? ", resolved" : "")); + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "\n"); + } else { + fprintf(stdout, ", \"%s\"\n", localPtr->name); + } + localPtr = localPtr->nextPtr; + } + } + } + + /* + * Print the ExceptionRange array. + */ + + if (codePtr->numExceptRanges > 0) { + fprintf(stdout, " Exception ranges %d, depth %d:\n", + codePtr->numExceptRanges, codePtr->maxExceptDepth); + for (i = 0; i < codePtr->numExceptRanges; i++) { + ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); + fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", + i, rangePtr->nestingLevel, + ((rangePtr->type == LOOP_EXCEPTION_RANGE) + ? "loop" : "catch"), + rangePtr->codeOffset, + (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); + switch (rangePtr->type) { + case LOOP_EXCEPTION_RANGE: + fprintf(stdout, "continue %d, break %d\n", + rangePtr->continueOffset, rangePtr->breakOffset); + break; + case CATCH_EXCEPTION_RANGE: + fprintf(stdout, "catch %d\n", rangePtr->catchOffset); + break; + default: + panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", + rangePtr->type); + } + } + } + + /* + * If there were no commands (e.g., an expression or an empty string + * was compiled), just print all instructions and return. + */ + + if (numCmds == 0) { + pc = codeStart; + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + return; + } + + /* + * Print table showing the code offset, source offset, and source + * length for each command. These are encoded as a sequence of bytes. + */ + + fprintf(stdout, " Commands %d:", numCmds); + codeDeltaNext = codePtr->codeDeltaStart; + codeLengthNext = codePtr->codeLengthStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + codeLengthNext++; + codeLen = TclGetInt4AtPtr(codeLengthNext); + codeLengthNext += 4; + } else { + codeLen = TclGetInt1AtPtr(codeLengthNext); + codeLengthNext++; + } + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), + (i+1), codeOffset, (codeOffset + codeLen - 1), + srcOffset, (srcOffset + srcLen - 1)); + } + if (numCmds > 0) { + fprintf(stdout, "\n"); + } + + /* + * Print each instruction. If the instruction corresponds to the start + * of a command, print the command's source. Note that we don't need + * the code length here. + */ + + codeDeltaNext = codePtr->codeDeltaStart; + srcDeltaNext = codePtr->srcDeltaStart; + srcLengthNext = codePtr->srcLengthStart; + codeOffset = srcOffset = 0; + pc = codeStart; + for (i = 0; i < numCmds; i++) { + if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + codeDeltaNext++; + delta = TclGetInt4AtPtr(codeDeltaNext); + codeDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(codeDeltaNext); + codeDeltaNext++; + } + codeOffset += delta; + + if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + srcDeltaNext++; + delta = TclGetInt4AtPtr(srcDeltaNext); + srcDeltaNext += 4; + } else { + delta = TclGetInt1AtPtr(srcDeltaNext); + srcDeltaNext++; + } + srcOffset += delta; + + if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + srcLengthNext++; + srcLen = TclGetInt4AtPtr(srcLengthNext); + srcLengthNext += 4; + } else { + srcLen = TclGetInt1AtPtr(srcLengthNext); + srcLengthNext++; + } + + /* + * Print instructions before command i. + */ + + while ((pc-codeStart) < codeOffset) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + + fprintf(stdout, " Command %d: ", (i+1)); + TclPrintSource(stdout, (codePtr->source + srcOffset), + TclMin(srcLen, 55)); + fprintf(stdout, "\n"); + } + if (pc < codeLimit) { + /* + * Print instructions after the last command. + */ + + while (pc < codeLimit) { + fprintf(stdout, " "); + pc += TclPrintInstruction(codePtr, pc); + } + } +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a + * bytecode object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction(codePtr, pc) + ByteCode* codePtr; /* Bytecode containing the instruction. */ + unsigned char *pc; /* Points to first byte of instruction. */ +{ + Proc *procPtr = codePtr->procPtr; + unsigned char opCode = *pc; + register InstructionDesc *instDesc = &tclInstructionTable[opCode]; + unsigned char *codeStart = codePtr->codeStart; + unsigned int pcOffset = (pc - codeStart); + int opnd, i, j; + + fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); + for (i = 0; i < instDesc->numOperands; i++) { + switch (instDesc->opTypes[i]) { + case OPERAND_INT1: + opnd = TclGetInt1AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP1) + || (opCode == INST_JUMP_TRUE1) + || (opCode == INST_JUMP_FALSE1))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); + } + break; + case OPERAND_INT4: + opnd = TclGetInt4AtPtr(pc+1+i); + if ((i == 0) && ((opCode == INST_JUMP4) + || (opCode == INST_JUMP_TRUE4) + || (opCode == INST_JUMP_FALSE4))) { + fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd)); + } else { + fprintf(stdout, "%d", opnd); + } + break; + case OPERAND_UINT1: + opnd = TclGetUInt1AtPtr(pc+1+i); + if ((i == 0) && (opCode == INST_PUSH1)) { + fprintf(stdout, "%u # ", (unsigned int) opnd); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1) + || (opCode == INST_LOAD_ARRAY1) + || (opCode == INST_STORE_SCALAR1) + || (opCode == INST_STORE_ARRAY1))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); + } + break; + case OPERAND_UINT4: + opnd = TclGetUInt4AtPtr(pc+1+i); + if (opCode == INST_PUSH4) { + fprintf(stdout, "%u # ", opnd); + TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4) + || (opCode == INST_LOAD_ARRAY4) + || (opCode == INST_STORE_SCALAR4) + || (opCode == INST_STORE_ARRAY4))) { + int localCt = procPtr->numCompiledLocals; + CompiledLocal *localPtr = procPtr->firstLocalPtr; + if (opnd >= localCt) { + panic("TclPrintInstruction: bad local var index %u (%u locals)\n", + (unsigned int) opnd, localCt); + return instDesc->numBytes; + } + for (j = 0; j < opnd; j++) { + localPtr = localPtr->nextPtr; + } + if (TclIsVarTemporary(localPtr)) { + fprintf(stdout, "%u # temp var %u", + (unsigned int) opnd, (unsigned int) opnd); + } else { + fprintf(stdout, "%u # var ", (unsigned int) opnd); + TclPrintSource(stdout, localPtr->name, 40); + } + } else { + fprintf(stdout, "%u ", (unsigned int) opnd); + } + break; + case OPERAND_NONE: + default: + break; + } + } + fprintf(stdout, "\n"); + return instDesc->numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from + * the argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintObject(outFile, objPtr, maxChars) + FILE *outFile; /* The file to print the source to. */ + Tcl_Obj *objPtr; /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars; /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from + * the argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource(outFile, string, maxChars) + FILE *outFile; /* The file to print the source to. */ + CONST char *string; /* The string to print. */ + int maxChars; /* Maximum number of chars to print. */ +{ + register CONST char *p; + register int i = 0; + + if (string == NULL) { + fprintf(outFile, "\"\""); + return; + } + + fprintf(outFile, "\""); + p = string; + for (; (*p != '\0') && (i < maxChars); p++, i++) { + switch (*p) { + case '"': + fprintf(outFile, "\\\""); + continue; + case '\f': + fprintf(outFile, "\\f"); + continue; + case '\n': + fprintf(outFile, "\\n"); + continue; + case '\r': + fprintf(outFile, "\\r"); + continue; + case '\t': + fprintf(outFile, "\\t"); + continue; + case '\v': + fprintf(outFile, "\\v"); + continue; + default: + fprintf(outFile, "%c", *p); + continue; + } + } + fprintf(outFile, "\""); +} + +#ifdef TCL_COMPILE_STATS +/* + *---------------------------------------------------------------------- + * + * RecordByteCodeStats -- + * + * Accumulates various compilation-related statistics for each newly + * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is + * compiled with the -DTCL_COMPILE_STATS flag + * + * Results: + * None. + * + * Side effects: + * Accumulates aggregate code-related statistics in the interpreter's + * ByteCodeStats structure. Records statistics specific to a ByteCode + * in its ByteCode structure. + * + *---------------------------------------------------------------------- + */ + +void +RecordByteCodeStats(codePtr) + ByteCode *codePtr; /* Points to ByteCode structure with info + * to add to accumulated statistics. */ +{ + Interp *iPtr = (Interp *) *codePtr->interpHandle; + register ByteCodeStats *statsPtr = &(iPtr->stats); + + statsPtr->numCompilations++; + statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; + statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; + statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; + + statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; + statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; + + statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; + statsPtr->currentLitBytes += + (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *)); + statsPtr->currentExceptBytes += + (double) (codePtr->numExceptRanges * sizeof(ExceptionRange)); + statsPtr->currentAuxBytes += + (double) (codePtr->numAuxDataItems * sizeof(AuxData)); + statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; +} +#endif /* TCL_COMPILE_STATS */ + +/* + * Local Variables: + * mode: c + * c-basic-offset: 4 + * fill-column: 78 + * End: + */ +