/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompile.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompile.c

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (show annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 3 months ago) by dashley
File MIME type: text/plain
File size: 109699 byte(s)
Adjust line endings to Windows style.
Set properties to expand the "Header" keyword.
Change header and footer.
1 /* $Header$ */
2 /*
3 * tclCompile.c --
4 *
5 * This file contains procedures that compile Tcl commands or parts
6 * of commands (like quoted strings or nested sub-commands) into a
7 * sequence of instructions ("bytecodes").
8 *
9 * Copyright (c) 1996-1998 Sun Microsystems, Inc.
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.1.1.1 2001/06/13 04:36:17 dtashley Exp $
15 */
16
17 #include "tclInt.h"
18 #include "tclCompile.h"
19
20 /*
21 * Table of all AuxData types.
22 */
23
24 static Tcl_HashTable auxDataTypeTable;
25 static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
26
27 TCL_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 int tclTraceCompile = 0;
39 static int traceInitialized = 0;
40
41 /*
42 * A table describing the Tcl bytecode instructions. Entries in this table
43 * must correspond to the instruction opcode definitions in tclCompile.h.
44 * The names "op1" and "op4" refer to an instruction's one or four byte
45 * first operand. Similarly, "stktop" and "stknext" refer to the topmost
46 * and next to topmost stack elements.
47 *
48 * Note that the load, store, and incr instructions do not distinguish local
49 * from global variables; the bytecode interpreter at runtime uses the
50 * existence of a procedure call frame to distinguish these.
51 */
52
53 InstructionDesc instructionTable[] = {
54 /* Name Bytes #Opnds Operand types Stack top, next */
55 {"done", 1, 0, {OPERAND_NONE}},
56 /* Finish ByteCode execution and return stktop (top stack item) */
57 {"push1", 2, 1, {OPERAND_UINT1}},
58 /* Push object at ByteCode objArray[op1] */
59 {"push4", 5, 1, {OPERAND_UINT4}},
60 /* Push object at ByteCode objArray[op4] */
61 {"pop", 1, 0, {OPERAND_NONE}},
62 /* Pop the topmost stack object */
63 {"dup", 1, 0, {OPERAND_NONE}},
64 /* Duplicate the topmost stack object and push the result */
65 {"concat1", 2, 1, {OPERAND_UINT1}},
66 /* Concatenate the top op1 items and push result */
67 {"invokeStk1", 2, 1, {OPERAND_UINT1}},
68 /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
69 {"invokeStk4", 5, 1, {OPERAND_UINT4}},
70 /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
71 {"evalStk", 1, 0, {OPERAND_NONE}},
72 /* Evaluate command in stktop using Tcl_EvalObj. */
73 {"exprStk", 1, 0, {OPERAND_NONE}},
74 /* Execute expression in stktop using Tcl_ExprStringObj. */
75
76 {"loadScalar1", 2, 1, {OPERAND_UINT1}},
77 /* Load scalar variable at index op1 <= 255 in call frame */
78 {"loadScalar4", 5, 1, {OPERAND_UINT4}},
79 /* Load scalar variable at index op1 >= 256 in call frame */
80 {"loadScalarStk", 1, 0, {OPERAND_NONE}},
81 /* Load scalar variable; scalar's name is stktop */
82 {"loadArray1", 2, 1, {OPERAND_UINT1}},
83 /* Load array element; array at slot op1<=255, element is stktop */
84 {"loadArray4", 5, 1, {OPERAND_UINT4}},
85 /* Load array element; array at slot op1 > 255, element is stktop */
86 {"loadArrayStk", 1, 0, {OPERAND_NONE}},
87 /* Load array element; element is stktop, array name is stknext */
88 {"loadStk", 1, 0, {OPERAND_NONE}},
89 /* Load general variable; unparsed variable name is stktop */
90 {"storeScalar1", 2, 1, {OPERAND_UINT1}},
91 /* Store scalar variable at op1<=255 in frame; value is stktop */
92 {"storeScalar4", 5, 1, {OPERAND_UINT4}},
93 /* Store scalar variable at op1 > 255 in frame; value is stktop */
94 {"storeScalarStk", 1, 0, {OPERAND_NONE}},
95 /* Store scalar; value is stktop, scalar name is stknext */
96 {"storeArray1", 2, 1, {OPERAND_UINT1}},
97 /* Store array element; array at op1<=255, value is top then elem */
98 {"storeArray4", 5, 1, {OPERAND_UINT4}},
99 /* Store array element; array at op1>=256, value is top then elem */
100 {"storeArrayStk", 1, 0, {OPERAND_NONE}},
101 /* Store array element; value is stktop, then elem, array names */
102 {"storeStk", 1, 0, {OPERAND_NONE}},
103 /* Store general variable; value is stktop, then unparsed name */
104
105 {"incrScalar1", 2, 1, {OPERAND_UINT1}},
106 /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
107 {"incrScalarStk", 1, 0, {OPERAND_NONE}},
108 /* Incr scalar; incr amount is stktop, scalar's name is stknext */
109 {"incrArray1", 2, 1, {OPERAND_UINT1}},
110 /* Incr array elem; arr at slot op1<=255, amount is top then elem */
111 {"incrArrayStk", 1, 0, {OPERAND_NONE}},
112 /* Incr array element; amount is top then elem then array names */
113 {"incrStk", 1, 0, {OPERAND_NONE}},
114 /* Incr general variable; amount is stktop then unparsed var name */
115 {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
116 /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
117 {"incrScalarStkImm", 2, 1, {OPERAND_INT1}},
118 /* Incr scalar; scalar name is stktop; incr amount is op1 */
119 {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
120 /* Incr array elem; array at slot op1 <= 255, elem is stktop,
121 * amount is 2nd operand byte */
122 {"incrArrayStkImm", 2, 1, {OPERAND_INT1}},
123 /* Incr array element; elem is top then array name, amount is op1 */
124 {"incrStkImm", 2, 1, {OPERAND_INT1}},
125 /* Incr general variable; unparsed name is top, amount is op1 */
126
127 {"jump1", 2, 1, {OPERAND_INT1}},
128 /* Jump relative to (pc + op1) */
129 {"jump4", 5, 1, {OPERAND_INT4}},
130 /* Jump relative to (pc + op4) */
131 {"jumpTrue1", 2, 1, {OPERAND_INT1}},
132 /* Jump relative to (pc + op1) if stktop expr object is true */
133 {"jumpTrue4", 5, 1, {OPERAND_INT4}},
134 /* Jump relative to (pc + op4) if stktop expr object is true */
135 {"jumpFalse1", 2, 1, {OPERAND_INT1}},
136 /* Jump relative to (pc + op1) if stktop expr object is false */
137 {"jumpFalse4", 5, 1, {OPERAND_INT4}},
138 /* Jump relative to (pc + op4) if stktop expr object is false */
139
140 {"lor", 1, 0, {OPERAND_NONE}},
141 /* Logical or: push (stknext || stktop) */
142 {"land", 1, 0, {OPERAND_NONE}},
143 /* Logical and: push (stknext && stktop) */
144 {"bitor", 1, 0, {OPERAND_NONE}},
145 /* Bitwise or: push (stknext | stktop) */
146 {"bitxor", 1, 0, {OPERAND_NONE}},
147 /* Bitwise xor push (stknext ^ stktop) */
148 {"bitand", 1, 0, {OPERAND_NONE}},
149 /* Bitwise and: push (stknext & stktop) */
150 {"eq", 1, 0, {OPERAND_NONE}},
151 /* Equal: push (stknext == stktop) */
152 {"neq", 1, 0, {OPERAND_NONE}},
153 /* Not equal: push (stknext != stktop) */
154 {"lt", 1, 0, {OPERAND_NONE}},
155 /* Less: push (stknext < stktop) */
156 {"gt", 1, 0, {OPERAND_NONE}},
157 /* Greater: push (stknext || stktop) */
158 {"le", 1, 0, {OPERAND_NONE}},
159 /* Logical or: push (stknext || stktop) */
160 {"ge", 1, 0, {OPERAND_NONE}},
161 /* Logical or: push (stknext || stktop) */
162 {"lshift", 1, 0, {OPERAND_NONE}},
163 /* Left shift: push (stknext << stktop) */
164 {"rshift", 1, 0, {OPERAND_NONE}},
165 /* Right shift: push (stknext >> stktop) */
166 {"add", 1, 0, {OPERAND_NONE}},
167 /* Add: push (stknext + stktop) */
168 {"sub", 1, 0, {OPERAND_NONE}},
169 /* Sub: push (stkext - stktop) */
170 {"mult", 1, 0, {OPERAND_NONE}},
171 /* Multiply: push (stknext * stktop) */
172 {"div", 1, 0, {OPERAND_NONE}},
173 /* Divide: push (stknext / stktop) */
174 {"mod", 1, 0, {OPERAND_NONE}},
175 /* Mod: push (stknext % stktop) */
176 {"uplus", 1, 0, {OPERAND_NONE}},
177 /* Unary plus: push +stktop */
178 {"uminus", 1, 0, {OPERAND_NONE}},
179 /* Unary minus: push -stktop */
180 {"bitnot", 1, 0, {OPERAND_NONE}},
181 /* Bitwise not: push ~stktop */
182 {"not", 1, 0, {OPERAND_NONE}},
183 /* Logical not: push !stktop */
184 {"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}},
185 /* Call builtin math function with index op1; any args are on stk */
186 {"callFunc1", 2, 1, {OPERAND_UINT1}},
187 /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
188 {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}},
189 /* Try converting stktop to first int then double if possible. */
190
191 {"break", 1, 0, {OPERAND_NONE}},
192 /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
193 {"continue", 1, 0, {OPERAND_NONE}},
194 /* Skip to next iteration of closest enclosing loop; if none,
195 * return TCL_CONTINUE code. */
196
197 {"foreach_start4", 5, 1, {OPERAND_UINT4}},
198 /* Initialize execution of a foreach loop. Operand is aux data index
199 * of the ForeachInfo structure for the foreach command. */
200 {"foreach_step4", 5, 1, {OPERAND_UINT4}},
201 /* "Step" or begin next iteration of foreach loop. Push 0 if to
202 * terminate loop, else push 1. */
203
204 {"beginCatch4", 5, 1, {OPERAND_UINT4}},
205 /* Record start of catch with the operand's exception index.
206 * Push the current stack depth onto a special catch stack. */
207 {"endCatch", 1, 0, {OPERAND_NONE}},
208 /* End of last catch. Pop the bytecode interpreter's catch stack. */
209 {"pushResult", 1, 0, {OPERAND_NONE}},
210 /* Push the interpreter's object result onto the stack. */
211 {"pushReturnCode", 1, 0, {OPERAND_NONE}},
212 /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
213 * a new object onto the stack. */
214 {0}
215 };
216
217 /*
218 * Prototypes for procedures defined later in this file:
219 */
220
221 static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
222 Tcl_Obj *copyPtr));
223 static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
224 CompileEnv *envPtr, ByteCode *codePtr,
225 unsigned char *startPtr));
226 static void EnterCmdExtentData _ANSI_ARGS_((
227 CompileEnv *envPtr, int cmdNumber,
228 int numSrcBytes, int numCodeBytes));
229 static void EnterCmdStartData _ANSI_ARGS_((
230 CompileEnv *envPtr, int cmdNumber,
231 int srcOffset, int codeOffset));
232 static void FreeByteCodeInternalRep _ANSI_ARGS_((
233 Tcl_Obj *objPtr));
234 static int GetCmdLocEncodingSize _ANSI_ARGS_((
235 CompileEnv *envPtr));
236 static void LogCompilationInfo _ANSI_ARGS_((Tcl_Interp *interp,
237 char *script, char *command, int length));
238 #ifdef TCL_COMPILE_STATS
239 static void RecordByteCodeStats _ANSI_ARGS_((
240 ByteCode *codePtr));
241 #endif /* TCL_COMPILE_STATS */
242 static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
243 Tcl_Obj *objPtr));
244
245 /*
246 * The structure below defines the bytecode Tcl object type by
247 * means of procedures that can be invoked by generic object code.
248 */
249
250 Tcl_ObjType tclByteCodeType = {
251 "bytecode", /* name */
252 FreeByteCodeInternalRep, /* freeIntRepProc */
253 DupByteCodeInternalRep, /* dupIntRepProc */
254 (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
255 SetByteCodeFromAny /* setFromAnyProc */
256 };
257
258 /*
259 *----------------------------------------------------------------------
260 *
261 * TclSetByteCodeFromAny --
262 *
263 * Part of the bytecode Tcl object type implementation. Attempts to
264 * generate an byte code internal form for the Tcl object "objPtr" by
265 * compiling its string representation. This function also takes
266 * a hook procedure that will be invoked to perform any needed post
267 * processing on the compilation results before generating byte
268 * codes.
269 *
270 * Results:
271 * The return value is a standard Tcl object result. If an error occurs
272 * during compilation, an error message is left in the interpreter's
273 * result unless "interp" is NULL.
274 *
275 * Side effects:
276 * Frees the old internal representation. If no error occurs, then the
277 * compiled code is stored as "objPtr"s bytecode representation.
278 * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
279 * used to trace compilations.
280 *
281 *----------------------------------------------------------------------
282 */
283
284 int
285 TclSetByteCodeFromAny(interp, objPtr, hookProc, clientData)
286 Tcl_Interp *interp; /* The interpreter for which the code is
287 * being compiled. Must not be NULL. */
288 Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
289 CompileHookProc *hookProc; /* Procedure to invoke after compilation. */
290 ClientData clientData; /* Hook procedure private data. */
291 {
292 Interp *iPtr = (Interp *) interp;
293 CompileEnv compEnv; /* Compilation environment structure
294 * allocated in frame. */
295 LiteralTable *localTablePtr = &(compEnv.localLitTable);
296 register AuxData *auxDataPtr;
297 LiteralEntry *entryPtr;
298 register int i;
299 int length, nested, result;
300 char *string;
301
302 if (!traceInitialized) {
303 if (Tcl_LinkVar(interp, "tcl_traceCompile",
304 (char *) &tclTraceCompile, TCL_LINK_INT) != TCL_OK) {
305 panic("SetByteCodeFromAny: unable to create link for tcl_traceCompile variable");
306 }
307 traceInitialized = 1;
308 }
309
310 if (iPtr->evalFlags & TCL_BRACKET_TERM) {
311 nested = 1;
312 } else {
313 nested = 0;
314 }
315 string = Tcl_GetStringFromObj(objPtr, &length);
316 TclInitCompileEnv(interp, &compEnv, string, length);
317 result = TclCompileScript(interp, string, length, nested, &compEnv);
318
319 if (result == TCL_OK) {
320 /*
321 * Successful compilation. Add a "done" instruction at the end.
322 */
323
324 compEnv.numSrcBytes = iPtr->termOffset;
325 TclEmitOpcode(INST_DONE, &compEnv);
326
327 /*
328 * Invoke the compilation hook procedure if one exists.
329 */
330
331 if (hookProc) {
332 result = (*hookProc)(interp, &compEnv, clientData);
333 }
334
335 /*
336 * Change the object into a ByteCode object. Ownership of the literal
337 * objects and aux data items is given to the ByteCode object.
338 */
339
340 #ifdef TCL_COMPILE_DEBUG
341 TclVerifyLocalLiteralTable(&compEnv);
342 #endif /*TCL_COMPILE_DEBUG*/
343
344 TclInitByteCodeObj(objPtr, &compEnv);
345 #ifdef TCL_COMPILE_DEBUG
346 if (tclTraceCompile == 2) {
347 TclPrintByteCodeObj(interp, objPtr);
348 }
349 #endif /* TCL_COMPILE_DEBUG */
350 }
351
352 if (result != TCL_OK) {
353 /*
354 * Compilation errors.
355 */
356
357 entryPtr = compEnv.literalArrayPtr;
358 for (i = 0; i < compEnv.literalArrayNext; i++) {
359 TclReleaseLiteral(interp, entryPtr->objPtr);
360 entryPtr++;
361 }
362 #ifdef TCL_COMPILE_DEBUG
363 TclVerifyGlobalLiteralTable(iPtr);
364 #endif /*TCL_COMPILE_DEBUG*/
365
366 auxDataPtr = compEnv.auxDataArrayPtr;
367 for (i = 0; i < compEnv.auxDataArrayNext; i++) {
368 if (auxDataPtr->type->freeProc != NULL) {
369 auxDataPtr->type->freeProc(auxDataPtr->clientData);
370 }
371 auxDataPtr++;
372 }
373 }
374
375
376 /*
377 * Free storage allocated during compilation.
378 */
379
380 if (localTablePtr->buckets != localTablePtr->staticBuckets) {
381 ckfree((char *) localTablePtr->buckets);
382 }
383 TclFreeCompileEnv(&compEnv);
384 return result;
385 }
386
387 /*
388 *-----------------------------------------------------------------------
389 *
390 * SetByteCodeFromAny --
391 *
392 * Part of the bytecode Tcl object type implementation. Attempts to
393 * generate an byte code internal form for the Tcl object "objPtr" by
394 * compiling its string representation.
395 *
396 * Results:
397 * The return value is a standard Tcl object result. If an error occurs
398 * during compilation, an error message is left in the interpreter's
399 * result unless "interp" is NULL.
400 *
401 * Side effects:
402 * Frees the old internal representation. If no error occurs, then the
403 * compiled code is stored as "objPtr"s bytecode representation.
404 * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
405 * used to trace compilations.
406 *
407 *----------------------------------------------------------------------
408 */
409
410 static int
411 SetByteCodeFromAny(interp, objPtr)
412 Tcl_Interp *interp; /* The interpreter for which the code is
413 * being compiled. Must not be NULL. */
414 Tcl_Obj *objPtr; /* The object to make a ByteCode object. */
415 {
416 return TclSetByteCodeFromAny(interp, objPtr,
417 (CompileHookProc *) NULL, (ClientData) NULL);
418 }
419
420 /*
421 *----------------------------------------------------------------------
422 *
423 * DupByteCodeInternalRep --
424 *
425 * Part of the bytecode Tcl object type implementation. However, it
426 * does not copy the internal representation of a bytecode Tcl_Obj, but
427 * instead leaves the new object untyped (with a NULL type pointer).
428 * Code will be compiled for the new object only if necessary.
429 *
430 * Results:
431 * None.
432 *
433 * Side effects:
434 * None.
435 *
436 *----------------------------------------------------------------------
437 */
438
439 static void
440 DupByteCodeInternalRep(srcPtr, copyPtr)
441 Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
442 Tcl_Obj *copyPtr; /* Object with internal rep to set. */
443 {
444 return;
445 }
446
447 /*
448 *----------------------------------------------------------------------
449 *
450 * FreeByteCodeInternalRep --
451 *
452 * Part of the bytecode Tcl object type implementation. Frees the
453 * storage associated with a bytecode object's internal representation
454 * unless its code is actively being executed.
455 *
456 * Results:
457 * None.
458 *
459 * Side effects:
460 * The bytecode object's internal rep is marked invalid and its
461 * code gets freed unless the code is actively being executed.
462 * In that case the cleanup is delayed until the last execution
463 * of the code completes.
464 *
465 *----------------------------------------------------------------------
466 */
467
468 static void
469 FreeByteCodeInternalRep(objPtr)
470 register Tcl_Obj *objPtr; /* Object whose internal rep to free. */
471 {
472 register ByteCode *codePtr =
473 (ByteCode *) objPtr->internalRep.otherValuePtr;
474
475 codePtr->refCount--;
476 if (codePtr->refCount <= 0) {
477 TclCleanupByteCode(codePtr);
478 }
479 objPtr->typePtr = NULL;
480 objPtr->internalRep.otherValuePtr = NULL;
481 }
482
483 /*
484 *----------------------------------------------------------------------
485 *
486 * TclCleanupByteCode --
487 *
488 * This procedure does all the real work of freeing up a bytecode
489 * object's ByteCode structure. It's called only when the structure's
490 * reference count becomes zero.
491 *
492 * Results:
493 * None.
494 *
495 * Side effects:
496 * Frees objPtr's bytecode internal representation and sets its type
497 * and objPtr->internalRep.otherValuePtr NULL. Also releases its
498 * literals and frees its auxiliary data items.
499 *
500 *----------------------------------------------------------------------
501 */
502
503 void
504 TclCleanupByteCode(codePtr)
505 register ByteCode *codePtr; /* Points to the ByteCode to free. */
506 {
507 Tcl_Interp *interp = (Tcl_Interp *) *codePtr->interpHandle;
508 int numLitObjects = codePtr->numLitObjects;
509 int numAuxDataItems = codePtr->numAuxDataItems;
510 register Tcl_Obj **objArrayPtr;
511 register AuxData *auxDataPtr;
512 int i;
513 #ifdef TCL_COMPILE_STATS
514
515 if (interp != NULL) {
516 ByteCodeStats *statsPtr;
517 Tcl_Time destroyTime;
518 int lifetimeSec, lifetimeMicroSec, log2;
519
520 statsPtr = &((Interp *) interp)->stats;
521
522 statsPtr->numByteCodesFreed++;
523 statsPtr->currentSrcBytes -= (double) codePtr->numSrcBytes;
524 statsPtr->currentByteCodeBytes -= (double) codePtr->structureSize;
525
526 statsPtr->currentInstBytes -= (double) codePtr->numCodeBytes;
527 statsPtr->currentLitBytes -=
528 (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
529 statsPtr->currentExceptBytes -=
530 (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
531 statsPtr->currentAuxBytes -=
532 (double) (codePtr->numAuxDataItems * sizeof(AuxData));
533 statsPtr->currentCmdMapBytes -= (double) codePtr->numCmdLocBytes;
534
535 TclpGetTime(&destroyTime);
536 lifetimeSec = destroyTime.sec - codePtr->createTime.sec;
537 if (lifetimeSec > 2000) { /* avoid overflow */
538 lifetimeSec = 2000;
539 }
540 lifetimeMicroSec =
541 1000000*lifetimeSec + (destroyTime.usec - codePtr->createTime.usec);
542
543 log2 = TclLog2(lifetimeMicroSec);
544 if (log2 > 31) {
545 log2 = 31;
546 }
547 statsPtr->lifetimeCount[log2]++;
548 }
549 #endif /* TCL_COMPILE_STATS */
550
551 /*
552 * A single heap object holds the ByteCode structure and its code,
553 * object, command location, and auxiliary data arrays. This means we
554 * only need to 1) decrement the ref counts of the LiteralEntry's in
555 * its literal array, 2) call the free procs for the auxiliary data
556 * items, and 3) free the ByteCode structure's heap object.
557 *
558 * The case for TCL_BYTECODE_PRECOMPILED (precompiled ByteCodes,
559 * like those generated from tbcload) is special, as they doesn't
560 * make use of the global literal table. They instead maintain
561 * private references to their literals which must be decremented.
562 */
563
564 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
565 register Tcl_Obj *objPtr;
566
567 objArrayPtr = codePtr->objArrayPtr;
568 for (i = 0; i < numLitObjects; i++) {
569 objPtr = *objArrayPtr;
570 if (objPtr) {
571 Tcl_DecrRefCount(objPtr);
572 }
573 objArrayPtr++;
574 }
575 codePtr->numLitObjects = 0;
576 } else if (interp != NULL) {
577 /*
578 * If the interp has already been freed, then Tcl will have already
579 * forcefully released all the literals used by ByteCodes compiled
580 * with respect to that interp.
581 */
582
583 objArrayPtr = codePtr->objArrayPtr;
584 for (i = 0; i < numLitObjects; i++) {
585 /*
586 * TclReleaseLiteral sets a ByteCode's object array entry NULL to
587 * indicate that it has already freed the literal.
588 */
589
590 if (*objArrayPtr != NULL) {
591 TclReleaseLiteral(interp, *objArrayPtr);
592 }
593 objArrayPtr++;
594 }
595 }
596
597 auxDataPtr = codePtr->auxDataArrayPtr;
598 for (i = 0; i < numAuxDataItems; i++) {
599 if (auxDataPtr->type->freeProc != NULL) {
600 (*auxDataPtr->type->freeProc)(auxDataPtr->clientData);
601 }
602 auxDataPtr++;
603 }
604
605 TclHandleRelease(codePtr->interpHandle);
606 ckfree((char *) codePtr);
607 }
608
609 /*
610 *----------------------------------------------------------------------
611 *
612 * TclInitCompileEnv --
613 *
614 * Initializes a CompileEnv compilation environment structure for the
615 * compilation of a string in an interpreter.
616 *
617 * Results:
618 * None.
619 *
620 * Side effects:
621 * The CompileEnv structure is initialized.
622 *
623 *----------------------------------------------------------------------
624 */
625
626 void
627 TclInitCompileEnv(interp, envPtr, string, numBytes)
628 Tcl_Interp *interp; /* The interpreter for which a CompileEnv
629 * structure is initialized. */
630 register CompileEnv *envPtr; /* Points to the CompileEnv structure to
631 * initialize. */
632 char *string; /* The source string to be compiled. */
633 int numBytes; /* Number of bytes in source string. */
634 {
635 Interp *iPtr = (Interp *) interp;
636
637 envPtr->iPtr = iPtr;
638 envPtr->source = string;
639 envPtr->numSrcBytes = numBytes;
640 envPtr->procPtr = iPtr->compiledProcPtr;
641 envPtr->numCommands = 0;
642 envPtr->exceptDepth = 0;
643 envPtr->maxExceptDepth = 0;
644 envPtr->maxStackDepth = 0;
645 TclInitLiteralTable(&(envPtr->localLitTable));
646 envPtr->exprIsJustVarRef = 0;
647 envPtr->exprIsComparison = 0;
648
649 envPtr->codeStart = envPtr->staticCodeSpace;
650 envPtr->codeNext = envPtr->codeStart;
651 envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
652 envPtr->mallocedCodeArray = 0;
653
654 envPtr->literalArrayPtr = envPtr->staticLiteralSpace;
655 envPtr->literalArrayNext = 0;
656 envPtr->literalArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
657 envPtr->mallocedLiteralArray = 0;
658
659 envPtr->exceptArrayPtr = envPtr->staticExceptArraySpace;
660 envPtr->exceptArrayNext = 0;
661 envPtr->exceptArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
662 envPtr->mallocedExceptArray = 0;
663
664 envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
665 envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
666 envPtr->mallocedCmdMap = 0;
667
668 envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
669 envPtr->auxDataArrayNext = 0;
670 envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
671 envPtr->mallocedAuxDataArray = 0;
672 }
673
674 /*
675 *----------------------------------------------------------------------
676 *
677 * TclFreeCompileEnv --
678 *
679 * Free the storage allocated in a CompileEnv compilation environment
680 * structure.
681 *
682 * Results:
683 * None.
684 *
685 * Side effects:
686 * Allocated storage in the CompileEnv structure is freed. Note that
687 * its local literal table is not deleted and its literal objects are
688 * not released. In addition, storage referenced by its auxiliary data
689 * items is not freed. This is done so that, when compilation is
690 * successful, "ownership" of these objects and aux data items is
691 * handed over to the corresponding ByteCode structure.
692 *
693 *----------------------------------------------------------------------
694 */
695
696 void
697 TclFreeCompileEnv(envPtr)
698 register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
699 {
700 if (envPtr->mallocedCodeArray) {
701 ckfree((char *) envPtr->codeStart);
702 }
703 if (envPtr->mallocedLiteralArray) {
704 ckfree((char *) envPtr->literalArrayPtr);
705 }
706 if (envPtr->mallocedExceptArray) {
707 ckfree((char *) envPtr->exceptArrayPtr);
708 }
709 if (envPtr->mallocedCmdMap) {
710 ckfree((char *) envPtr->cmdMapPtr);
711 }
712 if (envPtr->mallocedAuxDataArray) {
713 ckfree((char *) envPtr->auxDataArrayPtr);
714 }
715 }
716
717 /*
718 *----------------------------------------------------------------------
719 *
720 * TclCompileScript --
721 *
722 * Compile a Tcl script in a string.
723 *
724 * Results:
725 * The return value is TCL_OK on a successful compilation and TCL_ERROR
726 * on failure. If TCL_ERROR is returned, then the interpreter's result
727 * contains an error message.
728 *
729 * interp->termOffset is set to the offset of the character in the
730 * script just after the last one successfully processed; this will be
731 * the offset of the ']' if (flags & TCL_BRACKET_TERM).
732 * envPtr->maxStackDepth is set to the maximum number of stack elements
733 * needed to execute the script's commands.
734 *
735 * Side effects:
736 * Adds instructions to envPtr to evaluate the script at runtime.
737 *
738 *----------------------------------------------------------------------
739 */
740
741 int
742 TclCompileScript(interp, script, numBytes, nested, envPtr)
743 Tcl_Interp *interp; /* Used for error and status reporting. */
744 char *script; /* The source script to compile. */
745 int numBytes; /* Number of bytes in script. If < 0, the
746 * script consists of all bytes up to the
747 * first null character. */
748 int nested; /* Non-zero means this is a nested command:
749 * close bracket ']' should be considered a
750 * command terminator. If zero, close
751 * bracket has no special meaning. */
752 CompileEnv *envPtr; /* Holds resulting instructions. */
753 {
754 Interp *iPtr = (Interp *) interp;
755 Tcl_Parse parse;
756 int maxDepth = 0; /* Maximum number of stack elements needed
757 * to execute all cmds. */
758 int lastTopLevelCmdIndex = -1;
759 /* Index of most recent toplevel command in
760 * the command location table. Initialized
761 * to avoid compiler warning. */
762 int startCodeOffset = -1; /* Offset of first byte of current command's
763 * code. Init. to avoid compiler warning. */
764 unsigned char *entryCodeNext = envPtr->codeNext;
765 char *p, *next;
766 Namespace *cmdNsPtr;
767 Command *cmdPtr;
768 Tcl_Token *tokenPtr;
769 int bytesLeft, isFirstCmd, gotParse, wordIdx, currCmdIndex;
770 int commandLength, objIndex, code;
771 char prev;
772 Tcl_DString ds;
773
774 Tcl_DStringInit(&ds);
775
776 if (numBytes < 0) {
777 numBytes = strlen(script);
778 }
779 Tcl_ResetResult(interp);
780 isFirstCmd = 1;
781
782 /*
783 * Each iteration through the following loop compiles the next
784 * command from the script.
785 */
786
787 p = script;
788 bytesLeft = numBytes;
789 gotParse = 0;
790 while (bytesLeft > 0) {
791 if (Tcl_ParseCommand(interp, p, bytesLeft, nested, &parse) != TCL_OK) {
792 code = TCL_ERROR;
793 goto error;
794 }
795 gotParse = 1;
796 if (parse.numWords > 0) {
797 /*
798 * If not the first command, pop the previous command's result
799 * and, if we're compiling a top level command, update the last
800 * command's code size to account for the pop instruction.
801 */
802
803 if (!isFirstCmd) {
804 TclEmitOpcode(INST_POP, envPtr);
805 if (!nested) {
806 envPtr->cmdMapPtr[lastTopLevelCmdIndex].numCodeBytes =
807 (envPtr->codeNext - envPtr->codeStart)
808 - startCodeOffset;
809 }
810 }
811
812 /*
813 * Determine the actual length of the command.
814 */
815
816 commandLength = parse.commandSize;
817 prev = '\0';
818 if (commandLength > 0) {
819 prev = parse.commandStart[commandLength-1];
820 }
821 if (((parse.commandStart+commandLength) != (script+numBytes))
822 || ((prev=='\n') || (nested && (prev==']')))) {
823 /*
824 * The command didn't end at the end of the script (i.e. it
825 * ended at a terminator character such as ";". Reduce the
826 * length by one so that the trace message doesn't include
827 * the terminator character.
828 */
829
830 commandLength -= 1;
831 }
832
833 /*
834 * If tracing, print a line for each top level command compiled.
835 */
836
837 if ((tclTraceCompile >= 1)
838 && !nested && (envPtr->procPtr == NULL)) {
839 fprintf(stdout, " Compiling: ");
840 TclPrintSource(stdout, parse.commandStart,
841 TclMin(commandLength, 55));
842 fprintf(stdout, "\n");
843 }
844
845 /*
846 * Each iteration of the following loop compiles one word
847 * from the command.
848 */
849
850 envPtr->numCommands++;
851 currCmdIndex = (envPtr->numCommands - 1);
852 if (!nested) {
853 lastTopLevelCmdIndex = currCmdIndex;
854 }
855 startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
856 EnterCmdStartData(envPtr, currCmdIndex,
857 (parse.commandStart - envPtr->source), startCodeOffset);
858
859 for (wordIdx = 0, tokenPtr = parse.tokenPtr;
860 wordIdx < parse.numWords;
861 wordIdx++, tokenPtr += (tokenPtr->numComponents + 1)) {
862 if (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD) {
863 /*
864 * If this is the first word and the command has a
865 * compile procedure, let it compile the command.
866 */
867
868 if (wordIdx == 0) {
869 if (envPtr->procPtr != NULL) {
870 cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
871 } else {
872 cmdNsPtr = NULL; /* use current NS */
873 }
874
875 /*
876 * We copy the string before trying to find the command
877 * by name. We used to modify the string in place, but
878 * this is not safe because the name resolution
879 * handlers could have side effects that rely on the
880 * unmodified string.
881 */
882
883 Tcl_DStringSetLength(&ds, 0);
884 Tcl_DStringAppend(&ds, tokenPtr[1].start,
885 tokenPtr[1].size);
886
887 cmdPtr = (Command *) Tcl_FindCommand(interp,
888 Tcl_DStringValue(&ds),
889 (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
890
891 if ((cmdPtr != NULL)
892 && (cmdPtr->compileProc != NULL)
893 && !(iPtr->flags & DONT_COMPILE_CMDS_INLINE)) {
894 code = (*(cmdPtr->compileProc))(interp, &parse,
895 envPtr);
896 if (code == TCL_OK) {
897 maxDepth = TclMax(envPtr->maxStackDepth,
898 maxDepth);
899 goto finishCommand;
900 } else if (code == TCL_OUT_LINE_COMPILE) {
901 /* do nothing */
902 } else { /* an error */
903 /*
904 * There was a compilation error, the last
905 * command did not get compiled into (*envPtr).
906 * Decrement the number of commands
907 * claimed to be in (*envPtr).
908 */
909 envPtr->numCommands--;
910 goto error;
911 }
912 }
913
914 /*
915 * No compile procedure so push the word. If the
916 * command was found, push a CmdName object to
917 * reduce runtime lookups.
918 */
919
920 objIndex = TclRegisterLiteral(envPtr,
921 tokenPtr[1].start, tokenPtr[1].size,
922 /*onHeap*/ 0);
923 if (cmdPtr != NULL) {
924 TclSetCmdNameObj(interp,
925 envPtr->literalArrayPtr[objIndex].objPtr,
926 cmdPtr);
927 }
928 } else {
929 objIndex = TclRegisterLiteral(envPtr,
930 tokenPtr[1].start, tokenPtr[1].size,
931 /*onHeap*/ 0);
932 }
933 TclEmitPush(objIndex, envPtr);
934 maxDepth = TclMax((wordIdx + 1), maxDepth);
935 } else {
936 /*
937 * The word is not a simple string of characters.
938 */
939
940 code = TclCompileTokens(interp, tokenPtr+1,
941 tokenPtr->numComponents, envPtr);
942 if (code != TCL_OK) {
943 goto error;
944 }
945 maxDepth = TclMax((wordIdx + envPtr->maxStackDepth),
946 maxDepth);
947 }
948 }
949
950 /*
951 * Emit an invoke instruction for the command. We skip this
952 * if a compile procedure was found for the command.
953 */
954
955 if (wordIdx > 0) {
956 if (wordIdx <= 255) {
957 TclEmitInstInt1(INST_INVOKE_STK1, wordIdx, envPtr);
958 } else {
959 TclEmitInstInt4(INST_INVOKE_STK4, wordIdx, envPtr);
960 }
961 }
962
963 /*
964 * Update the compilation environment structure and record the
965 * offsets of the source and code for the command.
966 */
967
968 finishCommand:
969 EnterCmdExtentData(envPtr, currCmdIndex, commandLength,
970 (envPtr->codeNext-envPtr->codeStart) - startCodeOffset);
971 isFirstCmd = 0;
972 } /* end if parse.numWords > 0 */
973
974 /*
975 * Advance to the next command in the script.
976 */
977
978 next = parse.commandStart + parse.commandSize;
979 bytesLeft -= (next - p);
980 p = next;
981 Tcl_FreeParse(&parse);
982 gotParse = 0;
983 if (nested && (p[-1] == ']')) {
984 /*
985 * We get here in the special case where TCL_BRACKET_TERM was
986 * set in the interpreter and we reached a close bracket in the
987 * script. Stop compilation.
988 */
989
990 break;
991 }
992 }
993
994 /*
995 * If the source script yielded no instructions (e.g., if it was empty),
996 * push an empty string as the command's result.
997 */
998
999 if (envPtr->codeNext == entryCodeNext) {
1000 TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
1001 envPtr);
1002 maxDepth = 1;
1003 }
1004
1005 if ((nested != 0) && (p > script) && (p[-1] == ']')) {
1006 iPtr->termOffset = (p - 1) - script;
1007 } else {
1008 iPtr->termOffset = (p - script);
1009 }
1010 envPtr->maxStackDepth = maxDepth;
1011 Tcl_DStringFree(&ds);
1012 return TCL_OK;
1013
1014 error:
1015 /*
1016 * Generate various pieces of error information, such as the line
1017 * number where the error occurred and information to add to the
1018 * errorInfo variable. Then free resources that had been allocated
1019 * to the command.
1020 */
1021
1022 commandLength = parse.commandSize;
1023 prev = '\0';
1024 if (commandLength > 0) {
1025 prev = parse.commandStart[commandLength-1];
1026 }
1027 if (((parse.commandStart+commandLength) != (script+numBytes))
1028 || ((prev == '\n') || (nested && (prev == ']')))) {
1029 /*
1030 * The command where the error occurred didn't end at the end
1031 * of the script (i.e. it ended at a terminator character such
1032 * as ";". Reduce the length by one so that the error message
1033 * doesn't include the terminator character.
1034 */
1035
1036 commandLength -= 1;
1037 }
1038 LogCompilationInfo(interp, script, parse.commandStart, commandLength);
1039 if (gotParse) {
1040 Tcl_FreeParse(&parse);
1041 }
1042 iPtr->termOffset = (p - script);
1043 envPtr->maxStackDepth = maxDepth;
1044 Tcl_DStringFree(&ds);
1045 return code;
1046 }
1047
1048 /*
1049 *----------------------------------------------------------------------
1050 *
1051 * TclCompileTokens --
1052 *
1053 * Given an array of tokens parsed from a Tcl command (e.g., the tokens
1054 * that make up a word) this procedure emits instructions to evaluate
1055 * the tokens and concatenate their values to form a single result
1056 * value on the interpreter's runtime evaluation stack.
1057 *
1058 * Results:
1059 * The return value is a standard Tcl result. If an error occurs, an
1060 * error message is left in the interpreter's result.
1061 *
1062 * envPtr->maxStackDepth is updated with the maximum number of stack
1063 * elements needed to evaluate the tokens.
1064 *
1065 * Side effects:
1066 * Instructions are added to envPtr to push and evaluate the tokens
1067 * at runtime.
1068 *
1069 *----------------------------------------------------------------------
1070 */
1071
1072 int
1073 TclCompileTokens(interp, tokenPtr, count, envPtr)
1074 Tcl_Interp *interp; /* Used for error and status reporting. */
1075 Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
1076 * to compile. */
1077 int count; /* Number of tokens to consider at tokenPtr.
1078 * Must be at least 1. */
1079 CompileEnv *envPtr; /* Holds the resulting instructions. */
1080 {
1081 Tcl_DString textBuffer; /* Holds concatenated chars from adjacent
1082 * TCL_TOKEN_TEXT, TCL_TOKEN_BS tokens. */
1083 char buffer[TCL_UTF_MAX];
1084 char *name, *p;
1085 int numObjsToConcat, nameBytes, hasNsQualifiers, localVar;
1086 int length, maxDepth, depthForVar, i, code;
1087 unsigned char *entryCodeNext = envPtr->codeNext;
1088
1089 Tcl_DStringInit(&textBuffer);
1090 maxDepth = 0;
1091 numObjsToConcat = 0;
1092 for ( ; count > 0; count--, tokenPtr++) {
1093 switch (tokenPtr->type) {
1094 case TCL_TOKEN_TEXT:
1095 Tcl_DStringAppend(&textBuffer, tokenPtr->start,
1096 tokenPtr->size);
1097 break;
1098
1099 case TCL_TOKEN_BS:
1100 length = Tcl_UtfBackslash(tokenPtr->start, (int *) NULL,
1101 buffer);
1102 Tcl_DStringAppend(&textBuffer, buffer, length);
1103 break;
1104
1105 case TCL_TOKEN_COMMAND:
1106 /*
1107 * Push any accumulated chars appearing before the command.
1108 */
1109
1110 if (Tcl_DStringLength(&textBuffer) > 0) {
1111 int literal;
1112
1113 literal = TclRegisterLiteral(envPtr,
1114 Tcl_DStringValue(&textBuffer),
1115 Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1116 TclEmitPush(literal, envPtr);
1117 numObjsToConcat++;
1118 maxDepth = TclMax(numObjsToConcat, maxDepth);
1119 Tcl_DStringFree(&textBuffer);
1120 }
1121
1122 code = TclCompileScript(interp, tokenPtr->start+1,
1123 tokenPtr->size-2, /*nested*/ 1, envPtr);
1124 if (code != TCL_OK) {
1125 goto error;
1126 }
1127 maxDepth = TclMax((numObjsToConcat + envPtr->maxStackDepth),
1128 maxDepth);
1129 numObjsToConcat++;
1130 break;
1131
1132 case TCL_TOKEN_VARIABLE:
1133 /*
1134 * Push any accumulated chars appearing before the $<var>.
1135 */
1136
1137 if (Tcl_DStringLength(&textBuffer) > 0) {
1138 int literal;
1139
1140 literal = TclRegisterLiteral(envPtr,
1141 Tcl_DStringValue(&textBuffer),
1142 Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1143 TclEmitPush(literal, envPtr);
1144 numObjsToConcat++;
1145 maxDepth = TclMax(numObjsToConcat, maxDepth);
1146 Tcl_DStringFree(&textBuffer);
1147 }
1148
1149 /*
1150 * Check if the name contains any namespace qualifiers.
1151 */
1152
1153 name = tokenPtr[1].start;
1154 nameBytes = tokenPtr[1].size;
1155 hasNsQualifiers = 0;
1156 for (i = 0, p = name; i < nameBytes; i++, p++) {
1157 if ((*p == ':') && (i < (nameBytes-1))
1158 && (*(p+1) == ':')) {
1159 hasNsQualifiers = 1;
1160 break;
1161 }
1162 }
1163
1164 /*
1165 * Either push the variable's name, or find its index in
1166 * the array of local variables in a procedure frame.
1167 */
1168
1169 depthForVar = 0;
1170 if ((envPtr->procPtr == NULL) || hasNsQualifiers) {
1171 localVar = -1;
1172 TclEmitPush(TclRegisterLiteral(envPtr, name, nameBytes,
1173 /*onHeap*/ 0), envPtr);
1174 depthForVar = 1;
1175 } else {
1176 localVar = TclFindCompiledLocal(name, nameBytes,
1177 /*create*/ 0, /*flags*/ 0, envPtr->procPtr);
1178 if (localVar < 0) {
1179 TclEmitPush(TclRegisterLiteral(envPtr, name,
1180 nameBytes, /*onHeap*/ 0), envPtr);
1181 depthForVar = 1;
1182 }
1183 }
1184
1185 /*
1186 * Emit instructions to load the variable.
1187 */
1188
1189 if (tokenPtr->numComponents == 1) {
1190 if (localVar < 0) {
1191 TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
1192 } else if (localVar <= 255) {
1193 TclEmitInstInt1(INST_LOAD_SCALAR1, localVar,
1194 envPtr);
1195 } else {
1196 TclEmitInstInt4(INST_LOAD_SCALAR4, localVar,
1197 envPtr);
1198 }
1199 } else {
1200 code = TclCompileTokens(interp, tokenPtr+2,
1201 tokenPtr->numComponents-1, envPtr);
1202 if (code != TCL_OK) {
1203 sprintf(buffer,
1204 "\n (parsing index for array \"%.*s\")",
1205 ((nameBytes > 100)? 100 : nameBytes), name);
1206 Tcl_AddObjErrorInfo(interp, buffer, -1);
1207 goto error;
1208 }
1209 depthForVar += envPtr->maxStackDepth;
1210 if (localVar < 0) {
1211 TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
1212 } else if (localVar <= 255) {
1213 TclEmitInstInt1(INST_LOAD_ARRAY1, localVar,
1214 envPtr);
1215 } else {
1216 TclEmitInstInt4(INST_LOAD_ARRAY4, localVar,
1217 envPtr);
1218 }
1219 }
1220 maxDepth = TclMax(numObjsToConcat + depthForVar, maxDepth);
1221 numObjsToConcat++;
1222 count -= tokenPtr->numComponents;
1223 tokenPtr += tokenPtr->numComponents;
1224 break;
1225
1226 default:
1227 panic("Unexpected token type in TclCompileTokens");
1228 }
1229 }
1230
1231 /*
1232 * Push any accumulated characters appearing at the end.
1233 */
1234
1235 if (Tcl_DStringLength(&textBuffer) > 0) {
1236 int literal;
1237
1238 literal = TclRegisterLiteral(envPtr, Tcl_DStringValue(&textBuffer),
1239 Tcl_DStringLength(&textBuffer), /*onHeap*/ 0);
1240 TclEmitPush(literal, envPtr);
1241 numObjsToConcat++;
1242 maxDepth = TclMax(numObjsToConcat, maxDepth);
1243 }
1244
1245 /*
1246 * If necessary, concatenate the parts of the word.
1247 */
1248
1249 while (numObjsToConcat > 255) {
1250 TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
1251 numObjsToConcat -= 254; /* concat pushes 1 obj, the result */
1252 }
1253 if (numObjsToConcat > 1) {
1254 TclEmitInstInt1(INST_CONCAT1, numObjsToConcat, envPtr);
1255 }
1256
1257 /*
1258 * If the tokens yielded no instructions, push an empty string.
1259 */
1260
1261 if (envPtr->codeNext == entryCodeNext) {
1262 TclEmitPush(TclRegisterLiteral(envPtr, "", 0, /*onHeap*/ 0),
1263 envPtr);
1264 maxDepth = 1;
1265 }
1266 Tcl_DStringFree(&textBuffer);
1267 envPtr->maxStackDepth = maxDepth;
1268 return TCL_OK;
1269
1270 error:
1271 Tcl_DStringFree(&textBuffer);
1272 envPtr->maxStackDepth = maxDepth;
1273 return code;
1274 }
1275
1276 /*
1277 *----------------------------------------------------------------------
1278 *
1279 * TclCompileCmdWord --
1280 *
1281 * Given an array of parse tokens for a word containing one or more Tcl
1282 * commands, emit inline instructions to execute them. This procedure
1283 * differs from TclCompileTokens in that a simple word such as a loop
1284 * body enclosed in braces is not just pushed as a string, but is
1285 * itself parsed into tokens and compiled.
1286 *
1287 * Results:
1288 * The return value is a standard Tcl result. If an error occurs, an
1289 * error message is left in the interpreter's result.
1290 *
1291 * envPtr->maxStackDepth is updated with the maximum number of stack
1292 * elements needed to execute the tokens.
1293 *
1294 * Side effects:
1295 * Instructions are added to envPtr to execute the tokens at runtime.
1296 *
1297 *----------------------------------------------------------------------
1298 */
1299
1300 int
1301 TclCompileCmdWord(interp, tokenPtr, count, envPtr)
1302 Tcl_Interp *interp; /* Used for error and status reporting. */
1303 Tcl_Token *tokenPtr; /* Pointer to first in an array of tokens
1304 * for a command word to compile inline. */
1305 int count; /* Number of tokens to consider at tokenPtr.
1306 * Must be at least 1. */
1307 CompileEnv *envPtr; /* Holds the resulting instructions. */
1308 {
1309 int code;
1310
1311 /*
1312 * Handle the common case: if there is a single text token, compile it
1313 * into an inline sequence of instructions.
1314 */
1315
1316 envPtr->maxStackDepth = 0;
1317 if ((count == 1) && (tokenPtr->type == TCL_TOKEN_TEXT)) {
1318 code = TclCompileScript(interp, tokenPtr->start, tokenPtr->size,
1319 /*nested*/ 0, envPtr);
1320 return code;
1321 }
1322
1323 /*
1324 * Multiple tokens or the single token involves substitutions. Emit
1325 * instructions to invoke the eval command procedure at runtime on the
1326 * result of evaluating the tokens.
1327 */
1328
1329 code = TclCompileTokens(interp, tokenPtr, count, envPtr);
1330 if (code != TCL_OK) {
1331 return code;
1332 }
1333 TclEmitOpcode(INST_EVAL_STK, envPtr);
1334 return TCL_OK;
1335 }
1336
1337 /*
1338 *----------------------------------------------------------------------
1339 *
1340 * TclCompileExprWords --
1341 *
1342 * Given an array of parse tokens representing one or more words that
1343 * contain a Tcl expression, emit inline instructions to execute the
1344 * expression. This procedure differs from TclCompileExpr in that it
1345 * supports Tcl's two-level substitution semantics for expressions that
1346 * appear as command words.
1347 *
1348 * Results:
1349 * The return value is a standard Tcl result. If an error occurs, an
1350 * error message is left in the interpreter's result.
1351 *
1352 * envPtr->maxStackDepth is updated with the maximum number of stack
1353 * elements needed to execute the expression.
1354 *
1355 * Side effects:
1356 * Instructions are added to envPtr to execute the expression.
1357 *
1358 *----------------------------------------------------------------------
1359 */
1360
1361 int
1362 TclCompileExprWords(interp, tokenPtr, numWords, envPtr)
1363 Tcl_Interp *interp; /* Used for error and status reporting. */
1364 Tcl_Token *tokenPtr; /* Points to first in an array of word
1365 * tokens tokens for the expression to
1366 * compile inline. */
1367 int numWords; /* Number of word tokens starting at
1368 * tokenPtr. Must be at least 1. Each word
1369 * token contains one or more subtokens. */
1370 CompileEnv *envPtr; /* Holds the resulting instructions. */
1371 {
1372 Tcl_Token *wordPtr;
1373 int maxDepth, range, numBytes, i, code;
1374 char *script;
1375 int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
1376 int saveExprIsComparison = envPtr->exprIsComparison;
1377
1378 envPtr->maxStackDepth = 0;
1379 maxDepth = 0;
1380 range = -1;
1381 code = TCL_OK;
1382
1383 /*
1384 * If the expression is a single word that doesn't require
1385 * substitutions, just compile it's string into inline instructions.
1386 */
1387
1388 if ((numWords == 1) && (tokenPtr->type == TCL_TOKEN_SIMPLE_WORD)) {
1389 /*
1390 * Temporarily overwrite the character just after the end of the
1391 * string with a 0 byte.
1392 */
1393
1394 script = tokenPtr[1].start;
1395 numBytes = tokenPtr[1].size;
1396 code = TclCompileExpr(interp, script, numBytes, envPtr);
1397 return code;
1398 }
1399
1400 /*
1401 * Emit code to call the expr command proc at runtime. Concatenate the
1402 * (already substituted once) expr tokens with a space between each.
1403 */
1404
1405 wordPtr = tokenPtr;
1406 for (i = 0; i < numWords; i++) {
1407 code = TclCompileTokens(interp, wordPtr+1, wordPtr->numComponents,
1408 envPtr);
1409 if (code != TCL_OK) {
1410 break;
1411 }
1412 if (i < (numWords - 1)) {
1413 TclEmitPush(TclRegisterLiteral(envPtr, " ", 1, /*onHeap*/ 0),
1414 envPtr);
1415 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
1416 } else {
1417 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
1418 }
1419 wordPtr += (wordPtr->numComponents + 1);
1420 }
1421 if (code == TCL_OK) {
1422 int concatItems = 2*numWords - 1;
1423 while (concatItems > 255) {
1424 TclEmitInstInt1(INST_CONCAT1, 255, envPtr);
1425 concatItems -= 254;
1426 }
1427 if (concatItems > 1) {
1428 TclEmitInstInt1(INST_CONCAT1, concatItems, envPtr);
1429 }
1430 TclEmitOpcode(INST_EXPR_STK, envPtr);
1431 }
1432
1433 envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
1434 envPtr->exprIsComparison = saveExprIsComparison;
1435 envPtr->maxStackDepth = maxDepth;
1436 return code;
1437 }
1438
1439 /*
1440 *----------------------------------------------------------------------
1441 *
1442 * TclInitByteCodeObj --
1443 *
1444 * Create a ByteCode structure and initialize it from a CompileEnv
1445 * compilation environment structure. The ByteCode structure is
1446 * smaller and contains just that information needed to execute
1447 * the bytecode instructions resulting from compiling a Tcl script.
1448 * The resulting structure is placed in the specified object.
1449 *
1450 * Results:
1451 * A newly constructed ByteCode object is stored in the internal
1452 * representation of the objPtr.
1453 *
1454 * Side effects:
1455 * A single heap object is allocated to hold the new ByteCode structure
1456 * and its code, object, command location, and aux data arrays. Note
1457 * that "ownership" (i.e., the pointers to) the Tcl objects and aux
1458 * data items will be handed over to the new ByteCode structure from
1459 * the CompileEnv structure.
1460 *
1461 *----------------------------------------------------------------------
1462 */
1463
1464 void
1465 TclInitByteCodeObj(objPtr, envPtr)
1466 Tcl_Obj *objPtr; /* Points object that should be
1467 * initialized, and whose string rep
1468 * contains the source code. */
1469 register CompileEnv *envPtr; /* Points to the CompileEnv structure from
1470 * which to create a ByteCode structure. */
1471 {
1472 register ByteCode *codePtr;
1473 size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
1474 size_t auxDataArrayBytes, structureSize;
1475 register unsigned char *p;
1476 unsigned char *nextPtr;
1477 int numLitObjects = envPtr->literalArrayNext;
1478 Namespace *namespacePtr;
1479 int i;
1480 Interp *iPtr;
1481
1482 iPtr = envPtr->iPtr;
1483
1484 codeBytes = (envPtr->codeNext - envPtr->codeStart);
1485 objArrayBytes = (envPtr->literalArrayNext * sizeof(Tcl_Obj *));
1486 exceptArrayBytes = (envPtr->exceptArrayNext * sizeof(ExceptionRange));
1487 auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
1488 cmdLocBytes = GetCmdLocEncodingSize(envPtr);
1489
1490 /*
1491 * Compute the total number of bytes needed for this bytecode.
1492 */
1493
1494 structureSize = sizeof(ByteCode);
1495 structureSize += TCL_ALIGN(codeBytes); /* align object array */
1496 structureSize += TCL_ALIGN(objArrayBytes); /* align exc range arr */
1497 structureSize += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
1498 structureSize += auxDataArrayBytes;
1499 structureSize += cmdLocBytes;
1500
1501 if (envPtr->iPtr->varFramePtr != NULL) {
1502 namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
1503 } else {
1504 namespacePtr = envPtr->iPtr->globalNsPtr;
1505 }
1506
1507 p = (unsigned char *) ckalloc((size_t) structureSize);
1508 codePtr = (ByteCode *) p;
1509 codePtr->interpHandle = TclHandlePreserve(iPtr->handle);
1510 codePtr->compileEpoch = iPtr->compileEpoch;
1511 codePtr->nsPtr = namespacePtr;
1512 codePtr->nsEpoch = namespacePtr->resolverEpoch;
1513 codePtr->refCount = 1;
1514 codePtr->flags = 0;
1515 codePtr->source = envPtr->source;
1516 codePtr->procPtr = envPtr->procPtr;
1517
1518 codePtr->numCommands = envPtr->numCommands;
1519 codePtr->numSrcBytes = envPtr->numSrcBytes;
1520 codePtr->numCodeBytes = codeBytes;
1521 codePtr->numLitObjects = numLitObjects;
1522 codePtr->numExceptRanges = envPtr->exceptArrayNext;
1523 codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
1524 codePtr->numCmdLocBytes = cmdLocBytes;
1525 codePtr->maxExceptDepth = envPtr->maxExceptDepth;
1526 codePtr->maxStackDepth = envPtr->maxStackDepth;
1527
1528 p += sizeof(ByteCode);
1529 codePtr->codeStart = p;
1530 memcpy((VOID *) p, (VOID *) envPtr->codeStart, (size_t) codeBytes);
1531
1532 p += TCL_ALIGN(codeBytes); /* align object array */
1533 codePtr->objArrayPtr = (Tcl_Obj **) p;
1534 for (i = 0; i < numLitObjects; i++) {
1535 codePtr->objArrayPtr[i] = envPtr->literalArrayPtr[i].objPtr;
1536 }
1537
1538 p += TCL_ALIGN(objArrayBytes); /* align exception range array */
1539 if (exceptArrayBytes > 0) {
1540 codePtr->exceptArrayPtr = (ExceptionRange *) p;
1541 memcpy((VOID *) p, (VOID *) envPtr->exceptArrayPtr,
1542 (size_t) exceptArrayBytes);
1543 } else {
1544 codePtr->exceptArrayPtr = NULL;
1545 }
1546
1547 p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
1548 if (auxDataArrayBytes > 0) {
1549 codePtr->auxDataArrayPtr = (AuxData *) p;
1550 memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
1551 (size_t) auxDataArrayBytes);
1552 } else {
1553 codePtr->auxDataArrayPtr = NULL;
1554 }
1555
1556 p += auxDataArrayBytes;
1557 nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
1558 #ifdef TCL_COMPILE_DEBUG
1559 if (((size_t)(nextPtr - p)) != cmdLocBytes) {
1560 panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
1561 }
1562 #endif
1563
1564 /*
1565 * Record various compilation-related statistics about the new ByteCode
1566 * structure. Don't include overhead for statistics-related fields.
1567 */
1568
1569 #ifdef TCL_COMPILE_STATS
1570 codePtr->structureSize = structureSize
1571 - (sizeof(size_t) + sizeof(Tcl_Time));
1572 TclpGetTime(&(codePtr->createTime));
1573
1574 RecordByteCodeStats(codePtr);
1575 #endif /* TCL_COMPILE_STATS */
1576
1577 /*
1578 * Free the old internal rep then convert the object to a
1579 * bytecode object by making its internal rep point to the just
1580 * compiled ByteCode.
1581 */
1582
1583 if ((objPtr->typePtr != NULL) &&
1584 (objPtr->typePtr->freeIntRepProc != NULL)) {
1585 (*objPtr->typePtr->freeIntRepProc)(objPtr);
1586 }
1587 objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
1588 objPtr->typePtr = &tclByteCodeType;
1589 }
1590
1591 /*
1592 *----------------------------------------------------------------------
1593 *
1594 * LogCompilationInfo --
1595 *
1596 * This procedure is invoked after an error occurs during compilation.
1597 * It adds information to the "errorInfo" variable to describe the
1598 * command that was being compiled when the error occurred.
1599 *
1600 * Results:
1601 * None.
1602 *
1603 * Side effects:
1604 * Information about the command is added to errorInfo and the
1605 * line number stored internally in the interpreter is set. If this
1606 * is the first call to this procedure or Tcl_AddObjErrorInfo since
1607 * an error occurred, then old information in errorInfo is
1608 * deleted.
1609 *
1610 *----------------------------------------------------------------------
1611 */
1612
1613 static void
1614 LogCompilationInfo(interp, script, command, length)
1615 Tcl_Interp *interp; /* Interpreter in which to log the
1616 * information. */
1617 char *script; /* First character in script containing
1618 * command (must be <= command). */
1619 char *command; /* First character in command that
1620 * generated the error. */
1621 int length; /* Number of bytes in command (-1 means
1622 * use all bytes up to first null byte). */
1623 {
1624 char buffer[200];
1625 register char *p;
1626 char *ellipsis = "";
1627 Interp *iPtr = (Interp *) interp;
1628
1629 if (iPtr->flags & ERR_ALREADY_LOGGED) {
1630 /*
1631 * Someone else has already logged error information for this
1632 * command; we shouldn't add anything more.
1633 */
1634
1635 return;
1636 }
1637
1638 /*
1639 * Compute the line number where the error occurred.
1640 */
1641
1642 iPtr->errorLine = 1;
1643 for (p = script; p != command; p++) {
1644 if (*p == '\n') {
1645 iPtr->errorLine++;
1646 }
1647 }
1648
1649 /*
1650 * Create an error message to add to errorInfo, including up to a
1651 * maximum number of characters of the command.
1652 */
1653
1654 if (length < 0) {
1655 length = strlen(command);
1656 }
1657 if (length > 150) {
1658 length = 150;
1659 ellipsis = "...";
1660 }
1661 sprintf(buffer, "\n while compiling\n\"%.*s%s\"",
1662 length, command, ellipsis);
1663 Tcl_AddObjErrorInfo(interp, buffer, -1);
1664 }
1665
1666 /*
1667 *----------------------------------------------------------------------
1668 *
1669 * TclFindCompiledLocal --
1670 *
1671 * This procedure is called at compile time to look up and optionally
1672 * allocate an entry ("slot") for a variable in a procedure's array of
1673 * local variables. If the variable's name is NULL, a new temporary
1674 * variable is always created. (Such temporary variables can only be
1675 * referenced using their slot index.)
1676 *
1677 * Results:
1678 * If create is 0 and the name is non-NULL, then if the variable is
1679 * found, the index of its entry in the procedure's array of local
1680 * variables is returned; otherwise -1 is returned. If name is NULL,
1681 * the index of a new temporary variable is returned. Finally, if
1682 * create is 1 and name is non-NULL, the index of a new entry is
1683 * returned.
1684 *
1685 * Side effects:
1686 * Creates and registers a new local variable if create is 1 and
1687 * the variable is unknown, or if the name is NULL.
1688 *
1689 *----------------------------------------------------------------------
1690 */
1691
1692 int
1693 TclFindCompiledLocal(name, nameBytes, create, flags, procPtr)
1694 register char *name; /* Points to first character of the name of
1695 * a scalar or array variable. If NULL, a
1696 * temporary var should be created. */
1697 int nameBytes; /* Number of bytes in the name. */
1698 int create; /* If 1, allocate a local frame entry for
1699 * the variable if it is new. */
1700 int flags; /* Flag bits for the compiled local if
1701 * created. Only VAR_SCALAR, VAR_ARRAY, and
1702 * VAR_LINK make sense. */
1703 register Proc *procPtr; /* Points to structure describing procedure
1704 * containing the variable reference. */
1705 {
1706 register CompiledLocal *localPtr;
1707 int localVar = -1;
1708 register int i;
1709
1710 /*
1711 * If not creating a temporary, does a local variable of the specified
1712 * name already exist?
1713 */
1714
1715 if (name != NULL) {
1716 int localCt = procPtr->numCompiledLocals;
1717 localPtr = procPtr->firstLocalPtr;
1718 for (i = 0; i < localCt; i++) {
1719 if (!TclIsVarTemporary(localPtr)) {
1720 char *localName = localPtr->name;
1721 if ((nameBytes == localPtr->nameLength)
1722 && (strncmp(name, localName, (unsigned) nameBytes) == 0)) {
1723 return i;
1724 }
1725 }
1726 localPtr = localPtr->nextPtr;
1727 }
1728 }
1729
1730 /*
1731 * Create a new variable if appropriate.
1732 */
1733
1734 if (create || (name == NULL)) {
1735 localVar = procPtr->numCompiledLocals;
1736 localPtr = (CompiledLocal *) ckalloc((unsigned)
1737 (sizeof(CompiledLocal) - sizeof(localPtr->name)
1738 + nameBytes+1));
1739 if (procPtr->firstLocalPtr == NULL) {
1740 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
1741 } else {
1742 procPtr->lastLocalPtr->nextPtr = localPtr;
1743 procPtr->lastLocalPtr = localPtr;
1744 }
1745 localPtr->nextPtr = NULL;
1746 localPtr->nameLength = nameBytes;
1747 localPtr->frameIndex = localVar;
1748 localPtr->flags = flags;
1749 if (name == NULL) {
1750 localPtr->flags |= VAR_TEMPORARY;
1751 }
1752 localPtr->defValuePtr = NULL;
1753 localPtr->resolveInfo = NULL;
1754
1755 if (name != NULL) {
1756 memcpy((VOID *) localPtr->name, (VOID *) name,
1757 (size_t) nameBytes);
1758 }
1759 localPtr->name[nameBytes] = '\0';
1760 procPtr->numCompiledLocals++;
1761 }
1762 return localVar;
1763 }
1764
1765 /*
1766 *----------------------------------------------------------------------
1767 *
1768 * TclInitCompiledLocals --
1769 *
1770 * This routine is invoked in order to initialize the compiled
1771 * locals table for a new call frame.
1772 *
1773 * Results:
1774 * None.
1775 *
1776 * Side effects:
1777 * May invoke various name resolvers in order to determine which
1778 * variables are being referenced at runtime.
1779 *
1780 *----------------------------------------------------------------------
1781 */
1782
1783 void
1784 TclInitCompiledLocals(interp, framePtr, nsPtr)
1785 Tcl_Interp *interp; /* Current interpreter. */
1786 CallFrame *framePtr; /* Call frame to initialize. */
1787 Namespace *nsPtr; /* Pointer to current namespace. */
1788 {
1789 register CompiledLocal *localPtr;
1790 Interp *iPtr = (Interp*) interp;
1791 Tcl_ResolvedVarInfo *vinfo, *resVarInfo;
1792 Var *varPtr = framePtr->compiledLocals;
1793 Var *resolvedVarPtr;
1794 ResolverScheme *resPtr;
1795 int result;
1796
1797 /*
1798 * Initialize the array of local variables stored in the call frame.
1799 * Some variables may have special resolution rules. In that case,
1800 * we call their "resolver" procs to get our hands on the variable,
1801 * and we make the compiled local a link to the real variable.
1802 */
1803
1804 for (localPtr = framePtr->procPtr->firstLocalPtr;
1805 localPtr != NULL;
1806 localPtr = localPtr->nextPtr) {
1807
1808 /*
1809 * Check to see if this local is affected by namespace or
1810 * interp resolvers. The resolver to use is cached for the
1811 * next invocation of the procedure.
1812 */
1813
1814 if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))
1815 && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {
1816 resPtr = iPtr->resolverPtr;
1817
1818 if (nsPtr->compiledVarResProc) {
1819 result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
1820 localPtr->name, localPtr->nameLength,
1821 (Tcl_Namespace *) nsPtr, &vinfo);
1822 } else {
1823 result = TCL_CONTINUE;
1824 }
1825
1826 while ((result == TCL_CONTINUE) && resPtr) {
1827 if (resPtr->compiledVarResProc) {
1828 result = (*resPtr->compiledVarResProc)(nsPtr->interp,
1829 localPtr->name, localPtr->nameLength,
1830 (Tcl_Namespace *) nsPtr, &vinfo);
1831 }
1832 resPtr = resPtr->nextPtr;
1833 }
1834 if (result == TCL_OK) {
1835 localPtr->resolveInfo = vinfo;
1836 localPtr->flags |= VAR_RESOLVED;
1837 }
1838 }
1839
1840 /*
1841 * Now invoke the resolvers to determine the exact variables that
1842 * should be used.
1843 */
1844
1845 resVarInfo = localPtr->resolveInfo;
1846 resolvedVarPtr = NULL;
1847
1848 if (resVarInfo && resVarInfo->fetchProc) {
1849 resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
1850 resVarInfo);
1851 }
1852
1853 if (resolvedVarPtr) {
1854 varPtr->name = localPtr->name; /* will be just '\0' if temp var */
1855 varPtr->nsPtr = NULL;
1856 varPtr->hPtr = NULL;
1857 varPtr->refCount = 0;
1858 varPtr->tracePtr = NULL;
1859 varPtr->searchPtr = NULL;
1860 varPtr->flags = 0;
1861 TclSetVarLink(varPtr);
1862 varPtr->value.linkPtr = resolvedVarPtr;
1863 resolvedVarPtr->refCount++;
1864 } else {
1865 varPtr->value.objPtr = NULL;
1866 varPtr->name = localPtr->name; /* will be just '\0' if temp var */
1867 varPtr->nsPtr = NULL;
1868 varPtr->hPtr = NULL;
1869 varPtr->refCount = 0;
1870 varPtr->tracePtr = NULL;
1871 varPtr->searchPtr = NULL;
1872 varPtr->flags = (localPtr->flags | VAR_UNDEFINED);
1873 }
1874 varPtr++;
1875 }
1876 }
1877
1878 /*
1879 *----------------------------------------------------------------------
1880 *
1881 * TclExpandCodeArray --
1882 *
1883 * Procedure that uses malloc to allocate more storage for a
1884 * CompileEnv's code array.
1885 *
1886 * Results:
1887 * None.
1888 *
1889 * Side effects:
1890 * The byte code array in *envPtr is reallocated to a new array of
1891 * double the size, and if envPtr->mallocedCodeArray is non-zero the
1892 * old array is freed. Byte codes are copied from the old array to the
1893 * new one.
1894 *
1895 *----------------------------------------------------------------------
1896 */
1897
1898 void
1899 TclExpandCodeArray(envPtr)
1900 CompileEnv *envPtr; /* Points to the CompileEnv whose code array
1901 * must be enlarged. */
1902 {
1903 /*
1904 * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
1905 * code bytes are stored between envPtr->codeStart and
1906 * (envPtr->codeNext - 1) [inclusive].
1907 */
1908
1909 size_t currBytes = (envPtr->codeNext - envPtr->codeStart);
1910 size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
1911 unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
1912
1913 /*
1914 * Copy from old code array to new, free old code array if needed, and
1915 * mark new code array as malloced.
1916 */
1917
1918 memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
1919 if (envPtr->mallocedCodeArray) {
1920 ckfree((char *) envPtr->codeStart);
1921 }
1922 envPtr->codeStart = newPtr;
1923 envPtr->codeNext = (newPtr + currBytes);
1924 envPtr->codeEnd = (newPtr + newBytes);
1925 envPtr->mallocedCodeArray = 1;
1926 }
1927
1928 /*
1929 *----------------------------------------------------------------------
1930 *
1931 * EnterCmdStartData --
1932 *
1933 * Registers the starting source and bytecode location of a
1934 * command. This information is used at runtime to map between
1935 * instruction pc and source locations.
1936 *
1937 * Results:
1938 * None.
1939 *
1940 * Side effects:
1941 * Inserts source and code location information into the compilation
1942 * environment envPtr for the command at index cmdIndex. The
1943 * compilation environment's CmdLocation array is grown if necessary.
1944 *
1945 *----------------------------------------------------------------------
1946 */
1947
1948 static void
1949 EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
1950 CompileEnv *envPtr; /* Points to the compilation environment
1951 * structure in which to enter command
1952 * location information. */
1953 int cmdIndex; /* Index of the command whose start data
1954 * is being set. */
1955 int srcOffset; /* Offset of first char of the command. */
1956 int codeOffset; /* Offset of first byte of command code. */
1957 {
1958 CmdLocation *cmdLocPtr;
1959
1960 if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
1961 panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
1962 }
1963
1964 if (cmdIndex >= envPtr->cmdMapEnd) {
1965 /*
1966 * Expand the command location array by allocating more storage from
1967 * the heap. The currently allocated CmdLocation entries are stored
1968 * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
1969 */
1970
1971 size_t currElems = envPtr->cmdMapEnd;
1972 size_t newElems = 2*currElems;
1973 size_t currBytes = currElems * sizeof(CmdLocation);
1974 size_t newBytes = newElems * sizeof(CmdLocation);
1975 CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
1976
1977 /*
1978 * Copy from old command location array to new, free old command
1979 * location array if needed, and mark new array as malloced.
1980 */
1981
1982 memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
1983 if (envPtr->mallocedCmdMap) {
1984 ckfree((char *) envPtr->cmdMapPtr);
1985 }
1986 envPtr->cmdMapPtr = (CmdLocation *) newPtr;
1987 envPtr->cmdMapEnd = newElems;
1988 envPtr->mallocedCmdMap = 1;
1989 }
1990
1991 if (cmdIndex > 0) {
1992 if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
1993 panic("EnterCmdStartData: cmd map not sorted by code offset");
1994 }
1995 }
1996
1997 cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
1998 cmdLocPtr->codeOffset = codeOffset;
1999 cmdLocPtr->srcOffset = srcOffset;
2000 cmdLocPtr->numSrcBytes = -1;
2001 cmdLocPtr->numCodeBytes = -1;
2002 }
2003
2004 /*
2005 *----------------------------------------------------------------------
2006 *
2007 * EnterCmdExtentData --
2008 *
2009 * Registers the source and bytecode length for a command. This
2010 * information is used at runtime to map between instruction pc and
2011 * source locations.
2012 *
2013 * Results:
2014 * None.
2015 *
2016 * Side effects:
2017 * Inserts source and code length information into the compilation
2018 * environment envPtr for the command at index cmdIndex. Starting
2019 * source and bytecode information for the command must already
2020 * have been registered.
2021 *
2022 *----------------------------------------------------------------------
2023 */
2024
2025 static void
2026 EnterCmdExtentData(envPtr, cmdIndex, numSrcBytes, numCodeBytes)
2027 CompileEnv *envPtr; /* Points to the compilation environment
2028 * structure in which to enter command
2029 * location information. */
2030 int cmdIndex; /* Index of the command whose source and
2031 * code length data is being set. */
2032 int numSrcBytes; /* Number of command source chars. */
2033 int numCodeBytes; /* Offset of last byte of command code. */
2034 {
2035 CmdLocation *cmdLocPtr;
2036
2037 if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
2038 panic("EnterCmdExtentData: bad command index %d\n", cmdIndex);
2039 }
2040
2041 if (cmdIndex > envPtr->cmdMapEnd) {
2042 panic("EnterCmdExtentData: missing start data for command %d\n",
2043 cmdIndex);
2044 }
2045
2046 cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
2047 cmdLocPtr->numSrcBytes = numSrcBytes;
2048 cmdLocPtr->numCodeBytes = numCodeBytes;
2049 }
2050
2051 /*
2052 *----------------------------------------------------------------------
2053 *
2054 * TclCreateExceptRange --
2055 *
2056 * Procedure that allocates and initializes a new ExceptionRange
2057 * structure of the specified kind in a CompileEnv.
2058 *
2059 * Results:
2060 * Returns the index for the newly created ExceptionRange.
2061 *
2062 * Side effects:
2063 * If there is not enough room in the CompileEnv's ExceptionRange
2064 * array, the array in expanded: a new array of double the size is
2065 * allocated, if envPtr->mallocedExceptArray is non-zero the old
2066 * array is freed, and ExceptionRange entries are copied from the old
2067 * array to the new one.
2068 *
2069 *----------------------------------------------------------------------
2070 */
2071
2072 int
2073 TclCreateExceptRange(type, envPtr)
2074 ExceptionRangeType type; /* The kind of ExceptionRange desired. */
2075 register CompileEnv *envPtr;/* Points to CompileEnv for which to
2076 * create a new ExceptionRange structure. */
2077 {
2078 register ExceptionRange *rangePtr;
2079 int index = envPtr->exceptArrayNext;
2080
2081 if (index >= envPtr->exceptArrayEnd) {
2082 /*
2083 * Expand the ExceptionRange array. The currently allocated entries
2084 * are stored between elements 0 and (envPtr->exceptArrayNext - 1)
2085 * [inclusive].
2086 */
2087
2088 size_t currBytes =
2089 envPtr->exceptArrayNext * sizeof(ExceptionRange);
2090 int newElems = 2*envPtr->exceptArrayEnd;
2091 size_t newBytes = newElems * sizeof(ExceptionRange);
2092 ExceptionRange *newPtr = (ExceptionRange *)
2093 ckalloc((unsigned) newBytes);
2094
2095 /*
2096 * Copy from old ExceptionRange array to new, free old
2097 * ExceptionRange array if needed, and mark the new ExceptionRange
2098 * array as malloced.
2099 */
2100
2101 memcpy((VOID *) newPtr, (VOID *) envPtr->exceptArrayPtr,
2102 currBytes);
2103 if (envPtr->mallocedExceptArray) {
2104 ckfree((char *) envPtr->exceptArrayPtr);
2105 }
2106 envPtr->exceptArrayPtr = (ExceptionRange *) newPtr;
2107 envPtr->exceptArrayEnd = newElems;
2108 envPtr->mallocedExceptArray = 1;
2109 }
2110 envPtr->exceptArrayNext++;
2111
2112 rangePtr = &(envPtr->exceptArrayPtr[index]);
2113 rangePtr->type = type;
2114 rangePtr->nestingLevel = envPtr->exceptDepth;
2115 rangePtr->codeOffset = -1;
2116 rangePtr->numCodeBytes = -1;
2117 rangePtr->breakOffset = -1;
2118 rangePtr->continueOffset = -1;
2119 rangePtr->catchOffset = -1;
2120 return index;
2121 }
2122
2123 /*
2124 *----------------------------------------------------------------------
2125 *
2126 * TclCreateAuxData --
2127 *
2128 * Procedure that allocates and initializes a new AuxData structure in
2129 * a CompileEnv's array of compilation auxiliary data records. These
2130 * AuxData records hold information created during compilation by
2131 * CompileProcs and used by instructions during execution.
2132 *
2133 * Results:
2134 * Returns the index for the newly created AuxData structure.
2135 *
2136 * Side effects:
2137 * If there is not enough room in the CompileEnv's AuxData array,
2138 * the AuxData array in expanded: a new array of double the size
2139 * is allocated, if envPtr->mallocedAuxDataArray is non-zero
2140 * the old array is freed, and AuxData entries are copied from
2141 * the old array to the new one.
2142 *
2143 *----------------------------------------------------------------------
2144 */
2145
2146 int
2147 TclCreateAuxData(clientData, typePtr, envPtr)
2148 ClientData clientData; /* The compilation auxiliary data to store
2149 * in the new aux data record. */
2150 AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */
2151 register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
2152 * aux data structure is to be allocated. */
2153 {
2154 int index; /* Index for the new AuxData structure. */
2155 register AuxData *auxDataPtr;
2156 /* Points to the new AuxData structure */
2157
2158 index = envPtr->auxDataArrayNext;
2159 if (index >= envPtr->auxDataArrayEnd) {
2160 /*
2161 * Expand the AuxData array. The currently allocated entries are
2162 * stored between elements 0 and (envPtr->auxDataArrayNext - 1)
2163 * [inclusive].
2164 */
2165
2166 size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
2167 int newElems = 2*envPtr->auxDataArrayEnd;
2168 size_t newBytes = newElems * sizeof(AuxData);
2169 AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
2170
2171 /*
2172 * Copy from old AuxData array to new, free old AuxData array if
2173 * needed, and mark the new AuxData array as malloced.
2174 */
2175
2176 memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
2177 currBytes);
2178 if (envPtr->mallocedAuxDataArray) {
2179 ckfree((char *) envPtr->auxDataArrayPtr);
2180 }
2181 envPtr->auxDataArrayPtr = newPtr;
2182 envPtr->auxDataArrayEnd = newElems;
2183 envPtr->mallocedAuxDataArray = 1;
2184 }
2185 envPtr->auxDataArrayNext++;
2186
2187 auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
2188 auxDataPtr->clientData = clientData;
2189 auxDataPtr->type = typePtr;
2190 return index;
2191 }
2192
2193 /*
2194 *----------------------------------------------------------------------
2195 *
2196 * TclInitJumpFixupArray --
2197 *
2198 * Initializes a JumpFixupArray structure to hold some number of
2199 * jump fixup entries.
2200 *
2201 * Results:
2202 * None.
2203 *
2204 * Side effects:
2205 * The JumpFixupArray structure is initialized.
2206 *
2207 *----------------------------------------------------------------------
2208 */
2209
2210 void
2211 TclInitJumpFixupArray(fixupArrayPtr)
2212 register JumpFixupArray *fixupArrayPtr;
2213 /* Points to the JumpFixupArray structure
2214 * to initialize. */
2215 {
2216 fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
2217 fixupArrayPtr->next = 0;
2218 fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
2219 fixupArrayPtr->mallocedArray = 0;
2220 }
2221
2222 /*
2223 *----------------------------------------------------------------------
2224 *
2225 * TclExpandJumpFixupArray --
2226 *
2227 * Procedure that uses malloc to allocate more storage for a
2228 * jump fixup array.
2229 *
2230 * Results:
2231 * None.
2232 *
2233 * Side effects:
2234 * The jump fixup array in *fixupArrayPtr is reallocated to a new array
2235 * of double the size, and if fixupArrayPtr->mallocedArray is non-zero
2236 * the old array is freed. Jump fixup structures are copied from the
2237 * old array to the new one.
2238 *
2239 *----------------------------------------------------------------------
2240 */
2241
2242 void
2243 TclExpandJumpFixupArray(fixupArrayPtr)
2244 register JumpFixupArray *fixupArrayPtr;
2245 /* Points to the JumpFixupArray structure
2246 * to enlarge. */
2247 {
2248 /*
2249 * The currently allocated jump fixup entries are stored from fixup[0]
2250 * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
2251 * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
2252 */
2253
2254 size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
2255 int newElems = 2*(fixupArrayPtr->end + 1);
2256 size_t newBytes = newElems * sizeof(JumpFixup);
2257 JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
2258
2259 /*
2260 * Copy from the old array to new, free the old array if needed,
2261 * and mark the new array as malloced.
2262 */
2263
2264 memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
2265 if (fixupArrayPtr->mallocedArray) {
2266 ckfree((char *) fixupArrayPtr->fixup);
2267 }
2268 fixupArrayPtr->fixup = (JumpFixup *) newPtr;
2269 fixupArrayPtr->end = newElems;
2270 fixupArrayPtr->mallocedArray = 1;
2271 }
2272
2273 /*
2274 *----------------------------------------------------------------------
2275 *
2276 * TclFreeJumpFixupArray --
2277 *
2278 * Free any storage allocated in a jump fixup array structure.
2279 *
2280 * Results:
2281 * None.
2282 *
2283 * Side effects:
2284 * Allocated storage in the JumpFixupArray structure is freed.
2285 *
2286 *----------------------------------------------------------------------
2287 */
2288
2289 void
2290 TclFreeJumpFixupArray(fixupArrayPtr)
2291 register JumpFixupArray *fixupArrayPtr;
2292 /* Points to the JumpFixupArray structure
2293 * to free. */
2294 {
2295 if (fixupArrayPtr->mallocedArray) {
2296 ckfree((char *) fixupArrayPtr->fixup);
2297 }
2298 }
2299
2300 /*
2301 *----------------------------------------------------------------------
2302 *
2303 * TclEmitForwardJump --
2304 *
2305 * Procedure to emit a two-byte forward jump of kind "jumpType". Since
2306 * the jump may later have to be grown to five bytes if the jump target
2307 * is more than, say, 127 bytes away, this procedure also initializes a
2308 * JumpFixup record with information about the jump.
2309 *
2310 * Results:
2311 * None.
2312 *
2313 * Side effects:
2314 * The JumpFixup record pointed to by "jumpFixupPtr" is initialized
2315 * with information needed later if the jump is to be grown. Also,
2316 * a two byte jump of the designated type is emitted at the current
2317 * point in the bytecode stream.
2318 *
2319 *----------------------------------------------------------------------
2320 */
2321
2322 void
2323 TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
2324 CompileEnv *envPtr; /* Points to the CompileEnv structure that
2325 * holds the resulting instruction. */
2326 TclJumpType jumpType; /* Indicates the kind of jump: if true or
2327 * false or unconditional. */
2328 JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to
2329 * initialize with information about this
2330 * forward jump. */
2331 {
2332 /*
2333 * Initialize the JumpFixup structure:
2334 * - codeOffset is offset of first byte of jump below
2335 * - cmdIndex is index of the command after the current one
2336 * - exceptIndex is the index of the first ExceptionRange after
2337 * the current one.
2338 */
2339
2340 jumpFixupPtr->jumpType = jumpType;
2341 jumpFixupPtr->codeOffset = (envPtr->codeNext - envPtr->codeStart);
2342 jumpFixupPtr->cmdIndex = envPtr->numCommands;
2343 jumpFixupPtr->exceptIndex = envPtr->exceptArrayNext;
2344
2345 switch (jumpType) {
2346 case TCL_UNCONDITIONAL_JUMP:
2347 TclEmitInstInt1(INST_JUMP1, 0, envPtr);
2348 break;
2349 case TCL_TRUE_JUMP:
2350 TclEmitInstInt1(INST_JUMP_TRUE1, 0, envPtr);
2351 break;
2352 default:
2353 TclEmitInstInt1(INST_JUMP_FALSE1, 0, envPtr);
2354 break;
2355 }
2356 }
2357
2358 /*
2359 *----------------------------------------------------------------------
2360 *
2361 * TclFixupForwardJump --
2362 *
2363 * Procedure that updates a previously-emitted forward jump to jump
2364 * a specified number of bytes, "jumpDist". If necessary, the jump is
2365 * grown from two to five bytes; this is done if the jump distance is
2366 * greater than "distThreshold" (normally 127 bytes). The jump is
2367 * described by a JumpFixup record previously initialized by
2368 * TclEmitForwardJump.
2369 *
2370 * Results:
2371 * 1 if the jump was grown and subsequent instructions had to be moved;
2372 * otherwise 0. This result is returned to allow callers to update
2373 * any additional code offsets they may hold.
2374 *
2375 * Side effects:
2376 * The jump may be grown and subsequent instructions moved. If this
2377 * happens, the code offsets for any commands and any ExceptionRange
2378 * records between the jump and the current code address will be
2379 * updated to reflect the moved code. Also, the bytecode instruction
2380 * array in the CompileEnv structure may be grown and reallocated.
2381 *
2382 *----------------------------------------------------------------------
2383 */
2384
2385 int
2386 TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
2387 CompileEnv *envPtr; /* Points to the CompileEnv structure that
2388 * holds the resulting instruction. */
2389 JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that
2390 * describes the forward jump. */
2391 int jumpDist; /* Jump distance to set in jump
2392 * instruction. */
2393 int distThreshold; /* Maximum distance before the two byte
2394 * jump is grown to five bytes. */
2395 {
2396 unsigned char *jumpPc, *p;
2397 int firstCmd, lastCmd, firstRange, lastRange, k;
2398 unsigned int numBytes;
2399
2400 if (jumpDist <= distThreshold) {
2401 jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
2402 switch (jumpFixupPtr->jumpType) {
2403 case TCL_UNCONDITIONAL_JUMP:
2404 TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
2405 break;
2406 case TCL_TRUE_JUMP:
2407 TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
2408 break;
2409 default:
2410 TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
2411 break;
2412 }
2413 return 0;
2414 }
2415
2416 /*
2417 * We must grow the jump then move subsequent instructions down.
2418 * Note that if we expand the space for generated instructions,
2419 * code addresses might change; be careful about updating any of
2420 * these addresses held in variables.
2421 */
2422
2423 if ((envPtr->codeNext + 3) > envPtr->codeEnd) {
2424 TclExpandCodeArray(envPtr);
2425 }
2426 jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
2427 for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
2428 numBytes > 0; numBytes--, p--) {
2429 p[3] = p[0];
2430 }
2431 envPtr->codeNext += 3;
2432 jumpDist += 3;
2433 switch (jumpFixupPtr->jumpType) {
2434 case TCL_UNCONDITIONAL_JUMP:
2435 TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
2436 break;
2437 case TCL_TRUE_JUMP:
2438 TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
2439 break;
2440 default:
2441 TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
2442 break;
2443 }
2444
2445 /*
2446 * Adjust the code offsets for any commands and any ExceptionRange
2447 * records between the jump and the current code address.
2448 */
2449
2450 firstCmd = jumpFixupPtr->cmdIndex;
2451 lastCmd = (envPtr->numCommands - 1);
2452 if (firstCmd < lastCmd) {
2453 for (k = firstCmd; k <= lastCmd; k++) {
2454 (envPtr->cmdMapPtr[k]).codeOffset += 3;
2455 }
2456 }
2457
2458 firstRange = jumpFixupPtr->exceptIndex;
2459 lastRange = (envPtr->exceptArrayNext - 1);
2460 for (k = firstRange; k <= lastRange; k++) {
2461 ExceptionRange *rangePtr = &(envPtr->exceptArrayPtr[k]);
2462 rangePtr->codeOffset += 3;
2463
2464 switch (rangePtr->type) {
2465 case LOOP_EXCEPTION_RANGE:
2466 rangePtr->breakOffset += 3;
2467 if (rangePtr->continueOffset != -1) {
2468 rangePtr->continueOffset += 3;
2469 }
2470 break;
2471 case CATCH_EXCEPTION_RANGE:
2472 rangePtr->catchOffset += 3;
2473 break;
2474 default:
2475 panic("TclFixupForwardJump: bad ExceptionRange type %d\n",
2476 rangePtr->type);
2477 }
2478 }
2479 return 1; /* the jump was grown */
2480 }
2481
2482 /*
2483 *----------------------------------------------------------------------
2484 *
2485 * TclGetInstructionTable --
2486 *
2487 * Returns a pointer to the table describing Tcl bytecode instructions.
2488 * This procedure is defined so that clients can access the pointer from
2489 * outside the TCL DLLs.
2490 *
2491 * Results:
2492 * Returns a pointer to the global instruction table, same as the
2493 * expression (&instructionTable[0]).
2494 *
2495 * Side effects:
2496 * None.
2497 *
2498 *----------------------------------------------------------------------
2499 */
2500
2501 InstructionDesc *
2502 TclGetInstructionTable()
2503 {
2504 return &instructionTable[0];
2505 }
2506
2507 /*
2508 *--------------------------------------------------------------
2509 *
2510 * TclRegisterAuxDataType --
2511 *
2512 * This procedure is called to register a new AuxData type
2513 * in the table of all AuxData types supported by Tcl.
2514 *
2515 * Results:
2516 * None.
2517 *
2518 * Side effects:
2519 * The type is registered in the AuxData type table. If there was already
2520 * a type with the same name as in typePtr, it is replaced with the
2521 * new type.
2522 *
2523 *--------------------------------------------------------------
2524 */
2525
2526 void
2527 TclRegisterAuxDataType(typePtr)
2528 AuxDataType *typePtr; /* Information about object type;
2529 * storage must be statically
2530 * allocated (must live forever). */
2531 {
2532 register Tcl_HashEntry *hPtr;
2533 int new;
2534
2535 Tcl_MutexLock(&tableMutex);
2536 if (!auxDataTypeTableInitialized) {
2537 TclInitAuxDataTypeTable();
2538 }
2539
2540 /*
2541 * If there's already a type with the given name, remove it.
2542 */
2543
2544 hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
2545 if (hPtr != (Tcl_HashEntry *) NULL) {
2546 Tcl_DeleteHashEntry(hPtr);
2547 }
2548
2549 /*
2550 * Now insert the new object type.
2551 */
2552
2553 hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
2554 if (new) {
2555 Tcl_SetHashValue(hPtr, typePtr);
2556 }
2557 Tcl_MutexUnlock(&tableMutex);
2558 }
2559
2560 /*
2561 *----------------------------------------------------------------------
2562 *
2563 * TclGetAuxDataType --
2564 *
2565 * This procedure looks up an Auxdata type by name.
2566 *
2567 * Results:
2568 * If an AuxData type with name matching "typeName" is found, a pointer
2569 * to its AuxDataType structure is returned; otherwise, NULL is returned.
2570 *
2571 * Side effects:
2572 * None.
2573 *
2574 *----------------------------------------------------------------------
2575 */
2576
2577 AuxDataType *
2578 TclGetAuxDataType(typeName)
2579 char *typeName; /* Name of AuxData type to look up. */
2580 {
2581 register Tcl_HashEntry *hPtr;
2582 AuxDataType *typePtr = NULL;
2583
2584 Tcl_MutexLock(&tableMutex);
2585 if (!auxDataTypeTableInitialized) {
2586 TclInitAuxDataTypeTable();
2587 }
2588
2589 hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
2590 if (hPtr != (Tcl_HashEntry *) NULL) {
2591 typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
2592 }
2593 Tcl_MutexUnlock(&tableMutex);
2594
2595 return typePtr;
2596 }
2597
2598 /*
2599 *--------------------------------------------------------------
2600 *
2601 * TclInitAuxDataTypeTable --
2602 *
2603 * This procedure is invoked to perform once-only initialization of
2604 * the AuxData type table. It also registers the AuxData types defined in
2605 * this file.
2606 *
2607 * Results:
2608 * None.
2609 *
2610 * Side effects:
2611 * Initializes the table of defined AuxData types "auxDataTypeTable" with
2612 * builtin AuxData types defined in this file.
2613 *
2614 *--------------------------------------------------------------
2615 */
2616
2617 void
2618 TclInitAuxDataTypeTable()
2619 {
2620 /*
2621 * The table mutex must already be held before this routine is invoked.
2622 */
2623
2624 auxDataTypeTableInitialized = 1;
2625 Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
2626
2627 /*
2628 * There is only one AuxData type at this time, so register it here.
2629 */
2630
2631 TclRegisterAuxDataType(&tclForeachInfoType);
2632 }
2633
2634 /*
2635 *----------------------------------------------------------------------
2636 *
2637 * TclFinalizeAuxDataTypeTable --
2638 *
2639 * This procedure is called by Tcl_Finalize after all exit handlers
2640 * have been run to free up storage associated with the table of AuxData
2641 * types. This procedure is called by TclFinalizeExecution() which
2642 * is called by Tcl_Finalize().
2643 *
2644 * Results:
2645 * None.
2646 *
2647 * Side effects:
2648 * Deletes all entries in the hash table of AuxData types.
2649 *
2650 *----------------------------------------------------------------------
2651 */
2652
2653 void
2654 TclFinalizeAuxDataTypeTable()
2655 {
2656 Tcl_MutexLock(&tableMutex);
2657 if (auxDataTypeTableInitialized) {
2658 Tcl_DeleteHashTable(&auxDataTypeTable);
2659 auxDataTypeTableInitialized = 0;
2660 }
2661 Tcl_MutexUnlock(&tableMutex);
2662 }
2663
2664 /*
2665 *----------------------------------------------------------------------
2666 *
2667 * GetCmdLocEncodingSize --
2668 *
2669 * Computes the total number of bytes needed to encode the command
2670 * location information for some compiled code.
2671 *
2672 * Results:
2673 * The byte count needed to encode the compiled location information.
2674 *
2675 * Side effects:
2676 * None.
2677 *
2678 *----------------------------------------------------------------------
2679 */
2680
2681 static int
2682 GetCmdLocEncodingSize(envPtr)
2683 CompileEnv *envPtr; /* Points to compilation environment
2684 * structure containing the CmdLocation
2685 * structure to encode. */
2686 {
2687 register CmdLocation *mapPtr = envPtr->cmdMapPtr;
2688 int numCmds = envPtr->numCommands;
2689 int codeDelta, codeLen, srcDelta, srcLen;
2690 int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
2691 /* The offsets in their respective byte
2692 * sequences where the next encoded offset
2693 * or length should go. */
2694 int prevCodeOffset, prevSrcOffset, i;
2695
2696 codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
2697 prevCodeOffset = prevSrcOffset = 0;
2698 for (i = 0; i < numCmds; i++) {
2699 codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
2700 if (codeDelta < 0) {
2701 panic("GetCmdLocEncodingSize: bad code offset");
2702 } else if (codeDelta <= 127) {
2703 codeDeltaNext++;
2704 } else {
2705 codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
2706 }
2707 prevCodeOffset = mapPtr[i].codeOffset;
2708
2709 codeLen = mapPtr[i].numCodeBytes;
2710 if (codeLen < 0) {
2711 panic("GetCmdLocEncodingSize: bad code length");
2712 } else if (codeLen <= 127) {
2713 codeLengthNext++;
2714 } else {
2715 codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
2716 }
2717
2718 srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
2719 if ((-127 <= srcDelta) && (srcDelta <= 127)) {
2720 srcDeltaNext++;
2721 } else {
2722 srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
2723 }
2724 prevSrcOffset = mapPtr[i].srcOffset;
2725
2726 srcLen = mapPtr[i].numSrcBytes;
2727 if (srcLen < 0) {
2728 panic("GetCmdLocEncodingSize: bad source length");
2729 } else if (srcLen <= 127) {
2730 srcLengthNext++;
2731 } else {
2732 srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
2733 }
2734 }
2735
2736 return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
2737 }
2738
2739 /*
2740 *----------------------------------------------------------------------
2741 *
2742 * EncodeCmdLocMap --
2743 *
2744 * Encode the command location information for some compiled code into
2745 * a ByteCode structure. The encoded command location map is stored as
2746 * three adjacent byte sequences.
2747 *
2748 * Results:
2749 * Pointer to the first byte after the encoded command location
2750 * information.
2751 *
2752 * Side effects:
2753 * The encoded information is stored into the block of memory headed
2754 * by codePtr. Also records pointers to the start of the four byte
2755 * sequences in fields in codePtr's ByteCode header structure.
2756 *
2757 *----------------------------------------------------------------------
2758 */
2759
2760 static unsigned char *
2761 EncodeCmdLocMap(envPtr, codePtr, startPtr)
2762 CompileEnv *envPtr; /* Points to compilation environment
2763 * structure containing the CmdLocation
2764 * structure to encode. */
2765 ByteCode *codePtr; /* ByteCode in which to encode envPtr's
2766 * command location information. */
2767 unsigned char *startPtr; /* Points to the first byte in codePtr's
2768 * memory block where the location
2769 * information is to be stored. */
2770 {
2771 register CmdLocation *mapPtr = envPtr->cmdMapPtr;
2772 int numCmds = envPtr->numCommands;
2773 register unsigned char *p = startPtr;
2774 int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
2775 register int i;
2776
2777 /*
2778 * Encode the code offset for each command as a sequence of deltas.
2779 */
2780
2781 codePtr->codeDeltaStart = p;
2782 prevOffset = 0;
2783 for (i = 0; i < numCmds; i++) {
2784 codeDelta = (mapPtr[i].codeOffset - prevOffset);
2785 if (codeDelta < 0) {
2786 panic("EncodeCmdLocMap: bad code offset");
2787 } else if (codeDelta <= 127) {
2788 TclStoreInt1AtPtr(codeDelta, p);
2789 p++;
2790 } else {
2791 TclStoreInt1AtPtr(0xFF, p);
2792 p++;
2793 TclStoreInt4AtPtr(codeDelta, p);
2794 p += 4;
2795 }
2796 prevOffset = mapPtr[i].codeOffset;
2797 }
2798
2799 /*
2800 * Encode the code length for each command.
2801 */
2802
2803 codePtr->codeLengthStart = p;
2804 for (i = 0; i < numCmds; i++) {
2805 codeLen = mapPtr[i].numCodeBytes;
2806 if (codeLen < 0) {
2807 panic("EncodeCmdLocMap: bad code length");
2808 } else if (codeLen <= 127) {
2809 TclStoreInt1AtPtr(codeLen, p);
2810 p++;
2811 } else {
2812 TclStoreInt1AtPtr(0xFF, p);
2813 p++;
2814 TclStoreInt4AtPtr(codeLen, p);
2815 p += 4;
2816 }
2817 }
2818
2819 /*
2820 * Encode the source offset for each command as a sequence of deltas.
2821 */
2822
2823 codePtr->srcDeltaStart = p;
2824 prevOffset = 0;
2825 for (i = 0; i < numCmds; i++) {
2826 srcDelta = (mapPtr[i].srcOffset - prevOffset);
2827 if ((-127 <= srcDelta) && (srcDelta <= 127)) {
2828 TclStoreInt1AtPtr(srcDelta, p);
2829 p++;
2830 } else {
2831 TclStoreInt1AtPtr(0xFF, p);
2832 p++;
2833 TclStoreInt4AtPtr(srcDelta, p);
2834 p += 4;
2835 }
2836 prevOffset = mapPtr[i].srcOffset;
2837 }
2838
2839 /*
2840 * Encode the source length for each command.
2841 */
2842
2843 codePtr->srcLengthStart = p;
2844 for (i = 0; i < numCmds; i++) {
2845 srcLen = mapPtr[i].numSrcBytes;
2846 if (srcLen < 0) {
2847 panic("EncodeCmdLocMap: bad source length");
2848 } else if (srcLen <= 127) {
2849 TclStoreInt1AtPtr(srcLen, p);
2850 p++;
2851 } else {
2852 TclStoreInt1AtPtr(0xFF, p);
2853 p++;
2854 TclStoreInt4AtPtr(srcLen, p);
2855 p += 4;
2856 }
2857 }
2858
2859 return p;
2860 }
2861
2862 #ifdef TCL_COMPILE_DEBUG
2863 /*
2864 *----------------------------------------------------------------------
2865 *
2866 * TclPrintByteCodeObj --
2867 *
2868 * This procedure prints ("disassembles") the instructions of a
2869 * bytecode object to stdout.
2870 *
2871 * Results:
2872 * None.
2873 *
2874 * Side effects:
2875 * None.
2876 *
2877 *----------------------------------------------------------------------
2878 */
2879
2880 void
2881 TclPrintByteCodeObj(interp, objPtr)
2882 Tcl_Interp *interp; /* Used only for Tcl_GetStringFromObj. */
2883 Tcl_Obj *objPtr; /* The bytecode object to disassemble. */
2884 {
2885 ByteCode* codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
2886 unsigned char *codeStart, *codeLimit, *pc;
2887 unsigned char *codeDeltaNext, *codeLengthNext;
2888 unsigned char *srcDeltaNext, *srcLengthNext;
2889 int codeOffset, codeLen, srcOffset, srcLen, numCmds, delta, i;
2890 Interp *iPtr = (Interp *) *codePtr->interpHandle;
2891
2892 if (codePtr->refCount <= 0) {
2893 return; /* already freed */
2894 }
2895
2896 codeStart = codePtr->codeStart;
2897 codeLimit = (codeStart + codePtr->numCodeBytes);
2898 numCmds = codePtr->numCommands;
2899
2900 /*
2901 * Print header lines describing the ByteCode.
2902 */
2903
2904 fprintf(stdout, "\nByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
2905 (unsigned int) codePtr, codePtr->refCount,
2906 codePtr->compileEpoch, (unsigned int) iPtr,
2907 iPtr->compileEpoch);
2908 fprintf(stdout, " Source ");
2909 TclPrintSource(stdout, codePtr->source,
2910 TclMin(codePtr->numSrcBytes, 55));
2911 fprintf(stdout, "\n Cmds %d, src %d, inst %d, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
2912 numCmds, codePtr->numSrcBytes, codePtr->numCodeBytes,
2913 codePtr->numLitObjects, codePtr->numAuxDataItems,
2914 codePtr->maxStackDepth,
2915 #ifdef TCL_COMPILE_STATS
2916 (codePtr->numSrcBytes?
2917 ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
2918 #else
2919 0.0);
2920 #endif
2921 #ifdef TCL_COMPILE_STATS
2922 fprintf(stdout,
2923 " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
2924 codePtr->structureSize,
2925 (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
2926 codePtr->numCodeBytes,
2927 (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
2928 (codePtr->numExceptRanges * sizeof(ExceptionRange)),
2929 (codePtr->numAuxDataItems * sizeof(AuxData)),
2930 codePtr->numCmdLocBytes);
2931 #endif /* TCL_COMPILE_STATS */
2932
2933 /*
2934 * If the ByteCode is the compiled body of a Tcl procedure, print
2935 * information about that procedure. Note that we don't know the
2936 * procedure's name since ByteCode's can be shared among procedures.
2937 */
2938
2939 if (codePtr->procPtr != NULL) {
2940 Proc *procPtr = codePtr->procPtr;
2941 int numCompiledLocals = procPtr->numCompiledLocals;
2942 fprintf(stdout,
2943 " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
2944 (unsigned int) procPtr, procPtr->refCount, procPtr->numArgs,
2945 numCompiledLocals);
2946 if (numCompiledLocals > 0) {
2947 CompiledLocal *localPtr = procPtr->firstLocalPtr;
2948 for (i = 0; i < numCompiledLocals; i++) {
2949 fprintf(stdout, " slot %d%s%s%s%s%s%s", i,
2950 ((localPtr->flags & VAR_SCALAR)? ", scalar" : ""),
2951 ((localPtr->flags & VAR_ARRAY)? ", array" : ""),
2952 ((localPtr->flags & VAR_LINK)? ", link" : ""),
2953 ((localPtr->flags & VAR_ARGUMENT)? ", arg" : ""),
2954 ((localPtr->flags & VAR_TEMPORARY)? ", temp" : ""),
2955 ((localPtr->flags & VAR_RESOLVED)? ", resolved" : ""));
2956 if (TclIsVarTemporary(localPtr)) {
2957 fprintf(stdout, "\n");
2958 } else {
2959 fprintf(stdout, ", \"%s\"\n", localPtr->name);
2960 }
2961 localPtr = localPtr->nextPtr;
2962 }
2963 }
2964 }
2965
2966 /*
2967 * Print the ExceptionRange array.
2968 */
2969
2970 if (codePtr->numExceptRanges > 0) {
2971 fprintf(stdout, " Exception ranges %d, depth %d:\n",
2972 codePtr->numExceptRanges, codePtr->maxExceptDepth);
2973 for (i = 0; i < codePtr->numExceptRanges; i++) {
2974 ExceptionRange *rangePtr = &(codePtr->exceptArrayPtr[i]);
2975 fprintf(stdout, " %d: level %d, %s, pc %d-%d, ",
2976 i, rangePtr->nestingLevel,
2977 ((rangePtr->type == LOOP_EXCEPTION_RANGE)
2978 ? "loop" : "catch"),
2979 rangePtr->codeOffset,
2980 (rangePtr->codeOffset + rangePtr->numCodeBytes - 1));
2981 switch (rangePtr->type) {
2982 case LOOP_EXCEPTION_RANGE:
2983 fprintf(stdout, "continue %d, break %d\n",
2984 rangePtr->continueOffset, rangePtr->breakOffset);
2985 break;
2986 case CATCH_EXCEPTION_RANGE:
2987 fprintf(stdout, "catch %d\n", rangePtr->catchOffset);
2988 break;
2989 default:
2990 panic("TclPrintByteCodeObj: bad ExceptionRange type %d\n",
2991 rangePtr->type);
2992 }
2993 }
2994 }
2995
2996 /*
2997 * If there were no commands (e.g., an expression or an empty string
2998 * was compiled), just print all instructions and return.
2999 */
3000
3001 if (numCmds == 0) {
3002 pc = codeStart;
3003 while (pc < codeLimit) {
3004 fprintf(stdout, " ");
3005 pc += TclPrintInstruction(codePtr, pc);
3006 }
3007 return;
3008 }
3009
3010 /*
3011 * Print table showing the code offset, source offset, and source
3012 * length for each command. These are encoded as a sequence of bytes.
3013 */
3014
3015 fprintf(stdout, " Commands %d:", numCmds);
3016 codeDeltaNext = codePtr->codeDeltaStart;
3017 codeLengthNext = codePtr->codeLengthStart;
3018 srcDeltaNext = codePtr->srcDeltaStart;
3019 srcLengthNext = codePtr->srcLengthStart;
3020 codeOffset = srcOffset = 0;
3021 for (i = 0; i < numCmds; i++) {
3022 if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
3023 codeDeltaNext++;
3024 delta = TclGetInt4AtPtr(codeDeltaNext);
3025 codeDeltaNext += 4;
3026 } else {
3027 delta = TclGetInt1AtPtr(codeDeltaNext);
3028 codeDeltaNext++;
3029 }
3030 codeOffset += delta;
3031
3032 if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
3033 codeLengthNext++;
3034 codeLen = TclGetInt4AtPtr(codeLengthNext);
3035 codeLengthNext += 4;
3036 } else {
3037 codeLen = TclGetInt1AtPtr(codeLengthNext);
3038 codeLengthNext++;
3039 }
3040
3041 if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
3042 srcDeltaNext++;
3043 delta = TclGetInt4AtPtr(srcDeltaNext);
3044 srcDeltaNext += 4;
3045 } else {
3046 delta = TclGetInt1AtPtr(srcDeltaNext);
3047 srcDeltaNext++;
3048 }
3049 srcOffset += delta;
3050
3051 if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
3052 srcLengthNext++;
3053 srcLen = TclGetInt4AtPtr(srcLengthNext);
3054 srcLengthNext += 4;
3055 } else {
3056 srcLen = TclGetInt1AtPtr(srcLengthNext);
3057 srcLengthNext++;
3058 }
3059
3060 fprintf(stdout, "%s%4d: pc %d-%d, src %d-%d",
3061 ((i % 2)? " " : "\n "),
3062 (i+1), codeOffset, (codeOffset + codeLen - 1),
3063 srcOffset, (srcOffset + srcLen - 1));
3064 }
3065 if (numCmds > 0) {
3066 fprintf(stdout, "\n");
3067 }
3068
3069 /*
3070 * Print each instruction. If the instruction corresponds to the start
3071 * of a command, print the command's source. Note that we don't need
3072 * the code length here.
3073 */
3074
3075 codeDeltaNext = codePtr->codeDeltaStart;
3076 srcDeltaNext = codePtr->srcDeltaStart;
3077 srcLengthNext = codePtr->srcLengthStart;
3078 codeOffset = srcOffset = 0;
3079 pc = codeStart;
3080 for (i = 0; i < numCmds; i++) {
3081 if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
3082 codeDeltaNext++;
3083 delta = TclGetInt4AtPtr(codeDeltaNext);
3084 codeDeltaNext += 4;
3085 } else {
3086 delta = TclGetInt1AtPtr(codeDeltaNext);
3087 codeDeltaNext++;
3088 }
3089 codeOffset += delta;
3090
3091 if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
3092 srcDeltaNext++;
3093 delta = TclGetInt4AtPtr(srcDeltaNext);
3094 srcDeltaNext += 4;
3095 } else {
3096 delta = TclGetInt1AtPtr(srcDeltaNext);
3097 srcDeltaNext++;
3098 }
3099 srcOffset += delta;
3100
3101 if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
3102 srcLengthNext++;
3103 srcLen = TclGetInt4AtPtr(srcLengthNext);
3104 srcLengthNext += 4;
3105 } else {
3106 srcLen = TclGetInt1AtPtr(srcLengthNext);
3107 srcLengthNext++;
3108 }
3109
3110 /*
3111 * Print instructions before command i.
3112 */
3113
3114 while ((pc-codeStart) < codeOffset) {
3115 fprintf(stdout, " ");
3116 pc += TclPrintInstruction(codePtr, pc);
3117 }
3118
3119 fprintf(stdout, " Command %d: ", (i+1));
3120 TclPrintSource(stdout, (codePtr->source + srcOffset),
3121 TclMin(srcLen, 55));
3122 fprintf(stdout, "\n");
3123 }
3124 if (pc < codeLimit) {
3125 /*
3126 * Print instructions after the last command.
3127 */
3128
3129 while (pc < codeLimit) {
3130 fprintf(stdout, " ");
3131 pc += TclPrintInstruction(codePtr, pc);
3132 }
3133 }
3134 }
3135 #endif /* TCL_COMPILE_DEBUG */
3136
3137 /*
3138 *----------------------------------------------------------------------
3139 *
3140 * TclPrintInstruction --
3141 *
3142 * This procedure prints ("disassembles") one instruction from a
3143 * bytecode object to stdout.
3144 *
3145 * Results:
3146 * Returns the length in bytes of the current instruiction.
3147 *
3148 * Side effects:
3149 * None.
3150 *
3151 *----------------------------------------------------------------------
3152 */
3153
3154 int
3155 TclPrintInstruction(codePtr, pc)
3156 ByteCode* codePtr; /* Bytecode containing the instruction. */
3157 unsigned char *pc; /* Points to first byte of instruction. */
3158 {
3159 Proc *procPtr = codePtr->procPtr;
3160 unsigned char opCode = *pc;
3161 register InstructionDesc *instDesc = &instructionTable[opCode];
3162 unsigned char *codeStart = codePtr->codeStart;
3163 unsigned int pcOffset = (pc - codeStart);
3164 int opnd, i, j;
3165
3166 fprintf(stdout, "(%u) %s ", pcOffset, instDesc->name);
3167 for (i = 0; i < instDesc->numOperands; i++) {
3168 switch (instDesc->opTypes[i]) {
3169 case OPERAND_INT1:
3170 opnd = TclGetInt1AtPtr(pc+1+i);
3171 if ((i == 0) && ((opCode == INST_JUMP1)
3172 || (opCode == INST_JUMP_TRUE1)
3173 || (opCode == INST_JUMP_FALSE1))) {
3174 fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
3175 } else {
3176 fprintf(stdout, "%d", opnd);
3177 }
3178 break;
3179 case OPERAND_INT4:
3180 opnd = TclGetInt4AtPtr(pc+1+i);
3181 if ((i == 0) && ((opCode == INST_JUMP4)
3182 || (opCode == INST_JUMP_TRUE4)
3183 || (opCode == INST_JUMP_FALSE4))) {
3184 fprintf(stdout, "%d # pc %u", opnd, (pcOffset + opnd));
3185 } else {
3186 fprintf(stdout, "%d", opnd);
3187 }
3188 break;
3189 case OPERAND_UINT1:
3190 opnd = TclGetUInt1AtPtr(pc+1+i);
3191 if ((i == 0) && (opCode == INST_PUSH1)) {
3192 fprintf(stdout, "%u # ", (unsigned int) opnd);
3193 TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
3194 } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR1)
3195 || (opCode == INST_LOAD_ARRAY1)
3196 || (opCode == INST_STORE_SCALAR1)
3197 || (opCode == INST_STORE_ARRAY1))) {
3198 int localCt = procPtr->numCompiledLocals;
3199 CompiledLocal *localPtr = procPtr->firstLocalPtr;
3200 if (opnd >= localCt) {
3201 panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
3202 (unsigned int) opnd, localCt);
3203 return instDesc->numBytes;
3204 }
3205 for (j = 0; j < opnd; j++) {
3206 localPtr = localPtr->nextPtr;
3207 }
3208 if (TclIsVarTemporary(localPtr)) {
3209 fprintf(stdout, "%u # temp var %u",
3210 (unsigned int) opnd, (unsigned int) opnd);
3211 } else {
3212 fprintf(stdout, "%u # var ", (unsigned int) opnd);
3213 TclPrintSource(stdout, localPtr->name, 40);
3214 }
3215 } else {
3216 fprintf(stdout, "%u ", (unsigned int) opnd);
3217 }
3218 break;
3219 case OPERAND_UINT4:
3220 opnd = TclGetUInt4AtPtr(pc+1+i);
3221 if (opCode == INST_PUSH4) {
3222 fprintf(stdout, "%u # ", opnd);
3223 TclPrintObject(stdout, codePtr->objArrayPtr[opnd], 40);
3224 } else if ((i == 0) && ((opCode == INST_LOAD_SCALAR4)
3225 || (opCode == INST_LOAD_ARRAY4)
3226 || (opCode == INST_STORE_SCALAR4)
3227 || (opCode == INST_STORE_ARRAY4))) {
3228 int localCt = procPtr->numCompiledLocals;
3229 CompiledLocal *localPtr = procPtr->firstLocalPtr;
3230 if (opnd >= localCt) {
3231 panic("TclPrintInstruction: bad local var index %u (%u locals)\n",
3232 (unsigned int) opnd, localCt);
3233 return instDesc->numBytes;
3234 }
3235 for (j = 0; j < opnd; j++) {
3236 localPtr = localPtr->nextPtr;
3237 }
3238 if (TclIsVarTemporary(localPtr)) {
3239 fprintf(stdout, "%u # temp var %u",
3240 (unsigned int) opnd, (unsigned int) opnd);
3241 } else {
3242 fprintf(stdout, "%u # var ", (unsigned int) opnd);
3243 TclPrintSource(stdout, localPtr->name, 40);
3244 }
3245 } else {
3246 fprintf(stdout, "%u ", (unsigned int) opnd);
3247 }
3248 break;
3249 case OPERAND_NONE:
3250 default:
3251 break;
3252 }
3253 }
3254 fprintf(stdout, "\n");
3255 return instDesc->numBytes;
3256 }
3257
3258 /*
3259 *----------------------------------------------------------------------
3260 *
3261 * TclPrintObject --
3262 *
3263 * This procedure prints up to a specified number of characters from
3264 * the argument Tcl object's string representation to a specified file.
3265 *
3266 * Results:
3267 * None.
3268 *
3269 * Side effects:
3270 * Outputs characters to the specified file.
3271 *
3272 *----------------------------------------------------------------------
3273 */
3274
3275 void
3276 TclPrintObject(outFile, objPtr, maxChars)
3277 FILE *outFile; /* The file to print the source to. */
3278 Tcl_Obj *objPtr; /* Points to the Tcl object whose string
3279 * representation should be printed. */
3280 int maxChars; /* Maximum number of chars to print. */
3281 {
3282 char *bytes;
3283 int length;
3284
3285 bytes = Tcl_GetStringFromObj(objPtr, &length);
3286 TclPrintSource(outFile, bytes, TclMin(length, maxChars));
3287 }
3288
3289 /*
3290 *----------------------------------------------------------------------
3291 *
3292 * TclPrintSource --
3293 *
3294 * This procedure prints up to a specified number of characters from
3295 * the argument string to a specified file. It tries to produce legible
3296 * output by adding backslashes as necessary.
3297 *
3298 * Results:
3299 * None.
3300 *
3301 * Side effects:
3302 * Outputs characters to the specified file.
3303 *
3304 *----------------------------------------------------------------------
3305 */
3306
3307 void
3308 TclPrintSource(outFile, string, maxChars)
3309 FILE *outFile; /* The file to print the source to. */
3310 char *string; /* The string to print. */
3311 int maxChars; /* Maximum number of chars to print. */
3312 {
3313 register char *p;
3314 register int i = 0;
3315
3316 if (string == NULL) {
3317 fprintf(outFile, "\"\"");
3318 return;
3319 }
3320
3321 fprintf(outFile, "\"");
3322 p = string;
3323 for (; (*p != '\0') && (i < maxChars); p++, i++) {
3324 switch (*p) {
3325 case '"':
3326 fprintf(outFile, "\\\"");
3327 continue;
3328 case '\f':
3329 fprintf(outFile, "\\f");
3330 continue;
3331 case '\n':
3332 fprintf(outFile, "\\n");
3333 continue;
3334 case '\r':
3335 fprintf(outFile, "\\r");
3336 continue;
3337 case '\t':
3338 fprintf(outFile, "\\t");
3339 continue;
3340 case '\v':
3341 fprintf(outFile, "\\v");
3342 continue;
3343 default:
3344 fprintf(outFile, "%c", *p);
3345 continue;
3346 }
3347 }
3348 fprintf(outFile, "\"");
3349 }
3350
3351 #ifdef TCL_COMPILE_STATS
3352 /*
3353 *----------------------------------------------------------------------
3354 *
3355 * RecordByteCodeStats --
3356 *
3357 * Accumulates various compilation-related statistics for each newly
3358 * compiled ByteCode. Called by the TclInitByteCodeObj when Tcl is
3359 * compiled with the -DTCL_COMPILE_STATS flag
3360 *
3361 * Results:
3362 * None.
3363 *
3364 * Side effects:
3365 * Accumulates aggregate code-related statistics in the interpreter's
3366 * ByteCodeStats structure. Records statistics specific to a ByteCode
3367 * in its ByteCode structure.
3368 *
3369 *----------------------------------------------------------------------
3370 */
3371
3372 void
3373 RecordByteCodeStats(codePtr)
3374 ByteCode *codePtr; /* Points to ByteCode structure with info
3375 * to add to accumulated statistics. */
3376 {
3377 Interp *iPtr = (Interp *) *codePtr->interpHandle;
3378 register ByteCodeStats *statsPtr = &(iPtr->stats);
3379
3380 statsPtr->numCompilations++;
3381 statsPtr->totalSrcBytes += (double) codePtr->numSrcBytes;
3382 statsPtr->totalByteCodeBytes += (double) codePtr->structureSize;
3383 statsPtr->currentSrcBytes += (double) codePtr->numSrcBytes;
3384 statsPtr->currentByteCodeBytes += (double) codePtr->structureSize;
3385
3386 statsPtr->srcCount[TclLog2(codePtr->numSrcBytes)]++;
3387 statsPtr->byteCodeCount[TclLog2(codePtr->structureSize)]++;
3388
3389 statsPtr->currentInstBytes += (double) codePtr->numCodeBytes;
3390 statsPtr->currentLitBytes +=
3391 (double) (codePtr->numLitObjects * sizeof(Tcl_Obj *));
3392 statsPtr->currentExceptBytes +=
3393 (double) (codePtr->numExceptRanges * sizeof(ExceptionRange));
3394 statsPtr->currentAuxBytes +=
3395 (double) (codePtr->numAuxDataItems * sizeof(AuxData));
3396 statsPtr->currentCmdMapBytes += (double) codePtr->numCmdLocBytes;
3397 }
3398 #endif /* TCL_COMPILE_STATS */
3399
3400 /* End of tclcompile.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25