Fork me on GitHub

source: git/external/tcl/tclExecute.c@ 989ee8f

ImprovedOutputFile Timing dual_readout llp
Last change on this file since 989ee8f was d7d2da3, checked in by pavel <pavel@…>, 12 years ago

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