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

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

Parent Directory Parent Directory | Revision Log Revision Log

Revision 64 - (show annotations) (download)
Sun Oct 30 04:21:11 2016 UTC (7 years, 11 months ago) by dashley
File MIME type: text/plain
File size: 156562 byte(s) 
Adjust line endings to Windows style.
Set properties to expand the "Header" keyword.
Change header and footer.
1 /* $Header$ */
2 /*
3 * tclExecute.c --
4 *
5 * This file contains procedures that execute byte-compiled Tcl
6 * commands.
7 *
8 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
9 *
10 * See the file "license.terms" for information on usage and redistribution
11 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
12 *
13 * RCS: @(#) $Id: tclexecute.c,v 1.1.1.1 2001/06/13 04:38:49 dtashley Exp $
14 */
15
16 #include "tclInt.h"
17 #include "tclCompile.h"
18
19 #ifdef NO_FLOAT_H
20 # include "../compat/float.h"
21 #else
22 # include <float.h>
23 #endif
24 #ifndef TCL_NO_MATH
25 #include "tclMath.h"
26 #endif
27
28 /*
29 * The stuff below is a bit of a hack so that this file can be used
30 * in environments that include no UNIX, i.e. no errno. Just define
31 * errno here.
32 */
33
34 #ifndef TCL_GENERIC_ONLY
35 #include "tclPort.h"
36 #else
37 #define NO_ERRNO_H
38 #endif
39
40 #ifdef NO_ERRNO_H
41 int errno;
42 #define EDOM 33
43 #define ERANGE 34
44 #endif
45
46 /*
47 * Boolean flag indicating whether the Tcl bytecode interpreter has been
48 * initialized.
49 */
50
51 static int execInitialized = 0;
52 TCL_DECLARE_MUTEX(execMutex)
53
54 /*
55 * Variable that controls whether execution tracing is enabled and, if so,
56 * what level of tracing is desired:
57 * 0: no execution tracing
58 * 1: trace invocations of Tcl procs only
59 * 2: trace invocations of all (not compiled away) commands
60 * 3: display each instruction executed
61 * This variable is linked to the Tcl variable "tcl_traceExec".
62 */
63
64 int tclTraceExec = 0;
65
66 typedef struct ThreadSpecificData {
67 /*
68 * The following global variable is use to signal matherr that Tcl
69 * is responsible for the arithmetic, so errors can be handled in a
70 * fashion appropriate for Tcl. Zero means no Tcl math is in
71 * progress; non-zero means Tcl is doing math.
72 */
73
74 int mathInProgress;
75
76 } ThreadSpecificData;
77
78 static Tcl_ThreadDataKey dataKey;
79
80 /*
81 * The variable below serves no useful purpose except to generate
82 * a reference to matherr, so that the Tcl version of matherr is
83 * linked in rather than the system version. Without this reference
84 * the need for matherr won't be discovered during linking until after
85 * libtcl.a has been processed, so Tcl's version won't be used.
86 */
87
88 #ifdef NEED_MATHERR
89 extern int matherr();
90 int (*tclMatherrPtr)() = matherr;
91 #endif
92
93 /*
94 * Mapping from expression instruction opcodes to strings; used for error
95 * messages. Note that these entries must match the order and number of the
96 * expression opcodes (e.g., INST_LOR) in tclCompile.h.
97 */
98
99 static char *operatorStrings[] = {
100 "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
101 "+", "-", "*", "/", "%", "+", "-", "~", "!",
102 "BUILTIN FUNCTION", "FUNCTION"
103 };
104
105 /*
106 * Mapping from Tcl result codes to strings; used for error and debugging
107 * messages.
108 */
109
110 #ifdef TCL_COMPILE_DEBUG
111 static char *resultStrings[] = {
112 "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
113 };
114 #endif
115
116 /*
117 * Macros for testing floating-point values for certain special cases. Test
118 * for not-a-number by comparing a value against itself; test for infinity
119 * by comparing against the largest floating-point value.
120 */
121
122 #define IS_NAN(v) ((v) != (v))
123 #ifdef DBL_MAX
124 # define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
125 #else
126 # define IS_INF(v) 0
127 #endif
128
129 /*
130 * Macro to adjust the program counter and restart the instruction execution
131 * loop after each instruction is executed.
132 */
133
134 #define ADJUST_PC(instBytes) \
135 pc += (instBytes); \
136 continue
137
138 /*
139 * Macros used to cache often-referenced Tcl evaluation stack information
140 * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
141 * pair must surround any call inside TclExecuteByteCode (and a few other
142 * procedures that use this scheme) that could result in a recursive call
143 * to TclExecuteByteCode.
144 */
145
146 #define CACHE_STACK_INFO() \
147 stackPtr = eePtr->stackPtr; \
148 stackTop = eePtr->stackTop
149
150 #define DECACHE_STACK_INFO() \
151 eePtr->stackTop = stackTop
152
153 /*
154 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
155 * increments the object's ref count since it makes the stack have another
156 * reference pointing to the object. However, POP_OBJECT does not decrement
157 * the ref count. This is because the stack may hold the only reference to
158 * the object, so the object would be destroyed if its ref count were
159 * decremented before the caller had a chance to, e.g., store it in a
160 * variable. It is the caller's responsibility to decrement the ref count
161 * when it is finished with an object.
162 *
163 * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
164 * macro. The actual parameter might be an expression with side effects,
165 * and this ensures that it will be executed only once.
166 */
167
168 #define PUSH_OBJECT(objPtr) \
169 Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
170
171 #define POP_OBJECT() \
172 (stackPtr[stackTop--])
173
174 /*
175 * Macros used to trace instruction execution. The macros TRACE,
176 * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
177 * O2S is only used in TRACE* calls to get a string from an object.
178 */
179
180 #ifdef TCL_COMPILE_DEBUG
181 #define TRACE(a) \
182 if (traceInstructions) { \
183 fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
184 (unsigned int)(pc - codePtr->codeStart), \
185 GetOpcodeName(pc)); \
186 printf a; \
187 }
188 #define TRACE_WITH_OBJ(a, objPtr) \
189 if (traceInstructions) { \
190 fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
191 (unsigned int)(pc - codePtr->codeStart), \
192 GetOpcodeName(pc)); \
193 printf a; \
194 TclPrintObject(stdout, (objPtr), 30); \
195 fprintf(stdout, "\n"); \
196 }
197 #define O2S(objPtr) \
198 Tcl_GetString(objPtr)
199 #else
200 #define TRACE(a)
201 #define TRACE_WITH_OBJ(a, objPtr)
202 #define O2S(objPtr)
203 #endif /* TCL_COMPILE_DEBUG */
204
205 /*
206 * Declarations for local procedures to this file:
207 */
208
209 static void CallTraceProcedure _ANSI_ARGS_((Tcl_Interp *interp,
210 Trace *tracePtr, Command *cmdPtr,
211 char *command, int numChars,
212 int objc, Tcl_Obj *objv[]));
213 static void DupCmdNameInternalRep _ANSI_ARGS_((Tcl_Obj *objPtr,
214 Tcl_Obj *copyPtr));
215 static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
216 ExecEnv *eePtr, ClientData clientData));
217 static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
218 ExecEnv *eePtr, ClientData clientData));
219 static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
220 ExecEnv *eePtr, int objc, Tcl_Obj **objv));
221 static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
222 ExecEnv *eePtr, ClientData clientData));
223 static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
224 ExecEnv *eePtr, ClientData clientData));
225 static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
226 ExecEnv *eePtr, ClientData clientData));
227 static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
228 ExecEnv *eePtr, ClientData clientData));
229 static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
230 ExecEnv *eePtr, ClientData clientData));
231 static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
232 ExecEnv *eePtr, ClientData clientData));
233 #ifdef TCL_COMPILE_STATS
234 static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
235 Tcl_Interp *interp, int argc, char **argv));
236 #endif
237 static void FreeCmdNameInternalRep _ANSI_ARGS_((
238 Tcl_Obj *objPtr));
239 #ifdef TCL_COMPILE_DEBUG
240 static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
241 #endif
242 static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
243 int catchOnly, ByteCode* codePtr));
244 static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
245 ByteCode* codePtr, int *lengthPtr));
246 static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
247 static void IllegalExprOperandType _ANSI_ARGS_((
248 Tcl_Interp *interp, unsigned char *pc,
249 Tcl_Obj *opndPtr));
250 static void InitByteCodeExecution _ANSI_ARGS_((
251 Tcl_Interp *interp));
252 #ifdef TCL_COMPILE_DEBUG
253 static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
254 #endif
255 static int SetCmdNameFromAny _ANSI_ARGS_((Tcl_Interp *interp,
256 Tcl_Obj *objPtr));
257 #ifdef TCL_COMPILE_DEBUG
258 static char * StringForResultCode _ANSI_ARGS_((int result));
259 static void ValidatePcAndStackTop _ANSI_ARGS_((
260 ByteCode *codePtr, unsigned char *pc,
261 int stackTop, int stackLowerBound,
262 int stackUpperBound));
263 #endif
264 static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
265 Tcl_Obj *objPtr));
266
267 /*
268 * Table describing the built-in math functions. Entries in this table are
269 * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
270 * operand byte.
271 */
272
273 BuiltinFunc builtinFuncTable[] = {
274 #ifndef TCL_NO_MATH
275 {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
276 {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
277 {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
278 {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
279 {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
280 {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
281 {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
282 {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
283 {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
284 {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
285 {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
286 {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
287 {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
288 {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
289 {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
290 {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
291 {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
292 {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
293 {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
294 #endif
295 {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
296 {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
297 {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
298 {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
299 {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
300 {"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
301 {0},
302 };
303
304 /*
305 * The structure below defines the command name Tcl object type by means of
306 * procedures that can be invoked by generic object code. Objects of this
307 * type cache the Command pointer that results from looking up command names
308 * in the command hashtable. Such objects appear as the zeroth ("command
309 * name") argument in a Tcl command.
310 */
311
312 Tcl_ObjType tclCmdNameType = {
313 "cmdName", /* name */
314 FreeCmdNameInternalRep, /* freeIntRepProc */
315 DupCmdNameInternalRep, /* dupIntRepProc */
316 (Tcl_UpdateStringProc *) NULL, /* updateStringProc */
317 SetCmdNameFromAny /* setFromAnyProc */
318 };
319
320 /*
321 *----------------------------------------------------------------------
322 *
323 * InitByteCodeExecution --
324 *
325 * This procedure is called once to initialize the Tcl bytecode
326 * interpreter.
327 *
328 * Results:
329 * None.
330 *
331 * Side effects:
332 * This procedure initializes the array of instruction names. If
333 * compiling with the TCL_COMPILE_STATS flag, it initializes the
334 * array that counts the executions of each instruction and it
335 * creates the "evalstats" command. It also registers the command name
336 * Tcl_ObjType. It also establishes the link between the Tcl
337 * "tcl_traceExec" and C "tclTraceExec" variables.
338 *
339 *----------------------------------------------------------------------
340 */
341
342 static void
343 InitByteCodeExecution(interp)
344 Tcl_Interp *interp; /* Interpreter for which the Tcl variable
345 * "tcl_traceExec" is linked to control
346 * instruction tracing. */
347 {
348 Tcl_RegisterObjType(&tclCmdNameType);
349 if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
350 TCL_LINK_INT) != TCL_OK) {
351 panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
352 }
353
354 #ifdef TCL_COMPILE_STATS
355 Tcl_CreateCommand(interp, "evalstats", EvalStatsCmd,
356 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
357 #endif /* TCL_COMPILE_STATS */
358 }
359
360 /*
361 *----------------------------------------------------------------------
362 *
363 * TclCreateExecEnv --
364 *
365 * This procedure creates a new execution environment for Tcl bytecode
366 * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
367 * is typically created once for each Tcl interpreter (Interp
368 * structure) and recursively passed to TclExecuteByteCode to execute
369 * ByteCode sequences for nested commands.
370 *
371 * Results:
372 * A newly allocated ExecEnv is returned. This points to an empty
373 * evaluation stack of the standard initial size.
374 *
375 * Side effects:
376 * The bytecode interpreter is also initialized here, as this
377 * procedure will be called before any call to TclExecuteByteCode.
378 *
379 *----------------------------------------------------------------------
380 */
381
382 #define TCL_STACK_INITIAL_SIZE 2000
383
384 ExecEnv *
385 TclCreateExecEnv(interp)
386 Tcl_Interp *interp; /* Interpreter for which the execution
387 * environment is being created. */
388 {
389 ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
390
391 eePtr->stackPtr = (Tcl_Obj **)
392 ckalloc((unsigned) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
393 eePtr->stackTop = -1;
394 eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 1);
395
396 Tcl_MutexLock(&execMutex);
397 if (!execInitialized) {
398 TclInitAuxDataTypeTable();
399 InitByteCodeExecution(interp);
400 execInitialized = 1;
401 }
402 Tcl_MutexUnlock(&execMutex);
403
404 return eePtr;
405 }
406 #undef TCL_STACK_INITIAL_SIZE
407
408 /*
409 *----------------------------------------------------------------------
410 *
411 * TclDeleteExecEnv --
412 *
413 * Frees the storage for an ExecEnv.
414 *
415 * Results:
416 * None.
417 *
418 * Side effects:
419 * Storage for an ExecEnv and its contained storage (e.g. the
420 * evaluation stack) is freed.
421 *
422 *----------------------------------------------------------------------
423 */
424
425 void
426 TclDeleteExecEnv(eePtr)
427 ExecEnv *eePtr; /* Execution environment to free. */
428 {
429 ckfree((char *) eePtr->stackPtr);
430 ckfree((char *) eePtr);
431 }
432
433 /*
434 *----------------------------------------------------------------------
435 *
436 * TclFinalizeExecution --
437 *
438 * Finalizes the execution environment setup so that it can be
439 * later reinitialized.
440 *
441 * Results:
442 * None.
443 *
444 * Side effects:
445 * After this call, the next time TclCreateExecEnv will be called
446 * it will call InitByteCodeExecution.
447 *
448 *----------------------------------------------------------------------
449 */
450
451 void
452 TclFinalizeExecution()
453 {
454 Tcl_MutexLock(&execMutex);
455 execInitialized = 0;
456 Tcl_MutexUnlock(&execMutex);
457 TclFinalizeAuxDataTypeTable();
458 }
459
460 /*
461 *----------------------------------------------------------------------
462 *
463 * GrowEvaluationStack --
464 *
465 * This procedure grows a Tcl evaluation stack stored in an ExecEnv.
466 *
467 * Results:
468 * None.
469 *
470 * Side effects:
471 * The size of the evaluation stack is doubled.
472 *
473 *----------------------------------------------------------------------
474 */
475
476 static void
477 GrowEvaluationStack(eePtr)
478 register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
479 * stack to enlarge. */
480 {
481 /*
482 * The current Tcl stack elements are stored from eePtr->stackPtr[0]
483 * to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
484 */
485
486 int currElems = (eePtr->stackEnd + 1);
487 int newElems = 2*currElems;
488 int currBytes = currElems * sizeof(Tcl_Obj *);
489 int newBytes = 2*currBytes;
490 Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
491
492 /*
493 * Copy the existing stack items to the new stack space, free the old
494 * storage if appropriate, and mark new space as malloc'ed.
495 */
496
497 memcpy((VOID *) newStackPtr, (VOID *) eePtr->stackPtr,
498 (size_t) currBytes);
499 ckfree((char *) eePtr->stackPtr);
500 eePtr->stackPtr = newStackPtr;
501 eePtr->stackEnd = (newElems - 1); /* i.e. index of last usable item */
502 }
503
504 /*
505 *----------------------------------------------------------------------
506 *
507 * TclExecuteByteCode --
508 *
509 * This procedure executes the instructions of a ByteCode structure.
510 * It returns when a "done" instruction is executed or an error occurs.
511 *
512 * Results:
513 * The return value is one of the return codes defined in tcl.h
514 * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
515 * that either contains the result of executing the code or an
516 * error message.
517 *
518 * Side effects:
519 * Almost certainly, depending on the ByteCode's instructions.
520 *
521 *----------------------------------------------------------------------
522 */
523
524 int
525 TclExecuteByteCode(interp, codePtr)
526 Tcl_Interp *interp; /* Token for command interpreter. */
527 ByteCode *codePtr; /* The bytecode sequence to interpret. */
528 {
529 Interp *iPtr = (Interp *) interp;
530 ExecEnv *eePtr = iPtr->execEnvPtr;
531 /* Points to the execution environment. */
532 register Tcl_Obj **stackPtr = eePtr->stackPtr;
533 /* Cached evaluation stack base pointer. */
534 register int stackTop = eePtr->stackTop;
535 /* Cached top index of evaluation stack. */
536 register unsigned char *pc = codePtr->codeStart;
537 /* The current program counter. */
538 int opnd; /* Current instruction's operand byte. */
539 int pcAdjustment; /* Hold pc adjustment after instruction. */
540 int initStackTop = stackTop;/* Stack top at start of execution. */
541 ExceptionRange *rangePtr; /* Points to closest loop or catch exception
542 * range enclosing the pc. Used by various
543 * instructions and processCatch to
544 * process break, continue, and errors. */
545 int result = TCL_OK; /* Return code returned after execution. */
546 int traceInstructions = (tclTraceExec == 3);
547 Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
548 char *bytes;
549 int length;
550 long i;
551
552 /*
553 * This procedure uses a stack to hold information about catch commands.
554 * This information is the current operand stack top when starting to
555 * execute the code for each catch command. It starts out with stack-
556 * allocated space but uses dynamically-allocated storage if needed.
557 */
558
559 #define STATIC_CATCH_STACK_SIZE 4
560 int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
561 int *catchStackPtr = catchStackStorage;
562 int catchTop = -1;
563
564 #ifdef TCL_COMPILE_DEBUG
565 if (tclTraceExec >= 2) {
566 PrintByteCodeInfo(codePtr);
567 fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
568 fflush(stdout);
569 }
570 #endif
571
572 #ifdef TCL_COMPILE_STATS
573 iPtr->stats.numExecutions++;
574 #endif
575
576 /*
577 * Make sure the catch stack is large enough to hold the maximum number
578 * of catch commands that could ever be executing at the same time. This
579 * will be no more than the exception range array's depth.
580 */
581
582 if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
583 catchStackPtr = (int *)
584 ckalloc(codePtr->maxExceptDepth * sizeof(int));
585 }
586
587 /*
588 * Make sure the stack has enough room to execute this ByteCode.
589 */
590
591 while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
592 GrowEvaluationStack(eePtr);
593 stackPtr = eePtr->stackPtr;
594 }
595
596 /*
597 * Loop executing instructions until a "done" instruction, a TCL_RETURN,
598 * or some error.
599 */
600
601 for (;;) {
602 #ifdef TCL_COMPILE_DEBUG
603 ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop,
604 eePtr->stackEnd);
605 #else /* not TCL_COMPILE_DEBUG */
606 if (traceInstructions) {
607 fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
608 TclPrintInstruction(codePtr, pc);
609 fflush(stdout);
610 }
611 #endif /* TCL_COMPILE_DEBUG */
612
613 #ifdef TCL_COMPILE_STATS
614 iPtr->stats.instructionCount[*pc]++;
615 #endif
616 switch (*pc) {
617 case INST_DONE:
618 /*
619 * Pop the topmost object from the stack, set the interpreter's
620 * object result to point to it, and return.
621 */
622 valuePtr = POP_OBJECT();
623 Tcl_SetObjResult(interp, valuePtr);
624 TclDecrRefCount(valuePtr);
625 if (stackTop != initStackTop) {
626 fprintf(stderr, "\nTclExecuteByteCode: done instruction at pc %u: stack top %d != entry stack top %d\n",
627 (unsigned int)(pc - codePtr->codeStart),
628 (unsigned int) stackTop,
629 (unsigned int) initStackTop);
630 panic("TclExecuteByteCode execution failure: end stack top != start stack top");
631 }
632 TRACE_WITH_OBJ(("=> return code=%d, result=", result),
633 iPtr->objResultPtr);
634 #ifdef TCL_COMPILE_DEBUG
635 if (traceInstructions) {
636 fprintf(stdout, "\n");
637 }
638 #endif
639 goto done;
640
641 case INST_PUSH1:
642 #ifdef TCL_COMPILE_DEBUG
643 valuePtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
644 PUSH_OBJECT(valuePtr);
645 TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), valuePtr);
646 #else
647 PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
648 #endif /* TCL_COMPILE_DEBUG */
649 ADJUST_PC(2);
650
651 case INST_PUSH4:
652 valuePtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
653 PUSH_OBJECT(valuePtr);
654 TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), valuePtr);
655 ADJUST_PC(5);
656
657 case INST_POP:
658 valuePtr = POP_OBJECT();
659 TRACE_WITH_OBJ(("=> discarding "), valuePtr);
660 TclDecrRefCount(valuePtr); /* finished with pop'ed object. */
661 ADJUST_PC(1);
662
663 case INST_DUP:
664 valuePtr = stackPtr[stackTop];
665 PUSH_OBJECT(Tcl_DuplicateObj(valuePtr));
666 TRACE_WITH_OBJ(("=> "), valuePtr);
667 ADJUST_PC(1);
668
669 case INST_CONCAT1:
670 opnd = TclGetUInt1AtPtr(pc+1);
671 {
672 Tcl_Obj *concatObjPtr;
673 int totalLen = 0;
674
675 /*
676 * Concatenate strings (with no separators) from the top
677 * opnd items on the stack starting with the deepest item.
678 * First, determine how many characters are needed.
679 */
680
681 for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
682 bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
683 if (bytes != NULL) {
684 totalLen += length;
685 }
686 }
687
688 /*
689 * Initialize the new append string object by appending the
690 * strings of the opnd stack objects. Also pop the objects.
691 */
692
693 TclNewObj(concatObjPtr);
694 if (totalLen > 0) {
695 char *p = (char *) ckalloc((unsigned) (totalLen + 1));
696 concatObjPtr->bytes = p;
697 concatObjPtr->length = totalLen;
698 for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
699 valuePtr = stackPtr[i];
700 bytes = Tcl_GetStringFromObj(valuePtr, &length);
701 if (bytes != NULL) {
702 memcpy((VOID *) p, (VOID *) bytes,
703 (size_t) length);
704 p += length;
705 }
706 TclDecrRefCount(valuePtr);
707 }
708 *p = '\0';
709 } else {
710 for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
711 Tcl_DecrRefCount(stackPtr[i]);
712 }
713 }
714 stackTop -= opnd;
715
716 PUSH_OBJECT(concatObjPtr);
717 TRACE_WITH_OBJ(("%u => ", opnd), concatObjPtr);
718 ADJUST_PC(2);
719 }
720
721 case INST_INVOKE_STK4:
722 opnd = TclGetUInt4AtPtr(pc+1);
723 pcAdjustment = 5;
724 goto doInvocation;
725
726 case INST_INVOKE_STK1:
727 opnd = TclGetUInt1AtPtr(pc+1);
728 pcAdjustment = 2;
729
730 doInvocation:
731 {
732 int objc = opnd; /* The number of arguments. */
733 Tcl_Obj **objv; /* The array of argument objects. */
734 Command *cmdPtr; /* Points to command's Command struct. */
735 int newPcOffset; /* New inst offset for break, continue. */
736 #ifdef TCL_COMPILE_DEBUG
737 int isUnknownCmd = 0;
738 char cmdNameBuf[21];
739 #endif /* TCL_COMPILE_DEBUG */
740
741 /*
742 * If the interpreter was deleted, return an error.
743 */
744
745 if (iPtr->flags & DELETED) {
746 Tcl_ResetResult(interp);
747 Tcl_AppendToObj(Tcl_GetObjResult(interp),
748 "attempt to call eval in deleted interpreter", -1);
749 Tcl_SetErrorCode(interp, "CORE", "IDELETE",
750 "attempt to call eval in deleted interpreter",
751 (char *) NULL);
752 result = TCL_ERROR;
753 goto checkForCatch;
754 }
755
756 /*
757 * Find the procedure to execute this command. If the
758 * command is not found, handle it with the "unknown" proc.
759 */
760
761 objv = &(stackPtr[stackTop - (objc-1)]);
762 cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
763 if (cmdPtr == NULL) {
764 cmdPtr = (Command *) Tcl_FindCommand(interp, "unknown",
765 (Tcl_Namespace *) NULL, TCL_GLOBAL_ONLY);
766 if (cmdPtr == NULL) {
767 Tcl_ResetResult(interp);
768 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
769 "invalid command name \"",
770 Tcl_GetString(objv[0]), "\"",
771 (char *) NULL);
772 TRACE(("%u => unknown proc not found: ", objc));
773 result = TCL_ERROR;
774 goto checkForCatch;
775 }
776 #ifdef TCL_COMPILE_DEBUG
777 isUnknownCmd = 1;
778 #endif /*TCL_COMPILE_DEBUG*/
779 stackTop++; /* need room for new inserted objv[0] */
780 for (i = objc-1; i >= 0; i--) {
781 objv[i+1] = objv[i];
782 }
783 objc++;
784 objv[0] = Tcl_NewStringObj("unknown", -1);
785 Tcl_IncrRefCount(objv[0]);
786 }
787
788 /*
789 * Call any trace procedures.
790 */
791
792 if (iPtr->tracePtr != NULL) {
793 Trace *tracePtr, *nextTracePtr;
794
795 for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
796 tracePtr = nextTracePtr) {
797 nextTracePtr = tracePtr->nextPtr;
798 if (iPtr->numLevels <= tracePtr->level) {
799 int numChars;
800 char *cmd = GetSrcInfoForPc(pc, codePtr,
801 &numChars);
802 if (cmd != NULL) {
803 DECACHE_STACK_INFO();
804 CallTraceProcedure(interp, tracePtr, cmdPtr,
805 cmd, numChars, objc, objv);
806 CACHE_STACK_INFO();
807 }
808 }
809 }
810 }
811
812 /*
813 * Finally, invoke the command's Tcl_ObjCmdProc. First reset
814 * the interpreter's string and object results to their
815 * default empty values since they could have gotten changed
816 * by earlier invocations.
817 */
818
819 Tcl_ResetResult(interp);
820 if (tclTraceExec >= 2) {
821 #ifdef TCL_COMPILE_DEBUG
822 if (traceInstructions) {
823 strncpy(cmdNameBuf, Tcl_GetString(objv[0]), 20);
824 TRACE(("%u => call ", (isUnknownCmd? objc-1:objc)));
825 } else {
826 fprintf(stdout, "%d: (%u) invoking ",
827 iPtr->numLevels,
828 (unsigned int)(pc - codePtr->codeStart));
829 }
830 for (i = 0; i < objc; i++) {
831 TclPrintObject(stdout, objv[i], 15);
832 fprintf(stdout, " ");
833 }
834 fprintf(stdout, "\n");
835 fflush(stdout);
836 #else /* TCL_COMPILE_DEBUG */
837 fprintf(stdout, "%d: (%u) invoking %s\n",
838 iPtr->numLevels,
839 (unsigned int)(pc - codePtr->codeStart),
840 Tcl_GetString(objv[0]));
841 #endif /*TCL_COMPILE_DEBUG*/
842 }
843
844 iPtr->cmdCount++;
845 DECACHE_STACK_INFO();
846 result = (*cmdPtr->objProc)(cmdPtr->objClientData, interp,
847 objc, objv);
848 if (Tcl_AsyncReady()) {
849 result = Tcl_AsyncInvoke(interp, result);
850 }
851 CACHE_STACK_INFO();
852
853 /*
854 * If the interpreter has a non-empty string result, the
855 * result object is either empty or stale because some
856 * procedure set interp->result directly. If so, move the
857 * string result to the result object, then reset the
858 * string result.
859 */
860
861 if (*(iPtr->result) != 0) {
862 (void) Tcl_GetObjResult(interp);
863 }
864
865 /*
866 * Pop the objc top stack elements and decrement their ref
867 * counts.
868 */
869
870 for (i = 0; i < objc; i++) {
871 valuePtr = stackPtr[stackTop];
872 TclDecrRefCount(valuePtr);
873 stackTop--;
874 }
875
876 /*
877 * Process the result of the Tcl_ObjCmdProc call.
878 */
879
880 switch (result) {
881 case TCL_OK:
882 /*
883 * Push the call's object result and continue execution
884 * with the next instruction.
885 */
886 PUSH_OBJECT(Tcl_GetObjResult(interp));
887 TRACE_WITH_OBJ(("%u => ...after \"%.20s\", result=",
888 objc, cmdNameBuf), Tcl_GetObjResult(interp));
889 ADJUST_PC(pcAdjustment);
890
891 case TCL_BREAK:
892 case TCL_CONTINUE:
893 /*
894 * The invoked command requested a break or continue.
895 * Find the closest enclosing loop or catch exception
896 * range, if any. If a loop is found, terminate its
897 * execution or skip to its next iteration. If the
898 * closest is a catch exception range, jump to its
899 * catchOffset. If no enclosing range is found, stop
900 * execution and return the TCL_BREAK or TCL_CONTINUE.
901 */
902 rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
903 codePtr);
904 if (rangePtr == NULL) {
905 TRACE(("%u => ... after \"%.20s\", no encl. loop or catch, returning %s\n",
906 objc, cmdNameBuf,
907 StringForResultCode(result)));
908 goto abnormalReturn; /* no catch exists to check */
909 }
910 newPcOffset = 0;
911 switch (rangePtr->type) {
912 case LOOP_EXCEPTION_RANGE:
913 if (result == TCL_BREAK) {
914 newPcOffset = rangePtr->breakOffset;
915 } else if (rangePtr->continueOffset == -1) {
916 TRACE(("%u => ... after \"%.20s\", %s, loop w/o continue, checking for catch\n",
917 objc, cmdNameBuf,
918 StringForResultCode(result)));
919 goto checkForCatch;
920 } else {
921 newPcOffset = rangePtr->continueOffset;
922 }
923 TRACE(("%u => ... after \"%.20s\", %s, range at %d, new pc %d\n",
924 objc, cmdNameBuf,
925 StringForResultCode(result),
926 rangePtr->codeOffset, newPcOffset));
927 break;
928 case CATCH_EXCEPTION_RANGE:
929 TRACE(("%u => ... after \"%.20s\", %s...\n",
930 objc, cmdNameBuf,
931 StringForResultCode(result)));
932 goto processCatch; /* it will use rangePtr */
933 default:
934 panic("TclExecuteByteCode: bad ExceptionRange type\n");
935 }
936 result = TCL_OK;
937 pc = (codePtr->codeStart + newPcOffset);
938 continue; /* restart outer instruction loop at pc */
939
940 case TCL_ERROR:
941 /*
942 * The invoked command returned an error. Look for an
943 * enclosing catch exception range, if any.
944 */
945 TRACE_WITH_OBJ(("%u => ... after \"%.20s\", TCL_ERROR ",
946 objc, cmdNameBuf), Tcl_GetObjResult(interp));
947 goto checkForCatch;
948
949 case TCL_RETURN:
950 /*
951 * The invoked command requested that the current
952 * procedure stop execution and return. First check
953 * for an enclosing catch exception range, if any.
954 */
955 TRACE(("%u => ... after \"%.20s\", TCL_RETURN\n",
956 objc, cmdNameBuf));
957 goto checkForCatch;
958
959 default:
960 TRACE_WITH_OBJ(("%u => ... after \"%.20s\", OTHER RETURN CODE %d ",
961 objc, cmdNameBuf, result),
962 Tcl_GetObjResult(interp));
963 goto checkForCatch;
964 }
965 }
966
967 case INST_EVAL_STK:
968 objPtr = POP_OBJECT();
969 DECACHE_STACK_INFO();
970 result = Tcl_EvalObjEx(interp, objPtr, 0);
971 CACHE_STACK_INFO();
972 if (result == TCL_OK) {
973 /*
974 * Normal return; push the eval's object result.
975 */
976 PUSH_OBJECT(Tcl_GetObjResult(interp));
977 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
978 Tcl_GetObjResult(interp));
979 TclDecrRefCount(objPtr);
980 ADJUST_PC(1);
981 } else if ((result == TCL_BREAK) || (result == TCL_CONTINUE)) {
982 /*
983 * Find the closest enclosing loop or catch exception range,
984 * if any. If a loop is found, terminate its execution or
985 * skip to its next iteration. If the closest is a catch
986 * exception range, jump to its catchOffset. If no enclosing
987 * range is found, stop execution and return that same
988 * TCL_BREAK or TCL_CONTINUE.
989 */
990
991 int newPcOffset = 0; /* Pc offset computed during break,
992 * continue, error processing. Init.
993 * to avoid compiler warning. */
994
995 rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0,
996 codePtr);
997 if (rangePtr == NULL) {
998 TRACE(("\"%.30s\" => no encl. loop or catch, returning %s\n",
999 O2S(objPtr), StringForResultCode(result)));
1000 Tcl_DecrRefCount(objPtr);
1001 goto abnormalReturn; /* no catch exists to check */
1002 }
1003 switch (rangePtr->type) {
1004 case LOOP_EXCEPTION_RANGE:
1005 if (result == TCL_BREAK) {
1006 newPcOffset = rangePtr->breakOffset;
1007 } else if (rangePtr->continueOffset == -1) {
1008 TRACE(("\"%.30s\" => %s, loop w/o continue, checking for catch\n",
1009 O2S(objPtr), StringForResultCode(result)));
1010 Tcl_DecrRefCount(objPtr);
1011 goto checkForCatch;
1012 } else {
1013 newPcOffset = rangePtr->continueOffset;
1014 }
1015 result = TCL_OK;
1016 TRACE_WITH_OBJ(("\"%.30s\" => %s, range at %d, new pc %d ",
1017 O2S(objPtr), StringForResultCode(result),
1018 rangePtr->codeOffset, newPcOffset), valuePtr);
1019 break;
1020 case CATCH_EXCEPTION_RANGE:
1021 TRACE_WITH_OBJ(("\"%.30s\" => %s ",
1022 O2S(objPtr), StringForResultCode(result)),
1023 valuePtr);
1024 Tcl_DecrRefCount(objPtr);
1025 goto processCatch; /* it will use rangePtr */
1026 default:
1027 panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
1028 }
1029 Tcl_DecrRefCount(objPtr);
1030 pc = (codePtr->codeStart + newPcOffset);
1031 continue; /* restart outer instruction loop at pc */
1032 } else { /* eval returned TCL_ERROR, TCL_RETURN, unknown code */
1033 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
1034 Tcl_GetObjResult(interp));
1035 Tcl_DecrRefCount(objPtr);
1036 goto checkForCatch;
1037 }
1038
1039 case INST_EXPR_STK:
1040 objPtr = POP_OBJECT();
1041 Tcl_ResetResult(interp);
1042 DECACHE_STACK_INFO();
1043 result = Tcl_ExprObj(interp, objPtr, &valuePtr);
1044 CACHE_STACK_INFO();
1045 if (result != TCL_OK) {
1046 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1047 O2S(objPtr)), Tcl_GetObjResult(interp));
1048 Tcl_DecrRefCount(objPtr);
1049 goto checkForCatch;
1050 }
1051 stackPtr[++stackTop] = valuePtr; /* already has right refct */
1052 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1053 TclDecrRefCount(objPtr);
1054 ADJUST_PC(1);
1055
1056 case INST_LOAD_SCALAR1:
1057 #ifdef TCL_COMPILE_DEBUG
1058 opnd = TclGetUInt1AtPtr(pc+1);
1059 DECACHE_STACK_INFO();
1060 valuePtr = TclGetIndexedScalar(interp, opnd,
1061 /*leaveErrorMsg*/ 1);
1062 CACHE_STACK_INFO();
1063 if (valuePtr == NULL) {
1064 TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
1065 Tcl_GetObjResult(interp));
1066 result = TCL_ERROR;
1067 goto checkForCatch;
1068 }
1069 PUSH_OBJECT(valuePtr);
1070 TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
1071 #else /* TCL_COMPILE_DEBUG */
1072 DECACHE_STACK_INFO();
1073 opnd = TclGetUInt1AtPtr(pc+1);
1074 valuePtr = TclGetIndexedScalar(interp, opnd, /*leaveErrorMsg*/ 1);
1075 CACHE_STACK_INFO();
1076 if (valuePtr == NULL) {
1077 result = TCL_ERROR;
1078 goto checkForCatch;
1079 }
1080 PUSH_OBJECT(valuePtr);
1081 #endif /* TCL_COMPILE_DEBUG */
1082 ADJUST_PC(2);
1083
1084 case INST_LOAD_SCALAR4:
1085 opnd = TclGetUInt4AtPtr(pc+1);
1086 DECACHE_STACK_INFO();
1087 valuePtr = TclGetIndexedScalar(interp, opnd,
1088 /*leaveErrorMsg*/ 1);
1089 CACHE_STACK_INFO();
1090 if (valuePtr == NULL) {
1091 TRACE_WITH_OBJ(("%u => ERROR: ", opnd),
1092 Tcl_GetObjResult(interp));
1093 result = TCL_ERROR;
1094 goto checkForCatch;
1095 }
1096 PUSH_OBJECT(valuePtr);
1097 TRACE_WITH_OBJ(("%u => ", opnd), valuePtr);
1098 ADJUST_PC(5);
1099
1100 case INST_LOAD_SCALAR_STK:
1101 objPtr = POP_OBJECT(); /* scalar name */
1102 DECACHE_STACK_INFO();
1103 valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
1104 CACHE_STACK_INFO();
1105 if (valuePtr == NULL) {
1106 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
1107 Tcl_GetObjResult(interp));
1108 Tcl_DecrRefCount(objPtr);
1109 result = TCL_ERROR;
1110 goto checkForCatch;
1111 }
1112 PUSH_OBJECT(valuePtr);
1113 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1114 TclDecrRefCount(objPtr);
1115 ADJUST_PC(1);
1116
1117 case INST_LOAD_ARRAY4:
1118 opnd = TclGetUInt4AtPtr(pc+1);
1119 pcAdjustment = 5;
1120 goto doLoadArray;
1121
1122 case INST_LOAD_ARRAY1:
1123 opnd = TclGetUInt1AtPtr(pc+1);
1124 pcAdjustment = 2;
1125
1126 doLoadArray:
1127 {
1128 Tcl_Obj *elemPtr = POP_OBJECT();
1129
1130 DECACHE_STACK_INFO();
1131 valuePtr = TclGetElementOfIndexedArray(interp, opnd,
1132 elemPtr, /*leaveErrorMsg*/ 1);
1133 CACHE_STACK_INFO();
1134 if (valuePtr == NULL) {
1135 TRACE_WITH_OBJ(("%u \"%.30s\" => ERROR: ",
1136 opnd, O2S(elemPtr)), Tcl_GetObjResult(interp));
1137 Tcl_DecrRefCount(elemPtr);
1138 result = TCL_ERROR;
1139 goto checkForCatch;
1140 }
1141 PUSH_OBJECT(valuePtr);
1142 TRACE_WITH_OBJ(("%u \"%.30s\" => ",
1143 opnd, O2S(elemPtr)),valuePtr);
1144 TclDecrRefCount(elemPtr);
1145 }
1146 ADJUST_PC(pcAdjustment);
1147
1148 case INST_LOAD_ARRAY_STK:
1149 {
1150 Tcl_Obj *elemPtr = POP_OBJECT();
1151
1152 objPtr = POP_OBJECT(); /* array name */
1153 DECACHE_STACK_INFO();
1154 valuePtr = Tcl_ObjGetVar2(interp, objPtr, elemPtr,
1155 TCL_LEAVE_ERR_MSG);
1156 CACHE_STACK_INFO();
1157 if (valuePtr == NULL) {
1158 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ERROR: ",
1159 O2S(objPtr), O2S(elemPtr)),
1160 Tcl_GetObjResult(interp));
1161 Tcl_DecrRefCount(objPtr);
1162 Tcl_DecrRefCount(elemPtr);
1163 result = TCL_ERROR;
1164 goto checkForCatch;
1165 }
1166 PUSH_OBJECT(valuePtr);
1167 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" => ",
1168 O2S(objPtr), O2S(elemPtr)), valuePtr);
1169 TclDecrRefCount(objPtr);
1170 TclDecrRefCount(elemPtr);
1171 }
1172 ADJUST_PC(1);
1173
1174 case INST_LOAD_STK:
1175 objPtr = POP_OBJECT(); /* variable name */
1176 DECACHE_STACK_INFO();
1177 valuePtr = Tcl_ObjGetVar2(interp, objPtr, NULL, TCL_LEAVE_ERR_MSG);
1178 CACHE_STACK_INFO();
1179 if (valuePtr == NULL) {
1180 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1181 O2S(objPtr)), Tcl_GetObjResult(interp));
1182 Tcl_DecrRefCount(objPtr);
1183 result = TCL_ERROR;
1184 goto checkForCatch;
1185 }
1186 PUSH_OBJECT(valuePtr);
1187 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1188 TclDecrRefCount(objPtr);
1189 ADJUST_PC(1);
1190
1191 case INST_STORE_SCALAR4:
1192 opnd = TclGetUInt4AtPtr(pc+1);
1193 pcAdjustment = 5;
1194 goto doStoreScalar;
1195
1196 case INST_STORE_SCALAR1:
1197 opnd = TclGetUInt1AtPtr(pc+1);
1198 pcAdjustment = 2;
1199
1200 doStoreScalar:
1201 valuePtr = POP_OBJECT();
1202 DECACHE_STACK_INFO();
1203 value2Ptr = TclSetIndexedScalar(interp, opnd, valuePtr,
1204 /*leaveErrorMsg*/ 1);
1205 CACHE_STACK_INFO();
1206 if (value2Ptr == NULL) {
1207 TRACE_WITH_OBJ(("%u <- \"%.30s\" => ERROR: ",
1208 opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1209 Tcl_DecrRefCount(valuePtr);
1210 result = TCL_ERROR;
1211 goto checkForCatch;
1212 }
1213 PUSH_OBJECT(value2Ptr);
1214 TRACE_WITH_OBJ(("%u <- \"%.30s\" => ",
1215 opnd, O2S(valuePtr)), value2Ptr);
1216 TclDecrRefCount(valuePtr);
1217 ADJUST_PC(pcAdjustment);
1218
1219 case INST_STORE_SCALAR_STK:
1220 valuePtr = POP_OBJECT();
1221 objPtr = POP_OBJECT(); /* scalar name */
1222 DECACHE_STACK_INFO();
1223 value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
1224 TCL_LEAVE_ERR_MSG);
1225 CACHE_STACK_INFO();
1226 if (value2Ptr == NULL) {
1227 TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
1228 O2S(objPtr), O2S(valuePtr)),
1229 Tcl_GetObjResult(interp));
1230 Tcl_DecrRefCount(objPtr);
1231 Tcl_DecrRefCount(valuePtr);
1232 result = TCL_ERROR;
1233 goto checkForCatch;
1234 }
1235 PUSH_OBJECT(value2Ptr);
1236 TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
1237 O2S(objPtr), O2S(valuePtr)), value2Ptr);
1238 TclDecrRefCount(objPtr);
1239 TclDecrRefCount(valuePtr);
1240 ADJUST_PC(1);
1241
1242 case INST_STORE_ARRAY4:
1243 opnd = TclGetUInt4AtPtr(pc+1);
1244 pcAdjustment = 5;
1245 goto doStoreArray;
1246
1247 case INST_STORE_ARRAY1:
1248 opnd = TclGetUInt1AtPtr(pc+1);
1249 pcAdjustment = 2;
1250
1251 doStoreArray:
1252 {
1253 Tcl_Obj *elemPtr;
1254
1255 valuePtr = POP_OBJECT();
1256 elemPtr = POP_OBJECT();
1257 DECACHE_STACK_INFO();
1258 value2Ptr = TclSetElementOfIndexedArray(interp, opnd,
1259 elemPtr, valuePtr, TCL_LEAVE_ERR_MSG);
1260 CACHE_STACK_INFO();
1261 if (value2Ptr == NULL) {
1262 TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ERROR: ",
1263 opnd, O2S(elemPtr), O2S(valuePtr)),
1264 Tcl_GetObjResult(interp));
1265 Tcl_DecrRefCount(elemPtr);
1266 Tcl_DecrRefCount(valuePtr);
1267 result = TCL_ERROR;
1268 goto checkForCatch;
1269 }
1270 PUSH_OBJECT(value2Ptr);
1271 TRACE_WITH_OBJ(("%u \"%.30s\" <- \"%.30s\" => ",
1272 opnd, O2S(elemPtr), O2S(valuePtr)), value2Ptr);
1273 TclDecrRefCount(elemPtr);
1274 TclDecrRefCount(valuePtr);
1275 }
1276 ADJUST_PC(pcAdjustment);
1277
1278 case INST_STORE_ARRAY_STK:
1279 {
1280 Tcl_Obj *elemPtr;
1281
1282 valuePtr = POP_OBJECT();
1283 elemPtr = POP_OBJECT();
1284 objPtr = POP_OBJECT(); /* array name */
1285 DECACHE_STACK_INFO();
1286 value2Ptr = Tcl_ObjSetVar2(interp, objPtr, elemPtr, valuePtr,
1287 TCL_LEAVE_ERR_MSG);
1288 CACHE_STACK_INFO();
1289 if (value2Ptr == NULL) {
1290 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ERROR: ",
1291 O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1292 Tcl_GetObjResult(interp));
1293 Tcl_DecrRefCount(objPtr);
1294 Tcl_DecrRefCount(elemPtr);
1295 Tcl_DecrRefCount(valuePtr);
1296 result = TCL_ERROR;
1297 goto checkForCatch;
1298 }
1299 PUSH_OBJECT(value2Ptr);
1300 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
1301 O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1302 value2Ptr);
1303 TclDecrRefCount(objPtr);
1304 TclDecrRefCount(elemPtr);
1305 TclDecrRefCount(valuePtr);
1306 }
1307 ADJUST_PC(1);
1308
1309 case INST_STORE_STK:
1310 valuePtr = POP_OBJECT();
1311 objPtr = POP_OBJECT(); /* variable name */
1312 DECACHE_STACK_INFO();
1313 value2Ptr = Tcl_ObjSetVar2(interp, objPtr, NULL, valuePtr,
1314 TCL_LEAVE_ERR_MSG);
1315 CACHE_STACK_INFO();
1316 if (value2Ptr == NULL) {
1317 TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ERROR: ",
1318 O2S(objPtr), O2S(valuePtr)),
1319 Tcl_GetObjResult(interp));
1320 Tcl_DecrRefCount(objPtr);
1321 Tcl_DecrRefCount(valuePtr);
1322 result = TCL_ERROR;
1323 goto checkForCatch;
1324 }
1325 PUSH_OBJECT(value2Ptr);
1326 TRACE_WITH_OBJ(("\"%.30s\" <- \"%.30s\" => ",
1327 O2S(objPtr), O2S(valuePtr)), value2Ptr);
1328 TclDecrRefCount(objPtr);
1329 TclDecrRefCount(valuePtr);
1330 ADJUST_PC(1);
1331
1332 case INST_INCR_SCALAR1:
1333 opnd = TclGetUInt1AtPtr(pc+1);
1334 valuePtr = POP_OBJECT();
1335 if (valuePtr->typePtr != &tclIntType) {
1336 result = tclIntType.setFromAnyProc(interp, valuePtr);
1337 if (result != TCL_OK) {
1338 TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
1339 opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1340 Tcl_DecrRefCount(valuePtr);
1341 goto checkForCatch;
1342 }
1343 }
1344 i = valuePtr->internalRep.longValue;
1345 DECACHE_STACK_INFO();
1346 value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1347 CACHE_STACK_INFO();
1348 if (value2Ptr == NULL) {
1349 TRACE_WITH_OBJ(("%u (by %ld) => ERROR: ", opnd, i),
1350 Tcl_GetObjResult(interp));
1351 Tcl_DecrRefCount(valuePtr);
1352 result = TCL_ERROR;
1353 goto checkForCatch;
1354 }
1355 PUSH_OBJECT(value2Ptr);
1356 TRACE_WITH_OBJ(("%u (by %ld) => ", opnd, i), value2Ptr);
1357 TclDecrRefCount(valuePtr);
1358 ADJUST_PC(2);
1359
1360 case INST_INCR_SCALAR_STK:
1361 case INST_INCR_STK:
1362 valuePtr = POP_OBJECT();
1363 objPtr = POP_OBJECT(); /* scalar name */
1364 if (valuePtr->typePtr != &tclIntType) {
1365 result = tclIntType.setFromAnyProc(interp, valuePtr);
1366 if (result != TCL_OK) {
1367 TRACE_WITH_OBJ(("\"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1368 O2S(objPtr), O2S(valuePtr)),
1369 Tcl_GetObjResult(interp));
1370 Tcl_DecrRefCount(objPtr);
1371 Tcl_DecrRefCount(valuePtr);
1372 goto checkForCatch;
1373 }
1374 }
1375 i = valuePtr->internalRep.longValue;
1376 DECACHE_STACK_INFO();
1377 value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
1378 TCL_LEAVE_ERR_MSG);
1379 CACHE_STACK_INFO();
1380 if (value2Ptr == NULL) {
1381 TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ERROR: ",
1382 O2S(objPtr), i), Tcl_GetObjResult(interp));
1383 Tcl_DecrRefCount(objPtr);
1384 Tcl_DecrRefCount(valuePtr);
1385 result = TCL_ERROR;
1386 goto checkForCatch;
1387 }
1388 PUSH_OBJECT(value2Ptr);
1389 TRACE_WITH_OBJ(("\"%.30s\" (by %ld) => ", O2S(objPtr), i),
1390 value2Ptr);
1391 Tcl_DecrRefCount(objPtr);
1392 Tcl_DecrRefCount(valuePtr);
1393 ADJUST_PC(1);
1394
1395 case INST_INCR_ARRAY1:
1396 {
1397 Tcl_Obj *elemPtr;
1398
1399 opnd = TclGetUInt1AtPtr(pc+1);
1400 valuePtr = POP_OBJECT();
1401 elemPtr = POP_OBJECT();
1402 if (valuePtr->typePtr != &tclIntType) {
1403 result = tclIntType.setFromAnyProc(interp, valuePtr);
1404 if (result != TCL_OK) {
1405 TRACE_WITH_OBJ(("%u \"%.30s\" (by %s) => ERROR converting increment amount to int: ",
1406 opnd, O2S(elemPtr), O2S(valuePtr)),
1407 Tcl_GetObjResult(interp));
1408 Tcl_DecrRefCount(elemPtr);
1409 Tcl_DecrRefCount(valuePtr);
1410 goto checkForCatch;
1411 }
1412 }
1413 i = valuePtr->internalRep.longValue;
1414 DECACHE_STACK_INFO();
1415 value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1416 elemPtr, i);
1417 CACHE_STACK_INFO();
1418 if (value2Ptr == NULL) {
1419 TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
1420 opnd, O2S(elemPtr), i),
1421 Tcl_GetObjResult(interp));
1422 Tcl_DecrRefCount(elemPtr);
1423 Tcl_DecrRefCount(valuePtr);
1424 result = TCL_ERROR;
1425 goto checkForCatch;
1426 }
1427 PUSH_OBJECT(value2Ptr);
1428 TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
1429 opnd, O2S(elemPtr), i), value2Ptr);
1430 Tcl_DecrRefCount(elemPtr);
1431 Tcl_DecrRefCount(valuePtr);
1432 }
1433 ADJUST_PC(2);
1434
1435 case INST_INCR_ARRAY_STK:
1436 {
1437 Tcl_Obj *elemPtr;
1438
1439 valuePtr = POP_OBJECT();
1440 elemPtr = POP_OBJECT();
1441 objPtr = POP_OBJECT(); /* array name */
1442 if (valuePtr->typePtr != &tclIntType) {
1443 result = tclIntType.setFromAnyProc(interp, valuePtr);
1444 if (result != TCL_OK) {
1445 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %s) => ERROR converting increment amount to int: ",
1446 O2S(objPtr), O2S(elemPtr), O2S(valuePtr)),
1447 Tcl_GetObjResult(interp));
1448 Tcl_DecrRefCount(objPtr);
1449 Tcl_DecrRefCount(elemPtr);
1450 Tcl_DecrRefCount(valuePtr);
1451 goto checkForCatch;
1452 }
1453 }
1454 i = valuePtr->internalRep.longValue;
1455 DECACHE_STACK_INFO();
1456 value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
1457 TCL_LEAVE_ERR_MSG);
1458 CACHE_STACK_INFO();
1459 if (value2Ptr == NULL) {
1460 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
1461 O2S(objPtr), O2S(elemPtr), i),
1462 Tcl_GetObjResult(interp));
1463 Tcl_DecrRefCount(objPtr);
1464 Tcl_DecrRefCount(elemPtr);
1465 Tcl_DecrRefCount(valuePtr);
1466 result = TCL_ERROR;
1467 goto checkForCatch;
1468 }
1469 PUSH_OBJECT(value2Ptr);
1470 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
1471 O2S(objPtr), O2S(elemPtr), i), value2Ptr);
1472 Tcl_DecrRefCount(objPtr);
1473 Tcl_DecrRefCount(elemPtr);
1474 Tcl_DecrRefCount(valuePtr);
1475 }
1476 ADJUST_PC(1);
1477
1478 case INST_INCR_SCALAR1_IMM:
1479 opnd = TclGetUInt1AtPtr(pc+1);
1480 i = TclGetInt1AtPtr(pc+2);
1481 DECACHE_STACK_INFO();
1482 value2Ptr = TclIncrIndexedScalar(interp, opnd, i);
1483 CACHE_STACK_INFO();
1484 if (value2Ptr == NULL) {
1485 TRACE_WITH_OBJ(("%u %ld => ERROR: ", opnd, i),
1486 Tcl_GetObjResult(interp));
1487 result = TCL_ERROR;
1488 goto checkForCatch;
1489 }
1490 PUSH_OBJECT(value2Ptr);
1491 TRACE_WITH_OBJ(("%u %ld => ", opnd, i), value2Ptr);
1492 ADJUST_PC(3);
1493
1494 case INST_INCR_SCALAR_STK_IMM:
1495 case INST_INCR_STK_IMM:
1496 objPtr = POP_OBJECT(); /* variable name */
1497 i = TclGetInt1AtPtr(pc+1);
1498 DECACHE_STACK_INFO();
1499 value2Ptr = TclIncrVar2(interp, objPtr, (Tcl_Obj *) NULL, i,
1500 TCL_LEAVE_ERR_MSG);
1501 CACHE_STACK_INFO();
1502 if (value2Ptr == NULL) {
1503 TRACE_WITH_OBJ(("\"%.30s\" %ld => ERROR: ",
1504 O2S(objPtr), i), Tcl_GetObjResult(interp));
1505 result = TCL_ERROR;
1506 Tcl_DecrRefCount(objPtr);
1507 goto checkForCatch;
1508 }
1509 PUSH_OBJECT(value2Ptr);
1510 TRACE_WITH_OBJ(("\"%.30s\" %ld => ", O2S(objPtr), i),
1511 value2Ptr);
1512 TclDecrRefCount(objPtr);
1513 ADJUST_PC(2);
1514
1515 case INST_INCR_ARRAY1_IMM:
1516 {
1517 Tcl_Obj *elemPtr;
1518
1519 opnd = TclGetUInt1AtPtr(pc+1);
1520 i = TclGetInt1AtPtr(pc+2);
1521 elemPtr = POP_OBJECT();
1522 DECACHE_STACK_INFO();
1523 value2Ptr = TclIncrElementOfIndexedArray(interp, opnd,
1524 elemPtr, i);
1525 CACHE_STACK_INFO();
1526 if (value2Ptr == NULL) {
1527 TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ERROR: ",
1528 opnd, O2S(elemPtr), i),
1529 Tcl_GetObjResult(interp));
1530 Tcl_DecrRefCount(elemPtr);
1531 result = TCL_ERROR;
1532 goto checkForCatch;
1533 }
1534 PUSH_OBJECT(value2Ptr);
1535 TRACE_WITH_OBJ(("%u \"%.30s\" (by %ld) => ",
1536 opnd, O2S(elemPtr), i), value2Ptr);
1537 Tcl_DecrRefCount(elemPtr);
1538 }
1539 ADJUST_PC(3);
1540
1541 case INST_INCR_ARRAY_STK_IMM:
1542 {
1543 Tcl_Obj *elemPtr;
1544
1545 i = TclGetInt1AtPtr(pc+1);
1546 elemPtr = POP_OBJECT();
1547 objPtr = POP_OBJECT(); /* array name */
1548 DECACHE_STACK_INFO();
1549 value2Ptr = TclIncrVar2(interp, objPtr, elemPtr, i,
1550 TCL_LEAVE_ERR_MSG);
1551 CACHE_STACK_INFO();
1552 if (value2Ptr == NULL) {
1553 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ERROR: ",
1554 O2S(objPtr), O2S(elemPtr), i),
1555 Tcl_GetObjResult(interp));
1556 Tcl_DecrRefCount(objPtr);
1557 Tcl_DecrRefCount(elemPtr);
1558 result = TCL_ERROR;
1559 goto checkForCatch;
1560 }
1561 PUSH_OBJECT(value2Ptr);
1562 TRACE_WITH_OBJ(("\"%.30s(%.30s)\" (by %ld) => ",
1563 O2S(objPtr), O2S(elemPtr), i), value2Ptr);
1564 Tcl_DecrRefCount(objPtr);
1565 Tcl_DecrRefCount(elemPtr);
1566 }
1567 ADJUST_PC(2);
1568
1569 case INST_JUMP1:
1570 #ifdef TCL_COMPILE_DEBUG
1571 opnd = TclGetInt1AtPtr(pc+1);
1572 TRACE(("%d => new pc %u\n", opnd,
1573 (unsigned int)(pc + opnd - codePtr->codeStart)));
1574 pc += opnd;
1575 #else
1576 pc += TclGetInt1AtPtr(pc+1);
1577 #endif /* TCL_COMPILE_DEBUG */
1578 continue;
1579
1580 case INST_JUMP4:
1581 opnd = TclGetInt4AtPtr(pc+1);
1582 TRACE(("%d => new pc %u\n", opnd,
1583 (unsigned int)(pc + opnd - codePtr->codeStart)));
1584 ADJUST_PC(opnd);
1585
1586 case INST_JUMP_TRUE4:
1587 opnd = TclGetInt4AtPtr(pc+1);
1588 pcAdjustment = 5;
1589 goto doJumpTrue;
1590
1591 case INST_JUMP_TRUE1:
1592 opnd = TclGetInt1AtPtr(pc+1);
1593 pcAdjustment = 2;
1594
1595 doJumpTrue:
1596 {
1597 int b;
1598
1599 valuePtr = POP_OBJECT();
1600 if (valuePtr->typePtr == &tclIntType) {
1601 b = (valuePtr->internalRep.longValue != 0);
1602 } else if (valuePtr->typePtr == &tclDoubleType) {
1603 b = (valuePtr->internalRep.doubleValue != 0.0);
1604 } else {
1605 result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1606 if (result != TCL_OK) {
1607 TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
1608 Tcl_GetObjResult(interp));
1609 Tcl_DecrRefCount(valuePtr);
1610 goto checkForCatch;
1611 }
1612 }
1613 if (b) {
1614 TRACE(("%d => %.20s true, new pc %u\n",
1615 opnd, O2S(valuePtr),
1616 (unsigned int)(pc+opnd - codePtr->codeStart)));
1617 TclDecrRefCount(valuePtr);
1618 ADJUST_PC(opnd);
1619 } else {
1620 TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
1621 TclDecrRefCount(valuePtr);
1622 ADJUST_PC(pcAdjustment);
1623 }
1624 }
1625
1626 case INST_JUMP_FALSE4:
1627 opnd = TclGetInt4AtPtr(pc+1);
1628 pcAdjustment = 5;
1629 goto doJumpFalse;
1630
1631 case INST_JUMP_FALSE1:
1632 opnd = TclGetInt1AtPtr(pc+1);
1633 pcAdjustment = 2;
1634
1635 doJumpFalse:
1636 {
1637 int b;
1638
1639 valuePtr = POP_OBJECT();
1640 if (valuePtr->typePtr == &tclIntType) {
1641 b = (valuePtr->internalRep.longValue != 0);
1642 } else if (valuePtr->typePtr == &tclDoubleType) {
1643 b = (valuePtr->internalRep.doubleValue != 0.0);
1644 } else {
1645 result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
1646 if (result != TCL_OK) {
1647 TRACE_WITH_OBJ(("%d => ERROR: ", opnd),
1648 Tcl_GetObjResult(interp));
1649 Tcl_DecrRefCount(valuePtr);
1650 goto checkForCatch;
1651 }
1652 }
1653 if (b) {
1654 TRACE(("%d => %.20s true\n", opnd, O2S(valuePtr)));
1655 TclDecrRefCount(valuePtr);
1656 ADJUST_PC(pcAdjustment);
1657 } else {
1658 TRACE(("%d => %.20s false, new pc %u\n",
1659 opnd, O2S(valuePtr),
1660 (unsigned int)(pc + opnd - codePtr->codeStart)));
1661 TclDecrRefCount(valuePtr);
1662 ADJUST_PC(opnd);
1663 }
1664 }
1665
1666 case INST_LOR:
1667 case INST_LAND:
1668 {
1669 /*
1670 * Operands must be boolean or numeric. No int->double
1671 * conversions are performed.
1672 */
1673
1674 int i1, i2;
1675 int iResult;
1676 char *s;
1677 Tcl_ObjType *t1Ptr, *t2Ptr;
1678
1679 value2Ptr = POP_OBJECT();
1680 valuePtr = POP_OBJECT();
1681 t1Ptr = valuePtr->typePtr;
1682 t2Ptr = value2Ptr->typePtr;
1683
1684 if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
1685 i1 = (valuePtr->internalRep.longValue != 0);
1686 } else if (t1Ptr == &tclDoubleType) {
1687 i1 = (valuePtr->internalRep.doubleValue != 0.0);
1688 } else {
1689 s = Tcl_GetStringFromObj(valuePtr, &length);
1690 if (TclLooksLikeInt(s, length)) {
1691 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1692 valuePtr, &i);
1693 i1 = (i != 0);
1694 } else {
1695 result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1696 valuePtr, &i1);
1697 i1 = (i1 != 0);
1698 }
1699 if (result != TCL_OK) {
1700 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1701 O2S(valuePtr),
1702 (t1Ptr? t1Ptr->name : "null")));
1703 IllegalExprOperandType(interp, pc, valuePtr);
1704 Tcl_DecrRefCount(valuePtr);
1705 Tcl_DecrRefCount(value2Ptr);
1706 goto checkForCatch;
1707 }
1708 }
1709
1710 if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
1711 i2 = (value2Ptr->internalRep.longValue != 0);
1712 } else if (t2Ptr == &tclDoubleType) {
1713 i2 = (value2Ptr->internalRep.doubleValue != 0.0);
1714 } else {
1715 s = Tcl_GetStringFromObj(value2Ptr, &length);
1716 if (TclLooksLikeInt(s, length)) {
1717 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1718 value2Ptr, &i);
1719 i2 = (i != 0);
1720 } else {
1721 result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
1722 value2Ptr, &i2);
1723 }
1724 if (result != TCL_OK) {
1725 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
1726 O2S(value2Ptr),
1727 (t2Ptr? t2Ptr->name : "null")));
1728 IllegalExprOperandType(interp, pc, value2Ptr);
1729 Tcl_DecrRefCount(valuePtr);
1730 Tcl_DecrRefCount(value2Ptr);
1731 goto checkForCatch;
1732 }
1733 }
1734
1735 /*
1736 * Reuse the valuePtr object already on stack if possible.
1737 */
1738
1739 if (*pc == INST_LOR) {
1740 iResult = (i1 || i2);
1741 } else {
1742 iResult = (i1 && i2);
1743 }
1744 if (Tcl_IsShared(valuePtr)) {
1745 PUSH_OBJECT(Tcl_NewLongObj(iResult));
1746 TRACE(("%.20s %.20s => %d\n",
1747 O2S(valuePtr), O2S(value2Ptr), iResult));
1748 TclDecrRefCount(valuePtr);
1749 } else { /* reuse the valuePtr object */
1750 TRACE(("%.20s %.20s => %d\n",
1751 O2S(valuePtr), O2S(value2Ptr), iResult));
1752 Tcl_SetLongObj(valuePtr, iResult);
1753 ++stackTop; /* valuePtr now on stk top has right r.c. */
1754 }
1755 TclDecrRefCount(value2Ptr);
1756 }
1757 ADJUST_PC(1);
1758
1759 case INST_EQ:
1760 case INST_NEQ:
1761 case INST_LT:
1762 case INST_GT:
1763 case INST_LE:
1764 case INST_GE:
1765 {
1766 /*
1767 * Any type is allowed but the two operands must have the
1768 * same type. We will compute value op value2.
1769 */
1770
1771 Tcl_ObjType *t1Ptr, *t2Ptr;
1772 char *s1 = NULL; /* Init. avoids compiler warning. */
1773 char *s2 = NULL; /* Init. avoids compiler warning. */
1774 long i2 = 0; /* Init. avoids compiler warning. */
1775 double d1 = 0.0; /* Init. avoids compiler warning. */
1776 double d2 = 0.0; /* Init. avoids compiler warning. */
1777 long iResult = 0; /* Init. avoids compiler warning. */
1778
1779 value2Ptr = POP_OBJECT();
1780 valuePtr = POP_OBJECT();
1781 t1Ptr = valuePtr->typePtr;
1782 t2Ptr = value2Ptr->typePtr;
1783
1784 /*
1785 * We only want to coerce numeric validation if
1786 * neither type is NULL. A NULL type means the arg is
1787 * essentially an empty object ("", {} or [list]).
1788 */
1789 if (!((((t1Ptr == NULL) && (valuePtr->bytes == NULL))
1790 || (valuePtr->bytes && (valuePtr->length == 0)))
1791 || (((t2Ptr == NULL) && (value2Ptr->bytes == NULL))
1792 || (value2Ptr->bytes && (value2Ptr->length == 0))))) {
1793 if ((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType)) {
1794 s1 = Tcl_GetStringFromObj(valuePtr, &length);
1795 if (TclLooksLikeInt(s1, length)) {
1796 (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1797 valuePtr, &i);
1798 } else {
1799 (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1800 valuePtr, &d1);
1801 }
1802 t1Ptr = valuePtr->typePtr;
1803 }
1804 if ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType)) {
1805 s2 = Tcl_GetStringFromObj(value2Ptr, &length);
1806 if (TclLooksLikeInt(s2, length)) {
1807 (void) Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1808 value2Ptr, &i2);
1809 } else {
1810 (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
1811 value2Ptr, &d2);
1812 }
1813 t2Ptr = value2Ptr->typePtr;
1814 }
1815 }
1816 if (((t1Ptr != &tclIntType) && (t1Ptr != &tclDoubleType))
1817 || ((t2Ptr != &tclIntType) && (t2Ptr != &tclDoubleType))) {
1818 /*
1819 * One operand is not numeric. Compare as strings.
1820 */
1821 int cmpValue;
1822 s1 = Tcl_GetString(valuePtr);
1823 s2 = Tcl_GetString(value2Ptr);
1824 cmpValue = strcmp(s1, s2);
1825 switch (*pc) {
1826 case INST_EQ:
1827 iResult = (cmpValue == 0);
1828 break;
1829 case INST_NEQ:
1830 iResult = (cmpValue != 0);
1831 break;
1832 case INST_LT:
1833 iResult = (cmpValue < 0);
1834 break;
1835 case INST_GT:
1836 iResult = (cmpValue > 0);
1837 break;
1838 case INST_LE:
1839 iResult = (cmpValue <= 0);
1840 break;
1841 case INST_GE:
1842 iResult = (cmpValue >= 0);
1843 break;
1844 }
1845 } else if ((t1Ptr == &tclDoubleType)
1846 || (t2Ptr == &tclDoubleType)) {
1847 /*
1848 * Compare as doubles.
1849 */
1850 if (t1Ptr == &tclDoubleType) {
1851 d1 = valuePtr->internalRep.doubleValue;
1852 if (t2Ptr == &tclIntType) {
1853 d2 = value2Ptr->internalRep.longValue;
1854 } else {
1855 d2 = value2Ptr->internalRep.doubleValue;
1856 }
1857 } else { /* t1Ptr is int, t2Ptr is double */
1858 d1 = valuePtr->internalRep.longValue;
1859 d2 = value2Ptr->internalRep.doubleValue;
1860 }
1861 switch (*pc) {
1862 case INST_EQ:
1863 iResult = d1 == d2;
1864 break;
1865 case INST_NEQ:
1866 iResult = d1 != d2;
1867 break;
1868 case INST_LT:
1869 iResult = d1 < d2;
1870 break;
1871 case INST_GT:
1872 iResult = d1 > d2;
1873 break;
1874 case INST_LE:
1875 iResult = d1 <= d2;
1876 break;
1877 case INST_GE:
1878 iResult = d1 >= d2;
1879 break;
1880 }
1881 } else {
1882 /*
1883 * Compare as ints.
1884 */
1885 i = valuePtr->internalRep.longValue;
1886 i2 = value2Ptr->internalRep.longValue;
1887 switch (*pc) {
1888 case INST_EQ:
1889 iResult = i == i2;
1890 break;
1891 case INST_NEQ:
1892 iResult = i != i2;
1893 break;
1894 case INST_LT:
1895 iResult = i < i2;
1896 break;
1897 case INST_GT:
1898 iResult = i > i2;
1899 break;
1900 case INST_LE:
1901 iResult = i <= i2;
1902 break;
1903 case INST_GE:
1904 iResult = i >= i2;
1905 break;
1906 }
1907 }
1908
1909 /*
1910 * Reuse the valuePtr object already on stack if possible.
1911 */
1912
1913 if (Tcl_IsShared(valuePtr)) {
1914 PUSH_OBJECT(Tcl_NewLongObj(iResult));
1915 TRACE(("%.20s %.20s => %ld\n",
1916 O2S(valuePtr), O2S(value2Ptr), iResult));
1917 TclDecrRefCount(valuePtr);
1918 } else { /* reuse the valuePtr object */
1919 TRACE(("%.20s %.20s => %ld\n",
1920 O2S(valuePtr), O2S(value2Ptr), iResult));
1921 Tcl_SetLongObj(valuePtr, iResult);
1922 ++stackTop; /* valuePtr now on stk top has right r.c. */
1923 }
1924 TclDecrRefCount(value2Ptr);
1925 }
1926 ADJUST_PC(1);
1927
1928 case INST_MOD:
1929 case INST_LSHIFT:
1930 case INST_RSHIFT:
1931 case INST_BITOR:
1932 case INST_BITXOR:
1933 case INST_BITAND:
1934 {
1935 /*
1936 * Only integers are allowed. We compute value op value2.
1937 */
1938
1939 long i2, rem, negative;
1940 long iResult = 0; /* Init. avoids compiler warning. */
1941
1942 value2Ptr = POP_OBJECT();
1943 valuePtr = POP_OBJECT();
1944 if (valuePtr->typePtr == &tclIntType) {
1945 i = valuePtr->internalRep.longValue;
1946 } else { /* try to convert to int */
1947 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1948 valuePtr, &i);
1949 if (result != TCL_OK) {
1950 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
1951 O2S(valuePtr), O2S(value2Ptr),
1952 (valuePtr->typePtr?
1953 valuePtr->typePtr->name : "null")));
1954 IllegalExprOperandType(interp, pc, valuePtr);
1955 Tcl_DecrRefCount(valuePtr);
1956 Tcl_DecrRefCount(value2Ptr);
1957 goto checkForCatch;
1958 }
1959 }
1960 if (value2Ptr->typePtr == &tclIntType) {
1961 i2 = value2Ptr->internalRep.longValue;
1962 } else {
1963 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
1964 value2Ptr, &i2);
1965 if (result != TCL_OK) {
1966 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
1967 O2S(valuePtr), O2S(value2Ptr),
1968 (value2Ptr->typePtr?
1969 value2Ptr->typePtr->name : "null")));
1970 IllegalExprOperandType(interp, pc, value2Ptr);
1971 Tcl_DecrRefCount(valuePtr);
1972 Tcl_DecrRefCount(value2Ptr);
1973 goto checkForCatch;
1974 }
1975 }
1976
1977 switch (*pc) {
1978 case INST_MOD:
1979 /*
1980 * This code is tricky: C doesn't guarantee much about
1981 * the quotient or remainder, but Tcl does. The
1982 * remainder always has the same sign as the divisor and
1983 * a smaller absolute value.
1984 */
1985 if (i2 == 0) {
1986 TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
1987 Tcl_DecrRefCount(valuePtr);
1988 Tcl_DecrRefCount(value2Ptr);
1989 goto divideByZero;
1990 }
1991 negative = 0;
1992 if (i2 < 0) {
1993 i2 = -i2;
1994 i = -i;
1995 negative = 1;
1996 }
1997 rem = i % i2;
1998 if (rem < 0) {
1999 rem += i2;
2000 }
2001 if (negative) {
2002 rem = -rem;
2003 }
2004 iResult = rem;
2005 break;
2006 case INST_LSHIFT:
2007 iResult = i << i2;
2008 break;
2009 case INST_RSHIFT:
2010 /*
2011 * The following code is a bit tricky: it ensures that
2012 * right shifts propagate the sign bit even on machines
2013 * where ">>" won't do it by default.
2014 */
2015 if (i < 0) {
2016 iResult = ~((~i) >> i2);
2017 } else {
2018 iResult = i >> i2;
2019 }
2020 break;
2021 case INST_BITOR:
2022 iResult = i | i2;
2023 break;
2024 case INST_BITXOR:
2025 iResult = i ^ i2;
2026 break;
2027 case INST_BITAND:
2028 iResult = i & i2;
2029 break;
2030 }
2031
2032 /*
2033 * Reuse the valuePtr object already on stack if possible.
2034 */
2035
2036 if (Tcl_IsShared(valuePtr)) {
2037 PUSH_OBJECT(Tcl_NewLongObj(iResult));
2038 TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2039 TclDecrRefCount(valuePtr);
2040 } else { /* reuse the valuePtr object */
2041 TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2042 Tcl_SetLongObj(valuePtr, iResult);
2043 ++stackTop; /* valuePtr now on stk top has right r.c. */
2044 }
2045 TclDecrRefCount(value2Ptr);
2046 }
2047 ADJUST_PC(1);
2048
2049 case INST_ADD:
2050 case INST_SUB:
2051 case INST_MULT:
2052 case INST_DIV:
2053 {
2054 /*
2055 * Operands must be numeric and ints get converted to floats
2056 * if necessary. We compute value op value2.
2057 */
2058
2059 Tcl_ObjType *t1Ptr, *t2Ptr;
2060 long i2, quot, rem;
2061 double d1, d2;
2062 long iResult = 0; /* Init. avoids compiler warning. */
2063 double dResult = 0.0; /* Init. avoids compiler warning. */
2064 int doDouble = 0; /* 1 if doing floating arithmetic */
2065
2066 value2Ptr = POP_OBJECT();
2067 valuePtr = POP_OBJECT();
2068 t1Ptr = valuePtr->typePtr;
2069 t2Ptr = value2Ptr->typePtr;
2070
2071 if (t1Ptr == &tclIntType) {
2072 i = valuePtr->internalRep.longValue;
2073 } else if ((t1Ptr == &tclDoubleType)
2074 && (valuePtr->bytes == NULL)) {
2075 /*
2076 * We can only use the internal rep directly if there is
2077 * no string rep. Otherwise the string rep might actually
2078 * look like an integer, which is preferred.
2079 */
2080
2081 d1 = valuePtr->internalRep.doubleValue;
2082 } else {
2083 char *s = Tcl_GetStringFromObj(valuePtr, &length);
2084 if (TclLooksLikeInt(s, length)) {
2085 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2086 valuePtr, &i);
2087 } else {
2088 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2089 valuePtr, &d1);
2090 }
2091 if (result != TCL_OK) {
2092 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
2093 s, O2S(valuePtr),
2094 (valuePtr->typePtr?
2095 valuePtr->typePtr->name : "null")));
2096 IllegalExprOperandType(interp, pc, valuePtr);
2097 Tcl_DecrRefCount(valuePtr);
2098 Tcl_DecrRefCount(value2Ptr);
2099 goto checkForCatch;
2100 }
2101 t1Ptr = valuePtr->typePtr;
2102 }
2103
2104 if (t2Ptr == &tclIntType) {
2105 i2 = value2Ptr->internalRep.longValue;
2106 } else if ((t2Ptr == &tclDoubleType)
2107 && (value2Ptr->bytes == NULL)) {
2108 /*
2109 * We can only use the internal rep directly if there is
2110 * no string rep. Otherwise the string rep might actually
2111 * look like an integer, which is preferred.
2112 */
2113
2114 d2 = value2Ptr->internalRep.doubleValue;
2115 } else {
2116 char *s = Tcl_GetStringFromObj(value2Ptr, &length);
2117 if (TclLooksLikeInt(s, length)) {
2118 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2119 value2Ptr, &i2);
2120 } else {
2121 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2122 value2Ptr, &d2);
2123 }
2124 if (result != TCL_OK) {
2125 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
2126 O2S(value2Ptr), s,
2127 (value2Ptr->typePtr?
2128 value2Ptr->typePtr->name : "null")));
2129 IllegalExprOperandType(interp, pc, value2Ptr);
2130 Tcl_DecrRefCount(valuePtr);
2131 Tcl_DecrRefCount(value2Ptr);
2132 goto checkForCatch;
2133 }
2134 t2Ptr = value2Ptr->typePtr;
2135 }
2136
2137 if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
2138 /*
2139 * Do double arithmetic.
2140 */
2141 doDouble = 1;
2142 if (t1Ptr == &tclIntType) {
2143 d1 = i; /* promote value 1 to double */
2144 } else if (t2Ptr == &tclIntType) {
2145 d2 = i2; /* promote value 2 to double */
2146 }
2147 switch (*pc) {
2148 case INST_ADD:
2149 dResult = d1 + d2;
2150 break;
2151 case INST_SUB:
2152 dResult = d1 - d2;
2153 break;
2154 case INST_MULT:
2155 dResult = d1 * d2;
2156 break;
2157 case INST_DIV:
2158 if (d2 == 0.0) {
2159 TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
2160 Tcl_DecrRefCount(valuePtr);
2161 Tcl_DecrRefCount(value2Ptr);
2162 goto divideByZero;
2163 }
2164 dResult = d1 / d2;
2165 break;
2166 }
2167
2168 /*
2169 * Check now for IEEE floating-point error.
2170 */
2171
2172 if (IS_NAN(dResult) || IS_INF(dResult)) {
2173 TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
2174 O2S(valuePtr), O2S(value2Ptr)));
2175 TclExprFloatError(interp, dResult);
2176 result = TCL_ERROR;
2177 Tcl_DecrRefCount(valuePtr);
2178 Tcl_DecrRefCount(value2Ptr);
2179 goto checkForCatch;
2180 }
2181 } else {
2182 /*
2183 * Do integer arithmetic.
2184 */
2185 switch (*pc) {
2186 case INST_ADD:
2187 iResult = i + i2;
2188 break;
2189 case INST_SUB:
2190 iResult = i - i2;
2191 break;
2192 case INST_MULT:
2193 iResult = i * i2;
2194 break;
2195 case INST_DIV:
2196 /*
2197 * This code is tricky: C doesn't guarantee much
2198 * about the quotient or remainder, but Tcl does.
2199 * The remainder always has the same sign as the
2200 * divisor and a smaller absolute value.
2201 */
2202 if (i2 == 0) {
2203 TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
2204 Tcl_DecrRefCount(valuePtr);
2205 Tcl_DecrRefCount(value2Ptr);
2206 goto divideByZero;
2207 }
2208 if (i2 < 0) {
2209 i2 = -i2;
2210 i = -i;
2211 }
2212 quot = i / i2;
2213 rem = i % i2;
2214 if (rem < 0) {
2215 quot -= 1;
2216 }
2217 iResult = quot;
2218 break;
2219 }
2220 }
2221
2222 /*
2223 * Reuse the valuePtr object already on stack if possible.
2224 */
2225
2226 if (Tcl_IsShared(valuePtr)) {
2227 if (doDouble) {
2228 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
2229 TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
2230 } else {
2231 PUSH_OBJECT(Tcl_NewLongObj(iResult));
2232 TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2233 }
2234 TclDecrRefCount(valuePtr);
2235 } else { /* reuse the valuePtr object */
2236 if (doDouble) { /* NB: stack top is off by 1 */
2237 TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
2238 Tcl_SetDoubleObj(valuePtr, dResult);
2239 } else {
2240 TRACE(("%ld %ld => %ld\n", i, i2, iResult));
2241 Tcl_SetLongObj(valuePtr, iResult);
2242 }
2243 ++stackTop; /* valuePtr now on stk top has right r.c. */
2244 }
2245 TclDecrRefCount(value2Ptr);
2246 }
2247 ADJUST_PC(1);
2248
2249 case INST_UPLUS:
2250 {
2251 /*
2252 * Operand must be numeric.
2253 */
2254
2255 double d;
2256 Tcl_ObjType *tPtr;
2257
2258 valuePtr = stackPtr[stackTop];
2259 tPtr = valuePtr->typePtr;
2260 if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2261 || (valuePtr->bytes != NULL))) {
2262 char *s = Tcl_GetStringFromObj(valuePtr, &length);
2263 if (TclLooksLikeInt(s, length)) {
2264 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2265 valuePtr, &i);
2266 } else {
2267 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2268 valuePtr, &d);
2269 }
2270 if (result != TCL_OK) {
2271 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
2272 s, (tPtr? tPtr->name : "null")));
2273 IllegalExprOperandType(interp, pc, valuePtr);
2274 goto checkForCatch;
2275 }
2276 tPtr = valuePtr->typePtr;
2277 }
2278
2279 /*
2280 * Ensure that the operand's string rep is the same as the
2281 * formatted version of its internal rep. This makes sure
2282 * that "expr +000123" yields "83", not "000123". We
2283 * implement this by _discarding_ the string rep since we
2284 * know it will be regenerated, if needed later, by
2285 * formatting the internal rep's value.
2286 */
2287
2288 if (Tcl_IsShared(valuePtr)) {
2289 if (tPtr == &tclIntType) {
2290 i = valuePtr->internalRep.longValue;
2291 objPtr = Tcl_NewLongObj(i);
2292 } else {
2293 d = valuePtr->internalRep.doubleValue;
2294 objPtr = Tcl_NewDoubleObj(d);
2295 }
2296 Tcl_IncrRefCount(objPtr);
2297 Tcl_DecrRefCount(valuePtr);
2298 valuePtr = objPtr;
2299 stackPtr[stackTop] = valuePtr;
2300 } else {
2301 Tcl_InvalidateStringRep(valuePtr);
2302 }
2303 TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
2304 }
2305 ADJUST_PC(1);
2306
2307 case INST_UMINUS:
2308 case INST_LNOT:
2309 {
2310 /*
2311 * The operand must be numeric. If the operand object is
2312 * unshared modify it directly, otherwise create a copy to
2313 * modify: this is "copy on write". free any old string
2314 * representation since it is now invalid.
2315 */
2316
2317 double d;
2318 Tcl_ObjType *tPtr;
2319
2320 valuePtr = POP_OBJECT();
2321 tPtr = valuePtr->typePtr;
2322 if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2323 || (valuePtr->bytes != NULL))) {
2324 if ((tPtr == &tclBooleanType)
2325 && (valuePtr->bytes == NULL)) {
2326 valuePtr->typePtr = &tclIntType;
2327 } else {
2328 char *s = Tcl_GetStringFromObj(valuePtr, &length);
2329 if (TclLooksLikeInt(s, length)) {
2330 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2331 valuePtr, &i);
2332 } else {
2333 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2334 valuePtr, &d);
2335 }
2336 if (result != TCL_OK) {
2337 TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
2338 s, (tPtr? tPtr->name : "null")));
2339 IllegalExprOperandType(interp, pc, valuePtr);
2340 Tcl_DecrRefCount(valuePtr);
2341 goto checkForCatch;
2342 }
2343 }
2344 tPtr = valuePtr->typePtr;
2345 }
2346
2347 if (Tcl_IsShared(valuePtr)) {
2348 /*
2349 * Create a new object.
2350 */
2351 if (tPtr == &tclIntType) {
2352 i = valuePtr->internalRep.longValue;
2353 objPtr = Tcl_NewLongObj(
2354 (*pc == INST_UMINUS)? -i : !i);
2355 TRACE_WITH_OBJ(("%ld => ", i), objPtr);
2356 } else {
2357 d = valuePtr->internalRep.doubleValue;
2358 if (*pc == INST_UMINUS) {
2359 objPtr = Tcl_NewDoubleObj(-d);
2360 } else {
2361 /*
2362 * Should be able to use "!d", but apparently
2363 * some compilers can't handle it.
2364 */
2365 objPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
2366 }
2367 TRACE_WITH_OBJ(("%.6g => ", d), objPtr);
2368 }
2369 PUSH_OBJECT(objPtr);
2370 TclDecrRefCount(valuePtr);
2371 } else {
2372 /*
2373 * valuePtr is unshared. Modify it directly.
2374 */
2375 if (tPtr == &tclIntType) {
2376 i = valuePtr->internalRep.longValue;
2377 Tcl_SetLongObj(valuePtr,
2378 (*pc == INST_UMINUS)? -i : !i);
2379 TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
2380 } else {
2381 d = valuePtr->internalRep.doubleValue;
2382 if (*pc == INST_UMINUS) {
2383 Tcl_SetDoubleObj(valuePtr, -d);
2384 } else {
2385 /*
2386 * Should be able to use "!d", but apparently
2387 * some compilers can't handle it.
2388 */
2389 Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
2390 }
2391 TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
2392 }
2393 ++stackTop; /* valuePtr now on stk top has right r.c. */
2394 }
2395 }
2396 ADJUST_PC(1);
2397
2398 case INST_BITNOT:
2399 {
2400 /*
2401 * The operand must be an integer. If the operand object is
2402 * unshared modify it directly, otherwise modify a copy.
2403 * Free any old string representation since it is now
2404 * invalid.
2405 */
2406
2407 Tcl_ObjType *tPtr;
2408
2409 valuePtr = POP_OBJECT();
2410 tPtr = valuePtr->typePtr;
2411 if (tPtr != &tclIntType) {
2412 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2413 valuePtr, &i);
2414 if (result != TCL_OK) { /* try to convert to double */
2415 TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
2416 O2S(valuePtr), (tPtr? tPtr->name : "null")));
2417 IllegalExprOperandType(interp, pc, valuePtr);
2418 Tcl_DecrRefCount(valuePtr);
2419 goto checkForCatch;
2420 }
2421 }
2422
2423 i = valuePtr->internalRep.longValue;
2424 if (Tcl_IsShared(valuePtr)) {
2425 PUSH_OBJECT(Tcl_NewLongObj(~i));
2426 TRACE(("0x%lx => (%lu)\n", i, ~i));
2427 TclDecrRefCount(valuePtr);
2428 } else {
2429 /*
2430 * valuePtr is unshared. Modify it directly.
2431 */
2432 Tcl_SetLongObj(valuePtr, ~i);
2433 ++stackTop; /* valuePtr now on stk top has right r.c. */
2434 TRACE(("0x%lx => (%lu)\n", i, ~i));
2435 }
2436 }
2437 ADJUST_PC(1);
2438
2439 case INST_CALL_BUILTIN_FUNC1:
2440 opnd = TclGetUInt1AtPtr(pc+1);
2441 {
2442 /*
2443 * Call one of the built-in Tcl math functions.
2444 */
2445
2446 BuiltinFunc *mathFuncPtr;
2447 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
2448
2449 if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
2450 TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
2451 panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
2452 }
2453 mathFuncPtr = &(builtinFuncTable[opnd]);
2454 DECACHE_STACK_INFO();
2455 tsdPtr->mathInProgress++;
2456 result = (*mathFuncPtr->proc)(interp, eePtr,
2457 mathFuncPtr->clientData);
2458 tsdPtr->mathInProgress--;
2459 CACHE_STACK_INFO();
2460 if (result != TCL_OK) {
2461 goto checkForCatch;
2462 }
2463 TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
2464 }
2465 ADJUST_PC(2);
2466
2467 case INST_CALL_FUNC1:
2468 opnd = TclGetUInt1AtPtr(pc+1);
2469 {
2470 /*
2471 * Call a non-builtin Tcl math function previously
2472 * registered by a call to Tcl_CreateMathFunc.
2473 */
2474
2475 int objc = opnd; /* Number of arguments. The function name
2476 * is the 0-th argument. */
2477 Tcl_Obj **objv; /* The array of arguments. The function
2478 * name is objv[0]. */
2479 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
2480
2481 objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
2482 DECACHE_STACK_INFO();
2483 tsdPtr->mathInProgress++;
2484 result = ExprCallMathFunc(interp, eePtr, objc, objv);
2485 tsdPtr->mathInProgress--;
2486 CACHE_STACK_INFO();
2487 if (result != TCL_OK) {
2488 goto checkForCatch;
2489 }
2490 TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
2491 ADJUST_PC(2);
2492 }
2493
2494 case INST_TRY_CVT_TO_NUMERIC:
2495 {
2496 /*
2497 * Try to convert the topmost stack object to an int or
2498 * double object. This is done in order to support Tcl's
2499 * policy of interpreting operands if at all possible as
2500 * first integers, else floating-point numbers.
2501 */
2502
2503 double d;
2504 char *s;
2505 Tcl_ObjType *tPtr;
2506 int converted, shared;
2507
2508 valuePtr = stackPtr[stackTop];
2509 tPtr = valuePtr->typePtr;
2510 converted = 0;
2511 if ((tPtr != &tclIntType) && ((tPtr != &tclDoubleType)
2512 || (valuePtr->bytes != NULL))) {
2513 if ((tPtr == &tclBooleanType)
2514 && (valuePtr->bytes == NULL)) {
2515 valuePtr->typePtr = &tclIntType;
2516 converted = 1;
2517 } else {
2518 s = Tcl_GetStringFromObj(valuePtr, &length);
2519 if (TclLooksLikeInt(s, length)) {
2520 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL,
2521 valuePtr, &i);
2522 } else {
2523 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2524 valuePtr, &d);
2525 }
2526 if (result == TCL_OK) {
2527 converted = 1;
2528 }
2529 result = TCL_OK; /* reset the result variable */
2530 }
2531 tPtr = valuePtr->typePtr;
2532 }
2533
2534 /*
2535 * Ensure that the topmost stack object, if numeric, has a
2536 * string rep the same as the formatted version of its
2537 * internal rep. This is used, e.g., to make sure that "expr
2538 * {0001}" yields "1", not "0001". We implement this by
2539 * _discarding_ the string rep since we know it will be
2540 * regenerated, if needed later, by formatting the internal
2541 * rep's value. Also check if there has been an IEEE
2542 * floating point error.
2543 */
2544
2545 if ((tPtr == &tclIntType) || (tPtr == &tclDoubleType)) {
2546 shared = 0;
2547 if (Tcl_IsShared(valuePtr)) {
2548 shared = 1;
2549 if (valuePtr->bytes != NULL) {
2550 /*
2551 * We only need to make a copy of the object
2552 * when it already had a string rep
2553 */
2554 if (tPtr == &tclIntType) {
2555 i = valuePtr->internalRep.longValue;
2556 objPtr = Tcl_NewLongObj(i);
2557 } else {
2558 d = valuePtr->internalRep.doubleValue;
2559 objPtr = Tcl_NewDoubleObj(d);
2560 }
2561 Tcl_IncrRefCount(objPtr);
2562 TclDecrRefCount(valuePtr);
2563 valuePtr = objPtr;
2564 stackPtr[stackTop] = valuePtr;
2565 tPtr = valuePtr->typePtr;
2566 }
2567 } else {
2568 Tcl_InvalidateStringRep(valuePtr);
2569 }
2570
2571 if (tPtr == &tclDoubleType) {
2572 d = valuePtr->internalRep.doubleValue;
2573 if (IS_NAN(d) || IS_INF(d)) {
2574 TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
2575 O2S(valuePtr)));
2576 TclExprFloatError(interp, d);
2577 result = TCL_ERROR;
2578 goto checkForCatch;
2579 }
2580 }
2581 shared = shared; /* lint, shared not used. */
2582 converted = converted; /* lint, converted not used. */
2583 TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
2584 (converted? "converted" : "not converted"),
2585 (shared? "shared" : "not shared")));
2586 } else {
2587 TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
2588 }
2589 }
2590 ADJUST_PC(1);
2591
2592 case INST_BREAK:
2593 /*
2594 * First reset the interpreter's result. Then find the closest
2595 * enclosing loop or catch exception range, if any. If a loop is
2596 * found, terminate its execution. If the closest is a catch
2597 * exception range, jump to its catchOffset. If no enclosing
2598 * range is found, stop execution and return TCL_BREAK.
2599 */
2600
2601 Tcl_ResetResult(interp);
2602 rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
2603 if (rangePtr == NULL) {
2604 TRACE(("=> no encl. loop or catch, returning TCL_BREAK\n"));
2605 result = TCL_BREAK;
2606 goto abnormalReturn; /* no catch exists to check */
2607 }
2608 switch (rangePtr->type) {
2609 case LOOP_EXCEPTION_RANGE:
2610 result = TCL_OK;
2611 TRACE(("=> range at %d, new pc %d\n",
2612 rangePtr->codeOffset, rangePtr->breakOffset));
2613 break;
2614 case CATCH_EXCEPTION_RANGE:
2615 result = TCL_BREAK;
2616 TRACE(("=> ...\n"));
2617 goto processCatch; /* it will use rangePtr */
2618 default:
2619 panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2620 }
2621 pc = (codePtr->codeStart + rangePtr->breakOffset);
2622 continue; /* restart outer instruction loop at pc */
2623
2624 case INST_CONTINUE:
2625 /*
2626 * Find the closest enclosing loop or catch exception range,
2627 * if any. If a loop is found, skip to its next iteration.
2628 * If the closest is a catch exception range, jump to its
2629 * catchOffset. If no enclosing range is found, stop
2630 * execution and return TCL_CONTINUE.
2631 */
2632
2633 Tcl_ResetResult(interp);
2634 rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
2635 if (rangePtr == NULL) {
2636 TRACE(("=> no encl. loop or catch, returning TCL_CONTINUE\n"));
2637 result = TCL_CONTINUE;
2638 goto abnormalReturn;
2639 }
2640 switch (rangePtr->type) {
2641 case LOOP_EXCEPTION_RANGE:
2642 if (rangePtr->continueOffset == -1) {
2643 TRACE(("=> loop w/o continue, checking for catch\n"));
2644 goto checkForCatch;
2645 } else {
2646 result = TCL_OK;
2647 TRACE(("=> range at %d, new pc %d\n",
2648 rangePtr->codeOffset, rangePtr->continueOffset));
2649 }
2650 break;
2651 case CATCH_EXCEPTION_RANGE:
2652 result = TCL_CONTINUE;
2653 TRACE(("=> ...\n"));
2654 goto processCatch; /* it will use rangePtr */
2655 default:
2656 panic("TclExecuteByteCode: unrecognized ExceptionRange type %d\n", rangePtr->type);
2657 }
2658 pc = (codePtr->codeStart + rangePtr->continueOffset);
2659 continue; /* restart outer instruction loop at pc */
2660
2661 case INST_FOREACH_START4:
2662 opnd = TclGetUInt4AtPtr(pc+1);
2663 {
2664 /*
2665 * Initialize the temporary local var that holds the count
2666 * of the number of iterations of the loop body to -1.
2667 */
2668
2669 ForeachInfo *infoPtr = (ForeachInfo *)
2670 codePtr->auxDataArrayPtr[opnd].clientData;
2671 int iterTmpIndex = infoPtr->loopCtTemp;
2672 Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2673 Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
2674 Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
2675
2676 if (oldValuePtr == NULL) {
2677 iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
2678 Tcl_IncrRefCount(iterVarPtr->value.objPtr);
2679 } else {
2680 Tcl_SetLongObj(oldValuePtr, -1);
2681 }
2682 TclSetVarScalar(iterVarPtr);
2683 TclClearVarUndefined(iterVarPtr);
2684 TRACE(("%u => loop iter count temp %d\n",
2685 opnd, iterTmpIndex));
2686 }
2687 ADJUST_PC(5);
2688
2689 case INST_FOREACH_STEP4:
2690 opnd = TclGetUInt4AtPtr(pc+1);
2691 {
2692 /*
2693 * "Step" a foreach loop (i.e., begin its next iteration) by
2694 * assigning the next value list element to each loop var.
2695 */
2696
2697 ForeachInfo *infoPtr = (ForeachInfo *)
2698 codePtr->auxDataArrayPtr[opnd].clientData;
2699 ForeachVarList *varListPtr;
2700 int numLists = infoPtr->numLists;
2701 Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
2702 Tcl_Obj *listPtr;
2703 List *listRepPtr;
2704 Var *iterVarPtr, *listVarPtr;
2705 int iterNum, listTmpIndex, listLen, numVars;
2706 int varIndex, valIndex, continueLoop, j;
2707
2708 /*
2709 * Increment the temp holding the loop iteration number.
2710 */
2711
2712 iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
2713 valuePtr = iterVarPtr->value.objPtr;
2714 iterNum = (valuePtr->internalRep.longValue + 1);
2715 Tcl_SetLongObj(valuePtr, iterNum);
2716
2717 /*
2718 * Check whether all value lists are exhausted and we should
2719 * stop the loop.
2720 */
2721
2722 continueLoop = 0;
2723 listTmpIndex = infoPtr->firstValueTemp;
2724 for (i = 0; i < numLists; i++) {
2725 varListPtr = infoPtr->varLists[i];
2726 numVars = varListPtr->numVars;
2727
2728 listVarPtr = &(compiledLocals[listTmpIndex]);
2729 listPtr = listVarPtr->value.objPtr;
2730 result = Tcl_ListObjLength(interp, listPtr, &listLen);
2731 if (result != TCL_OK) {
2732 TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
2733 opnd, i, O2S(listPtr)),
2734 Tcl_GetObjResult(interp));
2735 goto checkForCatch;
2736 }
2737 if (listLen > (iterNum * numVars)) {
2738 continueLoop = 1;
2739 }
2740 listTmpIndex++;
2741 }
2742
2743 /*
2744 * If some var in some var list still has a remaining list
2745 * element iterate one more time. Assign to var the next
2746 * element from its value list. We already checked above
2747 * that each list temp holds a valid list object.
2748 */
2749
2750 if (continueLoop) {
2751 listTmpIndex = infoPtr->firstValueTemp;
2752 for (i = 0; i < numLists; i++) {
2753 varListPtr = infoPtr->varLists[i];
2754 numVars = varListPtr->numVars;
2755
2756 listVarPtr = &(compiledLocals[listTmpIndex]);
2757 listPtr = listVarPtr->value.objPtr;
2758 listRepPtr = (List *) listPtr->internalRep.otherValuePtr;
2759 listLen = listRepPtr->elemCount;
2760
2761 valIndex = (iterNum * numVars);
2762 for (j = 0; j < numVars; j++) {
2763 int setEmptyStr = 0;
2764 if (valIndex >= listLen) {
2765 setEmptyStr = 1;
2766 valuePtr = Tcl_NewObj();
2767 } else {
2768 valuePtr = listRepPtr->elements[valIndex];
2769 }
2770
2771 varIndex = varListPtr->varIndexes[j];
2772 DECACHE_STACK_INFO();
2773 value2Ptr = TclSetIndexedScalar(interp,
2774 varIndex, valuePtr, /*leaveErrorMsg*/ 1);
2775 CACHE_STACK_INFO();
2776 if (value2Ptr == NULL) {
2777 TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
2778 opnd, varIndex),
2779 Tcl_GetObjResult(interp));
2780 if (setEmptyStr) {
2781 Tcl_DecrRefCount(valuePtr);
2782 }
2783 result = TCL_ERROR;
2784 goto checkForCatch;
2785 }
2786 valIndex++;
2787 }
2788 listTmpIndex++;
2789 }
2790 }
2791
2792 /*
2793 * Push 1 if at least one value list had a remaining element
2794 * and the loop should continue. Otherwise push 0.
2795 */
2796
2797 PUSH_OBJECT(Tcl_NewLongObj(continueLoop));
2798 TRACE(("%u => %d lists, iter %d, %s loop\n",
2799 opnd, numLists, iterNum,
2800 (continueLoop? "continue" : "exit")));
2801 }
2802 ADJUST_PC(5);
2803
2804 case INST_BEGIN_CATCH4:
2805 /*
2806 * Record start of the catch command with exception range index
2807 * equal to the operand. Push the current stack depth onto the
2808 * special catch stack.
2809 */
2810 catchStackPtr[++catchTop] = stackTop;
2811 TRACE(("%u => catchTop=%d, stackTop=%d\n",
2812 TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
2813 ADJUST_PC(5);
2814
2815 case INST_END_CATCH:
2816 catchTop--;
2817 result = TCL_OK;
2818 TRACE(("=> catchTop=%d\n", catchTop));
2819 ADJUST_PC(1);
2820
2821 case INST_PUSH_RESULT:
2822 PUSH_OBJECT(Tcl_GetObjResult(interp));
2823 TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
2824 ADJUST_PC(1);
2825
2826 case INST_PUSH_RETURN_CODE:
2827 PUSH_OBJECT(Tcl_NewLongObj(result));
2828 TRACE(("=> %u\n", result));
2829 ADJUST_PC(1);
2830
2831 default:
2832 panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
2833 } /* end of switch on opCode */
2834
2835 /*
2836 * Division by zero in an expression. Control only reaches this
2837 * point by "goto divideByZero".
2838 */
2839
2840 divideByZero:
2841 Tcl_ResetResult(interp);
2842 Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
2843 Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
2844 (char *) NULL);
2845 result = TCL_ERROR;
2846
2847 /*
2848 * Execution has generated an "exception" such as TCL_ERROR. If the
2849 * exception is an error, record information about what was being
2850 * executed when the error occurred. Find the closest enclosing
2851 * catch range, if any. If no enclosing catch range is found, stop
2852 * execution and return the "exception" code.
2853 */
2854
2855 checkForCatch:
2856 if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
2857 bytes = GetSrcInfoForPc(pc, codePtr, &length);
2858 if (bytes != NULL) {
2859 Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
2860 iPtr->flags |= ERR_ALREADY_LOGGED;
2861 }
2862 }
2863 rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
2864 if (rangePtr == NULL) {
2865 #ifdef TCL_COMPILE_DEBUG
2866 if (traceInstructions) {
2867 fprintf(stdout, " ... no enclosing catch, returning %s\n",
2868 StringForResultCode(result));
2869 }
2870 #endif
2871 goto abnormalReturn;
2872 }
2873
2874 /*
2875 * A catch exception range (rangePtr) was found to handle an
2876 * "exception". It was found either by checkForCatch just above or
2877 * by an instruction during break, continue, or error processing.
2878 * Jump to its catchOffset after unwinding the operand stack to
2879 * the depth it had when starting to execute the range's catch
2880 * command.
2881 */
2882
2883 processCatch:
2884 while (stackTop > catchStackPtr[catchTop]) {
2885 valuePtr = POP_OBJECT();
2886 TclDecrRefCount(valuePtr);
2887 }
2888 #ifdef TCL_COMPILE_DEBUG
2889 if (traceInstructions) {
2890 fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
2891 rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
2892 (unsigned int)(rangePtr->catchOffset));
2893 }
2894 #endif
2895 pc = (codePtr->codeStart + rangePtr->catchOffset);
2896 continue; /* restart the execution loop at pc */
2897 } /* end of infinite loop dispatching on instructions */
2898
2899 /*
2900 * Abnormal return code. Restore the stack to state it had when starting
2901 * to execute the ByteCode.
2902 */
2903
2904 abnormalReturn:
2905 while (stackTop > initStackTop) {
2906 valuePtr = POP_OBJECT();
2907 Tcl_DecrRefCount(valuePtr);
2908 }
2909
2910 /*
2911 * Free the catch stack array if malloc'ed storage was used.
2912 */
2913
2914 done:
2915 if (catchStackPtr != catchStackStorage) {
2916 ckfree((char *) catchStackPtr);
2917 }
2918 eePtr->stackTop = initStackTop;
2919 return result;
2920 #undef STATIC_CATCH_STACK_SIZE
2921 }
2922
2923 #ifdef TCL_COMPILE_DEBUG
2924 /*
2925 *----------------------------------------------------------------------
2926 *
2927 * PrintByteCodeInfo --
2928 *
2929 * This procedure prints a summary about a bytecode object to stdout.
2930 * It is called by TclExecuteByteCode when starting to execute the
2931 * bytecode object if tclTraceExec has the value 2 or more.
2932 *
2933 * Results:
2934 * None.
2935 *
2936 * Side effects:
2937 * None.
2938 *
2939 *----------------------------------------------------------------------
2940 */
2941
2942 static void
2943 PrintByteCodeInfo(codePtr)
2944 register ByteCode *codePtr; /* The bytecode whose summary is printed
2945 * to stdout. */
2946 {
2947 Proc *procPtr = codePtr->procPtr;
2948 Interp *iPtr = (Interp *) *codePtr->interpHandle;
2949
2950 fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
2951 (unsigned int) codePtr, codePtr->refCount,
2952 codePtr->compileEpoch, (unsigned int) iPtr,
2953 iPtr->compileEpoch);
2954
2955 fprintf(stdout, " Source: ");
2956 TclPrintSource(stdout, codePtr->source, 60);
2957
2958 fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
2959 codePtr->numCommands, codePtr->numSrcBytes,
2960 codePtr->numCodeBytes, codePtr->numLitObjects,
2961 codePtr->numAuxDataItems, codePtr->maxStackDepth,
2962 #ifdef TCL_COMPILE_STATS
2963 (codePtr->numSrcBytes?
2964 ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
2965 #else
2966 0.0);
2967 #endif
2968 #ifdef TCL_COMPILE_STATS
2969 fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
2970 codePtr->structureSize,
2971 (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
2972 codePtr->numCodeBytes,
2973 (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
2974 (codePtr->numExceptRanges * sizeof(ExceptionRange)),
2975 (codePtr->numAuxDataItems * sizeof(AuxData)),
2976 codePtr->numCmdLocBytes);
2977 #endif /* TCL_COMPILE_STATS */
2978 if (procPtr != NULL) {
2979 fprintf(stdout,
2980 " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
2981 (unsigned int) procPtr, procPtr->refCount,
2982 procPtr->numArgs, procPtr->numCompiledLocals);
2983 }
2984 }
2985 #endif /* TCL_COMPILE_DEBUG */
2986
2987 /*
2988 *----------------------------------------------------------------------
2989 *
2990 * ValidatePcAndStackTop --
2991 *
2992 * This procedure is called by TclExecuteByteCode when debugging to
2993 * verify that the program counter and stack top are valid during
2994 * execution.
2995 *
2996 * Results:
2997 * None.
2998 *
2999 * Side effects:
3000 * Prints a message to stderr and panics if either the pc or stack
3001 * top are invalid.
3002 *
3003 *----------------------------------------------------------------------
3004 */
3005
3006 #ifdef TCL_COMPILE_DEBUG
3007 static void
3008 ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound,
3009 stackUpperBound)
3010 register ByteCode *codePtr; /* The bytecode whose summary is printed
3011 * to stdout. */
3012 unsigned char *pc; /* Points to first byte of a bytecode
3013 * instruction. The program counter. */
3014 int stackTop; /* Current stack top. Must be between
3015 * stackLowerBound and stackUpperBound
3016 * (inclusive). */
3017 int stackLowerBound; /* Smallest legal value for stackTop. */
3018 int stackUpperBound; /* Greatest legal value for stackTop. */
3019 {
3020 unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
3021 unsigned int codeStart = (unsigned int) codePtr->codeStart;
3022 unsigned int codeEnd = (unsigned int)
3023 (codePtr->codeStart + codePtr->numCodeBytes);
3024 unsigned char opCode = *pc;
3025
3026 if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
3027 fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
3028 (unsigned int) pc);
3029 panic("TclExecuteByteCode execution failure: bad pc");
3030 }
3031 if ((unsigned int) opCode > LAST_INST_OPCODE) {
3032 fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
3033 (unsigned int) opCode, relativePc);
3034 panic("TclExecuteByteCode execution failure: bad opcode");
3035 }
3036 if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
3037 int numChars;
3038 char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
3039 char *ellipsis = "";
3040
3041 fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode",
3042 stackTop, relativePc);
3043 if (cmd != NULL) {
3044 if (numChars > 100) {
3045 numChars = 100;
3046 ellipsis = "...";
3047 }
3048 fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
3049 ellipsis);
3050 } else {
3051 fprintf(stderr, "\n");
3052 }
3053 panic("TclExecuteByteCode execution failure: bad stack top");
3054 }
3055 }
3056 #endif /* TCL_COMPILE_DEBUG */
3057
3058 /*
3059 *----------------------------------------------------------------------
3060 *
3061 * IllegalExprOperandType --
3062 *
3063 * Used by TclExecuteByteCode to add an error message to errorInfo
3064 * when an illegal operand type is detected by an expression
3065 * instruction. The argument opndPtr holds the operand object in error.
3066 *
3067 * Results:
3068 * None.
3069 *
3070 * Side effects:
3071 * An error message is appended to errorInfo.
3072 *
3073 *----------------------------------------------------------------------
3074 */
3075
3076 static void
3077 IllegalExprOperandType(interp, pc, opndPtr)
3078 Tcl_Interp *interp; /* Interpreter to which error information
3079 * pertains. */
3080 unsigned char *pc; /* Points to the instruction being executed
3081 * when the illegal type was found. */
3082 Tcl_Obj *opndPtr; /* Points to the operand holding the value
3083 * with the illegal type. */
3084 {
3085 unsigned char opCode = *pc;
3086
3087 Tcl_ResetResult(interp);
3088 if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
3089 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
3090 "can't use empty string as operand of \"",
3091 operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
3092 } else {
3093 char *msg = "non-numeric string";
3094 if (opndPtr->typePtr != &tclDoubleType) {
3095 /*
3096 * See if the operand can be interpreted as a double in order to
3097 * improve the error message.
3098 */
3099
3100 char *s = Tcl_GetString(opndPtr);
3101 double d;
3102
3103 if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
3104 /*
3105 * Make sure that what appears to be a double
3106 * (ie 08) isn't really a bad octal
3107 */
3108 if (TclCheckBadOctal(NULL, Tcl_GetString(opndPtr))) {
3109 msg = "invalid octal number";
3110 } else {
3111 msg = "floating-point value";
3112 }
3113 }
3114 }
3115 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
3116 msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
3117 "\"", (char *) NULL);
3118 }
3119 }
3120
3121 /*
3122 *----------------------------------------------------------------------
3123 *
3124 * CallTraceProcedure --
3125 *
3126 * Invokes a trace procedure registered with an interpreter. These
3127 * procedures trace command execution. Currently this trace procedure
3128 * is called with the address of the string-based Tcl_CmdProc for the
3129 * command, not the Tcl_ObjCmdProc.
3130 *
3131 * Results:
3132 * None.
3133 *
3134 * Side effects:
3135 * Those side effects made by the trace procedure.
3136 *
3137 *----------------------------------------------------------------------
3138 */
3139
3140 static void
3141 CallTraceProcedure(interp, tracePtr, cmdPtr, command, numChars, objc, objv)
3142 Tcl_Interp *interp; /* The current interpreter. */
3143 register Trace *tracePtr; /* Describes the trace procedure to call. */
3144 Command *cmdPtr; /* Points to command's Command struct. */
3145 char *command; /* Points to the first character of the
3146 * command's source before substitutions. */
3147 int numChars; /* The number of characters in the
3148 * command's source. */
3149 register int objc; /* Number of arguments for the command. */
3150 Tcl_Obj *objv[]; /* Pointers to Tcl_Obj of each argument. */
3151 {
3152 Interp *iPtr = (Interp *) interp;
3153 register char **argv;
3154 register int i;
3155 int length;
3156 char *p;
3157
3158 /*
3159 * Get the string rep from the objv argument objects and place their
3160 * pointers in argv. First make sure argv is large enough to hold the
3161 * objc args plus 1 extra word for the zero end-of-argv word.
3162 */
3163
3164 argv = (char **) ckalloc((unsigned)(objc + 1) * sizeof(char *));
3165 for (i = 0; i < objc; i++) {
3166 argv[i] = Tcl_GetStringFromObj(objv[i], &length);
3167 }
3168 argv[objc] = 0;
3169
3170 /*
3171 * Copy the command characters into a new string.
3172 */
3173
3174 p = (char *) ckalloc((unsigned) (numChars + 1));
3175 memcpy((VOID *) p, (VOID *) command, (size_t) numChars);
3176 p[numChars] = '\0';
3177
3178 /*
3179 * Call the trace procedure then free allocated storage.
3180 */
3181
3182 (*tracePtr->proc)(tracePtr->clientData, interp, iPtr->numLevels,
3183 p, cmdPtr->proc, cmdPtr->clientData, objc, argv);
3184
3185 ckfree((char *) argv);
3186 ckfree((char *) p);
3187 }
3188
3189 /*
3190 *----------------------------------------------------------------------
3191 *
3192 * GetSrcInfoForPc --
3193 *
3194 * Given a program counter value, finds the closest command in the
3195 * bytecode code unit's CmdLocation array and returns information about
3196 * that command's source: a pointer to its first byte and the number of
3197 * characters.
3198 *
3199 * Results:
3200 * If a command is found that encloses the program counter value, a
3201 * pointer to the command's source is returned and the length of the
3202 * source is stored at *lengthPtr. If multiple commands resulted in
3203 * code at pc, information about the closest enclosing command is
3204 * returned. If no matching command is found, NULL is returned and
3205 * *lengthPtr is unchanged.
3206 *
3207 * Side effects:
3208 * None.
3209 *
3210 *----------------------------------------------------------------------
3211 */
3212
3213 static char *
3214 GetSrcInfoForPc(pc, codePtr, lengthPtr)
3215 unsigned char *pc; /* The program counter value for which to
3216 * return the closest command's source info.
3217 * This points to a bytecode instruction
3218 * in codePtr's code. */
3219 ByteCode *codePtr; /* The bytecode sequence in which to look
3220 * up the command source for the pc. */
3221 int *lengthPtr; /* If non-NULL, the location where the
3222 * length of the command's source should be
3223 * stored. If NULL, no length is stored. */
3224 {
3225 register int pcOffset = (pc - codePtr->codeStart);
3226 int numCmds = codePtr->numCommands;
3227 unsigned char *codeDeltaNext, *codeLengthNext;
3228 unsigned char *srcDeltaNext, *srcLengthNext;
3229 int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
3230 int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
3231 int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
3232 int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
3233
3234 if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
3235 return NULL;
3236 }
3237
3238 /*
3239 * Decode the code and source offset and length for each command. The
3240 * closest enclosing command is the last one whose code started before
3241 * pcOffset.
3242 */
3243
3244 codeDeltaNext = codePtr->codeDeltaStart;
3245 codeLengthNext = codePtr->codeLengthStart;
3246 srcDeltaNext = codePtr->srcDeltaStart;
3247 srcLengthNext = codePtr->srcLengthStart;
3248 codeOffset = srcOffset = 0;
3249 for (i = 0; i < numCmds; i++) {
3250 if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
3251 codeDeltaNext++;
3252 delta = TclGetInt4AtPtr(codeDeltaNext);
3253 codeDeltaNext += 4;
3254 } else {
3255 delta = TclGetInt1AtPtr(codeDeltaNext);
3256 codeDeltaNext++;
3257 }
3258 codeOffset += delta;
3259
3260 if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
3261 codeLengthNext++;
3262 codeLen = TclGetInt4AtPtr(codeLengthNext);
3263 codeLengthNext += 4;
3264 } else {
3265 codeLen = TclGetInt1AtPtr(codeLengthNext);
3266 codeLengthNext++;
3267 }
3268 codeEnd = (codeOffset + codeLen - 1);
3269
3270 if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
3271 srcDeltaNext++;
3272 delta = TclGetInt4AtPtr(srcDeltaNext);
3273 srcDeltaNext += 4;
3274 } else {
3275 delta = TclGetInt1AtPtr(srcDeltaNext);
3276 srcDeltaNext++;
3277 }
3278 srcOffset += delta;
3279
3280 if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
3281 srcLengthNext++;
3282 srcLen = TclGetInt4AtPtr(srcLengthNext);
3283 srcLengthNext += 4;
3284 } else {
3285 srcLen = TclGetInt1AtPtr(srcLengthNext);
3286 srcLengthNext++;
3287 }
3288
3289 if (codeOffset > pcOffset) { /* best cmd already found */
3290 break;
3291 } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
3292 int dist = (pcOffset - codeOffset);
3293 if (dist <= bestDist) {
3294 bestDist = dist;
3295 bestSrcOffset = srcOffset;
3296 bestSrcLength = srcLen;
3297 }
3298 }
3299 }
3300
3301 if (bestDist == INT_MAX) {
3302 return NULL;
3303 }
3304
3305 if (lengthPtr != NULL) {
3306 *lengthPtr = bestSrcLength;
3307 }
3308 return (codePtr->source + bestSrcOffset);
3309 }
3310
3311 /*
3312 *----------------------------------------------------------------------
3313 *
3314 * GetExceptRangeForPc --
3315 *
3316 * Given a program counter value, return the closest enclosing
3317 * ExceptionRange.
3318 *
3319 * Results:
3320 * In the normal case, catchOnly is 0 (false) and this procedure
3321 * returns a pointer to the most closely enclosing ExceptionRange
3322 * structure regardless of whether it is a loop or catch exception
3323 * range. This is appropriate when processing a TCL_BREAK or
3324 * TCL_CONTINUE, which will be "handled" either by a loop exception
3325 * range or a closer catch range. If catchOnly is nonzero, this
3326 * procedure ignores loop exception ranges and returns a pointer to the
3327 * closest catch range. If no matching ExceptionRange is found that
3328 * encloses pc, a NULL is returned.
3329 *
3330 * Side effects:
3331 * None.
3332 *
3333 *----------------------------------------------------------------------
3334 */
3335
3336 static ExceptionRange *
3337 GetExceptRangeForPc(pc, catchOnly, codePtr)
3338 unsigned char *pc; /* The program counter value for which to
3339 * search for a closest enclosing exception
3340 * range. This points to a bytecode
3341 * instruction in codePtr's code. */
3342 int catchOnly; /* If 0, consider either loop or catch
3343 * ExceptionRanges in search. If nonzero
3344 * consider only catch ranges (and ignore
3345 * any closer loop ranges). */
3346 ByteCode* codePtr; /* Points to the ByteCode in which to search
3347 * for the enclosing ExceptionRange. */
3348 {
3349 ExceptionRange *rangeArrayPtr;
3350 int numRanges = codePtr->numExceptRanges;
3351 register ExceptionRange *rangePtr;
3352 int pcOffset = (pc - codePtr->codeStart);
3353 register int i, level;
3354
3355 if (numRanges == 0) {
3356 return NULL;
3357 }
3358 rangeArrayPtr = codePtr->exceptArrayPtr;
3359
3360 for (level = codePtr->maxExceptDepth; level >= 0; level--) {
3361 for (i = 0; i < numRanges; i++) {
3362 rangePtr = &(rangeArrayPtr[i]);
3363 if (rangePtr->nestingLevel == level) {
3364 int start = rangePtr->codeOffset;
3365 int end = (start + rangePtr->numCodeBytes);
3366 if ((start <= pcOffset) && (pcOffset < end)) {
3367 if ((!catchOnly)
3368 || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
3369 return rangePtr;
3370 }
3371 }
3372 }
3373 }
3374 }
3375 return NULL;
3376 }
3377
3378 /*
3379 *----------------------------------------------------------------------
3380 *
3381 * GetOpcodeName --
3382 *
3383 * This procedure is called by the TRACE and TRACE_WITH_OBJ macros
3384 * used in TclExecuteByteCode when debugging. It returns the name of
3385 * the bytecode instruction at a specified instruction pc.
3386 *
3387 * Results:
3388 * A character string for the instruction.
3389 *
3390 * Side effects:
3391 * None.
3392 *
3393 *----------------------------------------------------------------------
3394 */
3395
3396 #ifdef TCL_COMPILE_DEBUG
3397 static char *
3398 GetOpcodeName(pc)
3399 unsigned char *pc; /* Points to the instruction whose name
3400 * should be returned. */
3401 {
3402 unsigned char opCode = *pc;
3403
3404 return instructionTable[opCode].name;
3405 }
3406 #endif /* TCL_COMPILE_DEBUG */
3407
3408 /*
3409 *----------------------------------------------------------------------
3410 *
3411 * VerifyExprObjType --
3412 *
3413 * This procedure is called by the math functions to verify that
3414 * the object is either an int or double, coercing it if necessary.
3415 * If an error occurs during conversion, an error message is left
3416 * in the interpreter's result unless "interp" is NULL.
3417 *
3418 * Results:
3419 * TCL_OK if it was int or double, TCL_ERROR otherwise
3420 *
3421 * Side effects:
3422 * objPtr is ensured to be either tclIntType of tclDoubleType.
3423 *
3424 *----------------------------------------------------------------------
3425 */
3426
3427 static int
3428 VerifyExprObjType(interp, objPtr)
3429 Tcl_Interp *interp; /* The interpreter in which to execute the
3430 * function. */
3431 Tcl_Obj *objPtr; /* Points to the object to type check. */
3432 {
3433 if ((objPtr->typePtr == &tclIntType) ||
3434 (objPtr->typePtr == &tclDoubleType)) {
3435 return TCL_OK;
3436 } else {
3437 int length, result = TCL_OK;
3438 char *s = Tcl_GetStringFromObj(objPtr, &length);
3439
3440 if (TclLooksLikeInt(s, length)) {
3441 long i;
3442 result = Tcl_GetLongFromObj((Tcl_Interp *) NULL, objPtr, &i);
3443 } else {
3444 double d;
3445 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
3446 }
3447 if ((result != TCL_OK) && (interp != NULL)) {
3448 Tcl_ResetResult(interp);
3449 if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
3450 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3451 "argument to math function was an invalid octal number",
3452 -1);
3453 } else {
3454 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3455 "argument to math function didn't have numeric value",
3456 -1);
3457 }
3458 }
3459 return result;
3460 }
3461 }
3462
3463 /*
3464 *----------------------------------------------------------------------
3465 *
3466 * Math Functions --
3467 *
3468 * This page contains the procedures that implement all of the
3469 * built-in math functions for expressions.
3470 *
3471 * Results:
3472 * Each procedure returns TCL_OK if it succeeds and pushes an
3473 * Tcl object holding the result. If it fails it returns TCL_ERROR
3474 * and leaves an error message in the interpreter's result.
3475 *
3476 * Side effects:
3477 * None.
3478 *
3479 *----------------------------------------------------------------------
3480 */
3481
3482 static int
3483 ExprUnaryFunc(interp, eePtr, clientData)
3484 Tcl_Interp *interp; /* The interpreter in which to execute the
3485 * function. */
3486 ExecEnv *eePtr; /* Points to the environment for executing
3487 * the function. */
3488 ClientData clientData; /* Contains the address of a procedure that
3489 * takes one double argument and returns a
3490 * double result. */
3491 {
3492 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3493 register int stackTop; /* Cached top index of evaluation stack. */
3494 register Tcl_Obj *valuePtr;
3495 double d, dResult;
3496 int result;
3497
3498 double (*func) _ANSI_ARGS_((double)) =
3499 (double (*)_ANSI_ARGS_((double))) clientData;
3500
3501 /*
3502 * Set stackPtr and stackTop from eePtr.
3503 */
3504
3505 result = TCL_OK;
3506 CACHE_STACK_INFO();
3507
3508 /*
3509 * Pop the function's argument from the evaluation stack. Convert it
3510 * to a double if necessary.
3511 */
3512
3513 valuePtr = POP_OBJECT();
3514
3515 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3516 result = TCL_ERROR;
3517 goto done;
3518 }
3519
3520 if (valuePtr->typePtr == &tclIntType) {
3521 d = (double) valuePtr->internalRep.longValue;
3522 } else {
3523 d = valuePtr->internalRep.doubleValue;
3524 }
3525
3526 errno = 0;
3527 dResult = (*func)(d);
3528 if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
3529 TclExprFloatError(interp, dResult);
3530 result = TCL_ERROR;
3531 goto done;
3532 }
3533
3534 /*
3535 * Push a Tcl object holding the result.
3536 */
3537
3538 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3539
3540 /*
3541 * Reflect the change to stackTop back in eePtr.
3542 */
3543
3544 done:
3545 Tcl_DecrRefCount(valuePtr);
3546 DECACHE_STACK_INFO();
3547 return result;
3548 }
3549
3550 static int
3551 ExprBinaryFunc(interp, eePtr, clientData)
3552 Tcl_Interp *interp; /* The interpreter in which to execute the
3553 * function. */
3554 ExecEnv *eePtr; /* Points to the environment for executing
3555 * the function. */
3556 ClientData clientData; /* Contains the address of a procedure that
3557 * takes two double arguments and
3558 * returns a double result. */
3559 {
3560 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3561 register int stackTop; /* Cached top index of evaluation stack. */
3562 register Tcl_Obj *valuePtr, *value2Ptr;
3563 double d1, d2, dResult;
3564 int result;
3565
3566 double (*func) _ANSI_ARGS_((double, double))
3567 = (double (*)_ANSI_ARGS_((double, double))) clientData;
3568
3569 /*
3570 * Set stackPtr and stackTop from eePtr.
3571 */
3572
3573 result = TCL_OK;
3574 CACHE_STACK_INFO();
3575
3576 /*
3577 * Pop the function's two arguments from the evaluation stack. Convert
3578 * them to doubles if necessary.
3579 */
3580
3581 value2Ptr = POP_OBJECT();
3582 valuePtr = POP_OBJECT();
3583
3584 if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
3585 (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
3586 result = TCL_ERROR;
3587 goto done;
3588 }
3589
3590 if (valuePtr->typePtr == &tclIntType) {
3591 d1 = (double) valuePtr->internalRep.longValue;
3592 } else {
3593 d1 = valuePtr->internalRep.doubleValue;
3594 }
3595
3596 if (value2Ptr->typePtr == &tclIntType) {
3597 d2 = (double) value2Ptr->internalRep.longValue;
3598 } else {
3599 d2 = value2Ptr->internalRep.doubleValue;
3600 }
3601
3602 errno = 0;
3603 dResult = (*func)(d1, d2);
3604 if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
3605 TclExprFloatError(interp, dResult);
3606 result = TCL_ERROR;
3607 goto done;
3608 }
3609
3610 /*
3611 * Push a Tcl object holding the result.
3612 */
3613
3614 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3615
3616 /*
3617 * Reflect the change to stackTop back in eePtr.
3618 */
3619
3620 done:
3621 Tcl_DecrRefCount(valuePtr);
3622 Tcl_DecrRefCount(value2Ptr);
3623 DECACHE_STACK_INFO();
3624 return result;
3625 }
3626
3627 static int
3628 ExprAbsFunc(interp, eePtr, clientData)
3629 Tcl_Interp *interp; /* The interpreter in which to execute the
3630 * function. */
3631 ExecEnv *eePtr; /* Points to the environment for executing
3632 * the function. */
3633 ClientData clientData; /* Ignored. */
3634 {
3635 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3636 register int stackTop; /* Cached top index of evaluation stack. */
3637 register Tcl_Obj *valuePtr;
3638 long i, iResult;
3639 double d, dResult;
3640 int result;
3641
3642 /*
3643 * Set stackPtr and stackTop from eePtr.
3644 */
3645
3646 result = TCL_OK;
3647 CACHE_STACK_INFO();
3648
3649 /*
3650 * Pop the argument from the evaluation stack.
3651 */
3652
3653 valuePtr = POP_OBJECT();
3654
3655 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3656 result = TCL_ERROR;
3657 goto done;
3658 }
3659
3660 /*
3661 * Push a Tcl object with the result.
3662 */
3663 if (valuePtr->typePtr == &tclIntType) {
3664 i = valuePtr->internalRep.longValue;
3665 if (i < 0) {
3666 iResult = -i;
3667 if (iResult < 0) {
3668 Tcl_ResetResult(interp);
3669 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3670 "integer value too large to represent", -1);
3671 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3672 "integer value too large to represent", (char *) NULL);
3673 result = TCL_ERROR;
3674 goto done;
3675 }
3676 } else {
3677 iResult = i;
3678 }
3679 PUSH_OBJECT(Tcl_NewLongObj(iResult));
3680 } else {
3681 d = valuePtr->internalRep.doubleValue;
3682 if (d < 0.0) {
3683 dResult = -d;
3684 } else {
3685 dResult = d;
3686 }
3687 if (IS_NAN(dResult) || IS_INF(dResult)) {
3688 TclExprFloatError(interp, dResult);
3689 result = TCL_ERROR;
3690 goto done;
3691 }
3692 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3693 }
3694
3695 /*
3696 * Reflect the change to stackTop back in eePtr.
3697 */
3698
3699 done:
3700 Tcl_DecrRefCount(valuePtr);
3701 DECACHE_STACK_INFO();
3702 return result;
3703 }
3704
3705 static int
3706 ExprDoubleFunc(interp, eePtr, clientData)
3707 Tcl_Interp *interp; /* The interpreter in which to execute the
3708 * function. */
3709 ExecEnv *eePtr; /* Points to the environment for executing
3710 * the function. */
3711 ClientData clientData; /* Ignored. */
3712 {
3713 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3714 register int stackTop; /* Cached top index of evaluation stack. */
3715 register Tcl_Obj *valuePtr;
3716 double dResult;
3717 int result;
3718
3719 /*
3720 * Set stackPtr and stackTop from eePtr.
3721 */
3722
3723 result = TCL_OK;
3724 CACHE_STACK_INFO();
3725
3726 /*
3727 * Pop the argument from the evaluation stack.
3728 */
3729
3730 valuePtr = POP_OBJECT();
3731
3732 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3733 result = TCL_ERROR;
3734 goto done;
3735 }
3736
3737 if (valuePtr->typePtr == &tclIntType) {
3738 dResult = (double) valuePtr->internalRep.longValue;
3739 } else {
3740 dResult = valuePtr->internalRep.doubleValue;
3741 }
3742
3743 /*
3744 * Push a Tcl object with the result.
3745 */
3746
3747 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3748
3749 /*
3750 * Reflect the change to stackTop back in eePtr.
3751 */
3752
3753 done:
3754 Tcl_DecrRefCount(valuePtr);
3755 DECACHE_STACK_INFO();
3756 return result;
3757 }
3758
3759 static int
3760 ExprIntFunc(interp, eePtr, clientData)
3761 Tcl_Interp *interp; /* The interpreter in which to execute the
3762 * function. */
3763 ExecEnv *eePtr; /* Points to the environment for executing
3764 * the function. */
3765 ClientData clientData; /* Ignored. */
3766 {
3767 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3768 register int stackTop; /* Cached top index of evaluation stack. */
3769 register Tcl_Obj *valuePtr;
3770 long iResult;
3771 double d;
3772 int result;
3773
3774 /*
3775 * Set stackPtr and stackTop from eePtr.
3776 */
3777
3778 result = TCL_OK;
3779 CACHE_STACK_INFO();
3780
3781 /*
3782 * Pop the argument from the evaluation stack.
3783 */
3784
3785 valuePtr = POP_OBJECT();
3786
3787 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3788 result = TCL_ERROR;
3789 goto done;
3790 }
3791
3792 if (valuePtr->typePtr == &tclIntType) {
3793 iResult = valuePtr->internalRep.longValue;
3794 } else {
3795 d = valuePtr->internalRep.doubleValue;
3796 if (d < 0.0) {
3797 if (d < (double) (long) LONG_MIN) {
3798 tooLarge:
3799 Tcl_ResetResult(interp);
3800 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3801 "integer value too large to represent", -1);
3802 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3803 "integer value too large to represent", (char *) NULL);
3804 result = TCL_ERROR;
3805 goto done;
3806 }
3807 } else {
3808 if (d > (double) LONG_MAX) {
3809 goto tooLarge;
3810 }
3811 }
3812 if (IS_NAN(d) || IS_INF(d)) {
3813 TclExprFloatError(interp, d);
3814 result = TCL_ERROR;
3815 goto done;
3816 }
3817 iResult = (long) d;
3818 }
3819
3820 /*
3821 * Push a Tcl object with the result.
3822 */
3823
3824 PUSH_OBJECT(Tcl_NewLongObj(iResult));
3825
3826 /*
3827 * Reflect the change to stackTop back in eePtr.
3828 */
3829
3830 done:
3831 Tcl_DecrRefCount(valuePtr);
3832 DECACHE_STACK_INFO();
3833 return result;
3834 }
3835
3836 static int
3837 ExprRandFunc(interp, eePtr, clientData)
3838 Tcl_Interp *interp; /* The interpreter in which to execute the
3839 * function. */
3840 ExecEnv *eePtr; /* Points to the environment for executing
3841 * the function. */
3842 ClientData clientData; /* Ignored. */
3843 {
3844 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3845 register int stackTop; /* Cached top index of evaluation stack. */
3846 Interp *iPtr = (Interp *) interp;
3847 double dResult;
3848 int tmp;
3849
3850 if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
3851 iPtr->flags |= RAND_SEED_INITIALIZED;
3852 iPtr->randSeed = TclpGetClicks();
3853 }
3854
3855 /*
3856 * Set stackPtr and stackTop from eePtr.
3857 */
3858
3859 CACHE_STACK_INFO();
3860
3861 /*
3862 * Generate the random number using the linear congruential
3863 * generator defined by the following recurrence:
3864 * seed = ( IA * seed ) mod IM
3865 * where IA is 16807 and IM is (2^31) - 1. In order to avoid
3866 * potential problems with integer overflow, the code uses
3867 * additional constants IQ and IR such that
3868 * IM = IA*IQ + IR
3869 * For details on how this algorithm works, refer to the following
3870 * papers:
3871 *
3872 * S.K. Park & K.W. Miller, "Random number generators: good ones
3873 * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
3874 *
3875 * W.H. Press & S.A. Teukolsky, "Portable random number
3876 * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
3877 */
3878
3879 #define RAND_IA 16807
3880 #define RAND_IM 2147483647
3881 #define RAND_IQ 127773
3882 #define RAND_IR 2836
3883 #define RAND_MASK 123459876
3884
3885 if (iPtr->randSeed == 0) {
3886 /*
3887 * Don't allow a 0 seed, since it breaks the generator. Shift
3888 * it to some other value.
3889 */
3890
3891 iPtr->randSeed = 123459876;
3892 }
3893 tmp = iPtr->randSeed/RAND_IQ;
3894 iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
3895 if (iPtr->randSeed < 0) {
3896 iPtr->randSeed += RAND_IM;
3897 }
3898
3899 /*
3900 * On 64-bit architectures we need to mask off the upper bits to
3901 * ensure we only have a 32-bit range. The constant has the
3902 * bizarre form below in order to make sure that it doesn't
3903 * get sign-extended (the rules for sign extension are very
3904 * concat, particularly on 64-bit machines).
3905 */
3906
3907 iPtr->randSeed &= ((((unsigned long) 0xfffffff) << 4) | 0xf);
3908 dResult = iPtr->randSeed * (1.0/RAND_IM);
3909
3910 /*
3911 * Push a Tcl object with the result.
3912 */
3913
3914 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
3915
3916 /*
3917 * Reflect the change to stackTop back in eePtr.
3918 */
3919
3920 DECACHE_STACK_INFO();
3921 return TCL_OK;
3922 }
3923
3924 static int
3925 ExprRoundFunc(interp, eePtr, clientData)
3926 Tcl_Interp *interp; /* The interpreter in which to execute the
3927 * function. */
3928 ExecEnv *eePtr; /* Points to the environment for executing
3929 * the function. */
3930 ClientData clientData; /* Ignored. */
3931 {
3932 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
3933 register int stackTop; /* Cached top index of evaluation stack. */
3934 Tcl_Obj *valuePtr;
3935 long iResult;
3936 double d, temp;
3937 int result;
3938
3939 /*
3940 * Set stackPtr and stackTop from eePtr.
3941 */
3942
3943 result = TCL_OK;
3944 CACHE_STACK_INFO();
3945
3946 /*
3947 * Pop the argument from the evaluation stack.
3948 */
3949
3950 valuePtr = POP_OBJECT();
3951
3952 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
3953 result = TCL_ERROR;
3954 goto done;
3955 }
3956
3957 if (valuePtr->typePtr == &tclIntType) {
3958 iResult = valuePtr->internalRep.longValue;
3959 } else {
3960 d = valuePtr->internalRep.doubleValue;
3961 if (d < 0.0) {
3962 if (d <= (((double) (long) LONG_MIN) - 0.5)) {
3963 tooLarge:
3964 Tcl_ResetResult(interp);
3965 Tcl_AppendToObj(Tcl_GetObjResult(interp),
3966 "integer value too large to represent", -1);
3967 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
3968 "integer value too large to represent",
3969 (char *) NULL);
3970 result = TCL_ERROR;
3971 goto done;
3972 }
3973 temp = (long) (d - 0.5);
3974 } else {
3975 if (d >= (((double) LONG_MAX + 0.5))) {
3976 goto tooLarge;
3977 }
3978 temp = (long) (d + 0.5);
3979 }
3980 if (IS_NAN(temp) || IS_INF(temp)) {
3981 TclExprFloatError(interp, temp);
3982 result = TCL_ERROR;
3983 goto done;
3984 }
3985 iResult = (long) temp;
3986 }
3987
3988 /*
3989 * Push a Tcl object with the result.
3990 */
3991
3992 PUSH_OBJECT(Tcl_NewLongObj(iResult));
3993
3994 /*
3995 * Reflect the change to stackTop back in eePtr.
3996 */
3997
3998 done:
3999 Tcl_DecrRefCount(valuePtr);
4000 DECACHE_STACK_INFO();
4001 return result;
4002 }
4003
4004 static int
4005 ExprSrandFunc(interp, eePtr, clientData)
4006 Tcl_Interp *interp; /* The interpreter in which to execute the
4007 * function. */
4008 ExecEnv *eePtr; /* Points to the environment for executing
4009 * the function. */
4010 ClientData clientData; /* Ignored. */
4011 {
4012 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
4013 register int stackTop; /* Cached top index of evaluation stack. */
4014 Interp *iPtr = (Interp *) interp;
4015 Tcl_Obj *valuePtr;
4016 long i = 0; /* Initialized to avoid compiler warning. */
4017 int result;
4018
4019 /*
4020 * Set stackPtr and stackTop from eePtr.
4021 */
4022
4023 CACHE_STACK_INFO();
4024
4025 /*
4026 * Pop the argument from the evaluation stack. Use the value
4027 * to reset the random number seed.
4028 */
4029
4030 valuePtr = POP_OBJECT();
4031
4032 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
4033 result = TCL_ERROR;
4034 goto badValue;
4035 }
4036
4037 if (valuePtr->typePtr == &tclIntType) {
4038 i = valuePtr->internalRep.longValue;
4039 } else {
4040 /*
4041 * At this point, the only other possible type is double
4042 */
4043 Tcl_ResetResult(interp);
4044 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
4045 "can't use floating-point value as argument to srand",
4046 (char *) NULL);
4047 badValue:
4048 Tcl_DecrRefCount(valuePtr);
4049 DECACHE_STACK_INFO();
4050 return TCL_ERROR;
4051 }
4052
4053 /*
4054 * Reset the seed.
4055 */
4056
4057 iPtr->flags |= RAND_SEED_INITIALIZED;
4058 iPtr->randSeed = i;
4059
4060 /*
4061 * To avoid duplicating the random number generation code we simply
4062 * clean up our state and call the real random number function. That
4063 * function will always succeed.
4064 */
4065
4066 Tcl_DecrRefCount(valuePtr);
4067 DECACHE_STACK_INFO();
4068
4069 ExprRandFunc(interp, eePtr, clientData);
4070 return TCL_OK;
4071 }
4072
4073 /*
4074 *----------------------------------------------------------------------
4075 *
4076 * ExprCallMathFunc --
4077 *
4078 * This procedure is invoked to call a non-builtin math function
4079 * during the execution of an expression.
4080 *
4081 * Results:
4082 * TCL_OK is returned if all went well and the function's value
4083 * was computed successfully. If an error occurred, TCL_ERROR
4084 * is returned and an error message is left in the interpreter's
4085 * result. After a successful return this procedure pushes a Tcl object
4086 * holding the result.
4087 *
4088 * Side effects:
4089 * None, unless the called math function has side effects.
4090 *
4091 *----------------------------------------------------------------------
4092 */
4093
4094 static int
4095 ExprCallMathFunc(interp, eePtr, objc, objv)
4096 Tcl_Interp *interp; /* The interpreter in which to execute the
4097 * function. */
4098 ExecEnv *eePtr; /* Points to the environment for executing
4099 * the function. */
4100 int objc; /* Number of arguments. The function name is
4101 * the 0-th argument. */
4102 Tcl_Obj **objv; /* The array of arguments. The function name
4103 * is objv[0]. */
4104 {
4105 Interp *iPtr = (Interp *) interp;
4106 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
4107 register int stackTop; /* Cached top index of evaluation stack. */
4108 char *funcName;
4109 Tcl_HashEntry *hPtr;
4110 MathFunc *mathFuncPtr; /* Information about math function. */
4111 Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
4112 Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
4113 register Tcl_Obj *valuePtr;
4114 long i;
4115 double d;
4116 int j, k, result;
4117 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
4118
4119 Tcl_ResetResult(interp);
4120
4121 /*
4122 * Set stackPtr and stackTop from eePtr.
4123 */
4124
4125 CACHE_STACK_INFO();
4126
4127 /*
4128 * Look up the MathFunc record for the function.
4129 */
4130
4131 funcName = Tcl_GetString(objv[0]);
4132 hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
4133 if (hPtr == NULL) {
4134 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
4135 "unknown math function \"", funcName, "\"", (char *) NULL);
4136 result = TCL_ERROR;
4137 goto done;
4138 }
4139 mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
4140 if (mathFuncPtr->numArgs != (objc-1)) {
4141 panic("ExprCallMathFunc: expected number of args %d != actual number %d",
4142 mathFuncPtr->numArgs, objc);
4143 result = TCL_ERROR;
4144 goto done;
4145 }
4146
4147 /*
4148 * Collect the arguments for the function, if there are any, into the
4149 * array "args". Note that args[0] will have the Tcl_Value that
4150 * corresponds to objv[1].
4151 */
4152
4153 for (j = 1, k = 0; j < objc; j++, k++) {
4154 valuePtr = objv[j];
4155
4156 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
4157 result = TCL_ERROR;
4158 goto done;
4159 }
4160
4161 /*
4162 * Copy the object's numeric value to the argument record,
4163 * converting it if necessary.
4164 */
4165
4166 if (valuePtr->typePtr == &tclIntType) {
4167 i = valuePtr->internalRep.longValue;
4168 if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
4169 args[k].type = TCL_DOUBLE;
4170 args[k].doubleValue = i;
4171 } else {
4172 args[k].type = TCL_INT;
4173 args[k].intValue = i;
4174 }
4175 } else {
4176 d = valuePtr->internalRep.doubleValue;
4177 if (mathFuncPtr->argTypes[k] == TCL_INT) {
4178 args[k].type = TCL_INT;
4179 args[k].intValue = (long) d;
4180 } else {
4181 args[k].type = TCL_DOUBLE;
4182 args[k].doubleValue = d;
4183 }
4184 }
4185 }
4186
4187 /*
4188 * Invoke the function and copy its result back into valuePtr.
4189 */
4190
4191 tsdPtr->mathInProgress++;
4192 result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
4193 &funcResult);
4194 tsdPtr->mathInProgress--;
4195 if (result != TCL_OK) {
4196 goto done;
4197 }
4198
4199 /*
4200 * Pop the objc top stack elements and decrement their ref counts.
4201 */
4202
4203 i = (stackTop - (objc-1));
4204 while (i <= stackTop) {
4205 valuePtr = stackPtr[i];
4206 Tcl_DecrRefCount(valuePtr);
4207 i++;
4208 }
4209 stackTop -= objc;
4210
4211 /*
4212 * Push the call's object result.
4213 */
4214
4215 if (funcResult.type == TCL_INT) {
4216 PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
4217 } else {
4218 d = funcResult.doubleValue;
4219 if (IS_NAN(d) || IS_INF(d)) {
4220 TclExprFloatError(interp, d);
4221 result = TCL_ERROR;
4222 goto done;
4223 }
4224 PUSH_OBJECT(Tcl_NewDoubleObj(d));
4225 }
4226
4227 /*
4228 * Reflect the change to stackTop back in eePtr.
4229 */
4230
4231 done:
4232 DECACHE_STACK_INFO();
4233 return result;
4234 }
4235
4236 /*
4237 *----------------------------------------------------------------------
4238 *
4239 * TclExprFloatError --
4240 *
4241 * This procedure is called when an error occurs during a
4242 * floating-point operation. It reads errno and sets
4243 * interp->objResultPtr accordingly.
4244 *
4245 * Results:
4246 * interp->objResultPtr is set to hold an error message.
4247 *
4248 * Side effects:
4249 * None.
4250 *
4251 *----------------------------------------------------------------------
4252 */
4253
4254 void
4255 TclExprFloatError(interp, value)
4256 Tcl_Interp *interp; /* Where to store error message. */
4257 double value; /* Value returned after error; used to
4258 * distinguish underflows from overflows. */
4259 {
4260 char *s;
4261
4262 Tcl_ResetResult(interp);
4263 if ((errno == EDOM) || (value != value)) {
4264 s = "domain error: argument not in valid range";
4265 Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4266 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
4267 } else if ((errno == ERANGE) || IS_INF(value)) {
4268 if (value == 0.0) {
4269 s = "floating-point value too small to represent";
4270 Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4271 Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
4272 } else {
4273 s = "floating-point value too large to represent";
4274 Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
4275 Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
4276 }
4277 } else {
4278 char msg[64 + TCL_INTEGER_SPACE];
4279
4280 sprintf(msg, "unknown floating-point error, errno = %d", errno);
4281 Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
4282 Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
4283 }
4284 }
4285
4286 /*
4287 *----------------------------------------------------------------------
4288 *
4289 * TclMathInProgress --
4290 *
4291 * This procedure is called to find out if Tcl is doing math
4292 * in this thread.
4293 *
4294 * Results:
4295 * 0 or 1.
4296 *
4297 * Side effects:
4298 * None.
4299 *
4300 *----------------------------------------------------------------------
4301 */
4302
4303 int
4304 TclMathInProgress()
4305 {
4306 ThreadSpecificData *tsdPtr = TCL_TSD_INIT(&dataKey);
4307 return tsdPtr->mathInProgress;
4308 }
4309
4310 #ifdef TCL_COMPILE_STATS
4311 /*
4312 *----------------------------------------------------------------------
4313 *
4314 * TclLog2 --
4315 *
4316 * Procedure used while collecting compilation statistics to determine
4317 * the log base 2 of an integer.
4318 *
4319 * Results:
4320 * Returns the log base 2 of the operand. If the argument is less
4321 * than or equal to zero, a zero is returned.
4322 *
4323 * Side effects:
4324 * None.
4325 *
4326 *----------------------------------------------------------------------
4327 */
4328
4329 int
4330 TclLog2(value)
4331 register int value; /* The integer for which to compute the
4332 * log base 2. */
4333 {
4334 register int n = value;
4335 register int result = 0;
4336
4337 while (n > 1) {
4338 n = n >> 1;
4339 result++;
4340 }
4341 return result;
4342 }
4343
4344 /*
4345 *----------------------------------------------------------------------
4346 *
4347 * EvalStatsCmd --
4348 *
4349 * Implements the "evalstats" command that prints instruction execution
4350 * counts to stdout.
4351 *
4352 * Results:
4353 * Standard Tcl results.
4354 *
4355 * Side effects:
4356 * None.
4357 *
4358 *----------------------------------------------------------------------
4359 */
4360
4361 static int
4362 EvalStatsCmd(unused, interp, argc, argv)
4363 ClientData unused; /* Unused. */
4364 Tcl_Interp *interp; /* The current interpreter. */
4365 int argc; /* The number of arguments. */
4366 char **argv; /* The argument strings. */
4367 {
4368 Interp *iPtr = (Interp *) interp;
4369 LiteralTable *globalTablePtr = &(iPtr->literalTable);
4370 ByteCodeStats *statsPtr = &(iPtr->stats);
4371 double totalCodeBytes, currentCodeBytes;
4372 double totalLiteralBytes, currentLiteralBytes;
4373 double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
4374 double strBytesSharedMultX, strBytesSharedOnce;
4375 double numInstructions, currentHeaderBytes;
4376 long numCurrentByteCodes, numByteCodeLits;
4377 long refCountSum, literalMgmtBytes, sum;
4378 int numSharedMultX, numSharedOnce;
4379 int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
4380 char *litTableStats;
4381 LiteralEntry *entryPtr;
4382
4383 numInstructions = 0.0;
4384 for (i = 0; i < 256; i++) {
4385 if (statsPtr->instructionCount[i] != 0) {
4386 numInstructions += statsPtr->instructionCount[i];
4387 }
4388 }
4389
4390 totalLiteralBytes = sizeof(LiteralTable)
4391 + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
4392 + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
4393 + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
4394 + statsPtr->totalLitStringBytes;
4395 totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
4396
4397 numCurrentByteCodes =
4398 statsPtr->numCompilations - statsPtr->numByteCodesFreed;
4399 currentHeaderBytes = numCurrentByteCodes
4400 * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
4401 literalMgmtBytes = sizeof(LiteralTable)
4402 + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
4403 + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
4404 currentLiteralBytes = literalMgmtBytes
4405 + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
4406 + statsPtr->currentLitStringBytes;
4407 currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
4408
4409 /*
4410 * Summary statistics, total and current source and ByteCode sizes.
4411 */
4412
4413 fprintf(stdout, "\n----------------------------------------------------------------\n");
4414 fprintf(stdout,
4415 "Compilation and execution statistics for interpreter 0x%x\n",
4416 (unsigned int) iPtr);
4417
4418 fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
4419 statsPtr->numExecutions);
4420 fprintf(stdout, "Number ByteCodes compiled %ld\n",
4421 statsPtr->numCompilations);
4422 fprintf(stdout, " Mean executions/compile %.1f\n",
4423 ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
4424
4425 fprintf(stdout, "\nInstructions executed %.0f\n",
4426 numInstructions);
4427 fprintf(stdout, " Mean inst/compile %.0f\n",
4428 numInstructions / statsPtr->numCompilations);
4429 fprintf(stdout, " Mean inst/execution %.0f\n",
4430 numInstructions / statsPtr->numExecutions);
4431
4432 fprintf(stdout, "\nTotal ByteCodes %ld\n",
4433 statsPtr->numCompilations);
4434 fprintf(stdout, " Source bytes %.6g\n",
4435 statsPtr->totalSrcBytes);
4436 fprintf(stdout, " Code bytes %.6g\n",
4437 totalCodeBytes);
4438 fprintf(stdout, " ByteCode bytes %.6g\n",
4439 statsPtr->totalByteCodeBytes);
4440 fprintf(stdout, " Literal bytes %.6g\n",
4441 totalLiteralBytes);
4442 fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
4443 sizeof(LiteralTable),
4444 iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4445 statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
4446 statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
4447 statsPtr->totalLitStringBytes);
4448 fprintf(stdout, " Mean code/compile %.1f\n",
4449 totalCodeBytes / statsPtr->numCompilations);
4450 fprintf(stdout, " Mean code/source %.1f\n",
4451 totalCodeBytes / statsPtr->totalSrcBytes);
4452
4453 fprintf(stdout, "\nCurrent ByteCodes %ld\n",
4454 numCurrentByteCodes);
4455 fprintf(stdout, " Source bytes %.6g\n",
4456 statsPtr->currentSrcBytes);
4457 fprintf(stdout, " Code bytes %.6g\n",
4458 currentCodeBytes);
4459 fprintf(stdout, " ByteCode bytes %.6g\n",
4460 statsPtr->currentByteCodeBytes);
4461 fprintf(stdout, " Literal bytes %.6g\n",
4462 currentLiteralBytes);
4463 fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
4464 sizeof(LiteralTable),
4465 iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4466 iPtr->literalTable.numEntries * sizeof(LiteralEntry),
4467 iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
4468 statsPtr->currentLitStringBytes);
4469 fprintf(stdout, " Mean code/source %.1f\n",
4470 currentCodeBytes / statsPtr->currentSrcBytes);
4471 fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
4472 (currentCodeBytes + statsPtr->currentSrcBytes),
4473 (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
4474
4475 /*
4476 * Literal table statistics.
4477 */
4478
4479 numByteCodeLits = 0;
4480 refCountSum = 0;
4481 numSharedMultX = 0;
4482 numSharedOnce = 0;
4483 objBytesIfUnshared = 0.0;
4484 strBytesIfUnshared = 0.0;
4485 strBytesSharedMultX = 0.0;
4486 strBytesSharedOnce = 0.0;
4487 for (i = 0; i < globalTablePtr->numBuckets; i++) {
4488 for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
4489 entryPtr = entryPtr->nextPtr) {
4490 if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
4491 numByteCodeLits++;
4492 }
4493 (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
4494 refCountSum += entryPtr->refCount;
4495 objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
4496 strBytesIfUnshared += (entryPtr->refCount * (length+1));
4497 if (entryPtr->refCount > 1) {
4498 numSharedMultX++;
4499 strBytesSharedMultX += (length+1);
4500 } else {
4501 numSharedOnce++;
4502 strBytesSharedOnce += (length+1);
4503 }
4504 }
4505 }
4506 sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
4507 - currentLiteralBytes;
4508
4509 fprintf(stdout, "\nTotal objects (all interps) %ld\n",
4510 tclObjsAlloced);
4511 fprintf(stdout, "Current objects %ld\n",
4512 (tclObjsAlloced - tclObjsFreed));
4513 fprintf(stdout, "Total literal objects %ld\n",
4514 statsPtr->numLiteralsCreated);
4515
4516 fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
4517 globalTablePtr->numEntries,
4518 (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
4519 fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
4520 numByteCodeLits,
4521 (numByteCodeLits * 100.0) / globalTablePtr->numEntries);
4522 fprintf(stdout, " Literals reused > 1x %d\n",
4523 numSharedMultX);
4524 fprintf(stdout, " Mean reference count %.2f\n",
4525 ((double) refCountSum) / globalTablePtr->numEntries);
4526 fprintf(stdout, " Mean len, str reused >1x %.2f\n",
4527 (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
4528 fprintf(stdout, " Mean len, str used 1x %.2f\n",
4529 (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
4530 fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
4531 sharingBytesSaved,
4532 (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
4533 fprintf(stdout, " Bytes with sharing %.6g\n",
4534 currentLiteralBytes);
4535 fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
4536 sizeof(LiteralTable),
4537 iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4538 iPtr->literalTable.numEntries * sizeof(LiteralEntry),
4539 iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
4540 statsPtr->currentLitStringBytes);
4541 fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
4542 (objBytesIfUnshared + strBytesIfUnshared),
4543 objBytesIfUnshared, strBytesIfUnshared);
4544 fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
4545 (strBytesIfUnshared - statsPtr->currentLitStringBytes),
4546 strBytesIfUnshared, statsPtr->currentLitStringBytes);
4547 fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
4548 literalMgmtBytes,
4549 (literalMgmtBytes * 100.0) / currentLiteralBytes);
4550 fprintf(stdout, " table %d + buckets %d + entries %d\n",
4551 sizeof(LiteralTable),
4552 iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
4553 iPtr->literalTable.numEntries * sizeof(LiteralEntry));
4554
4555 /*
4556 * Breakdown of current ByteCode space requirements.
4557 */
4558
4559 fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
4560 fprintf(stdout, " Bytes Pct of Avg per\n");
4561 fprintf(stdout, " total ByteCode\n");
4562 fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
4563 statsPtr->currentByteCodeBytes,
4564 statsPtr->currentByteCodeBytes / numCurrentByteCodes);
4565 fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
4566 currentHeaderBytes,
4567 ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
4568 currentHeaderBytes / numCurrentByteCodes);
4569 fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
4570 statsPtr->currentInstBytes,
4571 ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
4572 statsPtr->currentInstBytes / numCurrentByteCodes);
4573 fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
4574 statsPtr->currentLitBytes,
4575 ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
4576 statsPtr->currentLitBytes / numCurrentByteCodes);
4577 fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
4578 statsPtr->currentExceptBytes,
4579 ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
4580 statsPtr->currentExceptBytes / numCurrentByteCodes);
4581 fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
4582 statsPtr->currentAuxBytes,
4583 ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
4584 statsPtr->currentAuxBytes / numCurrentByteCodes);
4585 fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
4586 statsPtr->currentCmdMapBytes,
4587 ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
4588 statsPtr->currentCmdMapBytes / numCurrentByteCodes);
4589
4590 /*
4591 * Detailed literal statistics.
4592 */
4593
4594 fprintf(stdout, "\nLiteral string sizes:\n");
4595 fprintf(stdout, " Up to length Percentage\n");
4596 maxSizeDecade = 0;
4597 for (i = 31; i >= 0; i--) {
4598 if (statsPtr->literalCount[i] > 0) {
4599 maxSizeDecade = i;
4600 break;
4601 }
4602 }
4603 sum = 0;
4604 for (i = 0; i <= maxSizeDecade; i++) {
4605 decadeHigh = (1 << (i+1)) - 1;
4606 sum += statsPtr->literalCount[i];
4607 fprintf(stdout, " %10d %8.0f%%\n",
4608 decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
4609 }
4610
4611 litTableStats = TclLiteralStats(globalTablePtr);
4612 fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
4613 litTableStats);
4614 ckfree((char *) litTableStats);
4615
4616 /*
4617 * Source and ByteCode size distributions.
4618 */
4619
4620 fprintf(stdout, "\nSource sizes:\n");
4621 fprintf(stdout, " Up to size Percentage\n");
4622 minSizeDecade = maxSizeDecade = 0;
4623 for (i = 0; i < 31; i++) {
4624 if (statsPtr->srcCount[i] > 0) {
4625 minSizeDecade = i;
4626 break;
4627 }
4628 }
4629 for (i = 31; i >= 0; i--) {
4630 if (statsPtr->srcCount[i] > 0) {
4631 maxSizeDecade = i;
4632 break;
4633 }
4634 }
4635 sum = 0;
4636 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
4637 decadeHigh = (1 << (i+1)) - 1;
4638 sum += statsPtr->srcCount[i];
4639 fprintf(stdout, " %10d %8.0f%%\n",
4640 decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
4641 }
4642
4643 fprintf(stdout, "\nByteCode sizes:\n");
4644 fprintf(stdout, " Up to size Percentage\n");
4645 minSizeDecade = maxSizeDecade = 0;
4646 for (i = 0; i < 31; i++) {
4647 if (statsPtr->byteCodeCount[i] > 0) {
4648 minSizeDecade = i;
4649 break;
4650 }
4651 }
4652 for (i = 31; i >= 0; i--) {
4653 if (statsPtr->byteCodeCount[i] > 0) {
4654 maxSizeDecade = i;
4655 break;
4656 }
4657 }
4658 sum = 0;
4659 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
4660 decadeHigh = (1 << (i+1)) - 1;
4661 sum += statsPtr->byteCodeCount[i];
4662 fprintf(stdout, " %10d %8.0f%%\n",
4663 decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
4664 }
4665
4666 fprintf(stdout, "\nByteCode longevity (excludes current ByteCodes):\n");
4667 fprintf(stdout, " Up to ms Percentage\n");
4668 minSizeDecade = maxSizeDecade = 0;
4669 for (i = 0; i < 31; i++) {
4670 if (statsPtr->lifetimeCount[i] > 0) {
4671 minSizeDecade = i;
4672 break;
4673 }
4674 }
4675 for (i = 31; i >= 0; i--) {
4676 if (statsPtr->lifetimeCount[i] > 0) {
4677 maxSizeDecade = i;
4678 break;
4679 }
4680 }
4681 sum = 0;
4682 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
4683 decadeHigh = (1 << (i+1)) - 1;
4684 sum += statsPtr->lifetimeCount[i];
4685 fprintf(stdout, " %12.3f %8.0f%%\n",
4686 decadeHigh / 1000.0,
4687 (sum * 100.0) / statsPtr->numByteCodesFreed);
4688 }
4689
4690 /*
4691 * Instruction counts.
4692 */
4693
4694 fprintf(stdout, "\nInstruction counts:\n");
4695 for (i = 0; i <= LAST_INST_OPCODE; i++) {
4696 if (statsPtr->instructionCount[i]) {
4697 fprintf(stdout, "%20s %8ld %6.1f%%\n",
4698 instructionTable[i].name,
4699 statsPtr->instructionCount[i],
4700 (statsPtr->instructionCount[i]*100.0) / numInstructions);
4701 }
4702 }
4703
4704 fprintf(stdout, "\nInstructions NEVER executed:\n");
4705 for (i = 0; i <= LAST_INST_OPCODE; i++) {
4706 if (statsPtr->instructionCount[i] == 0) {
4707 fprintf(stdout, "%20s\n",
4708 instructionTable[i].name);
4709 }
4710 }
4711
4712 #ifdef TCL_MEM_DEBUG
4713 fprintf(stdout, "\nHeap Statistics:\n");
4714 TclDumpMemoryInfo(stdout);
4715 #endif
4716 fprintf(stdout, "\n----------------------------------------------------------------\n");
4717 return TCL_OK;
4718 }
4719 #endif /* TCL_COMPILE_STATS */
4720
4721 /*
4722 *----------------------------------------------------------------------
4723 *
4724 * Tcl_GetCommandFromObj --
4725 *
4726 * Returns the command specified by the name in a Tcl_Obj.
4727 *
4728 * Results:
4729 * Returns a token for the command if it is found. Otherwise, if it
4730 * can't be found or there is an error, returns NULL.
4731 *
4732 * Side effects:
4733 * May update the internal representation for the object, caching
4734 * the command reference so that the next time this procedure is
4735 * called with the same object, the command can be found quickly.
4736 *
4737 *----------------------------------------------------------------------
4738 */
4739
4740 Tcl_Command
4741 Tcl_GetCommandFromObj(interp, objPtr)
4742 Tcl_Interp *interp; /* The interpreter in which to resolve the
4743 * command and to report errors. */
4744 register Tcl_Obj *objPtr; /* The object containing the command's
4745 * name. If the name starts with "::", will
4746 * be looked up in global namespace. Else,
4747 * looked up first in the current namespace
4748 * if contextNsPtr is NULL, then in global
4749 * namespace. */
4750 {
4751 Interp *iPtr = (Interp *) interp;
4752 register ResolvedCmdName *resPtr;
4753 register Command *cmdPtr;
4754 Namespace *currNsPtr;
4755 int result;
4756
4757 /*
4758 * Get the internal representation, converting to a command type if
4759 * needed. The internal representation is a ResolvedCmdName that points
4760 * to the actual command.
4761 */
4762
4763 if (objPtr->typePtr != &tclCmdNameType) {
4764 result = tclCmdNameType.setFromAnyProc(interp, objPtr);
4765 if (result != TCL_OK) {
4766 return (Tcl_Command) NULL;
4767 }
4768 }
4769 resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4770
4771 /*
4772 * Get the current namespace.
4773 */
4774
4775 if (iPtr->varFramePtr != NULL) {
4776 currNsPtr = iPtr->varFramePtr->nsPtr;
4777 } else {
4778 currNsPtr = iPtr->globalNsPtr;
4779 }
4780
4781 /*
4782 * Check the context namespace and the namespace epoch of the resolved
4783 * symbol to make sure that it is fresh. If not, then force another
4784 * conversion to the command type, to discard the old rep and create a
4785 * new one. Note that we verify that the namespace id of the context
4786 * namespace is the same as the one we cached; this insures that the
4787 * namespace wasn't deleted and a new one created at the same address
4788 * with the same command epoch.
4789 */
4790
4791 cmdPtr = NULL;
4792 if ((resPtr != NULL)
4793 && (resPtr->refNsPtr == currNsPtr)
4794 && (resPtr->refNsId == currNsPtr->nsId)
4795 && (resPtr->refNsCmdEpoch == currNsPtr->cmdRefEpoch)) {
4796 cmdPtr = resPtr->cmdPtr;
4797 if (cmdPtr->cmdEpoch != resPtr->cmdEpoch) {
4798 cmdPtr = NULL;
4799 }
4800 }
4801
4802 if (cmdPtr == NULL) {
4803 result = tclCmdNameType.setFromAnyProc(interp, objPtr);
4804 if (result != TCL_OK) {
4805 return (Tcl_Command) NULL;
4806 }
4807 resPtr = (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4808 if (resPtr != NULL) {
4809 cmdPtr = resPtr->cmdPtr;
4810 }
4811 }
4812 return (Tcl_Command) cmdPtr;
4813 }
4814
4815 /*
4816 *----------------------------------------------------------------------
4817 *
4818 * TclSetCmdNameObj --
4819 *
4820 * Modify an object to be an CmdName object that refers to the argument
4821 * Command structure.
4822 *
4823 * Results:
4824 * None.
4825 *
4826 * Side effects:
4827 * The object's old internal rep is freed. It's string rep is not
4828 * changed. The refcount in the Command structure is incremented to
4829 * keep it from being freed if the command is later deleted until
4830 * TclExecuteByteCode has a chance to recognize that it was deleted.
4831 *
4832 *----------------------------------------------------------------------
4833 */
4834
4835 void
4836 TclSetCmdNameObj(interp, objPtr, cmdPtr)
4837 Tcl_Interp *interp; /* Points to interpreter containing command
4838 * that should be cached in objPtr. */
4839 register Tcl_Obj *objPtr; /* Points to Tcl object to be changed to
4840 * a CmdName object. */
4841 Command *cmdPtr; /* Points to Command structure that the
4842 * CmdName object should refer to. */
4843 {
4844 Interp *iPtr = (Interp *) interp;
4845 register ResolvedCmdName *resPtr;
4846 Tcl_ObjType *oldTypePtr = objPtr->typePtr;
4847 register Namespace *currNsPtr;
4848
4849 if (oldTypePtr == &tclCmdNameType) {
4850 return;
4851 }
4852
4853 /*
4854 * Get the current namespace.
4855 */
4856
4857 if (iPtr->varFramePtr != NULL) {
4858 currNsPtr = iPtr->varFramePtr->nsPtr;
4859 } else {
4860 currNsPtr = iPtr->globalNsPtr;
4861 }
4862
4863 cmdPtr->refCount++;
4864 resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
4865 resPtr->cmdPtr = cmdPtr;
4866 resPtr->refNsPtr = currNsPtr;
4867 resPtr->refNsId = currNsPtr->nsId;
4868 resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
4869 resPtr->cmdEpoch = cmdPtr->cmdEpoch;
4870 resPtr->refCount = 1;
4871
4872 if ((oldTypePtr != NULL) && (oldTypePtr->freeIntRepProc != NULL)) {
4873 oldTypePtr->freeIntRepProc(objPtr);
4874 }
4875 objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
4876 objPtr->internalRep.twoPtrValue.ptr2 = NULL;
4877 objPtr->typePtr = &tclCmdNameType;
4878 }
4879
4880 /*
4881 *----------------------------------------------------------------------
4882 *
4883 * FreeCmdNameInternalRep --
4884 *
4885 * Frees the resources associated with a cmdName object's internal
4886 * representation.
4887 *
4888 * Results:
4889 * None.
4890 *
4891 * Side effects:
4892 * Decrements the ref count of any cached ResolvedCmdName structure
4893 * pointed to by the cmdName's internal representation. If this is
4894 * the last use of the ResolvedCmdName, it is freed. This in turn
4895 * decrements the ref count of the Command structure pointed to by
4896 * the ResolvedSymbol, which may free the Command structure.
4897 *
4898 *----------------------------------------------------------------------
4899 */
4900
4901 static void
4902 FreeCmdNameInternalRep(objPtr)
4903 register Tcl_Obj *objPtr; /* CmdName object with internal
4904 * representation to free. */
4905 {
4906 register ResolvedCmdName *resPtr =
4907 (ResolvedCmdName *) objPtr->internalRep.otherValuePtr;
4908
4909 if (resPtr != NULL) {
4910 /*
4911 * Decrement the reference count of the ResolvedCmdName structure.
4912 * If there are no more uses, free the ResolvedCmdName structure.
4913 */
4914
4915 resPtr->refCount--;
4916 if (resPtr->refCount == 0) {
4917 /*
4918 * Now free the cached command, unless it is still in its
4919 * hash table or if there are other references to it
4920 * from other cmdName objects.
4921 */
4922
4923 Command *cmdPtr = resPtr->cmdPtr;
4924 TclCleanupCommand(cmdPtr);
4925 ckfree((char *) resPtr);
4926 }
4927 }
4928 }
4929
4930 /*
4931 *----------------------------------------------------------------------
4932 *
4933 * DupCmdNameInternalRep --
4934 *
4935 * Initialize the internal representation of an cmdName Tcl_Obj to a
4936 * copy of the internal representation of an existing cmdName object.
4937 *
4938 * Results:
4939 * None.
4940 *
4941 * Side effects:
4942 * "copyPtr"s internal rep is set to point to the ResolvedCmdName
4943 * structure corresponding to "srcPtr"s internal rep. Increments the
4944 * ref count of the ResolvedCmdName structure pointed to by the
4945 * cmdName's internal representation.
4946 *
4947 *----------------------------------------------------------------------
4948 */
4949
4950 static void
4951 DupCmdNameInternalRep(srcPtr, copyPtr)
4952 Tcl_Obj *srcPtr; /* Object with internal rep to copy. */
4953 register Tcl_Obj *copyPtr; /* Object with internal rep to set. */
4954 {
4955 register ResolvedCmdName *resPtr =
4956 (ResolvedCmdName *) srcPtr->internalRep.otherValuePtr;
4957
4958 copyPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
4959 copyPtr->internalRep.twoPtrValue.ptr2 = NULL;
4960 if (resPtr != NULL) {
4961 resPtr->refCount++;
4962 }
4963 copyPtr->typePtr = &tclCmdNameType;
4964 }
4965
4966 /*
4967 *----------------------------------------------------------------------
4968 *
4969 * SetCmdNameFromAny --
4970 *
4971 * Generate an cmdName internal form for the Tcl object "objPtr".
4972 *
4973 * Results:
4974 * The return value is a standard Tcl result. The conversion always
4975 * succeeds and TCL_OK is returned.
4976 *
4977 * Side effects:
4978 * A pointer to a ResolvedCmdName structure that holds a cached pointer
4979 * to the command with a name that matches objPtr's string rep is
4980 * stored as objPtr's internal representation. This ResolvedCmdName
4981 * pointer will be NULL if no matching command was found. The ref count
4982 * of the cached Command's structure (if any) is also incremented.
4983 *
4984 *----------------------------------------------------------------------
4985 */
4986
4987 static int
4988 SetCmdNameFromAny(interp, objPtr)
4989 Tcl_Interp *interp; /* Used for error reporting if not NULL. */
4990 register Tcl_Obj *objPtr; /* The object to convert. */
4991 {
4992 Interp *iPtr = (Interp *) interp;
4993 char *name;
4994 Tcl_Command cmd;
4995 register Command *cmdPtr;
4996 Namespace *currNsPtr;
4997 register ResolvedCmdName *resPtr;
4998
4999 /*
5000 * Get "objPtr"s string representation. Make it up-to-date if necessary.
5001 */
5002
5003 name = objPtr->bytes;
5004 if (name == NULL) {
5005 name = Tcl_GetString(objPtr);
5006 }
5007
5008 /*
5009 * Find the Command structure, if any, that describes the command called
5010 * "name". Build a ResolvedCmdName that holds a cached pointer to this
5011 * Command, and bump the reference count in the referenced Command
5012 * structure. A Command structure will not be deleted as long as it is
5013 * referenced from a CmdName object.
5014 */
5015
5016 cmd = Tcl_FindCommand(interp, name, (Tcl_Namespace *) NULL,
5017 /*flags*/ 0);
5018 cmdPtr = (Command *) cmd;
5019 if (cmdPtr != NULL) {
5020 /*
5021 * Get the current namespace.
5022 */
5023
5024 if (iPtr->varFramePtr != NULL) {
5025 currNsPtr = iPtr->varFramePtr->nsPtr;
5026 } else {
5027 currNsPtr = iPtr->globalNsPtr;
5028 }
5029
5030 cmdPtr->refCount++;
5031 resPtr = (ResolvedCmdName *) ckalloc(sizeof(ResolvedCmdName));
5032 resPtr->cmdPtr = cmdPtr;
5033 resPtr->refNsPtr = currNsPtr;
5034 resPtr->refNsId = currNsPtr->nsId;
5035 resPtr->refNsCmdEpoch = currNsPtr->cmdRefEpoch;
5036 resPtr->cmdEpoch = cmdPtr->cmdEpoch;
5037 resPtr->refCount = 1;
5038 } else {
5039 resPtr = NULL; /* no command named "name" was found */
5040 }
5041
5042 /*
5043 * Free the old internalRep before setting the new one. We do this as
5044 * late as possible to allow the conversion code, in particular
5045 * GetStringFromObj, to use that old internalRep. If no Command
5046 * structure was found, leave NULL as the cached value.
5047 */
5048
5049 if ((objPtr->typePtr != NULL)
5050 && (objPtr->typePtr->freeIntRepProc != NULL)) {
5051 objPtr->typePtr->freeIntRepProc(objPtr);
5052 }
5053
5054 objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) resPtr;
5055 objPtr->internalRep.twoPtrValue.ptr2 = NULL;
5056 objPtr->typePtr = &tclCmdNameType;
5057 return TCL_OK;
5058 }
5059
5060 #ifdef TCL_COMPILE_DEBUG
5061 /*
5062 *----------------------------------------------------------------------
5063 *
5064 * StringForResultCode --
5065 *
5066 * Procedure that returns a human-readable string representing a
5067 * Tcl result code such as TCL_ERROR.
5068 *
5069 * Results:
5070 * If the result code is one of the standard Tcl return codes, the
5071 * result is a string representing that code such as "TCL_ERROR".
5072 * Otherwise, the result string is that code formatted as a
5073 * sequence of decimal digit characters. Note that the resulting
5074 * string must not be modified by the caller.
5075 *
5076 * Side effects:
5077 * None.
5078 *
5079 *----------------------------------------------------------------------
5080 */
5081
5082 static char *
5083 StringForResultCode(result)
5084 int result; /* The Tcl result code for which to
5085 * generate a string. */
5086 {
5087 static char buf[TCL_INTEGER_SPACE];
5088
5089 if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
5090 return resultStrings[result];
5091 }
5092 TclFormatInt(buf, result);
5093 return buf;
5094 }
5095 #endif /* TCL_COMPILE_DEBUG */
5096
5097 /* End of tclexecute.c */

Properties

Name Value
svn:keywords Header
dashley@gmail.com
 ViewVC Help
Powered by ViewVC 1.1.25