Fork me on GitHub

source: git/external/tcl/tclExecute.c@ 9867b49

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

remove debug code from Tcl

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