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