diff options
Diffstat (limited to 'generic/tclCompile.c')
| -rw-r--r-- | generic/tclCompile.c | 3596 |
1 files changed, 2808 insertions, 788 deletions
diff --git a/generic/tclCompile.c b/generic/tclCompile.c index 659a611..347e3f0 100644 --- a/generic/tclCompile.c +++ b/generic/tclCompile.c @@ -6,16 +6,15 @@ * of instructions ("bytecodes"). * * Copyright (c) 1996-1998 Sun Microsystems, Inc. - * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. + * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. * * See the file "license.terms" for information on usage and redistribution of * this file, and for a DISCLAIMER OF ALL WARRANTIES. - * - * RCS: @(#) $Id: tclCompile.c,v 1.93 2005/11/30 14:59:40 dkf Exp $ */ #include "tclInt.h" #include "tclCompile.h" +#include <assert.h> /* * Table of all AuxData types. @@ -39,7 +38,7 @@ TCL_DECLARE_MUTEX(tableMutex) int tclTraceCompile = 0; static int traceInitialized = 0; #endif - + /* * A table describing the Tcl bytecode instructions. Entries in this table * must correspond to the instruction opcode definitions in tclCompile.h. The @@ -52,7 +51,7 @@ static int traceInitialized = 0; * existence of a procedure call frame to distinguish these. */ -InstructionDesc tclInstructionTable[] = { +InstructionDesc const tclInstructionTable[] = { /* Name Bytes stackEffect #Opnds Operand types */ {"done", 1, -1, 0, {OPERAND_NONE}}, /* Finish ByteCode execution and return stktop (top stack item) */ @@ -64,7 +63,7 @@ InstructionDesc tclInstructionTable[] = { /* Pop the topmost stack object */ {"dup", 1, +1, 0, {OPERAND_NONE}}, /* Duplicate the topmost stack object and push the result */ - {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, + {"strcat", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Concatenate the top op1 items and push result */ {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ @@ -156,11 +155,11 @@ InstructionDesc tclInstructionTable[] = { {"lt", 1, -1, 0, {OPERAND_NONE}}, /* Less: push (stknext < stktop) */ {"gt", 1, -1, 0, {OPERAND_NONE}}, - /* Greater: push (stknext || stktop) */ + /* Greater: push (stknext > stktop) */ {"le", 1, -1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ + /* Less or equal: push (stknext <= stktop) */ {"ge", 1, -1, 0, {OPERAND_NONE}}, - /* Logical or: push (stknext || stktop) */ + /* Greater or equal: push (stknext >= stktop) */ {"lshift", 1, -1, 0, {OPERAND_NONE}}, /* Left shift: push (stknext << stktop) */ {"rshift", 1, -1, 0, {OPERAND_NONE}}, @@ -196,10 +195,10 @@ InstructionDesc tclInstructionTable[] = { /* Skip to next iteration of closest enclosing loop; if none, return * TCL_CONTINUE code. */ - {"foreach_start4", 5, 0, 1, {OPERAND_UINT4}}, + {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}}, /* Initialize execution of a foreach loop. Operand is aux data index * of the ForeachInfo structure for the foreach command. */ - {"foreach_step4", 5, +1, 1, {OPERAND_UINT4}}, + {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}}, /* "Step" or begin next iteration of foreach loop. Push 0 if to * terminate loop, else push 1. */ @@ -289,8 +288,8 @@ InstructionDesc tclInstructionTable[] = { * is emitted. */ {"expandStart", 1, 0, 0, {OPERAND_NONE}}, - /* Start of command with {expand}ed arguments */ - {"expandStkTop", 5, 0, 1, {OPERAND_INT4}}, + /* Start of command with {*} (expanded) arguments */ + {"expandStkTop", 5, 0, 1, {OPERAND_UINT4}}, /* Expand the list at stacktop: push its elements on the stack */ {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, /* Invoke the command marked by the last 'expandStart' */ @@ -299,8 +298,9 @@ InstructionDesc tclInstructionTable[] = { /* List Index: push (lindex stktop op4) */ {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, /* List Range: push (lrange stktop op4 op4) */ - {"startCommand", 5, 0, 1, {OPERAND_UINT4}}, - /* Start of bytecoded command: op is the length of the cmd's code */ + {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, + /* Start of bytecoded command: op is the length of the cmd's code, op2 + * is number of commands here */ {"listIn", 1, -1, 0, {OPERAND_NONE}}, /* List containment: push [lsearch stktop stknext]>=0) */ @@ -310,7 +310,7 @@ InstructionDesc tclInstructionTable[] = { {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, /* Push the interpreter's return option dictionary as an object on the * stack. */ - {"returnStk", 1, -2, 0, {OPERAND_NONE}}, + {"returnStk", 1, -1, 0, {OPERAND_NONE}}, /* Compiled [return]; options and result are on the stack, code and * level are in the options. */ @@ -319,15 +319,15 @@ InstructionDesc tclInstructionTable[] = { * below the keys on the stack, and all those values are replaced by * the value read out of that key-path (like [dict get]). * Stack: ... dict key1 ... keyN => ... value */ - {"dictSet", 5, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, + {"dictSet", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, /* Update a dictionary value such that the keys are a path pointing to * the value. op4#1 = numKeys, op4#2 = LVTindex * Stack: ... key1 ... keyN value => ... newDict */ - {"dictUnset", 5, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, + {"dictUnset", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, /* Update a dictionary value such that the keys are not a path pointing * to any value. op4#1 = numKeys, op4#2 = LVTindex * Stack: ... key1 ... keyN => ... newDict */ - {"dictIncrImm", 5, 0, 2, {OPERAND_INT4, OPERAND_LVT4}}, + {"dictIncrImm", 9, 0, 2, {OPERAND_INT4, OPERAND_LVT4}}, /* Update a dictionary value such that the value pointed to by key is * incremented by some value (or set to it if the key isn't in the * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex @@ -342,40 +342,323 @@ InstructionDesc tclInstructionTable[] = { * Stack: ... key valueToAppend => ... newDict */ {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, /* Begin iterating over the dictionary, using the local scalar - * indicated by op4 to hold the iterator state. If doneBool is true, - * dictDone *must* be called later on. + * indicated by op4 to hold the iterator state. The local scalar + * should not refer to a named variable as the value is not wholly + * managed correctly. * Stack: ... dict => ... value key doneBool */ {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, /* Get the next iteration from the iterator in op4's local scalar. * Stack: ... => ... value key doneBool */ {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, - /* Terminate the iterator in op4's local scalar. */ - {"dictUpdateStart", 5, -2, 1, {OPERAND_LVT4}}, - /* Create the variables to mirror the state of the dictionary in the - * variable referred to by the immediate argument. - * Stack: ... keyList LVTindexList => ... - * Note that the list of LVT indices is assumed to be the same length - * as the keyList, and the indices should be only ever generated by the - * compiler. */ - {"dictUpdateEnd", 5, -2, 1, {OPERAND_LVT4}}, - /* Reflect the state of local variables back to the state of the - * dictionary in the variable referred to by the immediate argument. - * Stack: ... keyList LVTindexList => ... - * Same notes as in "dictUpdateStart" apply here. */ - {"jumpTable", 5, -1, 1, {OPERAND_UINT4}}, + /* Terminate the iterator in op4's local scalar. Use unsetScalar + * instead (with 0 for flags). */ + {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, + /* Create the variables (described in the aux data referred to by the + * second immediate argument) to mirror the state of the dictionary in + * the variable referred to by the first immediate argument. The list + * of keys (top of the stack, not poppsed) must be the same length as + * the list of variables. + * Stack: ... keyList => ... keyList */ + {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, + /* Reflect the state of local variables (described in the aux data + * referred to by the second immediate argument) back to the state of + * the dictionary in the variable referred to by the first immediate + * argument. The list of keys (popped from the stack) must be the same + * length as the list of variables. + * Stack: ... keyList => ... */ + {"jumpTable", 5, -1, 1, {OPERAND_AUX4}}, /* Jump according to the jump-table (in AuxData as indicated by the * operand) and the argument popped from the list. Always executes the * next instruction if no match against the table's entries was found. * Stack: ... value => ... * Note that the jump table contains offsets relative to the PC when * it points to this instruction; the code is relocatable. */ - {0} -}; + {"upvar", 5, -1, 1, {OPERAND_LVT4}}, + /* finds level and otherName in stack, links to local variable at + * index op1. Leaves the level on stack. */ + {"nsupvar", 5, -1, 1, {OPERAND_LVT4}}, + /* finds namespace and otherName in stack, links to local variable at + * index op1. Leaves the namespace on stack. */ + {"variable", 5, -1, 1, {OPERAND_LVT4}}, + /* finds namespace and otherName in stack, links to local variable at + * index op1. Leaves the namespace on stack. */ + {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, + /* Compiled bytecodes to signal syntax error. Equivalent to returnImm + * except for the ERR_ALREADY_LOGGED flag in the interpreter. */ + {"reverse", 5, 0, 1, {OPERAND_UINT4}}, + /* Reverse the order of the arg elements at the top of stack */ + + {"regexp", 2, -1, 1, {OPERAND_INT1}}, + /* Regexp: push (regexp stknext stktop) opnd == nocase */ + + {"existScalar", 5, 1, 1, {OPERAND_LVT4}}, + /* Test if scalar variable at index op1 in call frame exists */ + {"existArray", 5, 0, 1, {OPERAND_LVT4}}, + /* Test if array element exists; array at slot op1, element is + * stktop */ + {"existArrayStk", 1, -1, 0, {OPERAND_NONE}}, + /* Test if array element exists; element is stktop, array name is + * stknext */ + {"existStk", 1, 0, 0, {OPERAND_NONE}}, + /* Test if general variable exists; unparsed variable name is stktop*/ + + {"nop", 1, 0, 0, {OPERAND_NONE}}, + /* Do nothing */ + {"returnCodeBranch", 1, -1, 0, {OPERAND_NONE}}, + /* Jump to next instruction based on the return code on top of stack + * ERROR: +1; RETURN: +3; BREAK: +5; CONTINUE: +7; + * Other non-OK: +9 + */ + {"unsetScalar", 6, 0, 2, {OPERAND_UINT1, OPERAND_LVT4}}, + /* Make scalar variable at index op2 in call frame cease to exist; + * op1 is 1 for errors on problems, 0 otherwise */ + {"unsetArray", 6, -1, 2, {OPERAND_UINT1, OPERAND_LVT4}}, + /* Make array element cease to exist; array at slot op2, element is + * stktop; op1 is 1 for errors on problems, 0 otherwise */ + {"unsetArrayStk", 2, -2, 1, {OPERAND_UINT1}}, + /* Make array element cease to exist; element is stktop, array name is + * stknext; op1 is 1 for errors on problems, 0 otherwise */ + {"unsetStk", 2, -1, 1, {OPERAND_UINT1}}, + /* Make general variable cease to exist; unparsed variable name is + * stktop; op1 is 1 for errors on problems, 0 otherwise */ + + {"dictExpand", 1, -1, 0, {OPERAND_NONE}}, + /* Probe into a dict and extract it (or a subdict of it) into + * variables with matched names. Produces list of keys bound as + * result. Part of [dict with]. + * Stack: ... dict path => ... keyList */ + {"dictRecombineStk", 1, -3, 0, {OPERAND_NONE}}, + /* Map variable contents back into a dictionary in a variable. Part of + * [dict with]. + * Stack: ... dictVarName path keyList => ... */ + {"dictRecombineImm", 5, -2, 1, {OPERAND_LVT4}}, + /* Map variable contents back into a dictionary in the local variable + * indicated by the LVT index. Part of [dict with]. + * Stack: ... path keyList => ... */ + {"dictExists", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* The top op4 words (min 1) are a key path into the dictionary just + * below the keys on the stack, and all those values are replaced by a + * boolean indicating whether it is possible to read out a value from + * that key-path (like [dict exists]). + * Stack: ... dict key1 ... keyN => ... boolean */ + {"verifyDict", 1, -1, 0, {OPERAND_NONE}}, + /* Verifies that the word on the top of the stack is a dictionary, + * popping it if it is and throwing an error if it is not. + * Stack: ... value => ... */ + + {"strmap", 1, -2, 0, {OPERAND_NONE}}, + /* Simplified version of [string map] that only applies one change + * string, and only case-sensitively. + * Stack: ... from to string => ... changedString */ + {"strfind", 1, -1, 0, {OPERAND_NONE}}, + /* Find the first index of a needle string in a haystack string, + * producing the index (integer) or -1 if nothing found. + * Stack: ... needle haystack => ... index */ + {"strrfind", 1, -1, 0, {OPERAND_NONE}}, + /* Find the last index of a needle string in a haystack string, + * producing the index (integer) or -1 if nothing found. + * Stack: ... needle haystack => ... index */ + {"strrangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, + /* String Range: push (string range stktop op4 op4) */ + {"strrange", 1, -2, 0, {OPERAND_NONE}}, + /* String Range with non-constant arguments. + * Stack: ... string idxA idxB => ... substring */ + + {"yield", 1, 0, 0, {OPERAND_NONE}}, + /* Makes the current coroutine yield the value at the top of the + * stack, and places the response back on top of the stack when it + * resumes. + * Stack: ... valueToYield => ... resumeValue */ + {"coroName", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current coroutine as an object + * on the stack. */ + {"tailcall", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Do a tailcall with the opnd items on the stack as the thing to + * tailcall to; opnd must be greater than 0 for the semantics to work + * right. */ + + {"currentNamespace", 1, +1, 0, {OPERAND_NONE}}, + /* Push the name of the interpreter's current namespace as an object + * on the stack. */ + {"infoLevelNumber", 1, +1, 0, {OPERAND_NONE}}, + /* Push the stack depth (i.e., [info level]) of the interpreter as an + * object on the stack. */ + {"infoLevelArgs", 1, 0, 0, {OPERAND_NONE}}, + /* Push the argument words to a stack depth (i.e., [info level <n>]) + * of the interpreter as an object on the stack. + * Stack: ... depth => ... argList */ + {"resolveCmd", 1, 0, 0, {OPERAND_NONE}}, + /* Resolves the command named on the top of the stack to its fully + * qualified version, or produces the empty string if no such command + * exists. Never generates errors. + * Stack: ... cmdName => ... fullCmdName */ + + {"tclooSelf", 1, +1, 0, {OPERAND_NONE}}, + /* Push the identity of the current TclOO object (i.e., the name of + * its current public access command) on the stack. */ + {"tclooClass", 1, 0, 0, {OPERAND_NONE}}, + /* Push the class of the TclOO object named at the top of the stack + * onto the stack. + * Stack: ... object => ... class */ + {"tclooNamespace", 1, 0, 0, {OPERAND_NONE}}, + /* Push the namespace of the TclOO object named at the top of the + * stack onto the stack. + * Stack: ... object => ... namespace */ + {"tclooIsObject", 1, 0, 0, {OPERAND_NONE}}, + /* Push whether the value named at the top of the stack is a TclOO + * object (i.e., a boolean). Can corrupt the interpreter result + * despite not throwing, so not safe for use in a post-exception + * context. + * Stack: ... value => ... boolean */ + + {"arrayExistsStk", 1, 0, 0, {OPERAND_NONE}}, + /* Looks up the element on the top of the stack and tests whether it + * is an array. Pushes a boolean describing whether this is the + * case. Also runs the whole-array trace on the named variable, so can + * throw anything. + * Stack: ... varName => ... boolean */ + {"arrayExistsImm", 5, +1, 1, {OPERAND_UINT4}}, + /* Looks up the variable indexed by opnd and tests whether it is an + * array. Pushes a boolean describing whether this is the case. Also + * runs the whole-array trace on the named variable, so can throw + * anything. + * Stack: ... => ... boolean */ + {"arrayMakeStk", 1, -1, 0, {OPERAND_NONE}}, + /* Forces the element on the top of the stack to be the name of an + * array. + * Stack: ... varName => ... */ + {"arrayMakeImm", 5, 0, 1, {OPERAND_UINT4}}, + /* Forces the variable indexed by opnd to be an array. Does not touch + * the stack. */ + + {"invokeReplace", 6, INT_MIN, 2, {OPERAND_UINT4,OPERAND_UINT1}}, + /* Invoke command named objv[0], replacing the first two words with + * the word at the top of the stack; + * <objc,objv> = <op4,top op4 after popping 1> */ + + {"listConcat", 1, -1, 0, {OPERAND_NONE}}, + /* Concatenates the two lists at the top of the stack into a single + * list and pushes that resulting list onto the stack. + * Stack: ... list1 list2 => ... [lconcat list1 list2] */ + + {"expandDrop", 1, 0, 0, {OPERAND_NONE}}, + /* Drops an element from the auxiliary stack, popping stack elements + * until the matching stack depth is reached. */ + + /* New foreach implementation */ + {"foreach_start", 5, +2, 1, {OPERAND_AUX4}}, + /* Initialize execution of a foreach loop. Operand is aux data index + * of the ForeachInfo structure for the foreach command. It pushes 2 + * elements which hold runtime params for foreach_step, they are later + * dropped by foreach_end together with the value lists. NOTE that the + * iterator-tracker and info reference must not be passed to bytecodes + * that handle normal Tcl values. NOTE that this instruction jumps to + * the foreach_step instruction paired with it; the stack info below + * is only nominal. + * Stack: ... listObjs... => ... listObjs... iterTracker info */ + {"foreach_step", 1, 0, 0, {OPERAND_NONE}}, + /* "Step" or begin next iteration of foreach loop. Assigns to foreach + * iteration variables. May jump to straight after the foreach_start + * that pushed the iterTracker and info values. MUST be followed + * immediately by a foreach_end. + * Stack: ... listObjs... iterTracker info => + * ... listObjs... iterTracker info */ + {"foreach_end", 1, 0, 0, {OPERAND_NONE}}, + /* Clean up a foreach loop by dropping the info value, the tracker + * value and the lists that were being iterated over. + * Stack: ... listObjs... iterTracker info => ... */ + {"lmap_collect", 1, -1, 0, {OPERAND_NONE}}, + /* Appends the value at the top of the stack to the list located on + * the stack the "other side" of the foreach-related values. + * Stack: ... collector listObjs... iterTracker info value => + * ... collector listObjs... iterTracker info */ + + {"strtrim", 1, -1, 0, {OPERAND_NONE}}, + /* [string trim] core: removes the characters (designated by the value + * at the top of the stack) from both ends of the string and pushes + * the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimLeft", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimleft] core: removes the characters (designated by the + * value at the top of the stack) from the left of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + {"strtrimRight", 1, -1, 0, {OPERAND_NONE}}, + /* [string trimright] core: removes the characters (designated by the + * value at the top of the stack) from the right of the string and + * pushes the resulting string. + * Stack: ... string charset => ... trimmedString */ + + {"concatStk", 5, INT_MIN, 1, {OPERAND_UINT4}}, + /* Wrapper round Tcl_ConcatObj(), used for [concat] and [eval]. opnd + * is number of values to concatenate. + * Operation: push concat(stk1 stk2 ... stktop) */ + + {"strcaseUpper", 1, 0, 0, {OPERAND_NONE}}, + /* [string toupper] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strcaseLower", 1, 0, 0, {OPERAND_NONE}}, + /* [string tolower] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strcaseTitle", 1, 0, 0, {OPERAND_NONE}}, + /* [string totitle] core: converts whole string to upper case using + * the default (extended "C" locale) rules. + * Stack: ... string => ... newString */ + {"strreplace", 1, -3, 0, {OPERAND_NONE}}, + /* [string replace] core: replaces a non-empty range of one string + * with the contents of another. + * Stack: ... string fromIdx toIdx replacement => ... newString */ + + {"originCmd", 1, 0, 0, {OPERAND_NONE}}, + /* Reports which command was the origin (via namespace import chain) + * of the command named on the top of the stack. + * Stack: ... cmdName => ... fullOriginalCmdName */ + + {"tclooNext", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call the next item on the TclOO call chain, passing opnd arguments + * (min 1, max 255, *includes* "next"). The result of the invoked + * method implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "next" arg2 arg3 -- argN => ... result */ + {"tclooNextClass", 2, INT_MIN, 1, {OPERAND_UINT1}}, + /* Call the following item on the TclOO call chain defined by class + * className, passing opnd arguments (min 2, max 255, *includes* + * "nextto" and the class name). The result of the invoked method + * implementation will be pushed on the stack in place of the + * arguments (similar to invokeStk). + * Stack: ... "nextto" className arg3 arg4 -- argN => ... result */ + + {"yieldToInvoke", 1, 0, 0, {OPERAND_NONE}}, + /* Makes the current coroutine yield the value at the top of the + * stack, invoking the given command/args with resolution in the given + * namespace (all packed into a list), and places the list of values + * that are the response back on top of the stack when it resumes. + * Stack: ... [list ns cmd arg1 ... argN] => ... resumeList */ + + {"numericType", 1, 0, 0, {OPERAND_NONE}}, + /* Pushes the numeric type code of the word at the top of the stack. + * Stack: ... value => ... typeCode */ + {"tryCvtToBoolean", 1, +1, 0, {OPERAND_NONE}}, + /* Try converting stktop to boolean if possible. No errors. + * Stack: ... value => ... value isStrictBool */ + {"strclass", 2, 0, 1, {OPERAND_SCLS1}}, + /* See if all the characters of the given string are a member of the + * specified (by opnd) character class. Note that an empty string will + * satisfy the class check (standard definition of "all"). + * Stack: ... stringValue => ... boolean */ + + {NULL, 0, 0, 0, {OPERAND_NONE}} +}; + /* * Prototypes for procedures defined later in this file: */ +static ByteCode * CompileSubstObj(Tcl_Interp *interp, Tcl_Obj *objPtr, + int flags); static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, Tcl_Obj *copyPtr); static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, @@ -385,25 +668,78 @@ static void EnterCmdExtentData(CompileEnv *envPtr, static void EnterCmdStartData(CompileEnv *envPtr, int cmdNumber, int srcOffset, int codeOffset); static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); +static void FreeSubstCodeInternalRep(Tcl_Obj *objPtr); static int GetCmdLocEncodingSize(CompileEnv *envPtr); +static int IsCompactibleCompileEnv(Tcl_Interp *interp, + CompileEnv *envPtr); #ifdef TCL_COMPILE_STATS static void RecordByteCodeStats(ByteCode *codePtr); #endif /* TCL_COMPILE_STATS */ +static void RegisterAuxDataType(const AuxDataType *typePtr); static int SetByteCodeFromAny(Tcl_Interp *interp, Tcl_Obj *objPtr); +static void StartExpanding(CompileEnv *envPtr); +static int FormatInstruction(ByteCode *codePtr, + const unsigned char *pc, Tcl_Obj *bufferObj); +static void PrintSourceToObj(Tcl_Obj *appendObj, + const char *stringPtr, int maxChars); +static void UpdateStringOfInstName(Tcl_Obj *objPtr); + +/* + * TIP #280: Helper for building the per-word line information of all compiled + * commands. + */ +static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, + Tcl_Token *tokenPtr, const char *cmd, int len, + int numWords, int line, int *clNext, int **lines, + CompileEnv *envPtr); +static void ReleaseCmdWordData(ExtCmdLoc *eclPtr); /* * The structure below defines the bytecode Tcl object type by means of * procedures that can be invoked by generic object code. */ -Tcl_ObjType tclByteCodeType = { +const Tcl_ObjType tclByteCodeType = { "bytecode", /* name */ FreeByteCodeInternalRep, /* freeIntRepProc */ DupByteCodeInternalRep, /* dupIntRepProc */ NULL, /* updateStringProc */ SetByteCodeFromAny /* setFromAnyProc */ }; + +/* + * The structure below defines a bytecode Tcl object type to hold the + * compiled bytecode for the [subst]itution of Tcl values. + */ + +static const Tcl_ObjType substCodeType = { + "substcode", /* name */ + FreeSubstCodeInternalRep, /* freeIntRepProc */ + DupByteCodeInternalRep, /* dupIntRepProc - shared with bytecode */ + NULL, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; + +/* + * The structure below defines an instruction name Tcl object to allow + * reporting of inner contexts in errorstack without string allocation. + */ + +static const Tcl_ObjType tclInstNameType = { + "instname", /* name */ + NULL, /* freeIntRepProc */ + NULL, /* dupIntRepProc */ + UpdateStringOfInstName, /* updateStringProc */ + NULL, /* setFromAnyProc */ +}; + +/* + * Helper macros. + */ + +#define TclIncrUInt4AtPtr(ptr, delta) \ + TclStoreInt4AtPtr(TclGetUInt4AtPtr(ptr)+(delta), (ptr)); /* *---------------------------------------------------------------------- @@ -414,12 +750,13 @@ Tcl_ObjType tclByteCodeType = { * generate an byte code internal form for the Tcl object "objPtr" by * compiling its string representation. This function also takes a hook * procedure that will be invoked to perform any needed post processing - * on the compilation results before generating byte codes. + * on the compilation results before generating byte codes. interp is + * compilation context and may not be NULL. * * Results: * The return value is a standard Tcl object result. If an error occurs * during compilation, an error message is left in the interpreter's - * result unless "interp" is NULL. + * result. * * Side effects: * Frees the old internal representation. If no error occurs, then the @@ -438,17 +775,13 @@ TclSetByteCodeFromAny( CompileHookProc *hookProc, /* Procedure to invoke after compilation. */ ClientData clientData) /* Hook procedure private data. */ { -#ifdef TCL_COMPILE_DEBUG Interp *iPtr = (Interp *) interp; -#endif /*TCL_COMPILE_DEBUG*/ CompileEnv compEnv; /* Compilation environment structure allocated * in frame. */ - LiteralTable *localTablePtr = &(compEnv.localLitTable); - register AuxData *auxDataPtr; - LiteralEntry *entryPtr; - register int i; int length, result = TCL_OK; - char *stringPtr; + const char *stringPtr; + Proc *procPtr = iPtr->compiledProcPtr; + ContLineLoc *clLocPtr; #ifdef TCL_COMPILE_DEBUG if (!traceInitialized) { @@ -460,8 +793,34 @@ TclSetByteCodeFromAny( } #endif - stringPtr = Tcl_GetStringFromObj(objPtr, &length); - TclInitCompileEnv(interp, &compEnv, stringPtr, length); + stringPtr = TclGetStringFromObj(objPtr, &length); + + /* + * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and + * use to initialize the tracking in the compiler. This information was + * stored by TclCompEvalObj and ProcCompileProc. + */ + + TclInitCompileEnv(interp, &compEnv, stringPtr, length, + iPtr->invokeCmdFramePtr, iPtr->invokeWord); + + /* + * Now we check if we have data about invisible continuation lines for the + * script, and make it available to the compile environment, if so. + * + * It is not clear if the script Tcl_Obj* can be free'd while the compiler + * is using it, leading to the release of the associated ContLineLoc + * structure as well. To ensure that the latter doesn't happen we set a + * lock on it. We release this lock in the function TclFreeCompileEnv(), + * found in this file. The "lineCLPtr" hashtable is managed in the file + * "tclObj.c". + */ + + clLocPtr = TclContinuationsGet(objPtr); + if (clLocPtr) { + compEnv.clNext = &clLocPtr->loc[0]; + } + TclCompileScript(interp, stringPtr, length, &compEnv); /* @@ -471,11 +830,45 @@ TclSetByteCodeFromAny( TclEmitOpcode(INST_DONE, &compEnv); /* + * Check for optimizations! + * + * Test if the generated code is free of most hazards; if so, recompile + * but with generation of INST_START_CMD disabled. This produces somewhat + * faster code in some cases, and more compact code in more. + */ + + if (Tcl_GetMaster(interp) == NULL && + !Tcl_LimitTypeEnabled(interp, TCL_LIMIT_COMMANDS|TCL_LIMIT_TIME) + && IsCompactibleCompileEnv(interp, &compEnv)) { + TclFreeCompileEnv(&compEnv); + iPtr->compiledProcPtr = procPtr; + TclInitCompileEnv(interp, &compEnv, stringPtr, length, + iPtr->invokeCmdFramePtr, iPtr->invokeWord); + if (clLocPtr) { + compEnv.clNext = &clLocPtr->loc[0]; + } + compEnv.atCmdStart = 2; /* The disabling magic. */ + TclCompileScript(interp, stringPtr, length, &compEnv); + assert (compEnv.atCmdStart > 1); + TclEmitOpcode(INST_DONE, &compEnv); + assert (compEnv.atCmdStart > 1); + } + + /* + * Apply some peephole optimizations that can cross specific/generic + * instruction generator boundaries. + */ + + if (iPtr->extra.optimizer) { + (iPtr->extra.optimizer)(&compEnv); + } + + /* * Invoke the compilation hook procedure if one exists. */ if (hookProc) { - result = (*hookProc)(interp, &compEnv, clientData); + result = hookProc(interp, &compEnv, clientData); } /* @@ -487,43 +880,16 @@ TclSetByteCodeFromAny( TclVerifyLocalLiteralTable(&compEnv); #endif /*TCL_COMPILE_DEBUG*/ - TclInitByteCodeObj(objPtr, &compEnv); + if (result == TCL_OK) { + TclInitByteCodeObj(objPtr, &compEnv); #ifdef TCL_COMPILE_DEBUG - if (tclTraceCompile >= 2) { - TclPrintByteCodeObj(interp, objPtr); - } -#endif /* TCL_COMPILE_DEBUG */ - - if (result != TCL_OK) { - /* - * Handle any error from the hookProc - */ - - entryPtr = compEnv.literalArrayPtr; - for (i = 0; i < compEnv.literalArrayNext; i++) { - TclReleaseLiteral(interp, entryPtr->objPtr); - entryPtr++; - } -#ifdef TCL_COMPILE_DEBUG - TclVerifyGlobalLiteralTable(iPtr); -#endif /*TCL_COMPILE_DEBUG*/ - - auxDataPtr = compEnv.auxDataArrayPtr; - for (i = 0; i < compEnv.auxDataArrayNext; i++) { - if (auxDataPtr->type->freeProc != NULL) { - auxDataPtr->type->freeProc(auxDataPtr->clientData); - } - auxDataPtr++; + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); } +#endif /* TCL_COMPILE_DEBUG */ } - /* - * Free storage allocated during compilation. - */ - - if (localTablePtr->buckets != localTablePtr->staticBuckets) { - ckfree((char *) localTablePtr->buckets); - } TclFreeCompileEnv(&compEnv); return result; } @@ -557,7 +923,10 @@ SetByteCodeFromAny( * compiled. Must not be NULL. */ Tcl_Obj *objPtr) /* The object to make a ByteCode object. */ { - return TclSetByteCodeFromAny(interp, objPtr, NULL, (ClientData) NULL); + if (interp == NULL) { + return TCL_ERROR; + } + return TclSetByteCodeFromAny(interp, objPtr, NULL, NULL); } /* @@ -611,15 +980,13 @@ static void FreeByteCodeInternalRep( register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ { - register ByteCode *codePtr = (ByteCode *) - objPtr->internalRep.otherValuePtr; + register ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; + objPtr->typePtr = NULL; codePtr->refCount--; if (codePtr->refCount <= 0) { TclCleanupByteCode(codePtr); } - objPtr->typePtr = NULL; - objPtr->internalRep.otherValuePtr = NULL; } /* @@ -635,9 +1002,8 @@ FreeByteCodeInternalRep( * None. * * Side effects: - * Frees objPtr's bytecode internal representation and sets its type and - * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and - * frees its auxiliary data items. + * Frees objPtr's bytecode internal representation and sets its type NULL + * Also releases its literals and frees its auxiliary data items. * *---------------------------------------------------------------------- */ @@ -647,10 +1013,11 @@ TclCleanupByteCode( register ByteCode *codePtr) /* Points to the ByteCode to free. */ { Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; + Interp *iPtr = (Interp *) interp; int numLitObjects = codePtr->numLitObjects; int numAuxDataItems = codePtr->numAuxDataItems; register Tcl_Obj **objArrayPtr, *objPtr; - register AuxData *auxDataPtr; + register const AuxData *auxDataPtr; int i; #ifdef TCL_COMPILE_STATS @@ -659,7 +1026,7 @@ TclCleanupByteCode( Tcl_Time destroyTime; int lifetimeSec, lifetimeMicroSec, log2; - statsPtr = &((Interp *) interp)->stats; + statsPtr = &iPtr->stats; statsPtr->numByteCodesFreed++; statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; @@ -694,8 +1061,9 @@ TclCleanupByteCode( * A single heap object holds the ByteCode structure and its code, object, * command location, and auxiliary data arrays. This means we only need to * 1) decrement the ref counts of the LiteralEntry's in its literal array, - * 2) call the free procs for the auxiliary data items, and 3) free the - * ByteCode structure's heap object. + * 2) call the free procs for the auxiliary data items, 3) free the + * localCache if it is unused, and finally 4) free the ByteCode + * structure's heap object. * * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like * those generated from tbcload) is special, as they doesn't make use of @@ -710,7 +1078,7 @@ TclCleanupByteCode( * released. */ - if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { + if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) { objArrayPtr = codePtr->objArrayPtr; for (i = 0; i < numLitObjects; i++) { @@ -723,30 +1091,309 @@ TclCleanupByteCode( codePtr->numLitObjects = 0; } else { objArrayPtr = codePtr->objArrayPtr; - for (i = 0; i < numLitObjects; i++) { - /* - * TclReleaseLiteral sets a ByteCode's object array entry NULL to - * indicate that it has already freed the literal. - */ - - objPtr = *objArrayPtr; - if (objPtr != NULL) { - TclReleaseLiteral(interp, objPtr); - } - objArrayPtr++; + while (numLitObjects--) { + /* TclReleaseLiteral calls Tcl_DecrRefCount() for us */ + TclReleaseLiteral(interp, *objArrayPtr++); } } auxDataPtr = codePtr->auxDataArrayPtr; for (i = 0; i < numAuxDataItems; i++) { if (auxDataPtr->type->freeProc != NULL) { - (auxDataPtr->type->freeProc)(auxDataPtr->clientData); + auxDataPtr->type->freeProc(auxDataPtr->clientData); } auxDataPtr++; } + /* + * TIP #280. Release the location data associated with this byte code + * structure, if any. NOTE: The interp we belong to may be gone already, + * and the data with it. + * + * See also tclBasic.c, DeleteInterpProc + */ + + if (iPtr) { + Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, + (char *) codePtr); + + if (hePtr) { + ReleaseCmdWordData(Tcl_GetHashValue(hePtr)); + Tcl_DeleteHashEntry(hePtr); + } + } + + if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) { + TclFreeLocalCache(interp, codePtr->localCachePtr); + } + TclHandleRelease(codePtr->interpHandle); - ckfree((char *) codePtr); + ckfree(codePtr); +} + +/* + * --------------------------------------------------------------------- + * + * IsCompactibleCompileEnv -- + * + * Checks to see if we may apply some basic compaction optimizations to a + * piece of bytecode. Idempotent. + * + * --------------------------------------------------------------------- + */ + +static int +IsCompactibleCompileEnv( + Tcl_Interp *interp, + CompileEnv *envPtr) +{ + unsigned char *pc; + int size; + + /* + * Special: procedures in the '::tcl' namespace (or its children) are + * considered to be well-behaved and so can have compaction applied even + * if it would otherwise be invalid. + */ + + if (envPtr->procPtr != NULL && envPtr->procPtr->cmdPtr != NULL + && envPtr->procPtr->cmdPtr->nsPtr != NULL) { + Namespace *nsPtr = envPtr->procPtr->cmdPtr->nsPtr; + + if (strcmp(nsPtr->fullName, "::tcl") == 0 + || strncmp(nsPtr->fullName, "::tcl::", 7) == 0) { + return 1; + } + } + + /* + * Go through and ensure that no operation involved can cause a desired + * change of bytecode sequence during running. This comes down to ensuring + * that there are no mapped variables (due to traces) or calls to external + * commands (traces, [uplevel] trickery). This is actually a very + * conservative check; it turns down a lot of code that is OK in practice. + */ + + for (pc = envPtr->codeStart ; pc < envPtr->codeNext ; pc += size) { + switch (*pc) { + /* Invokes */ + case INST_INVOKE_STK1: + case INST_INVOKE_STK4: + case INST_INVOKE_EXPANDED: + case INST_INVOKE_REPLACE: + return 0; + /* Runtime evals */ + case INST_EVAL_STK: + case INST_EXPR_STK: + case INST_YIELD: + return 0; + /* Upvars */ + case INST_UPVAR: + case INST_NSUPVAR: + case INST_VARIABLE: + return 0; + default: + size = tclInstructionTable[*pc].numBytes; + assert (size > 0); + break; + } + } + + return 1; +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_SubstObj -- + * + * This function performs the substitutions specified on the given string + * as described in the user documentation for the "subst" Tcl command. + * + * Results: + * A Tcl_Obj* containing the substituted string, or NULL to indicate that + * an error occurred. + * + * Side effects: + * See the user documentation. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +Tcl_SubstObj( + Tcl_Interp *interp, /* Interpreter in which substitution occurs */ + Tcl_Obj *objPtr, /* The value to be substituted. */ + int flags) /* What substitutions to do. */ +{ + NRE_callback *rootPtr = TOP_CB(interp); + + if (TclNRRunCallbacks(interp, Tcl_NRSubstObj(interp, objPtr, flags), + rootPtr) != TCL_OK) { + return NULL; + } + return Tcl_GetObjResult(interp); +} + +/* + *---------------------------------------------------------------------- + * + * Tcl_NRSubstObj -- + * + * Request substitution of a Tcl value by the NR stack. + * + * Results: + * Returns TCL_OK. + * + * Side effects: + * Compiles objPtr into bytecode that performs the substitutions as + * governed by flags and places callbacks on the NR stack to execute + * the bytecode and store the result in the interp. + * + *---------------------------------------------------------------------- + */ + +int +Tcl_NRSubstObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int flags) +{ + ByteCode *codePtr = CompileSubstObj(interp, objPtr, flags); + + /* TODO: Confirm we do not need this. */ + /* Tcl_ResetResult(interp); */ + return TclNRExecuteByteCode(interp, codePtr); +} + +/* + *---------------------------------------------------------------------- + * + * CompileSubstObj -- + * + * Compile a Tcl value into ByteCode implementing its substitution, as + * governed by flags. + * + * Results: + * A (ByteCode *) is returned pointing to the resulting ByteCode. + * The caller must manage its refCount and arrange for a call to + * TclCleanupByteCode() when the last reference disappears. + * + * Side effects: + * The Tcl_ObjType of objPtr is changed to the "substcode" type, and the + * ByteCode and governing flags value are kept in the internal rep for + * faster operations the next time CompileSubstObj is called on the same + * value. + * + *---------------------------------------------------------------------- + */ + +static ByteCode * +CompileSubstObj( + Tcl_Interp *interp, + Tcl_Obj *objPtr, + int flags) +{ + Interp *iPtr = (Interp *) interp; + ByteCode *codePtr = NULL; + + if (objPtr->typePtr == &substCodeType) { + Namespace *nsPtr = iPtr->varFramePtr->nsPtr; + + codePtr = objPtr->internalRep.ptrAndLongRep.ptr; + if ((unsigned long)flags != objPtr->internalRep.ptrAndLongRep.value + || ((Interp *) *codePtr->interpHandle != iPtr) + || (codePtr->compileEpoch != iPtr->compileEpoch) + || (codePtr->nsPtr != nsPtr) + || (codePtr->nsEpoch != nsPtr->resolverEpoch) + || (codePtr->localCachePtr != + iPtr->varFramePtr->localCachePtr)) { + FreeSubstCodeInternalRep(objPtr); + } + } + if (objPtr->typePtr != &substCodeType) { + CompileEnv compEnv; + int numBytes; + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + + /* TODO: Check for more TIP 280 */ + TclInitCompileEnv(interp, &compEnv, bytes, numBytes, NULL, 0); + + TclSubstCompile(interp, bytes, numBytes, flags, 1, &compEnv); + + TclEmitOpcode(INST_DONE, &compEnv); + TclInitByteCodeObj(objPtr, &compEnv); + objPtr->typePtr = &substCodeType; + TclFreeCompileEnv(&compEnv); + + codePtr = objPtr->internalRep.twoPtrValue.ptr1; + objPtr->internalRep.ptrAndLongRep.ptr = codePtr; + objPtr->internalRep.ptrAndLongRep.value = flags; + if (iPtr->varFramePtr->localCachePtr) { + codePtr->localCachePtr = iPtr->varFramePtr->localCachePtr; + codePtr->localCachePtr->refCount++; + } +#ifdef TCL_COMPILE_DEBUG + if (tclTraceCompile >= 2) { + TclPrintByteCodeObj(interp, objPtr); + fflush(stdout); + } +#endif /* TCL_COMPILE_DEBUG */ + } + return codePtr; +} + +/* + *---------------------------------------------------------------------- + * + * FreeSubstCodeInternalRep -- + * + * Part of the substcode Tcl object type implementation. Frees the + * storage associated with a substcode object's internal representation + * unless its code is actively being executed. + * + * Results: + * None. + * + * Side effects: + * The substcode object's internal rep is marked invalid and its code + * gets freed unless the code is actively being executed. In that case + * the cleanup is delayed until the last execution of the code completes. + * + *---------------------------------------------------------------------- + */ + +static void +FreeSubstCodeInternalRep( + register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ +{ + register ByteCode *codePtr = objPtr->internalRep.ptrAndLongRep.ptr; + + objPtr->typePtr = NULL; + codePtr->refCount--; + if (codePtr->refCount <= 0) { + TclCleanupByteCode(codePtr); + } +} + +static void +ReleaseCmdWordData( + ExtCmdLoc *eclPtr) +{ + int i; + + if (eclPtr->type == TCL_LOCATION_SOURCE) { + Tcl_DecrRefCount(eclPtr->path); + } + for (i=0 ; i<eclPtr->nuloc ; i++) { + ckfree((char *) eclPtr->loc[i].line); + } + + if (eclPtr->loc != NULL) { + ckfree((char *) eclPtr->loc); + } + + ckfree((char *) eclPtr); } /* @@ -772,25 +1419,31 @@ TclInitCompileEnv( * structure is initialized. */ register CompileEnv *envPtr,/* Points to the CompileEnv structure to * initialize. */ - char *stringPtr, /* The source string to be compiled. */ - int numBytes) /* Number of bytes in source string. */ + const char *stringPtr, /* The source string to be compiled. */ + int numBytes, /* Number of bytes in source string. */ + const CmdFrame *invoker, /* Location context invoking the bcc */ + int word) /* Index of the word in that context getting + * compiled */ { Interp *iPtr = (Interp *) interp; + assert(tclInstructionTable[LAST_INST_OPCODE+1].name == NULL); + envPtr->iPtr = iPtr; envPtr->source = stringPtr; envPtr->numSrcBytes = numBytes; envPtr->procPtr = iPtr->compiledProcPtr; + iPtr->compiledProcPtr = NULL; envPtr->numCommands = 0; envPtr->exceptDepth = 0; envPtr->maxExceptDepth = 0; envPtr->maxStackDepth = 0; envPtr->currStackDepth = 0; - TclInitLiteralTable(&(envPtr->localLitTable)); + TclInitLiteralTable(&envPtr->localLitTable); envPtr->codeStart = envPtr->staticCodeSpace; envPtr->codeNext = envPtr->codeStart; - envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); + envPtr->codeEnd = envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES; envPtr->mallocedCodeArray = 0; envPtr->literalArrayPtr = envPtr->staticLiteralSpace; @@ -799,6 +1452,7 @@ TclInitCompileEnv( envPtr->mallocedLiteralArray = 0; envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; + envPtr->exceptAuxArrayPtr = envPtr->staticExAuxArraySpace; envPtr->exceptArrayNext = 0; envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; envPtr->mallocedExceptArray = 0; @@ -806,6 +1460,139 @@ TclInitCompileEnv( envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; envPtr->mallocedCmdMap = 0; + envPtr->atCmdStart = 1; + envPtr->expandCount = 0; + + /* + * TIP #280: Set up the extended command location information, based on + * the context invoking the byte code compiler. This structure is used to + * keep the per-word line information for all compiled commands. + * + * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the + * non-compiling evaluator + */ + + envPtr->extCmdMapPtr = ckalloc(sizeof(ExtCmdLoc)); + envPtr->extCmdMapPtr->loc = NULL; + envPtr->extCmdMapPtr->nloc = 0; + envPtr->extCmdMapPtr->nuloc = 0; + envPtr->extCmdMapPtr->path = NULL; + + if (invoker == NULL) { + /* + * Initialize the compiler for relative counting in case of a + * dynamic context. + */ + + envPtr->line = 1; + if (iPtr->evalFlags & TCL_EVAL_FILE) { + iPtr->evalFlags &= ~TCL_EVAL_FILE; + envPtr->extCmdMapPtr->type = TCL_LOCATION_SOURCE; + + if (iPtr->scriptFile) { + /* + * Normalization here, to have the correct pwd. Should have + * negligible impact on performance, as the norm should have + * been done already by the 'source' invoking us, and it + * caches the result. + */ + + Tcl_Obj *norm = + Tcl_FSGetNormalizedPath(interp, iPtr->scriptFile); + + if (norm == NULL) { + /* + * Error message in the interp result. No place to put it. + * And no place to serve the error itself to either. Fake + * a path, empty string. + */ + + TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, ""); + } else { + envPtr->extCmdMapPtr->path = norm; + } + } else { + TclNewLiteralStringObj(envPtr->extCmdMapPtr->path, ""); + } + + Tcl_IncrRefCount(envPtr->extCmdMapPtr->path); + } else { + envPtr->extCmdMapPtr->type = + (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); + } + } else { + /* + * Initialize the compiler using the context, making counting absolute + * to that context. Note that the context can be byte code execution. + * In that case we have to fill out the missing pieces (line, path, + * ...) which may make change the type as well. + */ + + CmdFrame *ctxPtr = TclStackAlloc(interp, sizeof(CmdFrame)); + int pc = 0; + + *ctxPtr = *invoker; + if (invoker->type == TCL_LOCATION_BC) { + /* + * Note: Type BC => ctx.data.eval.path is not used. + * ctx.data.tebc.codePtr is used instead. + */ + + TclGetSrcInfoForPc(ctxPtr); + pc = 1; + } + + if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) { + /* + * Word is not a literal, relative counting. + */ + + envPtr->line = 1; + envPtr->extCmdMapPtr->type = + (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); + + if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { + /* + * The reference made by 'TclGetSrcInfoForPc' is dead. + */ + + Tcl_DecrRefCount(ctxPtr->data.eval.path); + } + } else { + envPtr->line = ctxPtr->line[word]; + envPtr->extCmdMapPtr->type = ctxPtr->type; + + if (ctxPtr->type == TCL_LOCATION_SOURCE) { + envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; + + if (pc) { + /* + * The reference 'TclGetSrcInfoForPc' made is transfered. + */ + + ctxPtr->data.eval.path = NULL; + } else { + /* + * We have a new reference here. + */ + + Tcl_IncrRefCount(envPtr->extCmdMapPtr->path); + } + } + } + + TclStackFree(interp, ctxPtr); + } + + envPtr->extCmdMapPtr->start = envPtr->line; + + /* + * Initialize the data about invisible continuation lines as empty, i.e. + * not used. The caller (TclSetByteCodeFromAny) will set this up, if such + * data is available. + */ + + envPtr->clNext = NULL; envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; envPtr->auxDataArrayNext = 0; @@ -839,20 +1626,55 @@ void TclFreeCompileEnv( register CompileEnv *envPtr)/* Points to the CompileEnv structure. */ { + if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets){ + ckfree(envPtr->localLitTable.buckets); + envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; + } + if (envPtr->iPtr) { + /* + * We never converted to Bytecode, so free the things we would + * have transferred to it. + */ + + int i; + LiteralEntry *entryPtr = envPtr->literalArrayPtr; + AuxData *auxDataPtr = envPtr->auxDataArrayPtr; + + for (i = 0; i < envPtr->literalArrayNext; i++) { + TclReleaseLiteral((Tcl_Interp *)envPtr->iPtr, entryPtr->objPtr); + entryPtr++; + } + +#ifdef TCL_COMPILE_DEBUG + TclVerifyGlobalLiteralTable(envPtr->iPtr); +#endif /*TCL_COMPILE_DEBUG*/ + + for (i = 0; i < envPtr->auxDataArrayNext; i++) { + if (auxDataPtr->type->freeProc != NULL) { + auxDataPtr->type->freeProc(auxDataPtr->clientData); + } + auxDataPtr++; + } + } if (envPtr->mallocedCodeArray) { - ckfree((char *) envPtr->codeStart); + ckfree(envPtr->codeStart); } if (envPtr->mallocedLiteralArray) { - ckfree((char *) envPtr->literalArrayPtr); + ckfree(envPtr->literalArrayPtr); } if (envPtr->mallocedExceptArray) { - ckfree((char *) envPtr->exceptArrayPtr); + ckfree(envPtr->exceptArrayPtr); + ckfree(envPtr->exceptAuxArrayPtr); } if (envPtr->mallocedCmdMap) { - ckfree((char *) envPtr->cmdMapPtr); + ckfree(envPtr->cmdMapPtr); } if (envPtr->mallocedAuxDataArray) { - ckfree((char *) envPtr->auxDataArrayPtr); + ckfree(envPtr->auxDataArrayPtr); + } + if (envPtr->extCmdMapPtr) { + ReleaseCmdWordData(envPtr->extCmdMapPtr); + envPtr->extCmdMapPtr = NULL; } } @@ -914,7 +1736,9 @@ TclWordKnownAtCompileTime( case TCL_TOKEN_BS: if (tempPtr != NULL) { char utfBuf[TCL_UTF_MAX]; - int length = Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf); + int length = TclParseBackslash(tokenPtr->start, + tokenPtr->size, NULL, utfBuf); + Tcl_AppendToObj(tempPtr, utfBuf, length); } break; @@ -952,360 +1776,467 @@ TclWordKnownAtCompileTime( *---------------------------------------------------------------------- */ +static int +ExpandRequested( + Tcl_Token *tokenPtr, + int numWords) +{ + /* Determine whether any words of the command require expansion */ + while (numWords--) { + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + return 1; + } + tokenPtr = TokenAfter(tokenPtr); + } + return 0; +} + +static void +CompileCmdLiteral( + Tcl_Interp *interp, + Tcl_Obj *cmdObj, + CompileEnv *envPtr) +{ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(cmdObj, &numBytes); + int cmdLitIdx = TclRegisterNewCmdLiteral(envPtr, bytes, numBytes); + Command *cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + + if (cmdPtr) { + TclSetCmdNameObj(interp, TclFetchLiteral(envPtr, cmdLitIdx), cmdPtr); + } + TclEmitPush(cmdLitIdx, envPtr); +} + void -TclCompileScript( - Tcl_Interp *interp, /* Used for error and status reporting. Also - * serves as context for finding and compiling - * commands. May not be NULL. */ - CONST char *script, /* The source script to compile. */ - int numBytes, /* Number of bytes in script. If < 0, the - * script consists of all bytes up to the - * first null character. */ - CompileEnv *envPtr) /* Holds resulting instructions. */ +TclCompileInvocation( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + CompileEnv *envPtr) { - Interp *iPtr = (Interp *) interp; - Tcl_Parse parse; - int lastTopLevelCmdIndex = -1; - /* Index of most recent toplevel command in - * the command location table. Initialized * - * to avoid compiler warning. */ - int startCodeOffset = -1; /* Offset of first byte of current command's - * code. Init. to avoid compiler warning. */ - unsigned char *entryCodeNext = envPtr->codeNext; - CONST char *p, *next; - Namespace *cmdNsPtr; - Command *cmdPtr; - Tcl_Token *tokenPtr; - int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex; - int commandLength, objIndex, code; - Tcl_DString ds; + int wordIdx = 0, depth = TclGetStackDepth(envPtr); + DefineLineInformation; + + if (cmdObj) { + CompileCmdLiteral(interp, cmdObj, envPtr); + wordIdx = 1; + tokenPtr = TokenAfter(tokenPtr); + } + + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { + int objIdx; - Tcl_DStringInit(&ds); + SetLineInformation(wordIdx); - if (numBytes < 0) { - numBytes = strlen(script); + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, envPtr->clNext); + } + TclEmitPush(objIdx, envPtr); } - Tcl_ResetResult(interp); - isFirstCmd = 1; - if (envPtr->procPtr != NULL) { - cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; + if (wordIdx <= 255) { + TclEmitInvoke(envPtr, INST_INVOKE_STK1, wordIdx); } else { - cmdNsPtr = NULL; /* use current NS */ + TclEmitInvoke(envPtr, INST_INVOKE_STK4, wordIdx); + } + TclCheckStackDepth(depth+1, envPtr); +} + +static void +CompileExpanded( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + Tcl_Obj *cmdObj, + int numWords, + CompileEnv *envPtr) +{ + int wordIdx = 0; + DefineLineInformation; + int depth = TclGetStackDepth(envPtr); + + StartExpanding(envPtr); + if (cmdObj) { + CompileCmdLiteral(interp, cmdObj, envPtr); + wordIdx = 1; + tokenPtr = TokenAfter(tokenPtr); + } + + for (; wordIdx < numWords; wordIdx++, tokenPtr = TokenAfter(tokenPtr)) { + int objIdx; + + SetLineInformation(wordIdx); + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { + TclEmitInstInt4(INST_EXPAND_STKTOP, + envPtr->currStackDepth, envPtr); + } + continue; + } + + objIdx = TclRegisterNewLiteral(envPtr, + tokenPtr[1].start, tokenPtr[1].size); + if (envPtr->clNext) { + TclContinuationsEnterDerived(TclFetchLiteral(envPtr, objIdx), + tokenPtr[1].start - envPtr->source, envPtr->clNext); + } + TclEmitPush(objIdx, envPtr); } /* - * Each iteration through the following loop compiles the next command - * from the script. + * The stack depth during argument expansion can only be managed at + * runtime, as the number of elements in the expanded lists is not known + * at compile time. We adjust here the stack depth estimate so that it is + * correct after the command with expanded arguments returns. + * + * The end effect of this command's invocation is that all the words of + * the command are popped from the stack, and the result is pushed: the + * stack top changes by (1-wordIdx). + * + * Note that the estimates are not correct while the command is being + * prepared and run, INST_EXPAND_STKTOP is not stack-neutral in general. */ - p = script; - bytesLeft = numBytes; - gotParse = 0; - do { - if (Tcl_ParseCommand(interp, p, bytesLeft, 0, &parse) != TCL_OK) { - /* Compile bytecodes to report the parse error at runtime */ - Tcl_Obj *returnCmd = Tcl_NewStringObj( - "return -code 1 -level 0 -errorinfo", -1); - Tcl_Obj *errMsg = Tcl_GetObjResult(interp); - Tcl_Obj *errInfo = Tcl_DuplicateObj(errMsg); - char *cmdString; - int cmdLength; - Tcl_Parse subParse; - int errorLine = 1; - - Tcl_IncrRefCount(returnCmd); - Tcl_IncrRefCount(errInfo); - Tcl_AppendToObj(errInfo, "\n while executing\n\"", -1); - TclAppendLimitedToObj(errInfo, parse.commandStart, - /* Drop the command terminator (";","]") if appropriate */ - (parse.term == parse.commandStart + parse.commandSize - 1)? - parse.commandSize - 1 : parse.commandSize, 153, NULL); - Tcl_AppendToObj(errInfo, "\"", -1); - - Tcl_ListObjAppendElement(NULL, returnCmd, errInfo); - - for (p = envPtr->source; p != parse.commandStart; p++) { - if (*p == '\n') { - errorLine++; - } - } - Tcl_ListObjAppendElement(NULL, returnCmd, - Tcl_NewStringObj("-errorline", -1)); - Tcl_ListObjAppendElement(NULL, returnCmd, - Tcl_NewIntObj(errorLine)); - - Tcl_ListObjAppendElement(NULL, returnCmd, errMsg); - Tcl_DecrRefCount(errInfo); - - cmdString = Tcl_GetStringFromObj(returnCmd, &cmdLength); - Tcl_ParseCommand(interp, cmdString, cmdLength, 0, &subParse); - TclCompileReturnCmd(interp, &subParse, envPtr); - Tcl_DecrRefCount(returnCmd); - Tcl_FreeParse(&subParse); - return; + TclEmitInvoke(envPtr, INST_INVOKE_EXPANDED, wordIdx); + TclCheckStackDepth(depth+1, envPtr); +} + +static int +CompileCmdCompileProc( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + Command *cmdPtr, + CompileEnv *envPtr) +{ + int unwind = 0, incrOffset = -1; + DefineLineInformation; + int depth = TclGetStackDepth(envPtr); + + /* + * Emit of the INST_START_CMD instruction is controlled by the value of + * envPtr->atCmdStart: + * + * atCmdStart == 2 : We are not using the INST_START_CMD instruction. + * atCmdStart == 1 : INST_START_CMD was the last instruction emitted. + * : We do not need to emit another. Instead we + * : increment the number of cmds started at it (except + * : for the special case at the start of a script.) + * atCmdStart == 0 : The last instruction was something else. We need + * : to emit INST_START_CMD here. + */ + + switch (envPtr->atCmdStart) { + case 0: + unwind = tclInstructionTable[INST_START_CMD].numBytes; + TclEmitInstInt4(INST_START_CMD, 0, envPtr); + incrOffset = envPtr->codeNext - envPtr->codeStart; + TclEmitInt4(0, envPtr); + break; + case 1: + if (envPtr->codeNext > envPtr->codeStart) { + incrOffset = envPtr->codeNext - 4 - envPtr->codeStart; } - gotParse = 1; - if (parse.numWords > 0) { - int expand = 0; + break; + case 2: + /* Nothing to do */ + ; + } + if (TCL_OK == TclAttemptCompileProc(interp, parsePtr, 1, cmdPtr, envPtr)) { + if (incrOffset >= 0) { /* - * If not the first command, pop the previous command's result - * and, if we're compiling a top level command, update the last - * command's code size to account for the pop instruction. + * We successfully compiled a command. Increment the number of + * commands that start at the currently active INST_START_CMD. */ - if (!isFirstCmd) { - TclEmitOpcode(INST_POP, envPtr); - envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = - (envPtr->codeNext - envPtr->codeStart) - - startCodeOffset; + unsigned char *incrPtr = envPtr->codeStart + incrOffset; + unsigned char *startPtr = incrPtr - 5; + + TclIncrUInt4AtPtr(incrPtr, 1); + if (unwind) { + /* We started the INST_START_CMD. Record the code length. */ + TclStoreInt4AtPtr(envPtr->codeNext - startPtr, startPtr + 1); } + } + TclCheckStackDepth(depth+1, envPtr); + return TCL_OK; + } - /* - * Determine the actual length of the command. - */ + envPtr->codeNext -= unwind; /* Unwind INST_START_CMD */ - commandLength = parse.commandSize; - if (parse.term == parse.commandStart + commandLength - 1) { - /* - * The command terminator character (such as ; or ]) is the - * last character in the parsed command. Reduce the length by - * one so that the trace message doesn't include the - * terminator character. - */ + /* + * Throw out any line information generated by the failed compile attempt. + */ - commandLength -= 1; - } + while (mapPtr->nuloc - 1 > eclIndex) { + mapPtr->nuloc--; + ckfree(mapPtr->loc[mapPtr->nuloc].line); + mapPtr->loc[mapPtr->nuloc].line = NULL; + } -#ifdef TCL_COMPILE_DEBUG - /* - * If tracing, print a line for each top level command compiled. - */ + /* + * Reset the index of next command. Toss out any from failed nested + * partial compiles. + */ - if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { - fprintf(stdout, " Compiling: "); - TclPrintSource(stdout, parse.commandStart, - TclMin(commandLength, 55)); - fprintf(stdout, "\n"); - } -#endif + envPtr->numCommands = mapPtr->nuloc; + return TCL_ERROR; +} - /* - * Check whether expansion has been requested for any of the words - */ +static int +CompileCommandTokens( + Tcl_Interp *interp, + Tcl_Parse *parsePtr, + CompileEnv *envPtr) +{ + Interp *iPtr = (Interp *) interp; + Tcl_Token *tokenPtr = parsePtr->tokenPtr; + ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; + Tcl_Obj *cmdObj = Tcl_NewObj(); + Command *cmdPtr = NULL; + int code = TCL_ERROR; + int cmdKnown, expand = -1; + int *wlines, wlineat; + int cmdLine = envPtr->line; + int *clNext = envPtr->clNext; + int cmdIdx = envPtr->numCommands; + int startCodeOffset = envPtr->codeNext - envPtr->codeStart; + int depth = TclGetStackDepth(envPtr); + + assert (parsePtr->numWords > 0); + + /* Pre-Compile */ + + envPtr->numCommands++; + EnterCmdStartData(envPtr, cmdIdx, + parsePtr->commandStart - envPtr->source, startCodeOffset); - for (wordIdx = 0, tokenPtr = parse.tokenPtr; - wordIdx < parse.numWords; - wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - expand = 1; - TclEmitOpcode(INST_EXPAND_START, envPtr); - break; - } - } + /* + * TIP #280. Scan the words and compute the extended location information. + * The map first contain full per-word line information for use by the + * compiler. This is later replaced by a reduced form which signals + * non-literal words, stored in 'wlines'. + */ + + EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, + parsePtr->tokenPtr, parsePtr->commandStart, + parsePtr->commandSize, parsePtr->numWords, cmdLine, + clNext, &wlines, envPtr); + wlineat = eclPtr->nuloc - 1; - envPtr->numCommands++; - currCmdIndex = (envPtr->numCommands - 1); - lastTopLevelCmdIndex = currCmdIndex; - startCodeOffset = (envPtr->codeNext - envPtr->codeStart); - EnterCmdStartData(envPtr, currCmdIndex, - (parse.commandStart - envPtr->source), startCodeOffset); + envPtr->line = eclPtr->loc[wlineat].line[0]; + envPtr->clNext = eclPtr->loc[wlineat].next[0]; + /* Do we know the command word? */ + Tcl_IncrRefCount(cmdObj); + tokenPtr = parsePtr->tokenPtr; + cmdKnown = TclWordKnownAtCompileTime(tokenPtr, cmdObj); + + /* Is this a command we should (try to) compile with a compileProc ? */ + if (cmdKnown && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { + cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, cmdObj); + if (cmdPtr) { /* - * Each iteration of the following loop compiles one word from the - * command. + * Found a command. Test the ways we can be told not to attempt + * to compile it. */ + if ((cmdPtr->compileProc == NULL) + || (cmdPtr->nsPtr->flags & NS_SUPPRESS_COMPILATION) + || (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) { + cmdPtr = NULL; + } + } + if (cmdPtr && !(cmdPtr->flags & CMD_COMPILES_EXPANDED)) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + if (expand) { + /* We need to expand, but compileProc cannot. */ + cmdPtr = NULL; + } + } + } - for (wordIdx = 0, tokenPtr = parse.tokenPtr; - wordIdx < parse.numWords; wordIdx++, - tokenPtr += (tokenPtr->numComponents + 1)) { + /* If cmdPtr != NULL, we will try to call cmdPtr->compileProc */ + if (cmdPtr) { + code = CompileCmdCompileProc(interp, parsePtr, cmdPtr, envPtr); + } - if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { - /* - * The word is not a simple string of characters. - */ + if (code == TCL_ERROR) { + if (expand < 0) { + expand = ExpandRequested(parsePtr->tokenPtr, parsePtr->numWords); + } - TclCompileTokens(interp, tokenPtr+1, - tokenPtr->numComponents, envPtr); - if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { - TclEmitInstInt4(INST_EXPAND_STKTOP, - envPtr->currStackDepth, envPtr); - } - continue; - } + if (expand) { + CompileExpanded(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + } else { + TclCompileInvocation(interp, parsePtr->tokenPtr, + cmdKnown ? cmdObj : NULL, parsePtr->numWords, envPtr); + } + } - /* - * This is a simple string of literal characters (i.e. we know - * it absolutely and can use it directly). If this is the - * first word and the command has a compile procedure, let it - * compile the command. - */ + Tcl_DecrRefCount(cmdObj); - if ((wordIdx == 0) && !expand) { - /* - * We copy the string before trying to find the command by - * name. We used to modify the string in place, but this - * is not safe because the name resolution handlers could - * have side effects that rely on the unmodified string. - */ + TclEmitOpcode(INST_POP, envPtr); + EnterCmdExtentData(envPtr, cmdIdx, + parsePtr->term - parsePtr->commandStart, + (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - Tcl_DStringSetLength(&ds, 0); - Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size); - - cmdPtr = (Command *) Tcl_FindCommand(interp, - Tcl_DStringValue(&ds), - (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); - - if ((cmdPtr != NULL) - && (cmdPtr->compileProc != NULL) - && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) - && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { - int savedNumCmds = envPtr->numCommands; - unsigned int savedCodeNext = - envPtr->codeNext - envPtr->codeStart; - - /* - * Mark the start of the command; the proper bytecode - * length will be updated later. There is no need to - * do this for the first command in the compile env, - * as the check is done before calling - * TclExecuteByteCode(). Remark that we are compiling - * the first cmd in the environment exactly when - * (savedCodeNext == 0) - */ - - if (savedCodeNext != 0) { - TclEmitInstInt4(INST_START_CMD, 0, envPtr); - } - - code = (cmdPtr->compileProc)(interp, &parse, envPtr); - - if (code == TCL_OK) { - if (savedCodeNext != 0) { - /* - * Fix the bytecode length. - */ - unsigned char *fixPtr = envPtr->codeStart - + savedCodeNext + 1; - unsigned int fixLen = envPtr->codeNext - - envPtr->codeStart - savedCodeNext; - - TclStoreInt4AtPtr(fixLen, fixPtr); - } - goto finishCommand; - } else { - /* - * Restore numCommands and codeNext to their - * correct values, removing any commands compiled - * before the failure to produce bytecode got - * reported. [Bugs 705406 and 735055] - */ - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart+savedCodeNext; - } - } + /* + * TIP #280: Free full form of per-word line data and insert the reduced + * form now + */ - /* - * No compile procedure so push the word. If the command - * was found, push a CmdName object to reduce runtime - * lookups. Avoid sharing this literal among different - * namespaces to reduce shimmering. - */ + envPtr->line = cmdLine; + envPtr->clNext = clNext; + ckfree(eclPtr->loc[wlineat].line); + ckfree(eclPtr->loc[wlineat].next); + eclPtr->loc[wlineat].line = wlines; + eclPtr->loc[wlineat].next = NULL; - objIndex = TclRegisterNewNSLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - if (cmdPtr != NULL) { - TclSetCmdNameObj(interp, - envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); - } - if ((wordIdx == 0) && (parse.numWords == 1)) { - /* - * Single word script: unshare the command name to - * avoid shimmering between bytecode and cmdName - * representations [Bug 458361] - */ - - TclHideLiteral(interp, envPtr, objIndex); - } - } else { - objIndex = TclRegisterNewLiteral(envPtr, - tokenPtr[1].start, tokenPtr[1].size); - } - TclEmitPush(objIndex, envPtr); - } + TclCheckStackDepth(depth, envPtr); + return cmdIdx; +} - /* - * Emit an invoke instruction for the command. We skip this if a - * compile procedure was found for the command. - */ +void +TclCompileScript( + Tcl_Interp *interp, /* Used for error and status reporting. Also + * serves as context for finding and compiling + * commands. May not be NULL. */ + const char *script, /* The source script to compile. */ + int numBytes, /* Number of bytes in script. If < 0, the + * script consists of all bytes up to the + * first null character. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + int lastCmdIdx = -1; /* Index into envPtr->cmdMapPtr of the last + * command this routine compiles into bytecode. + * Initial value of -1 indicates this routine + * has not yet generated any bytecode. */ + const char *p = script; /* Where we are in our compile. */ + int depth = TclGetStackDepth(envPtr); + + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclCompileScript() called on uninitialized CompileEnv"); + } - if (expand) { - /* - * The stack depth during argument expansion can only be - * managed at runtime, as the number of elements in the - * expanded lists is not known at compile time. We adjust here - * the stack depth estimate so that it is correct after the - * command with expanded arguments returns. - * - * The end effect of this command's invocation is that all the - * words of the command are popped from the stack, and the - * result is pushed: the stack top changes by (1-wordIdx). - * - * Note that the estimates are not correct while the command - * is being prepared and run, INST_EXPAND_STKTOP is not - * stack-neutral in general. - */ + /* Each iteration compiles one command from the script. */ - TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); - TclAdjustStackDepth((1-wordIdx), envPtr); - } else if (wordIdx > 0) { - if (wordIdx <= 255) { - TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); - } else { - TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); - } - } + while (numBytes > 0) { + Tcl_Parse parse; + const char *next; + if (TCL_OK != Tcl_ParseCommand(interp, p, numBytes, 0, &parse)) { /* - * Update the compilation environment structure and record the - * offsets of the source and code for the command. + * Compile bytecodes to report the parse error at runtime. */ - finishCommand: - EnterCmdExtentData(envPtr, currCmdIndex, commandLength, - (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); - isFirstCmd = 0; - } /* end if parse.numWords > 0 */ + Tcl_LogCommandInfo(interp, script, parse.commandStart, + parse.term + 1 - parse.commandStart); + TclCompileSyntaxError(interp, envPtr); + return; + } + +#ifdef TCL_COMPILE_DEBUG + /* + * If tracing, print a line for each top level command compiled. + * TODO: Suppress when numWords == 0 ? + */ + + if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { + int commandLength = parse.term - parse.commandStart; + fprintf(stdout, " Compiling: "); + TclPrintSource(stdout, parse.commandStart, + TclMin(commandLength, 55)); + fprintf(stdout, "\n"); + } +#endif /* - * Advance to the next command in the script. + * TIP #280: Count newlines before the command start. + * (See test info-30.33). + */ + + TclAdvanceLines(&envPtr->line, p, parse.commandStart); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + parse.commandStart - envPtr->source); + + /* + * Advance parser to the next command in the script. */ next = parse.commandStart + parse.commandSize; - bytesLeft -= (next - p); + numBytes -= next - p; p = next; - Tcl_FreeParse(&parse); - gotParse = 0; - } while (bytesLeft > 0); - /* - * If the source script yielded no instructions (e.g., if it was empty), - * push an empty string as the command's result. - * - * WARNING: push an unshared object! If the script being compiled is a - * shared empty string, it will otherwise be self-referential and cause - * difficulties with literal management [Bugs 467523, 983660]. We used to - * have special code in TclReleaseLiteral to handle this particular - * self-reference, but now opt for avoiding its creation altogether. - */ + if (parse.numWords == 0) { + /* + * The "command" parsed has no words. In this case we can skip + * the rest of the loop body. With no words, clearly + * CompileCommandTokens() has nothing to do. Since the parser + * aggressively sucks up leading comment and white space, + * including newlines, parse.commandStart must be pointing at + * either the end of script, or a command-terminating semi-colon. + * In either case, the TclAdvance*() calls have nothing to do. + * Finally, when no words are parsed, no tokens have been + * allocated at parse.tokenPtr so there's also nothing for + * Tcl_FreeParse() to do. + * + * The advantage of this shortcut is that CompileCommandTokens() + * can be written with an assumption that parse.numWords > 0, with + * the implication the CCT() always generates bytecode. + */ + continue; + } - if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr); + lastCmdIdx = CompileCommandTokens(interp, &parse, envPtr); + + /* + * TIP #280: Track lines in the just compiled command. + */ + + TclAdvanceLines(&envPtr->line, parse.commandStart, p); + TclAdvanceContinuations(&envPtr->line, &envPtr->clNext, + p - envPtr->source); + Tcl_FreeParse(&parse); } - envPtr->numSrcBytes = (p - script); - Tcl_DStringFree(&ds); + if (lastCmdIdx == -1) { + /* + * Compiling the script yielded no bytecode. The script must be all + * whitespace, comments, and empty commands. Such scripts are defined + * to successfully produce the empty string result, so we emit the + * simple bytecode that makes that happen. + */ + + PushStringLiteral(envPtr, ""); + } else { + /* + * We compiled at least one command to bytecode. The routine + * CompileCommandTokens() follows the bytecode of each compiled + * command with an INST_POP, so that stack balance is maintained when + * several commands are in sequence. (The result of each command is + * thrown away before moving on to the next command). For the last + * command compiled, we need to undo that INST_POP so that the result + * of the last command becomes the result of the script. The code + * here removes that trailing INST_POP. + */ + + envPtr->cmdMapPtr[lastCmdIdx].numCodeBytes--; + envPtr->codeNext--; + envPtr->currStackDepth++; + } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -1330,6 +2261,76 @@ TclCompileScript( */ void +TclCompileVarSubst( + Tcl_Interp *interp, + Tcl_Token *tokenPtr, + CompileEnv *envPtr) +{ + const char *p, *name = tokenPtr[1].start; + int nameBytes = tokenPtr[1].size; + int i, localVar, localVarName = 1; + + /* + * Determine how the variable name should be handled: if it contains any + * namespace qualifiers it is not a local variable (localVarName=-1); if + * it looks like an array element and the token has a single component, it + * should not be created here [Bug 569438] (localVarName=0); otherwise, + * the local variable can safely be created (localVarName=1). + */ + + for (i = 0, p = name; i < nameBytes; i++, p++) { + if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { + localVarName = -1; + break; + } else if ((*p == '(') + && (tokenPtr->numComponents == 1) + && (*(name + nameBytes - 1) == ')')) { + localVarName = 0; + break; + } + } + + /* + * Either push the variable's name, or find its index in the array + * of local variables in a procedure frame. + */ + + localVar = -1; + if (localVarName != -1) { + localVar = TclFindCompiledLocal(name, nameBytes, localVarName, envPtr); + } + if (localVar < 0) { + PushLiteral(envPtr, name, nameBytes); + } + + /* + * Emit instructions to load the variable. + */ + + TclAdvanceLines(&envPtr->line, tokenPtr[1].start, + tokenPtr[1].start + tokenPtr[1].size); + + if (tokenPtr->numComponents == 1) { + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); + } + } else { + TclCompileTokens(interp, tokenPtr+2, tokenPtr->numComponents-1, envPtr); + if (localVar < 0) { + TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); + } else if (localVar <= 255) { + TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); + } else { + TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); + } + } +} + +void TclCompileTokens( Tcl_Interp *interp, /* Used for error and status reporting. */ Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to @@ -1341,22 +2342,90 @@ TclCompileTokens( Tcl_DString textBuffer; /* Holds concatenated chars from adjacent * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ char buffer[TCL_UTF_MAX]; - CONST char *name, *p; - int numObjsToConcat, nameBytes, localVarName, localVar; - int length, i; + int i, numObjsToConcat, length, adjust; unsigned char *entryCodeNext = envPtr->codeNext; +#define NUM_STATIC_POS 20 + int isLiteral, maxNumCL, numCL; + int *clPosition = NULL; + int depth = TclGetStackDepth(envPtr); + + /* + * For the handling of continuation lines in literals we first check if + * this is actually a literal. For if not we can forego the additional + * processing. Otherwise we pre-allocate a small table to store the + * locations of all continuation lines we find in this literal, if any. + * The table is extended if needed. + * + * Note: Different to the equivalent code in function 'TclSubstTokens()' + * (see file "tclParse.c") we do not seem to need the 'adjust' variable. + * We also do not seem to need code which merges continuation line + * information of multiple words which concat'd at runtime. Either that or + * I have not managed to find a test case for these two possibilities yet. + * It might be a difference between compile- versus run-time processing. + */ + numCL = 0; + maxNumCL = 0; + isLiteral = 1; + for (i=0 ; i < count; i++) { + if ((tokenPtr[i].type != TCL_TOKEN_TEXT) + && (tokenPtr[i].type != TCL_TOKEN_BS)) { + isLiteral = 0; + break; + } + } + + if (isLiteral) { + maxNumCL = NUM_STATIC_POS; + clPosition = ckalloc(maxNumCL * sizeof(int)); + } + + adjust = 0; Tcl_DStringInit(&textBuffer); numObjsToConcat = 0; for ( ; count > 0; count--, tokenPtr++) { switch (tokenPtr->type) { case TCL_TOKEN_TEXT: - Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); + TclDStringAppendToken(&textBuffer, tokenPtr); + TclAdvanceLines(&envPtr->line, tokenPtr->start, + tokenPtr->start + tokenPtr->size); break; case TCL_TOKEN_BS: - length = Tcl_UtfBackslash(tokenPtr->start, NULL, buffer); + length = TclParseBackslash(tokenPtr->start, tokenPtr->size, + NULL, buffer); Tcl_DStringAppend(&textBuffer, buffer, length); + + /* + * If the backslash sequence we found is in a literal, and + * represented a continuation line, we compute and store its + * location (as char offset to the beginning of the _result_ + * script). We may have to extend the table of locations. + * + * Note that the continuation line information is relevant even if + * the word we are processing is not a literal, as it can affect + * nested commands. See the branch for TCL_TOKEN_COMMAND below, + * where the adjustment we are tracking here is taken into + * account. The good thing is that we do not need a table of + * everything, just the number of lines we have to add as + * correction. + */ + + if ((length == 1) && (buffer[0] == ' ') && + (tokenPtr->start[1] == '\n')) { + if (isLiteral) { + int clPos = Tcl_DStringLength(&textBuffer); + + if (numCL >= maxNumCL) { + maxNumCL *= 2; + clPosition = ckrealloc(clPosition, + maxNumCL * sizeof(int)); + } + clPosition[numCL] = clPos; + numCL ++; + } + adjust++; + } break; case TCL_TOKEN_COMMAND: @@ -1365,18 +2434,23 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; + int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); - literal = TclRegisterNewLiteral(envPtr, - Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); + + if (numCL) { + TclContinuationsEnter(TclFetchLiteral(envPtr, literal), + numCL, clPosition); + } + numCL = 0; } + envPtr->line += adjust; TclCompileScript(interp, tokenPtr->start+1, tokenPtr->size-2, envPtr); + envPtr->line -= adjust; numObjsToConcat++; break; @@ -1388,86 +2462,21 @@ TclCompileTokens( if (Tcl_DStringLength(&textBuffer) > 0) { int literal; - literal = TclRegisterNewLiteral(envPtr, - Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); + literal = TclRegisterDStringLiteral(envPtr, &textBuffer); TclEmitPush(literal, envPtr); numObjsToConcat++; Tcl_DStringFree(&textBuffer); } - /* - * Determine how the variable name should be handled: if it - * contains any namespace qualifiers it is not a local variable - * (localVarName=-1); if it looks like an array element and the - * token has a single component, it should not be created here - * [Bug 569438] (localVarName=0); otherwise, the local variable - * can safely be created (localVarName=1). - */ - - name = tokenPtr[1].start; - nameBytes = tokenPtr[1].size; - localVarName = -1; - if (envPtr->procPtr != NULL) { - localVarName = 1; - for (i = 0, p = name; i < nameBytes; i++, p++) { - if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { - localVarName = -1; - break; - } else if ((*p == '(') - && (tokenPtr->numComponents == 1) - && (*(name + nameBytes - 1) == ')')) { - localVarName = 0; - break; - } - } - } - - /* - * Either push the variable's name, or find its index in the array - * of local variables in a procedure frame. - */ - - localVar = -1; - if (localVarName != -1) { - localVar = TclFindCompiledLocal(name, nameBytes, localVarName, - /*flags*/ 0, envPtr->procPtr); - } - if (localVar < 0) { - TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), - envPtr); - } - - /* - * Emit instructions to load the variable. - */ - - if (tokenPtr->numComponents == 1) { - if (localVar < 0) { - TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); - } - } else { - TclCompileTokens(interp, tokenPtr+2, - tokenPtr->numComponents-1, envPtr); - if (localVar < 0) { - TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); - } else if (localVar <= 255) { - TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); - } else { - TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); - } - } + TclCompileVarSubst(interp, tokenPtr, envPtr); numObjsToConcat++; count -= tokenPtr->numComponents; tokenPtr += tokenPtr->numComponents; break; default: - Tcl_Panic("Unexpected token type in TclCompileTokens"); + Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s", + tokenPtr->type, tokenPtr->size, tokenPtr->start); } } @@ -1476,12 +2485,15 @@ TclCompileTokens( */ if (Tcl_DStringLength(&textBuffer) > 0) { - int literal; + int literal = TclRegisterDStringLiteral(envPtr, &textBuffer); - literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), - Tcl_DStringLength(&textBuffer)); TclEmitPush(literal, envPtr); numObjsToConcat++; + if (numCL) { + TclContinuationsEnter(TclFetchLiteral(envPtr, literal), + numCL, clPosition); + } + numCL = 0; } /* @@ -1489,11 +2501,11 @@ TclCompileTokens( */ while (numObjsToConcat > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ } if (numObjsToConcat > 1) { - TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, numObjsToConcat, envPtr); } /* @@ -1501,9 +2513,19 @@ TclCompileTokens( */ if (envPtr->codeNext == entryCodeNext) { - TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); + PushStringLiteral(envPtr, ""); } Tcl_DStringFree(&textBuffer); + + /* + * Release the temp table we used to collect the locations of continuation + * lines, if any. + */ + + if (maxNumCL) { + ckfree(clPosition); + } + TclCheckStackDepth(depth+1, envPtr); } /* @@ -1551,7 +2573,7 @@ TclCompileCmdWord( */ TclCompileTokens(interp, tokenPtr, count, envPtr); - TclEmitOpcode(INST_EVAL_STK, envPtr); + TclEmitInvoke(envPtr, INST_EVAL_STK); } } @@ -1596,16 +2618,8 @@ TclCompileExprWords( */ if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { - CONST char *script = tokenPtr[1].start; - int numBytes = tokenPtr[1].size; - int savedNumCmds = envPtr->numCommands; - unsigned int savedCodeNext = envPtr->codeNext - envPtr->codeStart; - - if (TclCompileExpr(interp, script, numBytes, envPtr) == TCL_OK) { - return; - } - envPtr->numCommands = savedNumCmds; - envPtr->codeNext = envPtr->codeStart + savedCodeNext; + TclCompileExpr(interp, tokenPtr[1].start,tokenPtr[1].size, envPtr, 1); + return; } /* @@ -1615,19 +2629,19 @@ TclCompileExprWords( wordPtr = tokenPtr; for (i = 0; i < numWords; i++) { - TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); + CompileTokens(envPtr, wordPtr, interp); if (i < (numWords - 1)) { - TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); + PushStringLiteral(envPtr, " "); } - wordPtr += (wordPtr->numComponents + 1); + wordPtr += wordPtr->numComponents + 1; } concatItems = 2*numWords - 1; while (concatItems > 255) { - TclEmitInstInt1(INST_CONCAT1, 255, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, 255, envPtr); concatItems -= 254; } if (concatItems > 1) { - TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); + TclEmitInstInt1(INST_STR_CONCAT1, concatItems, envPtr); } TclEmitOpcode(INST_EXPR_STK, envPtr); } @@ -1635,6 +2649,49 @@ TclCompileExprWords( /* *---------------------------------------------------------------------- * + * TclCompileNoOp -- + * + * Function called to compile no-op's + * + * Results: + * The return value is TCL_OK, indicating successful compilation. + * + * Side effects: + * Instructions are added to envPtr to execute a no-op at runtime. No + * result is pushed onto the stack: the compiler has to take care of this + * itself if the last compiled command is a NoOp. + * + *---------------------------------------------------------------------- + */ + +int +TclCompileNoOp( + Tcl_Interp *interp, /* Used for error reporting. */ + Tcl_Parse *parsePtr, /* Points to a parse structure for the command + * created by Tcl_ParseCommand. */ + Command *cmdPtr, /* Points to defintion of command being + * compiled. */ + CompileEnv *envPtr) /* Holds resulting instructions. */ +{ + Tcl_Token *tokenPtr; + int i; + + tokenPtr = parsePtr->tokenPtr; + for (i = 1; i < parsePtr->numWords; i++) { + tokenPtr = tokenPtr + tokenPtr->numComponents + 1; + + if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { + CompileTokens(envPtr, tokenPtr, interp); + TclEmitOpcode(INST_POP, envPtr); + } + } + PushStringLiteral(envPtr, ""); + return TCL_OK; +} + +/* + *---------------------------------------------------------------------- + * * TclInitByteCodeObj -- * * Create a ByteCode structure and initialize it from a CompileEnv @@ -1674,15 +2731,19 @@ TclInitByteCodeObj( #endif int numLitObjects = envPtr->literalArrayNext; Namespace *namespacePtr; - int i; + int i, isNew; Interp *iPtr; + if (envPtr->iPtr == NULL) { + Tcl_Panic("TclInitByteCodeObj() called on uninitialized CompileEnv"); + } + iPtr = envPtr->iPtr; - codeBytes = (envPtr->codeNext - envPtr->codeStart); - objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); - exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); - auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); + codeBytes = envPtr->codeNext - envPtr->codeStart; + objArrayBytes = envPtr->literalArrayNext * sizeof(Tcl_Obj *); + exceptArrayBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); + auxDataArrayBytes = envPtr->auxDataArrayNext * sizeof(AuxData); cmdLocBytes = GetCmdLocEncodingSize(envPtr); /* @@ -1702,7 +2763,7 @@ TclInitByteCodeObj( namespacePtr = envPtr->iPtr->globalNsPtr; } - p = (unsigned char *) ckalloc((size_t) structureSize); + p = ckalloc(structureSize); codePtr = (ByteCode *) p; codePtr->interpHandle = TclHandlePreserve(iPtr->handle); codePtr->compileEpoch = iPtr->compileEpoch; @@ -1729,19 +2790,40 @@ TclInitByteCodeObj( p += sizeof(ByteCode); codePtr->codeStart = p; - memcpy((void *) p, (void *) envPtr->codeStart, (size_t) codeBytes); + memcpy(p, envPtr->codeStart, (size_t) codeBytes); p += TCL_ALIGN(codeBytes); /* align object array */ codePtr->objArrayPtr = (Tcl_Obj **) p; for (i = 0; i < numLitObjects; i++) { - codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; + Tcl_Obj *fetched = TclFetchLiteral(envPtr, i); + + if (objPtr == fetched) { + /* + * Prevent circular reference where the bytecode intrep of + * a value contains a literal which is that same value. + * If this is allowed to happen, refcount decrements may not + * reach zero, and memory may leak. Bugs 467523, 3357771 + * + * NOTE: [Bugs 3392070, 3389764] We make a copy based completely + * on the string value, and do not call Tcl_DuplicateObj() so we + * can be sure we do not have any lingering cycles hiding in + * the intrep. + */ + int numBytes; + const char *bytes = Tcl_GetStringFromObj(objPtr, &numBytes); + + codePtr->objArrayPtr[i] = Tcl_NewStringObj(bytes, numBytes); + Tcl_IncrRefCount(codePtr->objArrayPtr[i]); + TclReleaseLiteral((Tcl_Interp *)iPtr, objPtr); + } else { + codePtr->objArrayPtr[i] = fetched; + } } p += TCL_ALIGN(objArrayBytes); /* align exception range array */ if (exceptArrayBytes > 0) { codePtr->exceptArrayPtr = (ExceptionRange *) p; - memcpy((void *) p, (void *) envPtr->exceptArrayPtr, - (size_t) exceptArrayBytes); + memcpy(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); } else { codePtr->exceptArrayPtr = NULL; } @@ -1749,8 +2831,7 @@ TclInitByteCodeObj( p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ if (auxDataArrayBytes > 0) { codePtr->auxDataArrayPtr = (AuxData *) p; - memcpy((void *) p, (void *) envPtr->auxDataArrayPtr, - (size_t) auxDataArrayBytes); + memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); } else { codePtr->auxDataArrayPtr = NULL; } @@ -1761,7 +2842,7 @@ TclInitByteCodeObj( #else nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); if (((size_t)(nextPtr - p)) != cmdLocBytes) { - Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes); + Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %lu != expected size %lu", (unsigned long)(nextPtr - p), (unsigned long)cmdLocBytes); } #endif @@ -1773,7 +2854,7 @@ TclInitByteCodeObj( #ifdef TCL_COMPILE_STATS codePtr->structureSize = structureSize - (sizeof(size_t) + sizeof(Tcl_Time)); - Tcl_GetTime(&(codePtr->createTime)); + Tcl_GetTime(&codePtr->createTime); RecordByteCodeStats(codePtr); #endif /* TCL_COMPILE_STATS */ @@ -1784,8 +2865,22 @@ TclInitByteCodeObj( */ TclFreeIntRep(objPtr); - objPtr->internalRep.otherValuePtr = (void *) codePtr; + objPtr->internalRep.twoPtrValue.ptr1 = codePtr; objPtr->typePtr = &tclByteCodeType; + + /* + * TIP #280. Associate the extended per-word line information with the + * byte code object (internal rep), for use with the bc compiler. + */ + + Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, codePtr, + &isNew), envPtr->extCmdMapPtr); + envPtr->extCmdMapPtr = NULL; + + /* We've used up the CompileEnv. Mark as uninitialized. */ + envPtr->iPtr = NULL; + + codePtr->localCachePtr = NULL; } /* @@ -1815,33 +2910,61 @@ TclInitByteCodeObj( int TclFindCompiledLocal( - register CONST char *name, /* Points to first character of the name of a + register const char *name, /* Points to first character of the name of a * scalar or array variable. If NULL, a * temporary var should be created. */ int nameBytes, /* Number of bytes in the name. */ int create, /* If 1, allocate a local frame entry for the * variable if it is new. */ - int flags, /* Flag bits for the compiled local if - * created. Only VAR_SCALAR, VAR_ARRAY, and - * VAR_LINK make sense. */ - register Proc *procPtr) /* Points to structure describing procedure - * containing the variable reference. */ + CompileEnv *envPtr) /* Points to the current compile environment*/ { register CompiledLocal *localPtr; int localVar = -1; register int i; + Proc *procPtr; /* * If not creating a temporary, does a local variable of the specified * name already exist? */ + procPtr = envPtr->procPtr; + + if (procPtr == NULL) { + /* + * Compiling a non-body script: give it read access to the LVT in the + * current localCache + */ + + LocalCache *cachePtr = envPtr->iPtr->varFramePtr->localCachePtr; + const char *localName; + Tcl_Obj **varNamePtr; + int len; + + if (!cachePtr || !name) { + return -1; + } + + varNamePtr = &cachePtr->varName0; + for (i=0; i < cachePtr->numVars; varNamePtr++, i++) { + if (*varNamePtr) { + localName = Tcl_GetStringFromObj(*varNamePtr, &len); + if ((len == nameBytes) && !strncmp(name, localName, len)) { + return i; + } + } + } + return -1; + } + if (name != NULL) { int localCt = procPtr->numCompiledLocals; + localPtr = procPtr->firstLocalPtr; for (i = 0; i < localCt; i++) { if (!TclIsVarTemporary(localPtr)) { char *localName = localPtr->name; + if ((nameBytes == localPtr->nameLength) && (strncmp(name,localName,(unsigned)nameBytes) == 0)) { return i; @@ -1857,9 +2980,7 @@ TclFindCompiledLocal( if (create || (name == NULL)) { localVar = procPtr->numCompiledLocals; - localPtr = (CompiledLocal *) ckalloc((unsigned) - (sizeof(CompiledLocal) - sizeof(localPtr->name) - + nameBytes + 1)); + localPtr = ckalloc(TclOffset(CompiledLocal, name) + nameBytes + 1); if (procPtr->firstLocalPtr == NULL) { procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; } else { @@ -1869,7 +2990,7 @@ TclFindCompiledLocal( localPtr->nextPtr = NULL; localPtr->nameLength = nameBytes; localPtr->frameIndex = localVar; - localPtr->flags = flags | VAR_UNDEFINED; + localPtr->flags = 0; if (name == NULL) { localPtr->flags |= VAR_TEMPORARY; } @@ -1877,14 +2998,14 @@ TclFindCompiledLocal( localPtr->resolveInfo = NULL; if (name != NULL) { - memcpy((void *) localPtr->name, (void *) name, (size_t) nameBytes); + memcpy(localPtr->name, name, (size_t) nameBytes); } localPtr->name[nameBytes] = '\0'; procPtr->numCompiledLocals++; } return localVar; - } + /* *---------------------------------------------------------------------- * @@ -1909,7 +3030,7 @@ TclExpandCodeArray( void *envArgPtr) /* Points to the CompileEnv whose code array * must be enlarged. */ { - CompileEnv *envPtr = (CompileEnv*) envArgPtr; + CompileEnv *envPtr = envArgPtr; /* The CompileEnv containing the code array to * be doubled in size. */ @@ -1919,23 +3040,26 @@ TclExpandCodeArray( * [inclusive]. */ - size_t currBytes = (envPtr->codeNext - envPtr->codeStart); - size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); - unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); + size_t currBytes = envPtr->codeNext - envPtr->codeStart; + size_t newBytes = 2 * (envPtr->codeEnd - envPtr->codeStart); - /* - * Copy from old code array to new, free old code array if needed, and - * mark new code array as malloced. - */ - - memcpy((void *) newPtr, (void *) envPtr->codeStart, currBytes); if (envPtr->mallocedCodeArray) { - ckfree((char *) envPtr->codeStart); + envPtr->codeStart = ckrealloc(envPtr->codeStart, newBytes); + } else { + /* + * envPtr->codeStart isn't a ckalloc'd pointer, so we must code a + * ckrealloc equivalent for ourselves. + */ + + unsigned char *newPtr = ckalloc(newBytes); + + memcpy(newPtr, envPtr->codeStart, currBytes); + envPtr->codeStart = newPtr; + envPtr->mallocedCodeArray = 1; } - envPtr->codeStart = newPtr; - envPtr->codeNext = (newPtr + currBytes); - envPtr->codeEnd = (newPtr + newBytes); - envPtr->mallocedCodeArray = 1; + + envPtr->codeNext = envPtr->codeStart + currBytes; + envPtr->codeEnd = envPtr->codeStart + newBytes; } /* @@ -1971,7 +3095,7 @@ EnterCmdStartData( CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - Tcl_Panic("EnterCmdStartData: bad command index %d\n", cmdIndex); + Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex); } if (cmdIndex >= envPtr->cmdMapEnd) { @@ -1982,23 +3106,25 @@ EnterCmdStartData( */ size_t currElems = envPtr->cmdMapEnd; - size_t newElems = 2*currElems; + size_t newElems = 2 * currElems; size_t currBytes = currElems * sizeof(CmdLocation); size_t newBytes = newElems * sizeof(CmdLocation); - CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); - - /* - * Copy from old command location array to new, free old command - * location array if needed, and mark new array as malloced. - */ - memcpy((void *) newPtr, (void *) envPtr->cmdMapPtr, currBytes); if (envPtr->mallocedCmdMap) { - ckfree((char *) envPtr->cmdMapPtr); + envPtr->cmdMapPtr = ckrealloc(envPtr->cmdMapPtr, newBytes); + } else { + /* + * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must code a + * ckrealloc equivalent for ourselves. + */ + + CmdLocation *newPtr = ckalloc(newBytes); + + memcpy(newPtr, envPtr->cmdMapPtr, currBytes); + envPtr->cmdMapPtr = newPtr; + envPtr->mallocedCmdMap = 1; } - envPtr->cmdMapPtr = (CmdLocation *) newPtr; envPtr->cmdMapEnd = newElems; - envPtr->mallocedCmdMap = 1; } if (cmdIndex > 0) { @@ -2007,7 +3133,7 @@ EnterCmdStartData( } } - cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex]; cmdLocPtr->codeOffset = codeOffset; cmdLocPtr->srcOffset = srcOffset; cmdLocPtr->numSrcBytes = -1; @@ -2048,21 +3174,101 @@ EnterCmdExtentData( CmdLocation *cmdLocPtr; if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { - Tcl_Panic("EnterCmdExtentData: bad command index %d\n", cmdIndex); + Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex); } if (cmdIndex > envPtr->cmdMapEnd) { - Tcl_Panic("EnterCmdExtentData: missing start data for command %d\n", + Tcl_Panic("EnterCmdExtentData: missing start data for command %d", cmdIndex); } - cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); + cmdLocPtr = &envPtr->cmdMapPtr[cmdIndex]; cmdLocPtr->numSrcBytes = numSrcBytes; cmdLocPtr->numCodeBytes = numCodeBytes; } /* *---------------------------------------------------------------------- + * TIP #280 + * + * EnterCmdWordData -- + * + * Registers the lines for the words of a command. This information is + * used at runtime by 'info frame'. + * + * Results: + * None. + * + * Side effects: + * Inserts word location information into the compilation environment + * envPtr for the command at index cmdIndex. The compilation + * environment's ExtCmdLoc.ECL array is grown if necessary. + * + *---------------------------------------------------------------------- + */ + +static void +EnterCmdWordData( + ExtCmdLoc *eclPtr, /* Points to the map environment structure in + * which to enter command location + * information. */ + int srcOffset, /* Offset of first char of the command. */ + Tcl_Token *tokenPtr, + const char *cmd, + int len, + int numWords, + int line, + int *clNext, + int **wlines, + CompileEnv *envPtr) +{ + ECL *ePtr; + const char *last; + int wordIdx, wordLine, *wwlines, *wordNext; + + if (eclPtr->nuloc >= eclPtr->nloc) { + /* + * Expand the ECL array by allocating more storage from the heap. The + * currently allocated ECL entries are stored from eclPtr->loc[0] up + * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). + */ + + size_t currElems = eclPtr->nloc; + size_t newElems = (currElems ? 2*currElems : 1); + size_t newBytes = newElems * sizeof(ECL); + + eclPtr->loc = ckrealloc(eclPtr->loc, newBytes); + eclPtr->nloc = newElems; + } + + ePtr = &eclPtr->loc[eclPtr->nuloc]; + ePtr->srcOffset = srcOffset; + ePtr->line = ckalloc(numWords * sizeof(int)); + ePtr->next = ckalloc(numWords * sizeof(int *)); + ePtr->nline = numWords; + wwlines = ckalloc(numWords * sizeof(int)); + + last = cmd; + wordLine = line; + wordNext = clNext; + for (wordIdx=0 ; wordIdx<numWords; + wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { + TclAdvanceLines(&wordLine, last, tokenPtr->start); + TclAdvanceContinuations(&wordLine, &wordNext, + tokenPtr->start - envPtr->source); + wwlines[wordIdx] = + (TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1); + ePtr->line[wordIdx] = wordLine; + ePtr->next[wordIdx] = wordNext; + last = tokenPtr->start; + } + + *wlines = wwlines; + eclPtr->nuloc ++; +} + +/* + *---------------------------------------------------------------------- * * TclCreateExceptRange -- * @@ -2088,6 +3294,7 @@ TclCreateExceptRange( * new ExceptionRange structure. */ { register ExceptionRange *rangePtr; + register ExceptionAux *auxPtr; int index = envPtr->exceptArrayNext; if (index >= envPtr->exceptArrayEnd) { @@ -2099,27 +3306,36 @@ TclCreateExceptRange( size_t currBytes = envPtr->exceptArrayNext * sizeof(ExceptionRange); + size_t currBytes2 = envPtr->exceptArrayNext * sizeof(ExceptionAux); int newElems = 2*envPtr->exceptArrayEnd; size_t newBytes = newElems * sizeof(ExceptionRange); - ExceptionRange *newPtr = (ExceptionRange *) - ckalloc((unsigned) newBytes); - - /* - * Copy from old ExceptionRange array to new, free old ExceptionRange - * array if needed, and mark the new ExceptionRange array as malloced. - */ + size_t newBytes2 = newElems * sizeof(ExceptionAux); - memcpy((void *) newPtr, (void *) envPtr->exceptArrayPtr, currBytes); if (envPtr->mallocedExceptArray) { - ckfree((char *) envPtr->exceptArrayPtr); + envPtr->exceptArrayPtr = + ckrealloc(envPtr->exceptArrayPtr, newBytes); + envPtr->exceptAuxArrayPtr = + ckrealloc(envPtr->exceptAuxArrayPtr, newBytes2); + } else { + /* + * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. + */ + + ExceptionRange *newPtr = ckalloc(newBytes); + ExceptionAux *newPtr2 = ckalloc(newBytes2); + + memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); + memcpy(newPtr2, envPtr->exceptAuxArrayPtr, currBytes2); + envPtr->exceptArrayPtr = newPtr; + envPtr->exceptAuxArrayPtr = newPtr2; + envPtr->mallocedExceptArray = 1; } - envPtr->exceptArrayPtr = (ExceptionRange *) newPtr; envPtr->exceptArrayEnd = newElems; - envPtr->mallocedExceptArray = 1; } envPtr->exceptArrayNext++; - rangePtr = &(envPtr->exceptArrayPtr[index]); + rangePtr = &envPtr->exceptArrayPtr[index]; rangePtr->type = type; rangePtr->nestingLevel = envPtr->exceptDepth; rangePtr->codeOffset = -1; @@ -2127,10 +3343,294 @@ TclCreateExceptRange( rangePtr->breakOffset = -1; rangePtr->continueOffset = -1; rangePtr->catchOffset = -1; + auxPtr = &envPtr->exceptAuxArrayPtr[index]; + auxPtr->supportsContinue = 1; + auxPtr->stackDepth = envPtr->currStackDepth; + auxPtr->expandTarget = envPtr->expandCount; + auxPtr->expandTargetDepth = -1; + auxPtr->numBreakTargets = 0; + auxPtr->breakTargets = NULL; + auxPtr->allocBreakTargets = 0; + auxPtr->numContinueTargets = 0; + auxPtr->continueTargets = NULL; + auxPtr->allocContinueTargets = 0; return index; } /* + * --------------------------------------------------------------------- + * + * TclGetInnermostExceptionRange -- + * + * Returns the innermost exception range that covers the current code + * creation point, and (optionally) the stack depth that is expected at + * that point. Relies on the fact that the range has a numCodeBytes = -1 + * when it is being populated and that inner ranges come after outer + * ranges. + * + * --------------------------------------------------------------------- + */ + +ExceptionRange * +TclGetInnermostExceptionRange( + CompileEnv *envPtr, + int returnCode, + ExceptionAux **auxPtrPtr) +{ + int exnIdx = -1, i; + + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + + if (CurrentOffset(envPtr) >= rangePtr->codeOffset && + (rangePtr->numCodeBytes == -1 || CurrentOffset(envPtr) < + rangePtr->codeOffset+rangePtr->numCodeBytes) && + (returnCode != TCL_CONTINUE || + envPtr->exceptAuxArrayPtr[i].supportsContinue)) { + exnIdx = i; + } + } + if (exnIdx == -1) { + return NULL; + } + if (auxPtrPtr) { + *auxPtrPtr = &envPtr->exceptAuxArrayPtr[exnIdx]; + } + return &envPtr->exceptArrayPtr[exnIdx]; +} + +/* + * --------------------------------------------------------------------- + * + * TclAddLoopBreakFixup, TclAddLoopContinueFixup -- + * + * Adds a place that wants to break/continue to the loop exception range + * tracking that will be fixed up once the loop can be finalized. These + * functions will generate an INST_JUMP4 that will be fixed up during the + * loop finalization. + * + * --------------------------------------------------------------------- + */ + +void +TclAddLoopBreakFixup( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int range = auxPtr - envPtr->exceptAuxArrayPtr; + + if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to add 'break' fixup to full exception range"); + } + + if (++auxPtr->numBreakTargets > auxPtr->allocBreakTargets) { + auxPtr->allocBreakTargets *= 2; + auxPtr->allocBreakTargets += 2; + if (auxPtr->breakTargets) { + auxPtr->breakTargets = ckrealloc(auxPtr->breakTargets, + sizeof(int) * auxPtr->allocBreakTargets); + } else { + auxPtr->breakTargets = + ckalloc(sizeof(int) * auxPtr->allocBreakTargets); + } + } + auxPtr->breakTargets[auxPtr->numBreakTargets - 1] = CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); +} + +void +TclAddLoopContinueFixup( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int range = auxPtr - envPtr->exceptAuxArrayPtr; + + if (envPtr->exceptArrayPtr[range].type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to add 'continue' fixup to full exception range"); + } + + if (++auxPtr->numContinueTargets > auxPtr->allocContinueTargets) { + auxPtr->allocContinueTargets *= 2; + auxPtr->allocContinueTargets += 2; + if (auxPtr->continueTargets) { + auxPtr->continueTargets = ckrealloc(auxPtr->continueTargets, + sizeof(int) * auxPtr->allocContinueTargets); + } else { + auxPtr->continueTargets = + ckalloc(sizeof(int) * auxPtr->allocContinueTargets); + } + } + auxPtr->continueTargets[auxPtr->numContinueTargets - 1] = + CurrentOffset(envPtr); + TclEmitInstInt4(INST_JUMP4, 0, envPtr); +} + +/* + * --------------------------------------------------------------------- + * + * TclCleanupStackForBreakContinue -- + * + * Ditch the extra elements from the auxiliary stack and the main stack. + * How to do this exactly depends on whether there are any elements on + * the auxiliary stack to pop. + * + * --------------------------------------------------------------------- + */ + +void +TclCleanupStackForBreakContinue( + CompileEnv *envPtr, + ExceptionAux *auxPtr) +{ + int savedStackDepth = envPtr->currStackDepth; + int toPop = envPtr->expandCount - auxPtr->expandTarget; + + if (toPop > 0) { + while (toPop --> 0) { + TclEmitOpcode(INST_EXPAND_DROP, envPtr); + } + TclAdjustStackDepth(auxPtr->expandTargetDepth - envPtr->currStackDepth, + envPtr); + envPtr->currStackDepth = auxPtr->expandTargetDepth; + } + toPop = envPtr->currStackDepth - auxPtr->stackDepth; + while (toPop --> 0) { + TclEmitOpcode(INST_POP, envPtr); + } + envPtr->currStackDepth = savedStackDepth; +} + +/* + * --------------------------------------------------------------------- + * + * StartExpanding -- + * + * Pushes an INST_EXPAND_START and does some additional housekeeping so + * that the [break] and [continue] compilers can use an exception-free + * issue to discard it. + * + * --------------------------------------------------------------------- + */ + +static void +StartExpanding( + CompileEnv *envPtr) +{ + int i; + + TclEmitOpcode(INST_EXPAND_START, envPtr); + + /* + * Update inner exception ranges with information about the environment + * where this expansion started. + */ + + for (i=0 ; i<envPtr->exceptArrayNext ; i++) { + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[i]; + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[i]; + + /* + * Ignore loops unless they're still being built. + */ + + if (rangePtr->codeOffset > CurrentOffset(envPtr)) { + continue; + } + if (rangePtr->numCodeBytes != -1) { + continue; + } + + /* + * Adequate condition: further out loops and further in exceptions + * don't actually need this information. + */ + + if (auxPtr->expandTarget == envPtr->expandCount) { + auxPtr->expandTargetDepth = envPtr->currStackDepth; + } + } + + /* + * There's now one more expansion being processed on the auxiliary stack. + */ + + envPtr->expandCount++; +} + +/* + * --------------------------------------------------------------------- + * + * TclFinalizeLoopExceptionRange -- + * + * Finalizes a loop exception range, binding the registered [break] and + * [continue] implementations so that they jump to the correct place. + * Note that this must only be called after *all* the exception range + * target offsets have been set. + * + * --------------------------------------------------------------------- + */ + +void +TclFinalizeLoopExceptionRange( + CompileEnv *envPtr, + int range) +{ + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[range]; + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[range]; + int i, offset; + unsigned char *site; + + if (rangePtr->type != LOOP_EXCEPTION_RANGE) { + Tcl_Panic("trying to finalize a loop exception range"); + } + + /* + * Do the jump fixups. Note that these are always issued as INST_JUMP4 so + * there is no need to fuss around with updating code offsets. + */ + + for (i=0 ; i<auxPtr->numBreakTargets ; i++) { + site = envPtr->codeStart + auxPtr->breakTargets[i]; + offset = rangePtr->breakOffset - auxPtr->breakTargets[i]; + TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + } + for (i=0 ; i<auxPtr->numContinueTargets ; i++) { + site = envPtr->codeStart + auxPtr->continueTargets[i]; + if (rangePtr->continueOffset == -1) { + int j; + + /* + * WTF? Can't bind, so revert to an INST_CONTINUE. Not enough + * space to do anything else. + */ + + *site = INST_CONTINUE; + for (j=0 ; j<4 ; j++) { + *++site = INST_NOP; + } + } else { + offset = rangePtr->continueOffset - auxPtr->continueTargets[i]; + TclUpdateInstInt4AtPc(INST_JUMP4, offset, site); + } + } + + /* + * Drop the arrays we were holding the only reference to. + */ + + if (auxPtr->breakTargets) { + ckfree(auxPtr->breakTargets); + auxPtr->breakTargets = NULL; + auxPtr->numBreakTargets = 0; + } + if (auxPtr->continueTargets) { + ckfree(auxPtr->continueTargets); + auxPtr->continueTargets = NULL; + auxPtr->numContinueTargets = 0; + } +} + +/* *---------------------------------------------------------------------- * * TclCreateAuxData -- @@ -2157,14 +3657,14 @@ int TclCreateAuxData( ClientData clientData, /* The compilation auxiliary data to store in * the new aux data record. */ - AuxDataType *typePtr, /* Pointer to the type to attach to this + const AuxDataType *typePtr, /* Pointer to the type to attach to this * AuxData */ register CompileEnv *envPtr)/* Points to the CompileEnv for which a new * aux data structure is to be allocated. */ { int index; /* Index for the new AuxData structure. */ register AuxData *auxDataPtr; - /* Points to the new AuxData structure */ + /* Points to the new AuxData structure */ index = envPtr->auxDataArrayNext; if (index >= envPtr->auxDataArrayEnd) { @@ -2177,24 +3677,27 @@ TclCreateAuxData( size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); int newElems = 2*envPtr->auxDataArrayEnd; size_t newBytes = newElems * sizeof(AuxData); - AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); - /* - * Copy from old AuxData array to new, free old AuxData array if - * needed, and mark the new AuxData array as malloced. - */ - - memcpy((void *) newPtr, (void *) envPtr->auxDataArrayPtr, currBytes); if (envPtr->mallocedAuxDataArray) { - ckfree((char *) envPtr->auxDataArrayPtr); + envPtr->auxDataArrayPtr = + ckrealloc(envPtr->auxDataArrayPtr, newBytes); + } else { + /* + * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must + * code a ckrealloc equivalent for ourselves. + */ + + AuxData *newPtr = ckalloc(newBytes); + + memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); + envPtr->auxDataArrayPtr = newPtr; + envPtr->mallocedAuxDataArray = 1; } - envPtr->auxDataArrayPtr = newPtr; envPtr->auxDataArrayEnd = newElems; - envPtr->mallocedAuxDataArray = 1; } envPtr->auxDataArrayNext++; - auxDataPtr = &(envPtr->auxDataArrayPtr[index]); + auxDataPtr = &envPtr->auxDataArrayPtr[index]; auxDataPtr->clientData = clientData; auxDataPtr->type = typePtr; return index; @@ -2225,7 +3728,7 @@ TclInitJumpFixupArray( { fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; fixupArrayPtr->next = 0; - fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); + fixupArrayPtr->end = JUMPFIXUP_INIT_ENTRIES - 1; fixupArrayPtr->mallocedArray = 0; } @@ -2252,8 +3755,8 @@ TclInitJumpFixupArray( void TclExpandJumpFixupArray( register JumpFixupArray *fixupArrayPtr) - /* Points to the JumpFixupArray structure - * to enlarge. */ + /* Points to the JumpFixupArray structure to + * enlarge. */ { /* * The currently allocated jump fixup entries are stored from fixup[0] up @@ -2264,20 +3767,22 @@ TclExpandJumpFixupArray( size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); int newElems = 2*(fixupArrayPtr->end + 1); size_t newBytes = newElems * sizeof(JumpFixup); - JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); - - /* - * Copy from the old array to new, free the old array if needed, and mark - * the new array as malloced. - */ - memcpy((void *) newPtr, (void *) fixupArrayPtr->fixup, currBytes); if (fixupArrayPtr->mallocedArray) { - ckfree((char *) fixupArrayPtr->fixup); + fixupArrayPtr->fixup = ckrealloc(fixupArrayPtr->fixup, newBytes); + } else { + /* + * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must code a + * ckrealloc equivalent for ourselves. + */ + + JumpFixup *newPtr = ckalloc(newBytes); + + memcpy(newPtr, fixupArrayPtr->fixup, currBytes); + fixupArrayPtr->fixup = newPtr; + fixupArrayPtr->mallocedArray = 1; } - fixupArrayPtr->fixup = (JumpFixup *) newPtr; fixupArrayPtr->end = newElems; - fixupArrayPtr->mallocedArray = 1; } /* @@ -2303,7 +3808,7 @@ TclFreeJumpFixupArray( * free. */ { if (fixupArrayPtr->mallocedArray) { - ckfree((char *) fixupArrayPtr->fixup); + ckfree(fixupArrayPtr->fixup); } } @@ -2348,7 +3853,7 @@ TclEmitForwardJump( */ jumpFixupPtr->jumpType = jumpType; - jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); + jumpFixupPtr->codeOffset = envPtr->codeNext - envPtr->codeStart; jumpFixupPtr->cmdIndex = envPtr->numCommands; jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; @@ -2403,10 +3908,10 @@ TclFixupForwardJump( { unsigned char *jumpPc, *p; int firstCmd, lastCmd, firstRange, lastRange, k; - unsigned int numBytes; + unsigned numBytes; if (jumpDist <= distThreshold) { - jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); + jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; switch (jumpFixupPtr->jumpType) { case TCL_UNCONDITIONAL_JUMP: TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); @@ -2431,11 +3936,11 @@ TclFixupForwardJump( if ((envPtr->codeNext + 3) > envPtr->codeEnd) { TclExpandCodeArray(envPtr); } - jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); - for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1; - numBytes > 0; numBytes--, p--) { - p[3] = p[0]; - } + jumpPc = envPtr->codeStart + jumpFixupPtr->codeOffset; + numBytes = envPtr->codeNext-jumpPc-2; + p = jumpPc+2; + memmove(p+3, p, numBytes); + envPtr->codeNext += 3; jumpDist += 3; switch (jumpFixupPtr->jumpType) { @@ -2456,19 +3961,19 @@ TclFixupForwardJump( */ firstCmd = jumpFixupPtr->cmdIndex; - lastCmd = (envPtr->numCommands - 1); + lastCmd = envPtr->numCommands - 1; if (firstCmd < lastCmd) { for (k = firstCmd; k <= lastCmd; k++) { - (envPtr->cmdMapPtr[k]).codeOffset += 3; + envPtr->cmdMapPtr[k].codeOffset += 3; } } firstRange = jumpFixupPtr->exceptIndex; - lastRange = (envPtr->exceptArrayNext - 1); + lastRange = envPtr->exceptArrayNext - 1; for (k = firstRange; k <= lastRange; k++) { - ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); - rangePtr->codeOffset += 3; + ExceptionRange *rangePtr = &envPtr->exceptArrayPtr[k]; + rangePtr->codeOffset += 3; switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: rangePtr->breakOffset += 3; @@ -2480,16 +3985,225 @@ TclFixupForwardJump( rangePtr->catchOffset += 3; break; default: - Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d\n", + Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d", rangePtr->type); } } + + for (k = 0 ; k < envPtr->exceptArrayNext ; k++) { + ExceptionAux *auxPtr = &envPtr->exceptAuxArrayPtr[k]; + int i; + + for (i=0 ; i<auxPtr->numBreakTargets ; i++) { + if (jumpFixupPtr->codeOffset < auxPtr->breakTargets[i]) { + auxPtr->breakTargets[i] += 3; + } + } + for (i=0 ; i<auxPtr->numContinueTargets ; i++) { + if (jumpFixupPtr->codeOffset < auxPtr->continueTargets[i]) { + auxPtr->continueTargets[i] += 3; + } + } + } + return 1; /* the jump was grown */ } /* *---------------------------------------------------------------------- * + * TclEmitInvoke -- + * + * Emit one of the invoke-related instructions, wrapping it if necessary + * in code that ensures that any break or continue operation passing + * through it gets the stack unwinding correct, converting it into an + * internal jump if in an appropriate context. + * + * Results: + * None + * + * Side effects: + * Issues the jump with all correct stack management. May create another + * loop exception range; pointers to ExceptionRange and ExceptionAux + * structures should not be held across this call. + * + *---------------------------------------------------------------------- + */ + +void +TclEmitInvoke( + CompileEnv *envPtr, + int opcode, + ...) +{ + va_list argList; + ExceptionRange *rangePtr; + ExceptionAux *auxBreakPtr, *auxContinuePtr; + int arg1, arg2, wordCount = 0, expandCount = 0; + int loopRange = 0, breakRange = 0, continueRange = 0; + int cleanup, depth = TclGetStackDepth(envPtr); + + /* + * Parse the arguments. + */ + + va_start(argList, opcode); + switch (opcode) { + case INST_INVOKE_STK1: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_STK4: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + break; + case INST_INVOKE_REPLACE: + arg1 = va_arg(argList, int); + arg2 = va_arg(argList, int); + wordCount = arg1 + arg2 - 1; + cleanup = arg1 + 1; + break; + default: + Tcl_Panic("unexpected opcode"); + case INST_EVAL_STK: + wordCount = cleanup = 1; + arg1 = arg2 = 0; + break; + case INST_RETURN_STK: + wordCount = cleanup = 2; + arg1 = arg2 = 0; + break; + case INST_INVOKE_EXPANDED: + wordCount = arg1 = cleanup = va_arg(argList, int); + arg2 = 0; + expandCount = 1; + break; + } + va_end(argList); + + /* + * Determine if we need to handle break and continue exceptions with a + * special handling exception range (so that we can correctly unwind the + * stack). + * + * These must be done separately; they can be different (especially for + * calls from inside a [for] increment clause). + */ + + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_BREAK, &auxBreakPtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxBreakPtr = NULL; + } else if (auxBreakPtr->stackDepth == envPtr->currStackDepth-wordCount + && auxBreakPtr->expandTarget == envPtr->expandCount-expandCount) { + auxBreakPtr = NULL; + } else { + breakRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; + } + + rangePtr = TclGetInnermostExceptionRange(envPtr, TCL_CONTINUE, + &auxContinuePtr); + if (rangePtr == NULL || rangePtr->type != LOOP_EXCEPTION_RANGE) { + auxContinuePtr = NULL; + } else if (auxContinuePtr->stackDepth == envPtr->currStackDepth-wordCount + && auxContinuePtr->expandTarget == envPtr->expandCount-expandCount) { + auxContinuePtr = NULL; + } else { + continueRange = auxBreakPtr - envPtr->exceptAuxArrayPtr; + } + + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + loopRange = TclCreateExceptRange(LOOP_EXCEPTION_RANGE, envPtr); + ExceptionRangeStarts(envPtr, loopRange); + } + + /* + * Issue the invoke itself. + */ + + switch (opcode) { + case INST_INVOKE_STK1: + TclEmitInstInt1(INST_INVOKE_STK1, arg1, envPtr); + break; + case INST_INVOKE_STK4: + TclEmitInstInt4(INST_INVOKE_STK4, arg1, envPtr); + break; + case INST_INVOKE_EXPANDED: + TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); + envPtr->expandCount--; + TclAdjustStackDepth(1 - arg1, envPtr); + break; + case INST_EVAL_STK: + TclEmitOpcode(INST_EVAL_STK, envPtr); + break; + case INST_RETURN_STK: + TclEmitOpcode(INST_RETURN_STK, envPtr); + break; + case INST_INVOKE_REPLACE: + TclEmitInstInt4(INST_INVOKE_REPLACE, arg1, envPtr); + TclEmitInt1(arg2, envPtr); + TclAdjustStackDepth(-1, envPtr); /* Correction to stack depth calcs */ + break; + } + + /* + * If we're generating a special wrapper exception range, we need to + * finish that up now. + */ + + if (auxBreakPtr != NULL || auxContinuePtr != NULL) { + int savedStackDepth = envPtr->currStackDepth; + int savedExpandCount = envPtr->expandCount; + JumpFixup nonTrapFixup; + + if (auxBreakPtr != NULL) { + auxBreakPtr = envPtr->exceptAuxArrayPtr + breakRange; + } + if (auxContinuePtr != NULL) { + auxContinuePtr = envPtr->exceptAuxArrayPtr + continueRange; + } + + ExceptionRangeEnds(envPtr, loopRange); + TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &nonTrapFixup); + + /* + * Careful! When generating these stack unwinding sequences, the depth + * of stack in the cases where they are taken is not the same as if + * the exception is not taken. + */ + + if (auxBreakPtr != NULL) { + TclAdjustStackDepth(-1, envPtr); + + ExceptionRangeTarget(envPtr, loopRange, breakOffset); + TclCleanupStackForBreakContinue(envPtr, auxBreakPtr); + TclAddLoopBreakFixup(envPtr, auxBreakPtr); + TclAdjustStackDepth(1, envPtr); + + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; + } + + if (auxContinuePtr != NULL) { + TclAdjustStackDepth(-1, envPtr); + + ExceptionRangeTarget(envPtr, loopRange, continueOffset); + TclCleanupStackForBreakContinue(envPtr, auxContinuePtr); + TclAddLoopContinueFixup(envPtr, auxContinuePtr); + TclAdjustStackDepth(1, envPtr); + + envPtr->currStackDepth = savedStackDepth; + envPtr->expandCount = savedExpandCount; + } + + TclFinalizeLoopExceptionRange(envPtr, loopRange); + TclFixupForwardJumpToHere(envPtr, &nonTrapFixup, 127); + } + TclCheckStackDepth(depth+1-cleanup, envPtr); +} + +/* + *---------------------------------------------------------------------- + * * TclGetInstructionTable -- * * Returns a pointer to the table describing Tcl bytecode instructions. @@ -2506,7 +4220,7 @@ TclFixupForwardJump( *---------------------------------------------------------------------- */ -void * /* == InstructionDesc* == */ +const void * /* == InstructionDesc* == */ TclGetInstructionTable(void) { return &tclInstructionTable[0]; @@ -2515,7 +4229,7 @@ TclGetInstructionTable(void) /* *-------------------------------------------------------------- * - * TclRegisterAuxDataType -- + * RegisterAuxDataType -- * * This procedure is called to register a new AuxData type in the table * of all AuxData types supported by Tcl. @@ -2531,14 +4245,14 @@ TclGetInstructionTable(void) *-------------------------------------------------------------- */ -void -TclRegisterAuxDataType( - AuxDataType *typePtr) /* Information about object type; storage must - * be statically allocated (must live - * forever; will not be deallocated). */ +static void +RegisterAuxDataType( + const AuxDataType *typePtr) /* Information about object type; storage must + * be statically allocated (must live forever; + * will not be deallocated). */ { register Tcl_HashEntry *hPtr; - int new; + int isNew; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { @@ -2558,8 +4272,8 @@ TclRegisterAuxDataType( * Now insert the new object type. */ - hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new); - if (new) { + hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &isNew); + if (isNew) { Tcl_SetHashValue(hPtr, typePtr); } Tcl_MutexUnlock(&tableMutex); @@ -2582,12 +4296,12 @@ TclRegisterAuxDataType( *---------------------------------------------------------------------- */ -AuxDataType * +const AuxDataType * TclGetAuxDataType( - char *typeName) /* Name of AuxData type to look up. */ + const char *typeName) /* Name of AuxData type to look up. */ { register Tcl_HashEntry *hPtr; - AuxDataType *typePtr = NULL; + const AuxDataType *typePtr = NULL; Tcl_MutexLock(&tableMutex); if (!auxDataTypeTableInitialized) { @@ -2596,7 +4310,7 @@ TclGetAuxDataType( hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); if (hPtr != NULL) { - typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); + typePtr = Tcl_GetHashValue(hPtr); } Tcl_MutexUnlock(&tableMutex); @@ -2633,11 +4347,12 @@ TclInitAuxDataTypeTable(void) Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); /* - * There are only two AuxData type at this time, so register them here. + * There are only three AuxData types at this time, so register them here. */ - TclRegisterAuxDataType(&tclForeachInfoType); - TclRegisterAuxDataType(&tclJumptableInfoType); + RegisterAuxDataType(&tclForeachInfoType); + RegisterAuxDataType(&tclJumptableInfoType); + RegisterAuxDataType(&tclDictUpdateInfoType); } /* @@ -2705,13 +4420,13 @@ GetCmdLocEncodingSize( codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; prevCodeOffset = prevSrcOffset = 0; for (i = 0; i < numCmds; i++) { - codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); + codeDelta = mapPtr[i].codeOffset - prevCodeOffset; if (codeDelta < 0) { Tcl_Panic("GetCmdLocEncodingSize: bad code offset"); } else if (codeDelta <= 127) { codeDeltaNext++; } else { - codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ + codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ } prevCodeOffset = mapPtr[i].codeOffset; @@ -2721,14 +4436,14 @@ GetCmdLocEncodingSize( } else if (codeLen <= 127) { codeLengthNext++; } else { - codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + codeLengthNext += 5;/* 1 byte for 0xFF, 4 for length */ } - srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); - if ((-127 <= srcDelta) && (srcDelta <= 127)) { + srcDelta = mapPtr[i].srcOffset - prevSrcOffset; + if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) { srcDeltaNext++; } else { - srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ + srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ } prevSrcOffset = mapPtr[i].srcOffset; @@ -2738,7 +4453,7 @@ GetCmdLocEncodingSize( } else if (srcLen <= 127) { srcLengthNext++; } else { - srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ + srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ } } @@ -2790,7 +4505,7 @@ EncodeCmdLocMap( codePtr->codeDeltaStart = p; prevOffset = 0; for (i = 0; i < numCmds; i++) { - codeDelta = (mapPtr[i].codeOffset - prevOffset); + codeDelta = mapPtr[i].codeOffset - prevOffset; if (codeDelta < 0) { Tcl_Panic("EncodeCmdLocMap: bad code offset"); } else if (codeDelta <= 127) { @@ -2832,8 +4547,8 @@ EncodeCmdLocMap( codePtr->srcDeltaStart = p; prevOffset = 0; for (i = 0; i < numCmds; i++) { - srcDelta = (mapPtr[i].srcOffset - prevOffset); - if ((-127 <= srcDelta) && (srcDelta <= 127)) { + srcDelta = mapPtr[i].srcOffset - prevOffset; + if ((-127 <= srcDelta) && (srcDelta <= 127) && (srcDelta != -1)) { TclStoreInt1AtPtr(srcDelta, p); p++; } else { @@ -2891,33 +4606,157 @@ TclPrintByteCodeObj( Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ { - ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr; + Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); + + fprintf(stdout, "\n%s", TclGetString(bufPtr)); + Tcl_DecrRefCount(bufPtr); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintInstruction -- + * + * This procedure prints ("disassembles") one instruction from a bytecode + * object to stdout. + * + * Results: + * Returns the length in bytes of the current instruiction. + * + * Side effects: + * None. + * + *---------------------------------------------------------------------- + */ + +int +TclPrintInstruction( + ByteCode *codePtr, /* Bytecode containing the instruction. */ + const unsigned char *pc) /* Points to first byte of instruction. */ +{ + Tcl_Obj *bufferObj; + int numBytes; + + TclNewObj(bufferObj); + numBytes = FormatInstruction(codePtr, pc, bufferObj); + fprintf(stdout, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); + return numBytes; +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintObject -- + * + * This procedure prints up to a specified number of characters from the + * argument Tcl object's string representation to a specified file. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintObject( + FILE *outFile, /* The file to print the source to. */ + Tcl_Obj *objPtr, /* Points to the Tcl object whose string + * representation should be printed. */ + int maxChars) /* Maximum number of chars to print. */ +{ + char *bytes; + int length; + + bytes = Tcl_GetStringFromObj(objPtr, &length); + TclPrintSource(outFile, bytes, TclMin(length, maxChars)); +} + +/* + *---------------------------------------------------------------------- + * + * TclPrintSource -- + * + * This procedure prints up to a specified number of characters from the + * argument string to a specified file. It tries to produce legible + * output by adding backslashes as necessary. + * + * Results: + * None. + * + * Side effects: + * Outputs characters to the specified file. + * + *---------------------------------------------------------------------- + */ + +void +TclPrintSource( + FILE *outFile, /* The file to print the source to. */ + const char *stringPtr, /* The string to print. */ + int maxChars) /* Maximum number of chars to print. */ +{ + Tcl_Obj *bufferObj; + + TclNewObj(bufferObj); + PrintSourceToObj(bufferObj, stringPtr, maxChars); + fprintf(outFile, "%s", TclGetString(bufferObj)); + Tcl_DecrRefCount(bufferObj); +} +#endif /* TCL_COMPILE_DEBUG */ + +/* + *---------------------------------------------------------------------- + * + * TclDisassembleByteCodeObj -- + * + * Given an object which is of bytecode type, return a disassembled + * version of the bytecode (in a new refcount 0 object). No guarantees + * are made about the details of the contents of the result. + * + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclDisassembleByteCodeObj( + Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ +{ + ByteCode *codePtr = objPtr->internalRep.twoPtrValue.ptr1; unsigned char *codeStart, *codeLimit, *pc; unsigned char *codeDeltaNext, *codeLengthNext; unsigned char *srcDeltaNext, *srcLengthNext; int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; Interp *iPtr = (Interp *) *codePtr->interpHandle; + Tcl_Obj *bufferObj; + char ptrBuf1[20], ptrBuf2[20]; + TclNewObj(bufferObj); if (codePtr->refCount <= 0) { - return; /* already freed */ + return bufferObj; /* Already freed. */ } codeStart = codePtr->codeStart; - codeLimit = (codeStart + codePtr->numCodeBytes); + codeLimit = codeStart + codePtr->numCodeBytes; numCmds = codePtr->numCommands; /* * Print header lines describing the ByteCode. */ - fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n", - (unsigned int) codePtr, codePtr->refCount, - codePtr->compileEpoch, (unsigned int) iPtr, + sprintf(ptrBuf1, "%p", codePtr); + sprintf(ptrBuf2, "%p", iPtr); + Tcl_AppendPrintfToObj(bufferObj, + "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", + ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, iPtr->compileEpoch); - fprintf(stdout, " Source "); - TclPrintSource(stdout, codePtr->source, + Tcl_AppendToObj(bufferObj, " Source ", -1); + PrintSourceToObj(bufferObj, codePtr->source, TclMin(codePtr->numSrcBytes, 55)); - fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", + Tcl_AppendPrintfToObj(bufferObj, + "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, codePtr->numLitObjects, codePtr->numAuxDataItems, codePtr->maxStackDepth, @@ -2928,14 +4767,14 @@ TclPrintByteCodeObj( 0.0); #ifdef TCL_COMPILE_STATS - fprintf(stdout, - " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n", - codePtr->structureSize, - (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))), + Tcl_AppendPrintfToObj(bufferObj, + " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", + (unsigned long) codePtr->structureSize, + (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), codePtr->numCodeBytes, - (codePtr->numLitObjects * sizeof(Tcl_Obj *)), - (codePtr->numExceptRanges * sizeof(ExceptionRange)), - (codePtr->numAuxDataItems * sizeof(AuxData)), + (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), + (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), + (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), codePtr->numCmdLocBytes); #endif /* TCL_COMPILE_STATS */ @@ -2948,24 +4787,29 @@ TclPrintByteCodeObj( if (codePtr->procPtr != NULL) { Proc *procPtr = codePtr->procPtr; int numCompiledLocals = procPtr->numCompiledLocals; - fprintf(stdout, - " Proc 0x%x, refCt %d, args %d, compiled locals %d\n", - (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs, + + sprintf(ptrBuf1, "%p", procPtr); + Tcl_AppendPrintfToObj(bufferObj, + " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", + ptrBuf1, procPtr->refCount, procPtr->numArgs, numCompiledLocals); if (numCompiledLocals > 0) { CompiledLocal *localPtr = procPtr->firstLocalPtr; + for (i = 0; i < numCompiledLocals; i++) { - fprintf(stdout, " slot %d%s%s%s%s%s%s", i, - (localPtr->flags & VAR_SCALAR) ? ", scalar" : "", + Tcl_AppendPrintfToObj(bufferObj, + " slot %d%s%s%s%s%s%s", i, + (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", (localPtr->flags & VAR_ARRAY) ? ", array" : "", (localPtr->flags & VAR_LINK) ? ", link" : "", (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); if (TclIsVarTemporary(localPtr)) { - fprintf(stdout, "\n"); + Tcl_AppendToObj(bufferObj, "\n", -1); } else { - fprintf(stdout, ", \"%s\"\n", localPtr->name); + Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", + localPtr->name); } localPtr = localPtr->nextPtr; } @@ -2977,25 +4821,28 @@ TclPrintByteCodeObj( */ if (codePtr->numExceptRanges > 0) { - fprintf(stdout, " Exception ranges %d, depth %d:\n", + Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", codePtr->numExceptRanges, codePtr->maxExceptDepth); for (i = 0; i < codePtr->numExceptRanges; i++) { - ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); - fprintf(stdout, " %d: level %d, %s, pc %d-%d, ", + ExceptionRange *rangePtr = &codePtr->exceptArrayPtr[i]; + + Tcl_AppendPrintfToObj(bufferObj, + " %d: level %d, %s, pc %d-%d, ", i, rangePtr->nestingLevel, (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), rangePtr->codeOffset, (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); switch (rangePtr->type) { case LOOP_EXCEPTION_RANGE: - fprintf(stdout, "continue %d, break %d\n", + Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", rangePtr->continueOffset, rangePtr->breakOffset); break; case CATCH_EXCEPTION_RANGE: - fprintf(stdout, "catch %d\n", rangePtr->catchOffset); + Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", + rangePtr->catchOffset); break; default: - Tcl_Panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n", + Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", rangePtr->type); } } @@ -3009,10 +4856,10 @@ TclPrintByteCodeObj( if (numCmds == 0) { pc = codeStart; while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); } - return; + return bufferObj; } /* @@ -3020,14 +4867,14 @@ TclPrintByteCodeObj( * for each command. These are encoded as a sequence of bytes. */ - fprintf(stdout, " Commands %d:", numCmds); + Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); codeDeltaNext = codePtr->codeDeltaStart; codeLengthNext = codePtr->codeLengthStart; srcDeltaNext = codePtr->srcDeltaStart; srcLengthNext = codePtr->srcLengthStart; codeOffset = srcOffset = 0; for (i = 0; i < numCmds; i++) { - if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; @@ -3037,7 +4884,7 @@ TclPrintByteCodeObj( } codeOffset += delta; - if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) { + if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { codeLengthNext++; codeLen = TclGetInt4AtPtr(codeLengthNext); codeLengthNext += 4; @@ -3046,7 +4893,7 @@ TclPrintByteCodeObj( codeLengthNext++; } - if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; @@ -3056,7 +4903,7 @@ TclPrintByteCodeObj( } srcOffset += delta; - if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; @@ -3065,13 +4912,13 @@ TclPrintByteCodeObj( srcLengthNext++; } - fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d", - ((i % 2)? " " : "\n "), + Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", + ((i % 2)? " " : "\n "), (i+1), codeOffset, (codeOffset + codeLen - 1), srcOffset, (srcOffset + srcLen - 1)); } if (numCmds > 0) { - fprintf(stdout, "\n"); + Tcl_AppendToObj(bufferObj, "\n", -1); } /* @@ -3086,7 +4933,7 @@ TclPrintByteCodeObj( codeOffset = srcOffset = 0; pc = codeStart; for (i = 0; i < numCmds; i++) { - if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) { + if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { codeDeltaNext++; delta = TclGetInt4AtPtr(codeDeltaNext); codeDeltaNext += 4; @@ -3096,7 +4943,7 @@ TclPrintByteCodeObj( } codeOffset += delta; - if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) { + if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { srcDeltaNext++; delta = TclGetInt4AtPtr(srcDeltaNext); srcDeltaNext += 4; @@ -3106,7 +4953,7 @@ TclPrintByteCodeObj( } srcOffset += delta; - if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) { + if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { srcLengthNext++; srcLen = TclGetInt4AtPtr(srcLengthNext); srcLengthNext += 4; @@ -3120,14 +4967,14 @@ TclPrintByteCodeObj( */ while ((pc-codeStart) < codeOffset) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); } - fprintf(stdout, " Command %d: ", (i+1)); - TclPrintSource(stdout, (codePtr->source + srcOffset), + Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); + PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), TclMin(srcLen, 55)); - fprintf(stdout, "\n"); + Tcl_AppendToObj(bufferObj, "\n", -1); } if (pc < codeLimit) { /* @@ -3135,50 +4982,45 @@ TclPrintByteCodeObj( */ while (pc < codeLimit) { - fprintf(stdout, " "); - pc += TclPrintInstruction(codePtr, pc); + Tcl_AppendToObj(bufferObj, " ", -1); + pc += FormatInstruction(codePtr, pc, bufferObj); } } + return bufferObj; } /* *---------------------------------------------------------------------- * - * TclPrintInstruction -- + * FormatInstruction -- * - * This procedure prints ("disassembles") one instruction from a bytecode - * object to stdout. - * - * Results: - * Returns the length in bytes of the current instruiction. - * - * Side effects: - * None. + * Appends a representation of a bytecode instruction to a Tcl_Obj. * *---------------------------------------------------------------------- */ -int -TclPrintInstruction( +static int +FormatInstruction( ByteCode *codePtr, /* Bytecode containing the instruction. */ - unsigned char *pc) /* Points to first byte of instruction. */ + const unsigned char *pc, /* Points to first byte of instruction. */ + Tcl_Obj *bufferObj) /* Object to append instruction info to. */ { Proc *procPtr = codePtr->procPtr; unsigned char opCode = *pc; - register InstructionDesc *instDesc = &tclInstructionTable[opCode]; + register const InstructionDesc *instDesc = &tclInstructionTable[opCode]; unsigned char *codeStart = codePtr->codeStart; - unsigned int pcOffset = (pc - codeStart); - int opnd, i, j, numBytes = 1; + unsigned pcOffset = pc - codeStart; + int opnd = 0, i, j, numBytes = 1; int localCt = procPtr ? procPtr->numCompiledLocals : 0; CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; - - char suffixBuffer[64]; /* Additional info to print after main opcode + char suffixBuffer[128]; /* Additional info to print after main opcode * and immediates. */ char *suffixSrc = NULL; Tcl_Obj *suffixObj = NULL; + AuxData *auxPtr = NULL; suffixBuffer[0] = '\0'; - fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name); + Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); for (i = 0; i < instDesc->numOperands; i++) { switch (instDesc->opTypes[i]) { case OPERAND_INT1: @@ -3187,40 +5029,47 @@ TclPrintInstruction( || opCode == INST_JUMP_FALSE1) { sprintf(suffixBuffer, "pc %u", pcOffset+opnd); } - fprintf(stdout, "%+d ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_INT4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 || opCode == INST_JUMP_FALSE4) { sprintf(suffixBuffer, "pc %u", pcOffset+opnd); + } else if (opCode == INST_START_CMD) { + sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); } - fprintf(stdout, "%+d ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); break; case OPERAND_UINT1: opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; if (opCode == INST_PUSH1) { suffixObj = codePtr->objArrayPtr[opnd]; } - fprintf(stdout, "%u ", (unsigned int) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); break; + case OPERAND_AUX4: case OPERAND_UINT4: opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; if (opCode == INST_PUSH4) { suffixObj = codePtr->objArrayPtr[opnd]; - } else if (opCode == INST_START_CMD) { - sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); + } else if (opCode == INST_START_CMD && opnd != 1) { + sprintf(suffixBuffer+strlen(suffixBuffer), + ", %u cmds start here", opnd); + } + Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); + if (instDesc->opTypes[i] == OPERAND_AUX4) { + auxPtr = &codePtr->auxDataArrayPtr[opnd]; } - fprintf(stdout, "%u ", (unsigned int) opnd); break; case OPERAND_IDX4: opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; if (opnd >= -1) { - fprintf(stdout, "%d ", opnd); + Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); } else if (opnd == -2) { - fprintf(stdout, "end "); + Tcl_AppendPrintfToObj(bufferObj, "end "); } else { - fprintf(stdout, "end-%d ", -2-opnd); + Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); } break; case OPERAND_LVT1: @@ -3233,8 +5082,8 @@ TclPrintInstruction( printLVTindex: if (localPtr != NULL) { if (opnd >= localCt) { - Tcl_Panic("TclPrintInstruction: bad local var index %u (%u locals)\n", - (unsigned int) opnd, localCt); + Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", + (unsigned) opnd, localCt); } for (j = 0; j < opnd; j++) { localPtr = localPtr->nextPtr; @@ -3246,7 +5095,12 @@ TclPrintInstruction( suffixSrc = localPtr->name; } } - fprintf(stdout, "%%v%u ", (unsigned) opnd); + Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); + break; + case OPERAND_SCLS1: + opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; + Tcl_AppendPrintfToObj(bufferObj, "%s ", + tclStringClassTable[opnd].name); break; case OPERAND_NONE: default: @@ -3254,111 +5108,270 @@ TclPrintInstruction( } } if (suffixObj) { - fprintf(stdout, "\t# "); - TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40); + const char *bytes; + int length; + + Tcl_AppendToObj(bufferObj, "\t# ", -1); + bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); + PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); } else if (suffixBuffer[0]) { - fprintf(stdout, "\t# %s", suffixBuffer); + Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); if (suffixSrc) { - TclPrintSource(stdout, suffixSrc, 40); + PrintSourceToObj(bufferObj, suffixSrc, 40); } } - fprintf(stdout, "\n"); + Tcl_AppendToObj(bufferObj, "\n", -1); + if (auxPtr && auxPtr->type->printProc) { + Tcl_AppendToObj(bufferObj, "\t\t[", -1); + auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, + pcOffset); + Tcl_AppendToObj(bufferObj, "]\n", -1); + } return numBytes; } /* *---------------------------------------------------------------------- * - * TclPrintObject -- + * TclGetInnerContext -- * - * This procedure prints up to a specified number of characters from the - * argument Tcl object's string representation to a specified file. + * If possible, returns a list capturing the inner context. Otherwise + * return NULL. * - * Results: - * None. + *---------------------------------------------------------------------- + */ + +Tcl_Obj * +TclGetInnerContext( + Tcl_Interp *interp, + const unsigned char *pc, + Tcl_Obj **tosPtr) +{ + int objc = 0, off = 0; + Tcl_Obj *result; + Interp *iPtr = (Interp *) interp; + + switch (*pc) { + case INST_STR_LEN: + case INST_LNOT: + case INST_BITNOT: + case INST_UMINUS: + case INST_UPLUS: + case INST_TRY_CVT_TO_NUMERIC: + case INST_EXPAND_STKTOP: + case INST_EXPR_STK: + objc = 1; + break; + + case INST_LIST_IN: + case INST_LIST_NOT_IN: /* Basic list containment operators. */ + case INST_STR_EQ: + case INST_STR_NEQ: /* String (in)equality check */ + case INST_STR_CMP: /* String compare. */ + case INST_STR_INDEX: + case INST_STR_MATCH: + case INST_REGEXP: + case INST_EQ: + case INST_NEQ: + case INST_LT: + case INST_GT: + case INST_LE: + case INST_GE: + case INST_MOD: + case INST_LSHIFT: + case INST_RSHIFT: + case INST_BITOR: + case INST_BITXOR: + case INST_BITAND: + case INST_EXPON: + case INST_ADD: + case INST_SUB: + case INST_DIV: + case INST_MULT: + objc = 2; + break; + + case INST_RETURN_STK: + /* early pop. TODO: dig out opt dict too :/ */ + objc = 1; + break; + + case INST_SYNTAX: + case INST_RETURN_IMM: + objc = 2; + break; + + case INST_INVOKE_STK4: + objc = TclGetUInt4AtPtr(pc+1); + break; + + case INST_INVOKE_STK1: + objc = TclGetUInt1AtPtr(pc+1); + break; + } + + result = iPtr->innerContext; + if (Tcl_IsShared(result)) { + Tcl_DecrRefCount(result); + iPtr->innerContext = result = Tcl_NewListObj(objc + 1, NULL); + Tcl_IncrRefCount(result); + } else { + int len; + + /* + * Reset while keeping the list intrep as much as possible. + */ + + Tcl_ListObjLength(interp, result, &len); + Tcl_ListObjReplace(interp, result, 0, len, 0, NULL); + } + Tcl_ListObjAppendElement(NULL, result, TclNewInstNameObj(*pc)); + + for (; objc>0 ; objc--) { + Tcl_Obj *objPtr; + + objPtr = tosPtr[1 - objc + off]; + if (!objPtr) { + Tcl_Panic("InnerContext: bad tos -- appending null object"); + } + if ((objPtr->refCount<=0) +#ifdef TCL_MEM_DEBUG + || (objPtr->refCount==0x61616161) +#endif + ) { + Tcl_Panic("InnerContext: bad tos -- appending freed object %p", + objPtr); + } + Tcl_ListObjAppendElement(NULL, result, objPtr); + } + + return result; +} + +/* + *---------------------------------------------------------------------- * - * Side effects: - * Outputs characters to the specified file. + * TclNewInstNameObj -- + * + * Creates a new InstName Tcl_Obj based on the given instruction * *---------------------------------------------------------------------- */ -void -TclPrintObject( - FILE *outFile, /* The file to print the source to. */ - Tcl_Obj *objPtr, /* Points to the Tcl object whose string - * representation should be printed. */ - int maxChars) /* Maximum number of chars to print. */ +Tcl_Obj * +TclNewInstNameObj( + unsigned char inst) { - char *bytes; - int length; + Tcl_Obj *objPtr = Tcl_NewObj(); - bytes = Tcl_GetStringFromObj(objPtr, &length); - TclPrintSource(outFile, bytes, TclMin(length, maxChars)); + objPtr->typePtr = &tclInstNameType; + objPtr->internalRep.longValue = (long) inst; + objPtr->bytes = NULL; + + return objPtr; } /* *---------------------------------------------------------------------- * - * TclPrintSource -- + * UpdateStringOfInstName -- * - * This procedure prints up to a specified number of characters from the - * argument string to a specified file. It tries to produce legible - * output by adding backslashes as necessary. + * Update the string representation for an instruction name object. * - * Results: - * None. + *---------------------------------------------------------------------- + */ + +static void +UpdateStringOfInstName( + Tcl_Obj *objPtr) +{ + int inst = objPtr->internalRep.longValue; + char *s, buf[20]; + int len; + + if ((inst < 0) || (inst > LAST_INST_OPCODE)) { + sprintf(buf, "inst_%d", inst); + s = buf; + } else { + s = (char *) tclInstructionTable[objPtr->internalRep.longValue].name; + } + len = strlen(s); + objPtr->bytes = ckalloc(len + 1); + memcpy(objPtr->bytes, s, len + 1); + objPtr->length = len; +} + +/* + *---------------------------------------------------------------------- * - * Side effects: - * Outputs characters to the specified file. + * PrintSourceToObj -- + * + * Appends a quoted representation of a string to a Tcl_Obj. * *---------------------------------------------------------------------- */ -void -TclPrintSource( - FILE *outFile, /* The file to print the source to. */ - CONST char *stringPtr, /* The string to print. */ +static void +PrintSourceToObj( + Tcl_Obj *appendObj, /* The object to print the source to. */ + const char *stringPtr, /* The string to print. */ int maxChars) /* Maximum number of chars to print. */ { - register CONST char *p; - register int i = 0; + register const char *p; + register int i = 0, len; if (stringPtr == NULL) { - fprintf(outFile, "\"\""); + Tcl_AppendToObj(appendObj, "\"\"", -1); return; } - fprintf(outFile, "\""); + Tcl_AppendToObj(appendObj, "\"", -1); p = stringPtr; - for (; (*p != '\0') && (i < maxChars); p++, i++) { - switch (*p) { + for (; (*p != '\0') && (i < maxChars); p+=len) { + Tcl_UniChar ch; + + len = TclUtfToUniChar(p, &ch); + switch (ch) { case '"': - fprintf(outFile, "\\\""); + Tcl_AppendToObj(appendObj, "\\\"", -1); + i += 2; continue; case '\f': - fprintf(outFile, "\\f"); + Tcl_AppendToObj(appendObj, "\\f", -1); + i += 2; continue; case '\n': - fprintf(outFile, "\\n"); + Tcl_AppendToObj(appendObj, "\\n", -1); + i += 2; continue; case '\r': - fprintf(outFile, "\\r"); + Tcl_AppendToObj(appendObj, "\\r", -1); + i += 2; continue; case '\t': - fprintf(outFile, "\\t"); + Tcl_AppendToObj(appendObj, "\\t", -1); + i += 2; continue; case '\v': - fprintf(outFile, "\\v"); + Tcl_AppendToObj(appendObj, "\\v", -1); + i += 2; continue; default: - fprintf(outFile, "%c", *p); + if (ch < 0x20 || ch >= 0x7f) { + Tcl_AppendPrintfToObj(appendObj, "\\u%04x", ch); + i += 6; + } else { + Tcl_AppendPrintfToObj(appendObj, "%c", ch); + i++; + } continue; } } - fprintf(outFile, "\""); + Tcl_AppendToObj(appendObj, "\"", -1); + if (*p != '\0') { + Tcl_AppendToObj(appendObj, "...", -1); + } } -#endif /* TCL_COMPILE_DEBUG */ #ifdef TCL_COMPILE_STATS /* @@ -3387,7 +5400,13 @@ RecordByteCodeStats( * to add to accumulated statistics. */ { Interp *iPtr = (Interp *) *codePtr->interpHandle; - register ByteCodeStats *statsPtr = &(iPtr->stats); + register ByteCodeStats *statsPtr; + + if (iPtr == NULL) { + /* Avoid segfaulting in case we're called in a deleted interp */ + return; + } + statsPtr = &(iPtr->stats); statsPtr->numCompilations++; statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; @@ -3396,7 +5415,7 @@ RecordByteCodeStats( statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; - statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; + statsPtr->byteCodeCount[TclLog2((int) codePtr->structureSize)]++; statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; statsPtr->currentLitBytes += (double) @@ -3414,5 +5433,6 @@ RecordByteCodeStats( * mode: c * c-basic-offset: 4 * fill-column: 78 + * tab-width: 8 * End: */ |