/[dtapublic]/projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompile.c
ViewVC logotype

Contents of /projs/trunk/shared_source/c_tcl_base_7_5_w_mods/tclcompile.c

Parent Directory Parent Directory | Revision Log Revision Log


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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25