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 | */ |
---|