Planet
navi homePPSaboutscreenshotsdownloaddevelopmentforum

source: downloads/tcl8.5.2/generic/tclCompile.c @ 63

Last change on this file since 63 was 25, checked in by landauf, 17 years ago

added tcl to libs

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