Fork me on GitHub

source: git/external/tcl/tclCompile.c@ 227048f

Last change on this file since 227048f was adeddd8, checked in by Pavel Demin <pavel-demin@…>, 5 years ago

remove debug code from Tcl
  • Property mode set to 100644
File size: 241.7 KB
Line 
1/*
2 * tclCompile.c --
3 *
4 * This file contains procedures that compile Tcl commands or parts
5 * of commands (like quoted strings or nested sub-commands) into a
6 * sequence of instructions ("bytecodes").
7 *
8 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
9 * Copyright (c) 1998-1999 by Scriptics Corporation.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * RCS: @(#) $Id: tclCompile.c,v 1.1 2008-06-04 13:58:05 demin Exp $
15 */
16
17#include "tclInt.h"
18#include "tclCompile.h"
19
20/*
21 * A table describing the Tcl bytecode instructions. The entries in this
22 * table must correspond to the list of instructions in tclInt.h. The names
23 * "op1" and "op4" refer to an instruction's one or four byte first operand.
24 * Similarly, "stktop" and "stknext" refer to the topmost and next to
25 * topmost stack elements.
26 *
27 * Note that the load, store, and incr instructions do not distinguish local
28 * from global variables; the bytecode interpreter at runtime uses the
29 * existence of a procedure call frame to distinguish these.
30 */
31
32InstructionDesc instructionTable[] = {
33 /* Name Bytes #Opnds Operand types Stack top, next */
34 {"done", 1, 0, {OPERAND_NONE}},
35 /* Finish ByteCode execution and return stktop (top stack item) */
36 {"push1", 2, 1, {OPERAND_UINT1}},
37 /* Push object at ByteCode objArray[op1] */
38 {"push4", 5, 1, {OPERAND_UINT4}},
39 /* Push object at ByteCode objArray[op4] */
40 {"pop", 1, 0, {OPERAND_NONE}},
41 /* Pop the topmost stack object */
42 {"dup", 1, 0, {OPERAND_NONE}},
43 /* Duplicate the topmost stack object and push the result */
44 {"concat1", 2, 1, {OPERAND_UINT1}},
45 /* Concatenate the top op1 items and push result */
46 {"invokeStk1", 2, 1, {OPERAND_UINT1}},
47 /* Invoke command named objv[0]; <objc,objv> = <op1,top op1> */
48 {"invokeStk4", 5, 1, {OPERAND_UINT4}},
49 /* Invoke command named objv[0]; <objc,objv> = <op4,top op4> */
50 {"evalStk", 1, 0, {OPERAND_NONE}},
51 /* Evaluate command in stktop using Tcl_EvalObj. */
52 {"exprStk", 1, 0, {OPERAND_NONE}},
53 /* Execute expression in stktop using Tcl_ExprStringObj. */
54
55 {"loadScalar1", 2, 1, {OPERAND_UINT1}},
56 /* Load scalar variable at index op1 <= 255 in call frame */
57 {"loadScalar4", 5, 1, {OPERAND_UINT4}},
58 /* Load scalar variable at index op1 >= 256 in call frame */
59 {"loadScalarStk", 1, 0, {OPERAND_NONE}},
60 /* Load scalar variable; scalar's name is stktop */
61 {"loadArray1", 2, 1, {OPERAND_UINT1}},
62 /* Load array element; array at slot op1<=255, element is stktop */
63 {"loadArray4", 5, 1, {OPERAND_UINT4}},
64 /* Load array element; array at slot op1 > 255, element is stktop */
65 {"loadArrayStk", 1, 0, {OPERAND_NONE}},
66 /* Load array element; element is stktop, array name is stknext */
67 {"loadStk", 1, 0, {OPERAND_NONE}},
68 /* Load general variable; unparsed variable name is stktop */
69 {"storeScalar1", 2, 1, {OPERAND_UINT1}},
70 /* Store scalar variable at op1<=255 in frame; value is stktop */
71 {"storeScalar4", 5, 1, {OPERAND_UINT4}},
72 /* Store scalar variable at op1 > 255 in frame; value is stktop */
73 {"storeScalarStk", 1, 0, {OPERAND_NONE}},
74 /* Store scalar; value is stktop, scalar name is stknext */
75 {"storeArray1", 2, 1, {OPERAND_UINT1}},
76 /* Store array element; array at op1<=255, value is top then elem */
77 {"storeArray4", 5, 1, {OPERAND_UINT4}},
78 /* Store array element; array at op1>=256, value is top then elem */
79 {"storeArrayStk", 1, 0, {OPERAND_NONE}},
80 /* Store array element; value is stktop, then elem, array names */
81 {"storeStk", 1, 0, {OPERAND_NONE}},
82 /* Store general variable; value is stktop, then unparsed name */
83
84 {"incrScalar1", 2, 1, {OPERAND_UINT1}},
85 /* Incr scalar at index op1<=255 in frame; incr amount is stktop */
86 {"incrScalarStk", 1, 0, {OPERAND_NONE}},
87 /* Incr scalar; incr amount is stktop, scalar's name is stknext */
88 {"incrArray1", 2, 1, {OPERAND_UINT1}},
89 /* Incr array elem; arr at slot op1<=255, amount is top then elem */
90 {"incrArrayStk", 1, 0, {OPERAND_NONE}},
91 /* Incr array element; amount is top then elem then array names */
92 {"incrStk", 1, 0, {OPERAND_NONE}},
93 /* Incr general variable; amount is stktop then unparsed var name */
94 {"incrScalar1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
95 /* Incr scalar at slot op1 <= 255; amount is 2nd operand byte */
96 {"incrScalarStkImm", 2, 1, {OPERAND_INT1}},
97 /* Incr scalar; scalar name is stktop; incr amount is op1 */
98 {"incrArray1Imm", 3, 2, {OPERAND_UINT1, OPERAND_INT1}},
99 /* Incr array elem; array at slot op1 <= 255, elem is stktop,
100 * amount is 2nd operand byte */
101 {"incrArrayStkImm", 2, 1, {OPERAND_INT1}},
102 /* Incr array element; elem is top then array name, amount is op1 */
103 {"incrStkImm", 2, 1, {OPERAND_INT1}},
104 /* Incr general variable; unparsed name is top, amount is op1 */
105
106 {"jump1", 2, 1, {OPERAND_INT1}},
107 /* Jump relative to (pc + op1) */
108 {"jump4", 5, 1, {OPERAND_INT4}},
109 /* Jump relative to (pc + op4) */
110 {"jumpTrue1", 2, 1, {OPERAND_INT1}},
111 /* Jump relative to (pc + op1) if stktop expr object is true */
112 {"jumpTrue4", 5, 1, {OPERAND_INT4}},
113 /* Jump relative to (pc + op4) if stktop expr object is true */
114 {"jumpFalse1", 2, 1, {OPERAND_INT1}},
115 /* Jump relative to (pc + op1) if stktop expr object is false */
116 {"jumpFalse4", 5, 1, {OPERAND_INT4}},
117 /* Jump relative to (pc + op4) if stktop expr object is false */
118
119 {"lor", 1, 0, {OPERAND_NONE}},
120 /* Logical or: push (stknext || stktop) */
121 {"land", 1, 0, {OPERAND_NONE}},
122 /* Logical and: push (stknext && stktop) */
123 {"bitor", 1, 0, {OPERAND_NONE}},
124 /* Bitwise or: push (stknext | stktop) */
125 {"bitxor", 1, 0, {OPERAND_NONE}},
126 /* Bitwise xor push (stknext ^ stktop) */
127 {"bitand", 1, 0, {OPERAND_NONE}},
128 /* Bitwise and: push (stknext & stktop) */
129 {"eq", 1, 0, {OPERAND_NONE}},
130 /* Equal: push (stknext == stktop) */
131 {"neq", 1, 0, {OPERAND_NONE}},
132 /* Not equal: push (stknext != stktop) */
133 {"lt", 1, 0, {OPERAND_NONE}},
134 /* Less: push (stknext < stktop) */
135 {"gt", 1, 0, {OPERAND_NONE}},
136 /* Greater: push (stknext || stktop) */
137 {"le", 1, 0, {OPERAND_NONE}},
138 /* Logical or: push (stknext || stktop) */
139 {"ge", 1, 0, {OPERAND_NONE}},
140 /* Logical or: push (stknext || stktop) */
141 {"lshift", 1, 0, {OPERAND_NONE}},
142 /* Left shift: push (stknext << stktop) */
143 {"rshift", 1, 0, {OPERAND_NONE}},
144 /* Right shift: push (stknext >> stktop) */
145 {"add", 1, 0, {OPERAND_NONE}},
146 /* Add: push (stknext + stktop) */
147 {"sub", 1, 0, {OPERAND_NONE}},
148 /* Sub: push (stkext - stktop) */
149 {"mult", 1, 0, {OPERAND_NONE}},
150 /* Multiply: push (stknext * stktop) */
151 {"div", 1, 0, {OPERAND_NONE}},
152 /* Divide: push (stknext / stktop) */
153 {"mod", 1, 0, {OPERAND_NONE}},
154 /* Mod: push (stknext % stktop) */
155 {"uplus", 1, 0, {OPERAND_NONE}},
156 /* Unary plus: push +stktop */
157 {"uminus", 1, 0, {OPERAND_NONE}},
158 /* Unary minus: push -stktop */
159 {"bitnot", 1, 0, {OPERAND_NONE}},
160 /* Bitwise not: push ~stktop */
161 {"not", 1, 0, {OPERAND_NONE}},
162 /* Logical not: push !stktop */
163 {"callBuiltinFunc1", 2, 1, {OPERAND_UINT1}},
164 /* Call builtin math function with index op1; any args are on stk */
165 {"callFunc1", 2, 1, {OPERAND_UINT1}},
166 /* Call non-builtin func objv[0]; <objc,objv>=<op1,top op1> */
167 {"tryCvtToNumeric", 1, 0, {OPERAND_NONE}},
168 /* Try converting stktop to first int then double if possible. */
169
170 {"break", 1, 0, {OPERAND_NONE}},
171 /* Abort closest enclosing loop; if none, return TCL_BREAK code. */
172 {"continue", 1, 0, {OPERAND_NONE}},
173 /* Skip to next iteration of closest enclosing loop; if none,
174 * return TCL_CONTINUE code. */
175
176 {"foreach_start4", 5, 1, {OPERAND_UINT4}},
177 /* Initialize execution of a foreach loop. Operand is aux data index
178 * of the ForeachInfo structure for the foreach command. */
179 {"foreach_step4", 5, 1, {OPERAND_UINT4}},
180 /* "Step" or begin next iteration of foreach loop. Push 0 if to
181 * terminate loop, else push 1. */
182
183 {"beginCatch4", 5, 1, {OPERAND_UINT4}},
184 /* Record start of catch with the operand's exception range index.
185 * Push the current stack depth onto a special catch stack. */
186 {"endCatch", 1, 0, {OPERAND_NONE}},
187 /* End of last catch. Pop the bytecode interpreter's catch stack. */
188 {"pushResult", 1, 0, {OPERAND_NONE}},
189 /* Push the interpreter's object result onto the stack. */
190 {"pushReturnCode", 1, 0, {OPERAND_NONE}},
191 /* Push interpreter's return code (e.g. TCL_OK or TCL_ERROR) as
192 * a new object onto the stack. */
193 {0}
194};
195
196/*
197 * The following table assigns a type to each character. Only types
198 * meaningful to Tcl parsing are represented here. The table is
199 * designed to be referenced with either signed or unsigned characters,
200 * so it has 384 entries. The first 128 entries correspond to negative
201 * character values, the next 256 correspond to positive character
202 * values. The last 128 entries are identical to the first 128. The
203 * table is always indexed with a 128-byte offset (the 128th entry
204 * corresponds to a 0 character value).
205 */
206
207unsigned char tclTypeTable[] = {
208 /*
209 * Negative character values, from -128 to -1:
210 */
211
212 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
213 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
214 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
215 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
216 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
217 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
218 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
219 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
220 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
221 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
222 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
223 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
224 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
225 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
226 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
227 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
228 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
229 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
230 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
231 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
232 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
233 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
234 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
235 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
236 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
237 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
238 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
239 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
240 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
241 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
242 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
243 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
244
245 /*
246 * Positive character values, from 0-127:
247 */
248
249 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
250 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
251 TCL_NORMAL, TCL_SPACE, TCL_COMMAND_END, TCL_SPACE,
252 TCL_SPACE, TCL_SPACE, TCL_NORMAL, TCL_NORMAL,
253 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
254 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
255 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
256 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
257 TCL_SPACE, TCL_NORMAL, TCL_QUOTE, TCL_NORMAL,
258 TCL_DOLLAR, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
259 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
260 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
261 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
262 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
263 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_COMMAND_END,
264 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
265 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
266 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
267 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
268 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
269 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
270 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
271 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACKET,
272 TCL_BACKSLASH, TCL_COMMAND_END, TCL_NORMAL, TCL_NORMAL,
273 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
274 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
275 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
276 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
277 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
278 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
279 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_OPEN_BRACE,
280 TCL_NORMAL, TCL_CLOSE_BRACE, TCL_NORMAL, TCL_NORMAL,
281
282 /*
283 * Large unsigned character values, from 128-255:
284 */
285
286 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
287 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
288 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
289 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
290 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
291 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
292 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
293 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
294 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
295 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
296 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
297 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
298 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
299 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
300 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
301 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
302 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
303 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
304 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
305 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
306 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
307 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
308 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
309 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
310 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
311 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
312 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
313 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
314 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
315 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
316 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
317 TCL_NORMAL, TCL_NORMAL, TCL_NORMAL, TCL_NORMAL,
318};
319
320/*
321 * Table of all AuxData types.
322 */
323
324static Tcl_HashTable auxDataTypeTable;
325static int auxDataTypeTableInitialized = 0; /* 0 means not yet
326 * initialized. */
327
328/*
329 * Prototypes for procedures defined later in this file:
330 */
331
332static void AdvanceToNextWord _ANSI_ARGS_((char *string,
333 CompileEnv *envPtr));
334static int CollectArgInfo _ANSI_ARGS_((Tcl_Interp *interp,
335 char *string, char *lastChar, int flags,
336 ArgInfo *argInfoPtr));
337static int CompileBraces _ANSI_ARGS_((Tcl_Interp *interp,
338 char *string, char *lastChar, int flags,
339 CompileEnv *envPtr));
340static int CompileCmdWordInline _ANSI_ARGS_((
341 Tcl_Interp *interp, char *string,
342 char *lastChar, int flags, CompileEnv *envPtr));
343static int CompileExprWord _ANSI_ARGS_((Tcl_Interp *interp,
344 char *string, char *lastChar, int flags,
345 CompileEnv *envPtr));
346static int CompileMultipartWord _ANSI_ARGS_((
347 Tcl_Interp *interp, char *string,
348 char *lastChar, int flags, CompileEnv *envPtr));
349static int CompileWord _ANSI_ARGS_((Tcl_Interp *interp,
350 char *string, char *lastChar, int flags,
351 CompileEnv *envPtr));
352static int CreateExceptionRange _ANSI_ARGS_((
353 ExceptionRangeType type, CompileEnv *envPtr));
354static void DupByteCodeInternalRep _ANSI_ARGS_((Tcl_Obj *srcPtr,
355 Tcl_Obj *copyPtr));
356static ClientData DupForeachInfo _ANSI_ARGS_((ClientData clientData));
357static unsigned char * EncodeCmdLocMap _ANSI_ARGS_((
358 CompileEnv *envPtr, ByteCode *codePtr,
359 unsigned char *startPtr));
360static void EnterCmdExtentData _ANSI_ARGS_((
361 CompileEnv *envPtr, int cmdNumber,
362 int numSrcChars, int numCodeBytes));
363static void EnterCmdStartData _ANSI_ARGS_((
364 CompileEnv *envPtr, int cmdNumber,
365 int srcOffset, int codeOffset));
366static void ExpandObjectArray _ANSI_ARGS_((CompileEnv *envPtr));
367static void FreeForeachInfo _ANSI_ARGS_((
368 ClientData clientData));
369static void FreeByteCodeInternalRep _ANSI_ARGS_((
370 Tcl_Obj *objPtr));
371static void FreeArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
372static int GetCmdLocEncodingSize _ANSI_ARGS_((
373 CompileEnv *envPtr));
374static void InitArgInfo _ANSI_ARGS_((ArgInfo *argInfoPtr));
375static int IsLocalScalar _ANSI_ARGS_((char *name, int len));
376static int LookupCompiledLocal _ANSI_ARGS_((
377 char *name, int nameChars, int createIfNew,
378 int flagsIfCreated, Proc *procPtr));
379static int SetByteCodeFromAny _ANSI_ARGS_((Tcl_Interp *interp,
380 Tcl_Obj *objPtr));
381static void UpdateStringOfByteCode _ANSI_ARGS_((Tcl_Obj *objPtr));
382
383/*
384 * The structure below defines the bytecode Tcl object type by
385 * means of procedures that can be invoked by generic object code.
386 */
387
388Tcl_ObjType tclByteCodeType = {
389 "bytecode", /* name */
390 FreeByteCodeInternalRep, /* freeIntRepProc */
391 DupByteCodeInternalRep, /* dupIntRepProc */
392 UpdateStringOfByteCode, /* updateStringProc */
393 SetByteCodeFromAny /* setFromAnyProc */
394};
395
396/*
397 * The structures below define the AuxData types defined in this file.
398 */
399
400AuxDataType tclForeachInfoType = {
401 "ForeachInfo", /* name */
402 DupForeachInfo, /* dupProc */
403 FreeForeachInfo /* freeProc */
404};
405
406
407/*
408 *----------------------------------------------------------------------
409 *
410 * TclPrintSource --
411 *
412 * This procedure prints up to a specified number of characters from
413 * the argument string to a specified file. It tries to produce legible
414 * output by adding backslashes as necessary.
415 *
416 * Results:
417 * None.
418 *
419 * Side effects:
420 * Outputs characters to the specified file.
421 *
422 *----------------------------------------------------------------------
423 */
424
425void
426TclPrintSource(outFile, string, maxChars)
427 FILE *outFile; /* The file to print the source to. */
428 char *string; /* The string to print. */
429 int maxChars; /* Maximum number of chars to print. */
430{
431 register char *p;
432 register int i = 0;
433
434 if (string == NULL) {
435 fprintf(outFile, "\"\"");
436 return;
437 }
438
439 fprintf(outFile, "\"");
440 p = string;
441 for (; (*p != '\0') && (i < maxChars); p++, i++) {
442 switch (*p) {
443 case '"':
444 fprintf(outFile, "\\\"");
445 continue;
446 case '\f':
447 fprintf(outFile, "\\f");
448 continue;
449 case '\n':
450 fprintf(outFile, "\\n");
451 continue;
452 case '\r':
453 fprintf(outFile, "\\r");
454 continue;
455 case '\t':
456 fprintf(outFile, "\\t");
457 continue;
458 case '\v':
459 fprintf(outFile, "\\v");
460 continue;
461 default:
462 fprintf(outFile, "%c", *p);
463 continue;
464 }
465 }
466 fprintf(outFile, "\"");
467}
468
469
470/*
471 *----------------------------------------------------------------------
472 *
473 * FreeByteCodeInternalRep --
474 *
475 * Part of the bytecode Tcl object type implementation. Frees the
476 * storage associated with a bytecode object's internal representation
477 * unless its code is actively being executed.
478 *
479 * Results:
480 * None.
481 *
482 * Side effects:
483 * The bytecode object's internal rep is marked invalid and its
484 * code gets freed unless the code is actively being executed.
485 * In that case the cleanup is delayed until the last execution
486 * of the code completes.
487 *
488 *----------------------------------------------------------------------
489 */
490
491static void
492FreeByteCodeInternalRep(objPtr)
493 register Tcl_Obj *objPtr; /* Object whose internal rep to free. */
494{
495 register ByteCode *codePtr =
496 (ByteCode *) objPtr->internalRep.otherValuePtr;
497
498 codePtr->refCount--;
499 if (codePtr->refCount <= 0) {
500 TclCleanupByteCode(codePtr);
501 }
502 objPtr->typePtr = NULL;
503 objPtr->internalRep.otherValuePtr = NULL;
504}
505
506
507/*
508 *----------------------------------------------------------------------
509 *
510 * TclCleanupByteCode --
511 *
512 * This procedure does all the real work of freeing up a bytecode
513 * object's ByteCode structure. It's called only when the structure's
514 * reference count becomes zero.
515 *
516 * Results:
517 * None.
518 *
519 * Side effects:
520 * Frees objPtr's bytecode internal representation and sets
521 * its type and objPtr->internalRep.otherValuePtr NULL. Also
522 * decrements the ref counts on each object in its object array,
523 * and frees its auxiliary data items.
524 *
525 *----------------------------------------------------------------------
526 */
527
528void
529TclCleanupByteCode(codePtr)
530 ByteCode *codePtr; /* ByteCode to free. */
531{
532 Tcl_Obj **objArrayPtr = codePtr->objArrayPtr;
533 int numObjects = codePtr->numObjects;
534 int numAuxDataItems = codePtr->numAuxDataItems;
535 register AuxData *auxDataPtr;
536 register Tcl_Obj *elemPtr;
537 register int i;
538
539 /*
540 * A single heap object holds the ByteCode structure and its code,
541 * object, command location, and auxiliary data arrays. This means we
542 * only need to 1) decrement the ref counts on the objects in its
543 * object array, 2) call the free procs for the auxiliary data items,
544 * and 3) free the ByteCode structure's heap object.
545 */
546
547 for (i = 0; i < numObjects; i++) {
548 elemPtr = objArrayPtr[i];
549 TclDecrRefCount(elemPtr);
550 }
551
552 auxDataPtr = codePtr->auxDataArrayPtr;
553 for (i = 0; i < numAuxDataItems; i++) {
554 if (auxDataPtr->type->freeProc != NULL) {
555 auxDataPtr->type->freeProc(auxDataPtr->clientData);
556 }
557 auxDataPtr++;
558 }
559
560 ckfree((char *) codePtr);
561}
562
563
564/*
565 *----------------------------------------------------------------------
566 *
567 * DupByteCodeInternalRep --
568 *
569 * Part of the bytecode Tcl object type implementation. However, it
570 * does not copy the internal representation of a bytecode Tcl_Obj, but
571 * instead leaves the new object untyped (with a NULL type pointer).
572 * Code will be compiled for the new object only if necessary.
573 *
574 * Results:
575 * None.
576 *
577 * Side effects:
578 * None.
579 *
580 *----------------------------------------------------------------------
581 */
582
583static void
584DupByteCodeInternalRep(srcPtr, copyPtr)
585 Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
586 Tcl_Obj *copyPtr; /* Object with internal rep to set. */
587{
588 return;
589}
590
591
592/*
593 *-----------------------------------------------------------------------
594 *
595 * SetByteCodeFromAny --
596 *
597 * Part of the bytecode Tcl object type implementation. Attempts to
598 * generate an byte code internal form for the Tcl object "objPtr" by
599 * compiling its string representation.
600 *
601 * Results:
602 * The return value is a standard Tcl object result. If an error occurs
603 * during compilation, an error message is left in the interpreter's
604 * result unless "interp" is NULL.
605 *
606 * Side effects:
607 * Frees the old internal representation. If no error occurs, then the
608 * compiled code is stored as "objPtr"s bytecode representation.
609 * Also, if debugging, initializes the "tcl_traceCompile" Tcl variable
610 * used to trace compilations.
611 *
612 *----------------------------------------------------------------------
613 */
614
615static int
616SetByteCodeFromAny(interp, objPtr)
617 Tcl_Interp *interp; /* The interpreter for which the code is
618 * compiled. */
619 Tcl_Obj *objPtr; /* The object to convert. */
620{
621 Interp *iPtr = (Interp *) interp;
622 char *string;
623 CompileEnv compEnv; /* Compilation environment structure
624 * allocated in frame. */
625 AuxData *auxDataPtr;
626 register int i;
627 int length, result;
628
629 string = Tcl_GetStringFromObj(objPtr, &length);
630 TclInitCompileEnv(interp, &compEnv, string);
631 result = TclCompileString(interp, string, string+length,
632 iPtr->evalFlags, &compEnv);
633 if (result == TCL_OK) {
634 /*
635 * Add a "done" instruction at the end of the instruction sequence.
636 */
637
638 TclEmitOpcode(INST_DONE, &compEnv);
639
640 /*
641 * Convert the object to a ByteCode object.
642 */
643
644 TclInitByteCodeObj(objPtr, &compEnv);
645 } else {
646 /*
647 * Compilation errors. Decrement the ref counts on any objects in
648 * the object array and free any aux data items prior to freeing
649 * the compilation environment.
650 */
651
652 for (i = 0; i < compEnv.objArrayNext; i++) {
653 Tcl_Obj *elemPtr = compEnv.objArrayPtr[i];
654 Tcl_DecrRefCount(elemPtr);
655 }
656
657 auxDataPtr = compEnv.auxDataArrayPtr;
658 for (i = 0; i < compEnv.auxDataArrayNext; i++) {
659 if (auxDataPtr->type->freeProc != NULL) {
660 auxDataPtr->type->freeProc(auxDataPtr->clientData);
661 }
662 auxDataPtr++;
663 }
664 }
665 TclFreeCompileEnv(&compEnv);
666
667 return result;
668}
669
670
671/*
672 *----------------------------------------------------------------------
673 *
674 * UpdateStringOfByteCode --
675 *
676 * Part of the bytecode Tcl object type implementation. Called to
677 * update the string representation for a byte code object.
678 * Note: This procedure does not free an existing old string rep
679 * so storage will be lost if this has not already been done.
680 *
681 * Results:
682 * None.
683 *
684 * Side effects:
685 * Generates a panic.
686 *
687 *----------------------------------------------------------------------
688 */
689
690static void
691UpdateStringOfByteCode(objPtr)
692 register Tcl_Obj *objPtr; /* ByteCode object with string rep that
693 * needs updating. */
694{
695 /*
696 * This procedure is never invoked since the internal representation of
697 * a bytecode object is never modified.
698 */
699
700 panic("UpdateStringOfByteCode should never be called.");
701}
702
703
704/*
705 *----------------------------------------------------------------------
706 *
707 * TclInitCompileEnv --
708 *
709 * Initializes a CompileEnv compilation environment structure for the
710 * compilation of a string in an interpreter.
711 *
712 * Results:
713 * None.
714 *
715 * Side effects:
716 * The CompileEnv structure is initialized.
717 *
718 *----------------------------------------------------------------------
719 */
720
721void
722TclInitCompileEnv(interp, envPtr, string)
723 Tcl_Interp *interp; /* The interpreter for which a CompileEnv
724 * structure is initialized. */
725 register CompileEnv *envPtr; /* Points to the CompileEnv structure to
726 * initialize. */
727 char *string; /* The source string to be compiled. */
728{
729 Interp *iPtr = (Interp *) interp;
730
731 envPtr->iPtr = iPtr;
732 envPtr->source = string;
733 envPtr->procPtr = iPtr->compiledProcPtr;
734 envPtr->numCommands = 0;
735 envPtr->excRangeDepth = 0;
736 envPtr->maxExcRangeDepth = 0;
737 envPtr->maxStackDepth = 0;
738 Tcl_InitHashTable(&(envPtr->objTable), TCL_STRING_KEYS);
739 envPtr->pushSimpleWords = 1;
740 envPtr->wordIsSimple = 0;
741 envPtr->numSimpleWordChars = 0;
742 envPtr->exprIsJustVarRef = 0;
743 envPtr->exprIsComparison = 0;
744 envPtr->termOffset = 0;
745
746 envPtr->codeStart = envPtr->staticCodeSpace;
747 envPtr->codeNext = envPtr->codeStart;
748 envPtr->codeEnd = (envPtr->codeStart + COMPILEENV_INIT_CODE_BYTES);
749 envPtr->mallocedCodeArray = 0;
750
751 envPtr->objArrayPtr = envPtr->staticObjArraySpace;
752 envPtr->objArrayNext = 0;
753 envPtr->objArrayEnd = COMPILEENV_INIT_NUM_OBJECTS;
754 envPtr->mallocedObjArray = 0;
755
756 envPtr->excRangeArrayPtr = envPtr->staticExcRangeArraySpace;
757 envPtr->excRangeArrayNext = 0;
758 envPtr->excRangeArrayEnd = COMPILEENV_INIT_EXCEPT_RANGES;
759 envPtr->mallocedExcRangeArray = 0;
760
761 envPtr->cmdMapPtr = envPtr->staticCmdMapSpace;
762 envPtr->cmdMapEnd = COMPILEENV_INIT_CMD_MAP_SIZE;
763 envPtr->mallocedCmdMap = 0;
764
765 envPtr->auxDataArrayPtr = envPtr->staticAuxDataArraySpace;
766 envPtr->auxDataArrayNext = 0;
767 envPtr->auxDataArrayEnd = COMPILEENV_INIT_AUX_DATA_SIZE;
768 envPtr->mallocedAuxDataArray = 0;
769}
770
771
772/*
773 *----------------------------------------------------------------------
774 *
775 * TclFreeCompileEnv --
776 *
777 * Free the storage allocated in a CompileEnv compilation environment
778 * structure.
779 *
780 * Results:
781 * None.
782 *
783 * Side effects:
784 * Allocated storage in the CompileEnv structure is freed. Note that
785 * ref counts for Tcl objects in its object table are not decremented.
786 * In addition, any storage referenced by any auxiliary data items
787 * in the CompileEnv structure are not freed either. The expectation
788 * is that when compilation is successful, "ownership" (i.e., the
789 * pointers to) these objects and aux data items will just be handed
790 * over to the corresponding ByteCode structure.
791 *
792 *----------------------------------------------------------------------
793 */
794
795void
796TclFreeCompileEnv(envPtr)
797 register CompileEnv *envPtr; /* Points to the CompileEnv structure. */
798{
799 Tcl_DeleteHashTable(&(envPtr->objTable));
800 if (envPtr->mallocedCodeArray) {
801 ckfree((char *) envPtr->codeStart);
802 }
803 if (envPtr->mallocedObjArray) {
804 ckfree((char *) envPtr->objArrayPtr);
805 }
806 if (envPtr->mallocedExcRangeArray) {
807 ckfree((char *) envPtr->excRangeArrayPtr);
808 }
809 if (envPtr->mallocedCmdMap) {
810 ckfree((char *) envPtr->cmdMapPtr);
811 }
812 if (envPtr->mallocedAuxDataArray) {
813 ckfree((char *) envPtr->auxDataArrayPtr);
814 }
815}
816
817
818/*
819 *----------------------------------------------------------------------
820 *
821 * TclInitByteCodeObj --
822 *
823 * Create a ByteCode structure and initialize it from a CompileEnv
824 * compilation environment structure. The ByteCode structure is
825 * smaller and contains just that information needed to execute
826 * the bytecode instructions resulting from compiling a Tcl script.
827 * The resulting structure is placed in the specified object.
828 *
829 * Results:
830 * A newly constructed ByteCode object is stored in the internal
831 * representation of the objPtr.
832 *
833 * Side effects:
834 * A single heap object is allocated to hold the new ByteCode structure
835 * and its code, object, command location, and aux data arrays. Note
836 * that "ownership" (i.e., the pointers to) the Tcl objects and aux
837 * data items will be handed over to the new ByteCode structure from
838 * the CompileEnv structure.
839 *
840 *----------------------------------------------------------------------
841 */
842
843void
844TclInitByteCodeObj(objPtr, envPtr)
845 Tcl_Obj *objPtr; /* Points object that should be
846 * initialized, and whose string rep
847 * contains the source code. */
848 register CompileEnv *envPtr; /* Points to the CompileEnv structure from
849 * which to create a ByteCode structure. */
850{
851 register ByteCode *codePtr;
852 size_t codeBytes, objArrayBytes, exceptArrayBytes, cmdLocBytes;
853 size_t auxDataArrayBytes;
854 register size_t size, objBytes, totalSize;
855 register unsigned char *p;
856 unsigned char *nextPtr;
857 int srcLen = envPtr->termOffset;
858 int numObjects, i;
859 Namespace *namespacePtr;
860
861 codeBytes = (envPtr->codeNext - envPtr->codeStart);
862 numObjects = envPtr->objArrayNext;
863 objArrayBytes = (envPtr->objArrayNext * sizeof(Tcl_Obj *));
864 exceptArrayBytes = (envPtr->excRangeArrayNext * sizeof(ExceptionRange));
865 auxDataArrayBytes = (envPtr->auxDataArrayNext * sizeof(AuxData));
866 cmdLocBytes = GetCmdLocEncodingSize(envPtr);
867
868 size = sizeof(ByteCode);
869 size += TCL_ALIGN(codeBytes); /* align object array */
870 size += TCL_ALIGN(objArrayBytes); /* align exception range array */
871 size += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
872 size += auxDataArrayBytes;
873 size += cmdLocBytes;
874
875 /*
876 * Compute the total number of bytes needed for this bytecode
877 * including the storage for the Tcl objects in its object array.
878 */
879
880 objBytes = (numObjects * sizeof(Tcl_Obj));
881 for (i = 0; i < numObjects; i++) {
882 Tcl_Obj *litObjPtr = envPtr->objArrayPtr[i];
883 if (litObjPtr->bytes != NULL) {
884 objBytes += litObjPtr->length;
885 }
886 }
887 totalSize = (size + objBytes);
888
889 if (envPtr->iPtr->varFramePtr != NULL) {
890 namespacePtr = envPtr->iPtr->varFramePtr->nsPtr;
891 } else {
892 namespacePtr = envPtr->iPtr->globalNsPtr;
893 }
894
895 p = (unsigned char *) ckalloc(size);
896 codePtr = (ByteCode *) p;
897 codePtr->iPtr = envPtr->iPtr;
898 codePtr->compileEpoch = envPtr->iPtr->compileEpoch;
899 codePtr->nsPtr = namespacePtr;
900 codePtr->nsEpoch = namespacePtr->resolverEpoch;
901 codePtr->refCount = 1;
902 codePtr->flags = 0;
903 codePtr->source = envPtr->source;
904 codePtr->procPtr = envPtr->procPtr;
905 codePtr->totalSize = totalSize;
906 codePtr->numCommands = envPtr->numCommands;
907 codePtr->numSrcChars = srcLen;
908 codePtr->numCodeBytes = codeBytes;
909 codePtr->numObjects = numObjects;
910 codePtr->numExcRanges = envPtr->excRangeArrayNext;
911 codePtr->numAuxDataItems = envPtr->auxDataArrayNext;
912 codePtr->auxDataArrayPtr = NULL;
913 codePtr->numCmdLocBytes = cmdLocBytes;
914 codePtr->maxExcRangeDepth = envPtr->maxExcRangeDepth;
915 codePtr->maxStackDepth = envPtr->maxStackDepth;
916
917 p += sizeof(ByteCode);
918 codePtr->codeStart = p;
919 memcpy((VOID *) p, (VOID *) envPtr->codeStart, codeBytes);
920
921 p += TCL_ALIGN(codeBytes); /* align object array */
922 codePtr->objArrayPtr = (Tcl_Obj **) p;
923 memcpy((VOID *) p, (VOID *) envPtr->objArrayPtr, objArrayBytes);
924
925 p += TCL_ALIGN(objArrayBytes); /* align exception range array */
926 if (exceptArrayBytes > 0) {
927 codePtr->excRangeArrayPtr = (ExceptionRange *) p;
928 memcpy((VOID *) p, (VOID *) envPtr->excRangeArrayPtr,
929 exceptArrayBytes);
930 }
931
932 p += TCL_ALIGN(exceptArrayBytes); /* align AuxData array */
933 if (auxDataArrayBytes > 0) {
934 codePtr->auxDataArrayPtr = (AuxData *) p;
935 memcpy((VOID *) p, (VOID *) envPtr->auxDataArrayPtr,
936 auxDataArrayBytes);
937 }
938
939 p += auxDataArrayBytes;
940 nextPtr = EncodeCmdLocMap(envPtr, codePtr, (unsigned char *) p);
941 if (((size_t)(nextPtr - p)) != cmdLocBytes) {
942 panic("TclInitByteCodeObj: encoded cmd location bytes %d != expected size %d\n", (nextPtr - p), cmdLocBytes);
943 }
944
945 /*
946 * Free the old internal rep then convert the object to a
947 * bytecode object by making its internal rep point to the just
948 * compiled ByteCode.
949 */
950
951 if ((objPtr->typePtr != NULL) &&
952 (objPtr->typePtr->freeIntRepProc != NULL)) {
953 objPtr->typePtr->freeIntRepProc(objPtr);
954 }
955 objPtr->internalRep.otherValuePtr = (VOID *) codePtr;
956 objPtr->typePtr = &tclByteCodeType;
957}
958
959
960/*
961 *----------------------------------------------------------------------
962 *
963 * GetCmdLocEncodingSize --
964 *
965 * Computes the total number of bytes needed to encode the command
966 * location information for some compiled code.
967 *
968 * Results:
969 * The byte count needed to encode the compiled location information.
970 *
971 * Side effects:
972 * None.
973 *
974 *----------------------------------------------------------------------
975 */
976
977static int
978GetCmdLocEncodingSize(envPtr)
979 CompileEnv *envPtr; /* Points to compilation environment
980 * structure containing the CmdLocation
981 * structure to encode. */
982{
983 register CmdLocation *mapPtr = envPtr->cmdMapPtr;
984 int numCmds = envPtr->numCommands;
985 int codeDelta, codeLen, srcDelta, srcLen;
986 int codeDeltaNext, codeLengthNext, srcDeltaNext, srcLengthNext;
987 /* The offsets in their respective byte
988 * sequences where the next encoded offset
989 * or length should go. */
990 int prevCodeOffset, prevSrcOffset, i;
991
992 codeDeltaNext = codeLengthNext = srcDeltaNext = srcLengthNext = 0;
993 prevCodeOffset = prevSrcOffset = 0;
994 for (i = 0; i < numCmds; i++) {
995 codeDelta = (mapPtr[i].codeOffset - prevCodeOffset);
996 if (codeDelta < 0) {
997 panic("GetCmdLocEncodingSize: bad code offset");
998 } else if (codeDelta <= 127) {
999 codeDeltaNext++;
1000 } else {
1001 codeDeltaNext += 5; /* 1 byte for 0xFF, 4 for positive delta */
1002 }
1003 prevCodeOffset = mapPtr[i].codeOffset;
1004
1005 codeLen = mapPtr[i].numCodeBytes;
1006 if (codeLen < 0) {
1007 panic("GetCmdLocEncodingSize: bad code length");
1008 } else if (codeLen <= 127) {
1009 codeLengthNext++;
1010 } else {
1011 codeLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
1012 }
1013
1014 srcDelta = (mapPtr[i].srcOffset - prevSrcOffset);
1015 if ((-127 <= srcDelta) && (srcDelta <= 127)) {
1016 srcDeltaNext++;
1017 } else {
1018 srcDeltaNext += 5; /* 1 byte for 0xFF, 4 for delta */
1019 }
1020 prevSrcOffset = mapPtr[i].srcOffset;
1021
1022 srcLen = mapPtr[i].numSrcChars;
1023 if (srcLen < 0) {
1024 panic("GetCmdLocEncodingSize: bad source length");
1025 } else if (srcLen <= 127) {
1026 srcLengthNext++;
1027 } else {
1028 srcLengthNext += 5; /* 1 byte for 0xFF, 4 for length */
1029 }
1030 }
1031
1032 return (codeDeltaNext + codeLengthNext + srcDeltaNext + srcLengthNext);
1033}
1034
1035
1036/*
1037 *----------------------------------------------------------------------
1038 *
1039 * EncodeCmdLocMap --
1040 *
1041 * Encode the command location information for some compiled code into
1042 * a ByteCode structure. The encoded command location map is stored as
1043 * three adjacent byte sequences.
1044 *
1045 * Results:
1046 * Pointer to the first byte after the encoded command location
1047 * information.
1048 *
1049 * Side effects:
1050 * The encoded information is stored into the block of memory headed
1051 * by codePtr. Also records pointers to the start of the four byte
1052 * sequences in fields in codePtr's ByteCode header structure.
1053 *
1054 *----------------------------------------------------------------------
1055 */
1056
1057static unsigned char *
1058EncodeCmdLocMap(envPtr, codePtr, startPtr)
1059 CompileEnv *envPtr; /* Points to compilation environment
1060 * structure containing the CmdLocation
1061 * structure to encode. */
1062 ByteCode *codePtr; /* ByteCode in which to encode envPtr's
1063 * command location information. */
1064 unsigned char *startPtr; /* Points to the first byte in codePtr's
1065 * memory block where the location
1066 * information is to be stored. */
1067{
1068 register CmdLocation *mapPtr = envPtr->cmdMapPtr;
1069 int numCmds = envPtr->numCommands;
1070 register unsigned char *p = startPtr;
1071 int codeDelta, codeLen, srcDelta, srcLen, prevOffset;
1072 register int i;
1073
1074 /*
1075 * Encode the code offset for each command as a sequence of deltas.
1076 */
1077
1078 codePtr->codeDeltaStart = p;
1079 prevOffset = 0;
1080 for (i = 0; i < numCmds; i++) {
1081 codeDelta = (mapPtr[i].codeOffset - prevOffset);
1082 if (codeDelta < 0) {
1083 panic("EncodeCmdLocMap: bad code offset");
1084 } else if (codeDelta <= 127) {
1085 TclStoreInt1AtPtr(codeDelta, p);
1086 p++;
1087 } else {
1088 TclStoreInt1AtPtr(0xFF, p);
1089 p++;
1090 TclStoreInt4AtPtr(codeDelta, p);
1091 p += 4;
1092 }
1093 prevOffset = mapPtr[i].codeOffset;
1094 }
1095
1096 /*
1097 * Encode the code length for each command.
1098 */
1099
1100 codePtr->codeLengthStart = p;
1101 for (i = 0; i < numCmds; i++) {
1102 codeLen = mapPtr[i].numCodeBytes;
1103 if (codeLen < 0) {
1104 panic("EncodeCmdLocMap: bad code length");
1105 } else if (codeLen <= 127) {
1106 TclStoreInt1AtPtr(codeLen, p);
1107 p++;
1108 } else {
1109 TclStoreInt1AtPtr(0xFF, p);
1110 p++;
1111 TclStoreInt4AtPtr(codeLen, p);
1112 p += 4;
1113 }
1114 }
1115
1116 /*
1117 * Encode the source offset for each command as a sequence of deltas.
1118 */
1119
1120 codePtr->srcDeltaStart = p;
1121 prevOffset = 0;
1122 for (i = 0; i < numCmds; i++) {
1123 srcDelta = (mapPtr[i].srcOffset - prevOffset);
1124 if ((-127 <= srcDelta) && (srcDelta <= 127)) {
1125 TclStoreInt1AtPtr(srcDelta, p);
1126 p++;
1127 } else {
1128 TclStoreInt1AtPtr(0xFF, p);
1129 p++;
1130 TclStoreInt4AtPtr(srcDelta, p);
1131 p += 4;
1132 }
1133 prevOffset = mapPtr[i].srcOffset;
1134 }
1135
1136 /*
1137 * Encode the source length for each command.
1138 */
1139
1140 codePtr->srcLengthStart = p;
1141 for (i = 0; i < numCmds; i++) {
1142 srcLen = mapPtr[i].numSrcChars;
1143 if (srcLen < 0) {
1144 panic("EncodeCmdLocMap: bad source length");
1145 } else if (srcLen <= 127) {
1146 TclStoreInt1AtPtr(srcLen, p);
1147 p++;
1148 } else {
1149 TclStoreInt1AtPtr(0xFF, p);
1150 p++;
1151 TclStoreInt4AtPtr(srcLen, p);
1152 p += 4;
1153 }
1154 }
1155
1156 return p;
1157}
1158
1159
1160/*
1161 *----------------------------------------------------------------------
1162 *
1163 * TclCompileString --
1164 *
1165 * Compile a Tcl script in a null-terminated binary string.
1166 *
1167 * Results:
1168 * The return value is TCL_OK on a successful compilation and TCL_ERROR
1169 * on failure. If TCL_ERROR is returned, then the interpreter's result
1170 * contains an error message.
1171 *
1172 * envPtr->termOffset and interp->termOffset are filled in with the
1173 * offset of the character in the string just after the last one
1174 * successfully processed; this might be the offset of the ']' (if
1175 * flags & TCL_BRACKET_TERM), or the offset of the '\0' at the end of
1176 * the string. Also updates envPtr->maxStackDepth with the maximum
1177 * number of stack elements needed to execute the string's commands.
1178 *
1179 * Side effects:
1180 * Adds instructions to envPtr to evaluate the string at runtime.
1181 *
1182 *----------------------------------------------------------------------
1183 */
1184
1185int
1186TclCompileString(interp, string, lastChar, flags, envPtr)
1187 Tcl_Interp *interp; /* Used for error reporting. */
1188 char *string; /* The source string to compile. */
1189 char *lastChar; /* Pointer to terminating character of
1190 * string. */
1191 int flags; /* Flags to control compilation (same as
1192 * passed to Tcl_Eval). */
1193 CompileEnv *envPtr; /* Holds resulting instructions. */
1194{
1195 Interp *iPtr = (Interp *) interp;
1196 register char *src = string;/* Points to current source char. */
1197 register char c = *src; /* The current char. */
1198 register int type; /* Current char's CHAR_TYPE type. */
1199 char termChar = (char)((flags & TCL_BRACKET_TERM)? ']' : '\0');
1200 /* Return when this character is found
1201 * (either ']' or '\0'). Zero means newlines
1202 * terminate cmds. */
1203 int isFirstCmd = 1; /* 1 if compiling the first cmd. */
1204 char *cmdSrcStart = NULL; /* Points to first non-blank char in each
1205 * command. Initialized to avoid compiler
1206 * warning. */
1207 int cmdIndex; /* The index of the current command in the
1208 * compilation environment's command
1209 * location table. */
1210 int lastTopLevelCmdIndex = -1;
1211 /* Index of most recent toplevel command in
1212 * the command location table. Initialized
1213 * to avoid compiler warning. */
1214 int cmdCodeOffset = -1; /* Offset of first byte of current command's
1215 * code. Initialized to avoid compiler
1216 * warning. */
1217 int cmdWords; /* Number of words in current command. */
1218 Tcl_Command cmd; /* Used to search for commands. */
1219 Command *cmdPtr; /* Points to command's Command structure if
1220 * first word is simple and command was
1221 * found; else NULL. */
1222 int maxDepth = 0; /* Maximum number of stack elements needed
1223 * to execute all cmds. */
1224 char *termPtr; /* Points to char that terminated word. */
1225 char savedChar; /* Holds the character from string
1226 * termporarily replaced by a null character
1227 * during processing of words. */
1228 int objIndex = -1; /* The object array index for a pushed
1229 * object holding a word or word part
1230 * Initialized to avoid compiler warning. */
1231 unsigned char *entryCodeNext = envPtr->codeNext;
1232 /* Value of envPtr's current instruction
1233 * pointer at entry. Used to tell if any
1234 * instructions generated. */
1235 char *ellipsis = ""; /* Used to set errorInfo variable; "..."
1236 * indicates that not all of offending
1237 * command is included in errorInfo. ""
1238 * means that the command is all there. */
1239 Tcl_Obj *objPtr;
1240 int numChars;
1241 int result = TCL_OK;
1242 int savePushSimpleWords = envPtr->pushSimpleWords;
1243
1244 /*
1245 * commands: command {(';' | '\n') command}
1246 */
1247
1248 while ((src != lastChar) && (c != termChar)) {
1249 /*
1250 * Skip white space, semicolons, backslash-newlines (treated as
1251 * spaces), and comments before command.
1252 */
1253
1254 type = CHAR_TYPE(src, lastChar);
1255 while ((type & (TCL_SPACE | TCL_BACKSLASH))
1256 || (c == '\n') || (c == ';')) {
1257 if (type == TCL_BACKSLASH) {
1258 if (src[1] == '\n') {
1259 src += 2;
1260 } else {
1261 break;
1262 }
1263 } else {
1264 src++;
1265 }
1266 c = *src;
1267 type = CHAR_TYPE(src, lastChar);
1268 }
1269
1270 if (c == '#') {
1271 while (src != lastChar) {
1272 if (c == '\\') {
1273 int numRead;
1274 Tcl_Backslash(src, &numRead);
1275 src += numRead;
1276 } else if (c == '\n') {
1277 src++;
1278 c = *src;
1279 envPtr->termOffset = (src - string);
1280 break;
1281 } else {
1282 src++;
1283 }
1284 c = *src;
1285 }
1286 continue; /* end of comment, restart outer command loop */
1287 }
1288
1289 /*
1290 * Compile one command: zero or more words terminated by a '\n',
1291 * ';', ']' (if command is terminated by close bracket), or
1292 * the end of string.
1293 *
1294 * command: word*
1295 */
1296
1297 type = CHAR_TYPE(src, lastChar);
1298 if ((type == TCL_COMMAND_END)
1299 && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
1300 continue; /* empty command; restart outer cmd loop */
1301 }
1302
1303 /*
1304 * If not the first command, discard the previous command's result.
1305 */
1306
1307 if (!isFirstCmd) {
1308 TclEmitOpcode(INST_POP, envPtr);
1309 if (!(flags & TCL_BRACKET_TERM)) {
1310 /*
1311 * We are compiling a top level command. Update the number
1312 * of code bytes for the last command to account for the pop
1313 * instruction.
1314 */
1315
1316 (envPtr->cmdMapPtr[lastTopLevelCmdIndex]).numCodeBytes =
1317 (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset;
1318 }
1319 }
1320
1321 /*
1322 * Compile the words of the command. Process the first word
1323 * specially, since it is the name of a command. If it is a "simple"
1324 * string (just a sequence of characters), look it up in the table
1325 * of compilation procedures. If a word other than the first is
1326 * simple and represents an integer whose formatted representation
1327 * is the same as the word, just push an integer object. Also record
1328 * starting source and object information for the command.
1329 */
1330
1331 envPtr->numCommands++;
1332 cmdIndex = (envPtr->numCommands - 1);
1333 if (!(flags & TCL_BRACKET_TERM)) {
1334 lastTopLevelCmdIndex = cmdIndex;
1335 }
1336
1337 cmdSrcStart = src;
1338 cmdCodeOffset = (envPtr->codeNext - envPtr->codeStart);
1339 cmdWords = 0;
1340 EnterCmdStartData(envPtr, cmdIndex, src-envPtr->source,
1341 cmdCodeOffset);
1342
1343 while ((type != TCL_COMMAND_END)
1344 || ((c == ']') && !(flags & TCL_BRACKET_TERM))) {
1345 /*
1346 * Skip any leading white space at the start of a word. Note
1347 * that a backslash-newline is treated as a space.
1348 */
1349
1350 while (type & (TCL_SPACE | TCL_BACKSLASH)) {
1351 if (type == TCL_BACKSLASH) {
1352 if (src[1] == '\n') {
1353 src += 2;
1354 } else {
1355 break;
1356 }
1357 } else {
1358 src++;
1359 }
1360 c = *src;
1361 type = CHAR_TYPE(src, lastChar);
1362 }
1363 if ((type == TCL_COMMAND_END)
1364 && ((c != ']') || (flags & TCL_BRACKET_TERM))) {
1365 break; /* no words remain for command. */
1366 }
1367
1368 /*
1369 * Compile one word. We use an inline version of CompileWord to
1370 * avoid an extra procedure call.
1371 */
1372
1373 envPtr->pushSimpleWords = 0;
1374 if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
1375 src++;
1376 if (type == TCL_QUOTE) {
1377 result = TclCompileQuotes(interp, src, lastChar,
1378 '"', flags, envPtr);
1379 } else {
1380 result = CompileBraces(interp, src, lastChar,
1381 flags, envPtr);
1382 }
1383 termPtr = (src + envPtr->termOffset);
1384 if (result != TCL_OK) {
1385 src = termPtr;
1386 goto done;
1387 }
1388
1389 /*
1390 * Make sure terminating character of the quoted or braced
1391 * string is the end of word.
1392 */
1393
1394 c = *termPtr;
1395 if ((c == '\\') && (*(termPtr+1) == '\n')) {
1396 /*
1397 * Line is continued on next line; the backslash-
1398 * newline turns into space, which terminates the word.
1399 */
1400 } else {
1401 type = CHAR_TYPE(termPtr, lastChar);
1402 if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
1403 Tcl_ResetResult(interp);
1404 if (*(src-1) == '"') {
1405 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1406 "extra characters after close-quote", -1);
1407 } else {
1408 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1409 "extra characters after close-brace", -1);
1410 }
1411 result = TCL_ERROR;
1412 }
1413 }
1414 } else {
1415 result = CompileMultipartWord(interp, src, lastChar,
1416 flags, envPtr);
1417 termPtr = (src + envPtr->termOffset);
1418 }
1419 if (result != TCL_OK) {
1420 ellipsis = "...";
1421 src = termPtr;
1422 goto done;
1423 }
1424
1425 if (envPtr->wordIsSimple) {
1426 /*
1427 * A simple word. Temporarily replace the terminating
1428 * character with a null character.
1429 */
1430
1431 numChars = envPtr->numSimpleWordChars;
1432 savedChar = src[numChars];
1433 src[numChars] = '\0';
1434
1435 if ((cmdWords == 0)
1436 && (!(iPtr->flags & DONT_COMPILE_CMDS_INLINE))) {
1437 /*
1438 * The first word of a command and inline command
1439 * compilation has not been disabled (e.g., by command
1440 * traces). Look up the first word in the interpreter's
1441 * hashtable of commands. If a compilation procedure is
1442 * found, let it compile the command after resetting
1443 * error logging information. Note that if we are
1444 * compiling a procedure, we must look up the command
1445 * in the procedure's namespace and not the current
1446 * namespace.
1447 */
1448
1449 Namespace *cmdNsPtr;
1450
1451 if (envPtr->procPtr != NULL) {
1452 cmdNsPtr = envPtr->procPtr->cmdPtr->nsPtr;
1453 } else {
1454 cmdNsPtr = NULL;
1455 }
1456
1457 cmdPtr = NULL;
1458 cmd = Tcl_FindCommand(interp, src,
1459 (Tcl_Namespace *) cmdNsPtr, /*flags*/ 0);
1460 if (cmd != (Tcl_Command) NULL) {
1461 cmdPtr = (Command *) cmd;
1462 }
1463 if ((cmdPtr != NULL) && (cmdPtr->compileProc != NULL)) {
1464 char *firstArg = termPtr;
1465 src[numChars] = savedChar;
1466 iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
1467 | ERROR_CODE_SET);
1468 result = (*(cmdPtr->compileProc))(interp,
1469 firstArg, lastChar, flags, envPtr);
1470 if (result == TCL_OK) {
1471 src = (firstArg + envPtr->termOffset);
1472 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
1473 goto finishCommand;
1474 } else if (result == TCL_OUT_LINE_COMPILE) {
1475 result = TCL_OK;
1476 src[numChars] = '\0';
1477 } else {
1478 src = firstArg;
1479 goto done; /* an error */
1480 }
1481 }
1482
1483 /*
1484 * No compile procedure was found for the command: push
1485 * the word and continue to compile the remaining
1486 * words. If a hashtable entry was found for the
1487 * command, push a CmdName object instead to avoid
1488 * runtime lookups. If necessary, convert the pushed
1489 * object to be a CmdName object. If this is the first
1490 * CmdName object in this code unit that refers to the
1491 * command, increment the reference count in the
1492 * Command structure to reflect the new reference from
1493 * the CmdName object and, if the command is deleted
1494 * later, to keep the Command structure from being freed
1495 * until TclExecuteByteCode has a chance to recognize
1496 * that the command was deleted.
1497 */
1498
1499 objIndex = TclObjIndexForString(src, numChars,
1500 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
1501 if (cmdPtr != NULL) {
1502 objPtr = envPtr->objArrayPtr[objIndex];
1503 if ((objPtr->typePtr != &tclCmdNameType)
1504 && (objPtr->bytes != NULL)) {
1505 ResolvedCmdName *resPtr = (ResolvedCmdName *)
1506 ckalloc(sizeof(ResolvedCmdName));
1507 Namespace *nsPtr = (Namespace *)
1508 Tcl_GetCurrentNamespace(interp);
1509
1510 resPtr->cmdPtr = cmdPtr;
1511 resPtr->refNsPtr = nsPtr;
1512 resPtr->refNsId = nsPtr->nsId;
1513 resPtr->refNsCmdEpoch = nsPtr->cmdRefEpoch;
1514 resPtr->cmdEpoch = cmdPtr->cmdEpoch;
1515 resPtr->refCount = 1;
1516 objPtr->internalRep.twoPtrValue.ptr1 =
1517 (VOID *) resPtr;
1518 objPtr->internalRep.twoPtrValue.ptr2 = NULL;
1519 objPtr->typePtr = &tclCmdNameType;
1520 cmdPtr->refCount++;
1521 }
1522 }
1523 } else {
1524 /*
1525 * See if the word represents an integer whose formatted
1526 * representation is the same as the word (e.g., this is
1527 * true for 123 and -1 but not for 00005). If so, just
1528 * push an integer object.
1529 */
1530
1531 int isCompilableInt = 0;
1532 long n;
1533 char buf[40];
1534
1535 if (TclLooksLikeInt(src)) {
1536 int code = TclGetLong(interp, src, &n);
1537 if (code == TCL_OK) {
1538 TclFormatInt(buf, n);
1539 if (strcmp(src, buf) == 0) {
1540 isCompilableInt = 1;
1541 objIndex = TclObjIndexForString(src,
1542 numChars, /*allocStrRep*/ 0,
1543 /*inHeap*/ 0, envPtr);
1544 objPtr = envPtr->objArrayPtr[objIndex];
1545
1546 Tcl_InvalidateStringRep(objPtr);
1547 objPtr->internalRep.longValue = n;
1548 objPtr->typePtr = &tclIntType;
1549 }
1550 } else {
1551 Tcl_ResetResult(interp);
1552 }
1553 }
1554 if (!isCompilableInt) {
1555 objIndex = TclObjIndexForString(src, numChars,
1556 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
1557 }
1558 }
1559 src[numChars] = savedChar;
1560 TclEmitPush(objIndex, envPtr);
1561 maxDepth = TclMax((cmdWords + 1), maxDepth);
1562 } else { /* not a simple word */
1563 maxDepth = TclMax((cmdWords + envPtr->maxStackDepth),
1564 maxDepth);
1565 }
1566 src = termPtr;
1567 c = *src;
1568 type = CHAR_TYPE(src, lastChar);
1569 cmdWords++;
1570 }
1571
1572 /*
1573 * Emit an invoke instruction for the command. If a compile command
1574 * was found for the command we called it and skipped this.
1575 */
1576
1577 if (cmdWords > 0) {
1578 if (cmdWords <= 255) {
1579 TclEmitInstUInt1(INST_INVOKE_STK1, cmdWords, envPtr);
1580 } else {
1581 TclEmitInstUInt4(INST_INVOKE_STK4, cmdWords, envPtr);
1582 }
1583 }
1584
1585 /*
1586 * Update the compilation environment structure. Record
1587 * source/object information for the command.
1588 */
1589
1590 finishCommand:
1591 EnterCmdExtentData(envPtr, cmdIndex, src-cmdSrcStart,
1592 (envPtr->codeNext-envPtr->codeStart) - cmdCodeOffset);
1593
1594 isFirstCmd = 0;
1595 envPtr->termOffset = (src - string);
1596 c = *src;
1597 }
1598
1599 done:
1600 if (result == TCL_OK) {
1601 /*
1602 * If the source string yielded no instructions (e.g., if it was
1603 * empty), push an empty string object as the command's result.
1604 */
1605
1606 if (entryCodeNext == envPtr->codeNext) {
1607 int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
1608 /*inHeap*/ 0, envPtr);
1609 TclEmitPush(objIndex, envPtr);
1610 maxDepth = 1;
1611 }
1612 } else {
1613 /*
1614 * Add additional error information. First compute the line number
1615 * where the error occurred.
1616 */
1617
1618 register char *p;
1619 int numChars;
1620 char buf[200];
1621
1622 iPtr->errorLine = 1;
1623 for (p = string; p != cmdSrcStart; p++) {
1624 if (*p == '\n') {
1625 iPtr->errorLine++;
1626 }
1627 }
1628 for ( ; isspace(UCHAR(*p)) || (*p == ';'); p++) {
1629 if (*p == '\n') {
1630 iPtr->errorLine++;
1631 }
1632 }
1633
1634 /*
1635 * Figure out how much of the command to print (up to a certain
1636 * number of characters, or up to the end of the command).
1637 */
1638
1639 p = cmdSrcStart;
1640 while ((CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)
1641 || ((*p == ']') && !(flags & TCL_BRACKET_TERM))) {
1642 p++;
1643 }
1644 numChars = (p - cmdSrcStart);
1645 if (numChars > 150) {
1646 numChars = 150;
1647 ellipsis = " ...";
1648 } else if ((numChars >= 2) && (*p == '\n') && (*(p-1) == '{')) {
1649 ellipsis = " ...";
1650 }
1651
1652 sprintf(buf, "\n while compiling\n\"%.*s%s\"",
1653 numChars, cmdSrcStart, ellipsis);
1654 Tcl_AddObjErrorInfo(interp, buf, -1);
1655 }
1656
1657 envPtr->termOffset = (src - string);
1658 iPtr->termOffset = envPtr->termOffset;
1659 envPtr->maxStackDepth = maxDepth;
1660 envPtr->pushSimpleWords = savePushSimpleWords;
1661 return result;
1662}
1663
1664
1665/*
1666 *----------------------------------------------------------------------
1667 *
1668 * CompileWord --
1669 *
1670 * This procedure compiles one word from a command string. It skips
1671 * any leading white space.
1672 *
1673 * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
1674 * procedure emits push and other instructions to compute the
1675 * word on the Tcl evaluation stack at execution time. If a caller sets
1676 * envPtr->pushSimpleWords to 0, CompileWord will _not_ compile
1677 * "simple" words: words that are just a sequence of characters without
1678 * backslashes. It will leave their compilation up to the caller.
1679 *
1680 * As an important special case, if the word is simple, this procedure
1681 * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
1682 * number of characters in the simple word. This allows the caller to
1683 * process these words specially.
1684 *
1685 * Results:
1686 * The return value is a standard Tcl result. If an error occurs, an
1687 * error message is left in the interpreter's result.
1688 *
1689 * envPtr->termOffset is filled in with the offset of the character in
1690 * "string" just after the last one successfully processed in the last
1691 * word. This is normally the character just after the last one in a
1692 * word (perhaps the command terminator), or the vicinity of an error
1693 * (if the result is not TCL_OK).
1694 *
1695 * envPtr->wordIsSimple is set 1 if the word is simple: just a
1696 * sequence of characters without backslashes. If so, the word's
1697 * characters are the envPtr->numSimpleWordChars characters starting
1698 * at string.
1699 *
1700 * envPtr->maxStackDepth is updated with the maximum number of stack
1701 * elements needed to evaluate the word. This is not changed if
1702 * the word is simple and envPtr->pushSimpleWords was 0 (false).
1703 *
1704 * Side effects:
1705 * Instructions are added to envPtr to compute and push the word
1706 * at runtime.
1707 *
1708 *----------------------------------------------------------------------
1709 */
1710
1711static int
1712CompileWord(interp, string, lastChar, flags, envPtr)
1713 Tcl_Interp *interp; /* Interpreter to use for nested command
1714 * evaluations and error messages. */
1715 char *string; /* First character of word. */
1716 char *lastChar; /* Pointer to terminating character of
1717 * string. */
1718 int flags; /* Flags to control compilation (same values
1719 * passed to Tcl_EvalObj). */
1720 CompileEnv *envPtr; /* Holds the resulting instructions. */
1721{
1722 /*
1723 * Compile one word: approximately
1724 *
1725 * word: quoted_string | braced_string | multipart_word
1726 * quoted_string: '"' char* '"'
1727 * braced_string: '{' char* '}'
1728 * multipart_word (see CompileMultipartWord below)
1729 */
1730
1731 register char *src = string; /* Points to current source char. */
1732 register int type = CHAR_TYPE(src, lastChar);
1733 /* Current char's CHAR_TYPE type. */
1734 int maxDepth = 0; /* Maximum number of stack elements needed
1735 * to compute and push the word. */
1736 char *termPtr = src; /* Points to the character that terminated
1737 * the word. */
1738 int result = TCL_OK;
1739
1740 /*
1741 * Skip any leading white space at the start of a word. Note that a
1742 * backslash-newline is treated as a space.
1743 */
1744
1745 while (type & (TCL_SPACE | TCL_BACKSLASH)) {
1746 if (type == TCL_BACKSLASH) {
1747 if (src[1] == '\n') {
1748 src += 2;
1749 } else {
1750 break; /* no longer white space */
1751 }
1752 } else {
1753 src++;
1754 }
1755 type = CHAR_TYPE(src, lastChar);
1756 }
1757 if (type == TCL_COMMAND_END) {
1758 goto done;
1759 }
1760
1761 /*
1762 * Compile the word. Handle quoted and braced string words here in order
1763 * to avoid an extra procedure call.
1764 */
1765
1766 if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
1767 src++;
1768 if (type == TCL_QUOTE) {
1769 result = TclCompileQuotes(interp, src, lastChar, '"', flags,
1770 envPtr);
1771 } else {
1772 result = CompileBraces(interp, src, lastChar, flags, envPtr);
1773 }
1774 termPtr = (src + envPtr->termOffset);
1775 if (result != TCL_OK) {
1776 goto done;
1777 }
1778
1779 /*
1780 * Make sure terminating character of the quoted or braced string is
1781 * the end of word.
1782 */
1783
1784 if ((*termPtr == '\\') && (*(termPtr+1) == '\n')) {
1785 /*
1786 * Line is continued on next line; the backslash-newline turns
1787 * into space, which terminates the word.
1788 */
1789 } else {
1790 type = CHAR_TYPE(termPtr, lastChar);
1791 if (!(type & (TCL_SPACE | TCL_COMMAND_END))) {
1792 Tcl_ResetResult(interp);
1793 if (*(src-1) == '"') {
1794 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1795 "extra characters after close-quote", -1);
1796 } else {
1797 Tcl_AppendToObj(Tcl_GetObjResult(interp),
1798 "extra characters after close-brace", -1);
1799 }
1800 result = TCL_ERROR;
1801 goto done;
1802 }
1803 }
1804 maxDepth = envPtr->maxStackDepth;
1805 } else {
1806 result = CompileMultipartWord(interp, src, lastChar, flags, envPtr);
1807 termPtr = (src + envPtr->termOffset);
1808 maxDepth = envPtr->maxStackDepth;
1809 }
1810
1811 /*
1812 * Done processing the word. The values of envPtr->wordIsSimple and
1813 * envPtr->numSimpleWordChars are left at the values returned by
1814 * TclCompileQuotes/Braces/MultipartWord.
1815 */
1816
1817 done:
1818 envPtr->termOffset = (termPtr - string);
1819 envPtr->maxStackDepth = maxDepth;
1820 return result;
1821}
1822
1823
1824/*
1825 *----------------------------------------------------------------------
1826 *
1827 * CompileMultipartWord --
1828 *
1829 * This procedure compiles one multipart word: a word comprised of some
1830 * number of nested commands, variable references, or arbitrary
1831 * characters. This procedure assumes that quoted string and braced
1832 * string words and the end of command have already been handled by its
1833 * caller. It also assumes that any leading white space has already
1834 * been consumed.
1835 *
1836 * Ordinarily, callers set envPtr->pushSimpleWords to 1 and this
1837 * procedure emits push and other instructions to compute the word on
1838 * the Tcl evaluation stack at execution time. If a caller sets
1839 * envPtr->pushSimpleWords to 0, it will _not_ compile "simple" words:
1840 * words that are just a sequence of characters without backslashes.
1841 * It will leave their compilation up to the caller. This is done, for
1842 * example, to provide special support for the first word of commands,
1843 * which are almost always the (simple) name of a command.
1844 *
1845 * As an important special case, if the word is simple, this procedure
1846 * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
1847 * number of characters in the simple word. This allows the caller to
1848 * process these words specially.
1849 *
1850 * Results:
1851 * The return value is a standard Tcl result. If an error occurs, an
1852 * error message is left in the interpreter's result.
1853 *
1854 * envPtr->termOffset is filled in with the offset of the character in
1855 * "string" just after the last one successfully processed in the last
1856 * word. This is normally the character just after the last one in a
1857 * word (perhaps the command terminator), or the vicinity of an error
1858 * (if the result is not TCL_OK).
1859 *
1860 * envPtr->wordIsSimple is set 1 if the word is simple: just a
1861 * sequence of characters without backslashes. If so, the word's
1862 * characters are the envPtr->numSimpleWordChars characters starting
1863 * at string.
1864 *
1865 * envPtr->maxStackDepth is updated with the maximum number of stack
1866 * elements needed to evaluate the word. This is not changed if
1867 * the word is simple and envPtr->pushSimpleWords was 0 (false).
1868 *
1869 * Side effects:
1870 * Instructions are added to envPtr to compute and push the word
1871 * at runtime.
1872 *
1873 *----------------------------------------------------------------------
1874 */
1875
1876static int
1877CompileMultipartWord(interp, string, lastChar, flags, envPtr)
1878 Tcl_Interp *interp; /* Interpreter to use for nested command
1879 * evaluations and error messages. */
1880 char *string; /* First character of word. */
1881 char *lastChar; /* Pointer to terminating character of
1882 * string. */
1883 int flags; /* Flags to control compilation (same values
1884 * passed to Tcl_EvalObj). */
1885 CompileEnv *envPtr; /* Holds the resulting instructions. */
1886{
1887 /*
1888 * Compile one multi_part word:
1889 *
1890 * multi_part_word: word_part+
1891 * word_part: nested_cmd | var_reference | char+
1892 * nested_cmd: '[' command ']'
1893 * var_reference: '$' name | '$' name '(' index_string ')' |
1894 * '$' '{' braced_name '}')
1895 * name: (letter | digit | underscore)+
1896 * braced_name: (non_close_brace_char)*
1897 * index_string: (non_close_paren_char)*
1898 */
1899
1900 register char *src = string; /* Points to current source char. */
1901 register char c = *src; /* The current char. */
1902 register int type; /* Current char's CHAR_TYPE type. */
1903 int bracketNormal = !(flags & TCL_BRACKET_TERM);
1904 int simpleWord = 0; /* Set 1 if word is simple. */
1905 int numParts = 0; /* Count of word_part objs pushed. */
1906 int maxDepth = 0; /* Maximum number of stack elements needed
1907 * to compute and push the word. */
1908 char *start; /* Starting position of char+ word_part. */
1909 int hasBackslash; /* Nonzero if '\' in char+ word_part. */
1910 int numChars; /* Number of chars in char+ word_part. */
1911 char savedChar; /* Holds the character from string
1912 * termporarily replaced by a null character
1913 * during word_part processing. */
1914 int objIndex; /* The object array index for a pushed
1915 * object holding a word_part. */
1916 int savePushSimpleWords = envPtr->pushSimpleWords;
1917 int result = TCL_OK;
1918 int numRead;
1919
1920 type = CHAR_TYPE(src, lastChar);
1921 while (1) {
1922 /*
1923 * Process a word_part: a sequence of chars, a var reference, or
1924 * a nested command.
1925 */
1926
1927 if ((type & (TCL_NORMAL | TCL_CLOSE_BRACE | TCL_BACKSLASH |
1928 TCL_QUOTE | TCL_OPEN_BRACE)) ||
1929 ((c == ']') && bracketNormal)) {
1930 /*
1931 * A char+ word part. Scan first looking for any backslashes.
1932 * Note that a backslash-newline must be treated as a word
1933 * separator, as if the backslash-newline had been collapsed
1934 * before command parsing began.
1935 */
1936
1937 start = src;
1938 hasBackslash = 0;
1939 do {
1940 if (type == TCL_BACKSLASH) {
1941 hasBackslash = 1;
1942 Tcl_Backslash(src, &numRead);
1943 if (src[1] == '\n') {
1944 src += numRead;
1945 type = TCL_SPACE; /* force word end */
1946 break;
1947 }
1948 src += numRead;
1949 } else {
1950 src++;
1951 }
1952 c = *src;
1953 type = CHAR_TYPE(src, lastChar);
1954 } while (type & (TCL_NORMAL | TCL_BACKSLASH | TCL_QUOTE |
1955 TCL_OPEN_BRACE | TCL_CLOSE_BRACE)
1956 || ((c == ']') && bracketNormal));
1957
1958 if ((numParts == 0) && !hasBackslash
1959 && (type & (TCL_SPACE | TCL_COMMAND_END))) {
1960 /*
1961 * The word is "simple": just a sequence of characters
1962 * without backslashes terminated by a TCL_SPACE or
1963 * TCL_COMMAND_END. Just return if we are not to compile
1964 * simple words.
1965 */
1966
1967 simpleWord = 1;
1968 if (!envPtr->pushSimpleWords) {
1969 envPtr->wordIsSimple = 1;
1970 envPtr->numSimpleWordChars = (src - string);
1971 envPtr->termOffset = envPtr->numSimpleWordChars;
1972 envPtr->pushSimpleWords = savePushSimpleWords;
1973 return TCL_OK;
1974 }
1975 }
1976
1977 /*
1978 * Create and push a string object for the char+ word_part,
1979 * which starts at "start" and ends at the char just before
1980 * src. If backslashes were found, copy the word_part's
1981 * characters with substituted backslashes into a heap-allocated
1982 * buffer and use it to create the string object. Temporarily
1983 * replace the terminating character with a null character.
1984 */
1985
1986 numChars = (src - start);
1987 savedChar = start[numChars];
1988 start[numChars] = '\0';
1989 if ((numChars > 0) && (hasBackslash)) {
1990 char *buffer = ckalloc((unsigned) numChars + 1);
1991 register char *dst = buffer;
1992 register char *p = start;
1993 while (p < src) {
1994 if (*p == '\\') {
1995 *dst = Tcl_Backslash(p, &numRead);
1996 if (p[1] == '\n') {
1997 break;
1998 }
1999 p += numRead;
2000 dst++;
2001 } else {
2002 *dst++ = *p++;
2003 }
2004 }
2005 *dst = '\0';
2006 objIndex = TclObjIndexForString(buffer, dst-buffer,
2007 /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
2008 } else {
2009 objIndex = TclObjIndexForString(start, numChars,
2010 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
2011 }
2012 start[numChars] = savedChar;
2013 TclEmitPush(objIndex, envPtr);
2014 maxDepth = TclMax((numParts + 1), maxDepth);
2015 } else if (type == TCL_DOLLAR) {
2016 result = TclCompileDollarVar(interp, src, lastChar,
2017 flags, envPtr);
2018 src += envPtr->termOffset;
2019 if (result != TCL_OK) {
2020 goto done;
2021 }
2022 maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
2023 c = *src;
2024 type = CHAR_TYPE(src, lastChar);
2025 } else if (type == TCL_OPEN_BRACKET) {
2026 char *termPtr;
2027 envPtr->pushSimpleWords = 1;
2028 src++;
2029 result = TclCompileString(interp, src, lastChar,
2030 (flags | TCL_BRACKET_TERM), envPtr);
2031 termPtr = (src + envPtr->termOffset);
2032 if (*termPtr == ']') {
2033 termPtr++;
2034 } else if (*termPtr == '\0') {
2035 /*
2036 * Missing ] at end of nested command.
2037 */
2038
2039 Tcl_ResetResult(interp);
2040 Tcl_AppendToObj(Tcl_GetObjResult(interp),
2041 "missing close-bracket", -1);
2042 result = TCL_ERROR;
2043 }
2044 src = termPtr;
2045 if (result != TCL_OK) {
2046 goto done;
2047 }
2048 maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
2049 c = *src;
2050 type = CHAR_TYPE(src, lastChar);
2051 } else if (type & (TCL_SPACE | TCL_COMMAND_END)) {
2052 goto wordEnd;
2053 }
2054 numParts++;
2055 } /* end of infinite loop */
2056
2057 wordEnd:
2058 /*
2059 * End of a non-simple word: TCL_SPACE, TCL_COMMAND_END, or
2060 * backslash-newline. Concatenate the word_parts if necessary.
2061 */
2062
2063 while (numParts > 255) {
2064 TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
2065 numParts -= 254; /* concat pushes 1 obj, the result */
2066 }
2067 if (numParts > 1) {
2068 TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
2069 }
2070
2071 done:
2072 if (simpleWord) {
2073 envPtr->wordIsSimple = 1;
2074 envPtr->numSimpleWordChars = (src - string);
2075 } else {
2076 envPtr->wordIsSimple = 0;
2077 envPtr->numSimpleWordChars = 0;
2078 }
2079 envPtr->termOffset = (src - string);
2080 envPtr->maxStackDepth = maxDepth;
2081 envPtr->pushSimpleWords = savePushSimpleWords;
2082 return result;
2083}
2084
2085
2086/*
2087 *----------------------------------------------------------------------
2088 *
2089 * TclCompileQuotes --
2090 *
2091 * This procedure compiles a double-quoted string such as a quoted Tcl
2092 * command argument or a quoted value in a Tcl expression. This
2093 * procedure is also used to compile array element names within
2094 * parentheses (where the termChar will be ')' instead of '"'), or
2095 * anything else that needs the substitutions that happen in quotes.
2096 *
2097 * Ordinarily, callers set envPtr->pushSimpleWords to 1 and
2098 * TclCompileQuotes always emits push and other instructions to compute
2099 * the word on the Tcl evaluation stack at execution time. If a caller
2100 * sets envPtr->pushSimpleWords to 0, TclCompileQuotes will not compile
2101 * "simple" words: words that are just a sequence of characters without
2102 * backslashes. It will leave their compilation up to the caller. This
2103 * is done to provide special support for the first word of commands,
2104 * which are almost always the (simple) name of a command.
2105 *
2106 * As an important special case, if the word is simple, this procedure
2107 * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
2108 * number of characters in the simple word. This allows the caller to
2109 * process these words specially.
2110 *
2111 * Results:
2112 * The return value is a standard Tcl result, which is TCL_OK unless
2113 * there was an error while parsing the quoted string. If an error
2114 * occurs then the interpreter's result contains a standard error
2115 * message.
2116 *
2117 * envPtr->termOffset is filled in with the offset of the character in
2118 * "string" just after the last one successfully processed; this is
2119 * usually the character just after the matching close-quote.
2120 *
2121 * envPtr->wordIsSimple is set 1 if the word is simple: just a
2122 * sequence of characters without backslashes. If so, the word's
2123 * characters are the envPtr->numSimpleWordChars characters starting
2124 * at string.
2125 *
2126 * envPtr->maxStackDepth is updated with the maximum number of stack
2127 * elements needed to evaluate the word. This is not changed if
2128 * the word is simple and envPtr->pushSimpleWords was 0 (false).
2129 *
2130 * Side effects:
2131 * Instructions are added to envPtr to push the quoted-string
2132 * at runtime.
2133 *
2134 *----------------------------------------------------------------------
2135 */
2136
2137int
2138TclCompileQuotes(interp, string, lastChar, termChar, flags, envPtr)
2139 Tcl_Interp *interp; /* Interpreter to use for nested command
2140 * evaluations and error messages. */
2141 char *string; /* Points to the character just after
2142 * the opening '"' or '('. */
2143 char *lastChar; /* Pointer to terminating character of
2144 * string. */
2145 int termChar; /* Character that terminates the "quoted"
2146 * string (usually double-quote, but might
2147 * be right-paren or something else). */
2148 int flags; /* Flags to control compilation (same
2149 * values passed to Tcl_Eval). */
2150 CompileEnv *envPtr; /* Holds the resulting instructions. */
2151{
2152 register char *src = string; /* Points to current source char. */
2153 register char c = *src; /* The current char. */
2154 int simpleWord = 0; /* Set 1 if a simple quoted string word. */
2155 char *start; /* Start position of char+ string_part. */
2156 int hasBackslash; /* 1 if '\' found in char+ string_part. */
2157 int numRead; /* Count of chars read by Tcl_Backslash. */
2158 int numParts = 0; /* Count of string_part objs pushed. */
2159 int maxDepth = 0; /* Maximum number of stack elements needed
2160 * to compute and push the string. */
2161 char savedChar; /* Holds the character from string
2162 * termporarily replaced by a null
2163 * char during string_part processing. */
2164 int objIndex; /* The object array index for a pushed
2165 * object holding a string_part. */
2166 int numChars; /* Number of chars in string_part. */
2167 int savePushSimpleWords = envPtr->pushSimpleWords;
2168 int result = TCL_OK;
2169
2170 /*
2171 * quoted_string: '"' string_part* '"' (or termChar instead of ")
2172 * string_part: var_reference | nested_cmd | char+
2173 */
2174
2175
2176 while ((src != lastChar) && (c != termChar)) {
2177 if (c == '$') {
2178 result = TclCompileDollarVar(interp, src, lastChar, flags,
2179 envPtr);
2180 src += envPtr->termOffset;
2181 if (result != TCL_OK) {
2182 goto done;
2183 }
2184 maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
2185 c = *src;
2186 } else if (c == '[') {
2187 char *termPtr;
2188 envPtr->pushSimpleWords = 1;
2189 src++;
2190 result = TclCompileString(interp, src, lastChar,
2191 (flags | TCL_BRACKET_TERM), envPtr);
2192 termPtr = (src + envPtr->termOffset);
2193 if (*termPtr == ']') {
2194 termPtr++;
2195 }
2196 src = termPtr;
2197 if (result != TCL_OK) {
2198 goto done;
2199 }
2200 if (termPtr == lastChar) {
2201 /*
2202 * Missing ] at end of nested command.
2203 */
2204
2205 Tcl_ResetResult(interp);
2206 Tcl_AppendToObj(Tcl_GetObjResult(interp),
2207 "missing close-bracket", -1);
2208 result = TCL_ERROR;
2209 goto done;
2210 }
2211 maxDepth = TclMax((numParts + envPtr->maxStackDepth), maxDepth);
2212 c = *src;
2213 } else {
2214 /*
2215 * Start of a char+ string_part. Scan first looking for any
2216 * backslashes.
2217 */
2218
2219 start = src;
2220 hasBackslash = 0;
2221 do {
2222 if (c == '\\') {
2223 hasBackslash = 1;
2224 Tcl_Backslash(src, &numRead);
2225 src += numRead;
2226 } else {
2227 src++;
2228 }
2229 c = *src;
2230 } while ((src != lastChar) && (c != '$') && (c != '[')
2231 && (c != termChar));
2232
2233 if ((numParts == 0) && !hasBackslash
2234 && ((src == lastChar) && (c == termChar))) {
2235 /*
2236 * The quoted string is "simple": just a sequence of
2237 * characters without backslashes terminated by termChar or
2238 * a null character. Just return if we are not to compile
2239 * simple words.
2240 */
2241
2242 simpleWord = 1;
2243 if (!envPtr->pushSimpleWords) {
2244 if ((src == lastChar) && (termChar != '\0')) {
2245 char buf[40];
2246 sprintf(buf, "missing %c", termChar);
2247 Tcl_ResetResult(interp);
2248 Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
2249 result = TCL_ERROR;
2250 } else {
2251 src++;
2252 }
2253 envPtr->wordIsSimple = 1;
2254 envPtr->numSimpleWordChars = (src - string - 1);
2255 envPtr->termOffset = (src - string);
2256 envPtr->pushSimpleWords = savePushSimpleWords;
2257 return result;
2258 }
2259 }
2260
2261 /*
2262 * Create and push a string object for the char+ string_part
2263 * that starts at "start" and ends at the char just before
2264 * src. If backslashes were found, copy the string_part's
2265 * characters with substituted backslashes into a heap-allocated
2266 * buffer and use it to create the string object. Temporarily
2267 * replace the terminating character with a null character.
2268 */
2269
2270 numChars = (src - start);
2271 savedChar = start[numChars];
2272 start[numChars] = '\0';
2273 if ((numChars > 0) && (hasBackslash)) {
2274 char *buffer = ckalloc((unsigned) numChars + 1);
2275 register char *dst = buffer;
2276 register char *p = start;
2277 while (p < src) {
2278 if (*p == '\\') {
2279 *dst++ = Tcl_Backslash(p, &numRead);
2280 p += numRead;
2281 } else {
2282 *dst++ = *p++;
2283 }
2284 }
2285 *dst = '\0';
2286 objIndex = TclObjIndexForString(buffer, (dst - buffer),
2287 /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
2288 } else {
2289 objIndex = TclObjIndexForString(start, numChars,
2290 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
2291 }
2292 start[numChars] = savedChar;
2293 TclEmitPush(objIndex, envPtr);
2294 maxDepth = TclMax((numParts + 1), maxDepth);
2295 }
2296 numParts++;
2297 }
2298
2299 /*
2300 * End of the quoted string: src points at termChar or '\0'. If
2301 * necessary, concatenate the string_part objects on the stack.
2302 */
2303
2304 if ((src == lastChar) && (termChar != '\0')) {
2305 char buf[40];
2306 sprintf(buf, "missing %c", termChar);
2307 Tcl_ResetResult(interp);
2308 Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
2309 result = TCL_ERROR;
2310 goto done;
2311 } else {
2312 src++;
2313 }
2314
2315 if (numParts == 0) {
2316 /*
2317 * The quoted string was empty. Push an empty string object.
2318 */
2319
2320 int objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
2321 /*inHeap*/ 0, envPtr);
2322 TclEmitPush(objIndex, envPtr);
2323 } else {
2324 /*
2325 * Emit any needed concat instructions.
2326 */
2327
2328 while (numParts > 255) {
2329 TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
2330 numParts -= 254; /* concat pushes 1 obj, the result */
2331 }
2332 if (numParts > 1) {
2333 TclEmitInstUInt1(INST_CONCAT1, numParts, envPtr);
2334 }
2335 }
2336
2337 done:
2338 if (simpleWord) {
2339 envPtr->wordIsSimple = 1;
2340 envPtr->numSimpleWordChars = (src - string - 1);
2341 } else {
2342 envPtr->wordIsSimple = 0;
2343 envPtr->numSimpleWordChars = 0;
2344 }
2345 envPtr->termOffset = (src - string);
2346 envPtr->maxStackDepth = maxDepth;
2347 envPtr->pushSimpleWords = savePushSimpleWords;
2348 return result;
2349}
2350
2351
2352/*
2353 *--------------------------------------------------------------
2354 *
2355 * CompileBraces --
2356 *
2357 * This procedure compiles characters between matching curly braces.
2358 *
2359 * Ordinarily, callers set envPtr->pushSimpleWords to 1 and
2360 * CompileBraces always emits a push instruction to compute the word on
2361 * the Tcl evaluation stack at execution time. However, if a caller
2362 * sets envPtr->pushSimpleWords to 0, CompileBraces will _not_ compile
2363 * "simple" words: words that are just a sequence of characters without
2364 * backslash-newlines. It will leave their compilation up to the
2365 * caller.
2366 *
2367 * As an important special case, if the word is simple, this procedure
2368 * sets envPtr->wordIsSimple to 1 and envPtr->numSimpleWordChars to the
2369 * number of characters in the simple word. This allows the caller to
2370 * process these words specially.
2371 *
2372 * Results:
2373 * The return value is a standard Tcl result, which is TCL_OK unless
2374 * there was an error while parsing string. If an error occurs then
2375 * the interpreter's result contains a standard error message.
2376 *
2377 * envPtr->termOffset is filled in with the offset of the character in
2378 * "string" just after the last one successfully processed. This is
2379 * usually the character just after the matching close-brace.
2380 *
2381 * envPtr->wordIsSimple is set 1 if the word is simple: just a
2382 * sequence of characters without backslash-newlines. If so, the word's
2383 * characters are the envPtr->numSimpleWordChars characters starting
2384 * at string.
2385 *
2386 * envPtr->maxStackDepth is updated with the maximum number of stack
2387 * elements needed to evaluate the word. This is not changed if
2388 * the word is simple and envPtr->pushSimpleWords was 0 (false).
2389 *
2390 * Side effects:
2391 * Instructions are added to envPtr to push the braced string
2392 * at runtime.
2393 *
2394 *--------------------------------------------------------------
2395 */
2396
2397static int
2398CompileBraces(interp, string, lastChar, flags, envPtr)
2399 Tcl_Interp *interp; /* Interpreter to use for nested command
2400 * evaluations and error messages. */
2401 char *string; /* Character just after opening bracket. */
2402 char *lastChar; /* Pointer to terminating character of
2403 * string. */
2404 int flags; /* Flags to control compilation (same
2405 * values passed to Tcl_Eval). */
2406 CompileEnv *envPtr; /* Holds the resulting instructions. */
2407{
2408 register char *src = string; /* Points to current source char. */
2409 register char c; /* The current char. */
2410 int simpleWord = 0; /* Set 1 if a simple braced string word. */
2411 int level = 1; /* {} nesting level. Initially 1 since {
2412 * was parsed before we were called. */
2413 int hasBackslashNewline = 0; /* Nonzero if '\' found. */
2414 char *last; /* Points just before terminating '}'. */
2415 int numChars; /* Number of chars in braced string. */
2416 char savedChar; /* Holds the character from string
2417 * termporarily replaced by a null
2418 * char during braced string processing. */
2419 int objIndex; /* The object array index for a pushed
2420 * object holding a braced string. */
2421 int numRead;
2422 int result = TCL_OK;
2423
2424 /*
2425 * Check for any backslash-newlines, since we must treat
2426 * backslash-newlines specially (they must be replaced by spaces).
2427 */
2428
2429 while (1) {
2430 c = *src;
2431 if (src == lastChar) {
2432 Tcl_ResetResult(interp);
2433 Tcl_AppendToObj(Tcl_GetObjResult(interp),
2434 "missing close-brace", -1);
2435 result = TCL_ERROR;
2436 goto done;
2437 }
2438 if (CHAR_TYPE(src, lastChar) != TCL_NORMAL) {
2439 if (c == '{') {
2440 level++;
2441 } else if (c == '}') {
2442 --level;
2443 if (level == 0) {
2444 src++;
2445 last = (src - 2); /* point just before terminating } */
2446 break;
2447 }
2448 } else if (c == '\\') {
2449 if (*(src+1) == '\n') {
2450 hasBackslashNewline = 1;
2451 }
2452 (void) Tcl_Backslash(src, &numRead);
2453 src += numRead - 1;
2454 }
2455 }
2456 src++;
2457 }
2458
2459 if (!hasBackslashNewline) {
2460 /*
2461 * The braced word is "simple": just a sequence of characters
2462 * without backslash-newlines. Just return if we are not to compile
2463 * simple words.
2464 */
2465
2466 simpleWord = 1;
2467 if (!envPtr->pushSimpleWords) {
2468 envPtr->wordIsSimple = 1;
2469 envPtr->numSimpleWordChars = (src - string - 1);
2470 envPtr->termOffset = (src - string);
2471 return TCL_OK;
2472 }
2473 }
2474
2475 /*
2476 * Create and push a string object for the braced string. This starts at
2477 * "string" and ends just after "last" (which points to the final
2478 * character before the terminating '}'). If backslash-newlines were
2479 * found, we copy characters one at a time into a heap-allocated buffer
2480 * and do backslash-newline substitutions.
2481 */
2482
2483 numChars = (last - string + 1);
2484 savedChar = string[numChars];
2485 string[numChars] = '\0';
2486 if ((numChars > 0) && (hasBackslashNewline)) {
2487 char *buffer = ckalloc((unsigned) numChars + 1);
2488 register char *dst = buffer;
2489 register char *p = string;
2490 while (p <= last) {
2491 c = *dst++ = *p++;
2492 if (c == '\\') {
2493 if (*p == '\n') {
2494 dst[-1] = Tcl_Backslash(p-1, &numRead);
2495 p += numRead - 1;
2496 } else {
2497 (void) Tcl_Backslash(p-1, &numRead);
2498 while (numRead > 1) {
2499 *dst++ = *p++;
2500 numRead--;
2501 }
2502 }
2503 }
2504 }
2505 *dst = '\0';
2506 objIndex = TclObjIndexForString(buffer, (dst - buffer),
2507 /*allocStrRep*/ 1, /*inHeap*/ 1, envPtr);
2508 } else {
2509 objIndex = TclObjIndexForString(string, numChars, /*allocStrRep*/ 1,
2510 /*inHeap*/ 0, envPtr);
2511 }
2512 string[numChars] = savedChar;
2513 TclEmitPush(objIndex, envPtr);
2514
2515 done:
2516 if (simpleWord) {
2517 envPtr->wordIsSimple = 1;
2518 envPtr->numSimpleWordChars = (src - string - 1);
2519 } else {
2520 envPtr->wordIsSimple = 0;
2521 envPtr->numSimpleWordChars = 0;
2522 }
2523 envPtr->termOffset = (src - string);
2524 envPtr->maxStackDepth = 1;
2525 return result;
2526}
2527
2528
2529/*
2530 *----------------------------------------------------------------------
2531 *
2532 * TclCompileDollarVar --
2533 *
2534 * Given a string starting with a $ sign, parse a variable name
2535 * and compile instructions to push its value. If the variable
2536 * reference is just a '$' (i.e. the '$' isn't followed by anything
2537 * that could possibly be a variable name), just push a string object
2538 * containing '$'.
2539 *
2540 * Results:
2541 * The return value is a standard Tcl result. If an error occurs
2542 * then an error message is left in the interpreter's result.
2543 *
2544 * envPtr->termOffset is filled in with the offset of the character in
2545 * "string" just after the last one in the variable reference.
2546 *
2547 * envPtr->wordIsSimple is set 0 (false) because the word is not
2548 * simple: it is not just a sequence of characters without backslashes.
2549 * For the same reason, envPtr->numSimpleWordChars is set 0.
2550 *
2551 * envPtr->maxStackDepth is updated with the maximum number of stack
2552 * elements needed to execute the string's commands.
2553 *
2554 * Side effects:
2555 * Instructions are added to envPtr to look up the variable and
2556 * push its value at runtime.
2557 *
2558 *----------------------------------------------------------------------
2559 */
2560
2561int
2562TclCompileDollarVar(interp, string, lastChar, flags, envPtr)
2563 Tcl_Interp *interp; /* Interpreter to use for nested command
2564 * evaluations and error messages. */
2565 char *string; /* First char (i.e. $) of var reference. */
2566 char *lastChar; /* Pointer to terminating character of
2567 * string. */
2568 int flags; /* Flags to control compilation (same
2569 * values passed to Tcl_Eval). */
2570 CompileEnv *envPtr; /* Holds the resulting instructions. */
2571{
2572 register char *src = string; /* Points to current source char. */
2573 register char c; /* The current char. */
2574 char *name; /* Start of 1st part of variable name. */
2575 int nameChars; /* Count of chars in name. */
2576 int nameHasNsSeparators = 0; /* Set 1 if name contains "::"s. */
2577 char savedChar; /* Holds the character from string
2578 * termporarily replaced by a null
2579 * char during name processing. */
2580 int objIndex; /* The object array index for a pushed
2581 * object holding a name part. */
2582 int isArrayRef = 0; /* 1 if reference to array element. */
2583 int localIndex = -1; /* Frame index of local if found. */
2584 int maxDepth = 0; /* Maximum number of stack elements needed
2585 * to push the variable. */
2586 int savePushSimpleWords = envPtr->pushSimpleWords;
2587 int result = TCL_OK;
2588
2589 /*
2590 * var_reference: '$' '{' braced_name '}' |
2591 * '$' name ['(' index_string ')']
2592 *
2593 * There are three cases:
2594 * 1. The $ sign is followed by an open curly brace. Then the variable
2595 * name is everything up to the next close curly brace, and the
2596 * variable is a scalar variable.
2597 * 2. The $ sign is not followed by an open curly brace. Then the
2598 * variable name is everything up to the next character that isn't
2599 * a letter, digit, underscore, or a "::" namespace separator. If the
2600 * following character is an open parenthesis, then the information
2601 * between parentheses is the array element name, which can include
2602 * any of the substitutions permissible between quotes.
2603 * 3. The $ sign is followed by something that isn't a letter, digit,
2604 * underscore, or a "::" namespace separator: in this case,
2605 * there is no variable name, and "$" is pushed.
2606 */
2607
2608 src++; /* advance over the '$'. */
2609
2610 /*
2611 * Collect the first part of the variable's name into "name" and
2612 * determine if it is an array reference and if it contains any
2613 * namespace separator (::'s).
2614 */
2615
2616 if (*src == '{') {
2617 /*
2618 * A scalar name in braces.
2619 */
2620
2621 char *p;
2622
2623 src++;
2624 name = src;
2625 c = *src;
2626 while (c != '}') {
2627 if (src == lastChar) {
2628 Tcl_ResetResult(interp);
2629 Tcl_AppendToObj(Tcl_GetObjResult(interp),
2630 "missing close-brace for variable name", -1);
2631 result = TCL_ERROR;
2632 goto done;
2633 }
2634 src++;
2635 c = *src;
2636 }
2637 nameChars = (src - name);
2638 for (p = name; p < src; p++) {
2639 if ((*p == ':') && (*(p+1) == ':')) {
2640 nameHasNsSeparators = 1;
2641 break;
2642 }
2643 }
2644 src++; /* advance over the '}'. */
2645 } else {
2646 /*
2647 * Scalar name or array reference not in braces.
2648 */
2649
2650 name = src;
2651 c = *src;
2652 while (isalnum(UCHAR(c)) || (c == '_') || (c == ':')) {
2653 if (c == ':') {
2654 if (*(src+1) == ':') {
2655 nameHasNsSeparators = 1;
2656 src += 2;
2657 while (*src == ':') {
2658 src++;
2659 }
2660 c = *src;
2661 } else {
2662 break; /* : by itself */
2663 }
2664 } else {
2665 src++;
2666 c = *src;
2667 }
2668 }
2669 if (src == name) {
2670 /*
2671 * A '$' by itself, not a name reference. Push a "$" string.
2672 */
2673
2674 objIndex = TclObjIndexForString("$", 1, /*allocStrRep*/ 1,
2675 /*inHeap*/ 0, envPtr);
2676 TclEmitPush(objIndex, envPtr);
2677 maxDepth = 1;
2678 goto done;
2679 }
2680 nameChars = (src - name);
2681 isArrayRef = (c == '(');
2682 }
2683
2684 /*
2685 * Now emit instructions to load the variable. First either push the
2686 * name of the scalar or array, or determine its index in the array of
2687 * local variables in a procedure frame. Push the name if we are not
2688 * compiling a procedure body or if the name has namespace
2689 * qualifiers ("::"s).
2690 */
2691
2692 if (!isArrayRef) { /* scalar reference */
2693 if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
2694 savedChar = name[nameChars];
2695 name[nameChars] = '\0';
2696 objIndex = TclObjIndexForString(name, nameChars,
2697 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
2698 name[nameChars] = savedChar;
2699 TclEmitPush(objIndex, envPtr);
2700 TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
2701 maxDepth = 1;
2702 } else {
2703 localIndex = LookupCompiledLocal(name, nameChars,
2704 /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
2705 envPtr->procPtr);
2706 if (localIndex >= 0) {
2707 if (localIndex <= 255) {
2708 TclEmitInstUInt1(INST_LOAD_SCALAR1, localIndex, envPtr);
2709 } else {
2710 TclEmitInstUInt4(INST_LOAD_SCALAR4, localIndex, envPtr);
2711 }
2712 maxDepth = 0;
2713 } else {
2714 savedChar = name[nameChars];
2715 name[nameChars] = '\0';
2716 objIndex = TclObjIndexForString(name, nameChars,
2717 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
2718 name[nameChars] = savedChar;
2719 TclEmitPush(objIndex, envPtr);
2720 TclEmitOpcode(INST_LOAD_SCALAR_STK, envPtr);
2721 maxDepth = 1;
2722 }
2723 }
2724 } else { /* array reference */
2725 if ((envPtr->procPtr == NULL) || nameHasNsSeparators) {
2726 savedChar = name[nameChars];
2727 name[nameChars] = '\0';
2728 objIndex = TclObjIndexForString(name, nameChars,
2729 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
2730 name[nameChars] = savedChar;
2731 TclEmitPush(objIndex, envPtr);
2732 maxDepth = 1;
2733 } else {
2734 localIndex = LookupCompiledLocal(name, nameChars,
2735 /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
2736 envPtr->procPtr);
2737 if (localIndex < 0) {
2738 savedChar = name[nameChars];
2739 name[nameChars] = '\0';
2740 objIndex = TclObjIndexForString(name, nameChars,
2741 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
2742 name[nameChars] = savedChar;
2743 TclEmitPush(objIndex, envPtr);
2744 maxDepth = 1;
2745 }
2746 }
2747
2748 /*
2749 * Parse and push the array element. Perform substitutions on it,
2750 * just as is done for quoted strings.
2751 */
2752
2753 src++;
2754 envPtr->pushSimpleWords = 1;
2755 result = TclCompileQuotes(interp, src, lastChar, ')', flags,
2756 envPtr);
2757 src += envPtr->termOffset;
2758 if (result != TCL_OK) {
2759 char msg[200];
2760 sprintf(msg, "\n (parsing index for array \"%.*s\")",
2761 (nameChars > 100? 100 : nameChars), name);
2762 Tcl_AddObjErrorInfo(interp, msg, -1);
2763 goto done;
2764 }
2765 maxDepth += envPtr->maxStackDepth;
2766
2767 /*
2768 * Now emit the appropriate load instruction for the array element.
2769 */
2770
2771 if (localIndex < 0) { /* a global or an unknown local */
2772 TclEmitOpcode(INST_LOAD_ARRAY_STK, envPtr);
2773 } else {
2774 if (localIndex <= 255) {
2775 TclEmitInstUInt1(INST_LOAD_ARRAY1, localIndex, envPtr);
2776 } else {
2777 TclEmitInstUInt4(INST_LOAD_ARRAY4, localIndex, envPtr);
2778 }
2779 }
2780 }
2781
2782 done:
2783 envPtr->termOffset = (src - string);
2784 envPtr->wordIsSimple = 0;
2785 envPtr->numSimpleWordChars = 0;
2786 envPtr->maxStackDepth = maxDepth;
2787 envPtr->pushSimpleWords = savePushSimpleWords;
2788 return result;
2789}
2790
2791
2792/*
2793 *----------------------------------------------------------------------
2794 *
2795 * IsLocalScalar --
2796 *
2797 * Checks to see if a variable name refers to a local scalar.
2798 *
2799 * Results:
2800 * Returns 1 if the variable is a local scalar.
2801 *
2802 * Side effects:
2803 * None.
2804 *
2805 *----------------------------------------------------------------------
2806 */
2807
2808static int
2809IsLocalScalar(varName, length)
2810 char *varName; /* The name to check. */
2811 int length; /* The number of characters in the string. */
2812{
2813 char *p;
2814 char *lastChar = varName + (length - 1);
2815
2816 for (p = varName; p <= lastChar; p++) {
2817 if ((CHAR_TYPE(p, lastChar) != TCL_NORMAL) &&
2818 (CHAR_TYPE(p, lastChar) != TCL_COMMAND_END)) {
2819 /*
2820 * TCL_COMMAND_END is returned for the last character
2821 * of the string. By this point we know it isn't
2822 * an array or namespace reference.
2823 */
2824
2825 return 0;
2826 }
2827 if (*p == '(') {
2828 if (*lastChar == ')') { /* we have an array element */
2829 return 0;
2830 }
2831 } else if (*p == ':') {
2832 if ((p != lastChar) && *(p+1) == ':') { /* qualified name */
2833 return 0;
2834 }
2835 }
2836 }
2837
2838 return 1;
2839}
2840
2841
2842/*
2843 *----------------------------------------------------------------------
2844 *
2845 * TclCompileBreakCmd --
2846 *
2847 * Procedure called to compile the "break" command.
2848 *
2849 * Results:
2850 * The return value is a standard Tcl result, which is TCL_OK unless
2851 * there was an error while parsing string. If an error occurs then
2852 * the interpreter's result contains a standard error message.
2853 *
2854 * envPtr->termOffset is filled in with the offset of the character in
2855 * "string" just after the last one successfully processed.
2856 *
2857 * envPtr->maxStackDepth is updated with the maximum number of stack
2858 * elements needed to execute the command.
2859 *
2860 * Side effects:
2861 * Instructions are added to envPtr to evaluate the "break" command
2862 * at runtime.
2863 *
2864 *----------------------------------------------------------------------
2865 */
2866
2867int
2868TclCompileBreakCmd(interp, string, lastChar, flags, envPtr)
2869 Tcl_Interp *interp; /* Used for error reporting. */
2870 char *string; /* The source string to compile. */
2871 char *lastChar; /* Pointer to terminating character of
2872 * string. */
2873 int flags; /* Flags to control compilation (same as
2874 * passed to Tcl_Eval). */
2875 CompileEnv *envPtr; /* Holds resulting instructions. */
2876{
2877 register char *src = string;/* Points to current source char. */
2878 register int type; /* Current char's CHAR_TYPE type. */
2879 int result = TCL_OK;
2880
2881 /*
2882 * There should be no argument after the "break".
2883 */
2884
2885 type = CHAR_TYPE(src, lastChar);
2886 if (type != TCL_COMMAND_END) {
2887 AdvanceToNextWord(src, envPtr);
2888 src += envPtr->termOffset;
2889 type = CHAR_TYPE(src, lastChar);
2890 if (type != TCL_COMMAND_END) {
2891 Tcl_ResetResult(interp);
2892 Tcl_AppendToObj(Tcl_GetObjResult(interp),
2893 "wrong # args: should be \"break\"", -1);
2894 result = TCL_ERROR;
2895 goto done;
2896 }
2897 }
2898
2899 /*
2900 * Emit a break instruction.
2901 */
2902
2903 TclEmitOpcode(INST_BREAK, envPtr);
2904
2905 done:
2906 envPtr->termOffset = (src - string);
2907 envPtr->maxStackDepth = 0;
2908 return result;
2909}
2910
2911
2912/*
2913 *----------------------------------------------------------------------
2914 *
2915 * TclCompileCatchCmd --
2916 *
2917 * Procedure called to compile the "catch" command.
2918 *
2919 * Results:
2920 * The return value is a standard Tcl result, which is TCL_OK if
2921 * compilation was successful. If an error occurs then the
2922 * interpreter's result contains a standard error message and TCL_ERROR
2923 * is returned. If compilation failed because the command is too
2924 * complex for TclCompileCatchCmd, TCL_OUT_LINE_COMPILE is returned
2925 * indicating that the catch command should be compiled "out of line"
2926 * by emitting code to invoke its command procedure at runtime.
2927 *
2928 * envPtr->termOffset is filled in with the offset of the character in
2929 * "string" just after the last one successfully processed.
2930 *
2931 * envPtr->maxStackDepth is updated with the maximum number of stack
2932 * elements needed to execute the command.
2933 *
2934 * Side effects:
2935 * Instructions are added to envPtr to evaluate the "catch" command
2936 * at runtime.
2937 *
2938 *----------------------------------------------------------------------
2939 */
2940
2941int
2942TclCompileCatchCmd(interp, string, lastChar, flags, envPtr)
2943 Tcl_Interp *interp; /* Used for error reporting. */
2944 char *string; /* The source string to compile. */
2945 char *lastChar; /* Pointer to terminating character of
2946 * string. */
2947 int flags; /* Flags to control compilation (same as
2948 * passed to Tcl_Eval). */
2949 CompileEnv *envPtr; /* Holds resulting instructions. */
2950{
2951 Proc *procPtr = envPtr->procPtr;
2952 /* Points to structure describing procedure
2953 * containing the catch cmd, else NULL. */
2954 int maxDepth = 0; /* Maximum number of stack elements needed
2955 * to execute cmd. */
2956 ArgInfo argInfo; /* Structure holding information about the
2957 * start and end of each argument word. */
2958 int range = -1; /* If we compile the catch command, the
2959 * index for its catch range record in the
2960 * ExceptionRange array. -1 if we are not
2961 * compiling the command. */
2962 char *name; /* If a var name appears for a scalar local
2963 * to a procedure, this points to the name's
2964 * 1st char and nameChars is its length. */
2965 int nameChars; /* Length of the variable name, if any. */
2966 int localIndex = -1; /* Index of the variable in the current
2967 * procedure's array of local variables.
2968 * Otherwise -1 if not in a procedure or
2969 * the variable wasn't found. */
2970 char savedChar; /* Holds the character from string
2971 * termporarily replaced by a null character
2972 * during processing of words. */
2973 JumpFixup jumpFixup; /* Used to emit the jump after the "no
2974 * errors" epilogue code. */
2975 int numWords, objIndex, jumpDist, result;
2976 char *bodyStart, *bodyEnd;
2977 Tcl_Obj *objPtr;
2978 int savePushSimpleWords = envPtr->pushSimpleWords;
2979
2980 /*
2981 * Scan the words of the command and record the start and finish of
2982 * each argument word.
2983 */
2984
2985 InitArgInfo(&argInfo);
2986 result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
2987 numWords = argInfo.numArgs; /* i.e., the # after the command name */
2988 if (result != TCL_OK) {
2989 goto done;
2990 }
2991 if ((numWords != 1) && (numWords != 2)) {
2992 Tcl_ResetResult(interp);
2993 Tcl_AppendToObj(Tcl_GetObjResult(interp),
2994 "wrong # args: should be \"catch command ?varName?\"", -1);
2995 result = TCL_ERROR;
2996 goto done;
2997 }
2998
2999 /*
3000 * If a variable was specified and the catch command is at global level
3001 * (not in a procedure), don't compile it inline: the payoff is
3002 * too small.
3003 */
3004
3005 if ((numWords == 2) && (procPtr == NULL)) {
3006 result = TCL_OUT_LINE_COMPILE;
3007 goto done;
3008 }
3009
3010 /*
3011 * Make sure the variable name, if any, has no substitutions and just
3012 * refers to a local scaler.
3013 */
3014
3015 if (numWords == 2) {
3016 char *firstChar = argInfo.startArray[1];
3017 char *lastChar = argInfo.endArray[1];
3018
3019 if (*firstChar == '{') {
3020 if (*lastChar != '}') {
3021 Tcl_ResetResult(interp);
3022 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3023 "extra characters after close-brace", -1);
3024 result = TCL_ERROR;
3025 goto done;
3026 }
3027 firstChar++;
3028 lastChar--;
3029 }
3030
3031 nameChars = (lastChar - firstChar + 1);
3032 if (!IsLocalScalar(firstChar, nameChars)) {
3033 result = TCL_OUT_LINE_COMPILE;
3034 goto done;
3035 }
3036
3037 name = firstChar;
3038 localIndex = LookupCompiledLocal(name, nameChars,
3039 /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR,
3040 procPtr);
3041 }
3042
3043 /*
3044 *==== At this point we believe we can compile the catch command ====
3045 */
3046
3047 /*
3048 * Create and initialize a ExceptionRange record to hold information
3049 * about this catch command.
3050 */
3051
3052 envPtr->excRangeDepth++;
3053 envPtr->maxExcRangeDepth =
3054 TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
3055 range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
3056
3057 /*
3058 * Emit the instruction to mark the start of the catch command.
3059 */
3060
3061 TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
3062
3063 /*
3064 * Inline compile the catch's body word: the command it controls. Also
3065 * register the body's starting PC offset and byte length in the
3066 * ExceptionRange record.
3067 */
3068
3069 envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
3070
3071 bodyStart = argInfo.startArray[0];
3072 bodyEnd = argInfo.endArray[0];
3073 savedChar = *(bodyEnd+1);
3074 *(bodyEnd+1) = '\0';
3075 result = CompileCmdWordInline(interp, bodyStart, (bodyEnd+1),
3076 flags, envPtr);
3077 *(bodyEnd+1) = savedChar;
3078
3079 if (result != TCL_OK) {
3080 if (result == TCL_ERROR) {
3081 char msg[60];
3082 sprintf(msg, "\n (\"catch\" body line %d)",
3083 interp->errorLine);
3084 Tcl_AddObjErrorInfo(interp, msg, -1);
3085 }
3086 goto done;
3087 }
3088 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
3089 envPtr->excRangeArrayPtr[range].numCodeBytes =
3090 TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
3091
3092 /*
3093 * Now emit the "no errors" epilogue code for the catch. First, if a
3094 * variable was specified, store the body's result into the
3095 * variable; otherwise, just discard the body's result. Then push
3096 * a "0" object as the catch command's "no error" TCL_OK result,
3097 * and jump around the "error case" epilogue code.
3098 */
3099
3100 if (localIndex != -1) {
3101 if (localIndex <= 255) {
3102 TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
3103 } else {
3104 TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
3105 }
3106 }
3107 TclEmitOpcode(INST_POP, envPtr);
3108
3109 objIndex = TclObjIndexForString("0", 1, /*allocStrRep*/ 0, /*inHeap*/ 0,
3110 envPtr);
3111 objPtr = envPtr->objArrayPtr[objIndex];
3112
3113 Tcl_InvalidateStringRep(objPtr);
3114 objPtr->internalRep.longValue = 0;
3115 objPtr->typePtr = &tclIntType;
3116
3117 TclEmitPush(objIndex, envPtr);
3118 if (maxDepth == 0) {
3119 maxDepth = 1; /* since we just pushed one object */
3120 }
3121
3122 TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
3123
3124 /*
3125 * Now emit the "error case" epilogue code. First, if a variable was
3126 * specified, emit instructions to push the interpreter's object result
3127 * and store it into the variable. Then emit an instruction to push the
3128 * nonzero error result. Note that the initial PC offset here is the
3129 * catch's error target.
3130 */
3131
3132 envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
3133 if (localIndex != -1) {
3134 TclEmitOpcode(INST_PUSH_RESULT, envPtr);
3135 if (localIndex <= 255) {
3136 TclEmitInstUInt1(INST_STORE_SCALAR1, localIndex, envPtr);
3137 } else {
3138 TclEmitInstUInt4(INST_STORE_SCALAR4, localIndex, envPtr);
3139 }
3140 TclEmitOpcode(INST_POP, envPtr);
3141 }
3142 TclEmitOpcode(INST_PUSH_RETURN_CODE, envPtr);
3143
3144 /*
3145 * Now that we know the target of the jump after the "no errors"
3146 * epilogue, update it with the correct distance. This is less
3147 * than 127 bytes.
3148 */
3149
3150 jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
3151 if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
3152 panic("TclCompileCatchCmd: bad jump distance %d\n", jumpDist);
3153 }
3154
3155 /*
3156 * Emit the instruction to mark the end of the catch command.
3157 */
3158
3159 TclEmitOpcode(INST_END_CATCH, envPtr);
3160
3161 done:
3162 if (numWords == 0) {
3163 envPtr->termOffset = 0;
3164 } else {
3165 envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
3166 }
3167 if (range != -1) { /* we compiled the catch command */
3168 envPtr->excRangeDepth--;
3169 }
3170 envPtr->pushSimpleWords = savePushSimpleWords;
3171 envPtr->maxStackDepth = maxDepth;
3172 FreeArgInfo(&argInfo);
3173 return result;
3174}
3175
3176
3177/*
3178 *----------------------------------------------------------------------
3179 *
3180 * TclCompileContinueCmd --
3181 *
3182 * Procedure called to compile the "continue" command.
3183 *
3184 * Results:
3185 * The return value is a standard Tcl result, which is TCL_OK unless
3186 * there was an error while parsing string. If an error occurs then
3187 * the interpreter's result contains a standard error message.
3188 *
3189 * envPtr->termOffset is filled in with the offset of the character in
3190 * "string" just after the last one successfully processed.
3191 *
3192 * envPtr->maxStackDepth is updated with the maximum number of stack
3193 * elements needed to execute the command.
3194 *
3195 * Side effects:
3196 * Instructions are added to envPtr to evaluate the "continue" command
3197 * at runtime.
3198 *
3199 *----------------------------------------------------------------------
3200 */
3201
3202int
3203TclCompileContinueCmd(interp, string, lastChar, flags, envPtr)
3204 Tcl_Interp *interp; /* Used for error reporting. */
3205 char *string; /* The source string to compile. */
3206 char *lastChar; /* Pointer to terminating character of
3207 * string. */
3208 int flags; /* Flags to control compilation (same as
3209 * passed to Tcl_Eval). */
3210 CompileEnv *envPtr; /* Holds resulting instructions. */
3211{
3212 register char *src = string;/* Points to current source char. */
3213 register int type; /* Current char's CHAR_TYPE type. */
3214 int result = TCL_OK;
3215
3216 /*
3217 * There should be no argument after the "continue".
3218 */
3219
3220 type = CHAR_TYPE(src, lastChar);
3221 if (type != TCL_COMMAND_END) {
3222 AdvanceToNextWord(src, envPtr);
3223 src += envPtr->termOffset;
3224 type = CHAR_TYPE(src, lastChar);
3225 if (type != TCL_COMMAND_END) {
3226 Tcl_ResetResult(interp);
3227 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3228 "wrong # args: should be \"continue\"", -1);
3229 result = TCL_ERROR;
3230 goto done;
3231 }
3232 }
3233
3234 /*
3235 * Emit a continue instruction.
3236 */
3237
3238 TclEmitOpcode(INST_CONTINUE, envPtr);
3239
3240 done:
3241 envPtr->termOffset = (src - string);
3242 envPtr->maxStackDepth = 0;
3243 return result;
3244}
3245
3246
3247/*
3248 *----------------------------------------------------------------------
3249 *
3250 * TclCompileExprCmd --
3251 *
3252 * Procedure called to compile the "expr" command.
3253 *
3254 * Results:
3255 * The return value is a standard Tcl result, which is TCL_OK
3256 * unless there was an error while parsing string. If an error occurs
3257 * then the interpreter's result contains a standard error message.
3258 *
3259 * envPtr->termOffset is filled in with the offset of the character in
3260 * "string" just after the last one successfully processed.
3261 *
3262 * envPtr->maxStackDepth is updated with the maximum number of stack
3263 * elements needed to execute the "expr" command.
3264 *
3265 * Side effects:
3266 * Instructions are added to envPtr to evaluate the "expr" command
3267 * at runtime.
3268 *
3269 *----------------------------------------------------------------------
3270 */
3271
3272int
3273TclCompileExprCmd(interp, string, lastChar, flags, envPtr)
3274 Tcl_Interp *interp; /* Used for error reporting. */
3275 char *string; /* The source string to compile. */
3276 char *lastChar; /* Pointer to terminating character of
3277 * string. */
3278 int flags; /* Flags to control compilation (same as
3279 * passed to Tcl_Eval). */
3280 CompileEnv *envPtr; /* Holds resulting instructions. */
3281{
3282 int maxDepth = 0; /* Maximum number of stack elements needed
3283 * to execute cmd. */
3284 ArgInfo argInfo; /* Structure holding information about the
3285 * start and end of each argument word. */
3286 Tcl_DString buffer; /* Holds the concatenated expr command
3287 * argument words. */
3288 int firstWord; /* 1 if processing the first word; 0 if
3289 * processing subsequent words. */
3290 char *first, *last; /* Points to the first and last significant
3291 * chars of the concatenated expression. */
3292 int inlineCode; /* 1 if inline "optimistic" code is
3293 * emitted for the expression; else 0. */
3294 int range = -1; /* If we inline compile the concatenated
3295 * expression, the index for its catch range
3296 * record in the ExceptionRange array.
3297 * Initialized to avoid compile warning. */
3298 JumpFixup jumpFixup; /* Used to emit the "success" jump after
3299 * the inline concat. expression's code. */
3300 char savedChar; /* Holds the character termporarily replaced
3301 * by a null character during compilation
3302 * of the concatenated expression. */
3303 int numWords, objIndex, i, result;
3304 char *wordStart, *wordEnd, *p;
3305 char c;
3306 int savePushSimpleWords = envPtr->pushSimpleWords;
3307 int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
3308 int saveExprIsComparison = envPtr->exprIsComparison;
3309
3310 /*
3311 * Scan the words of the command and record the start and finish of
3312 * each argument word.
3313 */
3314
3315 InitArgInfo(&argInfo);
3316 result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
3317 numWords = argInfo.numArgs; /* i.e., the # after the command name */
3318 if (result != TCL_OK) {
3319 goto done;
3320 }
3321 if (numWords == 0) {
3322 Tcl_ResetResult(interp);
3323 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3324 "wrong # args: should be \"expr arg ?arg ...?\"", -1);
3325 result = TCL_ERROR;
3326 goto done;
3327 }
3328
3329 /*
3330 * If there is a single argument word and it is enclosed in {}s, we may
3331 * strip them off and safely compile the expr command into an inline
3332 * sequence of instructions using TclCompileExpr. We know these
3333 * instructions will have the right Tcl7.x expression semantics.
3334 *
3335 * Otherwise, if the word is not enclosed in {}s, or there are multiple
3336 * words, we may need to call the expr command (Tcl_ExprObjCmd) at
3337 * runtime. This recompiles the expression each time (typically) and so
3338 * is slow. However, there are some circumstances where we can still
3339 * compile inline instructions "optimistically" and check, during their
3340 * execution, for double substitutions (these appear as nonnumeric
3341 * operands). We check for any backslash or command substitutions. If
3342 * none appear, and only variable substitutions are found, we generate
3343 * inline instructions. If there is a compilation error, we must emit
3344 * instructions that return the error at runtime, since this is when
3345 * scripts in Tcl7.x would "see" the error.
3346 *
3347 * For now, if there are multiple words, or the single argument word is
3348 * not in {}s, we concatenate the argument words and strip off any
3349 * enclosing {}s or ""s. We call the expr command at runtime if
3350 * either command or backslash substitutions appear (but not if
3351 * only variable substitutions appear).
3352 */
3353
3354 if (numWords == 1) {
3355 wordStart = argInfo.startArray[0]; /* start of 1st arg word */
3356 wordEnd = argInfo.endArray[0]; /* last char of 1st arg word */
3357 if ((*wordStart == '{') && (*wordEnd == '}')) {
3358 /*
3359 * Simple case: a single argument word in {}'s.
3360 */
3361
3362 *wordEnd = '\0';
3363 result = TclCompileExpr(interp, (wordStart + 1), wordEnd,
3364 flags, envPtr);
3365 *wordEnd = '}';
3366
3367 envPtr->termOffset = (wordEnd + 1) - string;
3368 envPtr->pushSimpleWords = savePushSimpleWords;
3369 FreeArgInfo(&argInfo);
3370 return result;
3371 }
3372 }
3373
3374 /*
3375 * There are multiple words or no braces around the single word.
3376 * Concatenate the expression's argument words while stripping off
3377 * any enclosing {}s or ""s.
3378 */
3379
3380 Tcl_DStringInit(&buffer);
3381 firstWord = 1;
3382 for (i = 0; i < numWords; i++) {
3383 wordStart = argInfo.startArray[i];
3384 wordEnd = argInfo.endArray[i];
3385 if (((*wordStart == '{') && (*wordEnd == '}'))
3386 || ((*wordStart == '"') && (*wordEnd == '"'))) {
3387 wordStart++;
3388 wordEnd--;
3389 }
3390 if (!firstWord) {
3391 Tcl_DStringAppend(&buffer, " ", 1);
3392 }
3393 firstWord = 0;
3394 if (wordEnd >= wordStart) {
3395 Tcl_DStringAppend(&buffer, wordStart, (wordEnd-wordStart+1));
3396 }
3397 }
3398
3399 /*
3400 * Scan the concatenated expression's characters looking for any
3401 * '['s or '\'s or '$'s. If any are found, just call the expr cmd
3402 * at runtime.
3403 */
3404
3405 inlineCode = 1;
3406 first = Tcl_DStringValue(&buffer);
3407 last = first + (Tcl_DStringLength(&buffer) - 1);
3408 for (p = first; p <= last; p++) {
3409 c = *p;
3410 if ((c == '[') || (c == '\\') || (c == '$')) {
3411 inlineCode = 0;
3412 break;
3413 }
3414 }
3415
3416 if (inlineCode) {
3417 /*
3418 * Inline compile the concatenated expression inside a "catch"
3419 * so that a runtime error will back off to a (slow) call on expr.
3420 */
3421
3422 int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
3423 int startRangeNext = envPtr->excRangeArrayNext;
3424
3425 /*
3426 * Create a ExceptionRange record to hold information about the
3427 * "catch" range for the expression's inline code. Also emit the
3428 * instruction to mark the start of the range.
3429 */
3430
3431 envPtr->excRangeDepth++;
3432 envPtr->maxExcRangeDepth =
3433 TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
3434 range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
3435 TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
3436
3437 /*
3438 * Inline compile the concatenated expression.
3439 */
3440
3441 envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
3442 savedChar = *(last + 1);
3443 *(last + 1) = '\0';
3444 result = TclCompileExpr(interp, first, last + 1, flags, envPtr);
3445 *(last + 1) = savedChar;
3446
3447 maxDepth = envPtr->maxStackDepth;
3448 envPtr->excRangeArrayPtr[range].numCodeBytes =
3449 TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
3450
3451 if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
3452 || (envPtr->exprIsComparison)) {
3453 /*
3454 * We must call the expr command at runtime. Either there was a
3455 * compilation error or the inline code might fail to give the
3456 * correct 2 level substitution semantics.
3457 *
3458 * The latter can happen if the expression consisted of just a
3459 * single variable reference or if the top-level operator in the
3460 * expr is a comparison (which might operate on strings). In the
3461 * latter case, the expression's code might execute (apparently)
3462 * successfully but produce the wrong result. We depend on its
3463 * execution failing if a second level of substitutions is
3464 * required. This causes the "catch" code we generate around the
3465 * inline code to back off to a call on the expr command at
3466 * runtime, and this always gives the right 2 level substitution
3467 * semantics.
3468 *
3469 * We delete the inline code by backing up the code pc and catch
3470 * index. Note that if there was a compilation error, we can't
3471 * report the error yet since the expression might be valid
3472 * after the second round of substitutions.
3473 */
3474
3475 envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
3476 envPtr->excRangeArrayNext = startRangeNext;
3477 inlineCode = 0;
3478 } else {
3479 TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */
3480 TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
3481 envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
3482 TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */
3483 }
3484 }
3485
3486 /*
3487 * Emit code for the (slow) call on the expr command at runtime.
3488 * Generate code to concatenate the (already substituted once)
3489 * expression words with a space between each word.
3490 */
3491
3492 for (i = 0; i < numWords; i++) {
3493 wordStart = argInfo.startArray[i];
3494 wordEnd = argInfo.endArray[i];
3495 savedChar = *(wordEnd + 1);
3496 *(wordEnd + 1) = '\0';
3497 envPtr->pushSimpleWords = 1;
3498 result = CompileWord(interp, wordStart, wordEnd+1, flags, envPtr);
3499 *(wordEnd + 1) = savedChar;
3500 if (result != TCL_OK) {
3501 break;
3502 }
3503 if (i != (numWords - 1)) {
3504 objIndex = TclObjIndexForString(" ", 1, /*allocStrRep*/ 1,
3505 /*inHeap*/ 0, envPtr);
3506 TclEmitPush(objIndex, envPtr);
3507 maxDepth = TclMax((envPtr->maxStackDepth + 1), maxDepth);
3508 } else {
3509 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
3510 }
3511 }
3512 if (result == TCL_OK) {
3513 int concatItems = 2*numWords - 1;
3514 while (concatItems > 255) {
3515 TclEmitInstUInt1(INST_CONCAT1, 255, envPtr);
3516 concatItems -= 254; /* concat pushes 1 obj, the result */
3517 }
3518 if (concatItems > 1) {
3519 TclEmitInstUInt1(INST_CONCAT1, concatItems, envPtr);
3520 }
3521 TclEmitOpcode(INST_EXPR_STK, envPtr);
3522 }
3523
3524 /*
3525 * If emitting inline code, update the target of the jump after
3526 * that inline code.
3527 */
3528
3529 if (inlineCode) {
3530 int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
3531 if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
3532 /*
3533 * Update the inline expression code's catch ExceptionRange
3534 * target since it, being after the jump, also moved down.
3535 */
3536
3537 envPtr->excRangeArrayPtr[range].catchOffset += 3;
3538 }
3539 }
3540 Tcl_DStringFree(&buffer);
3541
3542 done:
3543 if (numWords == 0) {
3544 envPtr->termOffset = 0;
3545 } else {
3546 envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
3547 }
3548 if (range != -1) { /* we inline compiled the expr */
3549 envPtr->excRangeDepth--;
3550 }
3551 envPtr->pushSimpleWords = savePushSimpleWords;
3552 envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
3553 envPtr->exprIsComparison = saveExprIsComparison;
3554 envPtr->maxStackDepth = maxDepth;
3555 FreeArgInfo(&argInfo);
3556 return result;
3557}
3558
3559
3560/*
3561 *----------------------------------------------------------------------
3562 *
3563 * TclCompileForCmd --
3564 *
3565 * Procedure called to compile the "for" command.
3566 *
3567 * Results:
3568 * The return value is a standard Tcl result, which is TCL_OK unless
3569 * there was an error while parsing string. If an error occurs then
3570 * the interpreter's result contains a standard error message.
3571 *
3572 * envPtr->termOffset is filled in with the offset of the character in
3573 * "string" just after the last one successfully processed.
3574 *
3575 * envPtr->maxStackDepth is updated with the maximum number of stack
3576 * elements needed to execute the command.
3577 *
3578 * Side effects:
3579 * Instructions are added to envPtr to evaluate the "for" command
3580 * at runtime.
3581 *
3582 *----------------------------------------------------------------------
3583 */
3584
3585int
3586TclCompileForCmd(interp, string, lastChar, flags, envPtr)
3587 Tcl_Interp *interp; /* Used for error reporting. */
3588 char *string; /* The source string to compile. */
3589 char *lastChar; /* Pointer to terminating character of
3590 * string. */
3591 int flags; /* Flags to control compilation (same as
3592 * passed to Tcl_Eval). */
3593 CompileEnv *envPtr; /* Holds resulting instructions. */
3594{
3595 int maxDepth = 0; /* Maximum number of stack elements needed
3596 * to execute cmd. */
3597 ArgInfo argInfo; /* Structure holding information about the
3598 * start and end of each argument word. */
3599 int range1 = -1, range2; /* Indexes in the ExceptionRange array of
3600 * the loop ranges for this loop: one for
3601 * its body and one for its "next" cmd. */
3602 JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
3603 * jump after the "for" test when its target
3604 * PC is determined. */
3605 int jumpBackDist, jumpBackOffset, testCodeOffset, jumpDist, objIndex;
3606 unsigned char *jumpPc;
3607 int savePushSimpleWords = envPtr->pushSimpleWords;
3608 int numWords, result;
3609
3610 /*
3611 * Scan the words of the command and record the start and finish of
3612 * each argument word.
3613 */
3614
3615 InitArgInfo(&argInfo);
3616 result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
3617 numWords = argInfo.numArgs; /* i.e., the # after the command name */
3618 if (result != TCL_OK) {
3619 goto done;
3620 }
3621 if (numWords != 4) {
3622 Tcl_ResetResult(interp);
3623 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3624 "wrong # args: should be \"for start test next command\"", -1);
3625 result = TCL_ERROR;
3626 goto done;
3627 }
3628
3629 /*
3630 * If the test expression is not enclosed in braces, don't compile
3631 * the for inline. As a result of Tcl's two level substitution
3632 * semantics for expressions, the expression might have a constant
3633 * value that results in the loop never executing, or executing forever.
3634 * Consider "set x 0; for {} "$x > 5" {incr x} {}": the loop body
3635 * should never be executed.
3636 * NOTE: This is an overly aggressive test, since there are legitimate
3637 * literals that could be compiled but aren't in braces. However, until
3638 * the parser is integrated in 8.1, this is the simplest implementation.
3639 */
3640
3641 if (*(argInfo.startArray[1]) != '{') {
3642 result = TCL_OUT_LINE_COMPILE;
3643 goto done;
3644 }
3645
3646 /*
3647 * Create a ExceptionRange record for the for loop's body. This is used
3648 * to implement break and continue commands inside the body.
3649 * Then create a second ExceptionRange record for the "next" command in
3650 * order to implement break (but not continue) inside it. The second,
3651 * "next" ExceptionRange will always have a -1 continueOffset.
3652 */
3653
3654 envPtr->excRangeDepth++;
3655 envPtr->maxExcRangeDepth =
3656 TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
3657 range1 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
3658 range2 = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
3659
3660 /*
3661 * Compile inline the next word: the initial command.
3662 */
3663
3664 result = CompileCmdWordInline(interp, argInfo.startArray[0],
3665 (argInfo.endArray[0] + 1), flags, envPtr);
3666 if (result != TCL_OK) {
3667 if (result == TCL_ERROR) {
3668 Tcl_AddObjErrorInfo(interp, "\n (\"for\" initial command)", -1);
3669 }
3670 goto done;
3671 }
3672 maxDepth = envPtr->maxStackDepth;
3673
3674 /*
3675 * Discard the start command's result.
3676 */
3677
3678 TclEmitOpcode(INST_POP, envPtr);
3679
3680 /*
3681 * Compile the next word: the test expression.
3682 */
3683
3684 testCodeOffset = TclCurrCodeOffset();
3685 envPtr->pushSimpleWords = 1; /* process words normally */
3686 result = CompileExprWord(interp, argInfo.startArray[1],
3687 (argInfo.endArray[1] + 1), flags, envPtr);
3688 if (result != TCL_OK) {
3689 if (result == TCL_ERROR) {
3690 Tcl_AddObjErrorInfo(interp, "\n (\"for\" test expression)", -1);
3691 }
3692 goto done;
3693 }
3694 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
3695
3696 /*
3697 * Emit the jump that terminates the for command if the test was
3698 * false. We emit a one byte (relative) jump here, and replace it later
3699 * with a four byte jump if the jump target is > 127 bytes away.
3700 */
3701
3702 TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
3703
3704 /*
3705 * Compile the loop body word inline. Also register the loop body's
3706 * starting PC offset and byte length in the its ExceptionRange record.
3707 */
3708
3709 envPtr->excRangeArrayPtr[range1].codeOffset = TclCurrCodeOffset();
3710 result = CompileCmdWordInline(interp, argInfo.startArray[3],
3711 (argInfo.endArray[3] + 1), flags, envPtr);
3712 if (result != TCL_OK) {
3713 if (result == TCL_ERROR) {
3714 char msg[60];
3715 sprintf(msg, "\n (\"for\" body line %d)", interp->errorLine);
3716 Tcl_AddObjErrorInfo(interp, msg, -1);
3717 }
3718 goto done;
3719 }
3720 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
3721 envPtr->excRangeArrayPtr[range1].numCodeBytes =
3722 (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range1].codeOffset);
3723
3724 /*
3725 * Discard the loop body's result.
3726 */
3727
3728 TclEmitOpcode(INST_POP, envPtr);
3729
3730 /*
3731 * Finally, compile the "next" subcommand word inline.
3732 */
3733
3734 envPtr->excRangeArrayPtr[range1].continueOffset = TclCurrCodeOffset();
3735 envPtr->excRangeArrayPtr[range2].codeOffset = TclCurrCodeOffset();
3736 result = CompileCmdWordInline(interp, argInfo.startArray[2],
3737 (argInfo.endArray[2] + 1), flags, envPtr);
3738 if (result != TCL_OK) {
3739 if (result == TCL_ERROR) {
3740 Tcl_AddObjErrorInfo(interp, "\n (\"for\" loop-end command)", -1);
3741 }
3742 goto done;
3743 }
3744 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
3745 envPtr->excRangeArrayPtr[range2].numCodeBytes =
3746 TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range2].codeOffset;
3747
3748 /*
3749 * Discard the "next" subcommand's result.
3750 */
3751
3752 TclEmitOpcode(INST_POP, envPtr);
3753
3754 /*
3755 * Emit the unconditional jump back to the test at the top of the for
3756 * loop. We generate a four byte jump if the distance to the test is
3757 * greater than 120 bytes. This is conservative, and ensures that we
3758 * won't have to replace this unconditional jump if we later need to
3759 * replace the ifFalse jump with a four-byte jump.
3760 */
3761
3762 jumpBackOffset = TclCurrCodeOffset();
3763 jumpBackDist = (jumpBackOffset - testCodeOffset);
3764 if (jumpBackDist > 120) {
3765 TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
3766 } else {
3767 TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
3768 }
3769
3770 /*
3771 * Now that we know the target of the jumpFalse after the test, update
3772 * it with the correct distance. If the distance is too great (more
3773 * than 127 bytes), replace that jump with a four byte instruction and
3774 * move the instructions after the jump down.
3775 */
3776
3777 jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
3778 if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
3779 /*
3780 * Update the loop body's ExceptionRange record since it moved down:
3781 * i.e., increment both its start and continue PC offsets. Also,
3782 * update the "next" command's start PC offset in its ExceptionRange
3783 * record since it also moved down.
3784 */
3785
3786 envPtr->excRangeArrayPtr[range1].codeOffset += 3;
3787 envPtr->excRangeArrayPtr[range1].continueOffset += 3;
3788 envPtr->excRangeArrayPtr[range2].codeOffset += 3;
3789
3790 /*
3791 * Update the distance for the unconditional jump back to the test
3792 * at the top of the loop since it moved down 3 bytes too.
3793 */
3794
3795 jumpBackOffset += 3;
3796 jumpPc = (envPtr->codeStart + jumpBackOffset);
3797 if (jumpBackDist > 120) {
3798 jumpBackDist += 3;
3799 TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
3800 jumpPc);
3801 } else {
3802 jumpBackDist += 3;
3803 TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
3804 jumpPc);
3805 }
3806 }
3807
3808 /*
3809 * The current PC offset (after the loop's body and "next" subcommand)
3810 * is the loop's break target.
3811 */
3812
3813 envPtr->excRangeArrayPtr[range1].breakOffset =
3814 envPtr->excRangeArrayPtr[range2].breakOffset = TclCurrCodeOffset();
3815
3816 /*
3817 * Push an empty string object as the for command's result.
3818 */
3819
3820 objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
3821 envPtr);
3822 TclEmitPush(objIndex, envPtr);
3823 if (maxDepth == 0) {
3824 maxDepth = 1;
3825 }
3826
3827 done:
3828 if (numWords == 0) {
3829 envPtr->termOffset = 0;
3830 } else {
3831 envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
3832 }
3833 envPtr->pushSimpleWords = savePushSimpleWords;
3834 envPtr->maxStackDepth = maxDepth;
3835 if (range1 != -1) {
3836 envPtr->excRangeDepth--;
3837 }
3838 FreeArgInfo(&argInfo);
3839 return result;
3840}
3841
3842
3843/*
3844 *----------------------------------------------------------------------
3845 *
3846 * TclCompileForeachCmd --
3847 *
3848 * Procedure called to compile the "foreach" command.
3849 *
3850 * Results:
3851 * The return value is a standard Tcl result, which is TCL_OK if
3852 * compilation was successful. If an error occurs then the
3853 * interpreter's result contains a standard error message and TCL_ERROR
3854 * is returned. If complation failed because the command is too complex
3855 * for TclCompileForeachCmd, TCL_OUT_LINE_COMPILE is returned
3856 * indicating that the foreach command should be compiled "out of line"
3857 * by emitting code to invoke its command procedure at runtime.
3858 *
3859 * envPtr->termOffset is filled in with the offset of the character in
3860 * "string" just after the last one successfully processed.
3861 *
3862 * envPtr->maxStackDepth is updated with the maximum number of stack
3863 * elements needed to execute the "while" command.
3864 *
3865 * Side effects:
3866 * Instructions are added to envPtr to evaluate the "foreach" command
3867 * at runtime.
3868 *
3869 *----------------------------------------------------------------------
3870 */
3871
3872int
3873TclCompileForeachCmd(interp, string, lastChar, flags, envPtr)
3874 Tcl_Interp *interp; /* Used for error reporting. */
3875 char *string; /* The source string to compile. */
3876 char *lastChar; /* Pointer to terminating character of
3877 * string. */
3878 int flags; /* Flags to control compilation (same as
3879 * passed to Tcl_Eval). */
3880 CompileEnv *envPtr; /* Holds resulting instructions. */
3881{
3882 Proc *procPtr = envPtr->procPtr;
3883 /* Points to structure describing procedure
3884 * containing foreach command, else NULL. */
3885 int maxDepth = 0; /* Maximum number of stack elements needed
3886 * to execute cmd. */
3887 ArgInfo argInfo; /* Structure holding information about the
3888 * start and end of each argument word. */
3889 int numLists = 0; /* Count of variable (and value) lists. */
3890 int range = -1; /* Index in the ExceptionRange array of the
3891 * ExceptionRange record for this loop. */
3892 ForeachInfo *infoPtr; /* Points to the structure describing this
3893 * foreach command. Stored in a AuxData
3894 * record in the ByteCode. */
3895 JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
3896 * jump after test when its target PC is
3897 * determined. */
3898 char savedChar; /* Holds the char from string termporarily
3899 * replaced by a null character during
3900 * processing of argument words. */
3901 int firstListTmp = -1; /* If we decide to compile this foreach
3902 * command, this is the index or "slot
3903 * number" for the first temp var allocated
3904 * in the proc frame that holds a pointer to
3905 * a value list. Initialized to avoid a
3906 * compiler warning. */
3907 int loopIterNumTmp; /* If we decide to compile this foreach
3908 * command, the index for the temp var that
3909 * holds the current iteration count. */
3910 char *varListStart, *varListEnd, *valueListStart, *bodyStart, *bodyEnd;
3911 unsigned char *jumpPc;
3912 int jumpDist, jumpBackDist, jumpBackOffset;
3913 int numWords, numVars, infoIndex, tmpIndex, objIndex, i, j, result;
3914 int savePushSimpleWords = envPtr->pushSimpleWords;
3915
3916 /*
3917 * We parse the variable list argument words and create two arrays:
3918 * varcList[i] gives the number of variables in the i-th var list
3919 * varvList[i] points to an array of the names in the i-th var list
3920 * These are initially allocated on the stack, and are allocated on
3921 * the heap if necessary.
3922 */
3923
3924#define STATIC_VAR_LIST_SIZE 4
3925 int varcListStaticSpace[STATIC_VAR_LIST_SIZE];
3926 char **varvListStaticSpace[STATIC_VAR_LIST_SIZE];
3927
3928 int *varcList = varcListStaticSpace;
3929 char ***varvList = varvListStaticSpace;
3930
3931 /*
3932 * If the foreach command is at global level (not in a procedure),
3933 * don't compile it inline: the payoff is too small.
3934 */
3935
3936 if (procPtr == NULL) {
3937 return TCL_OUT_LINE_COMPILE;
3938 }
3939
3940 /*
3941 * Scan the words of the command and record the start and finish of
3942 * each argument word.
3943 */
3944
3945 InitArgInfo(&argInfo);
3946 result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
3947 numWords = argInfo.numArgs;
3948 if (result != TCL_OK) {
3949 goto done;
3950 }
3951 if ((numWords < 3) || (numWords%2 != 1)) {
3952 Tcl_ResetResult(interp);
3953 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3954 "wrong # args: should be \"foreach varList list ?varList list ...? command\"", -1);
3955 result = TCL_ERROR;
3956 goto done;
3957 }
3958
3959 /*
3960 * Initialize the varcList and varvList arrays; allocate heap storage,
3961 * if necessary, for them. Also make sure the variable names
3962 * have no substitutions: that they're just "var" or "var(elem)"
3963 */
3964
3965 numLists = (numWords - 1)/2;
3966 if (numLists > STATIC_VAR_LIST_SIZE) {
3967 varcList = (int *) ckalloc(numLists * sizeof(int));
3968 varvList = (char ***) ckalloc(numLists * sizeof(char **));
3969 }
3970 for (i = 0; i < numLists; i++) {
3971 varcList[i] = 0;
3972 varvList[i] = (char **) NULL;
3973 }
3974 for (i = 0; i < numLists; i++) {
3975 /*
3976 * Break each variable list into its component variables. If the
3977 * lists is enclosed in {}s or ""s, strip them off first.
3978 */
3979
3980 varListStart = argInfo.startArray[i*2];
3981 varListEnd = argInfo.endArray[i*2];
3982 if ((*varListStart == '{') || (*varListStart == '"')) {
3983 if ((*varListEnd != '}') && (*varListEnd != '"')) {
3984 Tcl_ResetResult(interp);
3985 if (*varListStart == '"') {
3986 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3987 "extra characters after close-quote", -1);
3988 } else {
3989 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3990 "extra characters after close-brace", -1);
3991 }
3992 result = TCL_ERROR;
3993 goto done;
3994 }
3995 varListStart++;
3996 varListEnd--;
3997 }
3998
3999 /*
4000 * NOTE: THIS NEEDS TO BE CONVERTED TO AN OBJECT LIST.
4001 */
4002
4003 savedChar = *(varListEnd+1);
4004 *(varListEnd+1) = '\0';
4005 result = Tcl_SplitList(interp, varListStart,
4006 &varcList[i], &varvList[i]);
4007 *(varListEnd+1) = savedChar;
4008 if (result != TCL_OK) {
4009 goto done;
4010 }
4011
4012 /*
4013 * Check that each variable name has no substitutions and that
4014 * it is a local scalar name.
4015 */
4016
4017 numVars = varcList[i];
4018 for (j = 0; j < numVars; j++) {
4019 char *varName = varvList[i][j];
4020 if (!IsLocalScalar(varName, (int) strlen(varName))) {
4021 result = TCL_OUT_LINE_COMPILE;
4022 goto done;
4023 }
4024 }
4025 }
4026
4027 /*
4028 *==== At this point we believe we can compile the foreach command ====
4029 */
4030
4031 /*
4032 * Create and initialize a ExceptionRange record to hold information
4033 * about this loop. This is used to implement break and continue.
4034 */
4035
4036 envPtr->excRangeDepth++;
4037 envPtr->maxExcRangeDepth =
4038 TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
4039 range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
4040
4041 /*
4042 * Reserve (numLists + 1) temporary variables:
4043 * - numLists temps for each value list
4044 * - a temp for the "next value" index into each value list
4045 * At this time we don't try to reuse temporaries; if there are two
4046 * nonoverlapping foreach loops, they don't share any temps.
4047 */
4048
4049 for (i = 0; i < numLists; i++) {
4050 tmpIndex = LookupCompiledLocal(NULL, /*nameChars*/ 0,
4051 /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
4052 if (i == 0) {
4053 firstListTmp = tmpIndex;
4054 }
4055 }
4056 loopIterNumTmp = LookupCompiledLocal(NULL, /*nameChars*/ 0,
4057 /*createIfNew*/ 1, /*flagsIfCreated*/ VAR_SCALAR, procPtr);
4058
4059 /*
4060 * Create and initialize the ForeachInfo and ForeachVarList data
4061 * structures describing this command. Then create a AuxData record
4062 * pointing to the ForeachInfo structure in the compilation environment.
4063 */
4064
4065 infoPtr = (ForeachInfo *) ckalloc((unsigned)
4066 (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
4067 infoPtr->numLists = numLists;
4068 infoPtr->firstListTmp = firstListTmp;
4069 infoPtr->loopIterNumTmp = loopIterNumTmp;
4070 for (i = 0; i < numLists; i++) {
4071 ForeachVarList *varListPtr;
4072 numVars = varcList[i];
4073 varListPtr = (ForeachVarList *) ckalloc((unsigned)
4074 sizeof(ForeachVarList) + numVars*sizeof(int));
4075 varListPtr->numVars = numVars;
4076 for (j = 0; j < numVars; j++) {
4077 char *varName = varvList[i][j];
4078 int nameChars = strlen(varName);
4079 varListPtr->varIndexes[j] = LookupCompiledLocal(varName,
4080 nameChars, /*createIfNew*/ 1,
4081 /*flagsIfCreated*/ VAR_SCALAR, procPtr);
4082 }
4083 infoPtr->varLists[i] = varListPtr;
4084 }
4085 infoIndex = TclCreateAuxData((ClientData) infoPtr,
4086 &tclForeachInfoType, envPtr);
4087
4088 /*
4089 * Emit code to store each value list into the associated temporary.
4090 */
4091
4092 for (i = 0; i < numLists; i++) {
4093 valueListStart = argInfo.startArray[2*i + 1];
4094 envPtr->pushSimpleWords = 1;
4095 result = CompileWord(interp, valueListStart, lastChar, flags,
4096 envPtr);
4097 if (result != TCL_OK) {
4098 goto done;
4099 }
4100 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
4101
4102 tmpIndex = (firstListTmp + i);
4103 if (tmpIndex <= 255) {
4104 TclEmitInstUInt1(INST_STORE_SCALAR1, tmpIndex, envPtr);
4105 } else {
4106 TclEmitInstUInt4(INST_STORE_SCALAR4, tmpIndex, envPtr);
4107 }
4108 TclEmitOpcode(INST_POP, envPtr);
4109 }
4110
4111 /*
4112 * Emit the instruction to initialize the foreach loop's index temp var.
4113 */
4114
4115 TclEmitInstUInt4(INST_FOREACH_START4, infoIndex, envPtr);
4116
4117 /*
4118 * Emit the top of loop code that assigns each loop variable and checks
4119 * whether to terminate the loop.
4120 */
4121
4122 envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
4123 TclEmitInstUInt4(INST_FOREACH_STEP4, infoIndex, envPtr);
4124
4125 /*
4126 * Emit the ifFalse jump that terminates the foreach if all value lists
4127 * are exhausted. We emit a one byte (relative) jump here, and replace
4128 * it later with a four byte jump if the jump target is more than
4129 * 127 bytes away.
4130 */
4131
4132 TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
4133
4134 /*
4135 * Compile the loop body word inline. Also register the loop body's
4136 * starting PC offset and byte length in the ExceptionRange record.
4137 */
4138
4139 bodyStart = argInfo.startArray[numWords - 1];
4140 bodyEnd = argInfo.endArray[numWords - 1];
4141 savedChar = *(bodyEnd+1);
4142 *(bodyEnd+1) = '\0';
4143 envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
4144 result = CompileCmdWordInline(interp, bodyStart, bodyEnd+1, flags,
4145 envPtr);
4146 *(bodyEnd+1) = savedChar;
4147 if (result != TCL_OK) {
4148 if (result == TCL_ERROR) {
4149 char msg[60];
4150 sprintf(msg, "\n (\"foreach\" body line %d)",
4151 interp->errorLine);
4152 Tcl_AddObjErrorInfo(interp, msg, -1);
4153 }
4154 goto done;
4155 }
4156 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
4157 envPtr->excRangeArrayPtr[range].numCodeBytes =
4158 TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
4159
4160 /*
4161 * Discard the loop body's result.
4162 */
4163
4164 TclEmitOpcode(INST_POP, envPtr);
4165
4166 /*
4167 * Emit the unconditional jump back to the test at the top of the
4168 * loop. We generate a four byte jump if the distance to the to of
4169 * the foreach is greater than 120 bytes. This is conservative and
4170 * ensures that we won't have to replace this unconditional jump if
4171 * we later need to replace the ifFalse jump with a four-byte jump.
4172 */
4173
4174 jumpBackOffset = TclCurrCodeOffset();
4175 jumpBackDist =
4176 (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
4177 if (jumpBackDist > 120) {
4178 TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
4179 } else {
4180 TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
4181 }
4182
4183 /*
4184 * Now that we know the target of the jumpFalse after the foreach_step
4185 * test, update it with the correct distance. If the distance is too
4186 * great (more than 127 bytes), replace that jump with a four byte
4187 * instruction and move the instructions after the jump down.
4188 */
4189
4190 jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
4191 if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
4192 /*
4193 * Update the loop body's starting PC offset since it moved down.
4194 */
4195
4196 envPtr->excRangeArrayPtr[range].codeOffset += 3;
4197
4198 /*
4199 * Update the distance for the unconditional jump back to the test
4200 * at the top of the loop since it moved down 3 bytes too.
4201 */
4202
4203 jumpBackOffset += 3;
4204 jumpPc = (envPtr->codeStart + jumpBackOffset);
4205 if (jumpBackDist > 120) {
4206 jumpBackDist += 3;
4207 TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
4208 jumpPc);
4209 } else {
4210 jumpBackDist += 3;
4211 TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
4212 jumpPc);
4213 }
4214 }
4215
4216 /*
4217 * The current PC offset (after the loop's body) is the loop's
4218 * break target.
4219 */
4220
4221 envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
4222
4223 /*
4224 * Push an empty string object as the foreach command's result.
4225 */
4226
4227 objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
4228 envPtr);
4229 TclEmitPush(objIndex, envPtr);
4230 if (maxDepth == 0) {
4231 maxDepth = 1;
4232 }
4233
4234 done:
4235 for (i = 0; i < numLists; i++) {
4236 if (varvList[i] != (char **) NULL) {
4237 ckfree((char *) varvList[i]);
4238 }
4239 }
4240 if (varcList != varcListStaticSpace) {
4241 ckfree((char *) varcList);
4242 ckfree((char *) varvList);
4243 }
4244 envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
4245 envPtr->pushSimpleWords = savePushSimpleWords;
4246 envPtr->maxStackDepth = maxDepth;
4247 if (range != -1) {
4248 envPtr->excRangeDepth--;
4249 }
4250 FreeArgInfo(&argInfo);
4251 return result;
4252}
4253
4254
4255/*
4256 *----------------------------------------------------------------------
4257 *
4258 * DupForeachInfo --
4259 *
4260 * This procedure duplicates a ForeachInfo structure created as
4261 * auxiliary data during the compilation of a foreach command.
4262 *
4263 * Results:
4264 * A pointer to a newly allocated copy of the existing ForeachInfo
4265 * structure is returned.
4266 *
4267 * Side effects:
4268 * Storage for the copied ForeachInfo record is allocated. If the
4269 * original ForeachInfo structure pointed to any ForeachVarList
4270 * records, these structures are also copied and pointers to them
4271 * are stored in the new ForeachInfo record.
4272 *
4273 *----------------------------------------------------------------------
4274 */
4275
4276static ClientData
4277DupForeachInfo(clientData)
4278 ClientData clientData; /* The foreach command's compilation
4279 * auxiliary data to duplicate. */
4280{
4281 register ForeachInfo *srcPtr = (ForeachInfo *) clientData;
4282 ForeachInfo *dupPtr;
4283 register ForeachVarList *srcListPtr, *dupListPtr;
4284 int numLists = srcPtr->numLists;
4285 int numVars, i, j;
4286
4287 dupPtr = (ForeachInfo *) ckalloc((unsigned)
4288 (sizeof(ForeachInfo) + (numLists * sizeof(ForeachVarList *))));
4289 dupPtr->numLists = numLists;
4290 dupPtr->firstListTmp = srcPtr->firstListTmp;
4291 dupPtr->loopIterNumTmp = srcPtr->loopIterNumTmp;
4292
4293 for (i = 0; i < numLists; i++) {
4294 srcListPtr = srcPtr->varLists[i];
4295 numVars = srcListPtr->numVars;
4296 dupListPtr = (ForeachVarList *) ckalloc((unsigned)
4297 sizeof(ForeachVarList) + numVars*sizeof(int));
4298 dupListPtr->numVars = numVars;
4299 for (j = 0; j < numVars; j++) {
4300 dupListPtr->varIndexes[j] = srcListPtr->varIndexes[j];
4301 }
4302 dupPtr->varLists[i] = dupListPtr;
4303 }
4304 return (ClientData) dupPtr;
4305}
4306
4307
4308/*
4309 *----------------------------------------------------------------------
4310 *
4311 * FreeForeachInfo --
4312 *
4313 * Procedure to free a ForeachInfo structure created as auxiliary data
4314 * during the compilation of a foreach command.
4315 *
4316 * Results:
4317 * None.
4318 *
4319 * Side effects:
4320 * Storage for the ForeachInfo structure pointed to by the ClientData
4321 * argument is freed as is any ForeachVarList record pointed to by the
4322 * ForeachInfo structure.
4323 *
4324 *----------------------------------------------------------------------
4325 */
4326
4327static void
4328FreeForeachInfo(clientData)
4329 ClientData clientData; /* The foreach command's compilation
4330 * auxiliary data to free. */
4331{
4332 register ForeachInfo *infoPtr = (ForeachInfo *) clientData;
4333 register ForeachVarList *listPtr;
4334 int numLists = infoPtr->numLists;
4335 register int i;
4336
4337 for (i = 0; i < numLists; i++) {
4338 listPtr = infoPtr->varLists[i];
4339 ckfree((char *) listPtr);
4340 }
4341 ckfree((char *) infoPtr);
4342}
4343
4344
4345/*
4346 *----------------------------------------------------------------------
4347 *
4348 * TclCompileIfCmd --
4349 *
4350 * Procedure called to compile the "if" command.
4351 *
4352 * Results:
4353 * The return value is a standard Tcl result, which is TCL_OK unless
4354 * there was an error while parsing string. If an error occurs then
4355 * the interpreter's result contains a standard error message.
4356 *
4357 * envPtr->termOffset is filled in with the offset of the character in
4358 * "string" just after the last one successfully processed.
4359 *
4360 * envPtr->maxStackDepth is updated with the maximum number of stack
4361 * elements needed to execute the command.
4362 *
4363 * Side effects:
4364 * Instructions are added to envPtr to evaluate the "if" command
4365 * at runtime.
4366 *
4367 *----------------------------------------------------------------------
4368 */
4369
4370int
4371TclCompileIfCmd(interp, string, lastChar, flags, envPtr)
4372 Tcl_Interp *interp; /* Used for error reporting. */
4373 char *string; /* The source string to compile. */
4374 char *lastChar; /* Pointer to terminating character of
4375 * string. */
4376 int flags; /* Flags to control compilation (same as
4377 * passed to Tcl_Eval). */
4378 CompileEnv *envPtr; /* Holds resulting instructions. */
4379{
4380 register char *src = string;/* Points to current source char. */
4381 register int type; /* Current char's CHAR_TYPE type. */
4382 int maxDepth = 0; /* Maximum number of stack elements needed
4383 * to execute cmd. */
4384 JumpFixupArray jumpFalseFixupArray;
4385 /* Used to fix up the ifFalse jump after
4386 * each "if"/"elseif" test when its target
4387 * PC is determined. */
4388 JumpFixupArray jumpEndFixupArray;
4389 /* Used to fix up the unconditional jump
4390 * after each "then" command to the end of
4391 * the "if" when that PC is determined. */
4392 char *testSrcStart;
4393 int jumpDist, jumpFalseDist, jumpIndex, objIndex, j, result;
4394 unsigned char *ifFalsePc;
4395 unsigned char opCode;
4396 int savePushSimpleWords = envPtr->pushSimpleWords;
4397
4398 /*
4399 * Loop compiling "expr then body" clauses after an "if" or "elseif".
4400 */
4401
4402 TclInitJumpFixupArray(&jumpFalseFixupArray);
4403 TclInitJumpFixupArray(&jumpEndFixupArray);
4404 while (1) {
4405 /*
4406 * At this point in the loop, we have an expression to test, either
4407 * the main expression or an expression following an "elseif".
4408 * The arguments after the expression must be "then" (optional) and
4409 * a script to execute if the expression is true.
4410 */
4411
4412 AdvanceToNextWord(src, envPtr);
4413 src += envPtr->termOffset;
4414 type = CHAR_TYPE(src, lastChar);
4415 if (type == TCL_COMMAND_END) {
4416 Tcl_ResetResult(interp);
4417 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4418 "wrong # args: no expression after \"if\" argument", -1);
4419 result = TCL_ERROR;
4420 goto done;
4421 }
4422
4423 /*
4424 * Compile the "if"/"elseif" test expression.
4425 */
4426
4427 testSrcStart = src;
4428 envPtr->pushSimpleWords = 1;
4429 result = CompileExprWord(interp, src, lastChar, flags, envPtr);
4430 if (result != TCL_OK) {
4431 if (result == TCL_ERROR) {
4432 Tcl_AddObjErrorInfo(interp,
4433 "\n (\"if\" test expression)", -1);
4434 }
4435 goto done;
4436 }
4437 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
4438 src += envPtr->termOffset;
4439
4440 /*
4441 * Emit the ifFalse jump around the "then" part if the test was
4442 * false. We emit a one byte (relative) jump here, and replace it
4443 * later with a four byte jump if the jump target is more than 127
4444 * bytes away.
4445 */
4446
4447 if (jumpFalseFixupArray.next >= jumpFalseFixupArray.end) {
4448 TclExpandJumpFixupArray(&jumpFalseFixupArray);
4449 }
4450 jumpIndex = jumpFalseFixupArray.next;
4451 jumpFalseFixupArray.next++;
4452 TclEmitForwardJump(envPtr, TCL_FALSE_JUMP,
4453 &(jumpFalseFixupArray.fixup[jumpIndex]));
4454
4455 /*
4456 * Skip over the optional "then" before the then clause.
4457 */
4458
4459 AdvanceToNextWord(src, envPtr);
4460 src += envPtr->termOffset;
4461 type = CHAR_TYPE(src, lastChar);
4462 if (type == TCL_COMMAND_END) {
4463 char buf[100];
4464 sprintf(buf, "wrong # args: no script following \"%.20s\" argument", testSrcStart);
4465 Tcl_ResetResult(interp);
4466 Tcl_AppendToObj(Tcl_GetObjResult(interp), buf, -1);
4467 result = TCL_ERROR;
4468 goto done;
4469 }
4470 if ((*src == 't') && (strncmp(src, "then", 4) == 0)) {
4471 type = CHAR_TYPE(src+4, lastChar);
4472 if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
4473 src += 4;
4474 AdvanceToNextWord(src, envPtr);
4475 src += envPtr->termOffset;
4476 type = CHAR_TYPE(src, lastChar);
4477 if (type == TCL_COMMAND_END) {
4478 Tcl_ResetResult(interp);
4479 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4480 "wrong # args: no script following \"then\" argument", -1);
4481 result = TCL_ERROR;
4482 goto done;
4483 }
4484 }
4485 }
4486
4487 /*
4488 * Compile the "then" command word inline.
4489 */
4490
4491 result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
4492 if (result != TCL_OK) {
4493 if (result == TCL_ERROR) {
4494 char msg[60];
4495 sprintf(msg, "\n (\"if\" then script line %d)",
4496 interp->errorLine);
4497 Tcl_AddObjErrorInfo(interp, msg, -1);
4498 }
4499 goto done;
4500 }
4501 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
4502 src += envPtr->termOffset;
4503
4504 /*
4505 * Emit an unconditional jump to the end of the "if" command. We
4506 * emit a one byte jump here, and replace it later with a four byte
4507 * jump if the jump target is more than 127 bytes away. Note that
4508 * both the jumpFalseFixupArray and the jumpEndFixupArray are
4509 * indexed by the same index, "jumpIndex".
4510 */
4511
4512 if (jumpEndFixupArray.next >= jumpEndFixupArray.end) {
4513 TclExpandJumpFixupArray(&jumpEndFixupArray);
4514 }
4515 jumpEndFixupArray.next++;
4516 TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP,
4517 &(jumpEndFixupArray.fixup[jumpIndex]));
4518
4519 /*
4520 * Now that we know the target of the jumpFalse after the if test,
4521 * update it with the correct distance. We generate a four byte
4522 * jump if the distance is greater than 120 bytes. This is
4523 * conservative, and ensures that we won't have to replace this
4524 * jump if we later also need to replace the preceeding
4525 * unconditional jump to the end of the "if" with a four-byte jump.
4526 */
4527
4528 jumpDist = (TclCurrCodeOffset() - jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
4529 if (TclFixupForwardJump(envPtr,
4530 &(jumpFalseFixupArray.fixup[jumpIndex]), jumpDist, 120)) {
4531 /*
4532 * Adjust the code offset for the unconditional jump at the end
4533 * of the last "then" clause.
4534 */
4535
4536 jumpEndFixupArray.fixup[jumpIndex].codeOffset += 3;
4537 }
4538
4539 /*
4540 * Check now for a "elseif" word. If we find one, keep looping.
4541 */
4542
4543 AdvanceToNextWord(src, envPtr);
4544 src += envPtr->termOffset;
4545 type = CHAR_TYPE(src, lastChar);
4546 if ((type != TCL_COMMAND_END)
4547 && ((*src == 'e') && (strncmp(src, "elseif", 6) == 0))) {
4548 type = CHAR_TYPE(src+6, lastChar);
4549 if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
4550 src += 6;
4551 AdvanceToNextWord(src, envPtr);
4552 src += envPtr->termOffset;
4553 type = CHAR_TYPE(src, lastChar);
4554 if (type == TCL_COMMAND_END) {
4555 Tcl_ResetResult(interp);
4556 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4557 "wrong # args: no expression after \"elseif\" argument", -1);
4558 result = TCL_ERROR;
4559 goto done;
4560 }
4561 continue; /* continue the "expr then body" loop */
4562 }
4563 }
4564 break;
4565 } /* end of the "expr then body" loop */
4566
4567 /*
4568 * No more "elseif expr then body" clauses. Check now for an "else"
4569 * clause. If there is another word, we are at its start.
4570 */
4571
4572 if (type != TCL_COMMAND_END) {
4573 if ((*src == 'e') && (strncmp(src, "else", 4) == 0)) {
4574 type = CHAR_TYPE(src+4, lastChar);
4575 if ((type == TCL_SPACE) || (type == TCL_COMMAND_END)) {
4576 src += 4;
4577 AdvanceToNextWord(src, envPtr);
4578 src += envPtr->termOffset;
4579 type = CHAR_TYPE(src, lastChar);
4580 if (type == TCL_COMMAND_END) {
4581 Tcl_ResetResult(interp);
4582 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4583 "wrong # args: no script following \"else\" argument", -1);
4584 result = TCL_ERROR;
4585 goto done;
4586 }
4587 }
4588 }
4589
4590 /*
4591 * Compile the "else" command word inline.
4592 */
4593
4594 result = CompileCmdWordInline(interp, src, lastChar, flags, envPtr);
4595 if (result != TCL_OK) {
4596 if (result == TCL_ERROR) {
4597 char msg[60];
4598 sprintf(msg, "\n (\"if\" else script line %d)",
4599 interp->errorLine);
4600 Tcl_AddObjErrorInfo(interp, msg, -1);
4601 }
4602 goto done;
4603 }
4604 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
4605 src += envPtr->termOffset;
4606
4607 /*
4608 * Skip over white space until the end of the command.
4609 */
4610
4611 type = CHAR_TYPE(src, lastChar);
4612 if (type != TCL_COMMAND_END) {
4613 AdvanceToNextWord(src, envPtr);
4614 src += envPtr->termOffset;
4615 type = CHAR_TYPE(src, lastChar);
4616 if (type != TCL_COMMAND_END) {
4617 Tcl_ResetResult(interp);
4618 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4619 "wrong # args: extra words after \"else\" clause in \"if\" command", -1);
4620 result = TCL_ERROR;
4621 goto done;
4622 }
4623 }
4624 } else {
4625 /*
4626 * The "if" command has no "else" clause: push an empty string
4627 * object as its result.
4628 */
4629
4630 objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0,
4631 /*inHeap*/ 0, envPtr);
4632 TclEmitPush(objIndex, envPtr);
4633 maxDepth = TclMax(1, maxDepth);
4634 }
4635
4636 /*
4637 * Now that we know the target of the unconditional jumps to the end of
4638 * the "if" command, update them with the correct distance. If the
4639 * distance is too great (> 127 bytes), replace the jump with a four
4640 * byte instruction and move instructions after the jump down.
4641 */
4642
4643 for (j = jumpEndFixupArray.next; j > 0; j--) {
4644 jumpIndex = (j - 1); /* i.e. process the closest jump first */
4645 jumpDist = (TclCurrCodeOffset() - jumpEndFixupArray.fixup[jumpIndex].codeOffset);
4646 if (TclFixupForwardJump(envPtr,
4647 &(jumpEndFixupArray.fixup[jumpIndex]), jumpDist, 127)) {
4648 /*
4649 * Adjust the jump distance for the "ifFalse" jump that
4650 * immediately preceeds this jump. We've moved it's target
4651 * (just after this unconditional jump) three bytes down.
4652 */
4653
4654 ifFalsePc = (envPtr->codeStart + jumpFalseFixupArray.fixup[jumpIndex].codeOffset);
4655 opCode = *ifFalsePc;
4656 if (opCode == INST_JUMP_FALSE1) {
4657 jumpFalseDist = TclGetInt1AtPtr(ifFalsePc + 1);
4658 jumpFalseDist += 3;
4659 TclStoreInt1AtPtr(jumpFalseDist, (ifFalsePc + 1));
4660 } else if (opCode == INST_JUMP_FALSE4) {
4661 jumpFalseDist = TclGetInt4AtPtr(ifFalsePc + 1);
4662 jumpFalseDist += 3;
4663 TclStoreInt4AtPtr(jumpFalseDist, (ifFalsePc + 1));
4664 } else {
4665 panic("TclCompileIfCmd: unexpected opcode updating ifFalse jump");
4666 }
4667 }
4668 }
4669
4670 /*
4671 * Free the jumpFixupArray array if malloc'ed storage was used.
4672 */
4673
4674 done:
4675 TclFreeJumpFixupArray(&jumpFalseFixupArray);
4676 TclFreeJumpFixupArray(&jumpEndFixupArray);
4677 envPtr->termOffset = (src - string);
4678 envPtr->maxStackDepth = maxDepth;
4679 envPtr->pushSimpleWords = savePushSimpleWords;
4680 return result;
4681}
4682
4683
4684/*
4685 *----------------------------------------------------------------------
4686 *
4687 * TclCompileIncrCmd --
4688 *
4689 * Procedure called to compile the "incr" command.
4690 *
4691 * Results:
4692 * The return value is a standard Tcl result, which is TCL_OK unless
4693 * there was an error while parsing string. If an error occurs then
4694 * the interpreter's result contains a standard error message.
4695 *
4696 * envPtr->termOffset is filled in with the offset of the character in
4697 * "string" just after the last one successfully processed.
4698 *
4699 * envPtr->maxStackDepth is updated with the maximum number of stack
4700 * elements needed to execute the "incr" command.
4701 *
4702 * Side effects:
4703 * Instructions are added to envPtr to evaluate the "incr" command
4704 * at runtime.
4705 *
4706 *----------------------------------------------------------------------
4707 */
4708
4709int
4710TclCompileIncrCmd(interp, string, lastChar, flags, envPtr)
4711 Tcl_Interp *interp; /* Used for error reporting. */
4712 char *string; /* The source string to compile. */
4713 char *lastChar; /* Pointer to terminating character of
4714 * string. */
4715 int flags; /* Flags to control compilation (same as
4716 * passed to Tcl_Eval). */
4717 CompileEnv *envPtr; /* Holds resulting instructions. */
4718{
4719 Proc *procPtr = envPtr->procPtr;
4720 /* Points to structure describing procedure
4721 * containing incr command, else NULL. */
4722 register char *src = string;
4723 /* Points to current source char. */
4724 register int type; /* Current char's CHAR_TYPE type. */
4725 int simpleVarName; /* 1 if name is just sequence of chars with
4726 * an optional element name in parens. */
4727 char *name = NULL; /* If simpleVarName, points to first char of
4728 * variable name and nameChars is length.
4729 * Otherwise NULL. */
4730 char *elName = NULL; /* If simpleVarName, points to first char of
4731 * element name and elNameChars is length.
4732 * Otherwise NULL. */
4733 int nameChars = 0; /* Length of the var name. Initialized to
4734 * avoid a compiler warning. */
4735 int elNameChars = 0; /* Length of array's element name, if any.
4736 * Initialized to avoid a compiler
4737 * warning. */
4738 int incrementGiven; /* 1 if an increment amount was given. */
4739 int isImmIncrValue = 0; /* 1 if increment amount is a literal
4740 * integer in [-127..127]. */
4741 int immIncrValue = 0; /* if isImmIncrValue is 1, the immediate
4742 * integer value. */
4743 int maxDepth = 0; /* Maximum number of stack elements needed
4744 * to execute cmd. */
4745 int localIndex = -1; /* Index of the variable in the current
4746 * procedure's array of local variables.
4747 * Otherwise -1 if not in a procedure or
4748 * the variable wasn't found. */
4749 char savedChar; /* Holds the character from string
4750 * termporarily replaced by a null char
4751 * during name processing. */
4752 int objIndex; /* The object array index for a pushed
4753 * object holding a name part. */
4754 int savePushSimpleWords = envPtr->pushSimpleWords;
4755 char *p;
4756 int i, result;
4757
4758 /*
4759 * Parse the next word: the variable name. If it is "simple" (requires
4760 * no substitutions at runtime), divide it up into a simple "name" plus
4761 * an optional "elName". Otherwise, if not simple, just push the name.
4762 */
4763
4764 AdvanceToNextWord(src, envPtr);
4765 src += envPtr->termOffset;
4766 type = CHAR_TYPE(src, lastChar);
4767 if (type == TCL_COMMAND_END) {
4768 badArgs:
4769 Tcl_ResetResult(interp);
4770 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4771 "wrong # args: should be \"incr varName ?increment?\"", -1);
4772 result = TCL_ERROR;
4773 goto done;
4774 }
4775
4776 envPtr->pushSimpleWords = 0;
4777 result = CompileWord(interp, src, lastChar, flags, envPtr);
4778 if (result != TCL_OK) {
4779 goto done;
4780 }
4781 simpleVarName = envPtr->wordIsSimple;
4782 if (simpleVarName) {
4783 name = src;
4784 nameChars = envPtr->numSimpleWordChars;
4785 if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
4786 name++;
4787 }
4788 elName = NULL;
4789 elNameChars = 0;
4790 p = name;
4791 for (i = 0; i < nameChars; i++) {
4792 if (*p == '(') {
4793 char *openParen = p;
4794 p = (src + nameChars-1);
4795 if (*p == ')') { /* last char is ')' => array reference */
4796 nameChars = (openParen - name);
4797 elName = openParen+1;
4798 elNameChars = (p - elName);
4799 }
4800 break;
4801 }
4802 p++;
4803 }
4804 } else {
4805 maxDepth = envPtr->maxStackDepth;
4806 }
4807 src += envPtr->termOffset;
4808
4809 /*
4810 * See if there is a next word. If so, we are incrementing the variable
4811 * by that value (which must be an integer).
4812 */
4813
4814 incrementGiven = 0;
4815 type = CHAR_TYPE(src, lastChar);
4816 if (type != TCL_COMMAND_END) {
4817 AdvanceToNextWord(src, envPtr);
4818 src += envPtr->termOffset;
4819 type = CHAR_TYPE(src, lastChar);
4820 incrementGiven = (type != TCL_COMMAND_END);
4821 }
4822
4823 /*
4824 * Non-simple names have already been pushed. If this is a simple
4825 * variable, either push its name (if a global or an unknown local
4826 * variable) or look up the variable's local frame index. If a local is
4827 * not found, push its name and do the lookup at runtime. If this is an
4828 * array reference, also push the array element.
4829 */
4830
4831 if (simpleVarName) {
4832 if (procPtr == NULL) {
4833 savedChar = name[nameChars];
4834 name[nameChars] = '\0';
4835 objIndex = TclObjIndexForString(name, nameChars,
4836 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
4837 name[nameChars] = savedChar;
4838 TclEmitPush(objIndex, envPtr);
4839 maxDepth = 1;
4840 } else {
4841 localIndex = LookupCompiledLocal(name, nameChars,
4842 /*createIfNew*/ 0, /*flagsIfCreated*/ 0,
4843 envPtr->procPtr);
4844 if ((localIndex < 0) || (localIndex > 255)) {
4845 if (localIndex > 255) { /* we'll push the name */
4846 localIndex = -1;
4847 }
4848 savedChar = name[nameChars];
4849 name[nameChars] = '\0';
4850 objIndex = TclObjIndexForString(name, nameChars,
4851 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
4852 name[nameChars] = savedChar;
4853 TclEmitPush(objIndex, envPtr);
4854 maxDepth = 1;
4855 } else {
4856 maxDepth = 0;
4857 }
4858 }
4859
4860 if (elName != NULL) {
4861 /*
4862 * Parse and push the array element's name. Perform
4863 * substitutions on it, just as is done for quoted strings.
4864 */
4865
4866 savedChar = elName[elNameChars];
4867 elName[elNameChars] = '\0';
4868 envPtr->pushSimpleWords = 1;
4869 result = TclCompileQuotes(interp, elName, elName+elNameChars,
4870 0, flags, envPtr);
4871 elName[elNameChars] = savedChar;
4872 if (result != TCL_OK) {
4873 char msg[200];
4874 sprintf(msg, "\n (parsing index for array \"%.*s\")",
4875 TclMin(nameChars, 100), name);
4876 Tcl_AddObjErrorInfo(interp, msg, -1);
4877 goto done;
4878 }
4879 maxDepth += envPtr->maxStackDepth;
4880 }
4881 }
4882
4883 /*
4884 * If an increment was given, push the new value.
4885 */
4886
4887 if (incrementGiven) {
4888 type = CHAR_TYPE(src, lastChar);
4889 envPtr->pushSimpleWords = 0;
4890 result = CompileWord(interp, src, lastChar, flags, envPtr);
4891 if (result != TCL_OK) {
4892 if (result == TCL_ERROR) {
4893 Tcl_AddObjErrorInfo(interp,
4894 "\n (increment expression)", -1);
4895 }
4896 goto done;
4897 }
4898 if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
4899 src++;
4900 }
4901 if (envPtr->wordIsSimple) {
4902 /*
4903 * See if the word represents an integer whose formatted
4904 * representation is the same as the word (e.g., this is
4905 * true for 123 and -1 but not for 00005). If so, just
4906 * push an integer object.
4907 */
4908
4909 int isCompilableInt = 0;
4910 int numChars = envPtr->numSimpleWordChars;
4911 char savedChar = src[numChars];
4912 char buf[40];
4913 Tcl_Obj *objPtr;
4914 long n;
4915
4916 src[numChars] = '\0';
4917 if (TclLooksLikeInt(src)) {
4918 int code = TclGetLong(interp, src, &n);
4919 if (code == TCL_OK) {
4920 if ((-127 <= n) && (n <= 127)) {
4921 isCompilableInt = 1;
4922 isImmIncrValue = 1;
4923 immIncrValue = n;
4924 } else {
4925 TclFormatInt(buf, n);
4926 if (strcmp(src, buf) == 0) {
4927 isCompilableInt = 1;
4928 isImmIncrValue = 0;
4929 objIndex = TclObjIndexForString(src, numChars,
4930 /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
4931 objPtr = envPtr->objArrayPtr[objIndex];
4932
4933 Tcl_InvalidateStringRep(objPtr);
4934 objPtr->internalRep.longValue = n;
4935 objPtr->typePtr = &tclIntType;
4936
4937 TclEmitPush(objIndex, envPtr);
4938 maxDepth += 1;
4939 }
4940 }
4941 } else {
4942 Tcl_ResetResult(interp);
4943 }
4944 }
4945 if (!isCompilableInt) {
4946 objIndex = TclObjIndexForString(src, numChars,
4947 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
4948 TclEmitPush(objIndex, envPtr);
4949 maxDepth += 1;
4950 }
4951 src[numChars] = savedChar;
4952 } else {
4953 maxDepth += envPtr->maxStackDepth;
4954 }
4955 if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
4956 src += (envPtr->termOffset - 1); /* already advanced 1 above */
4957 } else {
4958 src += envPtr->termOffset;
4959 }
4960 } else { /* no incr amount given so use 1 */
4961 isImmIncrValue = 1;
4962 immIncrValue = 1;
4963 }
4964
4965 /*
4966 * Now emit instructions to increment the variable.
4967 */
4968
4969 if (simpleVarName) {
4970 if (elName == NULL) { /* scalar */
4971 if (localIndex >= 0) {
4972 if (isImmIncrValue) {
4973 TclEmitInstUInt1(INST_INCR_SCALAR1_IMM, localIndex,
4974 envPtr);
4975 TclEmitInt1(immIncrValue, envPtr);
4976 } else {
4977 TclEmitInstUInt1(INST_INCR_SCALAR1, localIndex, envPtr);
4978 }
4979 } else {
4980 if (isImmIncrValue) {
4981 TclEmitInstInt1(INST_INCR_SCALAR_STK_IMM, immIncrValue,
4982 envPtr);
4983 } else {
4984 TclEmitOpcode(INST_INCR_SCALAR_STK, envPtr);
4985 }
4986 }
4987 } else { /* array */
4988 if (localIndex >= 0) {
4989 if (isImmIncrValue) {
4990 TclEmitInstUInt1(INST_INCR_ARRAY1_IMM, localIndex,
4991 envPtr);
4992 TclEmitInt1(immIncrValue, envPtr);
4993 } else {
4994 TclEmitInstUInt1(INST_INCR_ARRAY1, localIndex, envPtr);
4995 }
4996 } else {
4997 if (isImmIncrValue) {
4998 TclEmitInstInt1(INST_INCR_ARRAY_STK_IMM, immIncrValue,
4999 envPtr);
5000 } else {
5001 TclEmitOpcode(INST_INCR_ARRAY_STK, envPtr);
5002 }
5003 }
5004 }
5005 } else { /* non-simple variable name */
5006 if (isImmIncrValue) {
5007 TclEmitInstInt1(INST_INCR_STK_IMM, immIncrValue, envPtr);
5008 } else {
5009 TclEmitOpcode(INST_INCR_STK, envPtr);
5010 }
5011 }
5012
5013 /*
5014 * Skip over white space until the end of the command.
5015 */
5016
5017 type = CHAR_TYPE(src, lastChar);
5018 if (type != TCL_COMMAND_END) {
5019 AdvanceToNextWord(src, envPtr);
5020 src += envPtr->termOffset;
5021 type = CHAR_TYPE(src, lastChar);
5022 if (type != TCL_COMMAND_END) {
5023 goto badArgs;
5024 }
5025 }
5026
5027 done:
5028 envPtr->termOffset = (src - string);
5029 envPtr->maxStackDepth = maxDepth;
5030 envPtr->pushSimpleWords = savePushSimpleWords;
5031 return result;
5032}
5033
5034
5035/*
5036 *----------------------------------------------------------------------
5037 *
5038 * TclCompileSetCmd --
5039 *
5040 * Procedure called to compile the "set" command.
5041 *
5042 * Results:
5043 * The return value is a standard Tcl result, which is normally TCL_OK
5044 * unless there was an error while parsing string. If an error occurs
5045 * then the interpreter's result contains a standard error message. If
5046 * complation fails because the set command requires a second level of
5047 * substitutions, TCL_OUT_LINE_COMPILE is returned indicating that the
5048 * set command should be compiled "out of line" by emitting code to
5049 * invoke its command procedure (Tcl_SetCmd) at runtime.
5050 *
5051 * envPtr->termOffset is filled in with the offset of the character in
5052 * "string" just after the last one successfully processed.
5053 *
5054 * envPtr->maxStackDepth is updated with the maximum number of stack
5055 * elements needed to execute the incr command.
5056 *
5057 * Side effects:
5058 * Instructions are added to envPtr to evaluate the "set" command
5059 * at runtime.
5060 *
5061 *----------------------------------------------------------------------
5062 */
5063
5064int
5065TclCompileSetCmd(interp, string, lastChar, flags, envPtr)
5066 Tcl_Interp *interp; /* Used for error reporting. */
5067 char *string; /* The source string to compile. */
5068 char *lastChar; /* Pointer to terminating character of
5069 * string. */
5070 int flags; /* Flags to control compilation (same as
5071 * passed to Tcl_Eval). */
5072 CompileEnv *envPtr; /* Holds resulting instructions. */
5073{
5074 Proc *procPtr = envPtr->procPtr;
5075 /* Points to structure describing procedure
5076 * containing the set command, else NULL. */
5077 ArgInfo argInfo; /* Structure holding information about the
5078 * start and end of each argument word. */
5079 int simpleVarName; /* 1 if name is just sequence of chars with
5080 * an optional element name in parens. */
5081 char *elName = NULL; /* If simpleVarName, points to first char of
5082 * element name and elNameChars is length.
5083 * Otherwise NULL. */
5084 int isAssignment; /* 1 if assigning value to var, else 0. */
5085 int maxDepth = 0; /* Maximum number of stack elements needed
5086 * to execute cmd. */
5087 int localIndex = -1; /* Index of the variable in the current
5088 * procedure's array of local variables.
5089 * Otherwise -1 if not in a procedure, the
5090 * name contains "::"s, or the variable
5091 * wasn't found. */
5092 char savedChar; /* Holds the character from string
5093 * termporarily replaced by a null char
5094 * during name processing. */
5095 int objIndex = -1; /* The object array index for a pushed
5096 * object holding a name part. Initialized
5097 * to avoid a compiler warning. */
5098 char *wordStart, *p;
5099 int numWords, isCompilableInt, i, result;
5100 Tcl_Obj *objPtr;
5101 int savePushSimpleWords = envPtr->pushSimpleWords;
5102
5103 /*
5104 * Scan the words of the command and record the start and finish of
5105 * each argument word.
5106 */
5107
5108 InitArgInfo(&argInfo);
5109 result = CollectArgInfo(interp, string, lastChar, flags, &argInfo);
5110 numWords = argInfo.numArgs; /* i.e., the # after the command name */
5111 if (result != TCL_OK) {
5112 goto done;
5113 }
5114 if ((numWords < 1) || (numWords > 2)) {
5115 Tcl_ResetResult(interp);
5116 Tcl_AppendToObj(Tcl_GetObjResult(interp),
5117 "wrong # args: should be \"set varName ?newValue?\"", -1);
5118 result = TCL_ERROR;
5119 goto done;
5120 }
5121 isAssignment = (numWords == 2);
5122
5123 /*
5124 * Parse the next word: the variable name. If the name is enclosed in
5125 * quotes or braces, we return TCL_OUT_LINE_COMPILE and call the set
5126 * command procedure at runtime since this makes sure that a second
5127 * round of substitutions is done properly.
5128 */
5129
5130 wordStart = argInfo.startArray[0]; /* start of 1st arg word: varname */
5131 if ((*wordStart == '{') || (*wordStart == '"')) {
5132 result = TCL_OUT_LINE_COMPILE;
5133 goto done;
5134 }
5135
5136 /*
5137 * Check whether the name is "simple": requires no substitutions at
5138 * runtime.
5139 */
5140
5141 envPtr->pushSimpleWords = 0;
5142 result = CompileWord(interp, wordStart, argInfo.endArray[0] + 1,
5143 flags, envPtr);
5144 if (result != TCL_OK) {
5145 goto done;
5146 }
5147 simpleVarName = envPtr->wordIsSimple;
5148
5149 if (!simpleVarName) {
5150 /*
5151 * The name isn't simple. CompileWord already pushed it.
5152 */
5153
5154 maxDepth = envPtr->maxStackDepth;
5155 } else {
5156 char *name; /* If simpleVarName, points to first char of
5157 * variable name and nameChars is length.
5158 * Otherwise NULL. */
5159 int nameChars; /* Length of the var name. */
5160 int nameHasNsSeparators = 0;
5161 /* Set 1 if name contains "::"s. */
5162 int elNameChars; /* Length of array's element name if any. */
5163
5164 /*
5165 * A simple name. First divide it up into "name" plus "elName"
5166 * for an array element name, if any.
5167 */
5168
5169 name = wordStart;
5170 nameChars = envPtr->numSimpleWordChars;
5171 elName = NULL;
5172 elNameChars = 0;
5173
5174 p = name;
5175 for (i = 0; i < nameChars; i++) {
5176 if (*p == '(') {
5177 char *openParen = p;
5178 p = (name + nameChars-1);
5179 if (*p == ')') { /* last char is ')' => array reference */
5180 nameChars = (openParen - name);
5181 elName = openParen+1;
5182 elNameChars = (p - elName);
5183 }
5184 break;
5185 }
5186 p++;
5187 }
5188
5189 /*
5190 * Determine if name has any namespace separators (::'s).
5191 */
5192
5193 p = name;
5194 for (i = 0; i < nameChars; i++) {
5195 if ((*p == ':') && ((i+1) < nameChars) && (*(p+1) == ':')) {
5196 nameHasNsSeparators = 1;
5197 break;
5198 }
5199 p++;
5200 }
5201
5202 /*
5203 * Now either push the name or determine its index in the array of
5204 * local variables in a procedure frame. Note that if we are
5205 * compiling a procedure the variable must be local unless its
5206 * name has namespace separators ("::"s). Note also that global
5207 * variables are implemented by a local variable that "points" to
5208 * the real global. There are two cases:
5209 * 1) We are not compiling a procedure body. Push the global
5210 * variable's name and do the lookup at runtime.
5211 * 2) We are compiling a procedure and the name has "::"s.
5212 * Push the namespace variable's name and do the lookup at
5213 * runtime.
5214 * 3) We are compiling a procedure and the name has no "::"s.
5215 * If the variable has already been allocated an local index,
5216 * just look it up. If the variable is unknown and we are
5217 * doing an assignment, allocate a new index. Otherwise,
5218 * push the name and try to do the lookup at runtime.
5219 */
5220
5221 if ((procPtr == NULL) || nameHasNsSeparators) {
5222 savedChar = name[nameChars];
5223 name[nameChars] = '\0';
5224 objIndex = TclObjIndexForString(name, nameChars,
5225 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
5226 name[nameChars] = savedChar;
5227 TclEmitPush(objIndex, envPtr);
5228 maxDepth = 1;
5229 } else {
5230 localIndex = LookupCompiledLocal(name, nameChars,
5231 /*createIfNew*/ isAssignment,
5232 /*flagsIfCreated*/
5233 ((elName == NULL)? VAR_SCALAR : VAR_ARRAY),
5234 envPtr->procPtr);
5235 if (localIndex >= 0) {
5236 maxDepth = 0;
5237 } else {
5238 savedChar = name[nameChars];
5239 name[nameChars] = '\0';
5240 objIndex = TclObjIndexForString(name, nameChars,
5241 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
5242 name[nameChars] = savedChar;
5243 TclEmitPush(objIndex, envPtr);
5244 maxDepth = 1;
5245 }
5246 }
5247
5248 /*
5249 * If we are dealing with a reference to an array element, push the
5250 * array element. Perform substitutions on it, just as is done
5251 * for quoted strings.
5252 */
5253
5254 if (elName != NULL) {
5255 savedChar = elName[elNameChars];
5256 elName[elNameChars] = '\0';
5257 envPtr->pushSimpleWords = 1;
5258 result = TclCompileQuotes(interp, elName, elName+elNameChars,
5259 0, flags, envPtr);
5260 elName[elNameChars] = savedChar;
5261 if (result != TCL_OK) {
5262 char msg[200];
5263 sprintf(msg, "\n (parsing index for array \"%.*s\")",
5264 TclMin(nameChars, 100), name);
5265 Tcl_AddObjErrorInfo(interp, msg, -1);
5266 goto done;
5267 }
5268 maxDepth += envPtr->maxStackDepth;
5269 }
5270 }
5271
5272 /*
5273 * If we are doing an assignment, push the new value.
5274 */
5275
5276 if (isAssignment) {
5277 wordStart = argInfo.startArray[1]; /* start of 2nd arg word */
5278 envPtr->pushSimpleWords = 0; /* we will handle simple words */
5279 result = CompileWord(interp, wordStart, argInfo.endArray[1] + 1,
5280 flags, envPtr);
5281 if (result != TCL_OK) {
5282 goto done;
5283 }
5284 if (!envPtr->wordIsSimple) {
5285 /*
5286 * The value isn't simple. CompileWord already pushed it.
5287 */
5288
5289 maxDepth += envPtr->maxStackDepth;
5290 } else {
5291 /*
5292 * The value is simple. See if the word represents an integer
5293 * whose formatted representation is the same as the word (e.g.,
5294 * this is true for 123 and -1 but not for 00005). If so, just
5295 * push an integer object.
5296 */
5297
5298 char buf[40];
5299 long n;
5300
5301 p = wordStart;
5302 if ((*wordStart == '"') || (*wordStart == '{')) {
5303 p++;
5304 }
5305 savedChar = p[envPtr->numSimpleWordChars];
5306 p[envPtr->numSimpleWordChars] = '\0';
5307 isCompilableInt = 0;
5308 if (TclLooksLikeInt(p)) {
5309 int code = TclGetLong(interp, p, &n);
5310 if (code == TCL_OK) {
5311 TclFormatInt(buf, n);
5312 if (strcmp(p, buf) == 0) {
5313 isCompilableInt = 1;
5314 objIndex = TclObjIndexForString(p,
5315 envPtr->numSimpleWordChars,
5316 /*allocStrRep*/ 0, /*inHeap*/ 0, envPtr);
5317 objPtr = envPtr->objArrayPtr[objIndex];
5318
5319 Tcl_InvalidateStringRep(objPtr);
5320 objPtr->internalRep.longValue = n;
5321 objPtr->typePtr = &tclIntType;
5322 }
5323 } else {
5324 Tcl_ResetResult(interp);
5325 }
5326 }
5327 if (!isCompilableInt) {
5328 objIndex = TclObjIndexForString(p,
5329 envPtr->numSimpleWordChars, /*allocStrRep*/ 1,
5330 /*inHeap*/ 0, envPtr);
5331 }
5332 p[envPtr->numSimpleWordChars] = savedChar;
5333 TclEmitPush(objIndex, envPtr);
5334 maxDepth += 1;
5335 }
5336 }
5337
5338 /*
5339 * Now emit instructions to set/retrieve the variable.
5340 */
5341
5342 if (simpleVarName) {
5343 if (elName == NULL) { /* scalar */
5344 if (localIndex >= 0) {
5345 if (localIndex <= 255) {
5346 TclEmitInstUInt1((isAssignment?
5347 INST_STORE_SCALAR1 : INST_LOAD_SCALAR1),
5348 localIndex, envPtr);
5349 } else {
5350 TclEmitInstUInt4((isAssignment?
5351 INST_STORE_SCALAR4 : INST_LOAD_SCALAR4),
5352 localIndex, envPtr);
5353 }
5354 } else {
5355 TclEmitOpcode((isAssignment?
5356 INST_STORE_SCALAR_STK : INST_LOAD_SCALAR_STK),
5357 envPtr);
5358 }
5359 } else { /* array */
5360 if (localIndex >= 0) {
5361 if (localIndex <= 255) {
5362 TclEmitInstUInt1((isAssignment?
5363 INST_STORE_ARRAY1 : INST_LOAD_ARRAY1),
5364 localIndex, envPtr);
5365 } else {
5366 TclEmitInstUInt4((isAssignment?
5367 INST_STORE_ARRAY4 : INST_LOAD_ARRAY4),
5368 localIndex, envPtr);
5369 }
5370 } else {
5371 TclEmitOpcode((isAssignment?
5372 INST_STORE_ARRAY_STK : INST_LOAD_ARRAY_STK),
5373 envPtr);
5374 }
5375 }
5376 } else { /* non-simple variable name */
5377 TclEmitOpcode((isAssignment? INST_STORE_STK : INST_LOAD_STK), envPtr);
5378 }
5379
5380 done:
5381 if (numWords == 0) {
5382 envPtr->termOffset = 0;
5383 } else {
5384 envPtr->termOffset = (argInfo.endArray[numWords-1] + 1 - string);
5385 }
5386 envPtr->pushSimpleWords = savePushSimpleWords;
5387 envPtr->maxStackDepth = maxDepth;
5388 FreeArgInfo(&argInfo);
5389 return result;
5390}
5391
5392
5393/*
5394 *----------------------------------------------------------------------
5395 *
5396 * TclCompileWhileCmd --
5397 *
5398 * Procedure called to compile the "while" command.
5399 *
5400 * Results:
5401 * The return value is a standard Tcl result, which is TCL_OK if
5402 * compilation was successful. If an error occurs then the
5403 * interpreter's result contains a standard error message and TCL_ERROR
5404 * is returned. If compilation failed because the command is too
5405 * complex for TclCompileWhileCmd, TCL_OUT_LINE_COMPILE is returned
5406 * indicating that the while command should be compiled "out of line"
5407 * by emitting code to invoke its command procedure at runtime.
5408 *
5409 * envPtr->termOffset is filled in with the offset of the character in
5410 * "string" just after the last one successfully processed.
5411 *
5412 * envPtr->maxStackDepth is updated with the maximum number of stack
5413 * elements needed to execute the "while" command.
5414 *
5415 * Side effects:
5416 * Instructions are added to envPtr to evaluate the "while" command
5417 * at runtime.
5418 *
5419 *----------------------------------------------------------------------
5420 */
5421
5422int
5423TclCompileWhileCmd(interp, string, lastChar, flags, envPtr)
5424 Tcl_Interp *interp; /* Used for error reporting. */
5425 char *string; /* The source string to compile. */
5426 char *lastChar; /* Pointer to terminating character of
5427 * string. */
5428 int flags; /* Flags to control compilation (same as
5429 * passed to Tcl_Eval). */
5430 CompileEnv *envPtr; /* Holds resulting instructions. */
5431{
5432 register char *src = string;/* Points to current source char. */
5433 register int type; /* Current char's CHAR_TYPE type. */
5434 int maxDepth = 0; /* Maximum number of stack elements needed
5435 * to execute cmd. */
5436 int range = -1; /* Index in the ExceptionRange array of the
5437 * ExceptionRange record for this loop. */
5438 JumpFixup jumpFalseFixup; /* Used to update or replace the ifFalse
5439 * jump after test when its target PC is
5440 * determined. */
5441 unsigned char *jumpPc;
5442 int jumpDist, jumpBackDist, jumpBackOffset, objIndex, result;
5443 int savePushSimpleWords = envPtr->pushSimpleWords;
5444
5445 AdvanceToNextWord(src, envPtr);
5446 src += envPtr->termOffset;
5447 type = CHAR_TYPE(src, lastChar);
5448 if (type == TCL_COMMAND_END) {
5449 badArgs:
5450 Tcl_ResetResult(interp);
5451 Tcl_AppendToObj(Tcl_GetObjResult(interp),
5452 "wrong # args: should be \"while test command\"", -1);
5453 result = TCL_ERROR;
5454 goto done;
5455 }
5456
5457 /*
5458 * If the test expression is not enclosed in braces, don't compile
5459 * the while inline. As a result of Tcl's two level substitution
5460 * semantics for expressions, the expression might have a constant
5461 * value that results in the loop never executing, or executing forever.
5462 * Consider "set x 0; whie "$x > 5" {incr x}": the loop body
5463 * should never be executed.
5464 * NOTE: This is an overly aggressive test, since there are legitimate
5465 * literals that could be compiled but aren't in braces. However, until
5466 * the parser is integrated in 8.1, this is the simplest implementation.
5467 */
5468
5469 if (*src != '{') {
5470 result = TCL_OUT_LINE_COMPILE;
5471 goto done;
5472 }
5473
5474 /*
5475 * Create and initialize a ExceptionRange record to hold information
5476 * about this loop. This is used to implement break and continue.
5477 */
5478
5479 envPtr->excRangeDepth++;
5480 envPtr->maxExcRangeDepth =
5481 TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
5482
5483 range = CreateExceptionRange(LOOP_EXCEPTION_RANGE, envPtr);
5484 envPtr->excRangeArrayPtr[range].continueOffset = TclCurrCodeOffset();
5485
5486 /*
5487 * Compile the next word: the test expression.
5488 */
5489
5490 envPtr->pushSimpleWords = 1;
5491 result = CompileExprWord(interp, src, lastChar, flags, envPtr);
5492 if (result != TCL_OK) {
5493 if (result == TCL_ERROR) {
5494 Tcl_AddObjErrorInfo(interp,
5495 "\n (\"while\" test expression)", -1);
5496 }
5497 goto done;
5498 }
5499 maxDepth = envPtr->maxStackDepth;
5500 src += envPtr->termOffset;
5501
5502 /*
5503 * Emit the ifFalse jump that terminates the while if the test was
5504 * false. We emit a one byte (relative) jump here, and replace it
5505 * later with a four byte jump if the jump target is more than
5506 * 127 bytes away.
5507 */
5508
5509 TclEmitForwardJump(envPtr, TCL_FALSE_JUMP, &jumpFalseFixup);
5510
5511 /*
5512 * Compile the loop body word inline. Also register the loop body's
5513 * starting PC offset and byte length in the its ExceptionRange record.
5514 */
5515
5516 AdvanceToNextWord(src, envPtr);
5517 src += envPtr->termOffset;
5518 type = CHAR_TYPE(src, lastChar);
5519 if (type == TCL_COMMAND_END) {
5520 goto badArgs;
5521 }
5522
5523 envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
5524 result = CompileCmdWordInline(interp, src, lastChar,
5525 flags, envPtr);
5526 if (result != TCL_OK) {
5527 if (result == TCL_ERROR) {
5528 char msg[60];
5529 sprintf(msg, "\n (\"while\" body line %d)", interp->errorLine);
5530 Tcl_AddObjErrorInfo(interp, msg, -1);
5531 }
5532 goto done;
5533 }
5534 maxDepth = TclMax(envPtr->maxStackDepth, maxDepth);
5535 src += envPtr->termOffset;
5536 envPtr->excRangeArrayPtr[range].numCodeBytes =
5537 (TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset);
5538
5539 /*
5540 * Discard the loop body's result.
5541 */
5542
5543 TclEmitOpcode(INST_POP, envPtr);
5544
5545 /*
5546 * Emit the unconditional jump back to the test at the top of the
5547 * loop. We generate a four byte jump if the distance to the while's
5548 * test is greater than 120 bytes. This is conservative, and ensures
5549 * that we won't have to replace this unconditional jump if we later
5550 * need to replace the ifFalse jump with a four-byte jump.
5551 */
5552
5553 jumpBackOffset = TclCurrCodeOffset();
5554 jumpBackDist =
5555 (jumpBackOffset - envPtr->excRangeArrayPtr[range].continueOffset);
5556 if (jumpBackDist > 120) {
5557 TclEmitInstInt4(INST_JUMP4, /*offset*/ -jumpBackDist, envPtr);
5558 } else {
5559 TclEmitInstInt1(INST_JUMP1, /*offset*/ -jumpBackDist, envPtr);
5560 }
5561
5562 /*
5563 * Now that we know the target of the jumpFalse after the test, update
5564 * it with the correct distance. If the distance is too great (more
5565 * than 127 bytes), replace that jump with a four byte instruction and
5566 * move the instructions after the jump down.
5567 */
5568
5569 jumpDist = (TclCurrCodeOffset() - jumpFalseFixup.codeOffset);
5570 if (TclFixupForwardJump(envPtr, &jumpFalseFixup, jumpDist, 127)) {
5571 /*
5572 * Update the loop body's starting PC offset since it moved down.
5573 */
5574
5575 envPtr->excRangeArrayPtr[range].codeOffset += 3;
5576
5577 /*
5578 * Update the distance for the unconditional jump back to the test
5579 * at the top of the loop since it moved down 3 bytes too.
5580 */
5581
5582 jumpBackOffset += 3;
5583 jumpPc = (envPtr->codeStart + jumpBackOffset);
5584 if (jumpBackDist > 120) {
5585 jumpBackDist += 3;
5586 TclUpdateInstInt4AtPc(INST_JUMP4, /*offset*/ -jumpBackDist,
5587 jumpPc);
5588 } else {
5589 jumpBackDist += 3;
5590 TclUpdateInstInt1AtPc(INST_JUMP1, /*offset*/ -jumpBackDist,
5591 jumpPc);
5592 }
5593 }
5594
5595 /*
5596 * The current PC offset (after the loop's body) is the loop's
5597 * break target.
5598 */
5599
5600 envPtr->excRangeArrayPtr[range].breakOffset = TclCurrCodeOffset();
5601
5602 /*
5603 * Push an empty string object as the while command's result.
5604 */
5605
5606 objIndex = TclObjIndexForString("", 0, /*allocStrRep*/ 0, /*inHeap*/ 0,
5607 envPtr);
5608 TclEmitPush(objIndex, envPtr);
5609 if (maxDepth == 0) {
5610 maxDepth = 1;
5611 }
5612
5613 /*
5614 * Skip over white space until the end of the command.
5615 */
5616
5617 type = CHAR_TYPE(src, lastChar);
5618 if (type != TCL_COMMAND_END) {
5619 AdvanceToNextWord(src, envPtr);
5620 src += envPtr->termOffset;
5621 type = CHAR_TYPE(src, lastChar);
5622 if (type != TCL_COMMAND_END) {
5623 goto badArgs;
5624 }
5625 }
5626
5627 done:
5628 envPtr->termOffset = (src - string);
5629 envPtr->pushSimpleWords = savePushSimpleWords;
5630 envPtr->maxStackDepth = maxDepth;
5631 if (range != -1) {
5632 envPtr->excRangeDepth--;
5633 }
5634 return result;
5635}
5636
5637
5638/*
5639 *----------------------------------------------------------------------
5640 *
5641 * CompileExprWord --
5642 *
5643 * Procedure that compiles a Tcl expression in a command word.
5644 *
5645 * Results:
5646 * The return value is a standard Tcl result, which is TCL_OK unless
5647 * there was an error while compiling string. If an error occurs then
5648 * the interpreter's result contains a standard error message.
5649 *
5650 * envPtr->termOffset is filled in with the offset of the character in
5651 * "string" just after the last one successfully processed.
5652 *
5653 * envPtr->maxStackDepth is updated with the maximum number of stack
5654 * elements needed to execute the "expr" word.
5655 *
5656 * Side effects:
5657 * Instructions are added to envPtr to evaluate the expression word
5658 * at runtime.
5659 *
5660 *----------------------------------------------------------------------
5661 */
5662
5663static int
5664CompileExprWord(interp, string, lastChar, flags, envPtr)
5665 Tcl_Interp *interp; /* Used for error reporting. */
5666 char *string; /* The source string to compile. */
5667 char *lastChar; /* Pointer to terminating character of
5668 * string. */
5669 int flags; /* Flags to control compilation (same as
5670 * passed to Tcl_Eval). */
5671 CompileEnv *envPtr; /* Holds resulting instructions. */
5672{
5673 register char *src = string;/* Points to current source char. */
5674 register int type; /* Current char's CHAR_TYPE type. */
5675 int maxDepth = 0; /* Maximum number of stack elements needed
5676 * to execute the expression. */
5677 int nestedCmd = (flags & TCL_BRACKET_TERM);
5678 /* 1 if script being compiled is a nested
5679 * command and is terminated by a ']';
5680 * otherwise 0. */
5681 char *first, *last; /* Points to the first and last significant
5682 * characters of the word. */
5683 char savedChar; /* Holds the character termporarily replaced
5684 * by a null character during compilation
5685 * of the expression. */
5686 int inlineCode; /* 1 if inline "optimistic" code is
5687 * emitted for the expression; else 0. */
5688 int range = -1; /* If we inline compile an un-{}'d
5689 * expression, the index for its catch range
5690 * record in the ExceptionRange array.
5691 * Initialized to enable proper cleanup. */
5692 JumpFixup jumpFixup; /* Used to emit the "success" jump after
5693 * the inline expression code. */
5694 char *p;
5695 char c;
5696 int savePushSimpleWords = envPtr->pushSimpleWords;
5697 int saveExprIsJustVarRef = envPtr->exprIsJustVarRef;
5698 int saveExprIsComparison = envPtr->exprIsComparison;
5699 int numChars, result;
5700
5701 /*
5702 * Skip over leading white space.
5703 */
5704
5705 AdvanceToNextWord(src, envPtr);
5706 src += envPtr->termOffset;
5707 type = CHAR_TYPE(src, lastChar);
5708 if (type == TCL_COMMAND_END) {
5709 badArgs:
5710 Tcl_ResetResult(interp);
5711 Tcl_AppendToObj(Tcl_GetObjResult(interp),
5712 "malformed expression word", -1);
5713 result = TCL_ERROR;
5714 goto done;
5715 }
5716
5717 /*
5718 * If the word is enclosed in {}s, we may strip them off and safely
5719 * compile the expression into an inline sequence of instructions using
5720 * TclCompileExpr. We know these instructions will have the right Tcl7.x
5721 * expression semantics.
5722 *
5723 * Otherwise, if the word is not enclosed in {}s, we may need to call
5724 * the expr command (Tcl_ExprObjCmd) at runtime. This recompiles the
5725 * expression each time (typically) and so is slow. However, there are
5726 * some circumstances where we can still compile inline instructions
5727 * "optimistically" and check, during their execution, for double
5728 * substitutions (these appear as nonnumeric operands). We check for any
5729 * backslash or command substitutions. If none appear, and only variable
5730 * substitutions are found, we generate inline instructions.
5731 *
5732 * For now, if the expression is not enclosed in {}s, we call the expr
5733 * command at runtime if either command or backslash substitutions
5734 * appear (but not if only variable substitutions appear).
5735 */
5736
5737 if (*src == '{') {
5738 /*
5739 * Inline compile the expression inside {}s.
5740 */
5741
5742 first = src+1;
5743 src = TclWordEnd(src, lastChar, nestedCmd, NULL);
5744 if (*src == 0) {
5745 goto badArgs;
5746 }
5747 if (*src != '}') {
5748 goto badArgs;
5749 }
5750 last = (src-1);
5751
5752 numChars = (last - first + 1);
5753 savedChar = first[numChars];
5754 first[numChars] = '\0';
5755 result = TclCompileExpr(interp, first, first+numChars,
5756 flags, envPtr);
5757 first[numChars] = savedChar;
5758
5759 src++;
5760 maxDepth = envPtr->maxStackDepth;
5761 } else {
5762 /*
5763 * No braces. If the expression is enclosed in '"'s, call the expr
5764 * cmd at runtime. Otherwise, scan the word's characters looking for
5765 * any '['s or (for now) '\'s. If any are found, just call expr cmd
5766 * at runtime.
5767 */
5768
5769 first = src;
5770 last = TclWordEnd(first, lastChar, nestedCmd, NULL);
5771 if (*last == 0) { /* word doesn't end properly. */
5772 src = last;
5773 goto badArgs;
5774 }
5775
5776 inlineCode = 1;
5777 if ((*first == '"') && (*last == '"')) {
5778 inlineCode = 0;
5779 } else {
5780 for (p = first; p <= last; p++) {
5781 c = *p;
5782 if ((c == '[') || (c == '\\')) {
5783 inlineCode = 0;
5784 break;
5785 }
5786 }
5787 }
5788
5789 if (inlineCode) {
5790 /*
5791 * Inline compile the expression inside a "catch" so that a
5792 * runtime error will back off to make a (slow) call on expr.
5793 */
5794
5795 int startCodeOffset = (envPtr->codeNext - envPtr->codeStart);
5796 int startRangeNext = envPtr->excRangeArrayNext;
5797
5798 /*
5799 * Create a ExceptionRange record to hold information about
5800 * the "catch" range for the expression's inline code. Also
5801 * emit the instruction to mark the start of the range.
5802 */
5803
5804 envPtr->excRangeDepth++;
5805 envPtr->maxExcRangeDepth =
5806 TclMax(envPtr->excRangeDepth, envPtr->maxExcRangeDepth);
5807 range = CreateExceptionRange(CATCH_EXCEPTION_RANGE, envPtr);
5808 TclEmitInstUInt4(INST_BEGIN_CATCH4, range, envPtr);
5809
5810 /*
5811 * Inline compile the expression.
5812 */
5813
5814 envPtr->excRangeArrayPtr[range].codeOffset = TclCurrCodeOffset();
5815 numChars = (last - first + 1);
5816 savedChar = first[numChars];
5817 first[numChars] = '\0';
5818 result = TclCompileExpr(interp, first, first + numChars,
5819 flags, envPtr);
5820 first[numChars] = savedChar;
5821
5822 envPtr->excRangeArrayPtr[range].numCodeBytes =
5823 TclCurrCodeOffset() - envPtr->excRangeArrayPtr[range].codeOffset;
5824
5825 if ((result != TCL_OK) || (envPtr->exprIsJustVarRef)
5826 || (envPtr->exprIsComparison)) {
5827 /*
5828 * We must call the expr command at runtime. Either there
5829 * was a compilation error or the inline code might fail to
5830 * give the correct 2 level substitution semantics.
5831 *
5832 * The latter can happen if the expression consisted of just
5833 * a single variable reference or if the top-level operator
5834 * in the expr is a comparison (which might operate on
5835 * strings). In the latter case, the expression's code might
5836 * execute (apparently) successfully but produce the wrong
5837 * result. We depend on its execution failing if a second
5838 * level of substitutions is required. This causes the
5839 * "catch" code we generate around the inline code to back
5840 * off to a call on the expr command at runtime, and this
5841 * always gives the right 2 level substitution semantics.
5842 *
5843 * We delete the inline code by backing up the code pc and
5844 * catch index. Note that if there was a compilation error,
5845 * we can't report the error yet since the expression might
5846 * be valid after the second round of substitutions.
5847 */
5848
5849 envPtr->codeNext = (envPtr->codeStart + startCodeOffset);
5850 envPtr->excRangeArrayNext = startRangeNext;
5851 inlineCode = 0;
5852 } else {
5853 TclEmitOpcode(INST_END_CATCH, envPtr); /* for ok case */
5854 TclEmitForwardJump(envPtr, TCL_UNCONDITIONAL_JUMP, &jumpFixup);
5855 envPtr->excRangeArrayPtr[range].catchOffset = TclCurrCodeOffset();
5856 TclEmitOpcode(INST_END_CATCH, envPtr); /* for error case */
5857 }
5858 }
5859
5860 /*
5861 * Arrange to call expr at runtime with the (already substituted
5862 * once) expression word on the stack.
5863 */
5864
5865 envPtr->pushSimpleWords = 1;
5866 result = CompileWord(interp, first, lastChar, flags, envPtr);
5867 src += envPtr->termOffset;
5868 maxDepth = envPtr->maxStackDepth;
5869 if (result == TCL_OK) {
5870 TclEmitOpcode(INST_EXPR_STK, envPtr);
5871 }
5872
5873 /*
5874 * If emitting inline code for this non-{}'d expression, update
5875 * the target of the jump after that inline code.
5876 */
5877
5878 if (inlineCode) {
5879 int jumpDist = (TclCurrCodeOffset() - jumpFixup.codeOffset);
5880 if (TclFixupForwardJump(envPtr, &jumpFixup, jumpDist, 127)) {
5881 /*
5882 * Update the inline expression code's catch ExceptionRange
5883 * target since it, being after the jump, also moved down.
5884 */
5885
5886 envPtr->excRangeArrayPtr[range].catchOffset += 3;
5887 }
5888 }
5889 } /* if expression isn't in {}s */
5890
5891 done:
5892 if (range != -1) {
5893 envPtr->excRangeDepth--;
5894 }
5895 envPtr->termOffset = (src - string);
5896 envPtr->maxStackDepth = maxDepth;
5897 envPtr->pushSimpleWords = savePushSimpleWords;
5898 envPtr->exprIsJustVarRef = saveExprIsJustVarRef;
5899 envPtr->exprIsComparison = saveExprIsComparison;
5900 return result;
5901}
5902
5903
5904/*
5905 *----------------------------------------------------------------------
5906 *
5907 * CompileCmdWordInline --
5908 *
5909 * Procedure that compiles a Tcl command word inline. If the word is
5910 * enclosed in quotes or braces, we call TclCompileString to compile it
5911 * after stripping them off. Otherwise, we normally push the word's
5912 * value and call eval at runtime, but if the word is just a sequence
5913 * of alphanumeric characters, we emit an invoke instruction
5914 * directly. This procedure assumes that string points to the start of
5915 * the word to compile.
5916 *
5917 * Results:
5918 * The return value is a standard Tcl result, which is TCL_OK unless
5919 * there was an error while compiling string. If an error occurs then
5920 * the interpreter's result contains a standard error message.
5921 *
5922 * envPtr->termOffset is filled in with the offset of the character in
5923 * "string" just after the last one successfully processed.
5924 *
5925 * envPtr->maxStackDepth is updated with the maximum number of stack
5926 * elements needed to execute the command.
5927 *
5928 * Side effects:
5929 * Instructions are added to envPtr to execute the command word
5930 * at runtime.
5931 *
5932 *----------------------------------------------------------------------
5933 */
5934
5935static int
5936CompileCmdWordInline(interp, string, lastChar, flags, envPtr)
5937 Tcl_Interp *interp; /* Used for error reporting. */
5938 char *string; /* The source string to compile. */
5939 char *lastChar; /* Pointer to terminating character of
5940 * string. */
5941 int flags; /* Flags to control compilation (same as
5942 * passed to Tcl_Eval). */
5943 CompileEnv *envPtr; /* Holds resulting instructions. */
5944{
5945 Interp *iPtr = (Interp *) interp;
5946 register char *src = string;/* Points to current source char. */
5947 register int type; /* Current char's CHAR_TYPE type. */
5948 int maxDepth = 0; /* Maximum number of stack elements needed
5949 * to execute cmd. */
5950 char *termPtr; /* Points to char that terminated braced
5951 * string. */
5952 char savedChar; /* Holds the character termporarily replaced
5953 * by a null character during compilation
5954 * of the command. */
5955 int savePushSimpleWords = envPtr->pushSimpleWords;
5956 int objIndex;
5957 int result = TCL_OK;
5958 register char c;
5959
5960 type = CHAR_TYPE(src, lastChar);
5961 if (type & (TCL_QUOTE | TCL_OPEN_BRACE)) {
5962 src++;
5963 envPtr->pushSimpleWords = 0;
5964 if (type == TCL_QUOTE) {
5965 result = TclCompileQuotes(interp, src, lastChar,
5966 '"', flags, envPtr);
5967 } else {
5968 result = CompileBraces(interp, src, lastChar, flags, envPtr);
5969 }
5970 if (result != TCL_OK) {
5971 goto done;
5972 }
5973
5974 /*
5975 * Make sure the terminating character is the end of word.
5976 */
5977
5978 termPtr = (src + envPtr->termOffset);
5979 c = *termPtr;
5980 if ((c == '\\') && (*(termPtr+1) == '\n')) {
5981 /*
5982 * Line is continued on next line; the backslash-newline turns
5983 * into space, which terminates the word.
5984 */
5985 } else {
5986 type = CHAR_TYPE(termPtr, lastChar);
5987 if ((type != TCL_SPACE) && (type != TCL_COMMAND_END)) {
5988 Tcl_ResetResult(interp);
5989 if (*(src-1) == '"') {
5990 Tcl_AppendToObj(Tcl_GetObjResult(interp),
5991 "extra characters after close-quote", -1);
5992 } else {
5993 Tcl_AppendToObj(Tcl_GetObjResult(interp),
5994 "extra characters after close-brace", -1);
5995 }
5996 result = TCL_ERROR;
5997 goto done;
5998 }
5999 }
6000
6001 if (envPtr->wordIsSimple) {
6002 /*
6003 * A simple word enclosed in "" or {}s. Call TclCompileString to
6004 * compile it inline. Add a null character after the end of the
6005 * quoted or braced string: i.e., at the " or }. Turn the
6006 * flag bit TCL_BRACKET_TERM off since the recursively
6007 * compiled subcommand is now terminated by a null character.
6008 */
6009 char *closeCharPos = (termPtr - 1);
6010
6011 savedChar = *closeCharPos;
6012 *closeCharPos = '\0';
6013 result = TclCompileString(interp, src, closeCharPos,
6014 (flags & ~TCL_BRACKET_TERM), envPtr);
6015 *closeCharPos = savedChar;
6016 if (result != TCL_OK) {
6017 goto done;
6018 }
6019 } else {
6020 /*
6021 * The braced string contained a backslash-newline. Call eval
6022 * at runtime.
6023 */
6024 TclEmitOpcode(INST_EVAL_STK, envPtr);
6025 }
6026 src = termPtr;
6027 maxDepth = envPtr->maxStackDepth;
6028 } else {
6029 /*
6030 * Not a braced or quoted string. We normally push the word's
6031 * value and call eval at runtime. However, if the word is just
6032 * a sequence of alphanumeric characters, we call its compile
6033 * procedure, if any, or otherwise just emit an invoke instruction.
6034 */
6035
6036 char *p = src;
6037 c = *p;
6038 while (isalnum(UCHAR(c)) || (c == '_')) {
6039 p++;
6040 c = *p;
6041 }
6042 type = CHAR_TYPE(p, lastChar);
6043 if ((p > src) && (type == TCL_COMMAND_END)) {
6044 /*
6045 * Look for a compile procedure and call it. Otherwise emit an
6046 * invoke instruction to call the command at runtime.
6047 */
6048
6049 Tcl_Command cmd;
6050 Command *cmdPtr = NULL;
6051 int wasCompiled = 0;
6052
6053 savedChar = *p;
6054 *p = '\0';
6055
6056 cmd = Tcl_FindCommand(interp, src, (Tcl_Namespace *) NULL,
6057 /*flags*/ 0);
6058 if (cmd != (Tcl_Command) NULL) {
6059 cmdPtr = (Command *) cmd;
6060 }
6061 if (cmdPtr != NULL && cmdPtr->compileProc != NULL) {
6062 *p = savedChar;
6063 src = p;
6064 iPtr->flags &= ~(ERR_ALREADY_LOGGED | ERR_IN_PROGRESS
6065 | ERROR_CODE_SET);
6066 result = (*(cmdPtr->compileProc))(interp, src, lastChar, flags, envPtr);
6067 if (result != TCL_OK) {
6068 goto done;
6069 }
6070 wasCompiled = 1;
6071 src += envPtr->termOffset;
6072 maxDepth = envPtr->maxStackDepth;
6073 }
6074 if (!wasCompiled) {
6075 objIndex = TclObjIndexForString(src, p-src,
6076 /*allocStrRep*/ 1, /*inHeap*/ 0, envPtr);
6077 *p = savedChar;
6078 TclEmitPush(objIndex, envPtr);
6079 TclEmitInstUInt1(INST_INVOKE_STK1, 1, envPtr);
6080 src = p;
6081 maxDepth = 1;
6082 }
6083 } else {
6084 /*
6085 * Push the word and call eval at runtime.
6086 */
6087
6088 envPtr->pushSimpleWords = 1;
6089 result = CompileWord(interp, src, lastChar, flags, envPtr);
6090 if (result != TCL_OK) {
6091 goto done;
6092 }
6093 TclEmitOpcode(INST_EVAL_STK, envPtr);
6094 src += envPtr->termOffset;
6095 maxDepth = envPtr->maxStackDepth;
6096 }
6097 }
6098
6099 done:
6100 envPtr->termOffset = (src - string);
6101 envPtr->maxStackDepth = maxDepth;
6102 envPtr->pushSimpleWords = savePushSimpleWords;
6103 return result;
6104}
6105
6106
6107/*
6108 *----------------------------------------------------------------------
6109 *
6110 * LookupCompiledLocal --
6111 *
6112 * This procedure is called at compile time to look up and optionally
6113 * allocate an entry ("slot") for a variable in a procedure's array of
6114 * local variables. If the variable's name is NULL, a new temporary
6115 * variable is always created. (Such temporary variables can only be
6116 * referenced using their slot index.)
6117 *
6118 * Results:
6119 * If createIfNew is 0 (false) and the name is non-NULL, then if the
6120 * variable is found, the index of its entry in the procedure's array
6121 * of local variables is returned; otherwise -1 is returned.
6122 * If name is NULL, the index of a new temporary variable is returned.
6123 * Finally, if createIfNew is 1 and name is non-NULL, the index of a
6124 * new entry is returned.
6125 *
6126 * Side effects:
6127 * Creates and registers a new local variable if createIfNew is 1 and
6128 * the variable is unknown, or if the name is NULL.
6129 *
6130 *----------------------------------------------------------------------
6131 */
6132
6133static int
6134LookupCompiledLocal(name, nameChars, createIfNew, flagsIfCreated, procPtr)
6135 register char *name; /* Points to first character of the name of
6136 * a scalar or array variable. If NULL, a
6137 * temporary var should be created. */
6138 int nameChars; /* The length of the name excluding the
6139 * terminating null character. */
6140 int createIfNew; /* 1 to allocate a local frame entry for the
6141 * variable if it is new. */
6142 int flagsIfCreated; /* Flag bits for the compiled local if
6143 * created. Only VAR_SCALAR, VAR_ARRAY, and
6144 * VAR_LINK make sense. */
6145 register Proc *procPtr; /* Points to structure describing procedure
6146 * containing the variable reference. */
6147{
6148 register CompiledLocal *localPtr;
6149 int localIndex = -1;
6150 register int i;
6151 int localCt;
6152
6153 /*
6154 * If not creating a temporary, does a local variable of the specified
6155 * name already exist?
6156 */
6157
6158 if (name != NULL) {
6159 localCt = procPtr->numCompiledLocals;
6160 localPtr = procPtr->firstLocalPtr;
6161 for (i = 0; i < localCt; i++) {
6162 if (!TclIsVarTemporary(localPtr)) {
6163 char *localName = localPtr->name;
6164 if ((name[0] == localName[0])
6165 && (nameChars == localPtr->nameLength)
6166 && (strncmp(name, localName, (unsigned) nameChars) == 0)) {
6167 return i;
6168 }
6169 }
6170 localPtr = localPtr->nextPtr;
6171 }
6172 }
6173
6174 /*
6175 * Create a new variable if appropriate.
6176 */
6177
6178 if (createIfNew || (name == NULL)) {
6179 localIndex = procPtr->numCompiledLocals;
6180 localPtr = (CompiledLocal *) ckalloc((unsigned)
6181 (sizeof(CompiledLocal) - sizeof(localPtr->name)
6182 + nameChars+1));
6183 if (procPtr->firstLocalPtr == NULL) {
6184 procPtr->firstLocalPtr = procPtr->lastLocalPtr = localPtr;
6185 } else {
6186 procPtr->lastLocalPtr->nextPtr = localPtr;
6187 procPtr->lastLocalPtr = localPtr;
6188 }
6189 localPtr->nextPtr = NULL;
6190 localPtr->nameLength = nameChars;
6191 localPtr->frameIndex = localIndex;
6192 localPtr->flags = flagsIfCreated;
6193 if (name == NULL) {
6194 localPtr->flags |= VAR_TEMPORARY;
6195 }
6196 localPtr->defValuePtr = NULL;
6197 localPtr->resolveInfo = NULL;
6198
6199 if (name != NULL) {
6200 memcpy((VOID *) localPtr->name, (VOID *) name, (size_t) nameChars);
6201 }
6202 localPtr->name[nameChars] = '\0';
6203 procPtr->numCompiledLocals++;
6204 }
6205 return localIndex;
6206}
6207
6208
6209/*
6210 *----------------------------------------------------------------------
6211 *
6212 * TclInitCompiledLocals --
6213 *
6214 * This routine is invoked in order to initialize the compiled
6215 * locals table for a new call frame.
6216 *
6217 * Results:
6218 * None.
6219 *
6220 * Side effects:
6221 * May invoke various name resolvers in order to determine which
6222 * variables are being referenced at runtime.
6223 *
6224 *----------------------------------------------------------------------
6225 */
6226
6227void
6228TclInitCompiledLocals(interp, framePtr, nsPtr)
6229 Tcl_Interp *interp; /* Current interpreter. */
6230 CallFrame *framePtr; /* Call frame to initialize. */
6231 Namespace *nsPtr; /* Pointer to current namespace. */
6232{
6233 register CompiledLocal *localPtr;
6234 Interp *iPtr = (Interp*) interp;
6235 Tcl_ResolvedVarInfo *vinfo, *resVarInfo;
6236 Var *varPtr = framePtr->compiledLocals;
6237 Var *resolvedVarPtr;
6238 ResolverScheme *resPtr;
6239 int result;
6240
6241 /*
6242 * Initialize the array of local variables stored in the call frame.
6243 * Some variables may have special resolution rules. In that case,
6244 * we call their "resolver" procs to get our hands on the variable,
6245 * and we make the compiled local a link to the real variable.
6246 */
6247
6248 for (localPtr = framePtr->procPtr->firstLocalPtr;
6249 localPtr != NULL;
6250 localPtr = localPtr->nextPtr) {
6251
6252 /*
6253 * Check to see if this local is affected by namespace or
6254 * interp resolvers. The resolver to use is cached for the
6255 * next invocation of the procedure.
6256 */
6257
6258 if (!(localPtr->flags & (VAR_ARGUMENT|VAR_TEMPORARY|VAR_RESOLVED))
6259 && (nsPtr->compiledVarResProc || iPtr->resolverPtr)) {
6260 resPtr = iPtr->resolverPtr;
6261
6262 if (nsPtr->compiledVarResProc) {
6263 result = (*nsPtr->compiledVarResProc)(nsPtr->interp,
6264 localPtr->name, localPtr->nameLength,
6265 (Tcl_Namespace *) nsPtr, &vinfo);
6266 } else {
6267 result = TCL_CONTINUE;
6268 }
6269
6270 while ((result == TCL_CONTINUE) && resPtr) {
6271 if (resPtr->compiledVarResProc) {
6272 result = (*resPtr->compiledVarResProc)(nsPtr->interp,
6273 localPtr->name, localPtr->nameLength,
6274 (Tcl_Namespace *) nsPtr, &vinfo);
6275 }
6276 resPtr = resPtr->nextPtr;
6277 }
6278 if (result == TCL_OK) {
6279 localPtr->resolveInfo = vinfo;
6280 localPtr->flags |= VAR_RESOLVED;
6281 }
6282 }
6283
6284 /*
6285 * Now invoke the resolvers to determine the exact variables that
6286 * should be used.
6287 */
6288
6289 resVarInfo = localPtr->resolveInfo;
6290 resolvedVarPtr = NULL;
6291
6292 if (resVarInfo && resVarInfo->fetchProc) {
6293 resolvedVarPtr = (Var*) (*resVarInfo->fetchProc)(interp,
6294 resVarInfo);
6295 }
6296
6297 if (resolvedVarPtr) {
6298 varPtr->name = localPtr->name; /* will be just '\0' if temp var */
6299 varPtr->nsPtr = NULL;
6300 varPtr->hPtr = NULL;
6301 varPtr->refCount = 0;
6302 varPtr->tracePtr = NULL;
6303 varPtr->searchPtr = NULL;
6304 varPtr->flags = 0;
6305 TclSetVarLink(varPtr);
6306 varPtr->value.linkPtr = resolvedVarPtr;
6307 resolvedVarPtr->refCount++;
6308 } else {
6309 varPtr->value.objPtr = NULL;
6310 varPtr->name = localPtr->name; /* will be just '\0' if temp var */
6311 varPtr->nsPtr = NULL;
6312 varPtr->hPtr = NULL;
6313 varPtr->refCount = 0;
6314 varPtr->tracePtr = NULL;
6315 varPtr->searchPtr = NULL;
6316 varPtr->flags = (localPtr->flags | VAR_UNDEFINED);
6317 }
6318 varPtr++;
6319 }
6320}
6321
6322
6323/*
6324 *----------------------------------------------------------------------
6325 *
6326 * AdvanceToNextWord --
6327 *
6328 * This procedure is called to skip over any leading white space at the
6329 * start of a word. Note that a backslash-newline is treated as a
6330 * space.
6331 *
6332 * Results:
6333 * None.
6334 *
6335 * Side effects:
6336 * Updates envPtr->termOffset with the offset of the first
6337 * character in "string" that was not white space or a
6338 * backslash-newline. This might be the offset of the character that
6339 * ends the command: a newline, null, semicolon, or close-bracket.
6340 *
6341 *----------------------------------------------------------------------
6342 */
6343
6344static void
6345AdvanceToNextWord(string, envPtr)
6346 char *string; /* The source string to compile. */
6347 CompileEnv *envPtr; /* Holds resulting instructions. */
6348{
6349 register char *src; /* Points to current source char. */
6350 register int type; /* Current char's CHAR_TYPE type. */
6351
6352 src = string;
6353 type = CHAR_TYPE(src, src+1);
6354 while (type & (TCL_SPACE | TCL_BACKSLASH)) {
6355 if (type == TCL_BACKSLASH) {
6356 if (src[1] == '\n') {
6357 src += 2;
6358 } else {
6359 break; /* exit loop; no longer white space */
6360 }
6361 } else {
6362 src++;
6363 }
6364 type = CHAR_TYPE(src, src+1);
6365 }
6366 envPtr->termOffset = (src - string);
6367}
6368
6369
6370/*
6371 *----------------------------------------------------------------------
6372 *
6373 * Tcl_Backslash --
6374 *
6375 * Figure out how to handle a backslash sequence.
6376 *
6377 * Results:
6378 * The return value is the character that should be substituted
6379 * in place of the backslash sequence that starts at src. If
6380 * readPtr isn't NULL then it is filled in with a count of the
6381 * number of characters in the backslash sequence.
6382 *
6383 * Side effects:
6384 * None.
6385 *
6386 *----------------------------------------------------------------------
6387 */
6388
6389char
6390Tcl_Backslash(src, readPtr)
6391 CONST char *src; /* Points to the backslash character of
6392 * a backslash sequence. */
6393 int *readPtr; /* Fill in with number of characters read
6394 * from src, unless NULL. */
6395{
6396 CONST char *p = src + 1;
6397 char result;
6398 int count;
6399
6400 count = 2;
6401
6402 switch (*p) {
6403 /*
6404 * Note: in the conversions below, use absolute values (e.g.,
6405 * 0xa) rather than symbolic values (e.g. \n) that get converted
6406 * by the compiler. It's possible that compilers on some
6407 * platforms will do the symbolic conversions differently, which
6408 * could result in non-portable Tcl scripts.
6409 */
6410
6411 case 'a':
6412 result = 0x7;
6413 break;
6414 case 'b':
6415 result = 0x8;
6416 break;
6417 case 'f':
6418 result = 0xc;
6419 break;
6420 case 'n':
6421 result = 0xa;
6422 break;
6423 case 'r':
6424 result = 0xd;
6425 break;
6426 case 't':
6427 result = 0x9;
6428 break;
6429 case 'v':
6430 result = 0xb;
6431 break;
6432 case 'x':
6433 if (isxdigit(UCHAR(p[1]))) {
6434 char *end;
6435
6436 result = (char) strtoul(p+1, &end, 16);
6437 count = end - src;
6438 } else {
6439 count = 2;
6440 result = 'x';
6441 }
6442 break;
6443 case '\n':
6444 do {
6445 p++;
6446 } while ((*p == ' ') || (*p == '\t'));
6447 result = ' ';
6448 count = p - src;
6449 break;
6450 case 0:
6451 result = '\\';
6452 count = 1;
6453 break;
6454 default:
6455 if (isdigit(UCHAR(*p))) {
6456 result = (char)(*p - '0');
6457 p++;
6458 if (!isdigit(UCHAR(*p))) {
6459 break;
6460 }
6461 count = 3;
6462 result = (char)((result << 3) + (*p - '0'));
6463 p++;
6464 if (!isdigit(UCHAR(*p))) {
6465 break;
6466 }
6467 count = 4;
6468 result = (char)((result << 3) + (*p - '0'));
6469 break;
6470 }
6471 result = *p;
6472 count = 2;
6473 break;
6474 }
6475
6476 if (readPtr != NULL) {
6477 *readPtr = count;
6478 }
6479 return result;
6480}
6481
6482
6483/*
6484 *----------------------------------------------------------------------
6485 *
6486 * TclObjIndexForString --
6487 *
6488 * Procedure to find, or if necessary create, an object in a
6489 * CompileEnv's object array that has a string representation
6490 * matching the argument string.
6491 *
6492 * Results:
6493 * The index in the CompileEnv's object array of an object with a
6494 * string representation matching the argument "string". The object is
6495 * created if necessary. If inHeap is 1, then string is heap allocated
6496 * and ownership of the string is passed to TclObjIndexForString;
6497 * otherwise, the string is owned by the caller and must not be
6498 * modified or freed by TclObjIndexForString. Typically, a caller sets
6499 * inHeap 1 if string is an already heap-allocated buffer holding the
6500 * result of backslash substitutions.
6501 *
6502 * Side effects:
6503 * A new Tcl object will be created if no existing object matches the
6504 * input string. If allocStrRep is 1 then if a new object is created,
6505 * its string representation is allocated in the heap, else it is left
6506 * NULL. If inHeap is 1, this procedure is given ownership of the
6507 * string: if an object is created and allocStrRep is 1 then its
6508 * string representation is set directly from string, otherwise
6509 * the string is freed.
6510 *
6511 *----------------------------------------------------------------------
6512 */
6513
6514int
6515TclObjIndexForString(string, length, allocStrRep, inHeap, envPtr)
6516 register char *string; /* Points to string for which an object is
6517 * found or created in CompileEnv's object
6518 * array. */
6519 int length; /* Length of string. */
6520 int allocStrRep; /* If 1 then the object's string rep should
6521 * be allocated in the heap. */
6522 int inHeap; /* If 1 then string is heap allocated and
6523 * its ownership is passed to
6524 * TclObjIndexForString. */
6525 CompileEnv *envPtr; /* Points to the CompileEnv in whose object
6526 * array an object is found or created. */
6527{
6528 register Tcl_Obj *objPtr; /* Points to the object created for
6529 * the string, if one was created. */
6530 int objIndex; /* Index of matching object. */
6531 Tcl_HashEntry *hPtr;
6532 int strLength, new;
6533
6534 /*
6535 * Look up the string in the code's object hashtable. If found, just
6536 * return the associated object array index. Note that if the string
6537 * has embedded nulls, we don't create a hash table entry. This
6538 * should be fixed, but we need to update hash tables, first.
6539 */
6540
6541 strLength = strlen(string);
6542 if (length == -1) {
6543 length = strLength;
6544 }
6545 if (strLength != length) {
6546 hPtr = NULL;
6547 } else {
6548 hPtr = Tcl_CreateHashEntry(&envPtr->objTable, string, &new);
6549 if (!new) { /* already in object table and array */
6550 objIndex = (int) Tcl_GetHashValue(hPtr);
6551 if (inHeap) {
6552 ckfree(string);
6553 }
6554 return objIndex;
6555 }
6556 }
6557
6558 /*
6559 * Create a new object holding the string, add it to the object array,
6560 * and register its index in the object hashtable.
6561 */
6562
6563 objPtr = Tcl_NewObj();
6564 if (allocStrRep) {
6565 if (inHeap) { /* use input string for obj's string rep */
6566 objPtr->bytes = string;
6567 } else {
6568 if (length > 0) {
6569 objPtr->bytes = ckalloc((unsigned) length + 1);
6570 memcpy((VOID *) objPtr->bytes, (VOID *) string,
6571 (size_t) length);
6572 objPtr->bytes[length] = '\0';
6573 }
6574 }
6575 objPtr->length = length;
6576 } else { /* leave the string rep NULL */
6577 if (inHeap) {
6578 ckfree(string);
6579 }
6580 }
6581
6582 if (envPtr->objArrayNext >= envPtr->objArrayEnd) {
6583 ExpandObjectArray(envPtr);
6584 }
6585 objIndex = envPtr->objArrayNext;
6586 envPtr->objArrayPtr[objIndex] = objPtr;
6587 Tcl_IncrRefCount(objPtr);
6588 envPtr->objArrayNext++;
6589
6590 if (hPtr) {
6591 Tcl_SetHashValue(hPtr, objIndex);
6592 }
6593 return objIndex;
6594}
6595
6596
6597/*
6598 *----------------------------------------------------------------------
6599 *
6600 * TclExpandCodeArray --
6601 *
6602 * Procedure that uses malloc to allocate more storage for a
6603 * CompileEnv's code array.
6604 *
6605 * Results:
6606 * None.
6607 *
6608 * Side effects:
6609 * The byte code array in *envPtr is reallocated to a new array of
6610 * double the size, and if envPtr->mallocedCodeArray is non-zero the
6611 * old array is freed. Byte codes are copied from the old array to the
6612 * new one.
6613 *
6614 *----------------------------------------------------------------------
6615 */
6616
6617void
6618TclExpandCodeArray(envPtr)
6619 CompileEnv *envPtr; /* Points to the CompileEnv whose code array
6620 * must be enlarged. */
6621{
6622 /*
6623 * envPtr->codeNext is equal to envPtr->codeEnd. The currently defined
6624 * code bytes are stored between envPtr->codeStart and
6625 * (envPtr->codeNext - 1) [inclusive].
6626 */
6627
6628 size_t currBytes = TclCurrCodeOffset();
6629 size_t newBytes = 2*(envPtr->codeEnd - envPtr->codeStart);
6630 unsigned char *newPtr = (unsigned char *) ckalloc((unsigned) newBytes);
6631
6632 /*
6633 * Copy from old code array to new, free old code array if needed, and
6634 * mark new code array as malloced.
6635 */
6636
6637 memcpy((VOID *) newPtr, (VOID *) envPtr->codeStart, currBytes);
6638 if (envPtr->mallocedCodeArray) {
6639 ckfree((char *) envPtr->codeStart);
6640 }
6641 envPtr->codeStart = newPtr;
6642 envPtr->codeNext = (newPtr + currBytes);
6643 envPtr->codeEnd = (newPtr + newBytes);
6644 envPtr->mallocedCodeArray = 1;
6645}
6646
6647
6648/*
6649 *----------------------------------------------------------------------
6650 *
6651 * ExpandObjectArray --
6652 *
6653 * Procedure that uses malloc to allocate more storage for a
6654 * CompileEnv's object array.
6655 *
6656 * Results:
6657 * None.
6658 *
6659 * Side effects:
6660 * The object array in *envPtr is reallocated to a new array of
6661 * double the size, and if envPtr->mallocedObjArray is non-zero the
6662 * old array is freed. Tcl_Obj pointers are copied from the old array
6663 * to the new one.
6664 *
6665 *----------------------------------------------------------------------
6666 */
6667
6668static void
6669ExpandObjectArray(envPtr)
6670 CompileEnv *envPtr; /* Points to the CompileEnv whose object
6671 * array must be enlarged. */
6672{
6673 /*
6674 * envPtr->objArrayNext is equal to envPtr->objArrayEnd. The currently
6675 * allocated Tcl_Obj pointers are stored between elements
6676 * 0 and (envPtr->objArrayNext - 1) [inclusive] in the object array
6677 * pointed to by objArrayPtr.
6678 */
6679
6680 size_t currBytes = envPtr->objArrayNext * sizeof(Tcl_Obj *);
6681 int newElems = 2*envPtr->objArrayEnd;
6682 size_t newBytes = newElems * sizeof(Tcl_Obj *);
6683 Tcl_Obj **newPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
6684
6685 /*
6686 * Copy from old object array to new, free old object array if needed,
6687 * and mark new object array as malloced.
6688 */
6689
6690 memcpy((VOID *) newPtr, (VOID *) envPtr->objArrayPtr, currBytes);
6691 if (envPtr->mallocedObjArray) {
6692 ckfree((char *) envPtr->objArrayPtr);
6693 }
6694 envPtr->objArrayPtr = (Tcl_Obj **) newPtr;
6695 envPtr->objArrayEnd = newElems;
6696 envPtr->mallocedObjArray = 1;
6697}
6698
6699
6700/*
6701 *----------------------------------------------------------------------
6702 *
6703 * EnterCmdStartData --
6704 *
6705 * Registers the starting source and bytecode location of a
6706 * command. This information is used at runtime to map between
6707 * instruction pc and source locations.
6708 *
6709 * Results:
6710 * None.
6711 *
6712 * Side effects:
6713 * Inserts source and code location information into the compilation
6714 * environment envPtr for the command at index cmdIndex. The
6715 * compilation environment's CmdLocation array is grown if necessary.
6716 *
6717 *----------------------------------------------------------------------
6718 */
6719
6720static void
6721EnterCmdStartData(envPtr, cmdIndex, srcOffset, codeOffset)
6722 CompileEnv *envPtr; /* Points to the compilation environment
6723 * structure in which to enter command
6724 * location information. */
6725 int cmdIndex; /* Index of the command whose start data
6726 * is being set. */
6727 int srcOffset; /* Offset of first char of the command. */
6728 int codeOffset; /* Offset of first byte of command code. */
6729{
6730 CmdLocation *cmdLocPtr;
6731
6732 if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
6733 panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
6734 }
6735
6736 if (cmdIndex >= envPtr->cmdMapEnd) {
6737 /*
6738 * Expand the command location array by allocating more storage from
6739 * the heap. The currently allocated CmdLocation entries are stored
6740 * from cmdMapPtr[0] up to cmdMapPtr[envPtr->cmdMapEnd] (inclusive).
6741 */
6742
6743 size_t currElems = envPtr->cmdMapEnd;
6744 size_t newElems = 2*currElems;
6745 size_t currBytes = currElems * sizeof(CmdLocation);
6746 size_t newBytes = newElems * sizeof(CmdLocation);
6747 CmdLocation *newPtr = (CmdLocation *) ckalloc((unsigned) newBytes);
6748
6749 /*
6750 * Copy from old command location array to new, free old command
6751 * location array if needed, and mark new array as malloced.
6752 */
6753
6754 memcpy((VOID *) newPtr, (VOID *) envPtr->cmdMapPtr, currBytes);
6755 if (envPtr->mallocedCmdMap) {
6756 ckfree((char *) envPtr->cmdMapPtr);
6757 }
6758 envPtr->cmdMapPtr = (CmdLocation *) newPtr;
6759 envPtr->cmdMapEnd = newElems;
6760 envPtr->mallocedCmdMap = 1;
6761 }
6762
6763 if (cmdIndex > 0) {
6764 if (codeOffset < envPtr->cmdMapPtr[cmdIndex-1].codeOffset) {
6765 panic("EnterCmdStartData: cmd map table not sorted by code offset");
6766 }
6767 }
6768
6769 cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
6770 cmdLocPtr->codeOffset = codeOffset;
6771 cmdLocPtr->srcOffset = srcOffset;
6772 cmdLocPtr->numSrcChars = -1;
6773 cmdLocPtr->numCodeBytes = -1;
6774}
6775
6776
6777/*
6778 *----------------------------------------------------------------------
6779 *
6780 * EnterCmdExtentData --
6781 *
6782 * Registers the source and bytecode length for a command. This
6783 * information is used at runtime to map between instruction pc and
6784 * source locations.
6785 *
6786 * Results:
6787 * None.
6788 *
6789 * Side effects:
6790 * Inserts source and code length information into the compilation
6791 * environment envPtr for the command at index cmdIndex. Starting
6792 * source and bytecode information for the command must already
6793 * have been registered.
6794 *
6795 *----------------------------------------------------------------------
6796 */
6797
6798static void
6799EnterCmdExtentData(envPtr, cmdIndex, numSrcChars, numCodeBytes)
6800 CompileEnv *envPtr; /* Points to the compilation environment
6801 * structure in which to enter command
6802 * location information. */
6803 int cmdIndex; /* Index of the command whose source and
6804 * code length data is being set. */
6805 int numSrcChars; /* Number of command source chars. */
6806 int numCodeBytes; /* Offset of last byte of command code. */
6807{
6808 CmdLocation *cmdLocPtr;
6809
6810 if ((cmdIndex < 0) || (cmdIndex >= envPtr->numCommands)) {
6811 panic("EnterCmdStartData: bad command index %d\n", cmdIndex);
6812 }
6813
6814 if (cmdIndex > envPtr->cmdMapEnd) {
6815 panic("EnterCmdStartData: no start data registered for command with index %d\n", cmdIndex);
6816 }
6817
6818 cmdLocPtr = &(envPtr->cmdMapPtr[cmdIndex]);
6819 cmdLocPtr->numSrcChars = numSrcChars;
6820 cmdLocPtr->numCodeBytes = numCodeBytes;
6821}
6822
6823
6824/*
6825 *----------------------------------------------------------------------
6826 *
6827 * InitArgInfo --
6828 *
6829 * Initializes a ArgInfo structure to hold information about
6830 * some number of argument words in a command.
6831 *
6832 * Results:
6833 * None.
6834 *
6835 * Side effects:
6836 * The ArgInfo structure is initialized.
6837 *
6838 *----------------------------------------------------------------------
6839 */
6840
6841static void
6842InitArgInfo(argInfoPtr)
6843 register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
6844 * to initialize. */
6845{
6846 argInfoPtr->numArgs = 0;
6847 argInfoPtr->startArray = argInfoPtr->staticStartSpace;
6848 argInfoPtr->endArray = argInfoPtr->staticEndSpace;
6849 argInfoPtr->allocArgs = ARGINFO_INIT_ENTRIES;
6850 argInfoPtr->mallocedArrays = 0;
6851}
6852
6853
6854/*
6855 *----------------------------------------------------------------------
6856 *
6857 * CollectArgInfo --
6858 *
6859 * Procedure to scan the argument words of a command and record the
6860 * start and finish of each argument word in a ArgInfo structure.
6861 *
6862 * Results:
6863 * The return value is a standard Tcl result, which is TCL_OK unless
6864 * there was an error while scanning string. If an error occurs then
6865 * the interpreter's result contains a standard error message.
6866 *
6867 * Side effects:
6868 * If necessary, the argument start and end arrays in *argInfoPtr
6869 * are grown and reallocated to a new arrays of double the size, and
6870 * if argInfoPtr->mallocedArray is non-zero the old arrays are freed.
6871 *
6872 *----------------------------------------------------------------------
6873 */
6874
6875static int
6876CollectArgInfo(interp, string, lastChar, flags, argInfoPtr)
6877 Tcl_Interp *interp; /* Used for error reporting. */
6878 char *string; /* The source command string to scan. */
6879 char *lastChar; /* Pointer to terminating character of
6880 * string. */
6881 int flags; /* Flags to control compilation (same as
6882 * passed to Tcl_Eval). */
6883 register ArgInfo *argInfoPtr;
6884 /* Points to the ArgInfo structure in which
6885 * to record the arg word information. */
6886{
6887 register char *src = string;/* Points to current source char. */
6888 register int type; /* Current char's CHAR_TYPE type. */
6889 int nestedCmd = (flags & TCL_BRACKET_TERM);
6890 /* 1 if string being scanned is a nested
6891 * command and is terminated by a ']';
6892 * otherwise 0. */
6893 int scanningArgs; /* 1 if still scanning argument words to
6894 * determine their start and end. */
6895 char *wordStart, *wordEnd; /* Points to the first and last significant
6896 * characters of each word. */
6897 CompileEnv tempCompEnv; /* Only used to hold the termOffset field
6898 * updated by AdvanceToNextWord. */
6899 char *prev;
6900
6901 argInfoPtr->numArgs = 0;
6902 scanningArgs = 1;
6903 while (scanningArgs) {
6904 AdvanceToNextWord(src, &tempCompEnv);
6905 src += tempCompEnv.termOffset;
6906 type = CHAR_TYPE(src, lastChar);
6907
6908 if ((type == TCL_COMMAND_END) && ((*src != ']') || nestedCmd)) {
6909 break; /* done collecting argument words */
6910 } else if (*src == '"') {
6911 wordStart = src;
6912 src = TclWordEnd(src, lastChar, nestedCmd, NULL);
6913 if (src == lastChar) {
6914 badStringTermination:
6915 Tcl_ResetResult(interp);
6916 Tcl_AppendToObj(Tcl_GetObjResult(interp),
6917 "quoted string doesn't terminate properly", -1);
6918 return TCL_ERROR;
6919 }
6920 prev = (src-1);
6921 if (*src == '"') {
6922 wordEnd = src;
6923 src++;
6924 } else if ((*src == ';') && (*prev == '"')) {
6925 scanningArgs = 0;
6926 wordEnd = prev;
6927 } else {
6928 goto badStringTermination;
6929 }
6930 } else if (*src == '{') {
6931 wordStart = src;
6932 src = TclWordEnd(src, lastChar, nestedCmd, NULL);
6933 if (src == lastChar) {
6934 Tcl_ResetResult(interp);
6935 Tcl_AppendToObj(Tcl_GetObjResult(interp),
6936 "missing close-brace", -1);
6937 return TCL_ERROR;
6938 }
6939 prev = (src-1);
6940 if (*src == '}') {
6941 wordEnd = src;
6942 src++;
6943 } else if ((*src == ';') && (*prev == '}')) {
6944 scanningArgs = 0;
6945 wordEnd = prev;
6946 } else {
6947 Tcl_ResetResult(interp);
6948 Tcl_AppendToObj(Tcl_GetObjResult(interp),
6949 "argument word in braces doesn't terminate properly", -1);
6950 return TCL_ERROR;
6951 }
6952 } else {
6953 wordStart = src;
6954 src = TclWordEnd(src, lastChar, nestedCmd, NULL);
6955 prev = (src-1);
6956 if (src == lastChar) {
6957 Tcl_ResetResult(interp);
6958 Tcl_AppendToObj(Tcl_GetObjResult(interp),
6959 "missing close-bracket or close-brace", -1);
6960 return TCL_ERROR;
6961 } else if (*src == ';') {
6962 scanningArgs = 0;
6963 wordEnd = prev;
6964 } else {
6965 wordEnd = src;
6966 src++;
6967 if ((src == lastChar) || (*src == '\n')
6968 || ((*src == ']') && nestedCmd)) {
6969 scanningArgs = 0;
6970 }
6971 }
6972 } /* end of test on each kind of word */
6973
6974 if (argInfoPtr->numArgs == argInfoPtr->allocArgs) {
6975 int newArgs = 2*argInfoPtr->numArgs;
6976 size_t currBytes = argInfoPtr->numArgs * sizeof(char *);
6977 size_t newBytes = newArgs * sizeof(char *);
6978 char **newStartArrayPtr =
6979 (char **) ckalloc((unsigned) newBytes);
6980 char **newEndArrayPtr =
6981 (char **) ckalloc((unsigned) newBytes);
6982
6983 /*
6984 * Copy from the old arrays to the new, free the old arrays if
6985 * needed, and mark the new arrays as malloc'ed.
6986 */
6987
6988 memcpy((VOID *) newStartArrayPtr,
6989 (VOID *) argInfoPtr->startArray, currBytes);
6990 memcpy((VOID *) newEndArrayPtr,
6991 (VOID *) argInfoPtr->endArray, currBytes);
6992 if (argInfoPtr->mallocedArrays) {
6993 ckfree((char *) argInfoPtr->startArray);
6994 ckfree((char *) argInfoPtr->endArray);
6995 }
6996 argInfoPtr->startArray = newStartArrayPtr;
6997 argInfoPtr->endArray = newEndArrayPtr;
6998 argInfoPtr->allocArgs = newArgs;
6999 argInfoPtr->mallocedArrays = 1;
7000 }
7001 argInfoPtr->startArray[argInfoPtr->numArgs] = wordStart;
7002 argInfoPtr->endArray[argInfoPtr->numArgs] = wordEnd;
7003 argInfoPtr->numArgs++;
7004 }
7005 return TCL_OK;
7006}
7007
7008
7009/*
7010 *----------------------------------------------------------------------
7011 *
7012 * FreeArgInfo --
7013 *
7014 * Free any storage allocated in a ArgInfo structure.
7015 *
7016 * Results:
7017 * None.
7018 *
7019 * Side effects:
7020 * Allocated storage in the ArgInfo structure is freed.
7021 *
7022 *----------------------------------------------------------------------
7023 */
7024
7025static void
7026FreeArgInfo(argInfoPtr)
7027 register ArgInfo *argInfoPtr; /* Points to the ArgInfo structure
7028 * to free. */
7029{
7030 if (argInfoPtr->mallocedArrays) {
7031 ckfree((char *) argInfoPtr->startArray);
7032 ckfree((char *) argInfoPtr->endArray);
7033 }
7034}
7035
7036
7037/*
7038 *----------------------------------------------------------------------
7039 *
7040 * CreateExceptionRange --
7041 *
7042 * Procedure that allocates and initializes a new ExceptionRange
7043 * structure of the specified kind in a CompileEnv's ExceptionRange
7044 * array.
7045 *
7046 * Results:
7047 * Returns the index for the newly created ExceptionRange.
7048 *
7049 * Side effects:
7050 * If there is not enough room in the CompileEnv's ExceptionRange
7051 * array, the array in expanded: a new array of double the size is
7052 * allocated, if envPtr->mallocedExcRangeArray is non-zero the old
7053 * array is freed, and ExceptionRange entries are copied from the old
7054 * array to the new one.
7055 *
7056 *----------------------------------------------------------------------
7057 */
7058
7059static int
7060CreateExceptionRange(type, envPtr)
7061 ExceptionRangeType type; /* The kind of ExceptionRange desired. */
7062 register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
7063 * loop ExceptionRange structure is to be
7064 * allocated. */
7065{
7066 int index; /* Index for the newly-allocated
7067 * ExceptionRange structure. */
7068 register ExceptionRange *rangePtr;
7069 /* Points to the new ExceptionRange
7070 * structure */
7071
7072 index = envPtr->excRangeArrayNext;
7073 if (index >= envPtr->excRangeArrayEnd) {
7074 /*
7075 * Expand the ExceptionRange array. The currently allocated entries
7076 * are stored between elements 0 and (envPtr->excRangeArrayNext - 1)
7077 * [inclusive].
7078 */
7079
7080 size_t currBytes =
7081 envPtr->excRangeArrayNext * sizeof(ExceptionRange);
7082 int newElems = 2*envPtr->excRangeArrayEnd;
7083 size_t newBytes = newElems * sizeof(ExceptionRange);
7084 ExceptionRange *newPtr = (ExceptionRange *)
7085 ckalloc((unsigned) newBytes);
7086
7087 /*
7088 * Copy from old ExceptionRange array to new, free old
7089 * ExceptionRange array if needed, and mark the new ExceptionRange
7090 * array as malloced.
7091 */
7092
7093 memcpy((VOID *) newPtr, (VOID *) envPtr->excRangeArrayPtr,
7094 currBytes);
7095 if (envPtr->mallocedExcRangeArray) {
7096 ckfree((char *) envPtr->excRangeArrayPtr);
7097 }
7098 envPtr->excRangeArrayPtr = (ExceptionRange *) newPtr;
7099 envPtr->excRangeArrayEnd = newElems;
7100 envPtr->mallocedExcRangeArray = 1;
7101 }
7102 envPtr->excRangeArrayNext++;
7103
7104 rangePtr = &(envPtr->excRangeArrayPtr[index]);
7105 rangePtr->type = type;
7106 rangePtr->nestingLevel = envPtr->excRangeDepth;
7107 rangePtr->codeOffset = -1;
7108 rangePtr->numCodeBytes = -1;
7109 rangePtr->breakOffset = -1;
7110 rangePtr->continueOffset = -1;
7111 rangePtr->catchOffset = -1;
7112 return index;
7113}
7114
7115
7116/*
7117 *----------------------------------------------------------------------
7118 *
7119 * TclCreateAuxData --
7120 *
7121 * Procedure that allocates and initializes a new AuxData structure in
7122 * a CompileEnv's array of compilation auxiliary data records. These
7123 * AuxData records hold information created during compilation by
7124 * CompileProcs and used by instructions during execution.
7125 *
7126 * Results:
7127 * Returns the index for the newly created AuxData structure.
7128 *
7129 * Side effects:
7130 * If there is not enough room in the CompileEnv's AuxData array,
7131 * the AuxData array in expanded: a new array of double the size
7132 * is allocated, if envPtr->mallocedAuxDataArray is non-zero
7133 * the old array is freed, and AuxData entries are copied from
7134 * the old array to the new one.
7135 *
7136 *----------------------------------------------------------------------
7137 */
7138
7139int
7140TclCreateAuxData(clientData, typePtr, envPtr)
7141 ClientData clientData; /* The compilation auxiliary data to store
7142 * in the new aux data record. */
7143 AuxDataType *typePtr; /* Pointer to the type to attach to this AuxData */
7144 register CompileEnv *envPtr;/* Points to the CompileEnv for which a new
7145 * aux data structure is to be allocated. */
7146{
7147 int index; /* Index for the new AuxData structure. */
7148 register AuxData *auxDataPtr;
7149 /* Points to the new AuxData structure */
7150
7151 index = envPtr->auxDataArrayNext;
7152 if (index >= envPtr->auxDataArrayEnd) {
7153 /*
7154 * Expand the AuxData array. The currently allocated entries are
7155 * stored between elements 0 and (envPtr->auxDataArrayNext - 1)
7156 * [inclusive].
7157 */
7158
7159 size_t currBytes = envPtr->auxDataArrayNext * sizeof(AuxData);
7160 int newElems = 2*envPtr->auxDataArrayEnd;
7161 size_t newBytes = newElems * sizeof(AuxData);
7162 AuxData *newPtr = (AuxData *) ckalloc((unsigned) newBytes);
7163
7164 /*
7165 * Copy from old AuxData array to new, free old AuxData array if
7166 * needed, and mark the new AuxData array as malloced.
7167 */
7168
7169 memcpy((VOID *) newPtr, (VOID *) envPtr->auxDataArrayPtr,
7170 currBytes);
7171 if (envPtr->mallocedAuxDataArray) {
7172 ckfree((char *) envPtr->auxDataArrayPtr);
7173 }
7174 envPtr->auxDataArrayPtr = newPtr;
7175 envPtr->auxDataArrayEnd = newElems;
7176 envPtr->mallocedAuxDataArray = 1;
7177 }
7178 envPtr->auxDataArrayNext++;
7179
7180 auxDataPtr = &(envPtr->auxDataArrayPtr[index]);
7181 auxDataPtr->type = typePtr;
7182 auxDataPtr->clientData = clientData;
7183 return index;
7184}
7185
7186
7187/*
7188 *----------------------------------------------------------------------
7189 *
7190 * TclInitJumpFixupArray --
7191 *
7192 * Initializes a JumpFixupArray structure to hold some number of
7193 * jump fixup entries.
7194 *
7195 * Results:
7196 * None.
7197 *
7198 * Side effects:
7199 * The JumpFixupArray structure is initialized.
7200 *
7201 *----------------------------------------------------------------------
7202 */
7203
7204void
7205TclInitJumpFixupArray(fixupArrayPtr)
7206 register JumpFixupArray *fixupArrayPtr;
7207 /* Points to the JumpFixupArray structure
7208 * to initialize. */
7209{
7210 fixupArrayPtr->fixup = fixupArrayPtr->staticFixupSpace;
7211 fixupArrayPtr->next = 0;
7212 fixupArrayPtr->end = (JUMPFIXUP_INIT_ENTRIES - 1);
7213 fixupArrayPtr->mallocedArray = 0;
7214}
7215
7216
7217/*
7218 *----------------------------------------------------------------------
7219 *
7220 * TclExpandJumpFixupArray --
7221 *
7222 * Procedure that uses malloc to allocate more storage for a
7223 * jump fixup array.
7224 *
7225 * Results:
7226 * None.
7227 *
7228 * Side effects:
7229 * The jump fixup array in *fixupArrayPtr is reallocated to a new array
7230 * of double the size, and if fixupArrayPtr->mallocedArray is non-zero
7231 * the old array is freed. Jump fixup structures are copied from the
7232 * old array to the new one.
7233 *
7234 *----------------------------------------------------------------------
7235 */
7236
7237void
7238TclExpandJumpFixupArray(fixupArrayPtr)
7239 register JumpFixupArray *fixupArrayPtr;
7240 /* Points to the JumpFixupArray structure
7241 * to enlarge. */
7242{
7243 /*
7244 * The currently allocated jump fixup entries are stored from fixup[0]
7245 * up to fixup[fixupArrayPtr->fixupNext] (*not* inclusive). We assume
7246 * fixupArrayPtr->fixupNext is equal to fixupArrayPtr->fixupEnd.
7247 */
7248
7249 size_t currBytes = fixupArrayPtr->next * sizeof(JumpFixup);
7250 int newElems = 2*(fixupArrayPtr->end + 1);
7251 size_t newBytes = newElems * sizeof(JumpFixup);
7252 JumpFixup *newPtr = (JumpFixup *) ckalloc((unsigned) newBytes);
7253
7254 /*
7255 * Copy from the old array to new, free the old array if needed,
7256 * and mark the new array as malloced.
7257 */
7258
7259 memcpy((VOID *) newPtr, (VOID *) fixupArrayPtr->fixup, currBytes);
7260 if (fixupArrayPtr->mallocedArray) {
7261 ckfree((char *) fixupArrayPtr->fixup);
7262 }
7263 fixupArrayPtr->fixup = (JumpFixup *) newPtr;
7264 fixupArrayPtr->end = newElems;
7265 fixupArrayPtr->mallocedArray = 1;
7266}
7267
7268
7269/*
7270 *----------------------------------------------------------------------
7271 *
7272 * TclFreeJumpFixupArray --
7273 *
7274 * Free any storage allocated in a jump fixup array structure.
7275 *
7276 * Results:
7277 * None.
7278 *
7279 * Side effects:
7280 * Allocated storage in the JumpFixupArray structure is freed.
7281 *
7282 *----------------------------------------------------------------------
7283 */
7284
7285void
7286TclFreeJumpFixupArray(fixupArrayPtr)
7287 register JumpFixupArray *fixupArrayPtr;
7288 /* Points to the JumpFixupArray structure
7289 * to free. */
7290{
7291 if (fixupArrayPtr->mallocedArray) {
7292 ckfree((char *) fixupArrayPtr->fixup);
7293 }
7294}
7295
7296
7297/*
7298 *----------------------------------------------------------------------
7299 *
7300 * TclEmitForwardJump --
7301 *
7302 * Procedure to emit a two-byte forward jump of kind "jumpType". Since
7303 * the jump may later have to be grown to five bytes if the jump target
7304 * is more than, say, 127 bytes away, this procedure also initializes a
7305 * JumpFixup record with information about the jump.
7306 *
7307 * Results:
7308 * None.
7309 *
7310 * Side effects:
7311 * The JumpFixup record pointed to by "jumpFixupPtr" is initialized
7312 * with information needed later if the jump is to be grown. Also,
7313 * a two byte jump of the designated type is emitted at the current
7314 * point in the bytecode stream.
7315 *
7316 *----------------------------------------------------------------------
7317 */
7318
7319void
7320TclEmitForwardJump(envPtr, jumpType, jumpFixupPtr)
7321 CompileEnv *envPtr; /* Points to the CompileEnv structure that
7322 * holds the resulting instruction. */
7323 TclJumpType jumpType; /* Indicates the kind of jump: if true or
7324 * false or unconditional. */
7325 JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure to
7326 * initialize with information about this
7327 * forward jump. */
7328{
7329 /*
7330 * Initialize the JumpFixup structure:
7331 * - codeOffset is offset of first byte of jump below
7332 * - cmdIndex is index of the command after the current one
7333 * - excRangeIndex is the index of the first ExceptionRange after
7334 * the current one.
7335 */
7336
7337 jumpFixupPtr->jumpType = jumpType;
7338 jumpFixupPtr->codeOffset = TclCurrCodeOffset();
7339 jumpFixupPtr->cmdIndex = envPtr->numCommands;
7340 jumpFixupPtr->excRangeIndex = envPtr->excRangeArrayNext;
7341
7342 switch (jumpType) {
7343 case TCL_UNCONDITIONAL_JUMP:
7344 TclEmitInstInt1(INST_JUMP1, /*offset*/ 0, envPtr);
7345 break;
7346 case TCL_TRUE_JUMP:
7347 TclEmitInstInt1(INST_JUMP_TRUE1, /*offset*/ 0, envPtr);
7348 break;
7349 default:
7350 TclEmitInstInt1(INST_JUMP_FALSE1, /*offset*/ 0, envPtr);
7351 break;
7352 }
7353}
7354
7355
7356/*
7357 *----------------------------------------------------------------------
7358 *
7359 * TclFixupForwardJump --
7360 *
7361 * Procedure that updates a previously-emitted forward jump to jump
7362 * a specified number of bytes, "jumpDist". If necessary, the jump is
7363 * grown from two to five bytes; this is done if the jump distance is
7364 * greater than "distThreshold" (normally 127 bytes). The jump is
7365 * described by a JumpFixup record previously initialized by
7366 * TclEmitForwardJump.
7367 *
7368 * Results:
7369 * 1 if the jump was grown and subsequent instructions had to be moved;
7370 * otherwise 0. This result is returned to allow callers to update
7371 * any additional code offsets they may hold.
7372 *
7373 * Side effects:
7374 * The jump may be grown and subsequent instructions moved. If this
7375 * happens, the code offsets for any commands and any ExceptionRange
7376 * records between the jump and the current code address will be
7377 * updated to reflect the moved code. Also, the bytecode instruction
7378 * array in the CompileEnv structure may be grown and reallocated.
7379 *
7380 *----------------------------------------------------------------------
7381 */
7382
7383int
7384TclFixupForwardJump(envPtr, jumpFixupPtr, jumpDist, distThreshold)
7385 CompileEnv *envPtr; /* Points to the CompileEnv structure that
7386 * holds the resulting instruction. */
7387 JumpFixup *jumpFixupPtr; /* Points to the JumpFixup structure that
7388 * describes the forward jump. */
7389 int jumpDist; /* Jump distance to set in jump
7390 * instruction. */
7391 int distThreshold; /* Maximum distance before the two byte
7392 * jump is grown to five bytes. */
7393{
7394 unsigned char *jumpPc, *p;
7395 int firstCmd, lastCmd, firstRange, lastRange, k;
7396 unsigned int numBytes;
7397
7398 if (jumpDist <= distThreshold) {
7399 jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
7400 switch (jumpFixupPtr->jumpType) {
7401 case TCL_UNCONDITIONAL_JUMP:
7402 TclUpdateInstInt1AtPc(INST_JUMP1, jumpDist, jumpPc);
7403 break;
7404 case TCL_TRUE_JUMP:
7405 TclUpdateInstInt1AtPc(INST_JUMP_TRUE1, jumpDist, jumpPc);
7406 break;
7407 default:
7408 TclUpdateInstInt1AtPc(INST_JUMP_FALSE1, jumpDist, jumpPc);
7409 break;
7410 }
7411 return 0;
7412 }
7413
7414 /*
7415 * We must grow the jump then move subsequent instructions down.
7416 */
7417
7418 TclEnsureCodeSpace(3, envPtr); /* NB: might change code addresses! */
7419 jumpPc = (envPtr->codeStart + jumpFixupPtr->codeOffset);
7420 for (numBytes = envPtr->codeNext-jumpPc-2, p = jumpPc+2+numBytes-1;
7421 numBytes > 0; numBytes--, p--) {
7422 p[3] = p[0];
7423 }
7424 envPtr->codeNext += 3;
7425 jumpDist += 3;
7426 switch (jumpFixupPtr->jumpType) {
7427 case TCL_UNCONDITIONAL_JUMP:
7428 TclUpdateInstInt4AtPc(INST_JUMP4, jumpDist, jumpPc);
7429 break;
7430 case TCL_TRUE_JUMP:
7431 TclUpdateInstInt4AtPc(INST_JUMP_TRUE4, jumpDist, jumpPc);
7432 break;
7433 default:
7434 TclUpdateInstInt4AtPc(INST_JUMP_FALSE4, jumpDist, jumpPc);
7435 break;
7436 }
7437
7438 /*
7439 * Adjust the code offsets for any commands and any ExceptionRange
7440 * records between the jump and the current code address.
7441 */
7442
7443 firstCmd = jumpFixupPtr->cmdIndex;
7444 lastCmd = (envPtr->numCommands - 1);
7445 if (firstCmd < lastCmd) {
7446 for (k = firstCmd; k <= lastCmd; k++) {
7447 (envPtr->cmdMapPtr[k]).codeOffset += 3;
7448 }
7449 }
7450
7451 firstRange = jumpFixupPtr->excRangeIndex;
7452 lastRange = (envPtr->excRangeArrayNext - 1);
7453 for (k = firstRange; k <= lastRange; k++) {
7454 ExceptionRange *rangePtr = &(envPtr->excRangeArrayPtr[k]);
7455 rangePtr->codeOffset += 3;
7456
7457 switch (rangePtr->type) {
7458 case LOOP_EXCEPTION_RANGE:
7459 rangePtr->breakOffset += 3;
7460 if (rangePtr->continueOffset != -1) {
7461 rangePtr->continueOffset += 3;
7462 }
7463 break;
7464 case CATCH_EXCEPTION_RANGE:
7465 rangePtr->catchOffset += 3;
7466 break;
7467 default:
7468 panic("TclFixupForwardJump: unrecognized ExceptionRange type %d\n", rangePtr->type);
7469 }
7470 }
7471 return 1; /* the jump was grown */
7472}
7473
7474
7475/*
7476 *----------------------------------------------------------------------
7477 *
7478 * TclGetInstructionTable --
7479 *
7480 * Returns a pointer to the table describing Tcl bytecode instructions.
7481 * This procedure is defined so that clients can access the pointer from
7482 * outside the TCL DLLs.
7483 *
7484 * Results:
7485 * Returns a pointer to the global instruction table, same as the expression
7486 * (&instructionTable[0]).
7487 *
7488 * Side effects:
7489 * None.
7490 *
7491 *----------------------------------------------------------------------
7492 */
7493
7494InstructionDesc *
7495TclGetInstructionTable()
7496{
7497 return &instructionTable[0];
7498}
7499
7500
7501/*
7502 *--------------------------------------------------------------
7503 *
7504 * TclRegisterAuxDataType --
7505 *
7506 * This procedure is called to register a new AuxData type
7507 * in the table of all AuxData types supported by Tcl.
7508 *
7509 * Results:
7510 * None.
7511 *
7512 * Side effects:
7513 * The type is registered in the AuxData type table. If there was already
7514 * a type with the same name as in typePtr, it is replaced with the
7515 * new type.
7516 *
7517 *--------------------------------------------------------------
7518 */
7519
7520void
7521TclRegisterAuxDataType(typePtr)
7522 AuxDataType *typePtr; /* Information about object type;
7523 * storage must be statically
7524 * allocated (must live forever). */
7525{
7526 register Tcl_HashEntry *hPtr;
7527 int new;
7528
7529 if (!auxDataTypeTableInitialized) {
7530 TclInitAuxDataTypeTable();
7531 }
7532
7533 /*
7534 * If there's already a type with the given name, remove it.
7535 */
7536
7537 hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typePtr->name);
7538 if (hPtr != (Tcl_HashEntry *) NULL) {
7539 Tcl_DeleteHashEntry(hPtr);
7540 }
7541
7542 /*
7543 * Now insert the new object type.
7544 */
7545
7546 hPtr = Tcl_CreateHashEntry(&auxDataTypeTable, typePtr->name, &new);
7547 if (new) {
7548 Tcl_SetHashValue(hPtr, typePtr);
7549 }
7550}
7551
7552
7553/*
7554 *----------------------------------------------------------------------
7555 *
7556 * TclGetAuxDataType --
7557 *
7558 * This procedure looks up an Auxdata type by name.
7559 *
7560 * Results:
7561 * If an AuxData type with name matching "typeName" is found, a pointer
7562 * to its AuxDataType structure is returned; otherwise, NULL is returned.
7563 *
7564 * Side effects:
7565 * None.
7566 *
7567 *----------------------------------------------------------------------
7568 */
7569
7570AuxDataType *
7571TclGetAuxDataType(typeName)
7572 char *typeName; /* Name of AuxData type to look up. */
7573{
7574 register Tcl_HashEntry *hPtr;
7575 AuxDataType *typePtr = NULL;
7576
7577 if (!auxDataTypeTableInitialized) {
7578 TclInitAuxDataTypeTable();
7579 }
7580
7581 hPtr = Tcl_FindHashEntry(&auxDataTypeTable, typeName);
7582 if (hPtr != (Tcl_HashEntry *) NULL) {
7583 typePtr = (AuxDataType *) Tcl_GetHashValue(hPtr);
7584 }
7585
7586 return typePtr;
7587}
7588
7589
7590/*
7591 *--------------------------------------------------------------
7592 *
7593 * TclInitAuxDataTypeTable --
7594 *
7595 * This procedure is invoked to perform once-only initialization of
7596 * the AuxData type table. It also registers the AuxData types defined in
7597 * this file.
7598 *
7599 * Results:
7600 * None.
7601 *
7602 * Side effects:
7603 * Initializes the table of defined AuxData types "auxDataTypeTable" with
7604 * builtin AuxData types defined in this file.
7605 *
7606 *--------------------------------------------------------------
7607 */
7608
7609void
7610TclInitAuxDataTypeTable()
7611{
7612 auxDataTypeTableInitialized = 1;
7613
7614 Tcl_InitHashTable(&auxDataTypeTable, TCL_STRING_KEYS);
7615 TclRegisterAuxDataType(&tclForeachInfoType);
7616}
7617
7618
7619/*
7620 *----------------------------------------------------------------------
7621 *
7622 * TclFinalizeAuxDataTypeTable --
7623 *
7624 * This procedure is called by Tcl_Finalize after all exit handlers
7625 * have been run to free up storage associated with the table of AuxData
7626 * types.
7627 *
7628 * Results:
7629 * None.
7630 *
7631 * Side effects:
7632 * Deletes all entries in the hash table of AuxData types, "auxDataTypeTable".
7633 *
7634 *----------------------------------------------------------------------
7635 */
7636
7637void
7638TclFinalizeAuxDataTypeTable()
7639{
7640 if (auxDataTypeTableInitialized) {
7641 Tcl_DeleteHashTable(&auxDataTypeTable);
7642 auxDataTypeTableInitialized = 0;
7643 }
7644}
Note: See TracBrowser for help on using the repository browser.