/[dtapublic]/sf_code/esrgpcpj/shared/tcl_base/tclcompile.c
ViewVC logotype

Annotation of /sf_code/esrgpcpj/shared/tcl_base/tclcompile.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25