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

dashley@gmail.com
ViewVC Help
Powered by ViewVC 1.1.25