1/* 2 * tclCompile.c -- 3 * 4 * This file contains procedures that compile Tcl commands or parts of 5 * commands (like quoted strings or nested sub-commands) into a sequence 6 * of instructions ("bytecodes"). 7 * 8 * Copyright (c) 1996-1998 Sun Microsystems, Inc. 9 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved. 10 * 11 * See the file "license.terms" for information on usage and redistribution of 12 * this file, and for a DISCLAIMER OF ALL WARRANTIES. 13 * 14 * RCS: @(#) $Id: tclCompile.c,v 1.146.2.13 2010/02/02 20:51:46 andreas_kupries Exp $ 15 */ 16 17#include "tclInt.h" 18#include "tclCompile.h" 19 20/* 21 * Table of all AuxData types. 22 */ 23 24static Tcl_HashTable auxDataTypeTable; 25static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */ 26 27TCL_DECLARE_MUTEX(tableMutex) 28 29/* 30 * Variable that controls whether compilation tracing is enabled and, if so, 31 * what level of tracing is desired: 32 * 0: no compilation tracing 33 * 1: summarize compilation of top level cmds and proc bodies 34 * 2: display all instructions of each ByteCode compiled 35 * This variable is linked to the Tcl variable "tcl_traceCompile". 36 */ 37 38#ifdef TCL_COMPILE_DEBUG 39int tclTraceCompile = 0; 40static int traceInitialized = 0; 41#endif 42 43/* 44 * A table describing the Tcl bytecode instructions. Entries in this table 45 * must correspond to the instruction opcode definitions in tclCompile.h. The 46 * names "op1" and "op4" refer to an instruction's one or four byte first 47 * operand. Similarly, "stktop" and "stknext" refer to the topmost and next to 48 * topmost stack elements. 49 * 50 * Note that the load, store, and incr instructions do not distinguish local 51 * from global variables; the bytecode interpreter at runtime uses the 52 * existence of a procedure call frame to distinguish these. 53 */ 54 55InstructionDesc tclInstructionTable[] = { 56 /* Name Bytes stackEffect #Opnds Operand types */ 57 {"done", 1, -1, 0, {OPERAND_NONE}}, 58 /* Finish ByteCode execution and return stktop (top stack item) */ 59 {"push1", 2, +1, 1, {OPERAND_UINT1}}, 60 /* Push object at ByteCode objArray[op1] */ 61 {"push4", 5, +1, 1, {OPERAND_UINT4}}, 62 /* Push object at ByteCode objArray[op4] */ 63 {"pop", 1, -1, 0, {OPERAND_NONE}}, 64 /* Pop the topmost stack object */ 65 {"dup", 1, +1, 0, {OPERAND_NONE}}, 66 /* Duplicate the topmost stack object and push the result */ 67 {"concat1", 2, INT_MIN, 1, {OPERAND_UINT1}}, 68 /* Concatenate the top op1 items and push result */ 69 {"invokeStk1", 2, INT_MIN, 1, {OPERAND_UINT1}}, 70 /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */ 71 {"invokeStk4", 5, INT_MIN, 1, {OPERAND_UINT4}}, 72 /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */ 73 {"evalStk", 1, 0, 0, {OPERAND_NONE}}, 74 /* Evaluate command in stktop using Tcl_EvalObj. */ 75 {"exprStk", 1, 0, 0, {OPERAND_NONE}}, 76 /* Execute expression in stktop using Tcl_ExprStringObj. */ 77 78 {"loadScalar1", 2, 1, 1, {OPERAND_LVT1}}, 79 /* Load scalar variable at index op1 <= 255 in call frame */ 80 {"loadScalar4", 5, 1, 1, {OPERAND_LVT4}}, 81 /* Load scalar variable at index op1 >= 256 in call frame */ 82 {"loadScalarStk", 1, 0, 0, {OPERAND_NONE}}, 83 /* Load scalar variable; scalar's name is stktop */ 84 {"loadArray1", 2, 0, 1, {OPERAND_LVT1}}, 85 /* Load array element; array at slot op1<=255, element is stktop */ 86 {"loadArray4", 5, 0, 1, {OPERAND_LVT4}}, 87 /* Load array element; array at slot op1 > 255, element is stktop */ 88 {"loadArrayStk", 1, -1, 0, {OPERAND_NONE}}, 89 /* Load array element; element is stktop, array name is stknext */ 90 {"loadStk", 1, 0, 0, {OPERAND_NONE}}, 91 /* Load general variable; unparsed variable name is stktop */ 92 {"storeScalar1", 2, 0, 1, {OPERAND_LVT1}}, 93 /* Store scalar variable at op1<=255 in frame; value is stktop */ 94 {"storeScalar4", 5, 0, 1, {OPERAND_LVT4}}, 95 /* Store scalar variable at op1 > 255 in frame; value is stktop */ 96 {"storeScalarStk", 1, -1, 0, {OPERAND_NONE}}, 97 /* Store scalar; value is stktop, scalar name is stknext */ 98 {"storeArray1", 2, -1, 1, {OPERAND_LVT1}}, 99 /* Store array element; array at op1<=255, value is top then elem */ 100 {"storeArray4", 5, -1, 1, {OPERAND_LVT4}}, 101 /* Store array element; array at op1>=256, value is top then elem */ 102 {"storeArrayStk", 1, -2, 0, {OPERAND_NONE}}, 103 /* Store array element; value is stktop, then elem, array names */ 104 {"storeStk", 1, -1, 0, {OPERAND_NONE}}, 105 /* Store general variable; value is stktop, then unparsed name */ 106 107 {"incrScalar1", 2, 0, 1, {OPERAND_LVT1}}, 108 /* Incr scalar at index op1<=255 in frame; incr amount is stktop */ 109 {"incrScalarStk", 1, -1, 0, {OPERAND_NONE}}, 110 /* Incr scalar; incr amount is stktop, scalar's name is stknext */ 111 {"incrArray1", 2, -1, 1, {OPERAND_LVT1}}, 112 /* Incr array elem; arr at slot op1<=255, amount is top then elem */ 113 {"incrArrayStk", 1, -2, 0, {OPERAND_NONE}}, 114 /* Incr array element; amount is top then elem then array names */ 115 {"incrStk", 1, -1, 0, {OPERAND_NONE}}, 116 /* Incr general variable; amount is stktop then unparsed var name */ 117 {"incrScalar1Imm", 3, +1, 2, {OPERAND_LVT1, OPERAND_INT1}}, 118 /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */ 119 {"incrScalarStkImm", 2, 0, 1, {OPERAND_INT1}}, 120 /* Incr scalar; scalar name is stktop; incr amount is op1 */ 121 {"incrArray1Imm", 3, 0, 2, {OPERAND_LVT1, OPERAND_INT1}}, 122 /* Incr array elem; array at slot op1 <= 255, elem is stktop, 123 * amount is 2nd operand byte */ 124 {"incrArrayStkImm", 2, -1, 1, {OPERAND_INT1}}, 125 /* Incr array element; elem is top then array name, amount is op1 */ 126 {"incrStkImm", 2, 0, 1, {OPERAND_INT1}}, 127 /* Incr general variable; unparsed name is top, amount is op1 */ 128 129 {"jump1", 2, 0, 1, {OPERAND_INT1}}, 130 /* Jump relative to (pc + op1) */ 131 {"jump4", 5, 0, 1, {OPERAND_INT4}}, 132 /* Jump relative to (pc + op4) */ 133 {"jumpTrue1", 2, -1, 1, {OPERAND_INT1}}, 134 /* Jump relative to (pc + op1) if stktop expr object is true */ 135 {"jumpTrue4", 5, -1, 1, {OPERAND_INT4}}, 136 /* Jump relative to (pc + op4) if stktop expr object is true */ 137 {"jumpFalse1", 2, -1, 1, {OPERAND_INT1}}, 138 /* Jump relative to (pc + op1) if stktop expr object is false */ 139 {"jumpFalse4", 5, -1, 1, {OPERAND_INT4}}, 140 /* Jump relative to (pc + op4) if stktop expr object is false */ 141 142 {"lor", 1, -1, 0, {OPERAND_NONE}}, 143 /* Logical or: push (stknext || stktop) */ 144 {"land", 1, -1, 0, {OPERAND_NONE}}, 145 /* Logical and: push (stknext && stktop) */ 146 {"bitor", 1, -1, 0, {OPERAND_NONE}}, 147 /* Bitwise or: push (stknext | stktop) */ 148 {"bitxor", 1, -1, 0, {OPERAND_NONE}}, 149 /* Bitwise xor push (stknext ^ stktop) */ 150 {"bitand", 1, -1, 0, {OPERAND_NONE}}, 151 /* Bitwise and: push (stknext & stktop) */ 152 {"eq", 1, -1, 0, {OPERAND_NONE}}, 153 /* Equal: push (stknext == stktop) */ 154 {"neq", 1, -1, 0, {OPERAND_NONE}}, 155 /* Not equal: push (stknext != stktop) */ 156 {"lt", 1, -1, 0, {OPERAND_NONE}}, 157 /* Less: push (stknext < stktop) */ 158 {"gt", 1, -1, 0, {OPERAND_NONE}}, 159 /* Greater: push (stknext || stktop) */ 160 {"le", 1, -1, 0, {OPERAND_NONE}}, 161 /* Less or equal: push (stknext || stktop) */ 162 {"ge", 1, -1, 0, {OPERAND_NONE}}, 163 /* Greater or equal: push (stknext || stktop) */ 164 {"lshift", 1, -1, 0, {OPERAND_NONE}}, 165 /* Left shift: push (stknext << stktop) */ 166 {"rshift", 1, -1, 0, {OPERAND_NONE}}, 167 /* Right shift: push (stknext >> stktop) */ 168 {"add", 1, -1, 0, {OPERAND_NONE}}, 169 /* Add: push (stknext + stktop) */ 170 {"sub", 1, -1, 0, {OPERAND_NONE}}, 171 /* Sub: push (stkext - stktop) */ 172 {"mult", 1, -1, 0, {OPERAND_NONE}}, 173 /* Multiply: push (stknext * stktop) */ 174 {"div", 1, -1, 0, {OPERAND_NONE}}, 175 /* Divide: push (stknext / stktop) */ 176 {"mod", 1, -1, 0, {OPERAND_NONE}}, 177 /* Mod: push (stknext % stktop) */ 178 {"uplus", 1, 0, 0, {OPERAND_NONE}}, 179 /* Unary plus: push +stktop */ 180 {"uminus", 1, 0, 0, {OPERAND_NONE}}, 181 /* Unary minus: push -stktop */ 182 {"bitnot", 1, 0, 0, {OPERAND_NONE}}, 183 /* Bitwise not: push ~stktop */ 184 {"not", 1, 0, 0, {OPERAND_NONE}}, 185 /* Logical not: push !stktop */ 186 {"callBuiltinFunc1", 2, 1, 1, {OPERAND_UINT1}}, 187 /* Call builtin math function with index op1; any args are on stk */ 188 {"callFunc1", 2, INT_MIN, 1, {OPERAND_UINT1}}, 189 /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */ 190 {"tryCvtToNumeric", 1, 0, 0, {OPERAND_NONE}}, 191 /* Try converting stktop to first int then double if possible. */ 192 193 {"break", 1, 0, 0, {OPERAND_NONE}}, 194 /* Abort closest enclosing loop; if none, return TCL_BREAK code. */ 195 {"continue", 1, 0, 0, {OPERAND_NONE}}, 196 /* Skip to next iteration of closest enclosing loop; if none, return 197 * TCL_CONTINUE code. */ 198 199 {"foreach_start4", 5, 0, 1, {OPERAND_AUX4}}, 200 /* Initialize execution of a foreach loop. Operand is aux data index 201 * of the ForeachInfo structure for the foreach command. */ 202 {"foreach_step4", 5, +1, 1, {OPERAND_AUX4}}, 203 /* "Step" or begin next iteration of foreach loop. Push 0 if to 204 * terminate loop, else push 1. */ 205 206 {"beginCatch4", 5, 0, 1, {OPERAND_UINT4}}, 207 /* Record start of catch with the operand's exception index. Push the 208 * current stack depth onto a special catch stack. */ 209 {"endCatch", 1, 0, 0, {OPERAND_NONE}}, 210 /* End of last catch. Pop the bytecode interpreter's catch stack. */ 211 {"pushResult", 1, +1, 0, {OPERAND_NONE}}, 212 /* Push the interpreter's object result onto the stack. */ 213 {"pushReturnCode", 1, +1, 0, {OPERAND_NONE}}, 214 /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as a new 215 * object onto the stack. */ 216 217 {"streq", 1, -1, 0, {OPERAND_NONE}}, 218 /* Str Equal: push (stknext eq stktop) */ 219 {"strneq", 1, -1, 0, {OPERAND_NONE}}, 220 /* Str !Equal: push (stknext neq stktop) */ 221 {"strcmp", 1, -1, 0, {OPERAND_NONE}}, 222 /* Str Compare: push (stknext cmp stktop) */ 223 {"strlen", 1, 0, 0, {OPERAND_NONE}}, 224 /* Str Length: push (strlen stktop) */ 225 {"strindex", 1, -1, 0, {OPERAND_NONE}}, 226 /* Str Index: push (strindex stknext stktop) */ 227 {"strmatch", 2, -1, 1, {OPERAND_INT1}}, 228 /* Str Match: push (strmatch stknext stktop) opnd == nocase */ 229 230 {"list", 5, INT_MIN, 1, {OPERAND_UINT4}}, 231 /* List: push (stk1 stk2 ... stktop) */ 232 {"listIndex", 1, -1, 0, {OPERAND_NONE}}, 233 /* List Index: push (listindex stknext stktop) */ 234 {"listLength", 1, 0, 0, {OPERAND_NONE}}, 235 /* List Len: push (listlength stktop) */ 236 237 {"appendScalar1", 2, 0, 1, {OPERAND_LVT1}}, 238 /* Append scalar variable at op1<=255 in frame; value is stktop */ 239 {"appendScalar4", 5, 0, 1, {OPERAND_LVT4}}, 240 /* Append scalar variable at op1 > 255 in frame; value is stktop */ 241 {"appendArray1", 2, -1, 1, {OPERAND_LVT1}}, 242 /* Append array element; array at op1<=255, value is top then elem */ 243 {"appendArray4", 5, -1, 1, {OPERAND_LVT4}}, 244 /* Append array element; array at op1>=256, value is top then elem */ 245 {"appendArrayStk", 1, -2, 0, {OPERAND_NONE}}, 246 /* Append array element; value is stktop, then elem, array names */ 247 {"appendStk", 1, -1, 0, {OPERAND_NONE}}, 248 /* Append general variable; value is stktop, then unparsed name */ 249 {"lappendScalar1", 2, 0, 1, {OPERAND_LVT1}}, 250 /* Lappend scalar variable at op1<=255 in frame; value is stktop */ 251 {"lappendScalar4", 5, 0, 1, {OPERAND_LVT4}}, 252 /* Lappend scalar variable at op1 > 255 in frame; value is stktop */ 253 {"lappendArray1", 2, -1, 1, {OPERAND_LVT1}}, 254 /* Lappend array element; array at op1<=255, value is top then elem */ 255 {"lappendArray4", 5, -1, 1, {OPERAND_LVT4}}, 256 /* Lappend array element; array at op1>=256, value is top then elem */ 257 {"lappendArrayStk", 1, -2, 0, {OPERAND_NONE}}, 258 /* Lappend array element; value is stktop, then elem, array names */ 259 {"lappendStk", 1, -1, 0, {OPERAND_NONE}}, 260 /* Lappend general variable; value is stktop, then unparsed name */ 261 262 {"lindexMulti", 5, INT_MIN, 1, {OPERAND_UINT4}}, 263 /* Lindex with generalized args, operand is number of stacked objs 264 * used: (operand-1) entries from stktop are the indices; then list to 265 * process. */ 266 {"over", 5, +1, 1, {OPERAND_UINT4}}, 267 /* Duplicate the arg-th element from top of stack (TOS=0) */ 268 {"lsetList", 1, -2, 0, {OPERAND_NONE}}, 269 /* Four-arg version of 'lset'. stktop is old value; next is new 270 * element value, next is the index list; pushes new value */ 271 {"lsetFlat", 5, INT_MIN, 1, {OPERAND_UINT4}}, 272 /* Three- or >=5-arg version of 'lset', operand is number of stacked 273 * objs: stktop is old value, next is new element value, next come 274 * (operand-2) indices; pushes the new value. 275 */ 276 277 {"returnImm", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, 278 /* Compiled [return], code, level are operands; options and result 279 * are on the stack. */ 280 {"expon", 1, -1, 0, {OPERAND_NONE}}, 281 /* Binary exponentiation operator: push (stknext ** stktop) */ 282 283 /* 284 * NOTE: the stack effects of expandStkTop and invokeExpanded are wrong - 285 * but it cannot be done right at compile time, the stack effect is only 286 * known at run time. The value for invokeExpanded is estimated better at 287 * compile time. 288 * See the comments further down in this file, where INST_INVOKE_EXPANDED 289 * is emitted. 290 */ 291 {"expandStart", 1, 0, 0, {OPERAND_NONE}}, 292 /* Start of command with {*} (expanded) arguments */ 293 {"expandStkTop", 5, 0, 1, {OPERAND_UINT4}}, 294 /* Expand the list at stacktop: push its elements on the stack */ 295 {"invokeExpanded", 1, 0, 0, {OPERAND_NONE}}, 296 /* Invoke the command marked by the last 'expandStart' */ 297 298 {"listIndexImm", 5, 0, 1, {OPERAND_IDX4}}, 299 /* List Index: push (lindex stktop op4) */ 300 {"listRangeImm", 9, 0, 2, {OPERAND_IDX4, OPERAND_IDX4}}, 301 /* List Range: push (lrange stktop op4 op4) */ 302 {"startCommand", 9, 0, 2, {OPERAND_INT4,OPERAND_UINT4}}, 303 /* Start of bytecoded command: op is the length of the cmd's code, op2 304 * is number of commands here */ 305 306 {"listIn", 1, -1, 0, {OPERAND_NONE}}, 307 /* List containment: push [lsearch stktop stknext]>=0) */ 308 {"listNotIn", 1, -1, 0, {OPERAND_NONE}}, 309 /* List negated containment: push [lsearch stktop stknext]<0) */ 310 311 {"pushReturnOpts", 1, +1, 0, {OPERAND_NONE}}, 312 /* Push the interpreter's return option dictionary as an object on the 313 * stack. */ 314 {"returnStk", 1, -2, 0, {OPERAND_NONE}}, 315 /* Compiled [return]; options and result are on the stack, code and 316 * level are in the options. */ 317 318 {"dictGet", 5, INT_MIN, 1, {OPERAND_UINT4}}, 319 /* The top op4 words (min 1) are a key path into the dictionary just 320 * below the keys on the stack, and all those values are replaced by 321 * the value read out of that key-path (like [dict get]). 322 * Stack: ... dict key1 ... keyN => ... value */ 323 {"dictSet", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, 324 /* Update a dictionary value such that the keys are a path pointing to 325 * the value. op4#1 = numKeys, op4#2 = LVTindex 326 * Stack: ... key1 ... keyN value => ... newDict */ 327 {"dictUnset", 9, INT_MIN, 2, {OPERAND_UINT4, OPERAND_LVT4}}, 328 /* Update a dictionary value such that the keys are not a path pointing 329 * to any value. op4#1 = numKeys, op4#2 = LVTindex 330 * Stack: ... key1 ... keyN => ... newDict */ 331 {"dictIncrImm", 9, 0, 2, {OPERAND_INT4, OPERAND_LVT4}}, 332 /* Update a dictionary value such that the value pointed to by key is 333 * incremented by some value (or set to it if the key isn't in the 334 * dictionary at all). op4#1 = incrAmount, op4#2 = LVTindex 335 * Stack: ... key => ... newDict */ 336 {"dictAppend", 5, -1, 1, {OPERAND_LVT4}}, 337 /* Update a dictionary value such that the value pointed to by key has 338 * some value string-concatenated onto it. op4 = LVTindex 339 * Stack: ... key valueToAppend => ... newDict */ 340 {"dictLappend", 5, -1, 1, {OPERAND_LVT4}}, 341 /* Update a dictionary value such that the value pointed to by key has 342 * some value list-appended onto it. op4 = LVTindex 343 * Stack: ... key valueToAppend => ... newDict */ 344 {"dictFirst", 5, +2, 1, {OPERAND_LVT4}}, 345 /* Begin iterating over the dictionary, using the local scalar 346 * indicated by op4 to hold the iterator state. If doneBool is true, 347 * dictDone *must* be called later on. 348 * Stack: ... dict => ... value key doneBool */ 349 {"dictNext", 5, +3, 1, {OPERAND_LVT4}}, 350 /* Get the next iteration from the iterator in op4's local scalar. 351 * Stack: ... => ... value key doneBool */ 352 {"dictDone", 5, 0, 1, {OPERAND_LVT4}}, 353 /* Terminate the iterator in op4's local scalar. */ 354 {"dictUpdateStart", 9, 0, 2, {OPERAND_LVT4, OPERAND_AUX4}}, 355 /* Create the variables (described in the aux data referred to by the 356 * second immediate argument) to mirror the state of the dictionary in 357 * the variable referred to by the first immediate argument. The list 358 * of keys (popped from the stack) must be the same length as the list 359 * of variables. 360 * Stack: ... keyList => ... */ 361 {"dictUpdateEnd", 9, -1, 2, {OPERAND_LVT4, OPERAND_AUX4}}, 362 /* Reflect the state of local variables (described in the aux data 363 * referred to by the second immediate argument) back to the state of 364 * the dictionary in the variable referred to by the first immediate 365 * argument. The list of keys (popped from the stack) must be the same 366 * length as the list of variables. 367 * Stack: ... keyList => ... */ 368 {"jumpTable", 5, -1, 1, {OPERAND_AUX4}}, 369 /* Jump according to the jump-table (in AuxData as indicated by the 370 * operand) and the argument popped from the list. Always executes the 371 * next instruction if no match against the table's entries was found. 372 * Stack: ... value => ... 373 * Note that the jump table contains offsets relative to the PC when 374 * it points to this instruction; the code is relocatable. */ 375 {"upvar", 5, 0, 1, {OPERAND_LVT4}}, 376 /* finds level and otherName in stack, links to local variable at 377 * index op1. Leaves the level on stack. */ 378 {"nsupvar", 5, 0, 1, {OPERAND_LVT4}}, 379 /* finds namespace and otherName in stack, links to local variable at 380 * index op1. Leaves the namespace on stack. */ 381 {"variable", 5, 0, 1, {OPERAND_LVT4}}, 382 /* finds namespace and otherName in stack, links to local variable at 383 * index op1. Leaves the namespace on stack. */ 384 {"syntax", 9, -1, 2, {OPERAND_INT4, OPERAND_UINT4}}, 385 /* Compiled bytecodes to signal syntax error. */ 386 {"reverse", 5, 0, 1, {OPERAND_UINT4}}, 387 /* Reverse the order of the arg elements at the top of stack */ 388 389 {"regexp", 2, -1, 1, {OPERAND_INT1}}, 390 /* Regexp: push (regexp stknext stktop) opnd == nocase */ 391 392 {"existScalar", 5, 1, 1, {OPERAND_LVT4}}, 393 /* Test if scalar variable at index op1 in call frame exists */ 394 {"existArray", 5, 0, 1, {OPERAND_LVT4}}, 395 /* Test if array element exists; array at slot op1, element is 396 * stktop */ 397 {"existArrayStk", 1, -1, 0, {OPERAND_NONE}}, 398 /* Test if array element exists; element is stktop, array name is 399 * stknext */ 400 {"existStk", 1, 0, 0, {OPERAND_NONE}}, 401 /* Test if general variable exists; unparsed variable name is stktop*/ 402 {0} 403}; 404 405/* 406 * Prototypes for procedures defined later in this file: 407 */ 408 409static void DupByteCodeInternalRep(Tcl_Obj *srcPtr, 410 Tcl_Obj *copyPtr); 411static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr, 412 ByteCode *codePtr, unsigned char *startPtr); 413static void EnterCmdExtentData(CompileEnv *envPtr, 414 int cmdNumber, int numSrcBytes, int numCodeBytes); 415static void EnterCmdStartData(CompileEnv *envPtr, 416 int cmdNumber, int srcOffset, int codeOffset); 417static void FreeByteCodeInternalRep(Tcl_Obj *objPtr); 418static int GetCmdLocEncodingSize(CompileEnv *envPtr); 419#ifdef TCL_COMPILE_STATS 420static void RecordByteCodeStats(ByteCode *codePtr); 421#endif /* TCL_COMPILE_STATS */ 422static int SetByteCodeFromAny(Tcl_Interp *interp, 423 Tcl_Obj *objPtr); 424static int FormatInstruction(ByteCode *codePtr, 425 unsigned char *pc, Tcl_Obj *bufferObj); 426static void PrintSourceToObj(Tcl_Obj *appendObj, 427 const char *stringPtr, int maxChars); 428/* 429 * TIP #280: Helper for building the per-word line information of all compiled 430 * commands. 431 */ 432static void EnterCmdWordData(ExtCmdLoc *eclPtr, int srcOffset, 433 Tcl_Token *tokenPtr, const char *cmd, int len, 434 int numWords, int line, int* clNext, int **lines, 435 CompileEnv* envPtr); 436 437/* 438 * The structure below defines the bytecode Tcl object type by means of 439 * procedures that can be invoked by generic object code. 440 */ 441 442Tcl_ObjType tclByteCodeType = { 443 "bytecode", /* name */ 444 FreeByteCodeInternalRep, /* freeIntRepProc */ 445 DupByteCodeInternalRep, /* dupIntRepProc */ 446 NULL, /* updateStringProc */ 447 SetByteCodeFromAny /* setFromAnyProc */ 448}; 449 450/* 451 *---------------------------------------------------------------------- 452 * 453 * TclSetByteCodeFromAny -- 454 * 455 * Part of the bytecode Tcl object type implementation. Attempts to 456 * generate an byte code internal form for the Tcl object "objPtr" by 457 * compiling its string representation. This function also takes a hook 458 * procedure that will be invoked to perform any needed post processing 459 * on the compilation results before generating byte codes. 460 * 461 * Results: 462 * The return value is a standard Tcl object result. If an error occurs 463 * during compilation, an error message is left in the interpreter's 464 * result unless "interp" is NULL. 465 * 466 * Side effects: 467 * Frees the old internal representation. If no error occurs, then the 468 * compiled code is stored as "objPtr"s bytecode representation. Also, if 469 * debugging, initializes the "tcl_traceCompile" Tcl variable used to 470 * trace compilations. 471 * 472 *---------------------------------------------------------------------- 473 */ 474 475int 476TclSetByteCodeFromAny( 477 Tcl_Interp *interp, /* The interpreter for which the code is being 478 * compiled. Must not be NULL. */ 479 Tcl_Obj *objPtr, /* The object to make a ByteCode object. */ 480 CompileHookProc *hookProc, /* Procedure to invoke after compilation. */ 481 ClientData clientData) /* Hook procedure private data. */ 482{ 483 Interp *iPtr = (Interp *) interp; 484 CompileEnv compEnv; /* Compilation environment structure allocated 485 * in frame. */ 486 register AuxData *auxDataPtr; 487 LiteralEntry *entryPtr; 488 register int i; 489 int length, result = TCL_OK; 490 const char *stringPtr; 491 ContLineLoc* clLocPtr; 492 493#ifdef TCL_COMPILE_DEBUG 494 if (!traceInitialized) { 495 if (Tcl_LinkVar(interp, "tcl_traceCompile", 496 (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) { 497 Tcl_Panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable"); 498 } 499 traceInitialized = 1; 500 } 501#endif 502 503 stringPtr = TclGetStringFromObj(objPtr, &length); 504 505 /* 506 * TIP #280: Pick up the CmdFrame in which the BC compiler was invoked and 507 * use to initialize the tracking in the compiler. This information was 508 * stored by TclCompEvalObj and ProcCompileProc. 509 */ 510 511 TclInitCompileEnv(interp, &compEnv, stringPtr, length, 512 iPtr->invokeCmdFramePtr, iPtr->invokeWord); 513 /* 514 * Now we check if we have data about invisible continuation lines for the 515 * script, and make it available to the compile environment, if so. 516 * 517 * It is not clear if the script Tcl_Obj* can be free'd while the compiler 518 * is using it, leading to the release of the associated ContLineLoc 519 * structure as well. To ensure that the latter doesn't happen we set a 520 * lock on it. We release this lock in the function TclFreeCompileEnv (), 521 * found in this file. The "lineCLPtr" hashtable is managed in the file 522 * "tclObj.c". 523 */ 524 525 clLocPtr = TclContinuationsGet (objPtr); 526 if (clLocPtr) { 527 compEnv.clLoc = clLocPtr; 528 compEnv.clNext = &compEnv.clLoc->loc[0]; 529 Tcl_Preserve (compEnv.clLoc); 530 } 531 532 TclCompileScript(interp, stringPtr, length, &compEnv); 533 534 /* 535 * Successful compilation. Add a "done" instruction at the end. 536 */ 537 538 TclEmitOpcode(INST_DONE, &compEnv); 539 540 /* 541 * Invoke the compilation hook procedure if one exists. 542 */ 543 544 if (hookProc) { 545 result = (*hookProc)(interp, &compEnv, clientData); 546 } 547 548 /* 549 * Change the object into a ByteCode object. Ownership of the literal 550 * objects and aux data items is given to the ByteCode object. 551 */ 552 553#ifdef TCL_COMPILE_DEBUG 554 TclVerifyLocalLiteralTable(&compEnv); 555#endif /*TCL_COMPILE_DEBUG*/ 556 557 TclInitByteCodeObj(objPtr, &compEnv); 558#ifdef TCL_COMPILE_DEBUG 559 if (tclTraceCompile >= 2) { 560 TclPrintByteCodeObj(interp, objPtr); 561 fflush(stdout); 562 } 563#endif /* TCL_COMPILE_DEBUG */ 564 565 if (result != TCL_OK) { 566 /* 567 * Handle any error from the hookProc 568 */ 569 570 entryPtr = compEnv.literalArrayPtr; 571 for (i = 0; i < compEnv.literalArrayNext; i++) { 572 TclReleaseLiteral(interp, entryPtr->objPtr); 573 entryPtr++; 574 } 575#ifdef TCL_COMPILE_DEBUG 576 TclVerifyGlobalLiteralTable(iPtr); 577#endif /*TCL_COMPILE_DEBUG*/ 578 579 auxDataPtr = compEnv.auxDataArrayPtr; 580 for (i = 0; i < compEnv.auxDataArrayNext; i++) { 581 if (auxDataPtr->type->freeProc != NULL) { 582 auxDataPtr->type->freeProc(auxDataPtr->clientData); 583 } 584 auxDataPtr++; 585 } 586 } 587 588 TclFreeCompileEnv(&compEnv); 589 return result; 590} 591 592/* 593 *----------------------------------------------------------------------- 594 * 595 * SetByteCodeFromAny -- 596 * 597 * Part of the bytecode Tcl object type implementation. Attempts to 598 * generate an byte code internal form for the Tcl object "objPtr" by 599 * compiling its string representation. 600 * 601 * Results: 602 * The return value is a standard Tcl object result. If an error occurs 603 * during compilation, an error message is left in the interpreter's 604 * result unless "interp" is NULL. 605 * 606 * Side effects: 607 * Frees the old internal representation. If no error occurs, then the 608 * compiled code is stored as "objPtr"s bytecode representation. Also, if 609 * debugging, initializes the "tcl_traceCompile" Tcl variable used to 610 * trace compilations. 611 * 612 *---------------------------------------------------------------------- 613 */ 614 615static int 616SetByteCodeFromAny( 617 Tcl_Interp *interp, /* The interpreter for which the code is being 618 * compiled. Must not be NULL. */ 619 Tcl_Obj *objPtr) /* The object to make a ByteCode object. */ 620{ 621 (void) TclSetByteCodeFromAny(interp, objPtr, NULL, (ClientData) NULL); 622 return TCL_OK; 623} 624 625/* 626 *---------------------------------------------------------------------- 627 * 628 * DupByteCodeInternalRep -- 629 * 630 * Part of the bytecode Tcl object type implementation. However, it does 631 * not copy the internal representation of a bytecode Tcl_Obj, but 632 * instead leaves the new object untyped (with a NULL type pointer). 633 * Code will be compiled for the new object only if necessary. 634 * 635 * Results: 636 * None. 637 * 638 * Side effects: 639 * None. 640 * 641 *---------------------------------------------------------------------- 642 */ 643 644static void 645DupByteCodeInternalRep( 646 Tcl_Obj *srcPtr, /* Object with internal rep to copy. */ 647 Tcl_Obj *copyPtr) /* Object with internal rep to set. */ 648{ 649 return; 650} 651 652/* 653 *---------------------------------------------------------------------- 654 * 655 * FreeByteCodeInternalRep -- 656 * 657 * Part of the bytecode Tcl object type implementation. Frees the storage 658 * associated with a bytecode object's internal representation unless its 659 * code is actively being executed. 660 * 661 * Results: 662 * None. 663 * 664 * Side effects: 665 * The bytecode object's internal rep is marked invalid and its code gets 666 * freed unless the code is actively being executed. In that case the 667 * cleanup is delayed until the last execution of the code completes. 668 * 669 *---------------------------------------------------------------------- 670 */ 671 672static void 673FreeByteCodeInternalRep( 674 register Tcl_Obj *objPtr) /* Object whose internal rep to free. */ 675{ 676 register ByteCode *codePtr = (ByteCode *) 677 objPtr->internalRep.otherValuePtr; 678 679 codePtr->refCount--; 680 if (codePtr->refCount <= 0) { 681 TclCleanupByteCode(codePtr); 682 } 683 objPtr->typePtr = NULL; 684 objPtr->internalRep.otherValuePtr = NULL; 685} 686 687/* 688 *---------------------------------------------------------------------- 689 * 690 * TclCleanupByteCode -- 691 * 692 * This procedure does all the real work of freeing up a bytecode 693 * object's ByteCode structure. It's called only when the structure's 694 * reference count becomes zero. 695 * 696 * Results: 697 * None. 698 * 699 * Side effects: 700 * Frees objPtr's bytecode internal representation and sets its type and 701 * objPtr->internalRep.otherValuePtr NULL. Also releases its literals and 702 * frees its auxiliary data items. 703 * 704 *---------------------------------------------------------------------- 705 */ 706 707void 708TclCleanupByteCode( 709 register ByteCode *codePtr) /* Points to the ByteCode to free. */ 710{ 711 Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle; 712 Interp *iPtr = (Interp *) interp; 713 int numLitObjects = codePtr->numLitObjects; 714 int numAuxDataItems = codePtr->numAuxDataItems; 715 register Tcl_Obj **objArrayPtr, *objPtr; 716 register AuxData *auxDataPtr; 717 int i; 718#ifdef TCL_COMPILE_STATS 719 720 if (interp != NULL) { 721 ByteCodeStats *statsPtr; 722 Tcl_Time destroyTime; 723 int lifetimeSec, lifetimeMicroSec, log2; 724 725 statsPtr = &((Interp *) interp)->stats; 726 727 statsPtr->numByteCodesFreed++; 728 statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes; 729 statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize; 730 731 statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes; 732 statsPtr->currentLitBytes -= (double) 733 codePtr->numLitObjects * sizeof(Tcl_Obj *); 734 statsPtr->currentExceptBytes -= (double) 735 codePtr->numExceptRanges * sizeof(ExceptionRange); 736 statsPtr->currentAuxBytes -= (double) 737 codePtr->numAuxDataItems * sizeof(AuxData); 738 statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes; 739 740 Tcl_GetTime(&destroyTime); 741 lifetimeSec = destroyTime.sec - codePtr->createTime.sec; 742 if (lifetimeSec > 2000) { /* avoid overflow */ 743 lifetimeSec = 2000; 744 } 745 lifetimeMicroSec = 1000000 * lifetimeSec + 746 (destroyTime.usec - codePtr->createTime.usec); 747 748 log2 = TclLog2(lifetimeMicroSec); 749 if (log2 > 31) { 750 log2 = 31; 751 } 752 statsPtr->lifetimeCount[log2]++; 753 } 754#endif /* TCL_COMPILE_STATS */ 755 756 /* 757 * A single heap object holds the ByteCode structure and its code, object, 758 * command location, and auxiliary data arrays. This means we only need to 759 * 1) decrement the ref counts of the LiteralEntry's in its literal array, 760 * 2) call the free procs for the auxiliary data items, 3) free the 761 * localCache if it is unused, and finally 4) free the ByteCode 762 * structure's heap object. 763 * 764 * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes, like 765 * those generated from tbcload) is special, as they doesn't make use of 766 * the global literal table. They instead maintain private references to 767 * their literals which must be decremented. 768 * 769 * In order to insure a proper and efficient cleanup of the literal array 770 * when it contains non-shared literals [Bug 983660], we also distinguish 771 * the case of an interpreter being deleted (signaled by interp == NULL). 772 * Also, as the interp deletion will remove the global literal table 773 * anyway, we avoid the extra cost of updating it for each literal being 774 * released. 775 */ 776 777 if ((codePtr->flags & TCL_BYTECODE_PRECOMPILED) || (interp == NULL)) { 778 779 objArrayPtr = codePtr->objArrayPtr; 780 for (i = 0; i < numLitObjects; i++) { 781 objPtr = *objArrayPtr; 782 if (objPtr) { 783 Tcl_DecrRefCount(objPtr); 784 } 785 objArrayPtr++; 786 } 787 codePtr->numLitObjects = 0; 788 } else { 789 objArrayPtr = codePtr->objArrayPtr; 790 for (i = 0; i < numLitObjects; i++) { 791 /* 792 * TclReleaseLiteral sets a ByteCode's object array entry NULL to 793 * indicate that it has already freed the literal. 794 */ 795 796 objPtr = *objArrayPtr; 797 if (objPtr != NULL) { 798 TclReleaseLiteral(interp, objPtr); 799 } 800 objArrayPtr++; 801 } 802 } 803 804 auxDataPtr = codePtr->auxDataArrayPtr; 805 for (i = 0; i < numAuxDataItems; i++) { 806 if (auxDataPtr->type->freeProc != NULL) { 807 (auxDataPtr->type->freeProc)(auxDataPtr->clientData); 808 } 809 auxDataPtr++; 810 } 811 812 /* 813 * TIP #280. Release the location data associated with this byte code 814 * structure, if any. NOTE: The interp we belong to may be gone already, 815 * and the data with it. 816 * 817 * See also tclBasic.c, DeleteInterpProc 818 */ 819 820 if (iPtr) { 821 Tcl_HashEntry *hePtr = Tcl_FindHashEntry(iPtr->lineBCPtr, 822 (char *) codePtr); 823 if (hePtr) { 824 ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr); 825 int i; 826 827 if (eclPtr->type == TCL_LOCATION_SOURCE) { 828 Tcl_DecrRefCount(eclPtr->path); 829 } 830 for (i=0 ; i<eclPtr->nuloc ; i++) { 831 ckfree((char *) eclPtr->loc[i].line); 832 } 833 834 if (eclPtr->loc != NULL) { 835 ckfree((char *) eclPtr->loc); 836 } 837 838 Tcl_DeleteHashTable (&eclPtr->litInfo); 839 840 ckfree((char *) eclPtr); 841 Tcl_DeleteHashEntry(hePtr); 842 } 843 } 844 845 if (codePtr->localCachePtr && (--codePtr->localCachePtr->refCount == 0)) { 846 TclFreeLocalCache(interp, codePtr->localCachePtr); 847 } 848 849 TclHandleRelease(codePtr->interpHandle); 850 ckfree((char *) codePtr); 851} 852 853/* 854 *---------------------------------------------------------------------- 855 * 856 * TclInitCompileEnv -- 857 * 858 * Initializes a CompileEnv compilation environment structure for the 859 * compilation of a string in an interpreter. 860 * 861 * Results: 862 * None. 863 * 864 * Side effects: 865 * The CompileEnv structure is initialized. 866 * 867 *---------------------------------------------------------------------- 868 */ 869 870void 871TclInitCompileEnv( 872 Tcl_Interp *interp, /* The interpreter for which a CompileEnv 873 * structure is initialized. */ 874 register CompileEnv *envPtr,/* Points to the CompileEnv structure to 875 * initialize. */ 876 const char *stringPtr, /* The source string to be compiled. */ 877 int numBytes, /* Number of bytes in source string. */ 878 const CmdFrame *invoker, /* Location context invoking the bcc */ 879 int word) /* Index of the word in that context getting 880 * compiled */ 881{ 882 Interp *iPtr = (Interp *) interp; 883 884 envPtr->iPtr = iPtr; 885 envPtr->source = stringPtr; 886 envPtr->numSrcBytes = numBytes; 887 envPtr->procPtr = iPtr->compiledProcPtr; 888 iPtr->compiledProcPtr = NULL; 889 envPtr->numCommands = 0; 890 envPtr->exceptDepth = 0; 891 envPtr->maxExceptDepth = 0; 892 envPtr->maxStackDepth = 0; 893 envPtr->currStackDepth = 0; 894 TclInitLiteralTable(&(envPtr->localLitTable)); 895 896 envPtr->codeStart = envPtr->staticCodeSpace; 897 envPtr->codeNext = envPtr->codeStart; 898 envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES); 899 envPtr->mallocedCodeArray = 0; 900 901 envPtr->literalArrayPtr = envPtr->staticLiteralSpace; 902 envPtr->literalArrayNext = 0; 903 envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS; 904 envPtr->mallocedLiteralArray = 0; 905 906 envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace; 907 envPtr->exceptArrayNext = 0; 908 envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES; 909 envPtr->mallocedExceptArray = 0; 910 911 envPtr->cmdMapPtr = envPtr->staticCmdMapSpace; 912 envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE; 913 envPtr->mallocedCmdMap = 0; 914 envPtr->atCmdStart = 1; 915 916 /* 917 * TIP #280: Set up the extended command location information, based on 918 * the context invoking the byte code compiler. This structure is used to 919 * keep the per-word line information for all compiled commands. 920 * 921 * See also tclBasic.c, TclEvalObjEx, for the equivalent code in the 922 * non-compiling evaluator 923 */ 924 925 envPtr->extCmdMapPtr = (ExtCmdLoc *) ckalloc(sizeof(ExtCmdLoc)); 926 envPtr->extCmdMapPtr->loc = NULL; 927 envPtr->extCmdMapPtr->nloc = 0; 928 envPtr->extCmdMapPtr->nuloc = 0; 929 envPtr->extCmdMapPtr->path = NULL; 930 Tcl_InitHashTable(&envPtr->extCmdMapPtr->litInfo, TCL_ONE_WORD_KEYS); 931 932 if (invoker == NULL || 933 (invoker->type == TCL_LOCATION_EVAL_LIST)) { 934 /* 935 * Initialize the compiler for relative counting in case of a 936 * dynamic context. 937 */ 938 939 envPtr->line = 1; 940 envPtr->extCmdMapPtr->type = 941 (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); 942 } else { 943 /* 944 * Initialize the compiler using the context, making counting absolute 945 * to that context. Note that the context can be byte code execution. 946 * In that case we have to fill out the missing pieces (line, path, 947 * ...) which may make change the type as well. 948 */ 949 950 CmdFrame* ctxPtr = (CmdFrame *) TclStackAlloc(interp, sizeof(CmdFrame)); 951 int pc = 0; 952 953 *ctxPtr = *invoker; 954 955 if (invoker->type == TCL_LOCATION_BC) { 956 /* 957 * Note: Type BC => ctx.data.eval.path is not used. 958 * ctx.data.tebc.codePtr is used instead. 959 */ 960 961 TclGetSrcInfoForPc(ctxPtr); 962 pc = 1; 963 } 964 965 if ((ctxPtr->nline <= word) || (ctxPtr->line[word] < 0)) { 966 /* 967 * Word is not a literal, relative counting. 968 */ 969 970 envPtr->line = 1; 971 envPtr->extCmdMapPtr->type = 972 (envPtr->procPtr ? TCL_LOCATION_PROC : TCL_LOCATION_BC); 973 974 if (pc && (ctxPtr->type == TCL_LOCATION_SOURCE)) { 975 /* 976 * The reference made by 'TclGetSrcInfoForPc' is dead. 977 */ 978 Tcl_DecrRefCount(ctxPtr->data.eval.path); 979 } 980 } else { 981 envPtr->line = ctxPtr->line[word]; 982 envPtr->extCmdMapPtr->type = ctxPtr->type; 983 984 if (ctxPtr->type == TCL_LOCATION_SOURCE) { 985 envPtr->extCmdMapPtr->path = ctxPtr->data.eval.path; 986 987 if (pc) { 988 /* 989 * The reference 'TclGetSrcInfoForPc' made is transfered. 990 */ 991 992 ctxPtr->data.eval.path = NULL; 993 } else { 994 /* 995 * We have a new reference here. 996 */ 997 998 Tcl_IncrRefCount(ctxPtr->data.eval.path); 999 } 1000 } 1001 } 1002 1003 TclStackFree(interp, ctxPtr); 1004 } 1005 1006 envPtr->extCmdMapPtr->start = envPtr->line; 1007 1008 /* 1009 * Initialize the data about invisible continuation lines as empty, 1010 * i.e. not used. The caller (TclSetByteCodeFromAny) will set this up, if 1011 * such data is available. 1012 */ 1013 1014 envPtr->clLoc = NULL; 1015 envPtr->clNext = NULL; 1016 1017 envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace; 1018 envPtr->auxDataArrayNext = 0; 1019 envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE; 1020 envPtr->mallocedAuxDataArray = 0; 1021} 1022 1023/* 1024 *---------------------------------------------------------------------- 1025 * 1026 * TclFreeCompileEnv -- 1027 * 1028 * Free the storage allocated in a CompileEnv compilation environment 1029 * structure. 1030 * 1031 * Results: 1032 * None. 1033 * 1034 * Side effects: 1035 * Allocated storage in the CompileEnv structure is freed. Note that its 1036 * local literal table is not deleted and its literal objects are not 1037 * released. In addition, storage referenced by its auxiliary data items 1038 * is not freed. This is done so that, when compilation is successful, 1039 * "ownership" of these objects and aux data items is handed over to the 1040 * corresponding ByteCode structure. 1041 * 1042 *---------------------------------------------------------------------- 1043 */ 1044 1045void 1046TclFreeCompileEnv( 1047 register CompileEnv *envPtr)/* Points to the CompileEnv structure. */ 1048{ 1049 if (envPtr->localLitTable.buckets != envPtr->localLitTable.staticBuckets) { 1050 ckfree((char *) envPtr->localLitTable.buckets); 1051 envPtr->localLitTable.buckets = envPtr->localLitTable.staticBuckets; 1052 } 1053 if (envPtr->mallocedCodeArray) { 1054 ckfree((char *) envPtr->codeStart); 1055 } 1056 if (envPtr->mallocedLiteralArray) { 1057 ckfree((char *) envPtr->literalArrayPtr); 1058 } 1059 if (envPtr->mallocedExceptArray) { 1060 ckfree((char *) envPtr->exceptArrayPtr); 1061 } 1062 if (envPtr->mallocedCmdMap) { 1063 ckfree((char *) envPtr->cmdMapPtr); 1064 } 1065 if (envPtr->mallocedAuxDataArray) { 1066 ckfree((char *) envPtr->auxDataArrayPtr); 1067 } 1068 if (envPtr->extCmdMapPtr) { 1069 ckfree((char *) envPtr->extCmdMapPtr); 1070 } 1071 1072 /* 1073 * If we used data about invisible continuation lines, then now is the 1074 * time to release on our hold on it. The lock was set in function 1075 * TclSetByteCodeFromAny(), found in this file. 1076 */ 1077 1078 if (envPtr->clLoc) { 1079 Tcl_Release (envPtr->clLoc); 1080 } 1081} 1082 1083/* 1084 *---------------------------------------------------------------------- 1085 * 1086 * TclWordKnownAtCompileTime -- 1087 * 1088 * Test whether the value of a token is completely known at compile time. 1089 * 1090 * Results: 1091 * Returns true if the tokenPtr argument points to a word value that is 1092 * completely known at compile time. Generally, values that are known at 1093 * compile time can be compiled to their values, while values that cannot 1094 * be known until substitution at runtime must be compiled to bytecode 1095 * instructions that perform that substitution. For several commands, 1096 * whether or not arguments are known at compile time determine whether 1097 * it is worthwhile to compile at all. 1098 * 1099 * Side effects: 1100 * When returning true, appends the known value of the word to the 1101 * unshared Tcl_Obj (*valuePtr), unless valuePtr is NULL. 1102 * 1103 *---------------------------------------------------------------------- 1104 */ 1105 1106int 1107TclWordKnownAtCompileTime( 1108 Tcl_Token *tokenPtr, /* Points to Tcl_Token we should check */ 1109 Tcl_Obj *valuePtr) /* If not NULL, points to an unshared Tcl_Obj 1110 * to which we should append the known value 1111 * of the word. */ 1112{ 1113 int numComponents = tokenPtr->numComponents; 1114 Tcl_Obj *tempPtr = NULL; 1115 1116 if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) { 1117 if (valuePtr != NULL) { 1118 Tcl_AppendToObj(valuePtr, tokenPtr[1].start, tokenPtr[1].size); 1119 } 1120 return 1; 1121 } 1122 if (tokenPtr->type != TCL_TOKEN_WORD) { 1123 return 0; 1124 } 1125 tokenPtr++; 1126 if (valuePtr != NULL) { 1127 tempPtr = Tcl_NewObj(); 1128 Tcl_IncrRefCount(tempPtr); 1129 } 1130 while (numComponents--) { 1131 switch (tokenPtr->type) { 1132 case TCL_TOKEN_TEXT: 1133 if (tempPtr != NULL) { 1134 Tcl_AppendToObj(tempPtr, tokenPtr->start, tokenPtr->size); 1135 } 1136 break; 1137 1138 case TCL_TOKEN_BS: 1139 if (tempPtr != NULL) { 1140 char utfBuf[TCL_UTF_MAX]; 1141 int length = Tcl_UtfBackslash(tokenPtr->start, NULL, utfBuf); 1142 Tcl_AppendToObj(tempPtr, utfBuf, length); 1143 } 1144 break; 1145 1146 default: 1147 if (tempPtr != NULL) { 1148 Tcl_DecrRefCount(tempPtr); 1149 } 1150 return 0; 1151 } 1152 tokenPtr++; 1153 } 1154 if (valuePtr != NULL) { 1155 Tcl_AppendObjToObj(valuePtr, tempPtr); 1156 Tcl_DecrRefCount(tempPtr); 1157 } 1158 return 1; 1159} 1160 1161/* 1162 *---------------------------------------------------------------------- 1163 * 1164 * TclCompileScript -- 1165 * 1166 * Compile a Tcl script in a string. 1167 * 1168 * Results: 1169 * The return value is TCL_OK on a successful compilation and TCL_ERROR 1170 * on failure. If TCL_ERROR is returned, then the interpreter's result 1171 * contains an error message. 1172 * 1173 * Side effects: 1174 * Adds instructions to envPtr to evaluate the script at runtime. 1175 * 1176 *---------------------------------------------------------------------- 1177 */ 1178 1179void 1180TclCompileScript( 1181 Tcl_Interp *interp, /* Used for error and status reporting. Also 1182 * serves as context for finding and compiling 1183 * commands. May not be NULL. */ 1184 const char *script, /* The source script to compile. */ 1185 int numBytes, /* Number of bytes in script. If < 0, the 1186 * script consists of all bytes up to the 1187 * first null character. */ 1188 CompileEnv *envPtr) /* Holds resulting instructions. */ 1189{ 1190 Interp *iPtr = (Interp *) interp; 1191 int lastTopLevelCmdIndex = -1; 1192 /* Index of most recent toplevel command in 1193 * the command location table. Initialized to 1194 * avoid compiler warning. */ 1195 int startCodeOffset = -1; /* Offset of first byte of current command's 1196 * code. Init. to avoid compiler warning. */ 1197 unsigned char *entryCodeNext = envPtr->codeNext; 1198 const char *p, *next; 1199 Namespace *cmdNsPtr; 1200 Command *cmdPtr; 1201 Tcl_Token *tokenPtr; 1202 int bytesLeft, isFirstCmd, wordIdx, currCmdIndex; 1203 int commandLength, objIndex; 1204 Tcl_DString ds; 1205 /* TIP #280 */ 1206 ExtCmdLoc *eclPtr = envPtr->extCmdMapPtr; 1207 int *wlines, wlineat, cmdLine; 1208 int* clNext; 1209 Tcl_Parse *parsePtr = (Tcl_Parse *) 1210 TclStackAlloc(interp, sizeof(Tcl_Parse)); 1211 1212 Tcl_DStringInit(&ds); 1213 1214 if (numBytes < 0) { 1215 numBytes = strlen(script); 1216 } 1217 Tcl_ResetResult(interp); 1218 isFirstCmd = 1; 1219 1220 if (envPtr->procPtr != NULL) { 1221 cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr; 1222 } else { 1223 cmdNsPtr = NULL; /* use current NS */ 1224 } 1225 1226 /* 1227 * Each iteration through the following loop compiles the next command 1228 * from the script. 1229 */ 1230 1231 p = script; 1232 bytesLeft = numBytes; 1233 cmdLine = envPtr->line; 1234 clNext = envPtr->clNext; 1235 do { 1236 if (Tcl_ParseCommand(interp, p, bytesLeft, 0, parsePtr) != TCL_OK) { 1237 /* 1238 * Compile bytecodes to report the parse error at runtime. 1239 */ 1240 1241 Tcl_LogCommandInfo(interp, script, parsePtr->commandStart, 1242 /* Drop the command terminator (";","]") if appropriate */ 1243 (parsePtr->term == 1244 parsePtr->commandStart + parsePtr->commandSize - 1)? 1245 parsePtr->commandSize - 1 : parsePtr->commandSize); 1246 TclCompileSyntaxError(interp, envPtr); 1247 break; 1248 } 1249 if (parsePtr->numWords > 0) { 1250 int expand = 0; /* Set if there are dynamic expansions to 1251 * handle */ 1252 1253 /* 1254 * If not the first command, pop the previous command's result 1255 * and, if we're compiling a top level command, update the last 1256 * command's code size to account for the pop instruction. 1257 */ 1258 1259 if (!isFirstCmd) { 1260 TclEmitOpcode(INST_POP, envPtr); 1261 envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes = 1262 (envPtr->codeNext - envPtr->codeStart) 1263 - startCodeOffset; 1264 } 1265 1266 /* 1267 * Determine the actual length of the command. 1268 */ 1269 1270 commandLength = parsePtr->commandSize; 1271 if (parsePtr->term == parsePtr->commandStart + commandLength - 1) { 1272 /* 1273 * The command terminator character (such as ; or ]) is the 1274 * last character in the parsed command. Reduce the length by 1275 * one so that the trace message doesn't include the 1276 * terminator character. 1277 */ 1278 1279 commandLength -= 1; 1280 } 1281 1282#ifdef TCL_COMPILE_DEBUG 1283 /* 1284 * If tracing, print a line for each top level command compiled. 1285 */ 1286 1287 if ((tclTraceCompile >= 1) && (envPtr->procPtr == NULL)) { 1288 fprintf(stdout, " Compiling: "); 1289 TclPrintSource(stdout, parsePtr->commandStart, 1290 TclMin(commandLength, 55)); 1291 fprintf(stdout, "\n"); 1292 } 1293#endif 1294 1295 /* 1296 * Check whether expansion has been requested for any of the 1297 * words. 1298 */ 1299 1300 for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; 1301 wordIdx < parsePtr->numWords; 1302 wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) { 1303 if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { 1304 expand = 1; 1305 break; 1306 } 1307 } 1308 1309 envPtr->numCommands++; 1310 currCmdIndex = (envPtr->numCommands - 1); 1311 lastTopLevelCmdIndex = currCmdIndex; 1312 startCodeOffset = (envPtr->codeNext - envPtr->codeStart); 1313 EnterCmdStartData(envPtr, currCmdIndex, 1314 parsePtr->commandStart - envPtr->source, startCodeOffset); 1315 1316 /* 1317 * Should only start issuing instructions after the "command has 1318 * started" so that the command range is correct in the bytecode. 1319 */ 1320 1321 if (expand) { 1322 TclEmitOpcode(INST_EXPAND_START, envPtr); 1323 } 1324 1325 /* 1326 * TIP #280. Scan the words and compute the extended location 1327 * information. The map first contain full per-word line 1328 * information for use by the compiler. This is later replaced by 1329 * a reduced form which signals non-literal words, stored in 1330 * 'wlines'. 1331 */ 1332 1333 TclAdvanceLines(&cmdLine, p, parsePtr->commandStart); 1334 TclAdvanceContinuations (&cmdLine, &clNext, 1335 parsePtr->commandStart - envPtr->source); 1336 EnterCmdWordData(eclPtr, parsePtr->commandStart - envPtr->source, 1337 parsePtr->tokenPtr, parsePtr->commandStart, 1338 parsePtr->commandSize, parsePtr->numWords, cmdLine, 1339 clNext, &wlines, envPtr); 1340 wlineat = eclPtr->nuloc - 1; 1341 1342 /* 1343 * Each iteration of the following loop compiles one word from the 1344 * command. 1345 */ 1346 1347 for (wordIdx = 0, tokenPtr = parsePtr->tokenPtr; 1348 wordIdx < parsePtr->numWords; wordIdx++, 1349 tokenPtr += (tokenPtr->numComponents + 1)) { 1350 1351 envPtr->line = eclPtr->loc[wlineat].line[wordIdx]; 1352 envPtr->clNext = eclPtr->loc [wlineat].next [wordIdx]; 1353 1354 if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { 1355 /* 1356 * The word is not a simple string of characters. 1357 */ 1358 1359 TclCompileTokens(interp, tokenPtr+1, 1360 tokenPtr->numComponents, envPtr); 1361 if (tokenPtr->type == TCL_TOKEN_EXPAND_WORD) { 1362 TclEmitInstInt4(INST_EXPAND_STKTOP, 1363 envPtr->currStackDepth, envPtr); 1364 } 1365 continue; 1366 } 1367 1368 /* 1369 * This is a simple string of literal characters (i.e. we know 1370 * it absolutely and can use it directly). If this is the 1371 * first word and the command has a compile procedure, let it 1372 * compile the command. 1373 */ 1374 1375 if ((wordIdx == 0) && !expand) { 1376 /* 1377 * We copy the string before trying to find the command by 1378 * name. We used to modify the string in place, but this 1379 * is not safe because the name resolution handlers could 1380 * have side effects that rely on the unmodified string. 1381 */ 1382 1383 Tcl_DStringSetLength(&ds, 0); 1384 Tcl_DStringAppend(&ds, tokenPtr[1].start,tokenPtr[1].size); 1385 1386 cmdPtr = (Command *) Tcl_FindCommand(interp, 1387 Tcl_DStringValue(&ds), 1388 (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0); 1389 1390 if ((cmdPtr != NULL) 1391 && (cmdPtr->compileProc != NULL) 1392 && !(cmdPtr->flags & CMD_HAS_EXEC_TRACES) 1393 && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) { 1394 int savedNumCmds = envPtr->numCommands; 1395 unsigned savedCodeNext = 1396 envPtr->codeNext - envPtr->codeStart; 1397 int update = 0, code; 1398 1399 /* 1400 * Mark the start of the command; the proper bytecode 1401 * length will be updated later. There is no need to 1402 * do this for the first bytecode in the compile env, 1403 * as the check is done before calling 1404 * TclExecuteByteCode(). Do emit an INST_START_CMD in 1405 * special cases where the first bytecode is in a 1406 * loop, to insure that the corresponding command is 1407 * counted properly. Compilers for commands able to 1408 * produce such a beast (currently 'while 1' only) set 1409 * envPtr->atCmdStart to 0 in order to signal this 1410 * case. [Bug 1752146] 1411 * 1412 * Note that the environment is initialised with 1413 * atCmdStart=1 to avoid emitting ISC for the first 1414 * command. 1415 */ 1416 1417 if (envPtr->atCmdStart) { 1418 if (savedCodeNext != 0) { 1419 /* 1420 * Increase the number of commands being 1421 * started at the current point. Note that 1422 * this depends on the exact layout of the 1423 * INST_START_CMD's operands, so be careful! 1424 */ 1425 1426 unsigned char *fixPtr = envPtr->codeNext - 4; 1427 1428 TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)+1, 1429 fixPtr); 1430 } 1431 } else { 1432 TclEmitInstInt4(INST_START_CMD, 0, envPtr); 1433 TclEmitInt4(1, envPtr); 1434 update = 1; 1435 } 1436 1437 code = (cmdPtr->compileProc)(interp, parsePtr, 1438 cmdPtr, envPtr); 1439 1440 if (code == TCL_OK) { 1441 if (update) { 1442 /* 1443 * Fix the bytecode length. 1444 */ 1445 1446 unsigned char *fixPtr = envPtr->codeStart 1447 + savedCodeNext + 1; 1448 unsigned fixLen = envPtr->codeNext 1449 - envPtr->codeStart - savedCodeNext; 1450 1451 TclStoreInt4AtPtr(fixLen, fixPtr); 1452 } 1453 goto finishCommand; 1454 } else { 1455 if (envPtr->atCmdStart && savedCodeNext != 0) { 1456 /* 1457 * Decrease the number of commands being 1458 * started at the current point. Note that 1459 * this depends on the exact layout of the 1460 * INST_START_CMD's operands, so be careful! 1461 */ 1462 1463 unsigned char *fixPtr = envPtr->codeNext - 4; 1464 1465 TclStoreInt4AtPtr(TclGetUInt4AtPtr(fixPtr)-1, 1466 fixPtr); 1467 } 1468 1469 /* 1470 * Restore numCommands and codeNext to their 1471 * correct values, removing any commands compiled 1472 * before the failure to produce bytecode got 1473 * reported. [Bugs 705406 and 735055] 1474 */ 1475 1476 envPtr->numCommands = savedNumCmds; 1477 envPtr->codeNext = envPtr->codeStart+savedCodeNext; 1478 } 1479 } 1480 1481 /* 1482 * No compile procedure so push the word. If the command 1483 * was found, push a CmdName object to reduce runtime 1484 * lookups. Avoid sharing this literal among different 1485 * namespaces to reduce shimmering. 1486 */ 1487 1488 objIndex = TclRegisterNewNSLiteral(envPtr, 1489 tokenPtr[1].start, tokenPtr[1].size); 1490 if (cmdPtr != NULL) { 1491 TclSetCmdNameObj(interp, 1492 envPtr->literalArrayPtr[objIndex].objPtr,cmdPtr); 1493 } 1494 if ((wordIdx == 0) && (parsePtr->numWords == 1)) { 1495 /* 1496 * Single word script: unshare the command name to 1497 * avoid shimmering between bytecode and cmdName 1498 * representations [Bug 458361] 1499 */ 1500 1501 TclHideLiteral(interp, envPtr, objIndex); 1502 } 1503 } else { 1504 /* 1505 * Simple argument word of a command. We reach this if and 1506 * only if the command word was not compiled for whatever 1507 * reason. Register the literal's location for use by 1508 * uplevel, etc. commands, should they encounter it 1509 * unmodified. We care only if the we are in a context 1510 * which already allows absolute counting. 1511 */ 1512 objIndex = TclRegisterNewLiteral(envPtr, 1513 tokenPtr[1].start, tokenPtr[1].size); 1514 1515 if (envPtr->clNext) { 1516 TclContinuationsEnterDerived (envPtr->literalArrayPtr[objIndex].objPtr, 1517 tokenPtr[1].start - envPtr->source, 1518 eclPtr->loc [wlineat].next [wordIdx]); 1519 } 1520 } 1521 TclEmitPush(objIndex, envPtr); 1522 } /* for loop */ 1523 1524 /* 1525 * Emit an invoke instruction for the command. We skip this if a 1526 * compile procedure was found for the command. 1527 */ 1528 1529 if (expand) { 1530 /* 1531 * The stack depth during argument expansion can only be 1532 * managed at runtime, as the number of elements in the 1533 * expanded lists is not known at compile time. We adjust here 1534 * the stack depth estimate so that it is correct after the 1535 * command with expanded arguments returns. 1536 * 1537 * The end effect of this command's invocation is that all the 1538 * words of the command are popped from the stack, and the 1539 * result is pushed: the stack top changes by (1-wordIdx). 1540 * 1541 * Note that the estimates are not correct while the command 1542 * is being prepared and run, INST_EXPAND_STKTOP is not 1543 * stack-neutral in general. 1544 */ 1545 1546 TclEmitOpcode(INST_INVOKE_EXPANDED, envPtr); 1547 TclAdjustStackDepth((1-wordIdx), envPtr); 1548 } else if (wordIdx > 0) { 1549 /* 1550 * Save PC -> command map for the TclArgumentBC* functions. 1551 */ 1552 1553 int isnew; 1554 Tcl_HashEntry* hePtr = Tcl_CreateHashEntry(&eclPtr->litInfo, 1555 (char*) (envPtr->codeNext - envPtr->codeStart), &isnew); 1556 Tcl_SetHashValue(hePtr, INT2PTR(wlineat)); 1557 1558 if (wordIdx <= 255) { 1559 TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr); 1560 } else { 1561 TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr); 1562 } 1563 } 1564 1565 /* 1566 * Update the compilation environment structure and record the 1567 * offsets of the source and code for the command. 1568 */ 1569 1570 finishCommand: 1571 EnterCmdExtentData(envPtr, currCmdIndex, commandLength, 1572 (envPtr->codeNext-envPtr->codeStart) - startCodeOffset); 1573 isFirstCmd = 0; 1574 1575 /* 1576 * TIP #280: Free full form of per-word line data and insert the 1577 * reduced form now 1578 */ 1579 1580 ckfree((char *) eclPtr->loc[wlineat].line); 1581 ckfree((char *) eclPtr->loc[wlineat].next); 1582 eclPtr->loc[wlineat].line = wlines; 1583 eclPtr->loc[wlineat].next = NULL; 1584 } /* end if parsePtr->numWords > 0 */ 1585 1586 /* 1587 * Advance to the next command in the script. 1588 */ 1589 1590 next = parsePtr->commandStart + parsePtr->commandSize; 1591 bytesLeft -= next - p; 1592 p = next; 1593 1594 /* 1595 * TIP #280: Track lines in the just compiled command. 1596 */ 1597 1598 TclAdvanceLines(&cmdLine, parsePtr->commandStart, p); 1599 TclAdvanceContinuations (&cmdLine, &clNext, p - envPtr->source); 1600 Tcl_FreeParse(parsePtr); 1601 } while (bytesLeft > 0); 1602 1603 /* 1604 * If the source script yielded no instructions (e.g., if it was empty), 1605 * push an empty string as the command's result. 1606 * 1607 * WARNING: push an unshared object! If the script being compiled is a 1608 * shared empty string, it will otherwise be self-referential and cause 1609 * difficulties with literal management [Bugs 467523, 983660]. We used to 1610 * have special code in TclReleaseLiteral to handle this particular 1611 * self-reference, but now opt for avoiding its creation altogether. 1612 */ 1613 1614 if (envPtr->codeNext == entryCodeNext) { 1615 TclEmitPush(TclAddLiteralObj(envPtr, Tcl_NewObj(), NULL), envPtr); 1616 } 1617 1618 envPtr->numSrcBytes = (p - script); 1619 TclStackFree(interp, parsePtr); 1620 Tcl_DStringFree(&ds); 1621} 1622 1623/* 1624 *---------------------------------------------------------------------- 1625 * 1626 * TclCompileTokens -- 1627 * 1628 * Given an array of tokens parsed from a Tcl command (e.g., the tokens 1629 * that make up a word) this procedure emits instructions to evaluate the 1630 * tokens and concatenate their values to form a single result value on 1631 * the interpreter's runtime evaluation stack. 1632 * 1633 * Results: 1634 * The return value is a standard Tcl result. If an error occurs, an 1635 * error message is left in the interpreter's result. 1636 * 1637 * Side effects: 1638 * Instructions are added to envPtr to push and evaluate the tokens at 1639 * runtime. 1640 * 1641 *---------------------------------------------------------------------- 1642 */ 1643 1644void 1645TclCompileTokens( 1646 Tcl_Interp *interp, /* Used for error and status reporting. */ 1647 Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens to 1648 * compile. */ 1649 int count, /* Number of tokens to consider at tokenPtr. 1650 * Must be at least 1. */ 1651 CompileEnv *envPtr) /* Holds the resulting instructions. */ 1652{ 1653 Tcl_DString textBuffer; /* Holds concatenated chars from adjacent 1654 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */ 1655 char buffer[TCL_UTF_MAX]; 1656 const char *name, *p; 1657 int numObjsToConcat, nameBytes, localVarName, localVar; 1658 int length, i; 1659 unsigned char *entryCodeNext = envPtr->codeNext; 1660#define NUM_STATIC_POS 20 1661 int isLiteral, maxNumCL, numCL; 1662 int* clPosition = NULL; 1663 1664 /* 1665 * For the handling of continuation lines in literals we first check if 1666 * this is actually a literal. For if not we can forego the additional 1667 * processing. Otherwise we pre-allocate a small table to store the 1668 * locations of all continuation lines we find in this literal, if 1669 * any. The table is extended if needed. 1670 * 1671 * Note: Different to the equivalent code in function 1672 * 'EvalTokensStandard()' (see file "tclBasic.c") we do not seem to need 1673 * the 'adjust' variable. We also do not seem to need code which merges 1674 * continuation line information of multiple words which concat'd at 1675 * runtime. Either that or I have not managed to find a test case for 1676 * these two possibilities yet. It might be a difference between compile- 1677 * versus runtime processing. 1678 */ 1679 1680 numCL = 0; 1681 maxNumCL = 0; 1682 isLiteral = 1; 1683 for (i=0 ; i < count; i++) { 1684 if ((tokenPtr[i].type != TCL_TOKEN_TEXT) && 1685 (tokenPtr[i].type != TCL_TOKEN_BS)) { 1686 isLiteral = 0; 1687 break; 1688 } 1689 } 1690 1691 if (isLiteral) { 1692 maxNumCL = NUM_STATIC_POS; 1693 clPosition = (int*) ckalloc (maxNumCL*sizeof(int)); 1694 } 1695 1696 Tcl_DStringInit(&textBuffer); 1697 numObjsToConcat = 0; 1698 for ( ; count > 0; count--, tokenPtr++) { 1699 switch (tokenPtr->type) { 1700 case TCL_TOKEN_TEXT: 1701 Tcl_DStringAppend(&textBuffer, tokenPtr->start, tokenPtr->size); 1702 break; 1703 1704 case TCL_TOKEN_BS: 1705 length = Tcl_UtfBackslash(tokenPtr->start, NULL, buffer); 1706 Tcl_DStringAppend(&textBuffer, buffer, length); 1707 1708 /* 1709 * If the backslash sequence we found is in a literal, and 1710 * represented a continuation line, we compute and store its 1711 * location (as char offset to the beginning of the _result_ 1712 * script). We may have to extend the table of locations. 1713 * 1714 * Note that the continuation line information is relevant even if 1715 * the word we are processing is not a literal, as it can affect 1716 * nested commands. See the branch for TCL_TOKEN_COMMAND below, 1717 * where the adjustment we are tracking here is taken into 1718 * account. The good thing is that we do not need a table of 1719 * everything, just the number of lines we have to add as 1720 * correction. 1721 */ 1722 1723 if ((length == 1) && (buffer[0] == ' ') && 1724 (tokenPtr->start[1] == '\n')) { 1725 if (isLiteral) { 1726 int clPos = Tcl_DStringLength (&textBuffer); 1727 1728 if (numCL >= maxNumCL) { 1729 maxNumCL *= 2; 1730 clPosition = (int*) ckrealloc ((char*)clPosition, 1731 maxNumCL*sizeof(int)); 1732 } 1733 clPosition[numCL] = clPos; 1734 numCL ++; 1735 } 1736 } 1737 break; 1738 1739 case TCL_TOKEN_COMMAND: 1740 /* 1741 * Push any accumulated chars appearing before the command. 1742 */ 1743 1744 if (Tcl_DStringLength(&textBuffer) > 0) { 1745 int literal = TclRegisterNewLiteral(envPtr, 1746 Tcl_DStringValue(&textBuffer), 1747 Tcl_DStringLength(&textBuffer)); 1748 1749 TclEmitPush(literal, envPtr); 1750 numObjsToConcat++; 1751 Tcl_DStringFree(&textBuffer); 1752 1753 if (numCL) { 1754 TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, 1755 numCL, clPosition); 1756 } 1757 numCL = 0; 1758 } 1759 1760 TclCompileScript(interp, tokenPtr->start+1, 1761 tokenPtr->size-2, envPtr); 1762 numObjsToConcat++; 1763 break; 1764 1765 case TCL_TOKEN_VARIABLE: 1766 /* 1767 * Push any accumulated chars appearing before the $<var>. 1768 */ 1769 1770 if (Tcl_DStringLength(&textBuffer) > 0) { 1771 int literal; 1772 1773 literal = TclRegisterNewLiteral(envPtr, 1774 Tcl_DStringValue(&textBuffer), 1775 Tcl_DStringLength(&textBuffer)); 1776 TclEmitPush(literal, envPtr); 1777 numObjsToConcat++; 1778 Tcl_DStringFree(&textBuffer); 1779 } 1780 1781 /* 1782 * Determine how the variable name should be handled: if it 1783 * contains any namespace qualifiers it is not a local variable 1784 * (localVarName=-1); if it looks like an array element and the 1785 * token has a single component, it should not be created here 1786 * [Bug 569438] (localVarName=0); otherwise, the local variable 1787 * can safely be created (localVarName=1). 1788 */ 1789 1790 name = tokenPtr[1].start; 1791 nameBytes = tokenPtr[1].size; 1792 localVarName = -1; 1793 if (envPtr->procPtr != NULL) { 1794 localVarName = 1; 1795 for (i = 0, p = name; i < nameBytes; i++, p++) { 1796 if ((*p == ':') && (i < nameBytes-1) && (*(p+1) == ':')) { 1797 localVarName = -1; 1798 break; 1799 } else if ((*p == '(') 1800 && (tokenPtr->numComponents == 1) 1801 && (*(name + nameBytes - 1) == ')')) { 1802 localVarName = 0; 1803 break; 1804 } 1805 } 1806 } 1807 1808 /* 1809 * Either push the variable's name, or find its index in the array 1810 * of local variables in a procedure frame. 1811 */ 1812 1813 localVar = -1; 1814 if (localVarName != -1) { 1815 localVar = TclFindCompiledLocal(name, nameBytes, localVarName, 1816 envPtr->procPtr); 1817 } 1818 if (localVar < 0) { 1819 TclEmitPush(TclRegisterNewLiteral(envPtr, name, nameBytes), 1820 envPtr); 1821 } 1822 1823 /* 1824 * Emit instructions to load the variable. 1825 */ 1826 1827 if (tokenPtr->numComponents == 1) { 1828 if (localVar < 0) { 1829 TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr); 1830 } else if (localVar <= 255) { 1831 TclEmitInstInt1(INST_LOAD_SCALAR1, localVar, envPtr); 1832 } else { 1833 TclEmitInstInt4(INST_LOAD_SCALAR4, localVar, envPtr); 1834 } 1835 } else { 1836 TclCompileTokens(interp, tokenPtr+2, 1837 tokenPtr->numComponents-1, envPtr); 1838 if (localVar < 0) { 1839 TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr); 1840 } else if (localVar <= 255) { 1841 TclEmitInstInt1(INST_LOAD_ARRAY1, localVar, envPtr); 1842 } else { 1843 TclEmitInstInt4(INST_LOAD_ARRAY4, localVar, envPtr); 1844 } 1845 } 1846 numObjsToConcat++; 1847 count -= tokenPtr->numComponents; 1848 tokenPtr += tokenPtr->numComponents; 1849 break; 1850 1851 default: 1852 Tcl_Panic("Unexpected token type in TclCompileTokens: %d; %.*s", 1853 tokenPtr->type, tokenPtr->size, tokenPtr->start); 1854 } 1855 } 1856 1857 /* 1858 * Push any accumulated characters appearing at the end. 1859 */ 1860 1861 if (Tcl_DStringLength(&textBuffer) > 0) { 1862 int literal; 1863 1864 literal = TclRegisterNewLiteral(envPtr, Tcl_DStringValue(&textBuffer), 1865 Tcl_DStringLength(&textBuffer)); 1866 TclEmitPush(literal, envPtr); 1867 numObjsToConcat++; 1868 1869 if (numCL) { 1870 TclContinuationsEnter(envPtr->literalArrayPtr[literal].objPtr, 1871 numCL, clPosition); 1872 } 1873 numCL = 0; 1874 } 1875 1876 /* 1877 * If necessary, concatenate the parts of the word. 1878 */ 1879 1880 while (numObjsToConcat > 255) { 1881 TclEmitInstInt1(INST_CONCAT1, 255, envPtr); 1882 numObjsToConcat -= 254; /* concat pushes 1 obj, the result */ 1883 } 1884 if (numObjsToConcat > 1) { 1885 TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr); 1886 } 1887 1888 /* 1889 * If the tokens yielded no instructions, push an empty string. 1890 */ 1891 1892 if (envPtr->codeNext == entryCodeNext) { 1893 TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); 1894 } 1895 Tcl_DStringFree(&textBuffer); 1896 1897 /* 1898 * Release the temp table we used to collect the locations of 1899 * continuation lines, if any. 1900 */ 1901 1902 if (maxNumCL) { 1903 ckfree ((char*) clPosition); 1904 } 1905} 1906 1907/* 1908 *---------------------------------------------------------------------- 1909 * 1910 * TclCompileCmdWord -- 1911 * 1912 * Given an array of parse tokens for a word containing one or more Tcl 1913 * commands, emit inline instructions to execute them. This procedure 1914 * differs from TclCompileTokens in that a simple word such as a loop 1915 * body enclosed in braces is not just pushed as a string, but is itself 1916 * parsed into tokens and compiled. 1917 * 1918 * Results: 1919 * The return value is a standard Tcl result. If an error occurs, an 1920 * error message is left in the interpreter's result. 1921 * 1922 * Side effects: 1923 * Instructions are added to envPtr to execute the tokens at runtime. 1924 * 1925 *---------------------------------------------------------------------- 1926 */ 1927 1928void 1929TclCompileCmdWord( 1930 Tcl_Interp *interp, /* Used for error and status reporting. */ 1931 Tcl_Token *tokenPtr, /* Pointer to first in an array of tokens for 1932 * a command word to compile inline. */ 1933 int count, /* Number of tokens to consider at tokenPtr. 1934 * Must be at least 1. */ 1935 CompileEnv *envPtr) /* Holds the resulting instructions. */ 1936{ 1937 if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) { 1938 /* 1939 * Handle the common case: if there is a single text token, compile it 1940 * into an inline sequence of instructions. 1941 */ 1942 1943 TclCompileScript(interp, tokenPtr->start, tokenPtr->size, envPtr); 1944 } else { 1945 /* 1946 * Multiple tokens or the single token involves substitutions. Emit 1947 * instructions to invoke the eval command procedure at runtime on the 1948 * result of evaluating the tokens. 1949 */ 1950 1951 TclCompileTokens(interp, tokenPtr, count, envPtr); 1952 TclEmitOpcode(INST_EVAL_STK, envPtr); 1953 } 1954} 1955 1956/* 1957 *---------------------------------------------------------------------- 1958 * 1959 * TclCompileExprWords -- 1960 * 1961 * Given an array of parse tokens representing one or more words that 1962 * contain a Tcl expression, emit inline instructions to execute the 1963 * expression. This procedure differs from TclCompileExpr in that it 1964 * supports Tcl's two-level substitution semantics for expressions that 1965 * appear as command words. 1966 * 1967 * Results: 1968 * The return value is a standard Tcl result. If an error occurs, an 1969 * error message is left in the interpreter's result. 1970 * 1971 * Side effects: 1972 * Instructions are added to envPtr to execute the expression. 1973 * 1974 *---------------------------------------------------------------------- 1975 */ 1976 1977void 1978TclCompileExprWords( 1979 Tcl_Interp *interp, /* Used for error and status reporting. */ 1980 Tcl_Token *tokenPtr, /* Points to first in an array of word tokens 1981 * tokens for the expression to compile 1982 * inline. */ 1983 int numWords, /* Number of word tokens starting at tokenPtr. 1984 * Must be at least 1. Each word token 1985 * contains one or more subtokens. */ 1986 CompileEnv *envPtr) /* Holds the resulting instructions. */ 1987{ 1988 Tcl_Token *wordPtr; 1989 int i, concatItems; 1990 1991 /* 1992 * If the expression is a single word that doesn't require substitutions, 1993 * just compile its string into inline instructions. 1994 */ 1995 1996 if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) { 1997 TclCompileExpr(interp, tokenPtr[1].start, tokenPtr[1].size, envPtr, 1); 1998 return; 1999 } 2000 2001 /* 2002 * Emit code to call the expr command proc at runtime. Concatenate the 2003 * (already substituted once) expr tokens with a space between each. 2004 */ 2005 2006 wordPtr = tokenPtr; 2007 for (i = 0; i < numWords; i++) { 2008 TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents, envPtr); 2009 if (i < (numWords - 1)) { 2010 TclEmitPush(TclRegisterNewLiteral(envPtr, " ", 1), envPtr); 2011 } 2012 wordPtr += (wordPtr->numComponents + 1); 2013 } 2014 concatItems = 2*numWords - 1; 2015 while (concatItems > 255) { 2016 TclEmitInstInt1(INST_CONCAT1, 255, envPtr); 2017 concatItems -= 254; 2018 } 2019 if (concatItems > 1) { 2020 TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr); 2021 } 2022 TclEmitOpcode(INST_EXPR_STK, envPtr); 2023} 2024 2025/* 2026 *---------------------------------------------------------------------- 2027 * 2028 * TclCompileNoOp -- 2029 * 2030 * Function called to compile no-op's 2031 * 2032 * Results: 2033 * The return value is TCL_OK, indicating successful compilation. 2034 * 2035 * Side effects: 2036 * Instructions are added to envPtr to execute a no-op at runtime. No 2037 * result is pushed onto the stack: the compiler has to take care of this 2038 * itself if the last compiled command is a NoOp. 2039 * 2040 *---------------------------------------------------------------------- 2041 */ 2042 2043int 2044TclCompileNoOp( 2045 Tcl_Interp *interp, /* Used for error reporting. */ 2046 Tcl_Parse *parsePtr, /* Points to a parse structure for the command 2047 * created by Tcl_ParseCommand. */ 2048 Command *cmdPtr, /* Points to defintion of command being 2049 * compiled. */ 2050 CompileEnv *envPtr) /* Holds resulting instructions. */ 2051{ 2052 Tcl_Token *tokenPtr; 2053 int i; 2054 int savedStackDepth = envPtr->currStackDepth; 2055 2056 tokenPtr = parsePtr->tokenPtr; 2057 for(i = 1; i < parsePtr->numWords; i++) { 2058 tokenPtr = tokenPtr + tokenPtr->numComponents + 1; 2059 envPtr->currStackDepth = savedStackDepth; 2060 2061 if (tokenPtr->type != TCL_TOKEN_SIMPLE_WORD) { 2062 TclCompileTokens(interp, tokenPtr+1, tokenPtr->numComponents, 2063 envPtr); 2064 TclEmitOpcode(INST_POP, envPtr); 2065 } 2066 } 2067 envPtr->currStackDepth = savedStackDepth; 2068 TclEmitPush(TclRegisterNewLiteral(envPtr, "", 0), envPtr); 2069 return TCL_OK; 2070} 2071 2072/* 2073 *---------------------------------------------------------------------- 2074 * 2075 * TclInitByteCodeObj -- 2076 * 2077 * Create a ByteCode structure and initialize it from a CompileEnv 2078 * compilation environment structure. The ByteCode structure is smaller 2079 * and contains just that information needed to execute the bytecode 2080 * instructions resulting from compiling a Tcl script. The resulting 2081 * structure is placed in the specified object. 2082 * 2083 * Results: 2084 * A newly constructed ByteCode object is stored in the internal 2085 * representation of the objPtr. 2086 * 2087 * Side effects: 2088 * A single heap object is allocated to hold the new ByteCode structure 2089 * and its code, object, command location, and aux data arrays. Note that 2090 * "ownership" (i.e., the pointers to) the Tcl objects and aux data items 2091 * will be handed over to the new ByteCode structure from the CompileEnv 2092 * structure. 2093 * 2094 *---------------------------------------------------------------------- 2095 */ 2096 2097void 2098TclInitByteCodeObj( 2099 Tcl_Obj *objPtr, /* Points object that should be initialized, 2100 * and whose string rep contains the source 2101 * code. */ 2102 register CompileEnv *envPtr)/* Points to the CompileEnv structure from 2103 * which to create a ByteCode structure. */ 2104{ 2105 register ByteCode *codePtr; 2106 size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes; 2107 size_t auxDataArrayBytes, structureSize; 2108 register unsigned char *p; 2109#ifdef TCL_COMPILE_DEBUG 2110 unsigned char *nextPtr; 2111#endif 2112 int numLitObjects = envPtr->literalArrayNext; 2113 Namespace *namespacePtr; 2114 int i, isNew; 2115 Interp *iPtr; 2116 2117 iPtr = envPtr->iPtr; 2118 2119 codeBytes = (envPtr->codeNext - envPtr->codeStart); 2120 objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *)); 2121 exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange)); 2122 auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData)); 2123 cmdLocBytes = GetCmdLocEncodingSize(envPtr); 2124 2125 /* 2126 * Compute the total number of bytes needed for this bytecode. 2127 */ 2128 2129 structureSize = sizeof(ByteCode); 2130 structureSize += TCL_ALIGN(codeBytes); /* align object array */ 2131 structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */ 2132 structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ 2133 structureSize += auxDataArrayBytes; 2134 structureSize += cmdLocBytes; 2135 2136 if (envPtr->iPtr->varFramePtr != NULL) { 2137 namespacePtr = envPtr->iPtr->varFramePtr->nsPtr; 2138 } else { 2139 namespacePtr = envPtr->iPtr->globalNsPtr; 2140 } 2141 2142 p = (unsigned char *) ckalloc((size_t) structureSize); 2143 codePtr = (ByteCode *) p; 2144 codePtr->interpHandle = TclHandlePreserve(iPtr->handle); 2145 codePtr->compileEpoch = iPtr->compileEpoch; 2146 codePtr->nsPtr = namespacePtr; 2147 codePtr->nsEpoch = namespacePtr->resolverEpoch; 2148 codePtr->refCount = 1; 2149 if (namespacePtr->compiledVarResProc || iPtr->resolverPtr) { 2150 codePtr->flags = TCL_BYTECODE_RESOLVE_VARS; 2151 } else { 2152 codePtr->flags = 0; 2153 } 2154 codePtr->source = envPtr->source; 2155 codePtr->procPtr = envPtr->procPtr; 2156 2157 codePtr->numCommands = envPtr->numCommands; 2158 codePtr->numSrcBytes = envPtr->numSrcBytes; 2159 codePtr->numCodeBytes = codeBytes; 2160 codePtr->numLitObjects = numLitObjects; 2161 codePtr->numExceptRanges = envPtr->exceptArrayNext; 2162 codePtr->numAuxDataItems = envPtr->auxDataArrayNext; 2163 codePtr->numCmdLocBytes = cmdLocBytes; 2164 codePtr->maxExceptDepth = envPtr->maxExceptDepth; 2165 codePtr->maxStackDepth = envPtr->maxStackDepth; 2166 2167 p += sizeof(ByteCode); 2168 codePtr->codeStart = p; 2169 memcpy(p, envPtr->codeStart, (size_t) codeBytes); 2170 2171 p += TCL_ALIGN(codeBytes); /* align object array */ 2172 codePtr->objArrayPtr = (Tcl_Obj **) p; 2173 for (i = 0; i < numLitObjects; i++) { 2174 codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr; 2175 } 2176 2177 p += TCL_ALIGN(objArrayBytes); /* align exception range array */ 2178 if (exceptArrayBytes > 0) { 2179 codePtr->exceptArrayPtr = (ExceptionRange *) p; 2180 memcpy(p, envPtr->exceptArrayPtr, (size_t) exceptArrayBytes); 2181 } else { 2182 codePtr->exceptArrayPtr = NULL; 2183 } 2184 2185 p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */ 2186 if (auxDataArrayBytes > 0) { 2187 codePtr->auxDataArrayPtr = (AuxData *) p; 2188 memcpy(p, envPtr->auxDataArrayPtr, (size_t) auxDataArrayBytes); 2189 } else { 2190 codePtr->auxDataArrayPtr = NULL; 2191 } 2192 2193 p += auxDataArrayBytes; 2194#ifndef TCL_COMPILE_DEBUG 2195 EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); 2196#else 2197 nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p); 2198 if (((size_t)(nextPtr - p)) != cmdLocBytes) { 2199 Tcl_Panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d", (nextPtr - p), cmdLocBytes); 2200 } 2201#endif 2202 2203 /* 2204 * Record various compilation-related statistics about the new ByteCode 2205 * structure. Don't include overhead for statistics-related fields. 2206 */ 2207 2208#ifdef TCL_COMPILE_STATS 2209 codePtr->structureSize = structureSize 2210 - (sizeof(size_t) + sizeof(Tcl_Time)); 2211 Tcl_GetTime(&(codePtr->createTime)); 2212 2213 RecordByteCodeStats(codePtr); 2214#endif /* TCL_COMPILE_STATS */ 2215 2216 /* 2217 * Free the old internal rep then convert the object to a bytecode object 2218 * by making its internal rep point to the just compiled ByteCode. 2219 */ 2220 2221 TclFreeIntRep(objPtr); 2222 objPtr->internalRep.otherValuePtr = (void *) codePtr; 2223 objPtr->typePtr = &tclByteCodeType; 2224 2225 /* 2226 * TIP #280. Associate the extended per-word line information with the 2227 * byte code object (internal rep), for use with the bc compiler. 2228 */ 2229 2230 Tcl_SetHashValue(Tcl_CreateHashEntry(iPtr->lineBCPtr, (char *) codePtr, 2231 &isNew), envPtr->extCmdMapPtr); 2232 envPtr->extCmdMapPtr = NULL; 2233 2234 codePtr->localCachePtr = NULL; 2235} 2236 2237/* 2238 *---------------------------------------------------------------------- 2239 * 2240 * TclFindCompiledLocal -- 2241 * 2242 * This procedure is called at compile time to look up and optionally 2243 * allocate an entry ("slot") for a variable in a procedure's array of 2244 * local variables. If the variable's name is NULL, a new temporary 2245 * variable is always created. (Such temporary variables can only be 2246 * referenced using their slot index.) 2247 * 2248 * Results: 2249 * If create is 0 and the name is non-NULL, then if the variable is 2250 * found, the index of its entry in the procedure's array of local 2251 * variables is returned; otherwise -1 is returned. If name is NULL, the 2252 * index of a new temporary variable is returned. Finally, if create is 1 2253 * and name is non-NULL, the index of a new entry is returned. 2254 * 2255 * Side effects: 2256 * Creates and registers a new local variable if create is 1 and the 2257 * variable is unknown, or if the name is NULL. 2258 * 2259 *---------------------------------------------------------------------- 2260 */ 2261 2262int 2263TclFindCompiledLocal( 2264 register const char *name, /* Points to first character of the name of a 2265 * scalar or array variable. If NULL, a 2266 * temporary var should be created. */ 2267 int nameBytes, /* Number of bytes in the name. */ 2268 int create, /* If 1, allocate a local frame entry for the 2269 * variable if it is new. */ 2270 register Proc *procPtr) /* Points to structure describing procedure 2271 * containing the variable reference. */ 2272{ 2273 register CompiledLocal *localPtr; 2274 int localVar = -1; 2275 register int i; 2276 2277 /* 2278 * If not creating a temporary, does a local variable of the specified 2279 * name already exist? 2280 */ 2281 2282 if (name != NULL) { 2283 int localCt = procPtr->numCompiledLocals; 2284 2285 localPtr = procPtr->firstLocalPtr; 2286 for (i = 0; i < localCt; i++) { 2287 if (!TclIsVarTemporary(localPtr)) { 2288 char *localName = localPtr->name; 2289 2290 if ((nameBytes == localPtr->nameLength) && 2291 (strncmp(name,localName,(unsigned)nameBytes) == 0)) { 2292 return i; 2293 } 2294 } 2295 localPtr = localPtr->nextPtr; 2296 } 2297 } 2298 2299 /* 2300 * Create a new variable if appropriate. 2301 */ 2302 2303 if (create || (name == NULL)) { 2304 localVar = procPtr->numCompiledLocals; 2305 localPtr = (CompiledLocal *) ckalloc((unsigned) 2306 (sizeof(CompiledLocal) - sizeof(localPtr->name) 2307 + nameBytes + 1)); 2308 if (procPtr->firstLocalPtr == NULL) { 2309 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr; 2310 } else { 2311 procPtr->lastLocalPtr->nextPtr = localPtr; 2312 procPtr->lastLocalPtr = localPtr; 2313 } 2314 localPtr->nextPtr = NULL; 2315 localPtr->nameLength = nameBytes; 2316 localPtr->frameIndex = localVar; 2317 localPtr->flags = 0; 2318 if (name == NULL) { 2319 localPtr->flags |= VAR_TEMPORARY; 2320 } 2321 localPtr->defValuePtr = NULL; 2322 localPtr->resolveInfo = NULL; 2323 2324 if (name != NULL) { 2325 memcpy(localPtr->name, name, (size_t) nameBytes); 2326 } 2327 localPtr->name[nameBytes] = '\0'; 2328 procPtr->numCompiledLocals++; 2329 } 2330 return localVar; 2331} 2332 2333/* 2334 *---------------------------------------------------------------------- 2335 * 2336 * TclExpandCodeArray -- 2337 * 2338 * Procedure that uses malloc to allocate more storage for a CompileEnv's 2339 * code array. 2340 * 2341 * Results: 2342 * None. 2343 * 2344 * Side effects: 2345 * The byte code array in *envPtr is reallocated to a new array of double 2346 * the size, and if envPtr->mallocedCodeArray is non-zero the old array 2347 * is freed. Byte codes are copied from the old array to the new one. 2348 * 2349 *---------------------------------------------------------------------- 2350 */ 2351 2352void 2353TclExpandCodeArray( 2354 void *envArgPtr) /* Points to the CompileEnv whose code array 2355 * must be enlarged. */ 2356{ 2357 CompileEnv *envPtr = (CompileEnv *) envArgPtr; 2358 /* The CompileEnv containing the code array to 2359 * be doubled in size. */ 2360 2361 /* 2362 * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined 2363 * code bytes are stored between envPtr->codeStart and envPtr->codeNext-1 2364 * [inclusive]. 2365 */ 2366 2367 size_t currBytes = (envPtr->codeNext - envPtr->codeStart); 2368 size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart); 2369 2370 if (envPtr->mallocedCodeArray) { 2371 envPtr->codeStart = (unsigned char *) 2372 ckrealloc((char *)envPtr->codeStart, newBytes); 2373 } else { 2374 /* 2375 * envPtr->codeStart isn't a ckalloc'd pointer, so we must 2376 * code a ckrealloc equivalent for ourselves. 2377 */ 2378 unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes); 2379 memcpy(newPtr, envPtr->codeStart, currBytes); 2380 envPtr->codeStart = newPtr; 2381 envPtr->mallocedCodeArray = 1; 2382 } 2383 2384 envPtr->codeNext = (envPtr->codeStart + currBytes); 2385 envPtr->codeEnd = (envPtr->codeStart + newBytes); 2386} 2387 2388/* 2389 *---------------------------------------------------------------------- 2390 * 2391 * EnterCmdStartData -- 2392 * 2393 * Registers the starting source and bytecode location of a command. This 2394 * information is used at runtime to map between instruction pc and 2395 * source locations. 2396 * 2397 * Results: 2398 * None. 2399 * 2400 * Side effects: 2401 * Inserts source and code location information into the compilation 2402 * environment envPtr for the command at index cmdIndex. The compilation 2403 * environment's CmdLocation array is grown if necessary. 2404 * 2405 *---------------------------------------------------------------------- 2406 */ 2407 2408static void 2409EnterCmdStartData( 2410 CompileEnv *envPtr, /* Points to the compilation environment 2411 * structure in which to enter command 2412 * location information. */ 2413 int cmdIndex, /* Index of the command whose start data is 2414 * being set. */ 2415 int srcOffset, /* Offset of first char of the command. */ 2416 int codeOffset) /* Offset of first byte of command code. */ 2417{ 2418 CmdLocation *cmdLocPtr; 2419 2420 if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { 2421 Tcl_Panic("EnterCmdStartData: bad command index %d", cmdIndex); 2422 } 2423 2424 if (cmdIndex >= envPtr->cmdMapEnd) { 2425 /* 2426 * Expand the command location array by allocating more storage from 2427 * the heap. The currently allocated CmdLocation entries are stored 2428 * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive). 2429 */ 2430 2431 size_t currElems = envPtr->cmdMapEnd; 2432 size_t newElems = 2*currElems; 2433 size_t currBytes = currElems * sizeof(CmdLocation); 2434 size_t newBytes = newElems * sizeof(CmdLocation); 2435 2436 if (envPtr->mallocedCmdMap) { 2437 envPtr->cmdMapPtr = (CmdLocation *) 2438 ckrealloc((char *) envPtr->cmdMapPtr, newBytes); 2439 } else { 2440 /* 2441 * envPtr->cmdMapPtr isn't a ckalloc'd pointer, so we must 2442 * code a ckrealloc equivalent for ourselves. 2443 */ 2444 CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes); 2445 memcpy(newPtr, envPtr->cmdMapPtr, currBytes); 2446 envPtr->cmdMapPtr = newPtr; 2447 envPtr->mallocedCmdMap = 1; 2448 } 2449 envPtr->cmdMapEnd = newElems; 2450 } 2451 2452 if (cmdIndex > 0) { 2453 if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) { 2454 Tcl_Panic("EnterCmdStartData: cmd map not sorted by code offset"); 2455 } 2456 } 2457 2458 cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); 2459 cmdLocPtr->codeOffset = codeOffset; 2460 cmdLocPtr->srcOffset = srcOffset; 2461 cmdLocPtr->numSrcBytes = -1; 2462 cmdLocPtr->numCodeBytes = -1; 2463} 2464 2465/* 2466 *---------------------------------------------------------------------- 2467 * 2468 * EnterCmdExtentData -- 2469 * 2470 * Registers the source and bytecode length for a command. This 2471 * information is used at runtime to map between instruction pc and 2472 * source locations. 2473 * 2474 * Results: 2475 * None. 2476 * 2477 * Side effects: 2478 * Inserts source and code length information into the compilation 2479 * environment envPtr for the command at index cmdIndex. Starting source 2480 * and bytecode information for the command must already have been 2481 * registered. 2482 * 2483 *---------------------------------------------------------------------- 2484 */ 2485 2486static void 2487EnterCmdExtentData( 2488 CompileEnv *envPtr, /* Points to the compilation environment 2489 * structure in which to enter command 2490 * location information. */ 2491 int cmdIndex, /* Index of the command whose source and code 2492 * length data is being set. */ 2493 int numSrcBytes, /* Number of command source chars. */ 2494 int numCodeBytes) /* Offset of last byte of command code. */ 2495{ 2496 CmdLocation *cmdLocPtr; 2497 2498 if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) { 2499 Tcl_Panic("EnterCmdExtentData: bad command index %d", cmdIndex); 2500 } 2501 2502 if (cmdIndex > envPtr->cmdMapEnd) { 2503 Tcl_Panic("EnterCmdExtentData: missing start data for command %d", 2504 cmdIndex); 2505 } 2506 2507 cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]); 2508 cmdLocPtr->numSrcBytes = numSrcBytes; 2509 cmdLocPtr->numCodeBytes = numCodeBytes; 2510} 2511 2512/* 2513 *---------------------------------------------------------------------- 2514 * TIP #280 2515 * 2516 * EnterCmdWordData -- 2517 * 2518 * Registers the lines for the words of a command. This information is 2519 * used at runtime by 'info frame'. 2520 * 2521 * Results: 2522 * None. 2523 * 2524 * Side effects: 2525 * Inserts word location information into the compilation environment 2526 * envPtr for the command at index cmdIndex. The compilation 2527 * environment's ExtCmdLoc.ECL array is grown if necessary. 2528 * 2529 *---------------------------------------------------------------------- 2530 */ 2531 2532static void 2533EnterCmdWordData( 2534 ExtCmdLoc *eclPtr, /* Points to the map environment structure in 2535 * which to enter command location 2536 * information. */ 2537 int srcOffset, /* Offset of first char of the command. */ 2538 Tcl_Token *tokenPtr, 2539 const char *cmd, 2540 int len, 2541 int numWords, 2542 int line, 2543 int* clNext, 2544 int **wlines, 2545 CompileEnv* envPtr) 2546{ 2547 ECL *ePtr; 2548 const char *last; 2549 int wordIdx, wordLine, *wwlines; 2550 int* wordNext; 2551 2552 if (eclPtr->nuloc >= eclPtr->nloc) { 2553 /* 2554 * Expand the ECL array by allocating more storage from the heap. The 2555 * currently allocated ECL entries are stored from eclPtr->loc[0] up 2556 * to eclPtr->loc[eclPtr->nuloc-1] (inclusive). 2557 */ 2558 2559 size_t currElems = eclPtr->nloc; 2560 size_t newElems = (currElems ? 2*currElems : 1); 2561 size_t newBytes = newElems * sizeof(ECL); 2562 2563 eclPtr->loc = (ECL *) ckrealloc((char *)(eclPtr->loc), newBytes); 2564 eclPtr->nloc = newElems; 2565 } 2566 2567 ePtr = &eclPtr->loc[eclPtr->nuloc]; 2568 ePtr->srcOffset = srcOffset; 2569 ePtr->line = (int *) ckalloc(numWords * sizeof(int)); 2570 ePtr->next = (int**) ckalloc (numWords * sizeof (int*)); 2571 ePtr->nline = numWords; 2572 wwlines = (int *) ckalloc(numWords * sizeof(int)); 2573 2574 last = cmd; 2575 wordLine = line; 2576 wordNext = clNext; 2577 for (wordIdx=0 ; wordIdx<numWords; 2578 wordIdx++, tokenPtr += tokenPtr->numComponents + 1) { 2579 TclAdvanceLines (&wordLine, last, tokenPtr->start); 2580 TclAdvanceContinuations (&wordLine, &wordNext, 2581 tokenPtr->start - envPtr->source); 2582 wwlines[wordIdx] = 2583 (TclWordKnownAtCompileTime(tokenPtr, NULL) ? wordLine : -1); 2584 ePtr->line[wordIdx] = wordLine; 2585 ePtr->next[wordIdx] = wordNext; 2586 last = tokenPtr->start; 2587 } 2588 2589 *wlines = wwlines; 2590 eclPtr->nuloc ++; 2591} 2592 2593/* 2594 *---------------------------------------------------------------------- 2595 * 2596 * TclCreateExceptRange -- 2597 * 2598 * Procedure that allocates and initializes a new ExceptionRange 2599 * structure of the specified kind in a CompileEnv. 2600 * 2601 * Results: 2602 * Returns the index for the newly created ExceptionRange. 2603 * 2604 * Side effects: 2605 * If there is not enough room in the CompileEnv's ExceptionRange array, 2606 * the array in expanded: a new array of double the size is allocated, if 2607 * envPtr->mallocedExceptArray is non-zero the old array is freed, and 2608 * ExceptionRange entries are copied from the old array to the new one. 2609 * 2610 *---------------------------------------------------------------------- 2611 */ 2612 2613int 2614TclCreateExceptRange( 2615 ExceptionRangeType type, /* The kind of ExceptionRange desired. */ 2616 register CompileEnv *envPtr)/* Points to CompileEnv for which to create a 2617 * new ExceptionRange structure. */ 2618{ 2619 register ExceptionRange *rangePtr; 2620 int index = envPtr->exceptArrayNext; 2621 2622 if (index >= envPtr->exceptArrayEnd) { 2623 /* 2624 * Expand the ExceptionRange array. The currently allocated entries 2625 * are stored between elements 0 and (envPtr->exceptArrayNext - 1) 2626 * [inclusive]. 2627 */ 2628 2629 size_t currBytes = 2630 envPtr->exceptArrayNext * sizeof(ExceptionRange); 2631 int newElems = 2*envPtr->exceptArrayEnd; 2632 size_t newBytes = newElems * sizeof(ExceptionRange); 2633 2634 if (envPtr->mallocedExceptArray) { 2635 envPtr->exceptArrayPtr = (ExceptionRange *) 2636 ckrealloc((char *)(envPtr->exceptArrayPtr), newBytes); 2637 } else { 2638 /* 2639 * envPtr->exceptArrayPtr isn't a ckalloc'd pointer, so we must 2640 * code a ckrealloc equivalent for ourselves. 2641 */ 2642 ExceptionRange *newPtr = (ExceptionRange *) 2643 ckalloc((unsigned) newBytes); 2644 memcpy(newPtr, envPtr->exceptArrayPtr, currBytes); 2645 envPtr->exceptArrayPtr = newPtr; 2646 envPtr->mallocedExceptArray = 1; 2647 } 2648 envPtr->exceptArrayEnd = newElems; 2649 } 2650 envPtr->exceptArrayNext++; 2651 2652 rangePtr = &(envPtr->exceptArrayPtr[index]); 2653 rangePtr->type = type; 2654 rangePtr->nestingLevel = envPtr->exceptDepth; 2655 rangePtr->codeOffset = -1; 2656 rangePtr->numCodeBytes = -1; 2657 rangePtr->breakOffset = -1; 2658 rangePtr->continueOffset = -1; 2659 rangePtr->catchOffset = -1; 2660 return index; 2661} 2662 2663/* 2664 *---------------------------------------------------------------------- 2665 * 2666 * TclCreateAuxData -- 2667 * 2668 * Procedure that allocates and initializes a new AuxData structure in a 2669 * CompileEnv's array of compilation auxiliary data records. These 2670 * AuxData records hold information created during compilation by 2671 * CompileProcs and used by instructions during execution. 2672 * 2673 * Results: 2674 * Returns the index for the newly created AuxData structure. 2675 * 2676 * Side effects: 2677 * If there is not enough room in the CompileEnv's AuxData array, the 2678 * AuxData array in expanded: a new array of double the size is 2679 * allocated, if envPtr->mallocedAuxDataArray is non-zero the old array 2680 * is freed, and AuxData entries are copied from the old array to the new 2681 * one. 2682 * 2683 *---------------------------------------------------------------------- 2684 */ 2685 2686int 2687TclCreateAuxData( 2688 ClientData clientData, /* The compilation auxiliary data to store in 2689 * the new aux data record. */ 2690 AuxDataType *typePtr, /* Pointer to the type to attach to this 2691 * AuxData */ 2692 register CompileEnv *envPtr)/* Points to the CompileEnv for which a new 2693 * aux data structure is to be allocated. */ 2694{ 2695 int index; /* Index for the new AuxData structure. */ 2696 register AuxData *auxDataPtr; 2697 /* Points to the new AuxData structure */ 2698 2699 index = envPtr->auxDataArrayNext; 2700 if (index >= envPtr->auxDataArrayEnd) { 2701 /* 2702 * Expand the AuxData array. The currently allocated entries are 2703 * stored between elements 0 and (envPtr->auxDataArrayNext - 1) 2704 * [inclusive]. 2705 */ 2706 2707 size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData); 2708 int newElems = 2*envPtr->auxDataArrayEnd; 2709 size_t newBytes = newElems * sizeof(AuxData); 2710 2711 if (envPtr->mallocedAuxDataArray) { 2712 envPtr->auxDataArrayPtr = (AuxData *) 2713 ckrealloc((char *)(envPtr->auxDataArrayPtr), newBytes); 2714 } else { 2715 /* 2716 * envPtr->auxDataArrayPtr isn't a ckalloc'd pointer, so we must 2717 * code a ckrealloc equivalent for ourselves. 2718 */ 2719 AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes); 2720 memcpy(newPtr, envPtr->auxDataArrayPtr, currBytes); 2721 envPtr->auxDataArrayPtr = newPtr; 2722 envPtr->mallocedAuxDataArray = 1; 2723 } 2724 envPtr->auxDataArrayEnd = newElems; 2725 } 2726 envPtr->auxDataArrayNext++; 2727 2728 auxDataPtr = &(envPtr->auxDataArrayPtr[index]); 2729 auxDataPtr->clientData = clientData; 2730 auxDataPtr->type = typePtr; 2731 return index; 2732} 2733 2734/* 2735 *---------------------------------------------------------------------- 2736 * 2737 * TclInitJumpFixupArray -- 2738 * 2739 * Initializes a JumpFixupArray structure to hold some number of jump 2740 * fixup entries. 2741 * 2742 * Results: 2743 * None. 2744 * 2745 * Side effects: 2746 * The JumpFixupArray structure is initialized. 2747 * 2748 *---------------------------------------------------------------------- 2749 */ 2750 2751void 2752TclInitJumpFixupArray( 2753 register JumpFixupArray *fixupArrayPtr) 2754 /* Points to the JumpFixupArray structure to 2755 * initialize. */ 2756{ 2757 fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace; 2758 fixupArrayPtr->next = 0; 2759 fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1); 2760 fixupArrayPtr->mallocedArray = 0; 2761} 2762 2763/* 2764 *---------------------------------------------------------------------- 2765 * 2766 * TclExpandJumpFixupArray -- 2767 * 2768 * Procedure that uses malloc to allocate more storage for a jump fixup 2769 * array. 2770 * 2771 * Results: 2772 * None. 2773 * 2774 * Side effects: 2775 * The jump fixup array in *fixupArrayPtr is reallocated to a new array 2776 * of double the size, and if fixupArrayPtr->mallocedArray is non-zero 2777 * the old array is freed. Jump fixup structures are copied from the old 2778 * array to the new one. 2779 * 2780 *---------------------------------------------------------------------- 2781 */ 2782 2783void 2784TclExpandJumpFixupArray( 2785 register JumpFixupArray *fixupArrayPtr) 2786 /* Points to the JumpFixupArray structure 2787 * to enlarge. */ 2788{ 2789 /* 2790 * The currently allocated jump fixup entries are stored from fixup[0] up 2791 * to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume 2792 * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd. 2793 */ 2794 2795 size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup); 2796 int newElems = 2*(fixupArrayPtr->end + 1); 2797 size_t newBytes = newElems * sizeof(JumpFixup); 2798 2799 if (fixupArrayPtr->mallocedArray) { 2800 fixupArrayPtr->fixup = (JumpFixup *) 2801 ckrealloc((char *)(fixupArrayPtr->fixup), newBytes); 2802 } else { 2803 /* 2804 * fixupArrayPtr->fixup isn't a ckalloc'd pointer, so we must 2805 * code a ckrealloc equivalent for ourselves. 2806 */ 2807 JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes); 2808 memcpy(newPtr, fixupArrayPtr->fixup, currBytes); 2809 fixupArrayPtr->fixup = newPtr; 2810 fixupArrayPtr->mallocedArray = 1; 2811 } 2812 fixupArrayPtr->end = newElems; 2813} 2814 2815/* 2816 *---------------------------------------------------------------------- 2817 * 2818 * TclFreeJumpFixupArray -- 2819 * 2820 * Free any storage allocated in a jump fixup array structure. 2821 * 2822 * Results: 2823 * None. 2824 * 2825 * Side effects: 2826 * Allocated storage in the JumpFixupArray structure is freed. 2827 * 2828 *---------------------------------------------------------------------- 2829 */ 2830 2831void 2832TclFreeJumpFixupArray( 2833 register JumpFixupArray *fixupArrayPtr) 2834 /* Points to the JumpFixupArray structure to 2835 * free. */ 2836{ 2837 if (fixupArrayPtr->mallocedArray) { 2838 ckfree((char *) fixupArrayPtr->fixup); 2839 } 2840} 2841 2842/* 2843 *---------------------------------------------------------------------- 2844 * 2845 * TclEmitForwardJump -- 2846 * 2847 * Procedure to emit a two-byte forward jump of kind "jumpType". Since 2848 * the jump may later have to be grown to five bytes if the jump target 2849 * is more than, say, 127 bytes away, this procedure also initializes a 2850 * JumpFixup record with information about the jump. 2851 * 2852 * Results: 2853 * None. 2854 * 2855 * Side effects: 2856 * The JumpFixup record pointed to by "jumpFixupPtr" is initialized with 2857 * information needed later if the jump is to be grown. Also, a two byte 2858 * jump of the designated type is emitted at the current point in the 2859 * bytecode stream. 2860 * 2861 *---------------------------------------------------------------------- 2862 */ 2863 2864void 2865TclEmitForwardJump( 2866 CompileEnv *envPtr, /* Points to the CompileEnv structure that 2867 * holds the resulting instruction. */ 2868 TclJumpType jumpType, /* Indicates the kind of jump: if true or 2869 * false or unconditional. */ 2870 JumpFixup *jumpFixupPtr) /* Points to the JumpFixup structure to 2871 * initialize with information about this 2872 * forward jump. */ 2873{ 2874 /* 2875 * Initialize the JumpFixup structure: 2876 * - codeOffset is offset of first byte of jump below 2877 * - cmdIndex is index of the command after the current one 2878 * - exceptIndex is the index of the first ExceptionRange after the 2879 * current one. 2880 */ 2881 2882 jumpFixupPtr->jumpType = jumpType; 2883 jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart); 2884 jumpFixupPtr->cmdIndex = envPtr->numCommands; 2885 jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext; 2886 2887 switch (jumpType) { 2888 case TCL_UNCONDITIONAL_JUMP: 2889 TclEmitInstInt1(INST_JUMP1, 0, envPtr); 2890 break; 2891 case TCL_TRUE_JUMP: 2892 TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr); 2893 break; 2894 default: 2895 TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr); 2896 break; 2897 } 2898} 2899 2900/* 2901 *---------------------------------------------------------------------- 2902 * 2903 * TclFixupForwardJump -- 2904 * 2905 * Procedure that updates a previously-emitted forward jump to jump a 2906 * specified number of bytes, "jumpDist". If necessary, the jump is grown 2907 * from two to five bytes; this is done if the jump distance is greater 2908 * than "distThreshold" (normally 127 bytes). The jump is described by a 2909 * JumpFixup record previously initialized by TclEmitForwardJump. 2910 * 2911 * Results: 2912 * 1 if the jump was grown and subsequent instructions had to be moved; 2913 * otherwise 0. This result is returned to allow callers to update any 2914 * additional code offsets they may hold. 2915 * 2916 * Side effects: 2917 * The jump may be grown and subsequent instructions moved. If this 2918 * happens, the code offsets for any commands and any ExceptionRange 2919 * records between the jump and the current code address will be updated 2920 * to reflect the moved code. Also, the bytecode instruction array in the 2921 * CompileEnv structure may be grown and reallocated. 2922 * 2923 *---------------------------------------------------------------------- 2924 */ 2925 2926int 2927TclFixupForwardJump( 2928 CompileEnv *envPtr, /* Points to the CompileEnv structure that 2929 * holds the resulting instruction. */ 2930 JumpFixup *jumpFixupPtr, /* Points to the JumpFixup structure that 2931 * describes the forward jump. */ 2932 int jumpDist, /* Jump distance to set in jump instr. */ 2933 int distThreshold) /* Maximum distance before the two byte jump 2934 * is grown to five bytes. */ 2935{ 2936 unsigned char *jumpPc, *p; 2937 int firstCmd, lastCmd, firstRange, lastRange, k; 2938 unsigned numBytes; 2939 2940 if (jumpDist <= distThreshold) { 2941 jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); 2942 switch (jumpFixupPtr->jumpType) { 2943 case TCL_UNCONDITIONAL_JUMP: 2944 TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc); 2945 break; 2946 case TCL_TRUE_JUMP: 2947 TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc); 2948 break; 2949 default: 2950 TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc); 2951 break; 2952 } 2953 return 0; 2954 } 2955 2956 /* 2957 * We must grow the jump then move subsequent instructions down. Note that 2958 * if we expand the space for generated instructions, code addresses might 2959 * change; be careful about updating any of these addresses held in 2960 * variables. 2961 */ 2962 2963 if ((envPtr->codeNext + 3) > envPtr->codeEnd) { 2964 TclExpandCodeArray(envPtr); 2965 } 2966 jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset); 2967 numBytes = envPtr->codeNext-jumpPc-2; 2968 p = jumpPc+2; 2969 memmove(p+3, p, numBytes); 2970 2971 envPtr->codeNext += 3; 2972 jumpDist += 3; 2973 switch (jumpFixupPtr->jumpType) { 2974 case TCL_UNCONDITIONAL_JUMP: 2975 TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc); 2976 break; 2977 case TCL_TRUE_JUMP: 2978 TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc); 2979 break; 2980 default: 2981 TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc); 2982 break; 2983 } 2984 2985 /* 2986 * Adjust the code offsets for any commands and any ExceptionRange records 2987 * between the jump and the current code address. 2988 */ 2989 2990 firstCmd = jumpFixupPtr->cmdIndex; 2991 lastCmd = (envPtr->numCommands - 1); 2992 if (firstCmd < lastCmd) { 2993 for (k = firstCmd; k <= lastCmd; k++) { 2994 (envPtr->cmdMapPtr[k]).codeOffset += 3; 2995 } 2996 } 2997 2998 firstRange = jumpFixupPtr->exceptIndex; 2999 lastRange = (envPtr->exceptArrayNext - 1); 3000 for (k = firstRange; k <= lastRange; k++) { 3001 ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]); 3002 rangePtr->codeOffset += 3; 3003 3004 switch (rangePtr->type) { 3005 case LOOP_EXCEPTION_RANGE: 3006 rangePtr->breakOffset += 3; 3007 if (rangePtr->continueOffset != -1) { 3008 rangePtr->continueOffset += 3; 3009 } 3010 break; 3011 case CATCH_EXCEPTION_RANGE: 3012 rangePtr->catchOffset += 3; 3013 break; 3014 default: 3015 Tcl_Panic("TclFixupForwardJump: bad ExceptionRange type %d", 3016 rangePtr->type); 3017 } 3018 } 3019 return 1; /* the jump was grown */ 3020} 3021 3022/* 3023 *---------------------------------------------------------------------- 3024 * 3025 * TclGetInstructionTable -- 3026 * 3027 * Returns a pointer to the table describing Tcl bytecode instructions. 3028 * This procedure is defined so that clients can access the pointer from 3029 * outside the TCL DLLs. 3030 * 3031 * Results: 3032 * Returns a pointer to the global instruction table, same as the 3033 * expression (&tclInstructionTable[0]). 3034 * 3035 * Side effects: 3036 * None. 3037 * 3038 *---------------------------------------------------------------------- 3039 */ 3040 3041void * /* == InstructionDesc* == */ 3042TclGetInstructionTable(void) 3043{ 3044 return &tclInstructionTable[0]; 3045} 3046 3047/* 3048 *-------------------------------------------------------------- 3049 * 3050 * TclRegisterAuxDataType -- 3051 * 3052 * This procedure is called to register a new AuxData type in the table 3053 * of all AuxData types supported by Tcl. 3054 * 3055 * Results: 3056 * None. 3057 * 3058 * Side effects: 3059 * The type is registered in the AuxData type table. If there was already 3060 * a type with the same name as in typePtr, it is replaced with the new 3061 * type. 3062 * 3063 *-------------------------------------------------------------- 3064 */ 3065 3066void 3067TclRegisterAuxDataType( 3068 AuxDataType *typePtr) /* Information about object type; storage must 3069 * be statically allocated (must live forever; 3070 * will not be deallocated). */ 3071{ 3072 register Tcl_HashEntry *hPtr; 3073 int isNew; 3074 3075 Tcl_MutexLock(&tableMutex); 3076 if (!auxDataTypeTableInitialized) { 3077 TclInitAuxDataTypeTable(); 3078 } 3079 3080 /* 3081 * If there's already a type with the given name, remove it. 3082 */ 3083 3084 hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name); 3085 if (hPtr != NULL) { 3086 Tcl_DeleteHashEntry(hPtr); 3087 } 3088 3089 /* 3090 * Now insert the new object type. 3091 */ 3092 3093 hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &isNew); 3094 if (isNew) { 3095 Tcl_SetHashValue(hPtr, typePtr); 3096 } 3097 Tcl_MutexUnlock(&tableMutex); 3098} 3099 3100/* 3101 *---------------------------------------------------------------------- 3102 * 3103 * TclGetAuxDataType -- 3104 * 3105 * This procedure looks up an Auxdata type by name. 3106 * 3107 * Results: 3108 * If an AuxData type with name matching "typeName" is found, a pointer 3109 * to its AuxDataType structure is returned; otherwise, NULL is returned. 3110 * 3111 * Side effects: 3112 * None. 3113 * 3114 *---------------------------------------------------------------------- 3115 */ 3116 3117AuxDataType * 3118TclGetAuxDataType( 3119 char *typeName) /* Name of AuxData type to look up. */ 3120{ 3121 register Tcl_HashEntry *hPtr; 3122 AuxDataType *typePtr = NULL; 3123 3124 Tcl_MutexLock(&tableMutex); 3125 if (!auxDataTypeTableInitialized) { 3126 TclInitAuxDataTypeTable(); 3127 } 3128 3129 hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName); 3130 if (hPtr != NULL) { 3131 typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr); 3132 } 3133 Tcl_MutexUnlock(&tableMutex); 3134 3135 return typePtr; 3136} 3137 3138/* 3139 *-------------------------------------------------------------- 3140 * 3141 * TclInitAuxDataTypeTable -- 3142 * 3143 * This procedure is invoked to perform once-only initialization of the 3144 * AuxData type table. It also registers the AuxData types defined in 3145 * this file. 3146 * 3147 * Results: 3148 * None. 3149 * 3150 * Side effects: 3151 * Initializes the table of defined AuxData types "auxDataTypeTable" with 3152 * builtin AuxData types defined in this file. 3153 * 3154 *-------------------------------------------------------------- 3155 */ 3156 3157void 3158TclInitAuxDataTypeTable(void) 3159{ 3160 /* 3161 * The table mutex must already be held before this routine is invoked. 3162 */ 3163 3164 auxDataTypeTableInitialized = 1; 3165 Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS); 3166 3167 /* 3168 * There are only two AuxData type at this time, so register them here. 3169 */ 3170 3171 TclRegisterAuxDataType(&tclForeachInfoType); 3172 TclRegisterAuxDataType(&tclJumptableInfoType); 3173} 3174 3175/* 3176 *---------------------------------------------------------------------- 3177 * 3178 * TclFinalizeAuxDataTypeTable -- 3179 * 3180 * This procedure is called by Tcl_Finalize after all exit handlers have 3181 * been run to free up storage associated with the table of AuxData 3182 * types. This procedure is called by TclFinalizeExecution() which is 3183 * called by Tcl_Finalize(). 3184 * 3185 * Results: 3186 * None. 3187 * 3188 * Side effects: 3189 * Deletes all entries in the hash table of AuxData types. 3190 * 3191 *---------------------------------------------------------------------- 3192 */ 3193 3194void 3195TclFinalizeAuxDataTypeTable(void) 3196{ 3197 Tcl_MutexLock(&tableMutex); 3198 if (auxDataTypeTableInitialized) { 3199 Tcl_DeleteHashTable(&auxDataTypeTable); 3200 auxDataTypeTableInitialized = 0; 3201 } 3202 Tcl_MutexUnlock(&tableMutex); 3203} 3204 3205/* 3206 *---------------------------------------------------------------------- 3207 * 3208 * GetCmdLocEncodingSize -- 3209 * 3210 * Computes the total number of bytes needed to encode the command 3211 * location information for some compiled code. 3212 * 3213 * Results: 3214 * The byte count needed to encode the compiled location information. 3215 * 3216 * Side effects: 3217 * None. 3218 * 3219 *---------------------------------------------------------------------- 3220 */ 3221 3222static int 3223GetCmdLocEncodingSize( 3224 CompileEnv *envPtr) /* Points to compilation environment structure 3225 * containing the CmdLocation structure to 3226 * encode. */ 3227{ 3228 register CmdLocation *mapPtr = envPtr->cmdMapPtr; 3229 int numCmds = envPtr->numCommands; 3230 int codeDelta, codeLen, srcDelta, srcLen; 3231 int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext; 3232 /* The offsets in their respective byte 3233 * sequences where the next encoded offset or 3234 * length should go. */ 3235 int prevCodeOffset, prevSrcOffset, i; 3236 3237 codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0; 3238 prevCodeOffset = prevSrcOffset = 0; 3239 for (i = 0; i < numCmds; i++) { 3240 codeDelta = (mapPtr[i].codeOffset - prevCodeOffset); 3241 if (codeDelta < 0) { 3242 Tcl_Panic("GetCmdLocEncodingSize: bad code offset"); 3243 } else if (codeDelta <= 127) { 3244 codeDeltaNext++; 3245 } else { 3246 codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */ 3247 } 3248 prevCodeOffset = mapPtr[i].codeOffset; 3249 3250 codeLen = mapPtr[i].numCodeBytes; 3251 if (codeLen < 0) { 3252 Tcl_Panic("GetCmdLocEncodingSize: bad code length"); 3253 } else if (codeLen <= 127) { 3254 codeLengthNext++; 3255 } else { 3256 codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ 3257 } 3258 3259 srcDelta = (mapPtr[i].srcOffset - prevSrcOffset); 3260 if ((-127 <= srcDelta) && (srcDelta <= 127)) { 3261 srcDeltaNext++; 3262 } else { 3263 srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */ 3264 } 3265 prevSrcOffset = mapPtr[i].srcOffset; 3266 3267 srcLen = mapPtr[i].numSrcBytes; 3268 if (srcLen < 0) { 3269 Tcl_Panic("GetCmdLocEncodingSize: bad source length"); 3270 } else if (srcLen <= 127) { 3271 srcLengthNext++; 3272 } else { 3273 srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */ 3274 } 3275 } 3276 3277 return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext); 3278} 3279 3280/* 3281 *---------------------------------------------------------------------- 3282 * 3283 * EncodeCmdLocMap -- 3284 * 3285 * Encode the command location information for some compiled code into a 3286 * ByteCode structure. The encoded command location map is stored as 3287 * three adjacent byte sequences. 3288 * 3289 * Results: 3290 * Pointer to the first byte after the encoded command location 3291 * information. 3292 * 3293 * Side effects: 3294 * The encoded information is stored into the block of memory headed by 3295 * codePtr. Also records pointers to the start of the four byte sequences 3296 * in fields in codePtr's ByteCode header structure. 3297 * 3298 *---------------------------------------------------------------------- 3299 */ 3300 3301static unsigned char * 3302EncodeCmdLocMap( 3303 CompileEnv *envPtr, /* Points to compilation environment structure 3304 * containing the CmdLocation structure to 3305 * encode. */ 3306 ByteCode *codePtr, /* ByteCode in which to encode envPtr's 3307 * command location information. */ 3308 unsigned char *startPtr) /* Points to the first byte in codePtr's 3309 * memory block where the location information 3310 * is to be stored. */ 3311{ 3312 register CmdLocation *mapPtr = envPtr->cmdMapPtr; 3313 int numCmds = envPtr->numCommands; 3314 register unsigned char *p = startPtr; 3315 int codeDelta, codeLen, srcDelta, srcLen, prevOffset; 3316 register int i; 3317 3318 /* 3319 * Encode the code offset for each command as a sequence of deltas. 3320 */ 3321 3322 codePtr->codeDeltaStart = p; 3323 prevOffset = 0; 3324 for (i = 0; i < numCmds; i++) { 3325 codeDelta = (mapPtr[i].codeOffset - prevOffset); 3326 if (codeDelta < 0) { 3327 Tcl_Panic("EncodeCmdLocMap: bad code offset"); 3328 } else if (codeDelta <= 127) { 3329 TclStoreInt1AtPtr(codeDelta, p); 3330 p++; 3331 } else { 3332 TclStoreInt1AtPtr(0xFF, p); 3333 p++; 3334 TclStoreInt4AtPtr(codeDelta, p); 3335 p += 4; 3336 } 3337 prevOffset = mapPtr[i].codeOffset; 3338 } 3339 3340 /* 3341 * Encode the code length for each command. 3342 */ 3343 3344 codePtr->codeLengthStart = p; 3345 for (i = 0; i < numCmds; i++) { 3346 codeLen = mapPtr[i].numCodeBytes; 3347 if (codeLen < 0) { 3348 Tcl_Panic("EncodeCmdLocMap: bad code length"); 3349 } else if (codeLen <= 127) { 3350 TclStoreInt1AtPtr(codeLen, p); 3351 p++; 3352 } else { 3353 TclStoreInt1AtPtr(0xFF, p); 3354 p++; 3355 TclStoreInt4AtPtr(codeLen, p); 3356 p += 4; 3357 } 3358 } 3359 3360 /* 3361 * Encode the source offset for each command as a sequence of deltas. 3362 */ 3363 3364 codePtr->srcDeltaStart = p; 3365 prevOffset = 0; 3366 for (i = 0; i < numCmds; i++) { 3367 srcDelta = (mapPtr[i].srcOffset - prevOffset); 3368 if ((-127 <= srcDelta) && (srcDelta <= 127)) { 3369 TclStoreInt1AtPtr(srcDelta, p); 3370 p++; 3371 } else { 3372 TclStoreInt1AtPtr(0xFF, p); 3373 p++; 3374 TclStoreInt4AtPtr(srcDelta, p); 3375 p += 4; 3376 } 3377 prevOffset = mapPtr[i].srcOffset; 3378 } 3379 3380 /* 3381 * Encode the source length for each command. 3382 */ 3383 3384 codePtr->srcLengthStart = p; 3385 for (i = 0; i < numCmds; i++) { 3386 srcLen = mapPtr[i].numSrcBytes; 3387 if (srcLen < 0) { 3388 Tcl_Panic("EncodeCmdLocMap: bad source length"); 3389 } else if (srcLen <= 127) { 3390 TclStoreInt1AtPtr(srcLen, p); 3391 p++; 3392 } else { 3393 TclStoreInt1AtPtr(0xFF, p); 3394 p++; 3395 TclStoreInt4AtPtr(srcLen, p); 3396 p += 4; 3397 } 3398 } 3399 3400 return p; 3401} 3402 3403#ifdef TCL_COMPILE_DEBUG 3404/* 3405 *---------------------------------------------------------------------- 3406 * 3407 * TclPrintByteCodeObj -- 3408 * 3409 * This procedure prints ("disassembles") the instructions of a bytecode 3410 * object to stdout. 3411 * 3412 * Results: 3413 * None. 3414 * 3415 * Side effects: 3416 * None. 3417 * 3418 *---------------------------------------------------------------------- 3419 */ 3420 3421void 3422TclPrintByteCodeObj( 3423 Tcl_Interp *interp, /* Used only for Tcl_GetStringFromObj. */ 3424 Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ 3425{ 3426 Tcl_Obj *bufPtr = TclDisassembleByteCodeObj(objPtr); 3427 3428 fprintf(stdout, "\n%s", TclGetString(bufPtr)); 3429 Tcl_DecrRefCount(bufPtr); 3430} 3431 3432/* 3433 *---------------------------------------------------------------------- 3434 * 3435 * TclPrintInstruction -- 3436 * 3437 * This procedure prints ("disassembles") one instruction from a bytecode 3438 * object to stdout. 3439 * 3440 * Results: 3441 * Returns the length in bytes of the current instruiction. 3442 * 3443 * Side effects: 3444 * None. 3445 * 3446 *---------------------------------------------------------------------- 3447 */ 3448 3449int 3450TclPrintInstruction( 3451 ByteCode *codePtr, /* Bytecode containing the instruction. */ 3452 unsigned char *pc) /* Points to first byte of instruction. */ 3453{ 3454 Tcl_Obj *bufferObj; 3455 int numBytes; 3456 3457 TclNewObj(bufferObj); 3458 numBytes = FormatInstruction(codePtr, pc, bufferObj); 3459 fprintf(stdout, "%s", TclGetString(bufferObj)); 3460 Tcl_DecrRefCount(bufferObj); 3461 return numBytes; 3462} 3463 3464/* 3465 *---------------------------------------------------------------------- 3466 * 3467 * TclPrintObject -- 3468 * 3469 * This procedure prints up to a specified number of characters from the 3470 * argument Tcl object's string representation to a specified file. 3471 * 3472 * Results: 3473 * None. 3474 * 3475 * Side effects: 3476 * Outputs characters to the specified file. 3477 * 3478 *---------------------------------------------------------------------- 3479 */ 3480 3481void 3482TclPrintObject( 3483 FILE *outFile, /* The file to print the source to. */ 3484 Tcl_Obj *objPtr, /* Points to the Tcl object whose string 3485 * representation should be printed. */ 3486 int maxChars) /* Maximum number of chars to print. */ 3487{ 3488 char *bytes; 3489 int length; 3490 3491 bytes = Tcl_GetStringFromObj(objPtr, &length); 3492 TclPrintSource(outFile, bytes, TclMin(length, maxChars)); 3493} 3494 3495/* 3496 *---------------------------------------------------------------------- 3497 * 3498 * TclPrintSource -- 3499 * 3500 * This procedure prints up to a specified number of characters from the 3501 * argument string to a specified file. It tries to produce legible 3502 * output by adding backslashes as necessary. 3503 * 3504 * Results: 3505 * None. 3506 * 3507 * Side effects: 3508 * Outputs characters to the specified file. 3509 * 3510 *---------------------------------------------------------------------- 3511 */ 3512 3513void 3514TclPrintSource( 3515 FILE *outFile, /* The file to print the source to. */ 3516 const char *stringPtr, /* The string to print. */ 3517 int maxChars) /* Maximum number of chars to print. */ 3518{ 3519 Tcl_Obj *bufferObj; 3520 3521 TclNewObj(bufferObj); 3522 PrintSourceToObj(bufferObj, stringPtr, maxChars); 3523 fprintf(outFile, "%s", TclGetString(bufferObj)); 3524 Tcl_DecrRefCount(bufferObj); 3525} 3526#endif /* TCL_COMPILE_DEBUG */ 3527 3528/* 3529 *---------------------------------------------------------------------- 3530 * 3531 * TclDisassembleByteCodeObj -- 3532 * 3533 * Given an object which is of bytecode type, return a disassembled 3534 * version of the bytecode (in a new refcount 0 object). No guarantees 3535 * are made about the details of the contents of the result. 3536 * 3537 *---------------------------------------------------------------------- 3538 */ 3539 3540Tcl_Obj * 3541TclDisassembleByteCodeObj( 3542 Tcl_Obj *objPtr) /* The bytecode object to disassemble. */ 3543{ 3544 ByteCode *codePtr = objPtr->internalRep.otherValuePtr; 3545 unsigned char *codeStart, *codeLimit, *pc; 3546 unsigned char *codeDeltaNext, *codeLengthNext; 3547 unsigned char *srcDeltaNext, *srcLengthNext; 3548 int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i; 3549 Interp *iPtr = (Interp *) *codePtr->interpHandle; 3550 Tcl_Obj *bufferObj; 3551 char ptrBuf1[20], ptrBuf2[20]; 3552 3553 TclNewObj(bufferObj); 3554 if (codePtr->refCount <= 0) { 3555 return bufferObj; /* Already freed. */ 3556 } 3557 3558 codeStart = codePtr->codeStart; 3559 codeLimit = (codeStart + codePtr->numCodeBytes); 3560 numCmds = codePtr->numCommands; 3561 3562 /* 3563 * Print header lines describing the ByteCode. 3564 */ 3565 3566 sprintf(ptrBuf1, "%p", codePtr); 3567 sprintf(ptrBuf2, "%p", iPtr); 3568 Tcl_AppendPrintfToObj(bufferObj, 3569 "ByteCode 0x%s, refCt %u, epoch %u, interp 0x%s (epoch %u)\n", 3570 ptrBuf1, codePtr->refCount, codePtr->compileEpoch, ptrBuf2, 3571 iPtr->compileEpoch); 3572 Tcl_AppendToObj(bufferObj, " Source ", -1); 3573 PrintSourceToObj(bufferObj, codePtr->source, 3574 TclMin(codePtr->numSrcBytes, 55)); 3575 Tcl_AppendPrintfToObj(bufferObj, 3576 "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n", 3577 numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes, 3578 codePtr->numLitObjects, codePtr->numAuxDataItems, 3579 codePtr->maxStackDepth, 3580#ifdef TCL_COMPILE_STATS 3581 codePtr->numSrcBytes? 3582 codePtr->structureSize/(float)codePtr->numSrcBytes : 3583#endif 3584 0.0); 3585 3586#ifdef TCL_COMPILE_STATS 3587 Tcl_AppendPrintfToObj(bufferObj, 3588 " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n", 3589 (unsigned long) codePtr->structureSize, 3590 (unsigned long) (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time)), 3591 codePtr->numCodeBytes, 3592 (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)), 3593 (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)), 3594 (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)), 3595 codePtr->numCmdLocBytes); 3596#endif /* TCL_COMPILE_STATS */ 3597 3598 /* 3599 * If the ByteCode is the compiled body of a Tcl procedure, print 3600 * information about that procedure. Note that we don't know the 3601 * procedure's name since ByteCode's can be shared among procedures. 3602 */ 3603 3604 if (codePtr->procPtr != NULL) { 3605 Proc *procPtr = codePtr->procPtr; 3606 int numCompiledLocals = procPtr->numCompiledLocals; 3607 3608 sprintf(ptrBuf1, "%p", procPtr); 3609 Tcl_AppendPrintfToObj(bufferObj, 3610 " Proc 0x%s, refCt %d, args %d, compiled locals %d\n", 3611 ptrBuf1, procPtr->refCount, procPtr->numArgs, 3612 numCompiledLocals); 3613 if (numCompiledLocals > 0) { 3614 CompiledLocal *localPtr = procPtr->firstLocalPtr; 3615 3616 for (i = 0; i < numCompiledLocals; i++) { 3617 Tcl_AppendPrintfToObj(bufferObj, 3618 " slot %d%s%s%s%s%s%s", i, 3619 (localPtr->flags & (VAR_ARRAY|VAR_LINK)) ? "" : ", scalar", 3620 (localPtr->flags & VAR_ARRAY) ? ", array" : "", 3621 (localPtr->flags & VAR_LINK) ? ", link" : "", 3622 (localPtr->flags & VAR_ARGUMENT) ? ", arg" : "", 3623 (localPtr->flags & VAR_TEMPORARY) ? ", temp" : "", 3624 (localPtr->flags & VAR_RESOLVED) ? ", resolved" : ""); 3625 if (TclIsVarTemporary(localPtr)) { 3626 Tcl_AppendToObj(bufferObj, "\n", -1); 3627 } else { 3628 Tcl_AppendPrintfToObj(bufferObj, ", \"%s\"\n", 3629 localPtr->name); 3630 } 3631 localPtr = localPtr->nextPtr; 3632 } 3633 } 3634 } 3635 3636 /* 3637 * Print the ExceptionRange array. 3638 */ 3639 3640 if (codePtr->numExceptRanges > 0) { 3641 Tcl_AppendPrintfToObj(bufferObj, " Exception ranges %d, depth %d:\n", 3642 codePtr->numExceptRanges, codePtr->maxExceptDepth); 3643 for (i = 0; i < codePtr->numExceptRanges; i++) { 3644 ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]); 3645 3646 Tcl_AppendPrintfToObj(bufferObj, 3647 " %d: level %d, %s, pc %d-%d, ", 3648 i, rangePtr->nestingLevel, 3649 (rangePtr->type==LOOP_EXCEPTION_RANGE ? "loop" : "catch"), 3650 rangePtr->codeOffset, 3651 (rangePtr->codeOffset + rangePtr->numCodeBytes - 1)); 3652 switch (rangePtr->type) { 3653 case LOOP_EXCEPTION_RANGE: 3654 Tcl_AppendPrintfToObj(bufferObj, "continue %d, break %d\n", 3655 rangePtr->continueOffset, rangePtr->breakOffset); 3656 break; 3657 case CATCH_EXCEPTION_RANGE: 3658 Tcl_AppendPrintfToObj(bufferObj, "catch %d\n", 3659 rangePtr->catchOffset); 3660 break; 3661 default: 3662 Tcl_Panic("TclDisassembleByteCodeObj: bad ExceptionRange type %d", 3663 rangePtr->type); 3664 } 3665 } 3666 } 3667 3668 /* 3669 * If there were no commands (e.g., an expression or an empty string was 3670 * compiled), just print all instructions and return. 3671 */ 3672 3673 if (numCmds == 0) { 3674 pc = codeStart; 3675 while (pc < codeLimit) { 3676 Tcl_AppendToObj(bufferObj, " ", -1); 3677 pc += FormatInstruction(codePtr, pc, bufferObj); 3678 } 3679 return bufferObj; 3680 } 3681 3682 /* 3683 * Print table showing the code offset, source offset, and source length 3684 * for each command. These are encoded as a sequence of bytes. 3685 */ 3686 3687 Tcl_AppendPrintfToObj(bufferObj, " Commands %d:", numCmds); 3688 codeDeltaNext = codePtr->codeDeltaStart; 3689 codeLengthNext = codePtr->codeLengthStart; 3690 srcDeltaNext = codePtr->srcDeltaStart; 3691 srcLengthNext = codePtr->srcLengthStart; 3692 codeOffset = srcOffset = 0; 3693 for (i = 0; i < numCmds; i++) { 3694 if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { 3695 codeDeltaNext++; 3696 delta = TclGetInt4AtPtr(codeDeltaNext); 3697 codeDeltaNext += 4; 3698 } else { 3699 delta = TclGetInt1AtPtr(codeDeltaNext); 3700 codeDeltaNext++; 3701 } 3702 codeOffset += delta; 3703 3704 if ((unsigned) *codeLengthNext == (unsigned) 0xFF) { 3705 codeLengthNext++; 3706 codeLen = TclGetInt4AtPtr(codeLengthNext); 3707 codeLengthNext += 4; 3708 } else { 3709 codeLen = TclGetInt1AtPtr(codeLengthNext); 3710 codeLengthNext++; 3711 } 3712 3713 if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { 3714 srcDeltaNext++; 3715 delta = TclGetInt4AtPtr(srcDeltaNext); 3716 srcDeltaNext += 4; 3717 } else { 3718 delta = TclGetInt1AtPtr(srcDeltaNext); 3719 srcDeltaNext++; 3720 } 3721 srcOffset += delta; 3722 3723 if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { 3724 srcLengthNext++; 3725 srcLen = TclGetInt4AtPtr(srcLengthNext); 3726 srcLengthNext += 4; 3727 } else { 3728 srcLen = TclGetInt1AtPtr(srcLengthNext); 3729 srcLengthNext++; 3730 } 3731 3732 Tcl_AppendPrintfToObj(bufferObj, "%s%4d: pc %d-%d, src %d-%d", 3733 ((i % 2)? " " : "\n "), 3734 (i+1), codeOffset, (codeOffset + codeLen - 1), 3735 srcOffset, (srcOffset + srcLen - 1)); 3736 } 3737 if (numCmds > 0) { 3738 Tcl_AppendToObj(bufferObj, "\n", -1); 3739 } 3740 3741 /* 3742 * Print each instruction. If the instruction corresponds to the start of 3743 * a command, print the command's source. Note that we don't need the code 3744 * length here. 3745 */ 3746 3747 codeDeltaNext = codePtr->codeDeltaStart; 3748 srcDeltaNext = codePtr->srcDeltaStart; 3749 srcLengthNext = codePtr->srcLengthStart; 3750 codeOffset = srcOffset = 0; 3751 pc = codeStart; 3752 for (i = 0; i < numCmds; i++) { 3753 if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) { 3754 codeDeltaNext++; 3755 delta = TclGetInt4AtPtr(codeDeltaNext); 3756 codeDeltaNext += 4; 3757 } else { 3758 delta = TclGetInt1AtPtr(codeDeltaNext); 3759 codeDeltaNext++; 3760 } 3761 codeOffset += delta; 3762 3763 if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) { 3764 srcDeltaNext++; 3765 delta = TclGetInt4AtPtr(srcDeltaNext); 3766 srcDeltaNext += 4; 3767 } else { 3768 delta = TclGetInt1AtPtr(srcDeltaNext); 3769 srcDeltaNext++; 3770 } 3771 srcOffset += delta; 3772 3773 if ((unsigned) *srcLengthNext == (unsigned) 0xFF) { 3774 srcLengthNext++; 3775 srcLen = TclGetInt4AtPtr(srcLengthNext); 3776 srcLengthNext += 4; 3777 } else { 3778 srcLen = TclGetInt1AtPtr(srcLengthNext); 3779 srcLengthNext++; 3780 } 3781 3782 /* 3783 * Print instructions before command i. 3784 */ 3785 3786 while ((pc-codeStart) < codeOffset) { 3787 Tcl_AppendToObj(bufferObj, " ", -1); 3788 pc += FormatInstruction(codePtr, pc, bufferObj); 3789 } 3790 3791 Tcl_AppendPrintfToObj(bufferObj, " Command %d: ", i+1); 3792 PrintSourceToObj(bufferObj, (codePtr->source + srcOffset), 3793 TclMin(srcLen, 55)); 3794 Tcl_AppendToObj(bufferObj, "\n", -1); 3795 } 3796 if (pc < codeLimit) { 3797 /* 3798 * Print instructions after the last command. 3799 */ 3800 3801 while (pc < codeLimit) { 3802 Tcl_AppendToObj(bufferObj, " ", -1); 3803 pc += FormatInstruction(codePtr, pc, bufferObj); 3804 } 3805 } 3806 return bufferObj; 3807} 3808 3809/* 3810 *---------------------------------------------------------------------- 3811 * 3812 * FormatInstruction -- 3813 * 3814 * Appends a representation of a bytecode instruction to a Tcl_Obj. 3815 * 3816 *---------------------------------------------------------------------- 3817 */ 3818 3819static int 3820FormatInstruction( 3821 ByteCode *codePtr, /* Bytecode containing the instruction. */ 3822 unsigned char *pc, /* Points to first byte of instruction. */ 3823 Tcl_Obj *bufferObj) /* Object to append instruction info to. */ 3824{ 3825 Proc *procPtr = codePtr->procPtr; 3826 unsigned char opCode = *pc; 3827 register InstructionDesc *instDesc = &tclInstructionTable[opCode]; 3828 unsigned char *codeStart = codePtr->codeStart; 3829 unsigned pcOffset = pc - codeStart; 3830 int opnd = 0, i, j, numBytes = 1; 3831 int localCt = procPtr ? procPtr->numCompiledLocals : 0; 3832 CompiledLocal *localPtr = procPtr ? procPtr->firstLocalPtr : NULL; 3833 char suffixBuffer[128]; /* Additional info to print after main opcode 3834 * and immediates. */ 3835 char *suffixSrc = NULL; 3836 Tcl_Obj *suffixObj = NULL; 3837 AuxData *auxPtr = NULL; 3838 3839 suffixBuffer[0] = '\0'; 3840 Tcl_AppendPrintfToObj(bufferObj, "(%u) %s ", pcOffset, instDesc->name); 3841 for (i = 0; i < instDesc->numOperands; i++) { 3842 switch (instDesc->opTypes[i]) { 3843 case OPERAND_INT1: 3844 opnd = TclGetInt1AtPtr(pc+numBytes); numBytes++; 3845 if (opCode == INST_JUMP1 || opCode == INST_JUMP_TRUE1 3846 || opCode == INST_JUMP_FALSE1) { 3847 sprintf(suffixBuffer, "pc %u", pcOffset+opnd); 3848 } 3849 Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); 3850 break; 3851 case OPERAND_INT4: 3852 opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; 3853 if (opCode == INST_JUMP4 || opCode == INST_JUMP_TRUE4 3854 || opCode == INST_JUMP_FALSE4) { 3855 sprintf(suffixBuffer, "pc %u", pcOffset+opnd); 3856 } else if (opCode == INST_START_CMD) { 3857 sprintf(suffixBuffer, "next cmd at pc %u", pcOffset+opnd); 3858 } 3859 Tcl_AppendPrintfToObj(bufferObj, "%+d ", opnd); 3860 break; 3861 case OPERAND_UINT1: 3862 opnd = TclGetUInt1AtPtr(pc+numBytes); numBytes++; 3863 if (opCode == INST_PUSH1) { 3864 suffixObj = codePtr->objArrayPtr[opnd]; 3865 } 3866 Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); 3867 break; 3868 case OPERAND_AUX4: 3869 case OPERAND_UINT4: 3870 opnd = TclGetUInt4AtPtr(pc+numBytes); numBytes += 4; 3871 if (opCode == INST_PUSH4) { 3872 suffixObj = codePtr->objArrayPtr[opnd]; 3873 } else if (opCode == INST_START_CMD && opnd != 1) { 3874 sprintf(suffixBuffer+strlen(suffixBuffer), 3875 ", %u cmds start here", opnd); 3876 } 3877 Tcl_AppendPrintfToObj(bufferObj, "%u ", (unsigned) opnd); 3878 if (instDesc->opTypes[i] == OPERAND_AUX4) { 3879 auxPtr = &codePtr->auxDataArrayPtr[opnd]; 3880 } 3881 break; 3882 case OPERAND_IDX4: 3883 opnd = TclGetInt4AtPtr(pc+numBytes); numBytes += 4; 3884 if (opnd >= -1) { 3885 Tcl_AppendPrintfToObj(bufferObj, "%d ", opnd); 3886 } else if (opnd == -2) { 3887 Tcl_AppendPrintfToObj(bufferObj, "end "); 3888 } else { 3889 Tcl_AppendPrintfToObj(bufferObj, "end-%d ", -2-opnd); 3890 } 3891 break; 3892 case OPERAND_LVT1: 3893 opnd = TclGetUInt1AtPtr(pc+numBytes); 3894 numBytes++; 3895 goto printLVTindex; 3896 case OPERAND_LVT4: 3897 opnd = TclGetUInt4AtPtr(pc+numBytes); 3898 numBytes += 4; 3899 printLVTindex: 3900 if (localPtr != NULL) { 3901 if (opnd >= localCt) { 3902 Tcl_Panic("FormatInstruction: bad local var index %u (%u locals)", 3903 (unsigned) opnd, localCt); 3904 } 3905 for (j = 0; j < opnd; j++) { 3906 localPtr = localPtr->nextPtr; 3907 } 3908 if (TclIsVarTemporary(localPtr)) { 3909 sprintf(suffixBuffer, "temp var %u", (unsigned) opnd); 3910 } else { 3911 sprintf(suffixBuffer, "var "); 3912 suffixSrc = localPtr->name; 3913 } 3914 } 3915 Tcl_AppendPrintfToObj(bufferObj, "%%v%u ", (unsigned) opnd); 3916 break; 3917 case OPERAND_NONE: 3918 default: 3919 break; 3920 } 3921 } 3922 if (suffixObj) { 3923 char *bytes; 3924 int length; 3925 3926 Tcl_AppendToObj(bufferObj, "\t# ", -1); 3927 bytes = Tcl_GetStringFromObj(codePtr->objArrayPtr[opnd], &length); 3928 PrintSourceToObj(bufferObj, bytes, TclMin(length, 40)); 3929 } else if (suffixBuffer[0]) { 3930 Tcl_AppendPrintfToObj(bufferObj, "\t# %s", suffixBuffer); 3931 if (suffixSrc) { 3932 PrintSourceToObj(bufferObj, suffixSrc, 40); 3933 } 3934 } 3935 Tcl_AppendToObj(bufferObj, "\n", -1); 3936 if (auxPtr && auxPtr->type->printProc) { 3937 Tcl_AppendToObj(bufferObj, "\t\t[", -1); 3938 auxPtr->type->printProc(auxPtr->clientData, bufferObj, codePtr, 3939 pcOffset); 3940 Tcl_AppendToObj(bufferObj, "]\n", -1); 3941 } 3942 return numBytes; 3943} 3944 3945/* 3946 *---------------------------------------------------------------------- 3947 * 3948 * PrintSourceToObj -- 3949 * 3950 * Appends a quoted representation of a string to a Tcl_Obj. 3951 * 3952 *---------------------------------------------------------------------- 3953 */ 3954 3955static void 3956PrintSourceToObj( 3957 Tcl_Obj *appendObj, /* The object to print the source to. */ 3958 const char *stringPtr, /* The string to print. */ 3959 int maxChars) /* Maximum number of chars to print. */ 3960{ 3961 register const char *p; 3962 register int i = 0; 3963 3964 if (stringPtr == NULL) { 3965 Tcl_AppendToObj(appendObj, "\"\"", -1); 3966 return; 3967 } 3968 3969 Tcl_AppendToObj(appendObj, "\"", -1); 3970 p = stringPtr; 3971 for (; (*p != '\0') && (i < maxChars); p++, i++) { 3972 switch (*p) { 3973 case '"': 3974 Tcl_AppendToObj(appendObj, "\\\"", -1); 3975 continue; 3976 case '\f': 3977 Tcl_AppendToObj(appendObj, "\\f", -1); 3978 continue; 3979 case '\n': 3980 Tcl_AppendToObj(appendObj, "\\n", -1); 3981 continue; 3982 case '\r': 3983 Tcl_AppendToObj(appendObj, "\\r", -1); 3984 continue; 3985 case '\t': 3986 Tcl_AppendToObj(appendObj, "\\t", -1); 3987 continue; 3988 case '\v': 3989 Tcl_AppendToObj(appendObj, "\\v", -1); 3990 continue; 3991 default: 3992 Tcl_AppendPrintfToObj(appendObj, "%c", *p); 3993 continue; 3994 } 3995 } 3996 Tcl_AppendToObj(appendObj, "\"", -1); 3997} 3998 3999#ifdef TCL_COMPILE_STATS 4000/* 4001 *---------------------------------------------------------------------- 4002 * 4003 * RecordByteCodeStats -- 4004 * 4005 * Accumulates various compilation-related statistics for each newly 4006 * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is 4007 * compiled with the -DTCL_COMPILE_STATS flag 4008 * 4009 * Results: 4010 * None. 4011 * 4012 * Side effects: 4013 * Accumulates aggregate code-related statistics in the interpreter's 4014 * ByteCodeStats structure. Records statistics specific to a ByteCode in 4015 * its ByteCode structure. 4016 * 4017 *---------------------------------------------------------------------- 4018 */ 4019 4020void 4021RecordByteCodeStats( 4022 ByteCode *codePtr) /* Points to ByteCode structure with info 4023 * to add to accumulated statistics. */ 4024{ 4025 Interp *iPtr = (Interp *) *codePtr->interpHandle; 4026 register ByteCodeStats *statsPtr = &(iPtr->stats); 4027 4028 statsPtr->numCompilations++; 4029 statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes; 4030 statsPtr->totalByteCodeBytes += (double) codePtr->structureSize; 4031 statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes; 4032 statsPtr->currentByteCodeBytes += (double) codePtr->structureSize; 4033 4034 statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++; 4035 statsPtr->byteCodeCount[TclLog2((int)(codePtr->structureSize))]++; 4036 4037 statsPtr->currentInstBytes += (double) codePtr->numCodeBytes; 4038 statsPtr->currentLitBytes += (double) 4039 codePtr->numLitObjects * sizeof(Tcl_Obj *); 4040 statsPtr->currentExceptBytes += (double) 4041 codePtr->numExceptRanges * sizeof(ExceptionRange); 4042 statsPtr->currentAuxBytes += (double) 4043 codePtr->numAuxDataItems * sizeof(AuxData); 4044 statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes; 4045} 4046#endif /* TCL_COMPILE_STATS */ 4047 4048/* 4049 * Local Variables: 4050 * mode: c 4051 * c-basic-offset: 4 4052 * fill-column: 78 4053 * End: 4054 */ 4055