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 * Copyright (c) 1998-2000 by Scriptics Corporation.
9 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
10 *
11 * See the file "license.terms" for information on usage and redistribution
12 * of this file, and for a DISCLAIMER OF ALL WARRANTIES.
13 *
14 * RCS: @(#) $Id: tclExecute.c,v 1.94.2.5 2003/09/19 18:43:00 msofer Exp $
15 */
16
17 #include "tclInt.h"
18 #include "tclCompile.h"
19
20 #ifndef TCL_NO_MATH
21 # include "tclMath.h"
22 #endif
23
24 /*
25 * The stuff below is a bit of a hack so that this file can be used
26 * in environments that include no UNIX, i.e. no errno. Just define
27 * errno here.
28 */
29
30 #ifndef TCL_GENERIC_ONLY
31 # include "tclPort.h"
32 #else /* TCL_GENERIC_ONLY */
33 # ifndef NO_FLOAT_H
34 # include <float.h>
35 # else /* NO_FLOAT_H */
36 # ifndef NO_VALUES_H
37 # include <values.h>
38 # endif /* !NO_VALUES_H */
39 # endif /* !NO_FLOAT_H */
40 # define NO_ERRNO_H
41 #endif /* !TCL_GENERIC_ONLY */
42
43 #ifdef NO_ERRNO_H
44 int errno;
45 # define EDOM 33
46 # define ERANGE 34
47 #endif
48
49 /*
50 * Need DBL_MAX for IS_INF() macro...
51 */
52 #ifndef DBL_MAX
53 # ifdef MAXDOUBLE
54 # define DBL_MAX MAXDOUBLE
55 # else /* !MAXDOUBLE */
56 /*
57 * This value is from the Solaris headers, but doubles seem to be the
58 * same size everywhere. Long doubles aren't, but we don't use those.
59 */
60 # define DBL_MAX 1.79769313486231570e+308
61 # endif /* MAXDOUBLE */
62 #endif /* !DBL_MAX */
63
64 /*
65 * Boolean flag indicating whether the Tcl bytecode interpreter has been
66 * initialized.
67 */
68
69 static int execInitialized = 0;
70 TCL_DECLARE_MUTEX(execMutex)
71
72 #ifdef TCL_COMPILE_DEBUG
73 /*
74 * Variable that controls whether execution tracing is enabled and, if so,
75 * what level of tracing is desired:
76 * 0: no execution tracing
77 * 1: trace invocations of Tcl procs only
78 * 2: trace invocations of all (not compiled away) commands
79 * 3: display each instruction executed
80 * This variable is linked to the Tcl variable "tcl_traceExec".
81 */
82
83 int tclTraceExec = 0;
84 #endif
85
86 /*
87 * Mapping from expression instruction opcodes to strings; used for error
88 * messages. Note that these entries must match the order and number of the
89 * expression opcodes (e.g., INST_LOR) in tclCompile.h.
90 */
91
92 static char *operatorStrings[] = {
93 "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
94 "+", "-", "*", "/", "%", "+", "-", "~", "!",
95 "BUILTIN FUNCTION", "FUNCTION",
96 "", "", "", "", "", "", "", "", "eq", "ne",
97 };
98
99 /*
100 * Mapping from Tcl result codes to strings; used for error and debugging
101 * messages.
102 */
103
104 #ifdef TCL_COMPILE_DEBUG
105 static char *resultStrings[] = {
106 "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
107 };
108 #endif
109
110 /*
111 * These are used by evalstats to monitor object usage in Tcl.
112 */
113
114 #ifdef TCL_COMPILE_STATS
115 long tclObjsAlloced = 0;
116 long tclObjsFreed = 0;
117 #define TCL_MAX_SHARED_OBJ_STATS 5
118 long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
119 #endif /* TCL_COMPILE_STATS */
120
121 /*
122 * Macros for testing floating-point values for certain special cases. Test
123 * for not-a-number by comparing a value against itself; test for infinity
124 * by comparing against the largest floating-point value.
125 */
126
127 #define IS_NAN(v) ((v) != (v))
128 #define IS_INF(v) (((v) > DBL_MAX) || ((v) < -DBL_MAX))
129
130 /*
131 * The new macro for ending an instruction; note that a
132 * reasonable C-optimiser will resolve all branches
133 * at compile time. (result) is always a constant; the macro
134 * NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is
135 * resolved at runtime for variable (nCleanup).
136 *
137 * ARGUMENTS:
138 * pcAdjustment: how much to increment pc
139 * nCleanup: how many objects to remove from the stack
140 * result: 0 indicates no object should be pushed on the
141 * stack; otherwise, push objResultPtr. If (result < 0),
142 * objResultPtr already has the correct reference count.
143 */
144
145 #define NEXT_INST_F(pcAdjustment, nCleanup, result) \
146 if (nCleanup == 0) {\
147 if (result != 0) {\
148 if ((result) > 0) {\
149 PUSH_OBJECT(objResultPtr);\
150 } else {\
151 stackPtr[++stackTop] = objResultPtr;\
152 }\
153 } \
154 pc += (pcAdjustment);\
155 goto cleanup0;\
156 } else if (result != 0) {\
157 if ((result) > 0) {\
158 Tcl_IncrRefCount(objResultPtr);\
159 }\
160 pc += (pcAdjustment);\
161 switch (nCleanup) {\
162 case 1: goto cleanup1_pushObjResultPtr;\
163 case 2: goto cleanup2_pushObjResultPtr;\
164 default: panic("ERROR: bad usage of macro NEXT_INST_F");\
165 }\
166 } else {\
167 pc += (pcAdjustment);\
168 switch (nCleanup) {\
169 case 1: goto cleanup1;\
170 case 2: goto cleanup2;\
171 default: panic("ERROR: bad usage of macro NEXT_INST_F");\
172 }\
173 }
174
175 #define NEXT_INST_V(pcAdjustment, nCleanup, result) \
176 pc += (pcAdjustment);\
177 cleanup = (nCleanup);\
178 if (result) {\
179 if ((result) > 0) {\
180 Tcl_IncrRefCount(objResultPtr);\
181 }\
182 goto cleanupV_pushObjResultPtr;\
183 } else {\
184 goto cleanupV;\
185 }
186
187
188 /*
189 * Macros used to cache often-referenced Tcl evaluation stack information
190 * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
191 * pair must surround any call inside TclExecuteByteCode (and a few other
192 * procedures that use this scheme) that could result in a recursive call
193 * to TclExecuteByteCode.
194 */
195
196 #define CACHE_STACK_INFO() \
197 stackPtr = eePtr->stackPtr; \
198 stackTop = eePtr->stackTop
199
200 #define DECACHE_STACK_INFO() \
201 eePtr->stackTop = stackTop
202
203
204 /*
205 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
206 * increments the object's ref count since it makes the stack have another
207 * reference pointing to the object. However, POP_OBJECT does not decrement
208 * the ref count. This is because the stack may hold the only reference to
209 * the object, so the object would be destroyed if its ref count were
210 * decremented before the caller had a chance to, e.g., store it in a
211 * variable. It is the caller's responsibility to decrement the ref count
212 * when it is finished with an object.
213 *
214 * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
215 * macro. The actual parameter might be an expression with side effects,
216 * and this ensures that it will be executed only once.
217 */
218
219 #define PUSH_OBJECT(objPtr) \
220 Tcl_IncrRefCount(stackPtr[++stackTop] = (objPtr))
221
222 #define POP_OBJECT() \
223 (stackPtr[stackTop--])
224
225 /*
226 * Macros used to trace instruction execution. The macros TRACE,
227 * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode.
228 * O2S is only used in TRACE* calls to get a string from an object.
229 */
230
231 #ifdef TCL_COMPILE_DEBUG
232 # define TRACE(a) \
233 if (traceInstructions) { \
234 fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
235 (unsigned int)(pc - codePtr->codeStart), \
236 GetOpcodeName(pc)); \
237 printf a; \
238 }
239 # define TRACE_APPEND(a) \
240 if (traceInstructions) { \
241 printf a; \
242 }
243 # define TRACE_WITH_OBJ(a, objPtr) \
244 if (traceInstructions) { \
245 fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, stackTop, \
246 (unsigned int)(pc - codePtr->codeStart), \
247 GetOpcodeName(pc)); \
248 printf a; \
249 TclPrintObject(stdout, objPtr, 30); \
250 fprintf(stdout, "\n"); \
251 }
252 # define O2S(objPtr) \
253 (objPtr ? TclGetString(objPtr) : "")
254 #else /* !TCL_COMPILE_DEBUG */
255 # define TRACE(a)
256 # define TRACE_APPEND(a)
257 # define TRACE_WITH_OBJ(a, objPtr)
258 # define O2S(objPtr)
259 #endif /* TCL_COMPILE_DEBUG */
260
261 /*
262 * Macro to read a string containing either a wide or an int and
263 * decide which it is while decoding it at the same time. This
264 * enforces the policy that integer constants between LONG_MIN and
265 * LONG_MAX (inclusive) are represented by normal longs, and integer
266 * constants outside that range are represented by wide ints.
267 *
268 * GET_WIDE_OR_INT is the same as REQUIRE_WIDE_OR_INT except it never
269 * generates an error message.
270 */
271 #define REQUIRE_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
272 (resultVar) = Tcl_GetWideIntFromObj(interp, (objPtr), &(wideVar)); \
273 if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
274 && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
275 (objPtr)->typePtr = &tclIntType; \
276 (objPtr)->internalRep.longValue = (longVar) \
277 = Tcl_WideAsLong(wideVar); \
278 }
279 #define GET_WIDE_OR_INT(resultVar, objPtr, longVar, wideVar) \
280 (resultVar) = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, (objPtr), \
281 &(wideVar)); \
282 if ((resultVar) == TCL_OK && (wideVar) >= Tcl_LongAsWide(LONG_MIN) \
283 && (wideVar) <= Tcl_LongAsWide(LONG_MAX)) { \
284 (objPtr)->typePtr = &tclIntType; \
285 (objPtr)->internalRep.longValue = (longVar) \
286 = Tcl_WideAsLong(wideVar); \
287 }
288 /*
289 * Combined with REQUIRE_WIDE_OR_INT, this gets a long value from
290 * an obj.
291 */
292 #define FORCE_LONG(objPtr, longVar, wideVar) \
293 if ((objPtr)->typePtr == &tclWideIntType) { \
294 (longVar) = Tcl_WideAsLong(wideVar); \
295 }
296 #define IS_INTEGER_TYPE(typePtr) \
297 ((typePtr) == &tclIntType || (typePtr) == &tclWideIntType)
298 #define IS_NUMERIC_TYPE(typePtr) \
299 (IS_INTEGER_TYPE(typePtr) || (typePtr) == &tclDoubleType)
300
301 #define W0 Tcl_LongAsWide(0)
302 /*
303 * For tracing that uses wide values.
304 */
305 #define LLD "%" TCL_LL_MODIFIER "d"
306
307 #ifndef TCL_WIDE_INT_IS_LONG
308 /*
309 * Extract a double value from a general numeric object.
310 */
311 #define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
312 if ((typePtr) == &tclIntType) { \
313 (doubleVar) = (double) (objPtr)->internalRep.longValue; \
314 } else if ((typePtr) == &tclWideIntType) { \
315 (doubleVar) = Tcl_WideAsDouble((objPtr)->internalRep.wideValue);\
316 } else { \
317 (doubleVar) = (objPtr)->internalRep.doubleValue; \
318 }
319 #else /* TCL_WIDE_INT_IS_LONG */
320 #define GET_DOUBLE_VALUE(doubleVar, objPtr, typePtr) \
321 if (((typePtr) == &tclIntType) || ((typePtr) == &tclWideIntType)) { \
322 (doubleVar) = (double) (objPtr)->internalRep.longValue; \
323 } else { \
324 (doubleVar) = (objPtr)->internalRep.doubleValue; \
325 }
326 #endif /* TCL_WIDE_INT_IS_LONG */
327
328 /*
329 * Declarations for local procedures to this file:
330 */
331
332 static int TclExecuteByteCode _ANSI_ARGS_((Tcl_Interp *interp,
333 ByteCode *codePtr));
334 static int ExprAbsFunc _ANSI_ARGS_((Tcl_Interp *interp,
335 ExecEnv *eePtr, ClientData clientData));
336 static int ExprBinaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
337 ExecEnv *eePtr, ClientData clientData));
338 static int ExprCallMathFunc _ANSI_ARGS_((Tcl_Interp *interp,
339 ExecEnv *eePtr, int objc, Tcl_Obj **objv));
340 static int ExprDoubleFunc _ANSI_ARGS_((Tcl_Interp *interp,
341 ExecEnv *eePtr, ClientData clientData));
342 static int ExprIntFunc _ANSI_ARGS_((Tcl_Interp *interp,
343 ExecEnv *eePtr, ClientData clientData));
344 static int ExprRandFunc _ANSI_ARGS_((Tcl_Interp *interp,
345 ExecEnv *eePtr, ClientData clientData));
346 static int ExprRoundFunc _ANSI_ARGS_((Tcl_Interp *interp,
347 ExecEnv *eePtr, ClientData clientData));
348 static int ExprSrandFunc _ANSI_ARGS_((Tcl_Interp *interp,
349 ExecEnv *eePtr, ClientData clientData));
350 static int ExprUnaryFunc _ANSI_ARGS_((Tcl_Interp *interp,
351 ExecEnv *eePtr, ClientData clientData));
352 static int ExprWideFunc _ANSI_ARGS_((Tcl_Interp *interp,
353 ExecEnv *eePtr, ClientData clientData));
354 #ifdef TCL_COMPILE_STATS
355 static int EvalStatsCmd _ANSI_ARGS_((ClientData clientData,
356 Tcl_Interp *interp, int objc,
357 Tcl_Obj *CONST objv[]));
358 #endif /* TCL_COMPILE_STATS */
359 #ifdef TCL_COMPILE_DEBUG
360 static char * GetOpcodeName _ANSI_ARGS_((unsigned char *pc));
361 #endif /* TCL_COMPILE_DEBUG */
362 static ExceptionRange * GetExceptRangeForPc _ANSI_ARGS_((unsigned char *pc,
363 int catchOnly, ByteCode* codePtr));
364 static char * GetSrcInfoForPc _ANSI_ARGS_((unsigned char *pc,
365 ByteCode* codePtr, int *lengthPtr));
366 static void GrowEvaluationStack _ANSI_ARGS_((ExecEnv *eePtr));
367 static void IllegalExprOperandType _ANSI_ARGS_((
368 Tcl_Interp *interp, unsigned char *pc,
369 Tcl_Obj *opndPtr));
370 static void InitByteCodeExecution _ANSI_ARGS_((
371 Tcl_Interp *interp));
372 #ifdef TCL_COMPILE_DEBUG
373 static void PrintByteCodeInfo _ANSI_ARGS_((ByteCode *codePtr));
374 static char * StringForResultCode _ANSI_ARGS_((int result));
375 static void ValidatePcAndStackTop _ANSI_ARGS_((
376 ByteCode *codePtr, unsigned char *pc,
377 int stackTop, int stackLowerBound));
378 #endif /* TCL_COMPILE_DEBUG */
379 static int VerifyExprObjType _ANSI_ARGS_((Tcl_Interp *interp,
380 Tcl_Obj *objPtr));
381
382 /*
383 * Table describing the built-in math functions. Entries in this table are
384 * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
385 * operand byte.
386 */
387
388 BuiltinFunc tclBuiltinFuncTable[] = {
389 #ifndef TCL_NO_MATH
390 {"acos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) acos},
391 {"asin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) asin},
392 {"atan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) atan},
393 {"atan2", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) atan2},
394 {"ceil", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) ceil},
395 {"cos", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cos},
396 {"cosh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) cosh},
397 {"exp", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) exp},
398 {"floor", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) floor},
399 {"fmod", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) fmod},
400 {"hypot", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) hypot},
401 {"log", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log},
402 {"log10", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) log10},
403 {"pow", 2, {TCL_DOUBLE, TCL_DOUBLE}, ExprBinaryFunc, (ClientData) pow},
404 {"sin", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sin},
405 {"sinh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sinh},
406 {"sqrt", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) sqrt},
407 {"tan", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tan},
408 {"tanh", 1, {TCL_DOUBLE}, ExprUnaryFunc, (ClientData) tanh},
409 #endif
410 {"abs", 1, {TCL_EITHER}, ExprAbsFunc, 0},
411 {"double", 1, {TCL_EITHER}, ExprDoubleFunc, 0},
412 {"int", 1, {TCL_EITHER}, ExprIntFunc, 0},
413 {"rand", 0, {TCL_EITHER}, ExprRandFunc, 0}, /* NOTE: rand takes no args. */
414 {"round", 1, {TCL_EITHER}, ExprRoundFunc, 0},
415 {"srand", 1, {TCL_INT}, ExprSrandFunc, 0},
416 {"wide", 1, {TCL_EITHER}, ExprWideFunc, 0},
417 {0},
418 };
419
420 /*
421 *----------------------------------------------------------------------
422 *
423 * InitByteCodeExecution --
424 *
425 * This procedure is called once to initialize the Tcl bytecode
426 * interpreter.
427 *
428 * Results:
429 * None.
430 *
431 * Side effects:
432 * This procedure initializes the array of instruction names. If
433 * compiling with the TCL_COMPILE_STATS flag, it initializes the
434 * array that counts the executions of each instruction and it
435 * creates the "evalstats" command. It also establishes the link
436 * between the Tcl "tcl_traceExec" and C "tclTraceExec" variables.
437 *
438 *----------------------------------------------------------------------
439 */
440
441 static void
InitByteCodeExecution(interp)442 InitByteCodeExecution(interp)
443 Tcl_Interp *interp; /* Interpreter for which the Tcl variable
444 * "tcl_traceExec" is linked to control
445 * instruction tracing. */
446 {
447 #ifdef TCL_COMPILE_DEBUG
448 if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
449 TCL_LINK_INT) != TCL_OK) {
450 panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
451 }
452 #endif
453 #ifdef TCL_COMPILE_STATS
454 Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd,
455 (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL);
456 #endif /* TCL_COMPILE_STATS */
457 }
458
459 /*
460 *----------------------------------------------------------------------
461 *
462 * TclCreateExecEnv --
463 *
464 * This procedure creates a new execution environment for Tcl bytecode
465 * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv
466 * is typically created once for each Tcl interpreter (Interp
467 * structure) and recursively passed to TclExecuteByteCode to execute
468 * ByteCode sequences for nested commands.
469 *
470 * Results:
471 * A newly allocated ExecEnv is returned. This points to an empty
472 * evaluation stack of the standard initial size.
473 *
474 * Side effects:
475 * The bytecode interpreter is also initialized here, as this
476 * procedure will be called before any call to TclExecuteByteCode.
477 *
478 *----------------------------------------------------------------------
479 */
480
481 #define TCL_STACK_INITIAL_SIZE 2000
482
483 ExecEnv *
TclCreateExecEnv(interp)484 TclCreateExecEnv(interp)
485 Tcl_Interp *interp; /* Interpreter for which the execution
486 * environment is being created. */
487 {
488 ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
489 Tcl_Obj **stackPtr;
490
491 stackPtr = (Tcl_Obj **)
492 ckalloc((size_t) (TCL_STACK_INITIAL_SIZE * sizeof(Tcl_Obj *)));
493
494 /*
495 * Use the bottom pointer to keep a reference count; the
496 * execution environment holds a reference.
497 */
498
499 stackPtr++;
500 eePtr->stackPtr = stackPtr;
501 stackPtr[-1] = (Tcl_Obj *) ((char *) 1);
502
503 eePtr->stackTop = -1;
504 eePtr->stackEnd = (TCL_STACK_INITIAL_SIZE - 2);
505
506 eePtr->errorInfo = Tcl_NewStringObj("::errorInfo", -1);
507 Tcl_IncrRefCount(eePtr->errorInfo);
508
509 eePtr->errorCode = Tcl_NewStringObj("::errorCode", -1);
510 Tcl_IncrRefCount(eePtr->errorCode);
511
512 Tcl_MutexLock(&execMutex);
513 if (!execInitialized) {
514 TclInitAuxDataTypeTable();
515 InitByteCodeExecution(interp);
516 execInitialized = 1;
517 }
518 Tcl_MutexUnlock(&execMutex);
519
520 return eePtr;
521 }
522 #undef TCL_STACK_INITIAL_SIZE
523
524 /*
525 *----------------------------------------------------------------------
526 *
527 * TclDeleteExecEnv --
528 *
529 * Frees the storage for an ExecEnv.
530 *
531 * Results:
532 * None.
533 *
534 * Side effects:
535 * Storage for an ExecEnv and its contained storage (e.g. the
536 * evaluation stack) is freed.
537 *
538 *----------------------------------------------------------------------
539 */
540
541 void
TclDeleteExecEnv(eePtr)542 TclDeleteExecEnv(eePtr)
543 ExecEnv *eePtr; /* Execution environment to free. */
544 {
545 if (eePtr->stackPtr[-1] == (Tcl_Obj *) ((char *) 1)) {
546 ckfree((char *) (eePtr->stackPtr-1));
547 } else {
548 panic("ERROR: freeing an execEnv whose stack is still in use.\n");
549 }
550 TclDecrRefCount(eePtr->errorInfo);
551 TclDecrRefCount(eePtr->errorCode);
552 ckfree((char *) eePtr);
553 }
554
555 /*
556 *----------------------------------------------------------------------
557 *
558 * TclFinalizeExecution --
559 *
560 * Finalizes the execution environment setup so that it can be
561 * later reinitialized.
562 *
563 * Results:
564 * None.
565 *
566 * Side effects:
567 * After this call, the next time TclCreateExecEnv will be called
568 * it will call InitByteCodeExecution.
569 *
570 *----------------------------------------------------------------------
571 */
572
573 void
TclFinalizeExecution()574 TclFinalizeExecution()
575 {
576 Tcl_MutexLock(&execMutex);
577 execInitialized = 0;
578 Tcl_MutexUnlock(&execMutex);
579 TclFinalizeAuxDataTypeTable();
580 }
581
582 /*
583 *----------------------------------------------------------------------
584 *
585 * GrowEvaluationStack --
586 *
587 * This procedure grows a Tcl evaluation stack stored in an ExecEnv.
588 *
589 * Results:
590 * None.
591 *
592 * Side effects:
593 * The size of the evaluation stack is doubled.
594 *
595 *----------------------------------------------------------------------
596 */
597
598 static void
GrowEvaluationStack(eePtr)599 GrowEvaluationStack(eePtr)
600 register ExecEnv *eePtr; /* Points to the ExecEnv with an evaluation
601 * stack to enlarge. */
602 {
603 /*
604 * The current Tcl stack elements are stored from eePtr->stackPtr[0]
605 * to eePtr->stackPtr[eePtr->stackEnd] (inclusive).
606 */
607
608 int currElems = (eePtr->stackEnd + 1);
609 int newElems = 2*currElems;
610 int currBytes = currElems * sizeof(Tcl_Obj *);
611 int newBytes = 2*currBytes;
612 Tcl_Obj **newStackPtr = (Tcl_Obj **) ckalloc((unsigned) newBytes);
613 Tcl_Obj **oldStackPtr = eePtr->stackPtr;
614
615 /*
616 * We keep the stack reference count as a (char *), as that
617 * works nicely as a portable pointer-sized counter.
618 */
619
620 char *refCount = (char *) oldStackPtr[-1];
621
622 /*
623 * Copy the existing stack items to the new stack space, free the old
624 * storage if appropriate, and record the refCount of the new stack
625 * held by the environment.
626 */
627
628 newStackPtr++;
629 memcpy((VOID *) newStackPtr, (VOID *) oldStackPtr,
630 (size_t) currBytes);
631
632 if (refCount == (char *) 1) {
633 ckfree((VOID *) (oldStackPtr-1));
634 } else {
635 /*
636 * Remove the reference corresponding to the
637 * environment pointer.
638 */
639
640 oldStackPtr[-1] = (Tcl_Obj *) (refCount-1);
641 }
642
643 eePtr->stackPtr = newStackPtr;
644 eePtr->stackEnd = (newElems - 2); /* index of last usable item */
645 newStackPtr[-1] = (Tcl_Obj *) ((char *) 1);
646 }
647
648 /*
649 *--------------------------------------------------------------
650 *
651 * Tcl_ExprObj --
652 *
653 * Evaluate an expression in a Tcl_Obj.
654 *
655 * Results:
656 * A standard Tcl object result. If the result is other than TCL_OK,
657 * then the interpreter's result contains an error message. If the
658 * result is TCL_OK, then a pointer to the expression's result value
659 * object is stored in resultPtrPtr. In that case, the object's ref
660 * count is incremented to reflect the reference returned to the
661 * caller; the caller is then responsible for the resulting object
662 * and must, for example, decrement the ref count when it is finished
663 * with the object.
664 *
665 * Side effects:
666 * Any side effects caused by subcommands in the expression, if any.
667 * The interpreter result is not modified unless there is an error.
668 *
669 *--------------------------------------------------------------
670 */
671
672 int
Tcl_ExprObj(interp,objPtr,resultPtrPtr)673 Tcl_ExprObj(interp, objPtr, resultPtrPtr)
674 Tcl_Interp *interp; /* Context in which to evaluate the
675 * expression. */
676 register Tcl_Obj *objPtr; /* Points to Tcl object containing
677 * expression to evaluate. */
678 Tcl_Obj **resultPtrPtr; /* Where the Tcl_Obj* that is the expression
679 * result is stored if no errors occur. */
680 {
681 Interp *iPtr = (Interp *) interp;
682 CompileEnv compEnv; /* Compilation environment structure
683 * allocated in frame. */
684 LiteralTable *localTablePtr = &(compEnv.localLitTable);
685 register ByteCode *codePtr = NULL;
686 /* Tcl Internal type of bytecode.
687 * Initialized to avoid compiler warning. */
688 AuxData *auxDataPtr;
689 LiteralEntry *entryPtr;
690 Tcl_Obj *saveObjPtr;
691 char *string;
692 int length, i, result;
693
694 /*
695 * First handle some common expressions specially.
696 */
697
698 string = Tcl_GetStringFromObj(objPtr, &length);
699 if (length == 1) {
700 if (*string == '0') {
701 *resultPtrPtr = Tcl_NewLongObj(0);
702 Tcl_IncrRefCount(*resultPtrPtr);
703 return TCL_OK;
704 } else if (*string == '1') {
705 *resultPtrPtr = Tcl_NewLongObj(1);
706 Tcl_IncrRefCount(*resultPtrPtr);
707 return TCL_OK;
708 }
709 } else if ((length == 2) && (*string == '!')) {
710 if (*(string+1) == '0') {
711 *resultPtrPtr = Tcl_NewLongObj(1);
712 Tcl_IncrRefCount(*resultPtrPtr);
713 return TCL_OK;
714 } else if (*(string+1) == '1') {
715 *resultPtrPtr = Tcl_NewLongObj(0);
716 Tcl_IncrRefCount(*resultPtrPtr);
717 return TCL_OK;
718 }
719 }
720
721 /*
722 * Get the ByteCode from the object. If it exists, make sure it hasn't
723 * been invalidated by, e.g., someone redefining a command with a
724 * compile procedure (this might make the compiled code wrong). If
725 * necessary, convert the object to be a ByteCode object and compile it.
726 * Also, if the code was compiled in/for a different interpreter, we
727 * recompile it.
728 *
729 * Precompiled expressions, however, are immutable and therefore
730 * they are not recompiled, even if the epoch has changed.
731 *
732 */
733
734 if (objPtr->typePtr == &tclByteCodeType) {
735 codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
736 if (((Interp *) *codePtr->interpHandle != iPtr)
737 || (codePtr->compileEpoch != iPtr->compileEpoch)) {
738 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
739 if ((Interp *) *codePtr->interpHandle != iPtr) {
740 panic("Tcl_ExprObj: compiled expression jumped interps");
741 }
742 codePtr->compileEpoch = iPtr->compileEpoch;
743 } else {
744 (*tclByteCodeType.freeIntRepProc)(objPtr);
745 objPtr->typePtr = (Tcl_ObjType *) NULL;
746 }
747 }
748 }
749 if (objPtr->typePtr != &tclByteCodeType) {
750 TclInitCompileEnv(interp, &compEnv, string, length);
751 result = TclCompileExpr(interp, string, length, &compEnv);
752
753 /*
754 * Free the compilation environment's literal table bucket array if
755 * it was dynamically allocated.
756 */
757
758 if (localTablePtr->buckets != localTablePtr->staticBuckets) {
759 ckfree((char *) localTablePtr->buckets);
760 }
761
762 if (result != TCL_OK) {
763 /*
764 * Compilation errors. Free storage allocated for compilation.
765 */
766
767 #ifdef TCL_COMPILE_DEBUG
768 TclVerifyLocalLiteralTable(&compEnv);
769 #endif /*TCL_COMPILE_DEBUG*/
770 entryPtr = compEnv.literalArrayPtr;
771 for (i = 0; i < compEnv.literalArrayNext; i++) {
772 TclReleaseLiteral(interp, entryPtr->objPtr);
773 entryPtr++;
774 }
775 #ifdef TCL_COMPILE_DEBUG
776 TclVerifyGlobalLiteralTable(iPtr);
777 #endif /*TCL_COMPILE_DEBUG*/
778
779 auxDataPtr = compEnv.auxDataArrayPtr;
780 for (i = 0; i < compEnv.auxDataArrayNext; i++) {
781 if (auxDataPtr->type->freeProc != NULL) {
782 auxDataPtr->type->freeProc(auxDataPtr->clientData);
783 }
784 auxDataPtr++;
785 }
786 TclFreeCompileEnv(&compEnv);
787 return result;
788 }
789
790 /*
791 * Successful compilation. If the expression yielded no
792 * instructions, push an zero object as the expression's result.
793 */
794
795 if (compEnv.codeNext == compEnv.codeStart) {
796 TclEmitPush(TclRegisterLiteral(&compEnv, "0", 1, /*onHeap*/ 0),
797 &compEnv);
798 }
799
800 /*
801 * Add a "done" instruction as the last instruction and change the
802 * object into a ByteCode object. Ownership of the literal objects
803 * and aux data items is given to the ByteCode object.
804 */
805
806 compEnv.numSrcBytes = iPtr->termOffset;
807 TclEmitOpcode(INST_DONE, &compEnv);
808 TclInitByteCodeObj(objPtr, &compEnv);
809 TclFreeCompileEnv(&compEnv);
810 codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
811 #ifdef TCL_COMPILE_DEBUG
812 if (tclTraceCompile == 2) {
813 TclPrintByteCodeObj(interp, objPtr);
814 }
815 #endif /* TCL_COMPILE_DEBUG */
816 }
817
818 /*
819 * Execute the expression after first saving the interpreter's result.
820 */
821
822 saveObjPtr = Tcl_GetObjResult(interp);
823 Tcl_IncrRefCount(saveObjPtr);
824 Tcl_ResetResult(interp);
825
826 /*
827 * Increment the code's ref count while it is being executed. If
828 * afterwards no references to it remain, free the code.
829 */
830
831 codePtr->refCount++;
832 result = TclExecuteByteCode(interp, codePtr);
833 codePtr->refCount--;
834 if (codePtr->refCount <= 0) {
835 TclCleanupByteCode(codePtr);
836 objPtr->typePtr = NULL;
837 objPtr->internalRep.otherValuePtr = NULL;
838 }
839
840 /*
841 * If the expression evaluated successfully, store a pointer to its
842 * value object in resultPtrPtr then restore the old interpreter result.
843 * We increment the object's ref count to reflect the reference that we
844 * are returning to the caller. We also decrement the ref count of the
845 * interpreter's result object after calling Tcl_SetResult since we
846 * next store into that field directly.
847 */
848
849 if (result == TCL_OK) {
850 *resultPtrPtr = iPtr->objResultPtr;
851 Tcl_IncrRefCount(iPtr->objResultPtr);
852
853 Tcl_SetObjResult(interp, saveObjPtr);
854 }
855 TclDecrRefCount(saveObjPtr);
856 return result;
857 }
858
859 /*
860 *----------------------------------------------------------------------
861 *
862 * TclCompEvalObj --
863 *
864 * This procedure evaluates the script contained in a Tcl_Obj by
865 * first compiling it and then passing it to TclExecuteByteCode.
866 *
867 * Results:
868 * The return value is one of the return codes defined in tcl.h
869 * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
870 * that either contains the result of executing the code or an
871 * error message.
872 *
873 * Side effects:
874 * Almost certainly, depending on the ByteCode's instructions.
875 *
876 *----------------------------------------------------------------------
877 */
878
879 int
TclCompEvalObj(interp,objPtr)880 TclCompEvalObj(interp, objPtr)
881 Tcl_Interp *interp;
882 Tcl_Obj *objPtr;
883 {
884 register Interp *iPtr = (Interp *) interp;
885 register ByteCode* codePtr; /* Tcl Internal type of bytecode. */
886 int oldCount = iPtr->cmdCount; /* Used to tell whether any commands
887 * at all were executed. */
888 char *script;
889 int numSrcBytes;
890 int result;
891 Namespace *namespacePtr;
892
893
894 /*
895 * Check that the interpreter is ready to execute scripts
896 */
897
898 iPtr->numLevels++;
899 if (TclInterpReady(interp) == TCL_ERROR) {
900 iPtr->numLevels--;
901 return TCL_ERROR;
902 }
903
904 if (iPtr->varFramePtr != NULL) {
905 namespacePtr = iPtr->varFramePtr->nsPtr;
906 } else {
907 namespacePtr = iPtr->globalNsPtr;
908 }
909
910 /*
911 * If the object is not already of tclByteCodeType, compile it (and
912 * reset the compilation flags in the interpreter; this should be
913 * done after any compilation).
914 * Otherwise, check that it is "fresh" enough.
915 */
916
917 if (objPtr->typePtr != &tclByteCodeType) {
918 recompileObj:
919 iPtr->errorLine = 1;
920 result = tclByteCodeType.setFromAnyProc(interp, objPtr);
921 if (result != TCL_OK) {
922 iPtr->numLevels--;
923 return result;
924 }
925 iPtr->evalFlags = 0;
926 codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
927 } else {
928 /*
929 * Make sure the Bytecode hasn't been invalidated by, e.g., someone
930 * redefining a command with a compile procedure (this might make the
931 * compiled code wrong).
932 * The object needs to be recompiled if it was compiled in/for a
933 * different interpreter, or for a different namespace, or for the
934 * same namespace but with different name resolution rules.
935 * Precompiled objects, however, are immutable and therefore
936 * they are not recompiled, even if the epoch has changed.
937 *
938 * To be pedantically correct, we should also check that the
939 * originating procPtr is the same as the current context procPtr
940 * (assuming one exists at all - none for global level). This
941 * code is #def'ed out because [info body] was changed to never
942 * return a bytecode type object, which should obviate us from
943 * the extra checks here.
944 */
945 codePtr = (ByteCode *) objPtr->internalRep.otherValuePtr;
946 if (((Interp *) *codePtr->interpHandle != iPtr)
947 || (codePtr->compileEpoch != iPtr->compileEpoch)
948 #ifdef CHECK_PROC_ORIGINATION /* [Bug: 3412 Pedantic] */
949 || (codePtr->procPtr != NULL && !(iPtr->varFramePtr &&
950 iPtr->varFramePtr->procPtr == codePtr->procPtr))
951 #endif
952 || (codePtr->nsPtr != namespacePtr)
953 || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
954 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
955 if ((Interp *) *codePtr->interpHandle != iPtr) {
956 panic("Tcl_EvalObj: compiled script jumped interps");
957 }
958 codePtr->compileEpoch = iPtr->compileEpoch;
959 } else {
960 /*
961 * This byteCode is invalid: free it and recompile
962 */
963 tclByteCodeType.freeIntRepProc(objPtr);
964 goto recompileObj;
965 }
966 }
967 }
968
969 /*
970 * Execute the commands. If the code was compiled from an empty string,
971 * don't bother executing the code.
972 */
973
974 numSrcBytes = codePtr->numSrcBytes;
975 if ((numSrcBytes > 0) || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
976 /*
977 * Increment the code's ref count while it is being executed. If
978 * afterwards no references to it remain, free the code.
979 */
980
981 codePtr->refCount++;
982 result = TclExecuteByteCode(interp, codePtr);
983 codePtr->refCount--;
984 if (codePtr->refCount <= 0) {
985 TclCleanupByteCode(codePtr);
986 }
987 } else {
988 result = TCL_OK;
989 }
990 iPtr->numLevels--;
991
992
993 /*
994 * If no commands at all were executed, check for asynchronous
995 * handlers so that they at least get one change to execute.
996 * This is needed to handle event loops written in Tcl with
997 * empty bodies.
998 */
999
1000 if ((oldCount == iPtr->cmdCount) && Tcl_AsyncReady()) {
1001 result = Tcl_AsyncInvoke(interp, result);
1002
1003
1004 /*
1005 * If an error occurred, record information about what was being
1006 * executed when the error occurred.
1007 */
1008
1009 if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
1010 script = Tcl_GetStringFromObj(objPtr, &numSrcBytes);
1011 Tcl_LogCommandInfo(interp, script, script, numSrcBytes);
1012 }
1013 }
1014
1015 /*
1016 * Set the interpreter's termOffset member to the offset of the
1017 * character just after the last one executed. We approximate the offset
1018 * of the last character executed by using the number of characters
1019 * compiled.
1020 */
1021
1022 iPtr->termOffset = numSrcBytes;
1023 iPtr->flags &= ~ERR_ALREADY_LOGGED;
1024
1025 return result;
1026 }
1027
1028 /*
1029 *----------------------------------------------------------------------
1030 *
1031 * TclExecuteByteCode --
1032 *
1033 * This procedure executes the instructions of a ByteCode structure.
1034 * It returns when a "done" instruction is executed or an error occurs.
1035 *
1036 * Results:
1037 * The return value is one of the return codes defined in tcl.h
1038 * (such as TCL_OK), and interp->objResultPtr refers to a Tcl object
1039 * that either contains the result of executing the code or an
1040 * error message.
1041 *
1042 * Side effects:
1043 * Almost certainly, depending on the ByteCode's instructions.
1044 *
1045 *----------------------------------------------------------------------
1046 */
1047
1048 static int
TclExecuteByteCode(interp,codePtr)1049 TclExecuteByteCode(interp, codePtr)
1050 Tcl_Interp *interp; /* Token for command interpreter. */
1051 ByteCode *codePtr; /* The bytecode sequence to interpret. */
1052 {
1053 Interp *iPtr = (Interp *) interp;
1054 ExecEnv *eePtr = iPtr->execEnvPtr;
1055 /* Points to the execution environment. */
1056 register Tcl_Obj **stackPtr = eePtr->stackPtr;
1057 /* Cached evaluation stack base pointer. */
1058 register int stackTop = eePtr->stackTop;
1059 /* Cached top index of evaluation stack. */
1060 register unsigned char *pc = codePtr->codeStart;
1061 /* The current program counter. */
1062 int opnd; /* Current instruction's operand byte(s). */
1063 int pcAdjustment; /* Hold pc adjustment after instruction. */
1064 int initStackTop = stackTop;/* Stack top at start of execution. */
1065 ExceptionRange *rangePtr; /* Points to closest loop or catch exception
1066 * range enclosing the pc. Used by various
1067 * instructions and processCatch to
1068 * process break, continue, and errors. */
1069 int result = TCL_OK; /* Return code returned after execution. */
1070 int storeFlags;
1071 Tcl_Obj *valuePtr, *value2Ptr, *objPtr;
1072 char *bytes;
1073 int length;
1074 long i = 0; /* Init. avoids compiler warning. */
1075 Tcl_WideInt w;
1076 register int cleanup;
1077 Tcl_Obj *objResultPtr;
1078 char *part1, *part2;
1079 Var *varPtr, *arrayPtr;
1080 CallFrame *varFramePtr = iPtr->varFramePtr;
1081 #ifdef TCL_COMPILE_DEBUG
1082 int traceInstructions = (tclTraceExec == 3);
1083 char cmdNameBuf[21];
1084 #endif
1085
1086 /*
1087 * This procedure uses a stack to hold information about catch commands.
1088 * This information is the current operand stack top when starting to
1089 * execute the code for each catch command. It starts out with stack-
1090 * allocated space but uses dynamically-allocated storage if needed.
1091 */
1092
1093 #define STATIC_CATCH_STACK_SIZE 4
1094 int (catchStackStorage[STATIC_CATCH_STACK_SIZE]);
1095 int *catchStackPtr = catchStackStorage;
1096 int catchTop = -1;
1097
1098 #ifdef TCL_COMPILE_DEBUG
1099 if (tclTraceExec >= 2) {
1100 PrintByteCodeInfo(codePtr);
1101 fprintf(stdout, " Starting stack top=%d\n", eePtr->stackTop);
1102 fflush(stdout);
1103 }
1104 opnd = 0; /* Init. avoids compiler warning. */
1105 #endif
1106
1107 #ifdef TCL_COMPILE_STATS
1108 iPtr->stats.numExecutions++;
1109 #endif
1110
1111 /*
1112 * Make sure the catch stack is large enough to hold the maximum number
1113 * of catch commands that could ever be executing at the same time. This
1114 * will be no more than the exception range array's depth.
1115 */
1116
1117 if (codePtr->maxExceptDepth > STATIC_CATCH_STACK_SIZE) {
1118 catchStackPtr = (int *)
1119 ckalloc(codePtr->maxExceptDepth * sizeof(int));
1120 }
1121
1122 /*
1123 * Make sure the stack has enough room to execute this ByteCode.
1124 */
1125
1126 while ((stackTop + codePtr->maxStackDepth) > eePtr->stackEnd) {
1127 GrowEvaluationStack(eePtr);
1128 stackPtr = eePtr->stackPtr;
1129 }
1130
1131 /*
1132 * Loop executing instructions until a "done" instruction, a
1133 * TCL_RETURN, or some error.
1134 */
1135
1136 goto cleanup0;
1137
1138
1139 /*
1140 * Targets for standard instruction endings; unrolled
1141 * for speed in the most frequent cases (instructions that
1142 * consume up to two stack elements).
1143 *
1144 * This used to be a "for(;;)" loop, with each instruction doing
1145 * its own cleanup.
1146 */
1147
1148 cleanupV_pushObjResultPtr:
1149 switch (cleanup) {
1150 case 0:
1151 stackPtr[++stackTop] = (objResultPtr);
1152 goto cleanup0;
1153 default:
1154 cleanup -= 2;
1155 while (cleanup--) {
1156 valuePtr = POP_OBJECT();
1157 TclDecrRefCount(valuePtr);
1158 }
1159 case 2:
1160 cleanup2_pushObjResultPtr:
1161 valuePtr = POP_OBJECT();
1162 TclDecrRefCount(valuePtr);
1163 case 1:
1164 cleanup1_pushObjResultPtr:
1165 valuePtr = stackPtr[stackTop];
1166 TclDecrRefCount(valuePtr);
1167 }
1168 stackPtr[stackTop] = objResultPtr;
1169 goto cleanup0;
1170
1171 cleanupV:
1172 switch (cleanup) {
1173 default:
1174 cleanup -= 2;
1175 while (cleanup--) {
1176 valuePtr = POP_OBJECT();
1177 TclDecrRefCount(valuePtr);
1178 }
1179 case 2:
1180 cleanup2:
1181 valuePtr = POP_OBJECT();
1182 TclDecrRefCount(valuePtr);
1183 case 1:
1184 cleanup1:
1185 valuePtr = POP_OBJECT();
1186 TclDecrRefCount(valuePtr);
1187 case 0:
1188 /*
1189 * We really want to do nothing now, but this is needed
1190 * for some compilers (SunPro CC)
1191 */
1192 break;
1193 }
1194
1195 cleanup0:
1196
1197 #ifdef TCL_COMPILE_DEBUG
1198 ValidatePcAndStackTop(codePtr, pc, stackTop, initStackTop);
1199 if (traceInstructions) {
1200 fprintf(stdout, "%2d: %2d ", iPtr->numLevels, stackTop);
1201 TclPrintInstruction(codePtr, pc);
1202 fflush(stdout);
1203 }
1204 #endif /* TCL_COMPILE_DEBUG */
1205
1206 #ifdef TCL_COMPILE_STATS
1207 iPtr->stats.instructionCount[*pc]++;
1208 #endif
1209 switch (*pc) {
1210 case INST_DONE:
1211 if (stackTop <= initStackTop) {
1212 stackTop--;
1213 goto abnormalReturn;
1214 }
1215
1216 /*
1217 * Set the interpreter's object result to point to the
1218 * topmost object from the stack, and check for a possible
1219 * [catch]. The stackTop's level and refCount will be handled
1220 * by "processCatch" or "abnormalReturn".
1221 */
1222
1223 valuePtr = stackPtr[stackTop];
1224 Tcl_SetObjResult(interp, valuePtr);
1225 #ifdef TCL_COMPILE_DEBUG
1226 TRACE_WITH_OBJ(("=> return code=%d, result=", result),
1227 iPtr->objResultPtr);
1228 if (traceInstructions) {
1229 fprintf(stdout, "\n");
1230 }
1231 #endif
1232 goto checkForCatch;
1233
1234 case INST_PUSH1:
1235 objResultPtr = codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)];
1236 TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), objResultPtr);
1237 NEXT_INST_F(2, 0, 1);
1238
1239 case INST_PUSH4:
1240 objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
1241 TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
1242 NEXT_INST_F(5, 0, 1);
1243
1244 case INST_POP:
1245 TRACE_WITH_OBJ(("=> discarding "), stackPtr[stackTop]);
1246 valuePtr = POP_OBJECT();
1247 TclDecrRefCount(valuePtr);
1248 NEXT_INST_F(1, 0, 0);
1249
1250 case INST_DUP:
1251 objResultPtr = stackPtr[stackTop];
1252 TRACE_WITH_OBJ(("=> "), objResultPtr);
1253 NEXT_INST_F(1, 0, 1);
1254
1255 case INST_OVER:
1256 opnd = TclGetUInt4AtPtr( pc+1 );
1257 objResultPtr = stackPtr[ stackTop - opnd ];
1258 TRACE_WITH_OBJ(("=> "), objResultPtr);
1259 NEXT_INST_F(5, 0, 1);
1260
1261 case INST_CONCAT1:
1262 opnd = TclGetUInt1AtPtr(pc+1);
1263 {
1264 int totalLen = 0;
1265
1266 /*
1267 * Concatenate strings (with no separators) from the top
1268 * opnd items on the stack starting with the deepest item.
1269 * First, determine how many characters are needed.
1270 */
1271
1272 for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
1273 bytes = Tcl_GetStringFromObj(stackPtr[i], &length);
1274 if (bytes != NULL) {
1275 totalLen += length;
1276 }
1277 }
1278
1279 /*
1280 * Initialize the new append string object by appending the
1281 * strings of the opnd stack objects. Also pop the objects.
1282 */
1283
1284 TclNewObj(objResultPtr);
1285 if (totalLen > 0) {
1286 char *p = (char *) ckalloc((unsigned) (totalLen + 1));
1287 objResultPtr->bytes = p;
1288 objResultPtr->length = totalLen;
1289 for (i = (stackTop - (opnd-1)); i <= stackTop; i++) {
1290 valuePtr = stackPtr[i];
1291 bytes = Tcl_GetStringFromObj(valuePtr, &length);
1292 if (bytes != NULL) {
1293 memcpy((VOID *) p, (VOID *) bytes,
1294 (size_t) length);
1295 p += length;
1296 }
1297 }
1298 *p = '\0';
1299 }
1300
1301 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
1302 NEXT_INST_V(2, opnd, 1);
1303 }
1304
1305 case INST_INVOKE_STK4:
1306 opnd = TclGetUInt4AtPtr(pc+1);
1307 pcAdjustment = 5;
1308 goto doInvocation;
1309
1310 case INST_INVOKE_STK1:
1311 opnd = TclGetUInt1AtPtr(pc+1);
1312 pcAdjustment = 2;
1313
1314 doInvocation:
1315 {
1316 int objc = opnd; /* The number of arguments. */
1317 Tcl_Obj **objv; /* The array of argument objects. */
1318
1319 /*
1320 * We keep the stack reference count as a (char *), as that
1321 * works nicely as a portable pointer-sized counter.
1322 */
1323
1324 char **preservedStackRefCountPtr;
1325
1326 /*
1327 * Reference to memory block containing
1328 * objv array (must be kept live throughout
1329 * trace and command invokations.)
1330 */
1331
1332 objv = &(stackPtr[stackTop - (objc-1)]);
1333
1334 #ifdef TCL_COMPILE_DEBUG
1335 if (tclTraceExec >= 2) {
1336 if (traceInstructions) {
1337 strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
1338 TRACE(("%u => call ", objc));
1339 } else {
1340 fprintf(stdout, "%d: (%u) invoking ",
1341 iPtr->numLevels,
1342 (unsigned int)(pc - codePtr->codeStart));
1343 }
1344 for (i = 0; i < objc; i++) {
1345 TclPrintObject(stdout, objv[i], 15);
1346 fprintf(stdout, " ");
1347 }
1348 fprintf(stdout, "\n");
1349 fflush(stdout);
1350 }
1351 #endif /*TCL_COMPILE_DEBUG*/
1352
1353 /*
1354 * If trace procedures will be called, we need a
1355 * command string to pass to TclEvalObjvInternal; note
1356 * that a copy of the string will be made there to
1357 * include the ending \0.
1358 */
1359
1360 bytes = NULL;
1361 length = 0;
1362 if (iPtr->tracePtr != NULL) {
1363 Trace *tracePtr, *nextTracePtr;
1364
1365 for (tracePtr = iPtr->tracePtr; tracePtr != NULL;
1366 tracePtr = nextTracePtr) {
1367 nextTracePtr = tracePtr->nextPtr;
1368 if (tracePtr->level == 0 ||
1369 iPtr->numLevels <= tracePtr->level) {
1370 /*
1371 * Traces will be called: get command string
1372 */
1373
1374 bytes = GetSrcInfoForPc(pc, codePtr, &length);
1375 break;
1376 }
1377 }
1378 } else {
1379 Command *cmdPtr;
1380 cmdPtr = (Command *) Tcl_GetCommandFromObj(interp, objv[0]);
1381 if ((cmdPtr != NULL) && (cmdPtr->flags & CMD_HAS_EXEC_TRACES)) {
1382 bytes = GetSrcInfoForPc(pc, codePtr, &length);
1383 }
1384 }
1385
1386 /*
1387 * A reference to part of the stack vector itself
1388 * escapes our control: increase its refCount
1389 * to stop it from being deallocated by a recursive
1390 * call to ourselves. The extra variable is needed
1391 * because all others are liable to change due to the
1392 * trace procedures.
1393 */
1394
1395 preservedStackRefCountPtr = (char **) (stackPtr-1);
1396 ++*preservedStackRefCountPtr;
1397
1398 /*
1399 * Finally, let TclEvalObjvInternal handle the command.
1400 */
1401
1402 DECACHE_STACK_INFO();
1403 Tcl_ResetResult(interp);
1404 result = TclEvalObjvInternal(interp, objc, objv, bytes, length, 0);
1405 CACHE_STACK_INFO();
1406
1407 /*
1408 * If the old stack is going to be released, it is
1409 * safe to do so now, since no references to objv are
1410 * going to be used from now on.
1411 */
1412
1413 --*preservedStackRefCountPtr;
1414 if (*preservedStackRefCountPtr == (char *) 0) {
1415 ckfree((VOID *) preservedStackRefCountPtr);
1416 }
1417
1418 if (result == TCL_OK) {
1419 /*
1420 * Push the call's object result and continue execution
1421 * with the next instruction.
1422 */
1423
1424 TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
1425 objc, cmdNameBuf), Tcl_GetObjResult(interp));
1426
1427 objResultPtr = Tcl_GetObjResult(interp);
1428
1429 /*
1430 * Reset the interp's result to avoid possible duplications
1431 * of large objects [Bug 781585]. We do not call
1432 * Tcl_ResetResult() to avoid any side effects caused by
1433 * the resetting of errorInfo and errorCode [Bug 804681],
1434 * which are not needed here. We chose instead to manipulate
1435 * the interp's object result directly.
1436 *
1437 * Note that the result object is now in objResultPtr, it
1438 * keeps the refCount it had in its role of iPtr->objResultPtr.
1439 */
1440 {
1441 Tcl_Obj *newObjResultPtr;
1442 TclNewObj(newObjResultPtr);
1443 Tcl_IncrRefCount(newObjResultPtr);
1444 iPtr->objResultPtr = newObjResultPtr;
1445 }
1446
1447 NEXT_INST_V(pcAdjustment, opnd, -1);
1448 } else {
1449 cleanup = opnd;
1450 goto processExceptionReturn;
1451 }
1452 }
1453
1454 case INST_EVAL_STK:
1455 /*
1456 * Note to maintainers: it is important that INST_EVAL_STK
1457 * pop its argument from the stack before jumping to
1458 * checkForCatch! DO NOT OPTIMISE!
1459 */
1460
1461 objPtr = stackPtr[stackTop];
1462 DECACHE_STACK_INFO();
1463 result = TclCompEvalObj(interp, objPtr);
1464 CACHE_STACK_INFO();
1465 if (result == TCL_OK) {
1466 /*
1467 * Normal return; push the eval's object result.
1468 */
1469
1470 objResultPtr = Tcl_GetObjResult(interp);
1471 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
1472 Tcl_GetObjResult(interp));
1473
1474 /*
1475 * Reset the interp's result to avoid possible duplications
1476 * of large objects [Bug 781585]. We do not call
1477 * Tcl_ResetResult() to avoid any side effects caused by
1478 * the resetting of errorInfo and errorCode [Bug 804681],
1479 * which are not needed here. We chose instead to manipulate
1480 * the interp's object result directly.
1481 *
1482 * Note that the result object is now in objResultPtr, it
1483 * keeps the refCount it had in its role of iPtr->objResultPtr.
1484 */
1485 {
1486 Tcl_Obj *newObjResultPtr;
1487 TclNewObj(newObjResultPtr);
1488 Tcl_IncrRefCount(newObjResultPtr);
1489 iPtr->objResultPtr = newObjResultPtr;
1490 }
1491
1492 NEXT_INST_F(1, 1, -1);
1493 } else {
1494 cleanup = 1;
1495 goto processExceptionReturn;
1496 }
1497
1498 case INST_EXPR_STK:
1499 objPtr = stackPtr[stackTop];
1500 DECACHE_STACK_INFO();
1501 Tcl_ResetResult(interp);
1502 result = Tcl_ExprObj(interp, objPtr, &valuePtr);
1503 CACHE_STACK_INFO();
1504 if (result != TCL_OK) {
1505 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ",
1506 O2S(objPtr)), Tcl_GetObjResult(interp));
1507 goto checkForCatch;
1508 }
1509 objResultPtr = valuePtr;
1510 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
1511 NEXT_INST_F(1, 1, -1); /* already has right refct */
1512
1513 /*
1514 * ---------------------------------------------------------
1515 * Start of INST_LOAD instructions.
1516 *
1517 * WARNING: more 'goto' here than your doctor recommended!
1518 * The different instructions set the value of some variables
1519 * and then jump to somme common execution code.
1520 */
1521
1522 case INST_LOAD_SCALAR1:
1523 opnd = TclGetUInt1AtPtr(pc+1);
1524 varPtr = &(varFramePtr->compiledLocals[opnd]);
1525 part1 = varPtr->name;
1526 while (TclIsVarLink(varPtr)) {
1527 varPtr = varPtr->value.linkPtr;
1528 }
1529 TRACE(("%u => ", opnd));
1530 if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
1531 && (varPtr->tracePtr == NULL)) {
1532 /*
1533 * No errors, no traces: just get the value.
1534 */
1535 objResultPtr = varPtr->value.objPtr;
1536 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1537 NEXT_INST_F(2, 0, 1);
1538 }
1539 pcAdjustment = 2;
1540 cleanup = 0;
1541 arrayPtr = NULL;
1542 part2 = NULL;
1543 goto doCallPtrGetVar;
1544
1545 case INST_LOAD_SCALAR4:
1546 opnd = TclGetUInt4AtPtr(pc+1);
1547 varPtr = &(varFramePtr->compiledLocals[opnd]);
1548 part1 = varPtr->name;
1549 while (TclIsVarLink(varPtr)) {
1550 varPtr = varPtr->value.linkPtr;
1551 }
1552 TRACE(("%u => ", opnd));
1553 if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
1554 && (varPtr->tracePtr == NULL)) {
1555 /*
1556 * No errors, no traces: just get the value.
1557 */
1558 objResultPtr = varPtr->value.objPtr;
1559 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1560 NEXT_INST_F(5, 0, 1);
1561 }
1562 pcAdjustment = 5;
1563 cleanup = 0;
1564 arrayPtr = NULL;
1565 part2 = NULL;
1566 goto doCallPtrGetVar;
1567
1568 case INST_LOAD_ARRAY_STK:
1569 cleanup = 2;
1570 part2 = Tcl_GetString(stackPtr[stackTop]); /* element name */
1571 objPtr = stackPtr[stackTop-1]; /* array name */
1572 TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), part2));
1573 goto doLoadStk;
1574
1575 case INST_LOAD_STK:
1576 case INST_LOAD_SCALAR_STK:
1577 cleanup = 1;
1578 part2 = NULL;
1579 objPtr = stackPtr[stackTop]; /* variable name */
1580 TRACE(("\"%.30s\" => ", O2S(objPtr)));
1581
1582 doLoadStk:
1583 part1 = TclGetString(objPtr);
1584 varPtr = TclObjLookupVar(interp, objPtr, part2,
1585 TCL_LEAVE_ERR_MSG, "read",
1586 /*createPart1*/ 0,
1587 /*createPart2*/ 1, &arrayPtr);
1588 if (varPtr == NULL) {
1589 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1590 result = TCL_ERROR;
1591 goto checkForCatch;
1592 }
1593 if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
1594 && (varPtr->tracePtr == NULL)
1595 && ((arrayPtr == NULL)
1596 || (arrayPtr->tracePtr == NULL))) {
1597 /*
1598 * No errors, no traces: just get the value.
1599 */
1600 objResultPtr = varPtr->value.objPtr;
1601 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1602 NEXT_INST_V(1, cleanup, 1);
1603 }
1604 pcAdjustment = 1;
1605 goto doCallPtrGetVar;
1606
1607 case INST_LOAD_ARRAY4:
1608 opnd = TclGetUInt4AtPtr(pc+1);
1609 pcAdjustment = 5;
1610 goto doLoadArray;
1611
1612 case INST_LOAD_ARRAY1:
1613 opnd = TclGetUInt1AtPtr(pc+1);
1614 pcAdjustment = 2;
1615
1616 doLoadArray:
1617 part2 = TclGetString(stackPtr[stackTop]);
1618 arrayPtr = &(varFramePtr->compiledLocals[opnd]);
1619 part1 = arrayPtr->name;
1620 while (TclIsVarLink(arrayPtr)) {
1621 arrayPtr = arrayPtr->value.linkPtr;
1622 }
1623 TRACE(("%u \"%.30s\" => ", opnd, part2));
1624 varPtr = TclLookupArrayElement(interp, part1, part2,
1625 TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
1626 if (varPtr == NULL) {
1627 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1628 result = TCL_ERROR;
1629 goto checkForCatch;
1630 }
1631 if (TclIsVarScalar(varPtr) && !TclIsVarUndefined(varPtr)
1632 && (varPtr->tracePtr == NULL)
1633 && ((arrayPtr == NULL)
1634 || (arrayPtr->tracePtr == NULL))) {
1635 /*
1636 * No errors, no traces: just get the value.
1637 */
1638 objResultPtr = varPtr->value.objPtr;
1639 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1640 NEXT_INST_F(pcAdjustment, 1, 1);
1641 }
1642 cleanup = 1;
1643 goto doCallPtrGetVar;
1644
1645 doCallPtrGetVar:
1646 /*
1647 * There are either errors or the variable is traced:
1648 * call TclPtrGetVar to process fully.
1649 */
1650
1651 DECACHE_STACK_INFO();
1652 objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr, part1,
1653 part2, TCL_LEAVE_ERR_MSG);
1654 CACHE_STACK_INFO();
1655 if (objResultPtr == NULL) {
1656 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1657 result = TCL_ERROR;
1658 goto checkForCatch;
1659 }
1660 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1661 NEXT_INST_V(pcAdjustment, cleanup, 1);
1662
1663 /*
1664 * End of INST_LOAD instructions.
1665 * ---------------------------------------------------------
1666 */
1667
1668 /*
1669 * ---------------------------------------------------------
1670 * Start of INST_STORE and related instructions.
1671 *
1672 * WARNING: more 'goto' here than your doctor recommended!
1673 * The different instructions set the value of some variables
1674 * and then jump to somme common execution code.
1675 */
1676
1677 case INST_LAPPEND_STK:
1678 valuePtr = stackPtr[stackTop]; /* value to append */
1679 part2 = NULL;
1680 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1681 | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1682 goto doStoreStk;
1683
1684 case INST_LAPPEND_ARRAY_STK:
1685 valuePtr = stackPtr[stackTop]; /* value to append */
1686 part2 = TclGetString(stackPtr[stackTop - 1]);
1687 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1688 | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1689 goto doStoreStk;
1690
1691 case INST_APPEND_STK:
1692 valuePtr = stackPtr[stackTop]; /* value to append */
1693 part2 = NULL;
1694 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1695 goto doStoreStk;
1696
1697 case INST_APPEND_ARRAY_STK:
1698 valuePtr = stackPtr[stackTop]; /* value to append */
1699 part2 = TclGetString(stackPtr[stackTop - 1]);
1700 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1701 goto doStoreStk;
1702
1703 case INST_STORE_ARRAY_STK:
1704 valuePtr = stackPtr[stackTop];
1705 part2 = TclGetString(stackPtr[stackTop - 1]);
1706 storeFlags = TCL_LEAVE_ERR_MSG;
1707 goto doStoreStk;
1708
1709 case INST_STORE_STK:
1710 case INST_STORE_SCALAR_STK:
1711 valuePtr = stackPtr[stackTop];
1712 part2 = NULL;
1713 storeFlags = TCL_LEAVE_ERR_MSG;
1714
1715 doStoreStk:
1716 objPtr = stackPtr[stackTop - 1 - (part2 != NULL)]; /* variable name */
1717 part1 = TclGetString(objPtr);
1718 #ifdef TCL_COMPILE_DEBUG
1719 if (part2 == NULL) {
1720 TRACE(("\"%.30s\" <- \"%.30s\" =>",
1721 part1, O2S(valuePtr)));
1722 } else {
1723 TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
1724 part1, part2, O2S(valuePtr)));
1725 }
1726 #endif
1727 varPtr = TclObjLookupVar(interp, objPtr, part2,
1728 TCL_LEAVE_ERR_MSG, "set",
1729 /*createPart1*/ 1,
1730 /*createPart2*/ 1, &arrayPtr);
1731 if (varPtr == NULL) {
1732 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1733 result = TCL_ERROR;
1734 goto checkForCatch;
1735 }
1736 cleanup = ((part2 == NULL)? 2 : 3);
1737 pcAdjustment = 1;
1738 goto doCallPtrSetVar;
1739
1740 case INST_LAPPEND_ARRAY4:
1741 opnd = TclGetUInt4AtPtr(pc+1);
1742 pcAdjustment = 5;
1743 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1744 | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1745 goto doStoreArray;
1746
1747 case INST_LAPPEND_ARRAY1:
1748 opnd = TclGetUInt1AtPtr(pc+1);
1749 pcAdjustment = 2;
1750 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1751 | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1752 goto doStoreArray;
1753
1754 case INST_APPEND_ARRAY4:
1755 opnd = TclGetUInt4AtPtr(pc+1);
1756 pcAdjustment = 5;
1757 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1758 goto doStoreArray;
1759
1760 case INST_APPEND_ARRAY1:
1761 opnd = TclGetUInt1AtPtr(pc+1);
1762 pcAdjustment = 2;
1763 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1764 goto doStoreArray;
1765
1766 case INST_STORE_ARRAY4:
1767 opnd = TclGetUInt4AtPtr(pc+1);
1768 pcAdjustment = 5;
1769 storeFlags = TCL_LEAVE_ERR_MSG;
1770 goto doStoreArray;
1771
1772 case INST_STORE_ARRAY1:
1773 opnd = TclGetUInt1AtPtr(pc+1);
1774 pcAdjustment = 2;
1775 storeFlags = TCL_LEAVE_ERR_MSG;
1776
1777 doStoreArray:
1778 valuePtr = stackPtr[stackTop];
1779 part2 = TclGetString(stackPtr[stackTop - 1]);
1780 arrayPtr = &(varFramePtr->compiledLocals[opnd]);
1781 part1 = arrayPtr->name;
1782 TRACE(("%u \"%.30s\" <- \"%.30s\" => ",
1783 opnd, part2, O2S(valuePtr)));
1784 while (TclIsVarLink(arrayPtr)) {
1785 arrayPtr = arrayPtr->value.linkPtr;
1786 }
1787 varPtr = TclLookupArrayElement(interp, part1, part2,
1788 TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr);
1789 if (varPtr == NULL) {
1790 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1791 result = TCL_ERROR;
1792 goto checkForCatch;
1793 }
1794 cleanup = 2;
1795 goto doCallPtrSetVar;
1796
1797 case INST_LAPPEND_SCALAR4:
1798 opnd = TclGetUInt4AtPtr(pc+1);
1799 pcAdjustment = 5;
1800 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1801 | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1802 goto doStoreScalar;
1803
1804 case INST_LAPPEND_SCALAR1:
1805 opnd = TclGetUInt1AtPtr(pc+1);
1806 pcAdjustment = 2;
1807 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
1808 | TCL_LIST_ELEMENT | TCL_TRACE_READS);
1809 goto doStoreScalar;
1810
1811 case INST_APPEND_SCALAR4:
1812 opnd = TclGetUInt4AtPtr(pc+1);
1813 pcAdjustment = 5;
1814 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1815 goto doStoreScalar;
1816
1817 case INST_APPEND_SCALAR1:
1818 opnd = TclGetUInt1AtPtr(pc+1);
1819 pcAdjustment = 2;
1820 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
1821 goto doStoreScalar;
1822
1823 case INST_STORE_SCALAR4:
1824 opnd = TclGetUInt4AtPtr(pc+1);
1825 pcAdjustment = 5;
1826 storeFlags = TCL_LEAVE_ERR_MSG;
1827 goto doStoreScalar;
1828
1829 case INST_STORE_SCALAR1:
1830 opnd = TclGetUInt1AtPtr(pc+1);
1831 pcAdjustment = 2;
1832 storeFlags = TCL_LEAVE_ERR_MSG;
1833
1834 doStoreScalar:
1835 valuePtr = stackPtr[stackTop];
1836 varPtr = &(varFramePtr->compiledLocals[opnd]);
1837 part1 = varPtr->name;
1838 TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
1839 while (TclIsVarLink(varPtr)) {
1840 varPtr = varPtr->value.linkPtr;
1841 }
1842 cleanup = 1;
1843 arrayPtr = NULL;
1844 part2 = NULL;
1845
1846 doCallPtrSetVar:
1847 if ((storeFlags == TCL_LEAVE_ERR_MSG)
1848 && !((varPtr->flags & VAR_IN_HASHTABLE)
1849 && (varPtr->hPtr == NULL))
1850 && (varPtr->tracePtr == NULL)
1851 && (TclIsVarScalar(varPtr)
1852 || TclIsVarUndefined(varPtr))
1853 && ((arrayPtr == NULL)
1854 || (arrayPtr->tracePtr == NULL))) {
1855 /*
1856 * No traces, no errors, plain 'set': we can safely inline.
1857 * The value *will* be set to what's requested, so that
1858 * the stack top remains pointing to the same Tcl_Obj.
1859 */
1860 valuePtr = varPtr->value.objPtr;
1861 objResultPtr = stackPtr[stackTop];
1862 if (valuePtr != objResultPtr) {
1863 if (valuePtr != NULL) {
1864 TclDecrRefCount(valuePtr);
1865 } else {
1866 TclSetVarScalar(varPtr);
1867 TclClearVarUndefined(varPtr);
1868 }
1869 varPtr->value.objPtr = objResultPtr;
1870 Tcl_IncrRefCount(objResultPtr);
1871 }
1872 #ifndef TCL_COMPILE_DEBUG
1873 if (*(pc+pcAdjustment) == INST_POP) {
1874 NEXT_INST_V((pcAdjustment+1), cleanup, 0);
1875 }
1876 #else
1877 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1878 #endif
1879 NEXT_INST_V(pcAdjustment, cleanup, 1);
1880 } else {
1881 DECACHE_STACK_INFO();
1882 objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
1883 part1, part2, valuePtr, storeFlags);
1884 CACHE_STACK_INFO();
1885 if (objResultPtr == NULL) {
1886 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1887 result = TCL_ERROR;
1888 goto checkForCatch;
1889 }
1890 }
1891 #ifndef TCL_COMPILE_DEBUG
1892 if (*(pc+pcAdjustment) == INST_POP) {
1893 NEXT_INST_V((pcAdjustment+1), cleanup, 0);
1894 }
1895 #endif
1896 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
1897 NEXT_INST_V(pcAdjustment, cleanup, 1);
1898
1899
1900 /*
1901 * End of INST_STORE and related instructions.
1902 * ---------------------------------------------------------
1903 */
1904
1905 /*
1906 * ---------------------------------------------------------
1907 * Start of INST_INCR instructions.
1908 *
1909 * WARNING: more 'goto' here than your doctor recommended!
1910 * The different instructions set the value of some variables
1911 * and then jump to somme common execution code.
1912 */
1913
1914 case INST_INCR_SCALAR1:
1915 case INST_INCR_ARRAY1:
1916 case INST_INCR_ARRAY_STK:
1917 case INST_INCR_SCALAR_STK:
1918 case INST_INCR_STK:
1919 opnd = TclGetUInt1AtPtr(pc+1);
1920 valuePtr = stackPtr[stackTop];
1921 if (valuePtr->typePtr == &tclIntType) {
1922 i = valuePtr->internalRep.longValue;
1923 } else if (valuePtr->typePtr == &tclWideIntType) {
1924 TclGetLongFromWide(i,valuePtr);
1925 } else {
1926 REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
1927 if (result != TCL_OK) {
1928 TRACE_WITH_OBJ(("%u (by %s) => ERROR converting increment amount to int: ",
1929 opnd, O2S(valuePtr)), Tcl_GetObjResult(interp));
1930 DECACHE_STACK_INFO();
1931 Tcl_AddErrorInfo(interp, "\n (reading increment)");
1932 CACHE_STACK_INFO();
1933 goto checkForCatch;
1934 }
1935 FORCE_LONG(valuePtr, i, w);
1936 }
1937 stackTop--;
1938 TclDecrRefCount(valuePtr);
1939 switch (*pc) {
1940 case INST_INCR_SCALAR1:
1941 pcAdjustment = 2;
1942 goto doIncrScalar;
1943 case INST_INCR_ARRAY1:
1944 pcAdjustment = 2;
1945 goto doIncrArray;
1946 default:
1947 pcAdjustment = 1;
1948 goto doIncrStk;
1949 }
1950
1951 case INST_INCR_ARRAY_STK_IMM:
1952 case INST_INCR_SCALAR_STK_IMM:
1953 case INST_INCR_STK_IMM:
1954 i = TclGetInt1AtPtr(pc+1);
1955 pcAdjustment = 2;
1956
1957 doIncrStk:
1958 if ((*pc == INST_INCR_ARRAY_STK_IMM)
1959 || (*pc == INST_INCR_ARRAY_STK)) {
1960 part2 = TclGetString(stackPtr[stackTop]);
1961 objPtr = stackPtr[stackTop - 1];
1962 TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
1963 O2S(objPtr), part2, i));
1964 } else {
1965 part2 = NULL;
1966 objPtr = stackPtr[stackTop];
1967 TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
1968 }
1969 part1 = TclGetString(objPtr);
1970
1971 varPtr = TclObjLookupVar(interp, objPtr, part2,
1972 TCL_LEAVE_ERR_MSG, "read", 0, 1, &arrayPtr);
1973 if (varPtr == NULL) {
1974 DECACHE_STACK_INFO();
1975 Tcl_AddObjErrorInfo(interp,
1976 "\n (reading value of variable to increment)", -1);
1977 CACHE_STACK_INFO();
1978 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
1979 result = TCL_ERROR;
1980 goto checkForCatch;
1981 }
1982 cleanup = ((part2 == NULL)? 1 : 2);
1983 goto doIncrVar;
1984
1985 case INST_INCR_ARRAY1_IMM:
1986 opnd = TclGetUInt1AtPtr(pc+1);
1987 i = TclGetInt1AtPtr(pc+2);
1988 pcAdjustment = 3;
1989
1990 doIncrArray:
1991 part2 = TclGetString(stackPtr[stackTop]);
1992 arrayPtr = &(varFramePtr->compiledLocals[opnd]);
1993 part1 = arrayPtr->name;
1994 while (TclIsVarLink(arrayPtr)) {
1995 arrayPtr = arrayPtr->value.linkPtr;
1996 }
1997 TRACE(("%u \"%.30s\" (by %ld) => ",
1998 opnd, part2, i));
1999 varPtr = TclLookupArrayElement(interp, part1, part2,
2000 TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr);
2001 if (varPtr == NULL) {
2002 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
2003 result = TCL_ERROR;
2004 goto checkForCatch;
2005 }
2006 cleanup = 1;
2007 goto doIncrVar;
2008
2009 case INST_INCR_SCALAR1_IMM:
2010 opnd = TclGetUInt1AtPtr(pc+1);
2011 i = TclGetInt1AtPtr(pc+2);
2012 pcAdjustment = 3;
2013
2014 doIncrScalar:
2015 varPtr = &(varFramePtr->compiledLocals[opnd]);
2016 part1 = varPtr->name;
2017 while (TclIsVarLink(varPtr)) {
2018 varPtr = varPtr->value.linkPtr;
2019 }
2020 arrayPtr = NULL;
2021 part2 = NULL;
2022 cleanup = 0;
2023 TRACE(("%u %ld => ", opnd, i));
2024
2025
2026 doIncrVar:
2027 objPtr = varPtr->value.objPtr;
2028 if (TclIsVarScalar(varPtr)
2029 && !TclIsVarUndefined(varPtr)
2030 && (varPtr->tracePtr == NULL)
2031 && ((arrayPtr == NULL)
2032 || (arrayPtr->tracePtr == NULL))
2033 && (objPtr->typePtr == &tclIntType)) {
2034 /*
2035 * No errors, no traces, the variable already has an
2036 * integer value: inline processing.
2037 */
2038
2039 i += objPtr->internalRep.longValue;
2040 if (Tcl_IsShared(objPtr)) {
2041 objResultPtr = Tcl_NewLongObj(i);
2042 TclDecrRefCount(objPtr);
2043 Tcl_IncrRefCount(objResultPtr);
2044 varPtr->value.objPtr = objResultPtr;
2045 } else {
2046 Tcl_SetLongObj(objPtr, i);
2047 objResultPtr = objPtr;
2048 }
2049 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
2050 } else {
2051 DECACHE_STACK_INFO();
2052 objResultPtr = TclPtrIncrVar(interp, varPtr, arrayPtr, part1,
2053 part2, i, TCL_LEAVE_ERR_MSG);
2054 CACHE_STACK_INFO();
2055 if (objResultPtr == NULL) {
2056 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
2057 result = TCL_ERROR;
2058 goto checkForCatch;
2059 }
2060 }
2061 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
2062 #ifndef TCL_COMPILE_DEBUG
2063 if (*(pc+pcAdjustment) == INST_POP) {
2064 NEXT_INST_V((pcAdjustment+1), cleanup, 0);
2065 }
2066 #endif
2067 NEXT_INST_V(pcAdjustment, cleanup, 1);
2068
2069 /*
2070 * End of INST_INCR instructions.
2071 * ---------------------------------------------------------
2072 */
2073
2074
2075 case INST_JUMP1:
2076 opnd = TclGetInt1AtPtr(pc+1);
2077 TRACE(("%d => new pc %u\n", opnd,
2078 (unsigned int)(pc + opnd - codePtr->codeStart)));
2079 NEXT_INST_F(opnd, 0, 0);
2080
2081 case INST_JUMP4:
2082 opnd = TclGetInt4AtPtr(pc+1);
2083 TRACE(("%d => new pc %u\n", opnd,
2084 (unsigned int)(pc + opnd - codePtr->codeStart)));
2085 NEXT_INST_F(opnd, 0, 0);
2086
2087 case INST_JUMP_FALSE4:
2088 opnd = 5; /* TRUE */
2089 pcAdjustment = TclGetInt4AtPtr(pc+1); /* FALSE */
2090 goto doJumpTrue;
2091
2092 case INST_JUMP_TRUE4:
2093 opnd = TclGetInt4AtPtr(pc+1); /* TRUE */
2094 pcAdjustment = 5; /* FALSE */
2095 goto doJumpTrue;
2096
2097 case INST_JUMP_FALSE1:
2098 opnd = 2; /* TRUE */
2099 pcAdjustment = TclGetInt1AtPtr(pc+1); /* FALSE */
2100 goto doJumpTrue;
2101
2102 case INST_JUMP_TRUE1:
2103 opnd = TclGetInt1AtPtr(pc+1); /* TRUE */
2104 pcAdjustment = 2; /* FALSE */
2105
2106 doJumpTrue:
2107 {
2108 int b;
2109
2110 valuePtr = stackPtr[stackTop];
2111 if (valuePtr->typePtr == &tclIntType) {
2112 b = (valuePtr->internalRep.longValue != 0);
2113 } else if (valuePtr->typePtr == &tclDoubleType) {
2114 b = (valuePtr->internalRep.doubleValue != 0.0);
2115 } else if (valuePtr->typePtr == &tclWideIntType) {
2116 TclGetWide(w,valuePtr);
2117 b = (w != W0);
2118 } else {
2119 result = Tcl_GetBooleanFromObj(interp, valuePtr, &b);
2120 if (result != TCL_OK) {
2121 TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
2122 goto checkForCatch;
2123 }
2124 }
2125 #ifndef TCL_COMPILE_DEBUG
2126 NEXT_INST_F((b? opnd : pcAdjustment), 1, 0);
2127 #else
2128 if (b) {
2129 if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
2130 TRACE(("%d => %.20s true, new pc %u\n", opnd, O2S(valuePtr),
2131 (unsigned int)(pc+opnd - codePtr->codeStart)));
2132 } else {
2133 TRACE(("%d => %.20s true\n", pcAdjustment, O2S(valuePtr)));
2134 }
2135 NEXT_INST_F(opnd, 1, 0);
2136 } else {
2137 if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE1)) {
2138 TRACE(("%d => %.20s false\n", opnd, O2S(valuePtr)));
2139 } else {
2140 opnd = pcAdjustment;
2141 TRACE(("%d => %.20s false, new pc %u\n", opnd, O2S(valuePtr),
2142 (unsigned int)(pc + opnd - codePtr->codeStart)));
2143 }
2144 NEXT_INST_F(pcAdjustment, 1, 0);
2145 }
2146 #endif
2147 }
2148
2149 case INST_LOR:
2150 case INST_LAND:
2151 {
2152 /*
2153 * Operands must be boolean or numeric. No int->double
2154 * conversions are performed.
2155 */
2156
2157 int i1, i2;
2158 int iResult;
2159 char *s;
2160 Tcl_ObjType *t1Ptr, *t2Ptr;
2161
2162 value2Ptr = stackPtr[stackTop];
2163 valuePtr = stackPtr[stackTop - 1];;
2164 t1Ptr = valuePtr->typePtr;
2165 t2Ptr = value2Ptr->typePtr;
2166
2167 if ((t1Ptr == &tclIntType) || (t1Ptr == &tclBooleanType)) {
2168 i1 = (valuePtr->internalRep.longValue != 0);
2169 } else if (t1Ptr == &tclWideIntType) {
2170 TclGetWide(w,valuePtr);
2171 i1 = (w != W0);
2172 } else if (t1Ptr == &tclDoubleType) {
2173 i1 = (valuePtr->internalRep.doubleValue != 0.0);
2174 } else {
2175 s = Tcl_GetStringFromObj(valuePtr, &length);
2176 if (TclLooksLikeInt(s, length)) {
2177 GET_WIDE_OR_INT(result, valuePtr, i, w);
2178 if (valuePtr->typePtr == &tclIntType) {
2179 i1 = (i != 0);
2180 } else {
2181 i1 = (w != W0);
2182 }
2183 } else {
2184 result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL,
2185 valuePtr, &i1);
2186 i1 = (i1 != 0);
2187 }
2188 if (result != TCL_OK) {
2189 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
2190 (t1Ptr? t1Ptr->name : "null")));
2191 DECACHE_STACK_INFO();
2192 IllegalExprOperandType(interp, pc, valuePtr);
2193 CACHE_STACK_INFO();
2194 goto checkForCatch;
2195 }
2196 }
2197
2198 if ((t2Ptr == &tclIntType) || (t2Ptr == &tclBooleanType)) {
2199 i2 = (value2Ptr->internalRep.longValue != 0);
2200 } else if (t2Ptr == &tclWideIntType) {
2201 TclGetWide(w,value2Ptr);
2202 i2 = (w != W0);
2203 } else if (t2Ptr == &tclDoubleType) {
2204 i2 = (value2Ptr->internalRep.doubleValue != 0.0);
2205 } else {
2206 s = Tcl_GetStringFromObj(value2Ptr, &length);
2207 if (TclLooksLikeInt(s, length)) {
2208 GET_WIDE_OR_INT(result, value2Ptr, i, w);
2209 if (value2Ptr->typePtr == &tclIntType) {
2210 i2 = (i != 0);
2211 } else {
2212 i2 = (w != W0);
2213 }
2214 } else {
2215 result = Tcl_GetBooleanFromObj((Tcl_Interp *) NULL, value2Ptr, &i2);
2216 }
2217 if (result != TCL_OK) {
2218 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
2219 (t2Ptr? t2Ptr->name : "null")));
2220 DECACHE_STACK_INFO();
2221 IllegalExprOperandType(interp, pc, value2Ptr);
2222 CACHE_STACK_INFO();
2223 goto checkForCatch;
2224 }
2225 }
2226
2227 /*
2228 * Reuse the valuePtr object already on stack if possible.
2229 */
2230
2231 if (*pc == INST_LOR) {
2232 iResult = (i1 || i2);
2233 } else {
2234 iResult = (i1 && i2);
2235 }
2236 if (Tcl_IsShared(valuePtr)) {
2237 objResultPtr = Tcl_NewLongObj(iResult);
2238 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
2239 NEXT_INST_F(1, 2, 1);
2240 } else { /* reuse the valuePtr object */
2241 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
2242 Tcl_SetLongObj(valuePtr, iResult);
2243 NEXT_INST_F(1, 1, 0);
2244 }
2245 }
2246
2247 /*
2248 * ---------------------------------------------------------
2249 * Start of INST_LIST and related instructions.
2250 */
2251
2252 case INST_LIST:
2253 /*
2254 * Pop the opnd (objc) top stack elements into a new list obj
2255 * and then decrement their ref counts.
2256 */
2257
2258 opnd = TclGetUInt4AtPtr(pc+1);
2259 objResultPtr = Tcl_NewListObj(opnd, &(stackPtr[stackTop - (opnd-1)]));
2260 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
2261 NEXT_INST_V(5, opnd, 1);
2262
2263 case INST_LIST_LENGTH:
2264 valuePtr = stackPtr[stackTop];
2265
2266 result = Tcl_ListObjLength(interp, valuePtr, &length);
2267 if (result != TCL_OK) {
2268 TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
2269 Tcl_GetObjResult(interp));
2270 goto checkForCatch;
2271 }
2272 objResultPtr = Tcl_NewIntObj(length);
2273 TRACE(("%.20s => %d\n", O2S(valuePtr), length));
2274 NEXT_INST_F(1, 1, 1);
2275
2276 case INST_LIST_INDEX:
2277 /*** lindex with objc == 3 ***/
2278
2279 /*
2280 * Pop the two operands
2281 */
2282 value2Ptr = stackPtr[stackTop];
2283 valuePtr = stackPtr[stackTop- 1];
2284
2285 /*
2286 * Extract the desired list element
2287 */
2288 objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
2289 if (objResultPtr == NULL) {
2290 TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr), O2S(value2Ptr)),
2291 Tcl_GetObjResult(interp));
2292 result = TCL_ERROR;
2293 goto checkForCatch;
2294 }
2295
2296 /*
2297 * Stash the list element on the stack
2298 */
2299 TRACE(("%.20s %.20s => %s\n",
2300 O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
2301 NEXT_INST_F(1, 2, -1); /* already has the correct refCount */
2302
2303 case INST_LIST_INDEX_MULTI:
2304 {
2305 /*
2306 * 'lindex' with multiple index args:
2307 *
2308 * Determine the count of index args.
2309 */
2310
2311 int numIdx;
2312
2313 opnd = TclGetUInt4AtPtr(pc+1);
2314 numIdx = opnd-1;
2315
2316 /*
2317 * Do the 'lindex' operation.
2318 */
2319 objResultPtr = TclLindexFlat(interp, stackPtr[stackTop - numIdx],
2320 numIdx, stackPtr + stackTop - numIdx + 1);
2321
2322 /*
2323 * Check for errors
2324 */
2325 if (objResultPtr == NULL) {
2326 TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
2327 result = TCL_ERROR;
2328 goto checkForCatch;
2329 }
2330
2331 /*
2332 * Set result
2333 */
2334 TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
2335 NEXT_INST_V(5, opnd, -1);
2336 }
2337
2338 case INST_LSET_FLAT:
2339 {
2340 /*
2341 * Lset with 3, 5, or more args. Get the number
2342 * of index args.
2343 */
2344 int numIdx;
2345
2346 opnd = TclGetUInt4AtPtr( pc + 1 );
2347 numIdx = opnd - 2;
2348
2349 /*
2350 * Get the old value of variable, and remove the stack ref.
2351 * This is safe because the variable still references the
2352 * object; the ref count will never go zero here.
2353 */
2354 value2Ptr = POP_OBJECT();
2355 TclDecrRefCount(value2Ptr); /* This one should be done here */
2356
2357 /*
2358 * Get the new element value.
2359 */
2360 valuePtr = stackPtr[stackTop];
2361
2362 /*
2363 * Compute the new variable value
2364 */
2365 objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
2366 stackPtr + stackTop - numIdx, valuePtr);
2367
2368
2369 /*
2370 * Check for errors
2371 */
2372 if (objResultPtr == NULL) {
2373 TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
2374 result = TCL_ERROR;
2375 goto checkForCatch;
2376 }
2377
2378 /*
2379 * Set result
2380 */
2381 TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
2382 NEXT_INST_V(5, (numIdx+1), -1);
2383 }
2384
2385 case INST_LSET_LIST:
2386 /*
2387 * 'lset' with 4 args.
2388 *
2389 * Get the old value of variable, and remove the stack ref.
2390 * This is safe because the variable still references the
2391 * object; the ref count will never go zero here.
2392 */
2393 objPtr = POP_OBJECT();
2394 TclDecrRefCount(objPtr); /* This one should be done here */
2395
2396 /*
2397 * Get the new element value, and the index list
2398 */
2399 valuePtr = stackPtr[stackTop];
2400 value2Ptr = stackPtr[stackTop - 1];
2401
2402 /*
2403 * Compute the new variable value
2404 */
2405 objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
2406
2407 /*
2408 * Check for errors
2409 */
2410 if (objResultPtr == NULL) {
2411 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
2412 Tcl_GetObjResult(interp));
2413 result = TCL_ERROR;
2414 goto checkForCatch;
2415 }
2416
2417 /*
2418 * Set result
2419 */
2420 TRACE(("=> %s\n", O2S(objResultPtr)));
2421 NEXT_INST_F(1, 2, -1);
2422
2423 /*
2424 * End of INST_LIST and related instructions.
2425 * ---------------------------------------------------------
2426 */
2427
2428 case INST_STR_EQ:
2429 case INST_STR_NEQ:
2430 {
2431 /*
2432 * String (in)equality check
2433 */
2434 int iResult;
2435
2436 value2Ptr = stackPtr[stackTop];
2437 valuePtr = stackPtr[stackTop - 1];
2438
2439 if (valuePtr == value2Ptr) {
2440 /*
2441 * On the off-chance that the objects are the same,
2442 * we don't really have to think hard about equality.
2443 */
2444 iResult = (*pc == INST_STR_EQ);
2445 } else {
2446 char *s1, *s2;
2447 int s1len, s2len;
2448
2449 s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
2450 s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
2451 if (s1len == s2len) {
2452 /*
2453 * We only need to check (in)equality when
2454 * we have equal length strings.
2455 */
2456 if (*pc == INST_STR_NEQ) {
2457 iResult = (strcmp(s1, s2) != 0);
2458 } else {
2459 /* INST_STR_EQ */
2460 iResult = (strcmp(s1, s2) == 0);
2461 }
2462 } else {
2463 iResult = (*pc == INST_STR_NEQ);
2464 }
2465 }
2466
2467 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
2468
2469 /*
2470 * Peep-hole optimisation: if you're about to jump, do jump
2471 * from here.
2472 */
2473
2474 pc++;
2475 #ifndef TCL_COMPILE_DEBUG
2476 switch (*pc) {
2477 case INST_JUMP_FALSE1:
2478 NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
2479 case INST_JUMP_TRUE1:
2480 NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
2481 case INST_JUMP_FALSE4:
2482 NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
2483 case INST_JUMP_TRUE4:
2484 NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
2485 }
2486 #endif
2487 objResultPtr = Tcl_NewIntObj(iResult);
2488 NEXT_INST_F(0, 2, 1);
2489 }
2490
2491 case INST_STR_CMP:
2492 {
2493 /*
2494 * String compare
2495 */
2496 CONST char *s1, *s2;
2497 int s1len, s2len, iResult;
2498
2499 value2Ptr = stackPtr[stackTop];
2500 valuePtr = stackPtr[stackTop - 1];
2501
2502 /*
2503 * The comparison function should compare up to the
2504 * minimum byte length only.
2505 */
2506 if (valuePtr == value2Ptr) {
2507 /*
2508 * In the pure equality case, set lengths too for
2509 * the checks below (or we could goto beyond it).
2510 */
2511 iResult = s1len = s2len = 0;
2512 } else if ((valuePtr->typePtr == &tclByteArrayType)
2513 && (value2Ptr->typePtr == &tclByteArrayType)) {
2514 s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
2515 s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
2516 iResult = memcmp(s1, s2,
2517 (size_t) ((s1len < s2len) ? s1len : s2len));
2518 } else if (((valuePtr->typePtr == &tclStringType)
2519 && (value2Ptr->typePtr == &tclStringType))) {
2520 /*
2521 * Do a unicode-specific comparison if both of the args are of
2522 * String type. If the char length == byte length, we can do a
2523 * memcmp. In benchmark testing this proved the most efficient
2524 * check between the unicode and string comparison operations.
2525 */
2526
2527 s1len = Tcl_GetCharLength(valuePtr);
2528 s2len = Tcl_GetCharLength(value2Ptr);
2529 if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
2530 iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
2531 (unsigned) ((s1len < s2len) ? s1len : s2len));
2532 } else {
2533 iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
2534 Tcl_GetUnicode(value2Ptr),
2535 (unsigned) ((s1len < s2len) ? s1len : s2len));
2536 }
2537 } else {
2538 /*
2539 * We can't do a simple memcmp in order to handle the
2540 * special Tcl \xC0\x80 null encoding for utf-8.
2541 */
2542 s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
2543 s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
2544 iResult = TclpUtfNcmp2(s1, s2,
2545 (size_t) ((s1len < s2len) ? s1len : s2len));
2546 }
2547
2548 /*
2549 * Make sure only -1,0,1 is returned
2550 */
2551 if (iResult == 0) {
2552 iResult = s1len - s2len;
2553 }
2554 if (iResult < 0) {
2555 iResult = -1;
2556 } else if (iResult > 0) {
2557 iResult = 1;
2558 }
2559
2560 objResultPtr = Tcl_NewIntObj(iResult);
2561 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), iResult));
2562 NEXT_INST_F(1, 2, 1);
2563 }
2564
2565 case INST_STR_LEN:
2566 {
2567 int length1;
2568
2569 valuePtr = stackPtr[stackTop];
2570
2571 if (valuePtr->typePtr == &tclByteArrayType) {
2572 (void) Tcl_GetByteArrayFromObj(valuePtr, &length1);
2573 } else {
2574 length1 = Tcl_GetCharLength(valuePtr);
2575 }
2576 objResultPtr = Tcl_NewIntObj(length1);
2577 TRACE(("%.20s => %d\n", O2S(valuePtr), length1));
2578 NEXT_INST_F(1, 1, 1);
2579 }
2580
2581 case INST_STR_INDEX:
2582 {
2583 /*
2584 * String compare
2585 */
2586 int index;
2587 bytes = NULL; /* lint */
2588
2589 value2Ptr = stackPtr[stackTop];
2590 valuePtr = stackPtr[stackTop - 1];
2591
2592 /*
2593 * If we have a ByteArray object, avoid indexing in the
2594 * Utf string since the byte array contains one byte per
2595 * character. Otherwise, use the Unicode string rep to
2596 * get the index'th char.
2597 */
2598
2599 if (valuePtr->typePtr == &tclByteArrayType) {
2600 bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
2601 } else {
2602 /*
2603 * Get Unicode char length to calulate what 'end' means.
2604 */
2605 length = Tcl_GetCharLength(valuePtr);
2606 }
2607
2608 result = TclGetIntForIndex(interp, value2Ptr, length - 1, &index);
2609 if (result != TCL_OK) {
2610 goto checkForCatch;
2611 }
2612
2613 if ((index >= 0) && (index < length)) {
2614 if (valuePtr->typePtr == &tclByteArrayType) {
2615 objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
2616 (&bytes[index]), 1);
2617 } else if (valuePtr->bytes && length == valuePtr->length) {
2618 objResultPtr = Tcl_NewStringObj((CONST char *)
2619 (&valuePtr->bytes[index]), 1);
2620 } else {
2621 char buf[TCL_UTF_MAX];
2622 Tcl_UniChar ch;
2623
2624 ch = Tcl_GetUniChar(valuePtr, index);
2625 /*
2626 * This could be:
2627 * Tcl_NewUnicodeObj((CONST Tcl_UniChar *)&ch, 1)
2628 * but creating the object as a string seems to be
2629 * faster in practical use.
2630 */
2631 length = Tcl_UniCharToUtf(ch, buf);
2632 objResultPtr = Tcl_NewStringObj(buf, length);
2633 }
2634 } else {
2635 TclNewObj(objResultPtr);
2636 }
2637
2638 TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
2639 O2S(objResultPtr)));
2640 NEXT_INST_F(1, 2, 1);
2641 }
2642
2643 case INST_STR_MATCH:
2644 {
2645 int nocase, match;
2646
2647 nocase = TclGetInt1AtPtr(pc+1);
2648 valuePtr = stackPtr[stackTop]; /* String */
2649 value2Ptr = stackPtr[stackTop - 1]; /* Pattern */
2650
2651 /*
2652 * Check that at least one of the objects is Unicode before
2653 * promoting both.
2654 */
2655
2656 if ((valuePtr->typePtr == &tclStringType)
2657 || (value2Ptr->typePtr == &tclStringType)) {
2658 Tcl_UniChar *ustring1, *ustring2;
2659 int length1, length2;
2660
2661 ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
2662 ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
2663 match = TclUniCharMatch(ustring1, length1, ustring2, length2,
2664 nocase);
2665 } else {
2666 match = Tcl_StringCaseMatch(TclGetString(valuePtr),
2667 TclGetString(value2Ptr), nocase);
2668 }
2669
2670 /*
2671 * Reuse value2Ptr object already on stack if possible.
2672 * Adjustment is 2 due to the nocase byte
2673 */
2674
2675 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
2676 if (Tcl_IsShared(value2Ptr)) {
2677 objResultPtr = Tcl_NewIntObj(match);
2678 NEXT_INST_F(2, 2, 1);
2679 } else { /* reuse the valuePtr object */
2680 Tcl_SetIntObj(value2Ptr, match);
2681 NEXT_INST_F(2, 1, 0);
2682 }
2683 }
2684
2685 case INST_EQ:
2686 case INST_NEQ:
2687 case INST_LT:
2688 case INST_GT:
2689 case INST_LE:
2690 case INST_GE:
2691 {
2692 /*
2693 * Any type is allowed but the two operands must have the
2694 * same type. We will compute value op value2.
2695 */
2696
2697 Tcl_ObjType *t1Ptr, *t2Ptr;
2698 char *s1 = NULL; /* Init. avoids compiler warning. */
2699 char *s2 = NULL; /* Init. avoids compiler warning. */
2700 long i2 = 0; /* Init. avoids compiler warning. */
2701 double d1 = 0.0; /* Init. avoids compiler warning. */
2702 double d2 = 0.0; /* Init. avoids compiler warning. */
2703 long iResult = 0; /* Init. avoids compiler warning. */
2704
2705 value2Ptr = stackPtr[stackTop];
2706 valuePtr = stackPtr[stackTop - 1];
2707
2708 if (valuePtr == value2Ptr) {
2709 /*
2710 * Optimize the equal object case.
2711 */
2712 switch (*pc) {
2713 case INST_EQ:
2714 case INST_LE:
2715 case INST_GE:
2716 iResult = 1;
2717 break;
2718 case INST_NEQ:
2719 case INST_LT:
2720 case INST_GT:
2721 iResult = 0;
2722 break;
2723 }
2724 goto foundResult;
2725 }
2726
2727 t1Ptr = valuePtr->typePtr;
2728 t2Ptr = value2Ptr->typePtr;
2729
2730 /*
2731 * We only want to coerce numeric validation if neither type
2732 * is NULL. A NULL type means the arg is essentially an empty
2733 * object ("", {} or [list]).
2734 */
2735 if (!( (!t1Ptr && !valuePtr->bytes)
2736 || (valuePtr->bytes && !valuePtr->length)
2737 || (!t2Ptr && !value2Ptr->bytes)
2738 || (value2Ptr->bytes && !value2Ptr->length))) {
2739 if (!IS_NUMERIC_TYPE(t1Ptr)) {
2740 s1 = Tcl_GetStringFromObj(valuePtr, &length);
2741 if (TclLooksLikeInt(s1, length)) {
2742 GET_WIDE_OR_INT(iResult, valuePtr, i, w);
2743 } else {
2744 (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2745 valuePtr, &d1);
2746 }
2747 t1Ptr = valuePtr->typePtr;
2748 }
2749 if (!IS_NUMERIC_TYPE(t2Ptr)) {
2750 s2 = Tcl_GetStringFromObj(value2Ptr, &length);
2751 if (TclLooksLikeInt(s2, length)) {
2752 GET_WIDE_OR_INT(iResult, value2Ptr, i2, w);
2753 } else {
2754 (void) Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
2755 value2Ptr, &d2);
2756 }
2757 t2Ptr = value2Ptr->typePtr;
2758 }
2759 }
2760 if (!IS_NUMERIC_TYPE(t1Ptr) || !IS_NUMERIC_TYPE(t2Ptr)) {
2761 /*
2762 * One operand is not numeric. Compare as strings. NOTE:
2763 * strcmp is not correct for \x00 < \x01, but that is
2764 * unlikely to occur here. We could use the TclUtfNCmp2
2765 * to handle this.
2766 */
2767 int s1len, s2len;
2768 s1 = Tcl_GetStringFromObj(valuePtr, &s1len);
2769 s2 = Tcl_GetStringFromObj(value2Ptr, &s2len);
2770 switch (*pc) {
2771 case INST_EQ:
2772 if (s1len == s2len) {
2773 iResult = (strcmp(s1, s2) == 0);
2774 } else {
2775 iResult = 0;
2776 }
2777 break;
2778 case INST_NEQ:
2779 if (s1len == s2len) {
2780 iResult = (strcmp(s1, s2) != 0);
2781 } else {
2782 iResult = 1;
2783 }
2784 break;
2785 case INST_LT:
2786 iResult = (strcmp(s1, s2) < 0);
2787 break;
2788 case INST_GT:
2789 iResult = (strcmp(s1, s2) > 0);
2790 break;
2791 case INST_LE:
2792 iResult = (strcmp(s1, s2) <= 0);
2793 break;
2794 case INST_GE:
2795 iResult = (strcmp(s1, s2) >= 0);
2796 break;
2797 }
2798 } else if ((t1Ptr == &tclDoubleType)
2799 || (t2Ptr == &tclDoubleType)) {
2800 /*
2801 * Compare as doubles.
2802 */
2803 if (t1Ptr == &tclDoubleType) {
2804 d1 = valuePtr->internalRep.doubleValue;
2805 GET_DOUBLE_VALUE(d2, value2Ptr, t2Ptr);
2806 } else { /* t1Ptr is integer, t2Ptr is double */
2807 GET_DOUBLE_VALUE(d1, valuePtr, t1Ptr);
2808 d2 = value2Ptr->internalRep.doubleValue;
2809 }
2810 switch (*pc) {
2811 case INST_EQ:
2812 iResult = d1 == d2;
2813 break;
2814 case INST_NEQ:
2815 iResult = d1 != d2;
2816 break;
2817 case INST_LT:
2818 iResult = d1 < d2;
2819 break;
2820 case INST_GT:
2821 iResult = d1 > d2;
2822 break;
2823 case INST_LE:
2824 iResult = d1 <= d2;
2825 break;
2826 case INST_GE:
2827 iResult = d1 >= d2;
2828 break;
2829 }
2830 } else if ((t1Ptr == &tclWideIntType)
2831 || (t2Ptr == &tclWideIntType)) {
2832 Tcl_WideInt w2;
2833 /*
2834 * Compare as wide ints (neither are doubles)
2835 */
2836 if (t1Ptr == &tclIntType) {
2837 w = Tcl_LongAsWide(valuePtr->internalRep.longValue);
2838 TclGetWide(w2,value2Ptr);
2839 } else if (t2Ptr == &tclIntType) {
2840 TclGetWide(w,valuePtr);
2841 w2 = Tcl_LongAsWide(value2Ptr->internalRep.longValue);
2842 } else {
2843 TclGetWide(w,valuePtr);
2844 TclGetWide(w2,value2Ptr);
2845 }
2846 switch (*pc) {
2847 case INST_EQ:
2848 iResult = w == w2;
2849 break;
2850 case INST_NEQ:
2851 iResult = w != w2;
2852 break;
2853 case INST_LT:
2854 iResult = w < w2;
2855 break;
2856 case INST_GT:
2857 iResult = w > w2;
2858 break;
2859 case INST_LE:
2860 iResult = w <= w2;
2861 break;
2862 case INST_GE:
2863 iResult = w >= w2;
2864 break;
2865 }
2866 } else {
2867 /*
2868 * Compare as ints.
2869 */
2870 i = valuePtr->internalRep.longValue;
2871 i2 = value2Ptr->internalRep.longValue;
2872 switch (*pc) {
2873 case INST_EQ:
2874 iResult = i == i2;
2875 break;
2876 case INST_NEQ:
2877 iResult = i != i2;
2878 break;
2879 case INST_LT:
2880 iResult = i < i2;
2881 break;
2882 case INST_GT:
2883 iResult = i > i2;
2884 break;
2885 case INST_LE:
2886 iResult = i <= i2;
2887 break;
2888 case INST_GE:
2889 iResult = i >= i2;
2890 break;
2891 }
2892 }
2893
2894 foundResult:
2895 TRACE(("%.20s %.20s => %ld\n", O2S(valuePtr), O2S(value2Ptr), iResult));
2896
2897 /*
2898 * Peep-hole optimisation: if you're about to jump, do jump
2899 * from here.
2900 */
2901
2902 pc++;
2903 #ifndef TCL_COMPILE_DEBUG
2904 switch (*pc) {
2905 case INST_JUMP_FALSE1:
2906 NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
2907 case INST_JUMP_TRUE1:
2908 NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
2909 case INST_JUMP_FALSE4:
2910 NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
2911 case INST_JUMP_TRUE4:
2912 NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
2913 }
2914 #endif
2915 objResultPtr = Tcl_NewIntObj(iResult);
2916 NEXT_INST_F(0, 2, 1);
2917 }
2918
2919 case INST_MOD:
2920 case INST_LSHIFT:
2921 case INST_RSHIFT:
2922 case INST_BITOR:
2923 case INST_BITXOR:
2924 case INST_BITAND:
2925 {
2926 /*
2927 * Only integers are allowed. We compute value op value2.
2928 */
2929
2930 long i2 = 0, rem, negative;
2931 long iResult = 0; /* Init. avoids compiler warning. */
2932 Tcl_WideInt w2, wResult = W0;
2933 int doWide = 0;
2934
2935 value2Ptr = stackPtr[stackTop];
2936 valuePtr = stackPtr[stackTop - 1];
2937 if (valuePtr->typePtr == &tclIntType) {
2938 i = valuePtr->internalRep.longValue;
2939 } else if (valuePtr->typePtr == &tclWideIntType) {
2940 TclGetWide(w,valuePtr);
2941 } else { /* try to convert to int */
2942 REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
2943 if (result != TCL_OK) {
2944 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
2945 O2S(valuePtr), O2S(value2Ptr),
2946 (valuePtr->typePtr?
2947 valuePtr->typePtr->name : "null")));
2948 DECACHE_STACK_INFO();
2949 IllegalExprOperandType(interp, pc, valuePtr);
2950 CACHE_STACK_INFO();
2951 goto checkForCatch;
2952 }
2953 }
2954 if (value2Ptr->typePtr == &tclIntType) {
2955 i2 = value2Ptr->internalRep.longValue;
2956 } else if (value2Ptr->typePtr == &tclWideIntType) {
2957 TclGetWide(w2,value2Ptr);
2958 } else {
2959 REQUIRE_WIDE_OR_INT(result, value2Ptr, i2, w2);
2960 if (result != TCL_OK) {
2961 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
2962 O2S(valuePtr), O2S(value2Ptr),
2963 (value2Ptr->typePtr?
2964 value2Ptr->typePtr->name : "null")));
2965 DECACHE_STACK_INFO();
2966 IllegalExprOperandType(interp, pc, value2Ptr);
2967 CACHE_STACK_INFO();
2968 goto checkForCatch;
2969 }
2970 }
2971
2972 switch (*pc) {
2973 case INST_MOD:
2974 /*
2975 * This code is tricky: C doesn't guarantee much about
2976 * the quotient or remainder, but Tcl does. The
2977 * remainder always has the same sign as the divisor and
2978 * a smaller absolute value.
2979 */
2980 if (value2Ptr->typePtr == &tclWideIntType && w2 == W0) {
2981 if (valuePtr->typePtr == &tclIntType) {
2982 TRACE(("%ld "LLD" => DIVIDE BY ZERO\n", i, w2));
2983 } else {
2984 TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
2985 }
2986 goto divideByZero;
2987 }
2988 if (value2Ptr->typePtr == &tclIntType && i2 == 0) {
2989 if (valuePtr->typePtr == &tclIntType) {
2990 TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
2991 } else {
2992 TRACE((LLD" %ld => DIVIDE BY ZERO\n", w, i2));
2993 }
2994 goto divideByZero;
2995 }
2996 negative = 0;
2997 if (valuePtr->typePtr == &tclWideIntType
2998 || value2Ptr->typePtr == &tclWideIntType) {
2999 Tcl_WideInt wRemainder;
3000 /*
3001 * Promote to wide
3002 */
3003 if (valuePtr->typePtr == &tclIntType) {
3004 w = Tcl_LongAsWide(i);
3005 } else if (value2Ptr->typePtr == &tclIntType) {
3006 w2 = Tcl_LongAsWide(i2);
3007 }
3008 if (w2 < 0) {
3009 w2 = -w2;
3010 w = -w;
3011 negative = 1;
3012 }
3013 wRemainder = w % w2;
3014 if (wRemainder < 0) {
3015 wRemainder += w2;
3016 }
3017 if (negative) {
3018 wRemainder = -wRemainder;
3019 }
3020 wResult = wRemainder;
3021 doWide = 1;
3022 break;
3023 }
3024 if (i2 < 0) {
3025 i2 = -i2;
3026 i = -i;
3027 negative = 1;
3028 }
3029 rem = i % i2;
3030 if (rem < 0) {
3031 rem += i2;
3032 }
3033 if (negative) {
3034 rem = -rem;
3035 }
3036 iResult = rem;
3037 break;
3038 case INST_LSHIFT:
3039 /*
3040 * Shifts are never usefully 64-bits wide!
3041 */
3042 FORCE_LONG(value2Ptr, i2, w2);
3043 if (valuePtr->typePtr == &tclWideIntType) {
3044 #ifdef TCL_COMPILE_DEBUG
3045 w2 = Tcl_LongAsWide(i2);
3046 #endif /* TCL_COMPILE_DEBUG */
3047 wResult = w << i2;
3048 doWide = 1;
3049 break;
3050 }
3051 iResult = i << i2;
3052 break;
3053 case INST_RSHIFT:
3054 /*
3055 * The following code is a bit tricky: it ensures that
3056 * right shifts propagate the sign bit even on machines
3057 * where ">>" won't do it by default.
3058 */
3059 /*
3060 * Shifts are never usefully 64-bits wide!
3061 */
3062 FORCE_LONG(value2Ptr, i2, w2);
3063 if (valuePtr->typePtr == &tclWideIntType) {
3064 #ifdef TCL_COMPILE_DEBUG
3065 w2 = Tcl_LongAsWide(i2);
3066 #endif /* TCL_COMPILE_DEBUG */
3067 if (w < 0) {
3068 wResult = ~((~w) >> i2);
3069 } else {
3070 wResult = w >> i2;
3071 }
3072 doWide = 1;
3073 break;
3074 }
3075 if (i < 0) {
3076 iResult = ~((~i) >> i2);
3077 } else {
3078 iResult = i >> i2;
3079 }
3080 break;
3081 case INST_BITOR:
3082 if (valuePtr->typePtr == &tclWideIntType
3083 || value2Ptr->typePtr == &tclWideIntType) {
3084 /*
3085 * Promote to wide
3086 */
3087 if (valuePtr->typePtr == &tclIntType) {
3088 w = Tcl_LongAsWide(i);
3089 } else if (value2Ptr->typePtr == &tclIntType) {
3090 w2 = Tcl_LongAsWide(i2);
3091 }
3092 wResult = w | w2;
3093 doWide = 1;
3094 break;
3095 }
3096 iResult = i | i2;
3097 break;
3098 case INST_BITXOR:
3099 if (valuePtr->typePtr == &tclWideIntType
3100 || value2Ptr->typePtr == &tclWideIntType) {
3101 /*
3102 * Promote to wide
3103 */
3104 if (valuePtr->typePtr == &tclIntType) {
3105 w = Tcl_LongAsWide(i);
3106 } else if (value2Ptr->typePtr == &tclIntType) {
3107 w2 = Tcl_LongAsWide(i2);
3108 }
3109 wResult = w ^ w2;
3110 doWide = 1;
3111 break;
3112 }
3113 iResult = i ^ i2;
3114 break;
3115 case INST_BITAND:
3116 if (valuePtr->typePtr == &tclWideIntType
3117 || value2Ptr->typePtr == &tclWideIntType) {
3118 /*
3119 * Promote to wide
3120 */
3121 if (valuePtr->typePtr == &tclIntType) {
3122 w = Tcl_LongAsWide(i);
3123 } else if (value2Ptr->typePtr == &tclIntType) {
3124 w2 = Tcl_LongAsWide(i2);
3125 }
3126 wResult = w & w2;
3127 doWide = 1;
3128 break;
3129 }
3130 iResult = i & i2;
3131 break;
3132 }
3133
3134 /*
3135 * Reuse the valuePtr object already on stack if possible.
3136 */
3137
3138 if (Tcl_IsShared(valuePtr)) {
3139 if (doWide) {
3140 objResultPtr = Tcl_NewWideIntObj(wResult);
3141 TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
3142 } else {
3143 objResultPtr = Tcl_NewLongObj(iResult);
3144 TRACE(("%ld %ld => %ld\n", i, i2, iResult));
3145 }
3146 NEXT_INST_F(1, 2, 1);
3147 } else { /* reuse the valuePtr object */
3148 if (doWide) {
3149 TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
3150 Tcl_SetWideIntObj(valuePtr, wResult);
3151 } else {
3152 TRACE(("%ld %ld => %ld\n", i, i2, iResult));
3153 Tcl_SetLongObj(valuePtr, iResult);
3154 }
3155 NEXT_INST_F(1, 1, 0);
3156 }
3157 }
3158
3159 case INST_ADD:
3160 case INST_SUB:
3161 case INST_MULT:
3162 case INST_DIV:
3163 {
3164 /*
3165 * Operands must be numeric and ints get converted to floats
3166 * if necessary. We compute value op value2.
3167 */
3168
3169 Tcl_ObjType *t1Ptr, *t2Ptr;
3170 long i2 = 0, quot, rem; /* Init. avoids compiler warning. */
3171 double d1, d2;
3172 long iResult = 0; /* Init. avoids compiler warning. */
3173 double dResult = 0.0; /* Init. avoids compiler warning. */
3174 int doDouble = 0; /* 1 if doing floating arithmetic */
3175 Tcl_WideInt w2, wquot, wrem;
3176 Tcl_WideInt wResult = W0; /* Init. avoids compiler warning. */
3177 int doWide = 0; /* 1 if doing wide arithmetic. */
3178
3179 value2Ptr = stackPtr[stackTop];
3180 valuePtr = stackPtr[stackTop - 1];
3181 t1Ptr = valuePtr->typePtr;
3182 t2Ptr = value2Ptr->typePtr;
3183
3184 if (t1Ptr == &tclIntType) {
3185 i = valuePtr->internalRep.longValue;
3186 } else if (t1Ptr == &tclWideIntType) {
3187 TclGetWide(w,valuePtr);
3188 } else if ((t1Ptr == &tclDoubleType)
3189 && (valuePtr->bytes == NULL)) {
3190 /*
3191 * We can only use the internal rep directly if there is
3192 * no string rep. Otherwise the string rep might actually
3193 * look like an integer, which is preferred.
3194 */
3195
3196 d1 = valuePtr->internalRep.doubleValue;
3197 } else {
3198 char *s = Tcl_GetStringFromObj(valuePtr, &length);
3199 if (TclLooksLikeInt(s, length)) {
3200 GET_WIDE_OR_INT(result, valuePtr, i, w);
3201 } else {
3202 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
3203 valuePtr, &d1);
3204 }
3205 if (result != TCL_OK) {
3206 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
3207 s, O2S(valuePtr),
3208 (valuePtr->typePtr?
3209 valuePtr->typePtr->name : "null")));
3210 DECACHE_STACK_INFO();
3211 IllegalExprOperandType(interp, pc, valuePtr);
3212 CACHE_STACK_INFO();
3213 goto checkForCatch;
3214 }
3215 t1Ptr = valuePtr->typePtr;
3216 }
3217
3218 if (t2Ptr == &tclIntType) {
3219 i2 = value2Ptr->internalRep.longValue;
3220 } else if (t2Ptr == &tclWideIntType) {
3221 TclGetWide(w2,value2Ptr);
3222 } else if ((t2Ptr == &tclDoubleType)
3223 && (value2Ptr->bytes == NULL)) {
3224 /*
3225 * We can only use the internal rep directly if there is
3226 * no string rep. Otherwise the string rep might actually
3227 * look like an integer, which is preferred.
3228 */
3229
3230 d2 = value2Ptr->internalRep.doubleValue;
3231 } else {
3232 char *s = Tcl_GetStringFromObj(value2Ptr, &length);
3233 if (TclLooksLikeInt(s, length)) {
3234 GET_WIDE_OR_INT(result, value2Ptr, i2, w2);
3235 } else {
3236 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
3237 value2Ptr, &d2);
3238 }
3239 if (result != TCL_OK) {
3240 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
3241 O2S(value2Ptr), s,
3242 (value2Ptr->typePtr?
3243 value2Ptr->typePtr->name : "null")));
3244 DECACHE_STACK_INFO();
3245 IllegalExprOperandType(interp, pc, value2Ptr);
3246 CACHE_STACK_INFO();
3247 goto checkForCatch;
3248 }
3249 t2Ptr = value2Ptr->typePtr;
3250 }
3251
3252 if ((t1Ptr == &tclDoubleType) || (t2Ptr == &tclDoubleType)) {
3253 /*
3254 * Do double arithmetic.
3255 */
3256 doDouble = 1;
3257 if (t1Ptr == &tclIntType) {
3258 d1 = i; /* promote value 1 to double */
3259 } else if (t2Ptr == &tclIntType) {
3260 d2 = i2; /* promote value 2 to double */
3261 } else if (t1Ptr == &tclWideIntType) {
3262 d1 = Tcl_WideAsDouble(w);
3263 } else if (t2Ptr == &tclWideIntType) {
3264 d2 = Tcl_WideAsDouble(w2);
3265 }
3266 switch (*pc) {
3267 case INST_ADD:
3268 dResult = d1 + d2;
3269 break;
3270 case INST_SUB:
3271 dResult = d1 - d2;
3272 break;
3273 case INST_MULT:
3274 dResult = d1 * d2;
3275 break;
3276 case INST_DIV:
3277 if (d2 == 0.0) {
3278 TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
3279 goto divideByZero;
3280 }
3281 dResult = d1 / d2;
3282 break;
3283 }
3284
3285 /*
3286 * Check now for IEEE floating-point error.
3287 */
3288
3289 if (IS_NAN(dResult) || IS_INF(dResult)) {
3290 TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
3291 O2S(valuePtr), O2S(value2Ptr)));
3292 DECACHE_STACK_INFO();
3293 TclExprFloatError(interp, dResult);
3294 CACHE_STACK_INFO();
3295 result = TCL_ERROR;
3296 goto checkForCatch;
3297 }
3298 } else if ((t1Ptr == &tclWideIntType)
3299 || (t2Ptr == &tclWideIntType)) {
3300 /*
3301 * Do wide integer arithmetic.
3302 */
3303 doWide = 1;
3304 if (t1Ptr == &tclIntType) {
3305 w = Tcl_LongAsWide(i);
3306 } else if (t2Ptr == &tclIntType) {
3307 w2 = Tcl_LongAsWide(i2);
3308 }
3309 switch (*pc) {
3310 case INST_ADD:
3311 wResult = w + w2;
3312 break;
3313 case INST_SUB:
3314 wResult = w - w2;
3315 break;
3316 case INST_MULT:
3317 wResult = w * w2;
3318 break;
3319 case INST_DIV:
3320 /*
3321 * This code is tricky: C doesn't guarantee much
3322 * about the quotient or remainder, but Tcl does.
3323 * The remainder always has the same sign as the
3324 * divisor and a smaller absolute value.
3325 */
3326 if (w2 == W0) {
3327 TRACE((LLD" "LLD" => DIVIDE BY ZERO\n", w, w2));
3328 goto divideByZero;
3329 }
3330 if (w2 < 0) {
3331 w2 = -w2;
3332 w = -w;
3333 }
3334 wquot = w / w2;
3335 wrem = w % w2;
3336 if (wrem < W0) {
3337 wquot -= 1;
3338 }
3339 wResult = wquot;
3340 break;
3341 }
3342 } else {
3343 /*
3344 * Do integer arithmetic.
3345 */
3346 switch (*pc) {
3347 case INST_ADD:
3348 iResult = i + i2;
3349 break;
3350 case INST_SUB:
3351 iResult = i - i2;
3352 break;
3353 case INST_MULT:
3354 iResult = i * i2;
3355 break;
3356 case INST_DIV:
3357 /*
3358 * This code is tricky: C doesn't guarantee much
3359 * about the quotient or remainder, but Tcl does.
3360 * The remainder always has the same sign as the
3361 * divisor and a smaller absolute value.
3362 */
3363 if (i2 == 0) {
3364 TRACE(("%ld %ld => DIVIDE BY ZERO\n", i, i2));
3365 goto divideByZero;
3366 }
3367 if (i2 < 0) {
3368 i2 = -i2;
3369 i = -i;
3370 }
3371 quot = i / i2;
3372 rem = i % i2;
3373 if (rem < 0) {
3374 quot -= 1;
3375 }
3376 iResult = quot;
3377 break;
3378 }
3379 }
3380
3381 /*
3382 * Reuse the valuePtr object already on stack if possible.
3383 */
3384
3385 if (Tcl_IsShared(valuePtr)) {
3386 if (doDouble) {
3387 objResultPtr = Tcl_NewDoubleObj(dResult);
3388 TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
3389 } else if (doWide) {
3390 objResultPtr = Tcl_NewWideIntObj(wResult);
3391 TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
3392 } else {
3393 objResultPtr = Tcl_NewLongObj(iResult);
3394 TRACE(("%ld %ld => %ld\n", i, i2, iResult));
3395 }
3396 NEXT_INST_F(1, 2, 1);
3397 } else { /* reuse the valuePtr object */
3398 if (doDouble) { /* NB: stack top is off by 1 */
3399 TRACE(("%.6g %.6g => %.6g\n", d1, d2, dResult));
3400 Tcl_SetDoubleObj(valuePtr, dResult);
3401 } else if (doWide) {
3402 TRACE((LLD" "LLD" => "LLD"\n", w, w2, wResult));
3403 Tcl_SetWideIntObj(valuePtr, wResult);
3404 } else {
3405 TRACE(("%ld %ld => %ld\n", i, i2, iResult));
3406 Tcl_SetLongObj(valuePtr, iResult);
3407 }
3408 NEXT_INST_F(1, 1, 0);
3409 }
3410 }
3411
3412 case INST_UPLUS:
3413 {
3414 /*
3415 * Operand must be numeric.
3416 */
3417
3418 double d;
3419 Tcl_ObjType *tPtr;
3420
3421 valuePtr = stackPtr[stackTop];
3422 tPtr = valuePtr->typePtr;
3423 if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
3424 || (valuePtr->bytes != NULL))) {
3425 char *s = Tcl_GetStringFromObj(valuePtr, &length);
3426 if (TclLooksLikeInt(s, length)) {
3427 GET_WIDE_OR_INT(result, valuePtr, i, w);
3428 } else {
3429 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, valuePtr, &d);
3430 }
3431 if (result != TCL_OK) {
3432 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n",
3433 s, (tPtr? tPtr->name : "null")));
3434 DECACHE_STACK_INFO();
3435 IllegalExprOperandType(interp, pc, valuePtr);
3436 CACHE_STACK_INFO();
3437 goto checkForCatch;
3438 }
3439 tPtr = valuePtr->typePtr;
3440 }
3441
3442 /*
3443 * Ensure that the operand's string rep is the same as the
3444 * formatted version of its internal rep. This makes sure
3445 * that "expr +000123" yields "83", not "000123". We
3446 * implement this by _discarding_ the string rep since we
3447 * know it will be regenerated, if needed later, by
3448 * formatting the internal rep's value.
3449 */
3450
3451 if (Tcl_IsShared(valuePtr)) {
3452 if (tPtr == &tclIntType) {
3453 i = valuePtr->internalRep.longValue;
3454 objResultPtr = Tcl_NewLongObj(i);
3455 } else if (tPtr == &tclWideIntType) {
3456 TclGetWide(w,valuePtr);
3457 objResultPtr = Tcl_NewWideIntObj(w);
3458 } else {
3459 d = valuePtr->internalRep.doubleValue;
3460 objResultPtr = Tcl_NewDoubleObj(d);
3461 }
3462 TRACE_WITH_OBJ(("%s => ", O2S(objResultPtr)), objResultPtr);
3463 NEXT_INST_F(1, 1, 1);
3464 } else {
3465 Tcl_InvalidateStringRep(valuePtr);
3466 TRACE_WITH_OBJ(("%s => ", O2S(valuePtr)), valuePtr);
3467 NEXT_INST_F(1, 0, 0);
3468 }
3469 }
3470
3471 case INST_UMINUS:
3472 case INST_LNOT:
3473 {
3474 /*
3475 * The operand must be numeric or a boolean string as
3476 * accepted by Tcl_GetBooleanFromObj(). If the operand
3477 * object is unshared modify it directly, otherwise
3478 * create a copy to modify: this is "copy on write".
3479 * Free any old string representation since it is now
3480 * invalid.
3481 */
3482
3483 double d;
3484 int boolvar;
3485 Tcl_ObjType *tPtr;
3486
3487 valuePtr = stackPtr[stackTop];
3488 tPtr = valuePtr->typePtr;
3489 if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
3490 || (valuePtr->bytes != NULL))) {
3491 if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
3492 valuePtr->typePtr = &tclIntType;
3493 } else {
3494 char *s = Tcl_GetStringFromObj(valuePtr, &length);
3495 if (TclLooksLikeInt(s, length)) {
3496 GET_WIDE_OR_INT(result, valuePtr, i, w);
3497 } else {
3498 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
3499 valuePtr, &d);
3500 }
3501 if (result == TCL_ERROR && *pc == INST_LNOT) {
3502 result = Tcl_GetBooleanFromObj((Tcl_Interp *)NULL,
3503 valuePtr, &boolvar);
3504 i = (long)boolvar; /* i is long, not int! */
3505 }
3506 if (result != TCL_OK) {
3507 TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
3508 s, (tPtr? tPtr->name : "null")));
3509 DECACHE_STACK_INFO();
3510 IllegalExprOperandType(interp, pc, valuePtr);
3511 CACHE_STACK_INFO();
3512 goto checkForCatch;
3513 }
3514 }
3515 tPtr = valuePtr->typePtr;
3516 }
3517
3518 if (Tcl_IsShared(valuePtr)) {
3519 /*
3520 * Create a new object.
3521 */
3522 if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
3523 i = valuePtr->internalRep.longValue;
3524 objResultPtr = Tcl_NewLongObj(
3525 (*pc == INST_UMINUS)? -i : !i);
3526 TRACE_WITH_OBJ(("%ld => ", i), objResultPtr);
3527 } else if (tPtr == &tclWideIntType) {
3528 TclGetWide(w,valuePtr);
3529 if (*pc == INST_UMINUS) {
3530 objResultPtr = Tcl_NewWideIntObj(-w);
3531 } else {
3532 objResultPtr = Tcl_NewLongObj(w == W0);
3533 }
3534 TRACE_WITH_OBJ((LLD" => ", w), objResultPtr);
3535 } else {
3536 d = valuePtr->internalRep.doubleValue;
3537 if (*pc == INST_UMINUS) {
3538 objResultPtr = Tcl_NewDoubleObj(-d);
3539 } else {
3540 /*
3541 * Should be able to use "!d", but apparently
3542 * some compilers can't handle it.
3543 */
3544 objResultPtr = Tcl_NewLongObj((d==0.0)? 1 : 0);
3545 }
3546 TRACE_WITH_OBJ(("%.6g => ", d), objResultPtr);
3547 }
3548 NEXT_INST_F(1, 1, 1);
3549 } else {
3550 /*
3551 * valuePtr is unshared. Modify it directly.
3552 */
3553 if ((tPtr == &tclIntType) || (tPtr == &tclBooleanType)) {
3554 i = valuePtr->internalRep.longValue;
3555 Tcl_SetLongObj(valuePtr,
3556 (*pc == INST_UMINUS)? -i : !i);
3557 TRACE_WITH_OBJ(("%ld => ", i), valuePtr);
3558 } else if (tPtr == &tclWideIntType) {
3559 TclGetWide(w,valuePtr);
3560 if (*pc == INST_UMINUS) {
3561 Tcl_SetWideIntObj(valuePtr, -w);
3562 } else {
3563 Tcl_SetLongObj(valuePtr, w == W0);
3564 }
3565 TRACE_WITH_OBJ((LLD" => ", w), valuePtr);
3566 } else {
3567 d = valuePtr->internalRep.doubleValue;
3568 if (*pc == INST_UMINUS) {
3569 Tcl_SetDoubleObj(valuePtr, -d);
3570 } else {
3571 /*
3572 * Should be able to use "!d", but apparently
3573 * some compilers can't handle it.
3574 */
3575 Tcl_SetLongObj(valuePtr, (d==0.0)? 1 : 0);
3576 }
3577 TRACE_WITH_OBJ(("%.6g => ", d), valuePtr);
3578 }
3579 NEXT_INST_F(1, 0, 0);
3580 }
3581 }
3582
3583 case INST_BITNOT:
3584 {
3585 /*
3586 * The operand must be an integer. If the operand object is
3587 * unshared modify it directly, otherwise modify a copy.
3588 * Free any old string representation since it is now
3589 * invalid.
3590 */
3591
3592 Tcl_ObjType *tPtr;
3593
3594 valuePtr = stackPtr[stackTop];
3595 tPtr = valuePtr->typePtr;
3596 if (!IS_INTEGER_TYPE(tPtr)) {
3597 REQUIRE_WIDE_OR_INT(result, valuePtr, i, w);
3598 if (result != TCL_OK) { /* try to convert to double */
3599 TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n",
3600 O2S(valuePtr), (tPtr? tPtr->name : "null")));
3601 DECACHE_STACK_INFO();
3602 IllegalExprOperandType(interp, pc, valuePtr);
3603 CACHE_STACK_INFO();
3604 goto checkForCatch;
3605 }
3606 }
3607
3608 if (valuePtr->typePtr == &tclWideIntType) {
3609 TclGetWide(w,valuePtr);
3610 if (Tcl_IsShared(valuePtr)) {
3611 objResultPtr = Tcl_NewWideIntObj(~w);
3612 TRACE(("0x%llx => (%llu)\n", w, ~w));
3613 NEXT_INST_F(1, 1, 1);
3614 } else {
3615 /*
3616 * valuePtr is unshared. Modify it directly.
3617 */
3618 Tcl_SetWideIntObj(valuePtr, ~w);
3619 TRACE(("0x%llx => (%llu)\n", w, ~w));
3620 NEXT_INST_F(1, 0, 0);
3621 }
3622 } else {
3623 i = valuePtr->internalRep.longValue;
3624 if (Tcl_IsShared(valuePtr)) {
3625 objResultPtr = Tcl_NewLongObj(~i);
3626 TRACE(("0x%lx => (%lu)\n", i, ~i));
3627 NEXT_INST_F(1, 1, 1);
3628 } else {
3629 /*
3630 * valuePtr is unshared. Modify it directly.
3631 */
3632 Tcl_SetLongObj(valuePtr, ~i);
3633 TRACE(("0x%lx => (%lu)\n", i, ~i));
3634 NEXT_INST_F(1, 0, 0);
3635 }
3636 }
3637 }
3638
3639 case INST_CALL_BUILTIN_FUNC1:
3640 opnd = TclGetUInt1AtPtr(pc+1);
3641 {
3642 /*
3643 * Call one of the built-in Tcl math functions.
3644 */
3645
3646 BuiltinFunc *mathFuncPtr;
3647
3648 if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
3649 TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
3650 panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
3651 }
3652 mathFuncPtr = &(tclBuiltinFuncTable[opnd]);
3653 DECACHE_STACK_INFO();
3654 result = (*mathFuncPtr->proc)(interp, eePtr,
3655 mathFuncPtr->clientData);
3656 CACHE_STACK_INFO();
3657 if (result != TCL_OK) {
3658 goto checkForCatch;
3659 }
3660 TRACE_WITH_OBJ(("%d => ", opnd), stackPtr[stackTop]);
3661 }
3662 NEXT_INST_F(2, 0, 0);
3663
3664 case INST_CALL_FUNC1:
3665 opnd = TclGetUInt1AtPtr(pc+1);
3666 {
3667 /*
3668 * Call a non-builtin Tcl math function previously
3669 * registered by a call to Tcl_CreateMathFunc.
3670 */
3671
3672 int objc = opnd; /* Number of arguments. The function name
3673 * is the 0-th argument. */
3674 Tcl_Obj **objv; /* The array of arguments. The function
3675 * name is objv[0]. */
3676
3677 objv = &(stackPtr[stackTop - (objc-1)]); /* "objv[0]" */
3678 DECACHE_STACK_INFO();
3679 result = ExprCallMathFunc(interp, eePtr, objc, objv);
3680 CACHE_STACK_INFO();
3681 if (result != TCL_OK) {
3682 goto checkForCatch;
3683 }
3684 TRACE_WITH_OBJ(("%d => ", objc), stackPtr[stackTop]);
3685 }
3686 NEXT_INST_F(2, 0, 0);
3687
3688 case INST_TRY_CVT_TO_NUMERIC:
3689 {
3690 /*
3691 * Try to convert the topmost stack object to an int or
3692 * double object. This is done in order to support Tcl's
3693 * policy of interpreting operands if at all possible as
3694 * first integers, else floating-point numbers.
3695 */
3696
3697 double d;
3698 char *s;
3699 Tcl_ObjType *tPtr;
3700 int converted, needNew;
3701
3702 valuePtr = stackPtr[stackTop];
3703 tPtr = valuePtr->typePtr;
3704 converted = 0;
3705 if (!IS_INTEGER_TYPE(tPtr) && ((tPtr != &tclDoubleType)
3706 || (valuePtr->bytes != NULL))) {
3707 if ((tPtr == &tclBooleanType) && (valuePtr->bytes == NULL)) {
3708 valuePtr->typePtr = &tclIntType;
3709 converted = 1;
3710 } else {
3711 s = Tcl_GetStringFromObj(valuePtr, &length);
3712 if (TclLooksLikeInt(s, length)) {
3713 GET_WIDE_OR_INT(result, valuePtr, i, w);
3714 } else {
3715 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL,
3716 valuePtr, &d);
3717 }
3718 if (result == TCL_OK) {
3719 converted = 1;
3720 }
3721 result = TCL_OK; /* reset the result variable */
3722 }
3723 tPtr = valuePtr->typePtr;
3724 }
3725
3726 /*
3727 * Ensure that the topmost stack object, if numeric, has a
3728 * string rep the same as the formatted version of its
3729 * internal rep. This is used, e.g., to make sure that "expr
3730 * {0001}" yields "1", not "0001". We implement this by
3731 * _discarding_ the string rep since we know it will be
3732 * regenerated, if needed later, by formatting the internal
3733 * rep's value. Also check if there has been an IEEE
3734 * floating point error.
3735 */
3736
3737 objResultPtr = valuePtr;
3738 needNew = 0;
3739 if (IS_NUMERIC_TYPE(tPtr)) {
3740 if (Tcl_IsShared(valuePtr)) {
3741 if (valuePtr->bytes != NULL) {
3742 /*
3743 * We only need to make a copy of the object
3744 * when it already had a string rep
3745 */
3746 needNew = 1;
3747 if (tPtr == &tclIntType) {
3748 i = valuePtr->internalRep.longValue;
3749 objResultPtr = Tcl_NewLongObj(i);
3750 } else if (tPtr == &tclWideIntType) {
3751 TclGetWide(w,valuePtr);
3752 objResultPtr = Tcl_NewWideIntObj(w);
3753 } else {
3754 d = valuePtr->internalRep.doubleValue;
3755 objResultPtr = Tcl_NewDoubleObj(d);
3756 }
3757 tPtr = objResultPtr->typePtr;
3758 }
3759 } else {
3760 Tcl_InvalidateStringRep(valuePtr);
3761 }
3762
3763 if (tPtr == &tclDoubleType) {
3764 d = objResultPtr->internalRep.doubleValue;
3765 if (IS_NAN(d) || IS_INF(d)) {
3766 TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
3767 O2S(objResultPtr)));
3768 DECACHE_STACK_INFO();
3769 TclExprFloatError(interp, d);
3770 CACHE_STACK_INFO();
3771 result = TCL_ERROR;
3772 goto checkForCatch;
3773 }
3774 }
3775 converted = converted; /* lint, converted not used. */
3776 TRACE(("\"%.20s\" => numeric, %s, %s\n", O2S(valuePtr),
3777 (converted? "converted" : "not converted"),
3778 (needNew? "new Tcl_Obj" : "same Tcl_Obj")));
3779 } else {
3780 TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
3781 }
3782 if (needNew) {
3783 NEXT_INST_F(1, 1, 1);
3784 } else {
3785 NEXT_INST_F(1, 0, 0);
3786 }
3787 }
3788
3789 case INST_BREAK:
3790 DECACHE_STACK_INFO();
3791 Tcl_ResetResult(interp);
3792 CACHE_STACK_INFO();
3793 result = TCL_BREAK;
3794 cleanup = 0;
3795 goto processExceptionReturn;
3796
3797 case INST_CONTINUE:
3798 DECACHE_STACK_INFO();
3799 Tcl_ResetResult(interp);
3800 CACHE_STACK_INFO();
3801 result = TCL_CONTINUE;
3802 cleanup = 0;
3803 goto processExceptionReturn;
3804
3805 case INST_FOREACH_START4:
3806 opnd = TclGetUInt4AtPtr(pc+1);
3807 {
3808 /*
3809 * Initialize the temporary local var that holds the count
3810 * of the number of iterations of the loop body to -1.
3811 */
3812
3813 ForeachInfo *infoPtr = (ForeachInfo *)
3814 codePtr->auxDataArrayPtr[opnd].clientData;
3815 int iterTmpIndex = infoPtr->loopCtTemp;
3816 Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
3817 Var *iterVarPtr = &(compiledLocals[iterTmpIndex]);
3818 Tcl_Obj *oldValuePtr = iterVarPtr->value.objPtr;
3819
3820 if (oldValuePtr == NULL) {
3821 iterVarPtr->value.objPtr = Tcl_NewLongObj(-1);
3822 Tcl_IncrRefCount(iterVarPtr->value.objPtr);
3823 } else {
3824 Tcl_SetLongObj(oldValuePtr, -1);
3825 }
3826 TclSetVarScalar(iterVarPtr);
3827 TclClearVarUndefined(iterVarPtr);
3828 TRACE(("%u => loop iter count temp %d\n",
3829 opnd, iterTmpIndex));
3830 }
3831
3832 #ifndef TCL_COMPILE_DEBUG
3833 /*
3834 * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4
3835 * immediately after INST_FOREACH_START4 - let us just fall
3836 * through instead of jumping back to the top.
3837 */
3838
3839 pc += 5;
3840 #else
3841 NEXT_INST_F(5, 0, 0);
3842 #endif
3843 case INST_FOREACH_STEP4:
3844 opnd = TclGetUInt4AtPtr(pc+1);
3845 {
3846 /*
3847 * "Step" a foreach loop (i.e., begin its next iteration) by
3848 * assigning the next value list element to each loop var.
3849 */
3850
3851 ForeachInfo *infoPtr = (ForeachInfo *)
3852 codePtr->auxDataArrayPtr[opnd].clientData;
3853 ForeachVarList *varListPtr;
3854 int numLists = infoPtr->numLists;
3855 Var *compiledLocals = iPtr->varFramePtr->compiledLocals;
3856 Tcl_Obj *listPtr;
3857 List *listRepPtr;
3858 Var *iterVarPtr, *listVarPtr;
3859 int iterNum, listTmpIndex, listLen, numVars;
3860 int varIndex, valIndex, continueLoop, j;
3861
3862 /*
3863 * Increment the temp holding the loop iteration number.
3864 */
3865
3866 iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
3867 valuePtr = iterVarPtr->value.objPtr;
3868 iterNum = (valuePtr->internalRep.longValue + 1);
3869 Tcl_SetLongObj(valuePtr, iterNum);
3870
3871 /*
3872 * Check whether all value lists are exhausted and we should
3873 * stop the loop.
3874 */
3875
3876 continueLoop = 0;
3877 listTmpIndex = infoPtr->firstValueTemp;
3878 for (i = 0; i < numLists; i++) {
3879 varListPtr = infoPtr->varLists[i];
3880 numVars = varListPtr->numVars;
3881
3882 listVarPtr = &(compiledLocals[listTmpIndex]);
3883 listPtr = listVarPtr->value.objPtr;
3884 result = Tcl_ListObjLength(interp, listPtr, &listLen);
3885 if (result != TCL_OK) {
3886 TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
3887 opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
3888 goto checkForCatch;
3889 }
3890 if (listLen > (iterNum * numVars)) {
3891 continueLoop = 1;
3892 }
3893 listTmpIndex++;
3894 }
3895
3896 /*
3897 * If some var in some var list still has a remaining list
3898 * element iterate one more time. Assign to var the next
3899 * element from its value list. We already checked above
3900 * that each list temp holds a valid list object.
3901 */
3902
3903 if (continueLoop) {
3904 listTmpIndex = infoPtr->firstValueTemp;
3905 for (i = 0; i < numLists; i++) {
3906 varListPtr = infoPtr->varLists[i];
3907 numVars = varListPtr->numVars;
3908
3909 listVarPtr = &(compiledLocals[listTmpIndex]);
3910 listPtr = listVarPtr->value.objPtr;
3911 listRepPtr = (List *) listPtr->internalRep.twoPtrValue.ptr1;
3912 listLen = listRepPtr->elemCount;
3913
3914 valIndex = (iterNum * numVars);
3915 for (j = 0; j < numVars; j++) {
3916 int setEmptyStr = 0;
3917 if (valIndex >= listLen) {
3918 setEmptyStr = 1;
3919 TclNewObj(valuePtr);
3920 } else {
3921 valuePtr = listRepPtr->elements[valIndex];
3922 }
3923
3924 varIndex = varListPtr->varIndexes[j];
3925 varPtr = &(varFramePtr->compiledLocals[varIndex]);
3926 part1 = varPtr->name;
3927 while (TclIsVarLink(varPtr)) {
3928 varPtr = varPtr->value.linkPtr;
3929 }
3930 if (!((varPtr->flags & VAR_IN_HASHTABLE) && (varPtr->hPtr == NULL))
3931 && (varPtr->tracePtr == NULL)
3932 && (TclIsVarScalar(varPtr) || TclIsVarUndefined(varPtr))) {
3933 value2Ptr = varPtr->value.objPtr;
3934 if (valuePtr != value2Ptr) {
3935 if (value2Ptr != NULL) {
3936 TclDecrRefCount(value2Ptr);
3937 } else {
3938 TclSetVarScalar(varPtr);
3939 TclClearVarUndefined(varPtr);
3940 }
3941 varPtr->value.objPtr = valuePtr;
3942 Tcl_IncrRefCount(valuePtr);
3943 }
3944 } else {
3945 DECACHE_STACK_INFO();
3946 value2Ptr = TclPtrSetVar(interp, varPtr, NULL, part1,
3947 NULL, valuePtr, TCL_LEAVE_ERR_MSG);
3948 CACHE_STACK_INFO();
3949 if (value2Ptr == NULL) {
3950 TRACE_WITH_OBJ(("%u => ERROR init. index temp %d: ",
3951 opnd, varIndex),
3952 Tcl_GetObjResult(interp));
3953 if (setEmptyStr) {
3954 TclDecrRefCount(valuePtr);
3955 }
3956 result = TCL_ERROR;
3957 goto checkForCatch;
3958 }
3959 }
3960 valIndex++;
3961 }
3962 listTmpIndex++;
3963 }
3964 }
3965 TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
3966 iterNum, (continueLoop? "continue" : "exit")));
3967
3968 /*
3969 * Run-time peep-hole optimisation: the compiler ALWAYS follows
3970 * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
3971 * instruction and jump direct from here.
3972 */
3973
3974 pc += 5;
3975 if (*pc == INST_JUMP_FALSE1) {
3976 NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
3977 } else {
3978 NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
3979 }
3980 }
3981
3982 case INST_BEGIN_CATCH4:
3983 /*
3984 * Record start of the catch command with exception range index
3985 * equal to the operand. Push the current stack depth onto the
3986 * special catch stack.
3987 */
3988 catchStackPtr[++catchTop] = stackTop;
3989 TRACE(("%u => catchTop=%d, stackTop=%d\n",
3990 TclGetUInt4AtPtr(pc+1), catchTop, stackTop));
3991 NEXT_INST_F(5, 0, 0);
3992
3993 case INST_END_CATCH:
3994 catchTop--;
3995 result = TCL_OK;
3996 TRACE(("=> catchTop=%d\n", catchTop));
3997 NEXT_INST_F(1, 0, 0);
3998
3999 case INST_PUSH_RESULT:
4000 objResultPtr = Tcl_GetObjResult(interp);
4001 TRACE_WITH_OBJ(("=> "), Tcl_GetObjResult(interp));
4002
4003 /*
4004 * See the comments at INST_INVOKE_STK
4005 */
4006 {
4007 Tcl_Obj *newObjResultPtr;
4008 TclNewObj(newObjResultPtr);
4009 Tcl_IncrRefCount(newObjResultPtr);
4010 iPtr->objResultPtr = newObjResultPtr;
4011 }
4012
4013 NEXT_INST_F(1, 0, -1);
4014
4015 case INST_PUSH_RETURN_CODE:
4016 objResultPtr = Tcl_NewLongObj(result);
4017 TRACE(("=> %u\n", result));
4018 NEXT_INST_F(1, 0, 1);
4019
4020 default:
4021 panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
4022 } /* end of switch on opCode */
4023
4024 /*
4025 * Division by zero in an expression. Control only reaches this
4026 * point by "goto divideByZero".
4027 */
4028
4029 divideByZero:
4030 DECACHE_STACK_INFO();
4031 Tcl_ResetResult(interp);
4032 Tcl_AppendToObj(Tcl_GetObjResult(interp), "divide by zero", -1);
4033 Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero",
4034 (char *) NULL);
4035 CACHE_STACK_INFO();
4036
4037 result = TCL_ERROR;
4038 goto checkForCatch;
4039
4040 /*
4041 * An external evaluation (INST_INVOKE or INST_EVAL) returned
4042 * something different from TCL_OK, or else INST_BREAK or
4043 * INST_CONTINUE were called.
4044 */
4045
4046 processExceptionReturn:
4047 #if TCL_COMPILE_DEBUG
4048 switch (*pc) {
4049 case INST_INVOKE_STK1:
4050 case INST_INVOKE_STK4:
4051 TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
4052 break;
4053 case INST_EVAL_STK:
4054 /*
4055 * Note that the object at stacktop has to be used
4056 * before doing the cleanup.
4057 */
4058
4059 TRACE(("\"%.30s\" => ", O2S(stackPtr[stackTop])));
4060 break;
4061 default:
4062 TRACE(("=> "));
4063 }
4064 #endif
4065 if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
4066 rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 0, codePtr);
4067 if (rangePtr == NULL) {
4068 TRACE_APPEND(("no encl. loop or catch, returning %s\n",
4069 StringForResultCode(result)));
4070 goto abnormalReturn;
4071 }
4072 if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
4073 TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
4074 goto processCatch;
4075 }
4076 while (cleanup--) {
4077 valuePtr = POP_OBJECT();
4078 TclDecrRefCount(valuePtr);
4079 }
4080 if (result == TCL_BREAK) {
4081 result = TCL_OK;
4082 pc = (codePtr->codeStart + rangePtr->breakOffset);
4083 TRACE_APPEND(("%s, range at %d, new pc %d\n",
4084 StringForResultCode(result),
4085 rangePtr->codeOffset, rangePtr->breakOffset));
4086 NEXT_INST_F(0, 0, 0);
4087 } else {
4088 if (rangePtr->continueOffset == -1) {
4089 TRACE_APPEND(("%s, loop w/o continue, checking for catch\n",
4090 StringForResultCode(result)));
4091 goto checkForCatch;
4092 }
4093 result = TCL_OK;
4094 pc = (codePtr->codeStart + rangePtr->continueOffset);
4095 TRACE_APPEND(("%s, range at %d, new pc %d\n",
4096 StringForResultCode(result),
4097 rangePtr->codeOffset, rangePtr->continueOffset));
4098 NEXT_INST_F(0, 0, 0);
4099 }
4100 #if TCL_COMPILE_DEBUG
4101 } else if (traceInstructions) {
4102 if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
4103 objPtr = Tcl_GetObjResult(interp);
4104 TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
4105 result, O2S(objPtr)));
4106 } else {
4107 objPtr = Tcl_GetObjResult(interp);
4108 TRACE_APPEND(("%s, result= \"%s\"\n",
4109 StringForResultCode(result), O2S(objPtr)));
4110 }
4111 #endif
4112 }
4113
4114 /*
4115 * Execution has generated an "exception" such as TCL_ERROR. If the
4116 * exception is an error, record information about what was being
4117 * executed when the error occurred. Find the closest enclosing
4118 * catch range, if any. If no enclosing catch range is found, stop
4119 * execution and return the "exception" code.
4120 */
4121
4122 checkForCatch:
4123 if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
4124 bytes = GetSrcInfoForPc(pc, codePtr, &length);
4125 if (bytes != NULL) {
4126 DECACHE_STACK_INFO();
4127 Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
4128 CACHE_STACK_INFO();
4129 iPtr->flags |= ERR_ALREADY_LOGGED;
4130 }
4131 }
4132 if (catchTop == -1) {
4133 #ifdef TCL_COMPILE_DEBUG
4134 if (traceInstructions) {
4135 fprintf(stdout, " ... no enclosing catch, returning %s\n",
4136 StringForResultCode(result));
4137 }
4138 #endif
4139 goto abnormalReturn;
4140 }
4141 rangePtr = GetExceptRangeForPc(pc, /*catchOnly*/ 1, codePtr);
4142 if (rangePtr == NULL) {
4143 /*
4144 * This is only possible when compiling a [catch] that sends its
4145 * script to INST_EVAL. Cannot correct the compiler without
4146 * breakingcompat with previous .tbc compiled scripts.
4147 */
4148 #ifdef TCL_COMPILE_DEBUG
4149 if (traceInstructions) {
4150 fprintf(stdout, " ... no enclosing catch, returning %s\n",
4151 StringForResultCode(result));
4152 }
4153 #endif
4154 goto abnormalReturn;
4155 }
4156
4157 /*
4158 * A catch exception range (rangePtr) was found to handle an
4159 * "exception". It was found either by checkForCatch just above or
4160 * by an instruction during break, continue, or error processing.
4161 * Jump to its catchOffset after unwinding the operand stack to
4162 * the depth it had when starting to execute the range's catch
4163 * command.
4164 */
4165
4166 processCatch:
4167 while (stackTop > catchStackPtr[catchTop]) {
4168 valuePtr = POP_OBJECT();
4169 TclDecrRefCount(valuePtr);
4170 }
4171 #ifdef TCL_COMPILE_DEBUG
4172 if (traceInstructions) {
4173 fprintf(stdout, " ... found catch at %d, catchTop=%d, unwound to %d, new pc %u\n",
4174 rangePtr->codeOffset, catchTop, catchStackPtr[catchTop],
4175 (unsigned int)(rangePtr->catchOffset));
4176 }
4177 #endif
4178 pc = (codePtr->codeStart + rangePtr->catchOffset);
4179 NEXT_INST_F(0, 0, 0); /* restart the execution loop at pc */
4180
4181 /*
4182 * end of infinite loop dispatching on instructions.
4183 */
4184
4185 /*
4186 * Abnormal return code. Restore the stack to state it had when starting
4187 * to execute the ByteCode. Panic if the stack is below the initial level.
4188 */
4189
4190 abnormalReturn:
4191 while (stackTop > initStackTop) {
4192 valuePtr = POP_OBJECT();
4193 TclDecrRefCount(valuePtr);
4194 }
4195 if (stackTop < initStackTop) {
4196 fprintf(stderr, "\nTclExecuteByteCode: abnormal return at pc %u: stack top %d < entry stack top %d\n",
4197 (unsigned int)(pc - codePtr->codeStart),
4198 (unsigned int) stackTop,
4199 (unsigned int) initStackTop);
4200 panic("TclExecuteByteCode execution failure: end stack top < start stack top");
4201 }
4202
4203 /*
4204 * Free the catch stack array if malloc'ed storage was used.
4205 */
4206
4207 if (catchStackPtr != catchStackStorage) {
4208 ckfree((char *) catchStackPtr);
4209 }
4210 eePtr->stackTop = initStackTop;
4211 return result;
4212 #undef STATIC_CATCH_STACK_SIZE
4213 }
4214
4215 #ifdef TCL_COMPILE_DEBUG
4216 /*
4217 *----------------------------------------------------------------------
4218 *
4219 * PrintByteCodeInfo --
4220 *
4221 * This procedure prints a summary about a bytecode object to stdout.
4222 * It is called by TclExecuteByteCode when starting to execute the
4223 * bytecode object if tclTraceExec has the value 2 or more.
4224 *
4225 * Results:
4226 * None.
4227 *
4228 * Side effects:
4229 * None.
4230 *
4231 *----------------------------------------------------------------------
4232 */
4233
4234 static void
PrintByteCodeInfo(codePtr)4235 PrintByteCodeInfo(codePtr)
4236 register ByteCode *codePtr; /* The bytecode whose summary is printed
4237 * to stdout. */
4238 {
4239 Proc *procPtr = codePtr->procPtr;
4240 Interp *iPtr = (Interp *) *codePtr->interpHandle;
4241
4242 fprintf(stdout, "\nExecuting ByteCode 0x%x, refCt %u, epoch %u, interp 0x%x (epoch %u)\n",
4243 (unsigned int) codePtr, codePtr->refCount,
4244 codePtr->compileEpoch, (unsigned int) iPtr,
4245 iPtr->compileEpoch);
4246
4247 fprintf(stdout, " Source: ");
4248 TclPrintSource(stdout, codePtr->source, 60);
4249
4250 fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
4251 codePtr->numCommands, codePtr->numSrcBytes,
4252 codePtr->numCodeBytes, codePtr->numLitObjects,
4253 codePtr->numAuxDataItems, codePtr->maxStackDepth,
4254 #ifdef TCL_COMPILE_STATS
4255 (codePtr->numSrcBytes?
4256 ((float)codePtr->structureSize)/((float)codePtr->numSrcBytes) : 0.0));
4257 #else
4258 0.0);
4259 #endif
4260 #ifdef TCL_COMPILE_STATS
4261 fprintf(stdout, " Code %d = header %d+inst %d+litObj %d+exc %d+aux %d+cmdMap %d\n",
4262 codePtr->structureSize,
4263 (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time))),
4264 codePtr->numCodeBytes,
4265 (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
4266 (codePtr->numExceptRanges * sizeof(ExceptionRange)),
4267 (codePtr->numAuxDataItems * sizeof(AuxData)),
4268 codePtr->numCmdLocBytes);
4269 #endif /* TCL_COMPILE_STATS */
4270 if (procPtr != NULL) {
4271 fprintf(stdout,
4272 " Proc 0x%x, refCt %d, args %d, compiled locals %d\n",
4273 (unsigned int) procPtr, procPtr->refCount,
4274 procPtr->numArgs, procPtr->numCompiledLocals);
4275 }
4276 }
4277 #endif /* TCL_COMPILE_DEBUG */
4278
4279 /*
4280 *----------------------------------------------------------------------
4281 *
4282 * ValidatePcAndStackTop --
4283 *
4284 * This procedure is called by TclExecuteByteCode when debugging to
4285 * verify that the program counter and stack top are valid during
4286 * execution.
4287 *
4288 * Results:
4289 * None.
4290 *
4291 * Side effects:
4292 * Prints a message to stderr and panics if either the pc or stack
4293 * top are invalid.
4294 *
4295 *----------------------------------------------------------------------
4296 */
4297
4298 #ifdef TCL_COMPILE_DEBUG
4299 static void
ValidatePcAndStackTop(codePtr,pc,stackTop,stackLowerBound)4300 ValidatePcAndStackTop(codePtr, pc, stackTop, stackLowerBound)
4301 register ByteCode *codePtr; /* The bytecode whose summary is printed
4302 * to stdout. */
4303 unsigned char *pc; /* Points to first byte of a bytecode
4304 * instruction. The program counter. */
4305 int stackTop; /* Current stack top. Must be between
4306 * stackLowerBound and stackUpperBound
4307 * (inclusive). */
4308 int stackLowerBound; /* Smallest legal value for stackTop. */
4309 {
4310 int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
4311 /* Greatest legal value for stackTop. */
4312 unsigned int relativePc = (unsigned int) (pc - codePtr->codeStart);
4313 unsigned int codeStart = (unsigned int) codePtr->codeStart;
4314 unsigned int codeEnd = (unsigned int)
4315 (codePtr->codeStart + codePtr->numCodeBytes);
4316 unsigned char opCode = *pc;
4317
4318 if (((unsigned int) pc < codeStart) || ((unsigned int) pc > codeEnd)) {
4319 fprintf(stderr, "\nBad instruction pc 0x%x in TclExecuteByteCode\n",
4320 (unsigned int) pc);
4321 panic("TclExecuteByteCode execution failure: bad pc");
4322 }
4323 if ((unsigned int) opCode > LAST_INST_OPCODE) {
4324 fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
4325 (unsigned int) opCode, relativePc);
4326 panic("TclExecuteByteCode execution failure: bad opcode");
4327 }
4328 if ((stackTop < stackLowerBound) || (stackTop > stackUpperBound)) {
4329 int numChars;
4330 char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
4331 char *ellipsis = "";
4332
4333 fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
4334 stackTop, relativePc, stackLowerBound, stackUpperBound);
4335 if (cmd != NULL) {
4336 if (numChars > 100) {
4337 numChars = 100;
4338 ellipsis = "...";
4339 }
4340 fprintf(stderr, "\n executing %.*s%s\n", numChars, cmd,
4341 ellipsis);
4342 } else {
4343 fprintf(stderr, "\n");
4344 }
4345 panic("TclExecuteByteCode execution failure: bad stack top");
4346 }
4347 }
4348 #endif /* TCL_COMPILE_DEBUG */
4349
4350 /*
4351 *----------------------------------------------------------------------
4352 *
4353 * IllegalExprOperandType --
4354 *
4355 * Used by TclExecuteByteCode to add an error message to errorInfo
4356 * when an illegal operand type is detected by an expression
4357 * instruction. The argument opndPtr holds the operand object in error.
4358 *
4359 * Results:
4360 * None.
4361 *
4362 * Side effects:
4363 * An error message is appended to errorInfo.
4364 *
4365 *----------------------------------------------------------------------
4366 */
4367
4368 static void
IllegalExprOperandType(interp,pc,opndPtr)4369 IllegalExprOperandType(interp, pc, opndPtr)
4370 Tcl_Interp *interp; /* Interpreter to which error information
4371 * pertains. */
4372 unsigned char *pc; /* Points to the instruction being executed
4373 * when the illegal type was found. */
4374 Tcl_Obj *opndPtr; /* Points to the operand holding the value
4375 * with the illegal type. */
4376 {
4377 unsigned char opCode = *pc;
4378
4379 Tcl_ResetResult(interp);
4380 if ((opndPtr->bytes == NULL) || (opndPtr->length == 0)) {
4381 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
4382 "can't use empty string as operand of \"",
4383 operatorStrings[opCode - INST_LOR], "\"", (char *) NULL);
4384 } else {
4385 char *msg = "non-numeric string";
4386 char *s, *p;
4387 int length;
4388 int looksLikeInt = 0;
4389
4390 s = Tcl_GetStringFromObj(opndPtr, &length);
4391 p = s;
4392 /*
4393 * strtod() isn't at all consistent about detecting Inf and
4394 * NaN between platforms.
4395 */
4396 if (length == 3) {
4397 if ((s[0]=='n' || s[0]=='N') && (s[1]=='a' || s[1]=='A') &&
4398 (s[2]=='n' || s[2]=='N')) {
4399 msg = "non-numeric floating-point value";
4400 goto makeErrorMessage;
4401 }
4402 if ((s[0]=='i' || s[0]=='I') && (s[1]=='n' || s[1]=='N') &&
4403 (s[2]=='f' || s[2]=='F')) {
4404 msg = "infinite floating-point value";
4405 goto makeErrorMessage;
4406 }
4407 }
4408
4409 /*
4410 * We cannot use TclLooksLikeInt here because it passes strings
4411 * like "10;" [Bug 587140]. We'll accept as "looking like ints"
4412 * for the present purposes any string that looks formally like
4413 * a (decimal|octal|hex) integer.
4414 */
4415
4416 while (length && isspace(UCHAR(*p))) {
4417 length--;
4418 p++;
4419 }
4420 if (length && ((*p == '+') || (*p == '-'))) {
4421 length--;
4422 p++;
4423 }
4424 if (length) {
4425 if ((*p == '0') && ((*(p+1) == 'x') || (*(p+1) == 'X'))) {
4426 p += 2;
4427 length -= 2;
4428 looksLikeInt = ((length > 0) && isxdigit(UCHAR(*p)));
4429 if (looksLikeInt) {
4430 length--;
4431 p++;
4432 while (length && isxdigit(UCHAR(*p))) {
4433 length--;
4434 p++;
4435 }
4436 }
4437 } else {
4438 looksLikeInt = (length && isdigit(UCHAR(*p)));
4439 if (looksLikeInt) {
4440 length--;
4441 p++;
4442 while (length && isdigit(UCHAR(*p))) {
4443 length--;
4444 p++;
4445 }
4446 }
4447 }
4448 while (length && isspace(UCHAR(*p))) {
4449 length--;
4450 p++;
4451 }
4452 looksLikeInt = !length;
4453 }
4454 if (looksLikeInt) {
4455 /*
4456 * If something that looks like an integer could not be
4457 * converted, then it *must* be a bad octal or too large
4458 * to represent [Bug 542588].
4459 */
4460
4461 if (TclCheckBadOctal(NULL, s)) {
4462 msg = "invalid octal number";
4463 } else {
4464 msg = "integer value too large to represent";
4465 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
4466 "integer value too large to represent", (char *) NULL);
4467 }
4468 } else {
4469 /*
4470 * See if the operand can be interpreted as a double in
4471 * order to improve the error message.
4472 */
4473
4474 double d;
4475
4476 if (Tcl_GetDouble((Tcl_Interp *) NULL, s, &d) == TCL_OK) {
4477 msg = "floating-point value";
4478 }
4479 }
4480 makeErrorMessage:
4481 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp), "can't use ",
4482 msg, " as operand of \"", operatorStrings[opCode - INST_LOR],
4483 "\"", (char *) NULL);
4484 }
4485 }
4486
4487 /*
4488 *----------------------------------------------------------------------
4489 *
4490 * GetSrcInfoForPc --
4491 *
4492 * Given a program counter value, finds the closest command in the
4493 * bytecode code unit's CmdLocation array and returns information about
4494 * that command's source: a pointer to its first byte and the number of
4495 * characters.
4496 *
4497 * Results:
4498 * If a command is found that encloses the program counter value, a
4499 * pointer to the command's source is returned and the length of the
4500 * source is stored at *lengthPtr. If multiple commands resulted in
4501 * code at pc, information about the closest enclosing command is
4502 * returned. If no matching command is found, NULL is returned and
4503 * *lengthPtr is unchanged.
4504 *
4505 * Side effects:
4506 * None.
4507 *
4508 *----------------------------------------------------------------------
4509 */
4510
4511 static char *
GetSrcInfoForPc(pc,codePtr,lengthPtr)4512 GetSrcInfoForPc(pc, codePtr, lengthPtr)
4513 unsigned char *pc; /* The program counter value for which to
4514 * return the closest command's source info.
4515 * This points to a bytecode instruction
4516 * in codePtr's code. */
4517 ByteCode *codePtr; /* The bytecode sequence in which to look
4518 * up the command source for the pc. */
4519 int *lengthPtr; /* If non-NULL, the location where the
4520 * length of the command's source should be
4521 * stored. If NULL, no length is stored. */
4522 {
4523 register int pcOffset = (pc - codePtr->codeStart);
4524 int numCmds = codePtr->numCommands;
4525 unsigned char *codeDeltaNext, *codeLengthNext;
4526 unsigned char *srcDeltaNext, *srcLengthNext;
4527 int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
4528 int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
4529 int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
4530 int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
4531
4532 if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
4533 return NULL;
4534 }
4535
4536 /*
4537 * Decode the code and source offset and length for each command. The
4538 * closest enclosing command is the last one whose code started before
4539 * pcOffset.
4540 */
4541
4542 codeDeltaNext = codePtr->codeDeltaStart;
4543 codeLengthNext = codePtr->codeLengthStart;
4544 srcDeltaNext = codePtr->srcDeltaStart;
4545 srcLengthNext = codePtr->srcLengthStart;
4546 codeOffset = srcOffset = 0;
4547 for (i = 0; i < numCmds; i++) {
4548 if ((unsigned int) (*codeDeltaNext) == (unsigned int) 0xFF) {
4549 codeDeltaNext++;
4550 delta = TclGetInt4AtPtr(codeDeltaNext);
4551 codeDeltaNext += 4;
4552 } else {
4553 delta = TclGetInt1AtPtr(codeDeltaNext);
4554 codeDeltaNext++;
4555 }
4556 codeOffset += delta;
4557
4558 if ((unsigned int) (*codeLengthNext) == (unsigned int) 0xFF) {
4559 codeLengthNext++;
4560 codeLen = TclGetInt4AtPtr(codeLengthNext);
4561 codeLengthNext += 4;
4562 } else {
4563 codeLen = TclGetInt1AtPtr(codeLengthNext);
4564 codeLengthNext++;
4565 }
4566 codeEnd = (codeOffset + codeLen - 1);
4567
4568 if ((unsigned int) (*srcDeltaNext) == (unsigned int) 0xFF) {
4569 srcDeltaNext++;
4570 delta = TclGetInt4AtPtr(srcDeltaNext);
4571 srcDeltaNext += 4;
4572 } else {
4573 delta = TclGetInt1AtPtr(srcDeltaNext);
4574 srcDeltaNext++;
4575 }
4576 srcOffset += delta;
4577
4578 if ((unsigned int) (*srcLengthNext) == (unsigned int) 0xFF) {
4579 srcLengthNext++;
4580 srcLen = TclGetInt4AtPtr(srcLengthNext);
4581 srcLengthNext += 4;
4582 } else {
4583 srcLen = TclGetInt1AtPtr(srcLengthNext);
4584 srcLengthNext++;
4585 }
4586
4587 if (codeOffset > pcOffset) { /* best cmd already found */
4588 break;
4589 } else if (pcOffset <= codeEnd) { /* this cmd's code encloses pc */
4590 int dist = (pcOffset - codeOffset);
4591 if (dist <= bestDist) {
4592 bestDist = dist;
4593 bestSrcOffset = srcOffset;
4594 bestSrcLength = srcLen;
4595 }
4596 }
4597 }
4598
4599 if (bestDist == INT_MAX) {
4600 return NULL;
4601 }
4602
4603 if (lengthPtr != NULL) {
4604 *lengthPtr = bestSrcLength;
4605 }
4606 return (codePtr->source + bestSrcOffset);
4607 }
4608
4609 /*
4610 *----------------------------------------------------------------------
4611 *
4612 * GetExceptRangeForPc --
4613 *
4614 * Given a program counter value, return the closest enclosing
4615 * ExceptionRange.
4616 *
4617 * Results:
4618 * In the normal case, catchOnly is 0 (false) and this procedure
4619 * returns a pointer to the most closely enclosing ExceptionRange
4620 * structure regardless of whether it is a loop or catch exception
4621 * range. This is appropriate when processing a TCL_BREAK or
4622 * TCL_CONTINUE, which will be "handled" either by a loop exception
4623 * range or a closer catch range. If catchOnly is nonzero, this
4624 * procedure ignores loop exception ranges and returns a pointer to the
4625 * closest catch range. If no matching ExceptionRange is found that
4626 * encloses pc, a NULL is returned.
4627 *
4628 * Side effects:
4629 * None.
4630 *
4631 *----------------------------------------------------------------------
4632 */
4633
4634 static ExceptionRange *
GetExceptRangeForPc(pc,catchOnly,codePtr)4635 GetExceptRangeForPc(pc, catchOnly, codePtr)
4636 unsigned char *pc; /* The program counter value for which to
4637 * search for a closest enclosing exception
4638 * range. This points to a bytecode
4639 * instruction in codePtr's code. */
4640 int catchOnly; /* If 0, consider either loop or catch
4641 * ExceptionRanges in search. If nonzero
4642 * consider only catch ranges (and ignore
4643 * any closer loop ranges). */
4644 ByteCode* codePtr; /* Points to the ByteCode in which to search
4645 * for the enclosing ExceptionRange. */
4646 {
4647 ExceptionRange *rangeArrayPtr;
4648 int numRanges = codePtr->numExceptRanges;
4649 register ExceptionRange *rangePtr;
4650 int pcOffset = (pc - codePtr->codeStart);
4651 register int start;
4652
4653 if (numRanges == 0) {
4654 return NULL;
4655 }
4656
4657 /*
4658 * This exploits peculiarities of our compiler: nested ranges
4659 * are always *after* their containing ranges, so that by scanning
4660 * backwards we are sure that the first matching range is indeed
4661 * the deepest.
4662 */
4663
4664 rangeArrayPtr = codePtr->exceptArrayPtr;
4665 rangePtr = rangeArrayPtr + numRanges;
4666 while (--rangePtr >= rangeArrayPtr) {
4667 start = rangePtr->codeOffset;
4668 if ((start <= pcOffset) &&
4669 (pcOffset < (start + rangePtr->numCodeBytes))) {
4670 if ((!catchOnly)
4671 || (rangePtr->type == CATCH_EXCEPTION_RANGE)) {
4672 return rangePtr;
4673 }
4674 }
4675 }
4676 return NULL;
4677 }
4678
4679 /*
4680 *----------------------------------------------------------------------
4681 *
4682 * GetOpcodeName --
4683 *
4684 * This procedure is called by the TRACE and TRACE_WITH_OBJ macros
4685 * used in TclExecuteByteCode when debugging. It returns the name of
4686 * the bytecode instruction at a specified instruction pc.
4687 *
4688 * Results:
4689 * A character string for the instruction.
4690 *
4691 * Side effects:
4692 * None.
4693 *
4694 *----------------------------------------------------------------------
4695 */
4696
4697 #ifdef TCL_COMPILE_DEBUG
4698 static char *
GetOpcodeName(pc)4699 GetOpcodeName(pc)
4700 unsigned char *pc; /* Points to the instruction whose name
4701 * should be returned. */
4702 {
4703 unsigned char opCode = *pc;
4704
4705 return tclInstructionTable[opCode].name;
4706 }
4707 #endif /* TCL_COMPILE_DEBUG */
4708
4709 /*
4710 *----------------------------------------------------------------------
4711 *
4712 * VerifyExprObjType --
4713 *
4714 * This procedure is called by the math functions to verify that
4715 * the object is either an int or double, coercing it if necessary.
4716 * If an error occurs during conversion, an error message is left
4717 * in the interpreter's result unless "interp" is NULL.
4718 *
4719 * Results:
4720 * TCL_OK if it was int or double, TCL_ERROR otherwise
4721 *
4722 * Side effects:
4723 * objPtr is ensured to be of tclIntType, tclWideIntType or
4724 * tclDoubleType.
4725 *
4726 *----------------------------------------------------------------------
4727 */
4728
4729 static int
VerifyExprObjType(interp,objPtr)4730 VerifyExprObjType(interp, objPtr)
4731 Tcl_Interp *interp; /* The interpreter in which to execute the
4732 * function. */
4733 Tcl_Obj *objPtr; /* Points to the object to type check. */
4734 {
4735 if (IS_NUMERIC_TYPE(objPtr->typePtr)) {
4736 return TCL_OK;
4737 } else {
4738 int length, result = TCL_OK;
4739 char *s = Tcl_GetStringFromObj(objPtr, &length);
4740
4741 if (TclLooksLikeInt(s, length)) {
4742 Tcl_WideInt w;
4743 result = Tcl_GetWideIntFromObj((Tcl_Interp *) NULL, objPtr, &w);
4744 } else {
4745 double d;
4746 result = Tcl_GetDoubleFromObj((Tcl_Interp *) NULL, objPtr, &d);
4747 }
4748 if ((result != TCL_OK) && (interp != NULL)) {
4749 Tcl_ResetResult(interp);
4750 if (TclCheckBadOctal((Tcl_Interp *) NULL, s)) {
4751 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4752 "argument to math function was an invalid octal number",
4753 -1);
4754 } else {
4755 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4756 "argument to math function didn't have numeric value",
4757 -1);
4758 }
4759 }
4760 return result;
4761 }
4762 }
4763
4764 /*
4765 *----------------------------------------------------------------------
4766 *
4767 * Math Functions --
4768 *
4769 * This page contains the procedures that implement all of the
4770 * built-in math functions for expressions.
4771 *
4772 * Results:
4773 * Each procedure returns TCL_OK if it succeeds and pushes an
4774 * Tcl object holding the result. If it fails it returns TCL_ERROR
4775 * and leaves an error message in the interpreter's result.
4776 *
4777 * Side effects:
4778 * None.
4779 *
4780 *----------------------------------------------------------------------
4781 */
4782
4783 static int
ExprUnaryFunc(interp,eePtr,clientData)4784 ExprUnaryFunc(interp, eePtr, clientData)
4785 Tcl_Interp *interp; /* The interpreter in which to execute the
4786 * function. */
4787 ExecEnv *eePtr; /* Points to the environment for executing
4788 * the function. */
4789 ClientData clientData; /* Contains the address of a procedure that
4790 * takes one double argument and returns a
4791 * double result. */
4792 {
4793 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
4794 register int stackTop; /* Cached top index of evaluation stack. */
4795 register Tcl_Obj *valuePtr;
4796 double d, dResult;
4797 int result;
4798
4799 double (*func) _ANSI_ARGS_((double)) =
4800 (double (*)_ANSI_ARGS_((double))) clientData;
4801
4802 /*
4803 * Set stackPtr and stackTop from eePtr.
4804 */
4805
4806 result = TCL_OK;
4807 CACHE_STACK_INFO();
4808
4809 /*
4810 * Pop the function's argument from the evaluation stack. Convert it
4811 * to a double if necessary.
4812 */
4813
4814 valuePtr = POP_OBJECT();
4815
4816 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
4817 result = TCL_ERROR;
4818 goto done;
4819 }
4820
4821 GET_DOUBLE_VALUE(d, valuePtr, valuePtr->typePtr);
4822
4823 errno = 0;
4824 dResult = (*func)(d);
4825 if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
4826 TclExprFloatError(interp, dResult);
4827 result = TCL_ERROR;
4828 goto done;
4829 }
4830
4831 /*
4832 * Push a Tcl object holding the result.
4833 */
4834
4835 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
4836
4837 /*
4838 * Reflect the change to stackTop back in eePtr.
4839 */
4840
4841 done:
4842 TclDecrRefCount(valuePtr);
4843 DECACHE_STACK_INFO();
4844 return result;
4845 }
4846
4847 static int
ExprBinaryFunc(interp,eePtr,clientData)4848 ExprBinaryFunc(interp, eePtr, clientData)
4849 Tcl_Interp *interp; /* The interpreter in which to execute the
4850 * function. */
4851 ExecEnv *eePtr; /* Points to the environment for executing
4852 * the function. */
4853 ClientData clientData; /* Contains the address of a procedure that
4854 * takes two double arguments and
4855 * returns a double result. */
4856 {
4857 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
4858 register int stackTop; /* Cached top index of evaluation stack. */
4859 register Tcl_Obj *valuePtr, *value2Ptr;
4860 double d1, d2, dResult;
4861 int result;
4862
4863 double (*func) _ANSI_ARGS_((double, double))
4864 = (double (*)_ANSI_ARGS_((double, double))) clientData;
4865
4866 /*
4867 * Set stackPtr and stackTop from eePtr.
4868 */
4869
4870 result = TCL_OK;
4871 CACHE_STACK_INFO();
4872
4873 /*
4874 * Pop the function's two arguments from the evaluation stack. Convert
4875 * them to doubles if necessary.
4876 */
4877
4878 value2Ptr = POP_OBJECT();
4879 valuePtr = POP_OBJECT();
4880
4881 if ((VerifyExprObjType(interp, valuePtr) != TCL_OK) ||
4882 (VerifyExprObjType(interp, value2Ptr) != TCL_OK)) {
4883 result = TCL_ERROR;
4884 goto done;
4885 }
4886
4887 GET_DOUBLE_VALUE(d1, valuePtr, valuePtr->typePtr);
4888 GET_DOUBLE_VALUE(d2, value2Ptr, value2Ptr->typePtr);
4889
4890 errno = 0;
4891 dResult = (*func)(d1, d2);
4892 if ((errno != 0) || IS_NAN(dResult) || IS_INF(dResult)) {
4893 TclExprFloatError(interp, dResult);
4894 result = TCL_ERROR;
4895 goto done;
4896 }
4897
4898 /*
4899 * Push a Tcl object holding the result.
4900 */
4901
4902 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
4903
4904 /*
4905 * Reflect the change to stackTop back in eePtr.
4906 */
4907
4908 done:
4909 TclDecrRefCount(valuePtr);
4910 TclDecrRefCount(value2Ptr);
4911 DECACHE_STACK_INFO();
4912 return result;
4913 }
4914
4915 static int
ExprAbsFunc(interp,eePtr,clientData)4916 ExprAbsFunc(interp, eePtr, clientData)
4917 Tcl_Interp *interp; /* The interpreter in which to execute the
4918 * function. */
4919 ExecEnv *eePtr; /* Points to the environment for executing
4920 * the function. */
4921 ClientData clientData; /* Ignored. */
4922 {
4923 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
4924 register int stackTop; /* Cached top index of evaluation stack. */
4925 register Tcl_Obj *valuePtr;
4926 long i, iResult;
4927 double d, dResult;
4928 int result;
4929
4930 /*
4931 * Set stackPtr and stackTop from eePtr.
4932 */
4933
4934 result = TCL_OK;
4935 CACHE_STACK_INFO();
4936
4937 /*
4938 * Pop the argument from the evaluation stack.
4939 */
4940
4941 valuePtr = POP_OBJECT();
4942
4943 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
4944 result = TCL_ERROR;
4945 goto done;
4946 }
4947
4948 /*
4949 * Push a Tcl object with the result.
4950 */
4951 if (valuePtr->typePtr == &tclIntType) {
4952 i = valuePtr->internalRep.longValue;
4953 if (i < 0) {
4954 iResult = -i;
4955 if (iResult < 0) {
4956 Tcl_ResetResult(interp);
4957 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4958 "integer value too large to represent", -1);
4959 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
4960 "integer value too large to represent", (char *) NULL);
4961 result = TCL_ERROR;
4962 goto done;
4963 }
4964 } else {
4965 iResult = i;
4966 }
4967 PUSH_OBJECT(Tcl_NewLongObj(iResult));
4968 } else if (valuePtr->typePtr == &tclWideIntType) {
4969 Tcl_WideInt wResult, w;
4970 TclGetWide(w,valuePtr);
4971 if (w < W0) {
4972 wResult = -w;
4973 if (wResult < 0) {
4974 Tcl_ResetResult(interp);
4975 Tcl_AppendToObj(Tcl_GetObjResult(interp),
4976 "integer value too large to represent", -1);
4977 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
4978 "integer value too large to represent", (char *) NULL);
4979 result = TCL_ERROR;
4980 goto done;
4981 }
4982 } else {
4983 wResult = w;
4984 }
4985 PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
4986 } else {
4987 d = valuePtr->internalRep.doubleValue;
4988 if (d < 0.0) {
4989 dResult = -d;
4990 } else {
4991 dResult = d;
4992 }
4993 if (IS_NAN(dResult) || IS_INF(dResult)) {
4994 TclExprFloatError(interp, dResult);
4995 result = TCL_ERROR;
4996 goto done;
4997 }
4998 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
4999 }
5000
5001 /*
5002 * Reflect the change to stackTop back in eePtr.
5003 */
5004
5005 done:
5006 TclDecrRefCount(valuePtr);
5007 DECACHE_STACK_INFO();
5008 return result;
5009 }
5010
5011 static int
ExprDoubleFunc(interp,eePtr,clientData)5012 ExprDoubleFunc(interp, eePtr, clientData)
5013 Tcl_Interp *interp; /* The interpreter in which to execute the
5014 * function. */
5015 ExecEnv *eePtr; /* Points to the environment for executing
5016 * the function. */
5017 ClientData clientData; /* Ignored. */
5018 {
5019 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
5020 register int stackTop; /* Cached top index of evaluation stack. */
5021 register Tcl_Obj *valuePtr;
5022 double dResult;
5023 int result;
5024
5025 /*
5026 * Set stackPtr and stackTop from eePtr.
5027 */
5028
5029 result = TCL_OK;
5030 CACHE_STACK_INFO();
5031
5032 /*
5033 * Pop the argument from the evaluation stack.
5034 */
5035
5036 valuePtr = POP_OBJECT();
5037
5038 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
5039 result = TCL_ERROR;
5040 goto done;
5041 }
5042
5043 GET_DOUBLE_VALUE(dResult, valuePtr, valuePtr->typePtr);
5044
5045 /*
5046 * Push a Tcl object with the result.
5047 */
5048
5049 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
5050
5051 /*
5052 * Reflect the change to stackTop back in eePtr.
5053 */
5054
5055 done:
5056 TclDecrRefCount(valuePtr);
5057 DECACHE_STACK_INFO();
5058 return result;
5059 }
5060
5061 static int
ExprIntFunc(interp,eePtr,clientData)5062 ExprIntFunc(interp, eePtr, clientData)
5063 Tcl_Interp *interp; /* The interpreter in which to execute the
5064 * function. */
5065 ExecEnv *eePtr; /* Points to the environment for executing
5066 * the function. */
5067 ClientData clientData; /* Ignored. */
5068 {
5069 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
5070 register int stackTop; /* Cached top index of evaluation stack. */
5071 register Tcl_Obj *valuePtr;
5072 long iResult;
5073 double d;
5074 int result;
5075
5076 /*
5077 * Set stackPtr and stackTop from eePtr.
5078 */
5079
5080 result = TCL_OK;
5081 CACHE_STACK_INFO();
5082
5083 /*
5084 * Pop the argument from the evaluation stack.
5085 */
5086
5087 valuePtr = POP_OBJECT();
5088
5089 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
5090 result = TCL_ERROR;
5091 goto done;
5092 }
5093
5094 if (valuePtr->typePtr == &tclIntType) {
5095 iResult = valuePtr->internalRep.longValue;
5096 } else if (valuePtr->typePtr == &tclWideIntType) {
5097 TclGetLongFromWide(iResult,valuePtr);
5098 } else {
5099 d = valuePtr->internalRep.doubleValue;
5100 if (d < 0.0) {
5101 if (d < (double) (long) LONG_MIN) {
5102 tooLarge:
5103 Tcl_ResetResult(interp);
5104 Tcl_AppendToObj(Tcl_GetObjResult(interp),
5105 "integer value too large to represent", -1);
5106 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
5107 "integer value too large to represent", (char *) NULL);
5108 result = TCL_ERROR;
5109 goto done;
5110 }
5111 } else {
5112 if (d > (double) LONG_MAX) {
5113 goto tooLarge;
5114 }
5115 }
5116 if (IS_NAN(d) || IS_INF(d)) {
5117 TclExprFloatError(interp, d);
5118 result = TCL_ERROR;
5119 goto done;
5120 }
5121 iResult = (long) d;
5122 }
5123
5124 /*
5125 * Push a Tcl object with the result.
5126 */
5127
5128 PUSH_OBJECT(Tcl_NewLongObj(iResult));
5129
5130 /*
5131 * Reflect the change to stackTop back in eePtr.
5132 */
5133
5134 done:
5135 TclDecrRefCount(valuePtr);
5136 DECACHE_STACK_INFO();
5137 return result;
5138 }
5139
5140 static int
ExprWideFunc(interp,eePtr,clientData)5141 ExprWideFunc(interp, eePtr, clientData)
5142 Tcl_Interp *interp; /* The interpreter in which to execute the
5143 * function. */
5144 ExecEnv *eePtr; /* Points to the environment for executing
5145 * the function. */
5146 ClientData clientData; /* Ignored. */
5147 {
5148 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
5149 register int stackTop; /* Cached top index of evaluation stack. */
5150 register Tcl_Obj *valuePtr;
5151 Tcl_WideInt wResult;
5152 double d;
5153 int result;
5154
5155 /*
5156 * Set stackPtr and stackTop from eePtr.
5157 */
5158
5159 result = TCL_OK;
5160 CACHE_STACK_INFO();
5161
5162 /*
5163 * Pop the argument from the evaluation stack.
5164 */
5165
5166 valuePtr = POP_OBJECT();
5167
5168 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
5169 result = TCL_ERROR;
5170 goto done;
5171 }
5172
5173 if (valuePtr->typePtr == &tclWideIntType) {
5174 TclGetWide(wResult,valuePtr);
5175 } else if (valuePtr->typePtr == &tclIntType) {
5176 wResult = Tcl_LongAsWide(valuePtr->internalRep.longValue);
5177 } else {
5178 d = valuePtr->internalRep.doubleValue;
5179 if (d < 0.0) {
5180 if (d < Tcl_WideAsDouble(LLONG_MIN)) {
5181 tooLarge:
5182 Tcl_ResetResult(interp);
5183 Tcl_AppendToObj(Tcl_GetObjResult(interp),
5184 "integer value too large to represent", -1);
5185 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
5186 "integer value too large to represent", (char *) NULL);
5187 result = TCL_ERROR;
5188 goto done;
5189 }
5190 } else {
5191 if (d > Tcl_WideAsDouble(LLONG_MAX)) {
5192 goto tooLarge;
5193 }
5194 }
5195 if (IS_NAN(d) || IS_INF(d)) {
5196 TclExprFloatError(interp, d);
5197 result = TCL_ERROR;
5198 goto done;
5199 }
5200 wResult = Tcl_DoubleAsWide(d);
5201 }
5202
5203 /*
5204 * Push a Tcl object with the result.
5205 */
5206
5207 PUSH_OBJECT(Tcl_NewWideIntObj(wResult));
5208
5209 /*
5210 * Reflect the change to stackTop back in eePtr.
5211 */
5212
5213 done:
5214 TclDecrRefCount(valuePtr);
5215 DECACHE_STACK_INFO();
5216 return result;
5217 }
5218
5219 static int
ExprRandFunc(interp,eePtr,clientData)5220 ExprRandFunc(interp, eePtr, clientData)
5221 Tcl_Interp *interp; /* The interpreter in which to execute the
5222 * function. */
5223 ExecEnv *eePtr; /* Points to the environment for executing
5224 * the function. */
5225 ClientData clientData; /* Ignored. */
5226 {
5227 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
5228 register int stackTop; /* Cached top index of evaluation stack. */
5229 Interp *iPtr = (Interp *) interp;
5230 double dResult;
5231 long tmp; /* Algorithm assumes at least 32 bits.
5232 * Only long guarantees that. See below. */
5233
5234 if (!(iPtr->flags & RAND_SEED_INITIALIZED)) {
5235 iPtr->flags |= RAND_SEED_INITIALIZED;
5236
5237 /*
5238 * Take into consideration the thread this interp is running in order
5239 * to insure different seeds in different threads (bug #416643)
5240 */
5241
5242 iPtr->randSeed = TclpGetClicks() + ((long)Tcl_GetCurrentThread()<<12);
5243
5244 /*
5245 * Make sure 1 <= randSeed <= (2^31) - 2. See below.
5246 */
5247
5248 iPtr->randSeed &= (unsigned long) 0x7fffffff;
5249 if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
5250 iPtr->randSeed ^= 123459876;
5251 }
5252 }
5253
5254 /*
5255 * Set stackPtr and stackTop from eePtr.
5256 */
5257
5258 CACHE_STACK_INFO();
5259
5260 /*
5261 * Generate the random number using the linear congruential
5262 * generator defined by the following recurrence:
5263 * seed = ( IA * seed ) mod IM
5264 * where IA is 16807 and IM is (2^31) - 1. The recurrence maps
5265 * a seed in the range [1, IM - 1] to a new seed in that same range.
5266 * The recurrence maps IM to 0, and maps 0 back to 0, so those two
5267 * values must not be allowed as initial values of seed.
5268 *
5269 * In order to avoid potential problems with integer overflow, the
5270 * recurrence is implemented in terms of additional constants
5271 * IQ and IR such that
5272 * IM = IA*IQ + IR
5273 * None of the operations in the implementation overflows a 32-bit
5274 * signed integer, and the C type long is guaranteed to be at least
5275 * 32 bits wide.
5276 *
5277 * For more details on how this algorithm works, refer to the following
5278 * papers:
5279 *
5280 * S.K. Park & K.W. Miller, "Random number generators: good ones
5281 * are hard to find," Comm ACM 31(10):1192-1201, Oct 1988
5282 *
5283 * W.H. Press & S.A. Teukolsky, "Portable random number
5284 * generators," Computers in Physics 6(5):522-524, Sep/Oct 1992.
5285 */
5286
5287 #define RAND_IA 16807
5288 #define RAND_IM 2147483647
5289 #define RAND_IQ 127773
5290 #define RAND_IR 2836
5291 #define RAND_MASK 123459876
5292
5293 tmp = iPtr->randSeed/RAND_IQ;
5294 iPtr->randSeed = RAND_IA*(iPtr->randSeed - tmp*RAND_IQ) - RAND_IR*tmp;
5295 if (iPtr->randSeed < 0) {
5296 iPtr->randSeed += RAND_IM;
5297 }
5298
5299 /*
5300 * Since the recurrence keeps seed values in the range [1, RAND_IM - 1],
5301 * dividing by RAND_IM yields a double in the range (0, 1).
5302 */
5303
5304 dResult = iPtr->randSeed * (1.0/RAND_IM);
5305
5306 /*
5307 * Push a Tcl object with the result.
5308 */
5309
5310 PUSH_OBJECT(Tcl_NewDoubleObj(dResult));
5311
5312 /*
5313 * Reflect the change to stackTop back in eePtr.
5314 */
5315
5316 DECACHE_STACK_INFO();
5317 return TCL_OK;
5318 }
5319
5320 static int
ExprRoundFunc(interp,eePtr,clientData)5321 ExprRoundFunc(interp, eePtr, clientData)
5322 Tcl_Interp *interp; /* The interpreter in which to execute the
5323 * function. */
5324 ExecEnv *eePtr; /* Points to the environment for executing
5325 * the function. */
5326 ClientData clientData; /* Ignored. */
5327 {
5328 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
5329 register int stackTop; /* Cached top index of evaluation stack. */
5330 Tcl_Obj *valuePtr;
5331 long iResult;
5332 double d, temp;
5333 int result;
5334
5335 /*
5336 * Set stackPtr and stackTop from eePtr.
5337 */
5338
5339 result = TCL_OK;
5340 CACHE_STACK_INFO();
5341
5342 /*
5343 * Pop the argument from the evaluation stack.
5344 */
5345
5346 valuePtr = POP_OBJECT();
5347
5348 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
5349 result = TCL_ERROR;
5350 goto done;
5351 }
5352
5353 if (valuePtr->typePtr == &tclIntType) {
5354 iResult = valuePtr->internalRep.longValue;
5355 } else if (valuePtr->typePtr == &tclWideIntType) {
5356 Tcl_WideInt w;
5357 TclGetWide(w,valuePtr);
5358 PUSH_OBJECT(Tcl_NewWideIntObj(w));
5359 goto done;
5360 } else {
5361 d = valuePtr->internalRep.doubleValue;
5362 if (d < 0.0) {
5363 if (d <= (((double) (long) LONG_MIN) - 0.5)) {
5364 tooLarge:
5365 Tcl_ResetResult(interp);
5366 Tcl_AppendToObj(Tcl_GetObjResult(interp),
5367 "integer value too large to represent", -1);
5368 Tcl_SetErrorCode(interp, "ARITH", "IOVERFLOW",
5369 "integer value too large to represent",
5370 (char *) NULL);
5371 result = TCL_ERROR;
5372 goto done;
5373 }
5374 temp = (long) (d - 0.5);
5375 } else {
5376 if (d >= (((double) LONG_MAX + 0.5))) {
5377 goto tooLarge;
5378 }
5379 temp = (long) (d + 0.5);
5380 }
5381 if (IS_NAN(temp) || IS_INF(temp)) {
5382 TclExprFloatError(interp, temp);
5383 result = TCL_ERROR;
5384 goto done;
5385 }
5386 iResult = (long) temp;
5387 }
5388
5389 /*
5390 * Push a Tcl object with the result.
5391 */
5392
5393 PUSH_OBJECT(Tcl_NewLongObj(iResult));
5394
5395 /*
5396 * Reflect the change to stackTop back in eePtr.
5397 */
5398
5399 done:
5400 TclDecrRefCount(valuePtr);
5401 DECACHE_STACK_INFO();
5402 return result;
5403 }
5404
5405 static int
ExprSrandFunc(interp,eePtr,clientData)5406 ExprSrandFunc(interp, eePtr, clientData)
5407 Tcl_Interp *interp; /* The interpreter in which to execute the
5408 * function. */
5409 ExecEnv *eePtr; /* Points to the environment for executing
5410 * the function. */
5411 ClientData clientData; /* Ignored. */
5412 {
5413 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
5414 register int stackTop; /* Cached top index of evaluation stack. */
5415 Interp *iPtr = (Interp *) interp;
5416 Tcl_Obj *valuePtr;
5417 long i = 0; /* Initialized to avoid compiler warning. */
5418
5419 /*
5420 * Set stackPtr and stackTop from eePtr.
5421 */
5422
5423 CACHE_STACK_INFO();
5424
5425 /*
5426 * Pop the argument from the evaluation stack. Use the value
5427 * to reset the random number seed.
5428 */
5429
5430 valuePtr = POP_OBJECT();
5431
5432 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
5433 goto badValue;
5434 }
5435
5436 if (valuePtr->typePtr == &tclIntType) {
5437 i = valuePtr->internalRep.longValue;
5438 } else if (valuePtr->typePtr == &tclWideIntType) {
5439 TclGetLongFromWide(i,valuePtr);
5440 } else {
5441 /*
5442 * At this point, the only other possible type is double
5443 */
5444 Tcl_ResetResult(interp);
5445 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
5446 "can't use floating-point value as argument to srand",
5447 (char *) NULL);
5448 badValue:
5449 TclDecrRefCount(valuePtr);
5450 DECACHE_STACK_INFO();
5451 return TCL_ERROR;
5452 }
5453
5454 /*
5455 * Reset the seed. Make sure 1 <= randSeed <= 2^31 - 2.
5456 * See comments in ExprRandFunc() for more details.
5457 */
5458
5459 iPtr->flags |= RAND_SEED_INITIALIZED;
5460 iPtr->randSeed = i;
5461 iPtr->randSeed &= (unsigned long) 0x7fffffff;
5462 if ((iPtr->randSeed == 0) || (iPtr->randSeed == 0x7fffffff)) {
5463 iPtr->randSeed ^= 123459876;
5464 }
5465
5466 /*
5467 * To avoid duplicating the random number generation code we simply
5468 * clean up our state and call the real random number function. That
5469 * function will always succeed.
5470 */
5471
5472 TclDecrRefCount(valuePtr);
5473 DECACHE_STACK_INFO();
5474
5475 ExprRandFunc(interp, eePtr, clientData);
5476 return TCL_OK;
5477 }
5478
5479 /*
5480 *----------------------------------------------------------------------
5481 *
5482 * ExprCallMathFunc --
5483 *
5484 * This procedure is invoked to call a non-builtin math function
5485 * during the execution of an expression.
5486 *
5487 * Results:
5488 * TCL_OK is returned if all went well and the function's value
5489 * was computed successfully. If an error occurred, TCL_ERROR
5490 * is returned and an error message is left in the interpreter's
5491 * result. After a successful return this procedure pushes a Tcl object
5492 * holding the result.
5493 *
5494 * Side effects:
5495 * None, unless the called math function has side effects.
5496 *
5497 *----------------------------------------------------------------------
5498 */
5499
5500 static int
ExprCallMathFunc(interp,eePtr,objc,objv)5501 ExprCallMathFunc(interp, eePtr, objc, objv)
5502 Tcl_Interp *interp; /* The interpreter in which to execute the
5503 * function. */
5504 ExecEnv *eePtr; /* Points to the environment for executing
5505 * the function. */
5506 int objc; /* Number of arguments. The function name is
5507 * the 0-th argument. */
5508 Tcl_Obj **objv; /* The array of arguments. The function name
5509 * is objv[0]. */
5510 {
5511 Interp *iPtr = (Interp *) interp;
5512 Tcl_Obj **stackPtr; /* Cached evaluation stack base pointer. */
5513 register int stackTop; /* Cached top index of evaluation stack. */
5514 char *funcName;
5515 Tcl_HashEntry *hPtr;
5516 MathFunc *mathFuncPtr; /* Information about math function. */
5517 Tcl_Value args[MAX_MATH_ARGS]; /* Arguments for function call. */
5518 Tcl_Value funcResult; /* Result of function call as Tcl_Value. */
5519 register Tcl_Obj *valuePtr;
5520 long i;
5521 double d;
5522 int j, k, result;
5523
5524 Tcl_ResetResult(interp);
5525
5526 /*
5527 * Set stackPtr and stackTop from eePtr.
5528 */
5529
5530 CACHE_STACK_INFO();
5531
5532 /*
5533 * Look up the MathFunc record for the function.
5534 */
5535
5536 funcName = TclGetString(objv[0]);
5537 hPtr = Tcl_FindHashEntry(&iPtr->mathFuncTable, funcName);
5538 if (hPtr == NULL) {
5539 Tcl_AppendStringsToObj(Tcl_GetObjResult(interp),
5540 "unknown math function \"", funcName, "\"", (char *) NULL);
5541 result = TCL_ERROR;
5542 goto done;
5543 }
5544 mathFuncPtr = (MathFunc *) Tcl_GetHashValue(hPtr);
5545 if (mathFuncPtr->numArgs != (objc-1)) {
5546 panic("ExprCallMathFunc: expected number of args %d != actual number %d",
5547 mathFuncPtr->numArgs, objc);
5548 result = TCL_ERROR;
5549 goto done;
5550 }
5551
5552 /*
5553 * Collect the arguments for the function, if there are any, into the
5554 * array "args". Note that args[0] will have the Tcl_Value that
5555 * corresponds to objv[1].
5556 */
5557
5558 for (j = 1, k = 0; j < objc; j++, k++) {
5559 valuePtr = objv[j];
5560
5561 if (VerifyExprObjType(interp, valuePtr) != TCL_OK) {
5562 result = TCL_ERROR;
5563 goto done;
5564 }
5565
5566 /*
5567 * Copy the object's numeric value to the argument record,
5568 * converting it if necessary.
5569 */
5570
5571 if (valuePtr->typePtr == &tclIntType) {
5572 i = valuePtr->internalRep.longValue;
5573 if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
5574 args[k].type = TCL_DOUBLE;
5575 args[k].doubleValue = i;
5576 } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
5577 args[k].type = TCL_WIDE_INT;
5578 args[k].wideValue = Tcl_LongAsWide(i);
5579 } else {
5580 args[k].type = TCL_INT;
5581 args[k].intValue = i;
5582 }
5583 } else if (valuePtr->typePtr == &tclWideIntType) {
5584 Tcl_WideInt w;
5585 TclGetWide(w,valuePtr);
5586 if (mathFuncPtr->argTypes[k] == TCL_DOUBLE) {
5587 args[k].type = TCL_DOUBLE;
5588 args[k].doubleValue = Tcl_WideAsDouble(w);
5589 } else if (mathFuncPtr->argTypes[k] == TCL_INT) {
5590 args[k].type = TCL_INT;
5591 args[k].intValue = Tcl_WideAsLong(w);
5592 } else {
5593 args[k].type = TCL_WIDE_INT;
5594 args[k].wideValue = w;
5595 }
5596 } else {
5597 d = valuePtr->internalRep.doubleValue;
5598 if (mathFuncPtr->argTypes[k] == TCL_INT) {
5599 args[k].type = TCL_INT;
5600 args[k].intValue = (long) d;
5601 } else if (mathFuncPtr->argTypes[k] == TCL_WIDE_INT) {
5602 args[k].type = TCL_WIDE_INT;
5603 args[k].wideValue = Tcl_DoubleAsWide(d);
5604 } else {
5605 args[k].type = TCL_DOUBLE;
5606 args[k].doubleValue = d;
5607 }
5608 }
5609 }
5610
5611 /*
5612 * Invoke the function and copy its result back into valuePtr.
5613 */
5614
5615 result = (*mathFuncPtr->proc)(mathFuncPtr->clientData, interp, args,
5616 &funcResult);
5617 if (result != TCL_OK) {
5618 goto done;
5619 }
5620
5621 /*
5622 * Pop the objc top stack elements and decrement their ref counts.
5623 */
5624
5625 k = (stackTop - (objc-1));
5626 while (stackTop >= k) {
5627 valuePtr = POP_OBJECT();
5628 TclDecrRefCount(valuePtr);
5629 }
5630
5631 /*
5632 * Push the call's object result.
5633 */
5634
5635 if (funcResult.type == TCL_INT) {
5636 PUSH_OBJECT(Tcl_NewLongObj(funcResult.intValue));
5637 } else if (funcResult.type == TCL_WIDE_INT) {
5638 PUSH_OBJECT(Tcl_NewWideIntObj(funcResult.wideValue));
5639 } else {
5640 d = funcResult.doubleValue;
5641 if (IS_NAN(d) || IS_INF(d)) {
5642 TclExprFloatError(interp, d);
5643 result = TCL_ERROR;
5644 goto done;
5645 }
5646 PUSH_OBJECT(Tcl_NewDoubleObj(d));
5647 }
5648
5649 /*
5650 * Reflect the change to stackTop back in eePtr.
5651 */
5652
5653 done:
5654 DECACHE_STACK_INFO();
5655 return result;
5656 }
5657
5658 /*
5659 *----------------------------------------------------------------------
5660 *
5661 * TclExprFloatError --
5662 *
5663 * This procedure is called when an error occurs during a
5664 * floating-point operation. It reads errno and sets
5665 * interp->objResultPtr accordingly.
5666 *
5667 * Results:
5668 * interp->objResultPtr is set to hold an error message.
5669 *
5670 * Side effects:
5671 * None.
5672 *
5673 *----------------------------------------------------------------------
5674 */
5675
5676 void
TclExprFloatError(interp,value)5677 TclExprFloatError(interp, value)
5678 Tcl_Interp *interp; /* Where to store error message. */
5679 double value; /* Value returned after error; used to
5680 * distinguish underflows from overflows. */
5681 {
5682 char *s;
5683
5684 Tcl_ResetResult(interp);
5685 if ((errno == EDOM) || IS_NAN(value)) {
5686 s = "domain error: argument not in valid range";
5687 Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
5688 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, (char *) NULL);
5689 } else if ((errno == ERANGE) || IS_INF(value)) {
5690 if (value == 0.0) {
5691 s = "floating-point value too small to represent";
5692 Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
5693 Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, (char *) NULL);
5694 } else {
5695 s = "floating-point value too large to represent";
5696 Tcl_AppendToObj(Tcl_GetObjResult(interp), s, -1);
5697 Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, (char *) NULL);
5698 }
5699 } else {
5700 char msg[64 + TCL_INTEGER_SPACE];
5701
5702 sprintf(msg, "unknown floating-point error, errno = %d", errno);
5703 Tcl_AppendToObj(Tcl_GetObjResult(interp), msg, -1);
5704 Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN", msg, (char *) NULL);
5705 }
5706 }
5707
5708 #ifdef TCL_COMPILE_STATS
5709 /*
5710 *----------------------------------------------------------------------
5711 *
5712 * TclLog2 --
5713 *
5714 * Procedure used while collecting compilation statistics to determine
5715 * the log base 2 of an integer.
5716 *
5717 * Results:
5718 * Returns the log base 2 of the operand. If the argument is less
5719 * than or equal to zero, a zero is returned.
5720 *
5721 * Side effects:
5722 * None.
5723 *
5724 *----------------------------------------------------------------------
5725 */
5726
5727 int
TclLog2(value)5728 TclLog2(value)
5729 register int value; /* The integer for which to compute the
5730 * log base 2. */
5731 {
5732 register int n = value;
5733 register int result = 0;
5734
5735 while (n > 1) {
5736 n = n >> 1;
5737 result++;
5738 }
5739 return result;
5740 }
5741
5742 /*
5743 *----------------------------------------------------------------------
5744 *
5745 * EvalStatsCmd --
5746 *
5747 * Implements the "evalstats" command that prints instruction execution
5748 * counts to stdout.
5749 *
5750 * Results:
5751 * Standard Tcl results.
5752 *
5753 * Side effects:
5754 * None.
5755 *
5756 *----------------------------------------------------------------------
5757 */
5758
5759 static int
EvalStatsCmd(unused,interp,objc,objv)5760 EvalStatsCmd(unused, interp, objc, objv)
5761 ClientData unused; /* Unused. */
5762 Tcl_Interp *interp; /* The current interpreter. */
5763 int objc; /* The number of arguments. */
5764 Tcl_Obj *CONST objv[]; /* The argument strings. */
5765 {
5766 Interp *iPtr = (Interp *) interp;
5767 LiteralTable *globalTablePtr = &(iPtr->literalTable);
5768 ByteCodeStats *statsPtr = &(iPtr->stats);
5769 double totalCodeBytes, currentCodeBytes;
5770 double totalLiteralBytes, currentLiteralBytes;
5771 double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
5772 double strBytesSharedMultX, strBytesSharedOnce;
5773 double numInstructions, currentHeaderBytes;
5774 long numCurrentByteCodes, numByteCodeLits;
5775 long refCountSum, literalMgmtBytes, sum;
5776 int numSharedMultX, numSharedOnce;
5777 int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
5778 char *litTableStats;
5779 LiteralEntry *entryPtr;
5780
5781 numInstructions = 0.0;
5782 for (i = 0; i < 256; i++) {
5783 if (statsPtr->instructionCount[i] != 0) {
5784 numInstructions += statsPtr->instructionCount[i];
5785 }
5786 }
5787
5788 totalLiteralBytes = sizeof(LiteralTable)
5789 + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
5790 + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
5791 + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
5792 + statsPtr->totalLitStringBytes;
5793 totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
5794
5795 numCurrentByteCodes =
5796 statsPtr->numCompilations - statsPtr->numByteCodesFreed;
5797 currentHeaderBytes = numCurrentByteCodes
5798 * (sizeof(ByteCode) - (sizeof(size_t) + sizeof(Tcl_Time)));
5799 literalMgmtBytes = sizeof(LiteralTable)
5800 + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
5801 + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
5802 currentLiteralBytes = literalMgmtBytes
5803 + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
5804 + statsPtr->currentLitStringBytes;
5805 currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
5806
5807 /*
5808 * Summary statistics, total and current source and ByteCode sizes.
5809 */
5810
5811 fprintf(stdout, "\n----------------------------------------------------------------\n");
5812 fprintf(stdout,
5813 "Compilation and execution statistics for interpreter 0x%x\n",
5814 (unsigned int) iPtr);
5815
5816 fprintf(stdout, "\nNumber ByteCodes executed %ld\n",
5817 statsPtr->numExecutions);
5818 fprintf(stdout, "Number ByteCodes compiled %ld\n",
5819 statsPtr->numCompilations);
5820 fprintf(stdout, " Mean executions/compile %.1f\n",
5821 ((float)statsPtr->numExecutions) / ((float)statsPtr->numCompilations));
5822
5823 fprintf(stdout, "\nInstructions executed %.0f\n",
5824 numInstructions);
5825 fprintf(stdout, " Mean inst/compile %.0f\n",
5826 numInstructions / statsPtr->numCompilations);
5827 fprintf(stdout, " Mean inst/execution %.0f\n",
5828 numInstructions / statsPtr->numExecutions);
5829
5830 fprintf(stdout, "\nTotal ByteCodes %ld\n",
5831 statsPtr->numCompilations);
5832 fprintf(stdout, " Source bytes %.6g\n",
5833 statsPtr->totalSrcBytes);
5834 fprintf(stdout, " Code bytes %.6g\n",
5835 totalCodeBytes);
5836 fprintf(stdout, " ByteCode bytes %.6g\n",
5837 statsPtr->totalByteCodeBytes);
5838 fprintf(stdout, " Literal bytes %.6g\n",
5839 totalLiteralBytes);
5840 fprintf(stdout, " table %d + bkts %d + entries %ld + objects %ld + strings %.6g\n",
5841 sizeof(LiteralTable),
5842 iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
5843 statsPtr->numLiteralsCreated * sizeof(LiteralEntry),
5844 statsPtr->numLiteralsCreated * sizeof(Tcl_Obj),
5845 statsPtr->totalLitStringBytes);
5846 fprintf(stdout, " Mean code/compile %.1f\n",
5847 totalCodeBytes / statsPtr->numCompilations);
5848 fprintf(stdout, " Mean code/source %.1f\n",
5849 totalCodeBytes / statsPtr->totalSrcBytes);
5850
5851 fprintf(stdout, "\nCurrent (active) ByteCodes %ld\n",
5852 numCurrentByteCodes);
5853 fprintf(stdout, " Source bytes %.6g\n",
5854 statsPtr->currentSrcBytes);
5855 fprintf(stdout, " Code bytes %.6g\n",
5856 currentCodeBytes);
5857 fprintf(stdout, " ByteCode bytes %.6g\n",
5858 statsPtr->currentByteCodeBytes);
5859 fprintf(stdout, " Literal bytes %.6g\n",
5860 currentLiteralBytes);
5861 fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
5862 sizeof(LiteralTable),
5863 iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
5864 iPtr->literalTable.numEntries * sizeof(LiteralEntry),
5865 iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
5866 statsPtr->currentLitStringBytes);
5867 fprintf(stdout, " Mean code/source %.1f\n",
5868 currentCodeBytes / statsPtr->currentSrcBytes);
5869 fprintf(stdout, " Code + source bytes %.6g (%0.1f mean code/src)\n",
5870 (currentCodeBytes + statsPtr->currentSrcBytes),
5871 (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
5872
5873 /*
5874 * Tcl_IsShared statistics check
5875 *
5876 * This gives the refcount of each obj as Tcl_IsShared was called
5877 * for it. Shared objects must be duplicated before they can be
5878 * modified.
5879 */
5880
5881 numSharedMultX = 0;
5882 fprintf(stdout, "\nTcl_IsShared object check (all objects):\n");
5883 fprintf(stdout, " Object had refcount <=1 (not shared) %ld\n",
5884 tclObjsShared[1]);
5885 for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
5886 fprintf(stdout, " refcount ==%d %ld\n",
5887 i, tclObjsShared[i]);
5888 numSharedMultX += tclObjsShared[i];
5889 }
5890 fprintf(stdout, " refcount >=%d %ld\n",
5891 i, tclObjsShared[0]);
5892 numSharedMultX += tclObjsShared[0];
5893 fprintf(stdout, " Total shared objects %d\n",
5894 numSharedMultX);
5895
5896 /*
5897 * Literal table statistics.
5898 */
5899
5900 numByteCodeLits = 0;
5901 refCountSum = 0;
5902 numSharedMultX = 0;
5903 numSharedOnce = 0;
5904 objBytesIfUnshared = 0.0;
5905 strBytesIfUnshared = 0.0;
5906 strBytesSharedMultX = 0.0;
5907 strBytesSharedOnce = 0.0;
5908 for (i = 0; i < globalTablePtr->numBuckets; i++) {
5909 for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
5910 entryPtr = entryPtr->nextPtr) {
5911 if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
5912 numByteCodeLits++;
5913 }
5914 (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
5915 refCountSum += entryPtr->refCount;
5916 objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
5917 strBytesIfUnshared += (entryPtr->refCount * (length+1));
5918 if (entryPtr->refCount > 1) {
5919 numSharedMultX++;
5920 strBytesSharedMultX += (length+1);
5921 } else {
5922 numSharedOnce++;
5923 strBytesSharedOnce += (length+1);
5924 }
5925 }
5926 }
5927 sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
5928 - currentLiteralBytes;
5929
5930 fprintf(stdout, "\nTotal objects (all interps) %ld\n",
5931 tclObjsAlloced);
5932 fprintf(stdout, "Current objects %ld\n",
5933 (tclObjsAlloced - tclObjsFreed));
5934 fprintf(stdout, "Total literal objects %ld\n",
5935 statsPtr->numLiteralsCreated);
5936
5937 fprintf(stdout, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
5938 globalTablePtr->numEntries,
5939 (globalTablePtr->numEntries * 100.0) / (tclObjsAlloced-tclObjsFreed));
5940 fprintf(stdout, " ByteCode literals %ld (%0.1f%% of current literals)\n",
5941 numByteCodeLits,
5942 (numByteCodeLits * 100.0) / globalTablePtr->numEntries);
5943 fprintf(stdout, " Literals reused > 1x %d\n",
5944 numSharedMultX);
5945 fprintf(stdout, " Mean reference count %.2f\n",
5946 ((double) refCountSum) / globalTablePtr->numEntries);
5947 fprintf(stdout, " Mean len, str reused >1x %.2f\n",
5948 (numSharedMultX? (strBytesSharedMultX/numSharedMultX) : 0.0));
5949 fprintf(stdout, " Mean len, str used 1x %.2f\n",
5950 (numSharedOnce? (strBytesSharedOnce/numSharedOnce) : 0.0));
5951 fprintf(stdout, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
5952 sharingBytesSaved,
5953 (sharingBytesSaved * 100.0) / (objBytesIfUnshared + strBytesIfUnshared));
5954 fprintf(stdout, " Bytes with sharing %.6g\n",
5955 currentLiteralBytes);
5956 fprintf(stdout, " table %d + bkts %d + entries %d + objects %d + strings %.6g\n",
5957 sizeof(LiteralTable),
5958 iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
5959 iPtr->literalTable.numEntries * sizeof(LiteralEntry),
5960 iPtr->literalTable.numEntries * sizeof(Tcl_Obj),
5961 statsPtr->currentLitStringBytes);
5962 fprintf(stdout, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
5963 (objBytesIfUnshared + strBytesIfUnshared),
5964 objBytesIfUnshared, strBytesIfUnshared);
5965 fprintf(stdout, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
5966 (strBytesIfUnshared - statsPtr->currentLitStringBytes),
5967 strBytesIfUnshared, statsPtr->currentLitStringBytes);
5968 fprintf(stdout, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
5969 literalMgmtBytes,
5970 (literalMgmtBytes * 100.0) / currentLiteralBytes);
5971 fprintf(stdout, " table %d + buckets %d + entries %d\n",
5972 sizeof(LiteralTable),
5973 iPtr->literalTable.numBuckets * sizeof(LiteralEntry *),
5974 iPtr->literalTable.numEntries * sizeof(LiteralEntry));
5975
5976 /*
5977 * Breakdown of current ByteCode space requirements.
5978 */
5979
5980 fprintf(stdout, "\nBreakdown of current ByteCode requirements:\n");
5981 fprintf(stdout, " Bytes Pct of Avg per\n");
5982 fprintf(stdout, " total ByteCode\n");
5983 fprintf(stdout, "Total %12.6g 100.00%% %8.1f\n",
5984 statsPtr->currentByteCodeBytes,
5985 statsPtr->currentByteCodeBytes / numCurrentByteCodes);
5986 fprintf(stdout, "Header %12.6g %8.1f%% %8.1f\n",
5987 currentHeaderBytes,
5988 ((currentHeaderBytes * 100.0) / statsPtr->currentByteCodeBytes),
5989 currentHeaderBytes / numCurrentByteCodes);
5990 fprintf(stdout, "Instructions %12.6g %8.1f%% %8.1f\n",
5991 statsPtr->currentInstBytes,
5992 ((statsPtr->currentInstBytes * 100.0) / statsPtr->currentByteCodeBytes),
5993 statsPtr->currentInstBytes / numCurrentByteCodes);
5994 fprintf(stdout, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
5995 statsPtr->currentLitBytes,
5996 ((statsPtr->currentLitBytes * 100.0) / statsPtr->currentByteCodeBytes),
5997 statsPtr->currentLitBytes / numCurrentByteCodes);
5998 fprintf(stdout, "Exception table %12.6g %8.1f%% %8.1f\n",
5999 statsPtr->currentExceptBytes,
6000 ((statsPtr->currentExceptBytes * 100.0) / statsPtr->currentByteCodeBytes),
6001 statsPtr->currentExceptBytes / numCurrentByteCodes);
6002 fprintf(stdout, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
6003 statsPtr->currentAuxBytes,
6004 ((statsPtr->currentAuxBytes * 100.0) / statsPtr->currentByteCodeBytes),
6005 statsPtr->currentAuxBytes / numCurrentByteCodes);
6006 fprintf(stdout, "Command map %12.6g %8.1f%% %8.1f\n",
6007 statsPtr->currentCmdMapBytes,
6008 ((statsPtr->currentCmdMapBytes * 100.0) / statsPtr->currentByteCodeBytes),
6009 statsPtr->currentCmdMapBytes / numCurrentByteCodes);
6010
6011 /*
6012 * Detailed literal statistics.
6013 */
6014
6015 fprintf(stdout, "\nLiteral string sizes:\n");
6016 fprintf(stdout, " Up to length Percentage\n");
6017 maxSizeDecade = 0;
6018 for (i = 31; i >= 0; i--) {
6019 if (statsPtr->literalCount[i] > 0) {
6020 maxSizeDecade = i;
6021 break;
6022 }
6023 }
6024 sum = 0;
6025 for (i = 0; i <= maxSizeDecade; i++) {
6026 decadeHigh = (1 << (i+1)) - 1;
6027 sum += statsPtr->literalCount[i];
6028 fprintf(stdout, " %10d %8.0f%%\n",
6029 decadeHigh, (sum * 100.0) / statsPtr->numLiteralsCreated);
6030 }
6031
6032 litTableStats = TclLiteralStats(globalTablePtr);
6033 fprintf(stdout, "\nCurrent literal table statistics:\n%s\n",
6034 litTableStats);
6035 ckfree((char *) litTableStats);
6036
6037 /*
6038 * Source and ByteCode size distributions.
6039 */
6040
6041 fprintf(stdout, "\nSource sizes:\n");
6042 fprintf(stdout, " Up to size Percentage\n");
6043 minSizeDecade = maxSizeDecade = 0;
6044 for (i = 0; i < 31; i++) {
6045 if (statsPtr->srcCount[i] > 0) {
6046 minSizeDecade = i;
6047 break;
6048 }
6049 }
6050 for (i = 31; i >= 0; i--) {
6051 if (statsPtr->srcCount[i] > 0) {
6052 maxSizeDecade = i;
6053 break;
6054 }
6055 }
6056 sum = 0;
6057 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
6058 decadeHigh = (1 << (i+1)) - 1;
6059 sum += statsPtr->srcCount[i];
6060 fprintf(stdout, " %10d %8.0f%%\n",
6061 decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
6062 }
6063
6064 fprintf(stdout, "\nByteCode sizes:\n");
6065 fprintf(stdout, " Up to size Percentage\n");
6066 minSizeDecade = maxSizeDecade = 0;
6067 for (i = 0; i < 31; i++) {
6068 if (statsPtr->byteCodeCount[i] > 0) {
6069 minSizeDecade = i;
6070 break;
6071 }
6072 }
6073 for (i = 31; i >= 0; i--) {
6074 if (statsPtr->byteCodeCount[i] > 0) {
6075 maxSizeDecade = i;
6076 break;
6077 }
6078 }
6079 sum = 0;
6080 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
6081 decadeHigh = (1 << (i+1)) - 1;
6082 sum += statsPtr->byteCodeCount[i];
6083 fprintf(stdout, " %10d %8.0f%%\n",
6084 decadeHigh, (sum * 100.0) / statsPtr->numCompilations);
6085 }
6086
6087 fprintf(stdout, "\nByteCode longevity (excludes Current ByteCodes):\n");
6088 fprintf(stdout, " Up to ms Percentage\n");
6089 minSizeDecade = maxSizeDecade = 0;
6090 for (i = 0; i < 31; i++) {
6091 if (statsPtr->lifetimeCount[i] > 0) {
6092 minSizeDecade = i;
6093 break;
6094 }
6095 }
6096 for (i = 31; i >= 0; i--) {
6097 if (statsPtr->lifetimeCount[i] > 0) {
6098 maxSizeDecade = i;
6099 break;
6100 }
6101 }
6102 sum = 0;
6103 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
6104 decadeHigh = (1 << (i+1)) - 1;
6105 sum += statsPtr->lifetimeCount[i];
6106 fprintf(stdout, " %12.3f %8.0f%%\n",
6107 decadeHigh / 1000.0,
6108 (sum * 100.0) / statsPtr->numByteCodesFreed);
6109 }
6110
6111 /*
6112 * Instruction counts.
6113 */
6114
6115 fprintf(stdout, "\nInstruction counts:\n");
6116 for (i = 0; i <= LAST_INST_OPCODE; i++) {
6117 if (statsPtr->instructionCount[i]) {
6118 fprintf(stdout, "%20s %8ld %6.1f%%\n",
6119 tclInstructionTable[i].name,
6120 statsPtr->instructionCount[i],
6121 (statsPtr->instructionCount[i]*100.0) / numInstructions);
6122 }
6123 }
6124
6125 fprintf(stdout, "\nInstructions NEVER executed:\n");
6126 for (i = 0; i <= LAST_INST_OPCODE; i++) {
6127 if (statsPtr->instructionCount[i] == 0) {
6128 fprintf(stdout, "%20s\n", tclInstructionTable[i].name);
6129 }
6130 }
6131
6132 #ifdef TCL_MEM_DEBUG
6133 fprintf(stdout, "\nHeap Statistics:\n");
6134 TclDumpMemoryInfo(stdout);
6135 #endif
6136 fprintf(stdout, "\n----------------------------------------------------------------\n");
6137 return TCL_OK;
6138 }
6139 #endif /* TCL_COMPILE_STATS */
6140
6141 #ifdef TCL_COMPILE_DEBUG
6142 /*
6143 *----------------------------------------------------------------------
6144 *
6145 * StringForResultCode --
6146 *
6147 * Procedure that returns a human-readable string representing a
6148 * Tcl result code such as TCL_ERROR.
6149 *
6150 * Results:
6151 * If the result code is one of the standard Tcl return codes, the
6152 * result is a string representing that code such as "TCL_ERROR".
6153 * Otherwise, the result string is that code formatted as a
6154 * sequence of decimal digit characters. Note that the resulting
6155 * string must not be modified by the caller.
6156 *
6157 * Side effects:
6158 * None.
6159 *
6160 *----------------------------------------------------------------------
6161 */
6162
6163 static char *
StringForResultCode(result)6164 StringForResultCode(result)
6165 int result; /* The Tcl result code for which to
6166 * generate a string. */
6167 {
6168 static char buf[TCL_INTEGER_SPACE];
6169
6170 if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
6171 return resultStrings[result];
6172 }
6173 TclFormatInt(buf, result);
6174 return buf;
6175 }
6176 #endif /* TCL_COMPILE_DEBUG */
6177