Planet

navi

home

PPS

about

screenshots

download

development

forum

Context Navigation

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

Last change on this file since 45 was 25, checked in by landauf, 18 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
24	static Tcl_HashTable auxDataTypeTable;
25	static int auxDataTypeTableInitialized; /* 0 means not yet initialized. */
26
27	TCL_DECLARE_MUTEX(tableMutex)
28
29	/*
30	* Variable that controls whether compilation tracing is enabled and, if so,
31	* what level of tracing is desired:
32	* 0: no compilation tracing
33	* 1: summarize compilation of top level cmds and proc bodies
34	* 2: display all instructions of each ByteCode compiled
35	* This variable is linked to the Tcl variable "tcl_traceCompile".
36	*/
37
38	#ifdef TCL_COMPILE_DEBUG
39	int tclTraceCompile = 0;
40	static 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
55	InstructionDesc 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
409	static void DupByteCodeInternalRep(Tcl_Obj *srcPtr,
410	Tcl_Obj *copyPtr);
411	static unsigned char * EncodeCmdLocMap(CompileEnv *envPtr,
412	ByteCode codePtr, unsigned char startPtr);
413	static void EnterCmdExtentData(CompileEnv *envPtr,
414	int cmdNumber, int numSrcBytes, int numCodeBytes);
415	static void EnterCmdStartData(CompileEnv *envPtr,
416	int cmdNumber, int srcOffset, int codeOffset);
417	static void FreeByteCodeInternalRep(Tcl_Obj *objPtr);
418	static int GetCmdLocEncodingSize(CompileEnv *envPtr);
419	#ifdef TCL_COMPILE_STATS
420	static void RecordByteCodeStats(ByteCode *codePtr);
421	#endif /* TCL_COMPILE_STATS */
422	static int SetByteCodeFromAny(Tcl_Interp *interp,
423	Tcl_Obj *objPtr);
424	static int FormatInstruction(ByteCode *codePtr,
425	unsigned char pc, Tcl_Obj bufferObj);
426	static 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	*/
432	static 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
441	Tcl_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
474	int
475	TclSetByteCodeFromAny(
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
594	static int
595	SetByteCodeFromAny(
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
623	static void
624	DupByteCodeInternalRep(
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
651	static void
652	FreeByteCodeInternalRep(
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
686	void
687	TclCleanupByteCode(
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
847	void
848	TclInitCompileEnv(
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
1000	void
1001	TclFreeCompileEnv(
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
1051	int
1052	TclWordKnownAtCompileTime(
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
1124	void
1125	TclCompileScript(
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
1560	void
1561	TclCompileTokens(
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
1758	void
1759	TclCompileCmdWord(
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
1807	void
1808	TclCompileExprWords(
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
1873	int
1874	TclCompileNoOp(
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
1927	void
1928	TclInitByteCodeObj(
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
2092	int
2093	TclFindCompiledLocal(
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
2182	void
2183	TclExpandCodeArray(
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
2238	static void
2239	EnterCmdStartData(
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
2316	static void
2317	EnterCmdExtentData(
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
2362	static void
2363	EnterCmdWordData(
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
2435	int
2436	TclCreateExceptRange(
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
2508	int
2509	TclCreateAuxData(
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
2573	void
2574	TclInitJumpFixupArray(
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
2605	void
2606	TclExpandJumpFixupArray(
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
2653	void
2654	TclFreeJumpFixupArray(
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
2686	void
2687	TclEmitForwardJump(
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
2748	int
2749	TclFixupForwardJump(
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
2863	void * /* == InstructionDesc* == */
2864	TclGetInstructionTable(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
2888	void
2889	TclRegisterAuxDataType(
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
2939	AuxDataType *
2940	TclGetAuxDataType(
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
2979	void
2980	TclInitAuxDataTypeTable(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
3016	void
3017	TclFinalizeAuxDataTypeTable(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
3044	static int
3045	GetCmdLocEncodingSize(
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
3123	static unsigned char *
3124	EncodeCmdLocMap(
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
3243	void
3244	TclPrintByteCodeObj(
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
3271	int
3272	TclPrintInstruction(
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
3303	void
3304	TclPrintObject(
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
3335	void
3336	TclPrintSource(
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
3362	Tcl_Obj *
3363	TclDisassembleByteCodeObj(
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
3641	static int
3642	FormatInstruction(
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
3777	static void
3778	PrintSourceToObj(
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
3842	void
3843	RecordByteCodeStats(
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.

Download in other formats: