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

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

Parent Directory Parent Directory | Revision Log Revision Log


Revision 64 - (hide annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 7 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 dashley 64 /* $Header$ */
2 dashley 25 /*
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 dashley 64 /* End of tclcompile.c */

Properties

Name Value
svn:keywords Header

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25