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