1 /*
2 * tclExecute.c --
3 *
4 * This file contains procedures that execute byte-compiled Tcl commands.
5 *
6 * Copyright (c) 1996-1997 Sun Microsystems, Inc.
7 * Copyright (c) 1998-2000 by Scriptics Corporation.
8 * Copyright (c) 2001 by Kevin B. Kenny. All rights reserved.
9 * Copyright (c) 2002-2005 by Miguel Sofer.
10 * Copyright (c) 2005-2007 by Donal K. Fellows.
11 * Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
12 *
13 * See the file "license.terms" for information on usage and redistribution of
14 * this file, and for a DISCLAIMER OF ALL WARRANTIES.
15 */
16
17 #include "tclInt.h"
18 #include "tclCompile.h"
19 #include "tommath.h"
20
21 #include <math.h>
22 #include <float.h>
23
24 /*
25 * Hack to determine whether we may expect IEEE floating point. The hack is
26 * formally incorrect in that non-IEEE platforms might have the same precision
27 * and range, but VAX, IBM, and Cray do not; are there any other floating
28 * point units that we might care about?
29 */
30
31 #if (FLT_RADIX == 2) && (DBL_MANT_DIG == 53) && (DBL_MAX_EXP == 1024)
32 #define IEEE_FLOATING_POINT
33 #endif
34
35 /*
36 * A mask (should be 2**n-1) that is used to work out when the bytecode engine
37 * should call Tcl_AsyncReady() to see whether there is a signal that needs
38 * handling.
39 */
40
41 #ifndef ASYNC_CHECK_COUNT_MASK
42 # define ASYNC_CHECK_COUNT_MASK 63
43 #endif /* !ASYNC_CHECK_COUNT_MASK */
44
45 /*
46 * Boolean flag indicating whether the Tcl bytecode interpreter has been
47 * initialized.
48 */
49
50 static int execInitialized = 0;
51 TCL_DECLARE_MUTEX(execMutex)
52
53 #ifdef TCL_COMPILE_DEBUG
54 /*
55 * Variable that controls whether execution tracing is enabled and, if so,
56 * what level of tracing is desired:
57 * 0: no execution tracing
58 * 1: trace invocations of Tcl procs only
59 * 2: trace invocations of all (not compiled away) commands
60 * 3: display each instruction executed
61 * This variable is linked to the Tcl variable "tcl_traceExec".
62 */
63
64 int tclTraceExec = 0;
65 #endif
66
67 /*
68 * Mapping from expression instruction opcodes to strings; used for error
69 * messages. Note that these entries must match the order and number of the
70 * expression opcodes (e.g., INST_LOR) in tclCompile.h.
71 *
72 * Does not include the string for INST_EXPON (and beyond), as that is
73 * disjoint for backward-compatability reasons.
74 */
75
76 static const char *const operatorStrings[] = {
77 "||", "&&", "|", "^", "&", "==", "!=", "<", ">", "<=", ">=", "<<", ">>",
78 "+", "-", "*", "/", "%", "+", "-", "~", "!"
79 };
80
81 /*
82 * Mapping from Tcl result codes to strings; used for error and debugging
83 * messages.
84 */
85
86 #ifdef TCL_COMPILE_DEBUG
87 static const char *const resultStrings[] = {
88 "TCL_OK", "TCL_ERROR", "TCL_RETURN", "TCL_BREAK", "TCL_CONTINUE"
89 };
90 #endif
91
92 /*
93 * These are used by evalstats to monitor object usage in Tcl.
94 */
95
96 #ifdef TCL_COMPILE_STATS
97 long tclObjsAlloced = 0;
98 long tclObjsFreed = 0;
99 long tclObjsShared[TCL_MAX_SHARED_OBJ_STATS] = { 0, 0, 0, 0, 0 };
100 #endif /* TCL_COMPILE_STATS */
101
102 /*
103 * Support pre-8.5 bytecodes unless specifically requested otherwise.
104 */
105
106 #ifndef TCL_SUPPORT_84_BYTECODE
107 #define TCL_SUPPORT_84_BYTECODE 1
108 #endif
109
110 #if TCL_SUPPORT_84_BYTECODE
111 /*
112 * We need to know the tclBuiltinFuncTable to support translation of pre-8.5
113 * math functions to the namespace-based ::tcl::mathfunc::op in 8.5+.
114 */
115
116 typedef struct {
117 const char *name; /* Name of function. */
118 int numArgs; /* Number of arguments for function. */
119 } BuiltinFunc;
120
121 /*
122 * Table describing the built-in math functions. Entries in this table are
123 * indexed by the values of the INST_CALL_BUILTIN_FUNC instruction's
124 * operand byte.
125 */
126
127 static const BuiltinFunc tclBuiltinFuncTable[] = {
128 {"acos", 1},
129 {"asin", 1},
130 {"atan", 1},
131 {"atan2", 2},
132 {"ceil", 1},
133 {"cos", 1},
134 {"cosh", 1},
135 {"exp", 1},
136 {"floor", 1},
137 {"fmod", 2},
138 {"hypot", 2},
139 {"log", 1},
140 {"log10", 1},
141 {"pow", 2},
142 {"sin", 1},
143 {"sinh", 1},
144 {"sqrt", 1},
145 {"tan", 1},
146 {"tanh", 1},
147 {"abs", 1},
148 {"double", 1},
149 {"int", 1},
150 {"rand", 0},
151 {"round", 1},
152 {"srand", 1},
153 {"wide", 1},
154 {NULL, 0},
155 };
156
157 #define LAST_BUILTIN_FUNC 25
158 #endif
159
160 /*
161 * These variable-access macros have to coincide with those in tclVar.c
162 */
163
164 #define VarHashGetValue(hPtr) \
165 ((Var *) ((char *)hPtr - TclOffset(VarInHash, entry)))
166
167 static inline Var *
VarHashCreateVar(TclVarHashTable * tablePtr,Tcl_Obj * key,int * newPtr)168 VarHashCreateVar(
169 TclVarHashTable *tablePtr,
170 Tcl_Obj *key,
171 int *newPtr)
172 {
173 Tcl_HashEntry *hPtr = Tcl_CreateHashEntry((Tcl_HashTable *) tablePtr,
174 (char *) key, newPtr);
175
176 if (!hPtr) {
177 return NULL;
178 }
179 return VarHashGetValue(hPtr);
180 }
181
182 #define VarHashFindVar(tablePtr, key) \
183 VarHashCreateVar((tablePtr), (key), NULL)
184
185 /*
186 * The new macro for ending an instruction; note that a reasonable C-optimiser
187 * will resolve all branches at compile time. (result) is always a constant;
188 * the macro NEXT_INST_F handles constant (nCleanup), NEXT_INST_V is resolved
189 * at runtime for variable (nCleanup).
190 *
191 * ARGUMENTS:
192 * pcAdjustment: how much to increment pc
193 * nCleanup: how many objects to remove from the stack
194 * resultHandling: 0 indicates no object should be pushed on the stack;
195 * otherwise, push objResultPtr. If (result < 0), objResultPtr already
196 * has the correct reference count.
197 */
198
199 #define NEXT_INST_F(pcAdjustment, nCleanup, resultHandling) \
200 if (nCleanup == 0) {\
201 if (resultHandling != 0) {\
202 if ((resultHandling) > 0) {\
203 PUSH_OBJECT(objResultPtr);\
204 } else {\
205 *(++tosPtr) = objResultPtr;\
206 }\
207 } \
208 pc += (pcAdjustment);\
209 goto cleanup0;\
210 } else if (resultHandling != 0) {\
211 if ((resultHandling) > 0) {\
212 Tcl_IncrRefCount(objResultPtr);\
213 }\
214 pc += (pcAdjustment);\
215 switch (nCleanup) {\
216 case 1: goto cleanup1_pushObjResultPtr;\
217 case 2: goto cleanup2_pushObjResultPtr;\
218 default: Tcl_Panic("bad usage of macro NEXT_INST_F");\
219 }\
220 } else {\
221 pc += (pcAdjustment);\
222 switch (nCleanup) {\
223 case 1: goto cleanup1;\
224 case 2: goto cleanup2;\
225 default: Tcl_Panic("bad usage of macro NEXT_INST_F");\
226 }\
227 }
228
229 #define NEXT_INST_V(pcAdjustment, nCleanup, resultHandling) \
230 pc += (pcAdjustment);\
231 cleanup = (nCleanup);\
232 if (resultHandling) {\
233 if ((resultHandling) > 0) {\
234 Tcl_IncrRefCount(objResultPtr);\
235 }\
236 goto cleanupV_pushObjResultPtr;\
237 } else {\
238 goto cleanupV;\
239 }
240
241 /*
242 * Macros used to cache often-referenced Tcl evaluation stack information
243 * in local variables. Note that a DECACHE_STACK_INFO()-CACHE_STACK_INFO()
244 * pair must surround any call inside TclExecuteByteCode (and a few other
245 * procedures that use this scheme) that could result in a recursive call
246 * to TclExecuteByteCode.
247 */
248
249 #define CACHE_STACK_INFO() \
250 checkInterp = 1
251
252 #define DECACHE_STACK_INFO() \
253 esPtr->tosPtr = tosPtr
254
255 /*
256 * Macros used to access items on the Tcl evaluation stack. PUSH_OBJECT
257 * increments the object's ref count since it makes the stack have another
258 * reference pointing to the object. However, POP_OBJECT does not decrement
259 * the ref count. This is because the stack may hold the only reference to the
260 * object, so the object would be destroyed if its ref count were decremented
261 * before the caller had a chance to, e.g., store it in a variable. It is the
262 * caller's responsibility to decrement the ref count when it is finished with
263 * an object.
264 *
265 * WARNING! It is essential that objPtr only appear once in the PUSH_OBJECT
266 * macro. The actual parameter might be an expression with side effects, and
267 * this ensures that it will be executed only once.
268 */
269
270 #define PUSH_OBJECT(objPtr) \
271 Tcl_IncrRefCount(*(++tosPtr) = (objPtr))
272
273 #define POP_OBJECT() *(tosPtr--)
274
275 #define OBJ_AT_TOS *tosPtr
276
277 #define OBJ_UNDER_TOS *(tosPtr-1)
278
279 #define OBJ_AT_DEPTH(n) *(tosPtr-(n))
280
281 #define CURR_DEPTH (tosPtr - initTosPtr)
282
283 #define STACK_BASE(esPtr) ((esPtr)->stackWords - 1)
284
285 /*
286 * Macros used to trace instruction execution. The macros TRACE,
287 * TRACE_WITH_OBJ, and O2S are only used inside TclExecuteByteCode. O2S is
288 * only used in TRACE* calls to get a string from an object.
289 */
290
291 #ifdef TCL_COMPILE_DEBUG
292 # define TRACE(a) \
293 if (traceInstructions) { \
294 fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
295 (int) CURR_DEPTH, \
296 (unsigned)(pc - codePtr->codeStart), \
297 GetOpcodeName(pc)); \
298 printf a; \
299 }
300 # define TRACE_APPEND(a) \
301 if (traceInstructions) { \
302 printf a; \
303 }
304 # define TRACE_WITH_OBJ(a, objPtr) \
305 if (traceInstructions) { \
306 fprintf(stdout, "%2d: %2d (%u) %s ", iPtr->numLevels, \
307 (int) CURR_DEPTH, \
308 (unsigned)(pc - codePtr->codeStart), \
309 GetOpcodeName(pc)); \
310 printf a; \
311 TclPrintObject(stdout, objPtr, 30); \
312 fprintf(stdout, "\n"); \
313 }
314 # define O2S(objPtr) \
315 (objPtr ? TclGetString(objPtr) : "")
316 #else /* !TCL_COMPILE_DEBUG */
317 # define TRACE(a)
318 # define TRACE_APPEND(a)
319 # define TRACE_WITH_OBJ(a, objPtr)
320 # define O2S(objPtr)
321 #endif /* TCL_COMPILE_DEBUG */
322
323 /*
324 * DTrace instruction probe macros.
325 */
326
327 #define TCL_DTRACE_INST_NEXT() \
328 if (TCL_DTRACE_INST_DONE_ENABLED()) {\
329 if (curInstName) {\
330 TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
331 }\
332 curInstName = tclInstructionTable[*pc].name;\
333 if (TCL_DTRACE_INST_START_ENABLED()) {\
334 TCL_DTRACE_INST_START(curInstName, (int) CURR_DEPTH, tosPtr);\
335 }\
336 } else if (TCL_DTRACE_INST_START_ENABLED()) {\
337 TCL_DTRACE_INST_START(tclInstructionTable[*pc].name, (int) CURR_DEPTH,\
338 tosPtr);\
339 }
340 #define TCL_DTRACE_INST_LAST() \
341 if (TCL_DTRACE_INST_DONE_ENABLED() && curInstName) {\
342 TCL_DTRACE_INST_DONE(curInstName, (int) CURR_DEPTH, tosPtr);\
343 }
344
345 /*
346 * Macro used in this file to save a function call for common uses of
347 * TclGetNumberFromObj(). The ANSI C "prototype" is:
348 *
349 * MODULE_SCOPE int GetNumberFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
350 * ClientData *ptrPtr, int *tPtr);
351 */
352
353 #ifdef NO_WIDE_TYPE
354
355 #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
356 (((objPtr)->typePtr == &tclIntType) \
357 ? (*(tPtr) = TCL_NUMBER_LONG, \
358 *(ptrPtr) = (ClientData) \
359 (&((objPtr)->internalRep.longValue)), TCL_OK) : \
360 ((objPtr)->typePtr == &tclDoubleType) \
361 ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
362 ? (*(tPtr) = TCL_NUMBER_NAN) \
363 : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
364 *(ptrPtr) = (ClientData) \
365 (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
366 ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
367 (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
368 ? TCL_ERROR : \
369 TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
370
371 #else
372
373 #define GetNumberFromObj(interp, objPtr, ptrPtr, tPtr) \
374 (((objPtr)->typePtr == &tclIntType) \
375 ? (*(tPtr) = TCL_NUMBER_LONG, \
376 *(ptrPtr) = (ClientData) \
377 (&((objPtr)->internalRep.longValue)), TCL_OK) : \
378 ((objPtr)->typePtr == &tclWideIntType) \
379 ? (*(tPtr) = TCL_NUMBER_WIDE, \
380 *(ptrPtr) = (ClientData) \
381 (&((objPtr)->internalRep.wideValue)), TCL_OK) : \
382 ((objPtr)->typePtr == &tclDoubleType) \
383 ? (((TclIsNaN((objPtr)->internalRep.doubleValue)) \
384 ? (*(tPtr) = TCL_NUMBER_NAN) \
385 : (*(tPtr) = TCL_NUMBER_DOUBLE)), \
386 *(ptrPtr) = (ClientData) \
387 (&((objPtr)->internalRep.doubleValue)), TCL_OK) : \
388 ((((objPtr)->typePtr == NULL) && ((objPtr)->bytes == NULL)) || \
389 (((objPtr)->bytes != NULL) && ((objPtr)->length == 0))) \
390 ? TCL_ERROR : \
391 TclGetNumberFromObj((interp), (objPtr), (ptrPtr), (tPtr)))
392
393 #endif
394
395 /*
396 * Macro used in this file to save a function call for common uses of
397 * Tcl_GetBooleanFromObj(). The ANSI C "prototype" is:
398 *
399 * MODULE_SCOPE int TclGetBooleanFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
400 * int *boolPtr);
401 */
402
403 #define TclGetBooleanFromObj(interp, objPtr, boolPtr) \
404 ((((objPtr)->typePtr == &tclIntType) \
405 || ((objPtr)->typePtr == &tclBooleanType)) \
406 ? (*(boolPtr) = ((objPtr)->internalRep.longValue!=0), TCL_OK) \
407 : Tcl_GetBooleanFromObj((interp), (objPtr), (boolPtr)))
408
409 /*
410 * Macro used in this file to save a function call for common uses of
411 * Tcl_GetWideIntFromObj(). The ANSI C "prototype" is:
412 *
413 * MODULE_SCOPE int TclGetWideIntFromObj(Tcl_Interp *interp, Tcl_Obj *objPtr,
414 * Tcl_WideInt *wideIntPtr);
415 */
416
417 #ifdef NO_WIDE_TYPE
418 #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
419 (((objPtr)->typePtr == &tclIntType) \
420 ? (*(wideIntPtr) = (Tcl_WideInt) \
421 ((objPtr)->internalRep.longValue), TCL_OK) : \
422 Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
423 #else
424 #define TclGetWideIntFromObj(interp, objPtr, wideIntPtr) \
425 (((objPtr)->typePtr == &tclWideIntType) \
426 ? (*(wideIntPtr) = (objPtr)->internalRep.wideValue, TCL_OK) : \
427 ((objPtr)->typePtr == &tclIntType) \
428 ? (*(wideIntPtr) = (Tcl_WideInt) \
429 ((objPtr)->internalRep.longValue), TCL_OK) : \
430 Tcl_GetWideIntFromObj((interp), (objPtr), (wideIntPtr)))
431 #endif
432
433 /*
434 * Macro used to make the check for type overflow more mnemonic. This works by
435 * comparing sign bits; the rest of the word is irrelevant. The ANSI C
436 * "prototype" (where inttype_t is any integer type) is:
437 *
438 * MODULE_SCOPE int Overflowing(inttype_t a, inttype_t b, inttype_t sum);
439 *
440 * Check first the condition most likely to fail in usual code (at least for
441 * usage in [incr]: do the first summand and the sum have != signs?
442 */
443
444 #define Overflowing(a,b,sum) ((((a)^(sum)) < 0) && (((a)^(b)) >= 0))
445
446 /*
447 * Custom object type only used in this file; values of its type should never
448 * be seen by user scripts.
449 */
450
451 static Tcl_ObjType dictIteratorType = {
452 "dictIterator",
453 NULL, NULL, NULL, NULL
454 };
455
456 /*
457 * Auxiliary tables used to compute powers of small integers
458 */
459
460 #if (LONG_MAX == 0x7fffffff)
461
462 /*
463 * Maximum base that, when raised to powers 2, 3, ... 8, fits in a 32-bit
464 * signed integer
465 */
466
467 static const long MaxBase32[] = {46340, 1290, 215, 73, 35, 21, 14};
468 static const size_t MaxBase32Size = sizeof(MaxBase32)/sizeof(long);
469
470 /*
471 * Table giving 3, 4, ..., 11, raised to the powers 9, 10, ..., as far as they
472 * fit in a 32-bit signed integer. Exp32Index[i] gives the starting index of
473 * powers of i+3; Exp32Value[i] gives the corresponding powers.
474 */
475
476 static const unsigned short Exp32Index[] = {
477 0, 11, 18, 23, 26, 29, 31, 32, 33
478 };
479 static const size_t Exp32IndexSize = sizeof(Exp32Index)/sizeof(unsigned short);
480 static const long Exp32Value[] = {
481 19683, 59049, 177147, 531441, 1594323, 4782969, 14348907, 43046721,
482 129140163, 387420489, 1162261467, 262144, 1048576, 4194304,
483 16777216, 67108864, 268435456, 1073741824, 1953125, 9765625,
484 48828125, 244140625, 1220703125, 10077696, 60466176, 362797056,
485 40353607, 282475249, 1977326743, 134217728, 1073741824, 387420489,
486 1000000000
487 };
488 static const size_t Exp32ValueSize = sizeof(Exp32Value)/sizeof(long);
489
490 #endif /* LONG_MAX == 0x7fffffff -- 32 bit machine */
491
492 #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
493
494 /*
495 * Maximum base that, when raised to powers 2, 3, ..., 16, fits in a
496 * Tcl_WideInt.
497 */
498
499 static const Tcl_WideInt MaxBase64[] = {
500 (Tcl_WideInt)46340*65536+62259, /* 3037000499 == isqrt(2**63-1) */
501 (Tcl_WideInt)2097151, (Tcl_WideInt)55108, (Tcl_WideInt)6208,
502 (Tcl_WideInt)1448, (Tcl_WideInt)511, (Tcl_WideInt)234, (Tcl_WideInt)127,
503 (Tcl_WideInt)78, (Tcl_WideInt)52, (Tcl_WideInt)38, (Tcl_WideInt)28,
504 (Tcl_WideInt)22, (Tcl_WideInt)18, (Tcl_WideInt)15
505 };
506 static const size_t MaxBase64Size = sizeof(MaxBase64)/sizeof(Tcl_WideInt);
507
508 /*
509 *Table giving 3, 4, ..., 13 raised to powers greater than 16 when the
510 * results fit in a 64-bit signed integer.
511 */
512
513 static const unsigned short Exp64Index[] = {
514 0, 23, 38, 49, 57, 63, 67, 70, 72, 74, 75, 76
515 };
516 static const size_t Exp64IndexSize = sizeof(Exp64Index)/sizeof(unsigned short);
517 static const Tcl_WideInt Exp64Value[] = {
518 (Tcl_WideInt)243*243*243*3*3,
519 (Tcl_WideInt)243*243*243*3*3*3,
520 (Tcl_WideInt)243*243*243*3*3*3*3,
521 (Tcl_WideInt)243*243*243*243,
522 (Tcl_WideInt)243*243*243*243*3,
523 (Tcl_WideInt)243*243*243*243*3*3,
524 (Tcl_WideInt)243*243*243*243*3*3*3,
525 (Tcl_WideInt)243*243*243*243*3*3*3*3,
526 (Tcl_WideInt)243*243*243*243*243,
527 (Tcl_WideInt)243*243*243*243*243*3,
528 (Tcl_WideInt)243*243*243*243*243*3*3,
529 (Tcl_WideInt)243*243*243*243*243*3*3*3,
530 (Tcl_WideInt)243*243*243*243*243*3*3*3*3,
531 (Tcl_WideInt)243*243*243*243*243*243,
532 (Tcl_WideInt)243*243*243*243*243*243*3,
533 (Tcl_WideInt)243*243*243*243*243*243*3*3,
534 (Tcl_WideInt)243*243*243*243*243*243*3*3*3,
535 (Tcl_WideInt)243*243*243*243*243*243*3*3*3*3,
536 (Tcl_WideInt)243*243*243*243*243*243*243,
537 (Tcl_WideInt)243*243*243*243*243*243*243*3,
538 (Tcl_WideInt)243*243*243*243*243*243*243*3*3,
539 (Tcl_WideInt)243*243*243*243*243*243*243*3*3*3,
540 (Tcl_WideInt)243*243*243*243*243*243*243*3*3*3*3,
541 (Tcl_WideInt)1024*1024*1024*4*4,
542 (Tcl_WideInt)1024*1024*1024*4*4*4,
543 (Tcl_WideInt)1024*1024*1024*4*4*4*4,
544 (Tcl_WideInt)1024*1024*1024*1024,
545 (Tcl_WideInt)1024*1024*1024*1024*4,
546 (Tcl_WideInt)1024*1024*1024*1024*4*4,
547 (Tcl_WideInt)1024*1024*1024*1024*4*4*4,
548 (Tcl_WideInt)1024*1024*1024*1024*4*4*4*4,
549 (Tcl_WideInt)1024*1024*1024*1024*1024,
550 (Tcl_WideInt)1024*1024*1024*1024*1024*4,
551 (Tcl_WideInt)1024*1024*1024*1024*1024*4*4,
552 (Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4,
553 (Tcl_WideInt)1024*1024*1024*1024*1024*4*4*4*4,
554 (Tcl_WideInt)1024*1024*1024*1024*1024*1024,
555 (Tcl_WideInt)1024*1024*1024*1024*1024*1024*4,
556 (Tcl_WideInt)3125*3125*3125*5*5,
557 (Tcl_WideInt)3125*3125*3125*5*5*5,
558 (Tcl_WideInt)3125*3125*3125*5*5*5*5,
559 (Tcl_WideInt)3125*3125*3125*3125,
560 (Tcl_WideInt)3125*3125*3125*3125*5,
561 (Tcl_WideInt)3125*3125*3125*3125*5*5,
562 (Tcl_WideInt)3125*3125*3125*3125*5*5*5,
563 (Tcl_WideInt)3125*3125*3125*3125*5*5*5*5,
564 (Tcl_WideInt)3125*3125*3125*3125*3125,
565 (Tcl_WideInt)3125*3125*3125*3125*3125*5,
566 (Tcl_WideInt)3125*3125*3125*3125*3125*5*5,
567 (Tcl_WideInt)7776*7776*7776*6*6,
568 (Tcl_WideInt)7776*7776*7776*6*6*6,
569 (Tcl_WideInt)7776*7776*7776*6*6*6*6,
570 (Tcl_WideInt)7776*7776*7776*7776,
571 (Tcl_WideInt)7776*7776*7776*7776*6,
572 (Tcl_WideInt)7776*7776*7776*7776*6*6,
573 (Tcl_WideInt)7776*7776*7776*7776*6*6*6,
574 (Tcl_WideInt)7776*7776*7776*7776*6*6*6*6,
575 (Tcl_WideInt)16807*16807*16807*7*7,
576 (Tcl_WideInt)16807*16807*16807*7*7*7,
577 (Tcl_WideInt)16807*16807*16807*7*7*7*7,
578 (Tcl_WideInt)16807*16807*16807*16807,
579 (Tcl_WideInt)16807*16807*16807*16807*7,
580 (Tcl_WideInt)16807*16807*16807*16807*7*7,
581 (Tcl_WideInt)32768*32768*32768*8*8,
582 (Tcl_WideInt)32768*32768*32768*8*8*8,
583 (Tcl_WideInt)32768*32768*32768*8*8*8*8,
584 (Tcl_WideInt)32768*32768*32768*32768,
585 (Tcl_WideInt)59049*59049*59049*9*9,
586 (Tcl_WideInt)59049*59049*59049*9*9*9,
587 (Tcl_WideInt)59049*59049*59049*9*9*9*9,
588 (Tcl_WideInt)100000*100000*100000*10*10,
589 (Tcl_WideInt)100000*100000*100000*10*10*10,
590 (Tcl_WideInt)161051*161051*161051*11*11,
591 (Tcl_WideInt)161051*161051*161051*11*11*11,
592 (Tcl_WideInt)248832*248832*248832*12*12,
593 (Tcl_WideInt)371293*371293*371293*13*13
594 };
595 static const size_t Exp64ValueSize = sizeof(Exp64Value)/sizeof(Tcl_WideInt);
596
597 #endif
598
599 /*
600 * Declarations for local procedures to this file:
601 */
602
603 #ifdef TCL_COMPILE_STATS
604 static int EvalStatsCmd(ClientData clientData,
605 Tcl_Interp *interp, int objc,
606 Tcl_Obj *const objv[]);
607 #endif /* TCL_COMPILE_STATS */
608 #ifdef TCL_COMPILE_DEBUG
609 static char * GetOpcodeName(unsigned char *pc);
610 static void PrintByteCodeInfo(ByteCode *codePtr);
611 static const char * StringForResultCode(int result);
612 static void ValidatePcAndStackTop(ByteCode *codePtr,
613 unsigned char *pc, int stackTop,
614 int stackLowerBound, int checkStack);
615 #endif /* TCL_COMPILE_DEBUG */
616 static void DeleteExecStack(ExecStack *esPtr);
617 static void DupExprCodeInternalRep(Tcl_Obj *srcPtr,
618 Tcl_Obj *copyPtr);
619 static void FreeExprCodeInternalRep(Tcl_Obj *objPtr);
620 static ExceptionRange * GetExceptRangeForPc(unsigned char *pc, int searchMode,
621 ByteCode *codePtr);
622 static const char * GetSrcInfoForPc(unsigned char *pc, ByteCode *codePtr,
623 int *lengthPtr);
624 static Tcl_Obj ** GrowEvaluationStack(ExecEnv *eePtr, int growth,
625 int move);
626 static void IllegalExprOperandType(Tcl_Interp *interp,
627 unsigned char *pc, Tcl_Obj *opndPtr);
628 static void InitByteCodeExecution(Tcl_Interp *interp);
629 /* Useful elsewhere, make available in tclInt.h or stubs? */
630 static Tcl_Obj ** StackAllocWords(Tcl_Interp *interp, int numWords);
631 static Tcl_Obj ** StackReallocWords(Tcl_Interp *interp, int numWords);
632
633 /*
634 * The structure below defines a bytecode Tcl object type to hold the
635 * compiled bytecode for Tcl expressions.
636 */
637
638 static Tcl_ObjType exprCodeType = {
639 "exprcode",
640 FreeExprCodeInternalRep, /* freeIntRepProc */
641 DupExprCodeInternalRep, /* dupIntRepProc */
642 NULL, /* updateStringProc */
643 NULL /* setFromAnyProc */
644 };
645
646 /*
647 *----------------------------------------------------------------------
648 *
649 * InitByteCodeExecution --
650 *
651 * This procedure is called once to initialize the Tcl bytecode
652 * interpreter.
653 *
654 * Results:
655 * None.
656 *
657 * Side effects:
658 * This procedure initializes the array of instruction names. If
659 * compiling with the TCL_COMPILE_STATS flag, it initializes the array
660 * that counts the executions of each instruction and it creates the
661 * "evalstats" command. It also establishes the link between the Tcl
662 * "tcl_traceExec" and C "tclTraceExec" variables.
663 *
664 *----------------------------------------------------------------------
665 */
666
667 static void
InitByteCodeExecution(Tcl_Interp * interp)668 InitByteCodeExecution(
669 Tcl_Interp *interp) /* Interpreter for which the Tcl variable
670 * "tcl_traceExec" is linked to control
671 * instruction tracing. */
672 {
673 #ifdef TCL_COMPILE_DEBUG
674 if (Tcl_LinkVar(interp, "tcl_traceExec", (char *) &tclTraceExec,
675 TCL_LINK_INT) != TCL_OK) {
676 Tcl_Panic("InitByteCodeExecution: can't create link for tcl_traceExec variable");
677 }
678 #endif
679 #ifdef TCL_COMPILE_STATS
680 Tcl_CreateObjCommand(interp, "evalstats", EvalStatsCmd, NULL, NULL);
681 #endif /* TCL_COMPILE_STATS */
682 }
683
684 /*
685 *----------------------------------------------------------------------
686 *
687 * TclCreateExecEnv --
688 *
689 * This procedure creates a new execution environment for Tcl bytecode
690 * execution. An ExecEnv points to a Tcl evaluation stack. An ExecEnv is
691 * typically created once for each Tcl interpreter (Interp structure) and
692 * recursively passed to TclExecuteByteCode to execute ByteCode sequences
693 * for nested commands.
694 *
695 * Results:
696 * A newly allocated ExecEnv is returned. This points to an empty
697 * evaluation stack of the standard initial size.
698 *
699 * Side effects:
700 * The bytecode interpreter is also initialized here, as this procedure
701 * will be called before any call to TclExecuteByteCode.
702 *
703 *----------------------------------------------------------------------
704 */
705
706 #define TCL_STACK_INITIAL_SIZE 2000
707
708 ExecEnv *
TclCreateExecEnv(Tcl_Interp * interp)709 TclCreateExecEnv(
710 Tcl_Interp *interp) /* Interpreter for which the execution
711 * environment is being created. */
712 {
713 ExecEnv *eePtr = (ExecEnv *) ckalloc(sizeof(ExecEnv));
714 ExecStack *esPtr = (ExecStack *) ckalloc(sizeof(ExecStack)
715 + (size_t) (TCL_STACK_INITIAL_SIZE-1) * sizeof(Tcl_Obj *));
716
717 eePtr->execStackPtr = esPtr;
718 TclNewBooleanObj(eePtr->constants[0], 0);
719 Tcl_IncrRefCount(eePtr->constants[0]);
720 TclNewBooleanObj(eePtr->constants[1], 1);
721 Tcl_IncrRefCount(eePtr->constants[1]);
722
723 esPtr->prevPtr = NULL;
724 esPtr->nextPtr = NULL;
725 esPtr->markerPtr = NULL;
726 esPtr->endPtr = &esPtr->stackWords[TCL_STACK_INITIAL_SIZE-1];
727 esPtr->tosPtr = STACK_BASE(esPtr);
728
729 Tcl_MutexLock(&execMutex);
730 if (!execInitialized) {
731 TclInitAuxDataTypeTable();
732 InitByteCodeExecution(interp);
733 execInitialized = 1;
734 }
735 Tcl_MutexUnlock(&execMutex);
736
737 return eePtr;
738 }
739 #undef TCL_STACK_INITIAL_SIZE
740
741 /*
742 *----------------------------------------------------------------------
743 *
744 * TclDeleteExecEnv --
745 *
746 * Frees the storage for an ExecEnv.
747 *
748 * Results:
749 * None.
750 *
751 * Side effects:
752 * Storage for an ExecEnv and its contained storage (e.g. the evaluation
753 * stack) is freed.
754 *
755 *----------------------------------------------------------------------
756 */
757
758 static void
DeleteExecStack(ExecStack * esPtr)759 DeleteExecStack(
760 ExecStack *esPtr)
761 {
762 if (esPtr->markerPtr) {
763 Tcl_Panic("freeing an execStack which is still in use");
764 }
765
766 if (esPtr->prevPtr) {
767 esPtr->prevPtr->nextPtr = esPtr->nextPtr;
768 }
769 if (esPtr->nextPtr) {
770 esPtr->nextPtr->prevPtr = esPtr->prevPtr;
771 }
772 ckfree((char *) esPtr);
773 }
774
775 void
TclDeleteExecEnv(ExecEnv * eePtr)776 TclDeleteExecEnv(
777 ExecEnv *eePtr) /* Execution environment to free. */
778 {
779 ExecStack *esPtr = eePtr->execStackPtr, *tmpPtr;
780
781 /*
782 * Delete all stacks in this exec env.
783 */
784
785 while (esPtr->nextPtr) {
786 esPtr = esPtr->nextPtr;
787 }
788 while (esPtr) {
789 tmpPtr = esPtr;
790 esPtr = tmpPtr->prevPtr;
791 DeleteExecStack(tmpPtr);
792 }
793
794 TclDecrRefCount(eePtr->constants[0]);
795 TclDecrRefCount(eePtr->constants[1]);
796 ckfree((char *) eePtr);
797 }
798
799 /*
800 *----------------------------------------------------------------------
801 *
802 * TclFinalizeExecution --
803 *
804 * Finalizes the execution environment setup so that it can be later
805 * reinitialized.
806 *
807 * Results:
808 * None.
809 *
810 * Side effects:
811 * After this call, the next time TclCreateExecEnv will be called it will
812 * call InitByteCodeExecution.
813 *
814 *----------------------------------------------------------------------
815 */
816
817 void
TclFinalizeExecution(void)818 TclFinalizeExecution(void)
819 {
820 Tcl_MutexLock(&execMutex);
821 execInitialized = 0;
822 Tcl_MutexUnlock(&execMutex);
823 TclFinalizeAuxDataTypeTable();
824 }
825
826 /*
827 * Auxiliary code to insure that GrowEvaluationStack always returns correctly
828 * aligned memory.
829 *
830 * WALLOCALIGN represents the alignment reqs in words, just as TCL_ALLOCALIGN
831 * represents the reqs in bytes. This assumes that TCL_ALLOCALIGN is a
832 * multiple of the wordsize 'sizeof(Tcl_Obj *)'.
833 */
834
835 #define WALLOCALIGN \
836 (TCL_ALLOCALIGN/sizeof(Tcl_Obj *))
837
838 /*
839 * wordSkip computes how many words have to be skipped until the next aligned
840 * word. Note that we are only interested in the low order bits of ptr, so
841 * that any possible information loss in PTR2INT is of no consequence.
842 */
843
844 static inline int
wordSkip(void * ptr)845 wordSkip(
846 void *ptr)
847 {
848 int mask = TCL_ALLOCALIGN-1;
849 int base = PTR2INT(ptr) & mask;
850 return (TCL_ALLOCALIGN - base)/sizeof(Tcl_Obj *);
851 }
852
853 /*
854 * Given a marker, compute where the following aligned memory starts.
855 */
856
857 #define MEMSTART(markerPtr) \
858 ((markerPtr) + wordSkip(markerPtr))
859
860
861 /*
862 *----------------------------------------------------------------------
863 *
864 * GrowEvaluationStack --
865 *
866 * This procedure grows a Tcl evaluation stack stored in an ExecEnv,
867 * copying over the words since the last mark if so requested. A mark is
868 * set at the beginning of the new area when no copying is requested.
869 *
870 * Results:
871 * Returns a pointer to the first usable word in the (possibly) grown
872 * stack.
873 *
874 * Side effects:
875 * The size of the evaluation stack may be grown, a marker is set
876 *
877 *----------------------------------------------------------------------
878 */
879
880 static Tcl_Obj **
GrowEvaluationStack(ExecEnv * eePtr,int growth,int move)881 GrowEvaluationStack(
882 ExecEnv *eePtr, /* Points to the ExecEnv with an evaluation
883 * stack to enlarge. */
884 int growth, /* How much larger than the current used
885 * size. */
886 int move) /* 1 if move words since last marker. */
887 {
888 ExecStack *esPtr = eePtr->execStackPtr, *oldPtr = NULL;
889 int newBytes, newElems, currElems;
890 int needed = growth - (esPtr->endPtr - esPtr->tosPtr);
891 Tcl_Obj **markerPtr = esPtr->markerPtr, **memStart;
892 int moveWords = 0;
893
894 if (move) {
895 if (!markerPtr) {
896 Tcl_Panic("STACK: Reallocating with no previous alloc");
897 }
898 if (needed <= 0) {
899 return MEMSTART(markerPtr);
900 }
901 } else {
902 Tcl_Obj **tmpMarkerPtr = esPtr->tosPtr + 1;
903 int offset = wordSkip(tmpMarkerPtr);
904
905 if (needed + offset < 0) {
906 /*
907 * Put a marker pointing to the previous marker in this stack, and
908 * store it in esPtr as the current marker. Return a pointer to
909 * the start of aligned memory.
910 */
911
912 esPtr->markerPtr = tmpMarkerPtr;
913 memStart = tmpMarkerPtr + offset;
914 esPtr->tosPtr = memStart - 1;
915 *esPtr->markerPtr = (Tcl_Obj *) markerPtr;
916 return memStart;
917 }
918 }
919
920 /*
921 * Reset move to hold the number of words to be moved to new stack (if
922 * any) and growth to hold the complete stack requirements: add one for
923 * the marker, (WALLOCALIGN-1) for the maximal possible offset.
924 */
925
926 if (move) {
927 moveWords = esPtr->tosPtr - MEMSTART(markerPtr) + 1;
928 }
929 needed = growth + moveWords + WALLOCALIGN;
930
931 /*
932 * Check if there is enough room in the next stack (if there is one, it
933 * should be both empty and the last one!)
934 */
935
936 if (esPtr->nextPtr) {
937 oldPtr = esPtr;
938 esPtr = oldPtr->nextPtr;
939 currElems = esPtr->endPtr - STACK_BASE(esPtr);
940 if (esPtr->markerPtr || (esPtr->tosPtr != STACK_BASE(esPtr))) {
941 Tcl_Panic("STACK: Stack after current is in use");
942 }
943 if (esPtr->nextPtr) {
944 Tcl_Panic("STACK: Stack after current is not last");
945 }
946 if (needed <= currElems) {
947 goto newStackReady;
948 }
949 DeleteExecStack(esPtr);
950 esPtr = oldPtr;
951 } else {
952 currElems = esPtr->endPtr - STACK_BASE(esPtr);
953 }
954
955 /*
956 * We need to allocate a new stack! It needs to store 'growth' words,
957 * including the elements to be copied over and the new marker.
958 */
959
960 newElems = 2*currElems;
961 while (needed > newElems) {
962 newElems *= 2;
963 }
964 newBytes = sizeof (ExecStack) + (newElems-1) * sizeof(Tcl_Obj *);
965
966 oldPtr = esPtr;
967 esPtr = (ExecStack *) ckalloc(newBytes);
968
969 oldPtr->nextPtr = esPtr;
970 esPtr->prevPtr = oldPtr;
971 esPtr->nextPtr = NULL;
972 esPtr->endPtr = &esPtr->stackWords[newElems-1];
973
974 newStackReady:
975 eePtr->execStackPtr = esPtr;
976
977 /*
978 * Store a NULL marker at the beginning of the stack, to indicate that
979 * this is the first marker in this stack and that rewinding to here
980 * should actually be a return to the previous stack.
981 */
982
983 esPtr->stackWords[0] = NULL;
984 esPtr->markerPtr = &esPtr->stackWords[0];
985 memStart = MEMSTART(esPtr->markerPtr);
986 esPtr->tosPtr = memStart - 1;
987
988 if (move) {
989 memcpy(memStart, MEMSTART(markerPtr), moveWords*sizeof(Tcl_Obj *));
990 esPtr->tosPtr += moveWords;
991 oldPtr->markerPtr = (Tcl_Obj **) *markerPtr;
992 oldPtr->tosPtr = markerPtr-1;
993 }
994
995 /*
996 * Free the old stack if it is now unused.
997 */
998
999 if (!oldPtr->markerPtr) {
1000 DeleteExecStack(oldPtr);
1001 }
1002
1003 return memStart;
1004 }
1005
1006 /*
1007 *--------------------------------------------------------------
1008 *
1009 * TclStackAlloc, TclStackRealloc, TclStackFree --
1010 *
1011 * Allocate memory from the execution stack; it has to be returned later
1012 * with a call to TclStackFree.
1013 *
1014 * Results:
1015 * A pointer to the first byte allocated, or panics if the allocation did
1016 * not succeed.
1017 *
1018 * Side effects:
1019 * The execution stack may be grown.
1020 *
1021 *--------------------------------------------------------------
1022 */
1023
1024 static Tcl_Obj **
StackAllocWords(Tcl_Interp * interp,int numWords)1025 StackAllocWords(
1026 Tcl_Interp *interp,
1027 int numWords)
1028 {
1029 /*
1030 * Note that GrowEvaluationStack sets a marker in the stack. This marker
1031 * is read when rewinding, e.g., by TclStackFree.
1032 */
1033
1034 Interp *iPtr = (Interp *) interp;
1035 ExecEnv *eePtr = iPtr->execEnvPtr;
1036 Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 0);
1037
1038 eePtr->execStackPtr->tosPtr += numWords;
1039 return resPtr;
1040 }
1041
1042 static Tcl_Obj **
StackReallocWords(Tcl_Interp * interp,int numWords)1043 StackReallocWords(
1044 Tcl_Interp *interp,
1045 int numWords)
1046 {
1047 Interp *iPtr = (Interp *) interp;
1048 ExecEnv *eePtr = iPtr->execEnvPtr;
1049 Tcl_Obj **resPtr = GrowEvaluationStack(eePtr, numWords, 1);
1050
1051 eePtr->execStackPtr->tosPtr += numWords;
1052 return resPtr;
1053 }
1054
1055 void
TclStackFree(Tcl_Interp * interp,void * freePtr)1056 TclStackFree(
1057 Tcl_Interp *interp,
1058 void *freePtr)
1059 {
1060 Interp *iPtr = (Interp *) interp;
1061 ExecEnv *eePtr;
1062 ExecStack *esPtr;
1063 Tcl_Obj **markerPtr;
1064
1065 if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
1066 ckfree((char *) freePtr);
1067 return;
1068 }
1069
1070 /*
1071 * Rewind the stack to the previous marker position. The current marker,
1072 * as set in the last call to GrowEvaluationStack, contains a pointer to
1073 * the previous marker.
1074 */
1075
1076 eePtr = iPtr->execEnvPtr;
1077 esPtr = eePtr->execStackPtr;
1078 markerPtr = esPtr->markerPtr;
1079
1080 if (MEMSTART(markerPtr) != (Tcl_Obj **)freePtr) {
1081 Tcl_Panic("TclStackFree: incorrect freePtr. Call out of sequence?");
1082 }
1083
1084 esPtr->tosPtr = markerPtr-1;
1085 esPtr->markerPtr = (Tcl_Obj **) *markerPtr;
1086 if (*markerPtr) {
1087 return;
1088 }
1089
1090 /*
1091 * Return to previous stack.
1092 */
1093
1094 esPtr->tosPtr = STACK_BASE(esPtr);
1095 if (esPtr->prevPtr) {
1096 eePtr->execStackPtr = esPtr->prevPtr;
1097 }
1098 if (esPtr->nextPtr) {
1099 if (!esPtr->prevPtr) {
1100 eePtr->execStackPtr = esPtr->nextPtr;
1101 }
1102 DeleteExecStack(esPtr);
1103 }
1104 }
1105
1106 void *
TclStackAlloc(Tcl_Interp * interp,int numBytes)1107 TclStackAlloc(
1108 Tcl_Interp *interp,
1109 int numBytes)
1110 {
1111 Interp *iPtr = (Interp *) interp;
1112 int numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
1113
1114 if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
1115 return (void *) ckalloc(numBytes);
1116 }
1117
1118 return (void *) StackAllocWords(interp, numWords);
1119 }
1120
1121 void *
TclStackRealloc(Tcl_Interp * interp,void * ptr,int numBytes)1122 TclStackRealloc(
1123 Tcl_Interp *interp,
1124 void *ptr,
1125 int numBytes)
1126 {
1127 Interp *iPtr = (Interp *) interp;
1128 ExecEnv *eePtr;
1129 ExecStack *esPtr;
1130 Tcl_Obj **markerPtr;
1131 int numWords;
1132
1133 if (iPtr == NULL || iPtr->execEnvPtr == NULL) {
1134 return (void *) ckrealloc((char *) ptr, numBytes);
1135 }
1136
1137 eePtr = iPtr->execEnvPtr;
1138 esPtr = eePtr->execStackPtr;
1139 markerPtr = esPtr->markerPtr;
1140
1141 if (MEMSTART(markerPtr) != (Tcl_Obj **)ptr) {
1142 Tcl_Panic("TclStackRealloc: incorrect ptr. Call out of sequence?");
1143 }
1144
1145 numWords = (numBytes + (sizeof(Tcl_Obj *) - 1))/sizeof(Tcl_Obj *);
1146 return (void *) StackReallocWords(interp, numWords);
1147 }
1148
1149 /*
1150 *--------------------------------------------------------------
1151 *
1152 * Tcl_ExprObj --
1153 *
1154 * Evaluate an expression in a Tcl_Obj.
1155 *
1156 * Results:
1157 * A standard Tcl object result. If the result is other than TCL_OK, then
1158 * the interpreter's result contains an error message. If the result is
1159 * TCL_OK, then a pointer to the expression's result value object is
1160 * stored in resultPtrPtr. In that case, the object's ref count is
1161 * incremented to reflect the reference returned to the caller; the
1162 * caller is then responsible for the resulting object and must, for
1163 * example, decrement the ref count when it is finished with the object.
1164 *
1165 * Side effects:
1166 * Any side effects caused by subcommands in the expression, if any. The
1167 * interpreter result is not modified unless there is an error.
1168 *
1169 *--------------------------------------------------------------
1170 */
1171
1172 int
Tcl_ExprObj(Tcl_Interp * interp,register Tcl_Obj * objPtr,Tcl_Obj ** resultPtrPtr)1173 Tcl_ExprObj(
1174 Tcl_Interp *interp, /* Context in which to evaluate the
1175 * expression. */
1176 register Tcl_Obj *objPtr, /* Points to Tcl object containing expression
1177 * to evaluate. */
1178 Tcl_Obj **resultPtrPtr) /* Where the Tcl_Obj* that is the expression
1179 * result is stored if no errors occur. */
1180 {
1181 Interp *iPtr = (Interp *) interp;
1182 CompileEnv compEnv; /* Compilation environment structure allocated
1183 * in frame. */
1184 register ByteCode *codePtr = NULL;
1185 /* Tcl Internal type of bytecode. Initialized
1186 * to avoid compiler warning. */
1187 int result;
1188
1189 /*
1190 * Execute the expression after first saving the interpreter's result.
1191 */
1192
1193 Tcl_Obj *saveObjPtr = Tcl_GetObjResult(interp);
1194 Tcl_IncrRefCount(saveObjPtr);
1195
1196 /*
1197 * Get the expression ByteCode from the object. If it exists, make sure it
1198 * is valid in the current context.
1199 */
1200 if (objPtr->typePtr == &exprCodeType) {
1201 Namespace *namespacePtr = iPtr->varFramePtr->nsPtr;
1202
1203 codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
1204 if (((Interp *) *codePtr->interpHandle != iPtr)
1205 || (codePtr->compileEpoch != iPtr->compileEpoch)
1206 || (codePtr->nsPtr != namespacePtr)
1207 || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
1208 objPtr->typePtr->freeIntRepProc(objPtr);
1209 objPtr->typePtr = (Tcl_ObjType *) NULL;
1210 }
1211 }
1212 if (objPtr->typePtr != &exprCodeType) {
1213 /*
1214 * TIP #280: No invoker (yet) - Expression compilation.
1215 */
1216
1217 int length;
1218 const char *string = TclGetStringFromObj(objPtr, &length);
1219
1220 TclInitCompileEnv(interp, &compEnv, string, length, NULL, 0);
1221 TclCompileExpr(interp, string, length, &compEnv, 0);
1222
1223 /*
1224 * Successful compilation. If the expression yielded no instructions,
1225 * push an zero object as the expression's result.
1226 */
1227
1228 if (compEnv.codeNext == compEnv.codeStart) {
1229 TclEmitPush(TclRegisterNewLiteral(&compEnv, "0", 1),
1230 &compEnv);
1231 }
1232
1233 /*
1234 * Add a "done" instruction as the last instruction and change the
1235 * object into a ByteCode object. Ownership of the literal objects and
1236 * aux data items is given to the ByteCode object.
1237 */
1238
1239 TclEmitOpcode(INST_DONE, &compEnv);
1240 TclInitByteCodeObj(objPtr, &compEnv);
1241 objPtr->typePtr = &exprCodeType;
1242 TclFreeCompileEnv(&compEnv);
1243 codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
1244 #ifdef TCL_COMPILE_DEBUG
1245 if (tclTraceCompile == 2) {
1246 TclPrintByteCodeObj(interp, objPtr);
1247 fflush(stdout);
1248 }
1249 #endif /* TCL_COMPILE_DEBUG */
1250 }
1251
1252 Tcl_ResetResult(interp);
1253
1254 /*
1255 * Increment the code's ref count while it is being executed. If
1256 * afterwards no references to it remain, free the code.
1257 */
1258
1259 codePtr->refCount++;
1260 result = TclExecuteByteCode(interp, codePtr);
1261 codePtr->refCount--;
1262 if (codePtr->refCount <= 0) {
1263 TclCleanupByteCode(codePtr);
1264 }
1265
1266 /*
1267 * If the expression evaluated successfully, store a pointer to its value
1268 * object in resultPtrPtr then restore the old interpreter result. We
1269 * increment the object's ref count to reflect the reference that we are
1270 * returning to the caller. We also decrement the ref count of the
1271 * interpreter's result object after calling Tcl_SetResult since we next
1272 * store into that field directly.
1273 */
1274
1275 if (result == TCL_OK) {
1276 *resultPtrPtr = iPtr->objResultPtr;
1277 Tcl_IncrRefCount(iPtr->objResultPtr);
1278
1279 Tcl_SetObjResult(interp, saveObjPtr);
1280 }
1281 TclDecrRefCount(saveObjPtr);
1282 return result;
1283 }
1284
1285 /*
1286 *----------------------------------------------------------------------
1287 *
1288 * DupExprCodeInternalRep --
1289 *
1290 * Part of the Tcl object type implementation for Tcl expression
1291 * bytecode. We do not copy the bytecode intrep. Instead, we
1292 * return without setting copyPtr->typePtr, so the copy is a plain
1293 * string copy of the expression value, and if it is to be used
1294 * as a compiled expression, it will just need a recompile.
1295 *
1296 * This makes sense, because with Tcl's copy-on-write practices,
1297 * the usual (only?) time Tcl_DuplicateObj() will be called is
1298 * when the copy is about to be modified, which would invalidate
1299 * any copied bytecode anyway. The only reason it might make sense
1300 * to copy the bytecode is if we had some modifying routines that
1301 * operated directly on the intrep, like we do for lists and dicts.
1302 *
1303 * Results:
1304 * None.
1305 *
1306 * Side effects:
1307 * None.
1308 *
1309 *----------------------------------------------------------------------
1310 */
1311
1312 static void
DupExprCodeInternalRep(Tcl_Obj * srcPtr,Tcl_Obj * copyPtr)1313 DupExprCodeInternalRep(
1314 Tcl_Obj *srcPtr,
1315 Tcl_Obj *copyPtr)
1316 {
1317 return;
1318 }
1319
1320 /*
1321 *----------------------------------------------------------------------
1322 *
1323 * FreeExprCodeInternalRep --
1324 *
1325 * Part of the Tcl object type implementation for Tcl expression
1326 * bytecode. Frees the storage allocated to hold the internal rep,
1327 * unless ref counts indicate bytecode execution is still in progress.
1328 *
1329 * Results:
1330 * None.
1331 *
1332 * Side effects:
1333 * May free allocated memory. Leaves objPtr untyped.
1334 *----------------------------------------------------------------------
1335 */
1336
1337 static void
FreeExprCodeInternalRep(Tcl_Obj * objPtr)1338 FreeExprCodeInternalRep(
1339 Tcl_Obj *objPtr)
1340 {
1341 ByteCode *codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
1342
1343 codePtr->refCount--;
1344 if (codePtr->refCount <= 0) {
1345 TclCleanupByteCode(codePtr);
1346 }
1347 objPtr->typePtr = NULL;
1348 }
1349
1350 /*
1351 *----------------------------------------------------------------------
1352 *
1353 * TclCompEvalObj --
1354 *
1355 * This procedure evaluates the script contained in a Tcl_Obj by first
1356 * compiling it and then passing it to TclExecuteByteCode.
1357 *
1358 * Results:
1359 * The return value is one of the return codes defined in tcl.h (such as
1360 * TCL_OK), and interp->objResultPtr refers to a Tcl object that either
1361 * contains the result of executing the code or an error message.
1362 *
1363 * Side effects:
1364 * Almost certainly, depending on the ByteCode's instructions.
1365 *
1366 *----------------------------------------------------------------------
1367 */
1368
1369 int
TclCompEvalObj(Tcl_Interp * interp,Tcl_Obj * objPtr,const CmdFrame * invoker,int word)1370 TclCompEvalObj(
1371 Tcl_Interp *interp,
1372 Tcl_Obj *objPtr,
1373 const CmdFrame *invoker,
1374 int word)
1375 {
1376 register Interp *iPtr = (Interp *) interp;
1377 register ByteCode *codePtr; /* Tcl Internal type of bytecode. */
1378 int result;
1379 Namespace *namespacePtr;
1380
1381 /*
1382 * Check that the interpreter is ready to execute scripts. Note that we
1383 * manage the interp's runlevel here: it is a small white lie (maybe), but
1384 * saves a ++/-- pair at each invocation. Amazingly enough, the impact on
1385 * performance is noticeable.
1386 */
1387
1388 iPtr->numLevels++;
1389 if (TclInterpReady(interp) == TCL_ERROR) {
1390 result = TCL_ERROR;
1391 goto done;
1392 }
1393
1394 namespacePtr = iPtr->varFramePtr->nsPtr;
1395
1396 /*
1397 * If the object is not already of tclByteCodeType, compile it (and reset
1398 * the compilation flags in the interpreter; this should be done after any
1399 * compilation). Otherwise, check that it is "fresh" enough.
1400 */
1401
1402 if (objPtr->typePtr == &tclByteCodeType) {
1403 /*
1404 * Make sure the Bytecode hasn't been invalidated by, e.g., someone
1405 * redefining a command with a compile procedure (this might make the
1406 * compiled code wrong). The object needs to be recompiled if it was
1407 * compiled in/for a different interpreter, or for a different
1408 * namespace, or for the same namespace but with different name
1409 * resolution rules. Precompiled objects, however, are immutable and
1410 * therefore they are not recompiled, even if the epoch has changed.
1411 *
1412 * To be pedantically correct, we should also check that the
1413 * originating procPtr is the same as the current context procPtr
1414 * (assuming one exists at all - none for global level). This code is
1415 * #def'ed out because [info body] was changed to never return a
1416 * bytecode type object, which should obviate us from the extra checks
1417 * here.
1418 */
1419
1420 codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
1421 if (((Interp *) *codePtr->interpHandle != iPtr)
1422 || (codePtr->compileEpoch != iPtr->compileEpoch)
1423 || (codePtr->nsPtr != namespacePtr)
1424 || (codePtr->nsEpoch != namespacePtr->resolverEpoch)) {
1425 if (codePtr->flags & TCL_BYTECODE_PRECOMPILED) {
1426 if ((Interp *) *codePtr->interpHandle != iPtr) {
1427 Tcl_Panic("Tcl_EvalObj: compiled script jumped interps");
1428 }
1429 codePtr->compileEpoch = iPtr->compileEpoch;
1430 } else {
1431 /*
1432 * This byteCode is invalid: free it and recompile.
1433 */
1434
1435 objPtr->typePtr->freeIntRepProc(objPtr);
1436 goto recompileObj;
1437 }
1438 }
1439
1440 /*
1441 * #280.
1442 * Literal sharing fix. This part of the fix is not required by 8.4
1443 * because it eval-directs any literals, so just saving the argument
1444 * locations per command in bytecode is enough, embedded 'eval'
1445 * commands, etc. get the correct information.
1446 *
1447 * It had be backported for 8.5 because we can force the separate
1448 * compiling of a literal (in a proc body) by putting it into a control
1449 * command with dynamic pieces, and then such literal may be shared
1450 * and require their line-information to be reset, as for 8.6, as
1451 * described below.
1452 *
1453 * In 8.6 all the embedded script are compiled, and the resulting
1454 * bytecode stored in the literal. Now the shared literal has bytecode
1455 * with location data for _one_ particular location this literal is
1456 * found at. If we get executed from a different location the bytecode
1457 * has to be recompiled to get the correct locations. Not doing this
1458 * will execute the saved bytecode with data for a different location,
1459 * causing 'info frame' to point to the wrong place in the sources.
1460 *
1461 * Future optimizations ...
1462 * (1) Save the location data (ExtCmdLoc) keyed by start line. In that
1463 * case we recompile once per location of the literal, but not
1464 * continously, because the moment we have all locations we do not
1465 * need to recompile any longer.
1466 *
1467 * (2) Alternative: Do not recompile, tell the execution engine the
1468 * offset between saved starting line and actual one. Then modify
1469 * the users to adjust the locations they have by this offset.
1470 *
1471 * (3) Alternative 2: Do not fully recompile, adjust just the location
1472 * information.
1473 */
1474
1475 if (invoker) {
1476 Tcl_HashEntry *hePtr =
1477 Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
1478
1479 if (hePtr) {
1480 ExtCmdLoc *eclPtr = Tcl_GetHashValue(hePtr);
1481 int redo = 0;
1482 CmdFrame *ctxPtr = TclStackAlloc(interp,sizeof(CmdFrame));
1483
1484 *ctxPtr = *invoker;
1485
1486 if (invoker->type == TCL_LOCATION_BC) {
1487 /*
1488 * Note: Type BC => ctx.data.eval.path is not used.
1489 * ctx.data.tebc.codePtr used instead
1490 */
1491
1492 TclGetSrcInfoForPc(ctxPtr);
1493 if (ctxPtr->type == TCL_LOCATION_SOURCE) {
1494 /*
1495 * The reference made by 'TclGetSrcInfoForPc' is
1496 * dead.
1497 */
1498
1499 Tcl_DecrRefCount(ctxPtr->data.eval.path);
1500 ctxPtr->data.eval.path = NULL;
1501 }
1502 }
1503
1504 if (word < ctxPtr->nline) {
1505 /*
1506 * Note: We do not care if the line[word] is -1. This
1507 * is a difference and requires a recompile (location
1508 * changed from absolute to relative, literal is used
1509 * fixed and through variable)
1510 *
1511 * Example:
1512 * test info-32.0 using literal of info-24.8
1513 * (dict with ... vs set body ...).
1514 */
1515
1516 redo = ((eclPtr->type == TCL_LOCATION_SOURCE)
1517 && (eclPtr->start != ctxPtr->line[word]))
1518 || ((eclPtr->type == TCL_LOCATION_BC)
1519 && (ctxPtr->type == TCL_LOCATION_SOURCE));
1520 }
1521
1522 TclStackFree(interp, ctxPtr);
1523
1524 if (redo) {
1525 goto recompileObj;
1526 }
1527 }
1528 }
1529
1530 /*
1531 * Increment the code's ref count while it is being executed. If
1532 * afterwards no references to it remain, free the code.
1533 */
1534
1535 runCompiledObj:
1536 codePtr->refCount++;
1537 result = TclExecuteByteCode(interp, codePtr);
1538 codePtr->refCount--;
1539 if (codePtr->refCount <= 0) {
1540 TclCleanupByteCode(codePtr);
1541 }
1542 goto done;
1543 }
1544
1545 recompileObj:
1546 iPtr->errorLine = 1;
1547
1548 /*
1549 * TIP #280. Remember the invoker for a moment in the interpreter
1550 * structures so that the byte code compiler can pick it up when
1551 * initializing the compilation environment, i.e. the extended location
1552 * information.
1553 */
1554
1555 iPtr->invokeCmdFramePtr = invoker;
1556 iPtr->invokeWord = word;
1557 tclByteCodeType.setFromAnyProc(interp, objPtr);
1558 iPtr->invokeCmdFramePtr = NULL;
1559 codePtr = (ByteCode *) objPtr->internalRep.twoPtrValue.ptr1;
1560 goto runCompiledObj;
1561
1562 done:
1563 iPtr->numLevels--;
1564 return result;
1565 }
1566
1567 /*
1568 *----------------------------------------------------------------------
1569 *
1570 * TclIncrObj --
1571 *
1572 * Increment an integeral value in a Tcl_Obj by an integeral value held
1573 * in another Tcl_Obj. Caller is responsible for making sure we can
1574 * update the first object.
1575 *
1576 * Results:
1577 * TCL_ERROR if either object is non-integer, and TCL_OK otherwise. On
1578 * error, an error message is left in the interpreter (if it is not NULL,
1579 * of course).
1580 *
1581 * Side effects:
1582 * valuePtr gets the new incrmented value.
1583 *
1584 *----------------------------------------------------------------------
1585 */
1586
1587 int
TclIncrObj(Tcl_Interp * interp,Tcl_Obj * valuePtr,Tcl_Obj * incrPtr)1588 TclIncrObj(
1589 Tcl_Interp *interp,
1590 Tcl_Obj *valuePtr,
1591 Tcl_Obj *incrPtr)
1592 {
1593 ClientData ptr1, ptr2;
1594 int type1, type2;
1595 mp_int value, incr;
1596
1597 if (Tcl_IsShared(valuePtr)) {
1598 Tcl_Panic("%s called with shared object", "TclIncrObj");
1599 }
1600
1601 if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
1602 /*
1603 * Produce error message (reparse?!)
1604 */
1605
1606 return TclGetIntFromObj(interp, valuePtr, &type1);
1607 }
1608 if (GetNumberFromObj(NULL, incrPtr, &ptr2, &type2) != TCL_OK) {
1609 /*
1610 * Produce error message (reparse?!)
1611 */
1612
1613 TclGetIntFromObj(interp, incrPtr, &type1);
1614 Tcl_AddErrorInfo(interp, "\n (reading increment)");
1615 return TCL_ERROR;
1616 }
1617
1618 if ((type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
1619 long augend = *((const long *) ptr1);
1620 long addend = *((const long *) ptr2);
1621 long sum = augend + addend;
1622
1623 /*
1624 * Overflow when (augend and sum have different sign) and (augend and
1625 * addend have the same sign). This is encapsulated in the Overflowing
1626 * macro.
1627 */
1628
1629 if (!Overflowing(augend, addend, sum)) {
1630 TclSetLongObj(valuePtr, sum);
1631 return TCL_OK;
1632 }
1633 #ifndef NO_WIDE_TYPE
1634 {
1635 Tcl_WideInt w1 = (Tcl_WideInt) augend;
1636 Tcl_WideInt w2 = (Tcl_WideInt) addend;
1637
1638 /*
1639 * We know the sum value is outside the long range, so we use the
1640 * macro form that doesn't range test again.
1641 */
1642
1643 TclSetWideIntObj(valuePtr, w1 + w2);
1644 return TCL_OK;
1645 }
1646 #endif
1647 }
1648
1649 if ((type1 == TCL_NUMBER_DOUBLE) || (type1 == TCL_NUMBER_NAN)) {
1650 /*
1651 * Produce error message (reparse?!)
1652 */
1653
1654 return TclGetIntFromObj(interp, valuePtr, &type1);
1655 }
1656 if ((type2 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_NAN)) {
1657 /*
1658 * Produce error message (reparse?!)
1659 */
1660
1661 TclGetIntFromObj(interp, incrPtr, &type1);
1662 Tcl_AddErrorInfo(interp, "\n (reading increment)");
1663 return TCL_ERROR;
1664 }
1665
1666 #ifndef NO_WIDE_TYPE
1667 if ((type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
1668 Tcl_WideInt w1, w2, sum;
1669
1670 TclGetWideIntFromObj(NULL, valuePtr, &w1);
1671 TclGetWideIntFromObj(NULL, incrPtr, &w2);
1672 sum = w1 + w2;
1673
1674 /*
1675 * Check for overflow.
1676 */
1677
1678 if (!Overflowing(w1, w2, sum)) {
1679 Tcl_SetWideIntObj(valuePtr, sum);
1680 return TCL_OK;
1681 }
1682 }
1683 #endif
1684
1685 Tcl_TakeBignumFromObj(interp, valuePtr, &value);
1686 Tcl_GetBignumFromObj(interp, incrPtr, &incr);
1687 mp_add(&value, &incr, &value);
1688 mp_clear(&incr);
1689 Tcl_SetBignumObj(valuePtr, &value);
1690 return TCL_OK;
1691 }
1692
1693 /*
1694 *----------------------------------------------------------------------
1695 *
1696 * TclExecuteByteCode --
1697 *
1698 * This procedure executes the instructions of a ByteCode structure. It
1699 * returns when a "done" instruction is executed or an error occurs.
1700 *
1701 * Results:
1702 * The return value is one of the return codes defined in tcl.h (such as
1703 * TCL_OK), and interp->objResultPtr refers to a Tcl object that either
1704 * contains the result of executing the code or an error message.
1705 *
1706 * Side effects:
1707 * Almost certainly, depending on the ByteCode's instructions.
1708 *
1709 *----------------------------------------------------------------------
1710 */
1711
1712 int
TclExecuteByteCode(Tcl_Interp * interp,ByteCode * codePtr)1713 TclExecuteByteCode(
1714 Tcl_Interp *interp, /* Token for command interpreter. */
1715 ByteCode *codePtr) /* The bytecode sequence to interpret. */
1716 {
1717 /*
1718 * Compiler cast directive - not a real variable.
1719 * Interp *iPtr = (Interp *) interp;
1720 */
1721 #define iPtr ((Interp *) interp)
1722
1723 /*
1724 * Check just the read-traced/write-traced bit of a variable.
1725 */
1726
1727 #define ReadTraced(varPtr) ((varPtr)->flags & VAR_TRACED_READ)
1728 #define WriteTraced(varPtr) ((varPtr)->flags & VAR_TRACED_WRITE)
1729
1730 /*
1731 * Constants: variables that do not change during the execution, used
1732 * sporadically.
1733 */
1734
1735 ExecStack *esPtr;
1736 Tcl_Obj **initTosPtr; /* Stack top at start of execution. */
1737 ptrdiff_t *initCatchTop; /* Catch stack top at start of execution. */
1738 Var *compiledLocals;
1739 Namespace *namespacePtr;
1740 CmdFrame *bcFramePtr; /* TIP #280: Structure for tracking lines. */
1741 Tcl_Obj **constants = &iPtr->execEnvPtr->constants[0];
1742
1743 /*
1744 * Globals: variables that store state, must remain valid at all times.
1745 */
1746
1747 ptrdiff_t *catchTop;
1748 register Tcl_Obj **tosPtr; /* Cached pointer to top of evaluation
1749 * stack. */
1750 register unsigned char *pc = codePtr->codeStart;
1751 /* The current program counter. */
1752 int instructionCount = 0; /* Counter that is used to work out when to
1753 * call Tcl_AsyncReady() */
1754 Tcl_Obj *expandNestList = NULL;
1755 int checkInterp = 0; /* Indicates when a check of interp readyness
1756 * is necessary. Set by CACHE_STACK_INFO() */
1757
1758 /*
1759 * Transfer variables - needed only between opcodes, but not while
1760 * executing an instruction.
1761 */
1762
1763 register int cleanup;
1764 Tcl_Obj *objResultPtr;
1765
1766 /*
1767 * Result variable - needed only when going to checkForcatch or other
1768 * error handlers; also used as local in some opcodes.
1769 */
1770
1771 int result = TCL_OK; /* Return code returned after execution. */
1772
1773 /*
1774 * Locals - variables that are used within opcodes or bounded sections of
1775 * the file (jumps between opcodes within a family).
1776 * NOTE: These are now defined locally where needed.
1777 */
1778
1779 #ifdef TCL_COMPILE_DEBUG
1780 int traceInstructions = (tclTraceExec == 3);
1781 char cmdNameBuf[21];
1782 #endif
1783 const char *curInstName = NULL;
1784
1785 /*
1786 * The execution uses a unified stack: first the catch stack, immediately
1787 * above it a CmdFrame, then the execution stack.
1788 *
1789 * Make sure the catch stack is large enough to hold the maximum number of
1790 * catch commands that could ever be executing at the same time (this will
1791 * be no more than the exception range array's depth). Make sure the
1792 * execution stack is large enough to execute this ByteCode.
1793 */
1794
1795 catchTop = initCatchTop = (ptrdiff_t *) (
1796 GrowEvaluationStack(iPtr->execEnvPtr,
1797 (sizeof(CmdFrame) + sizeof(Tcl_Obj *) - 1)/sizeof(Tcl_Obj *) +
1798 codePtr->maxExceptDepth + codePtr->maxStackDepth, 0) - 1);
1799 bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1);
1800 tosPtr = initTosPtr = ((Tcl_Obj **) (bcFramePtr + 1)) - 1;
1801 esPtr = iPtr->execEnvPtr->execStackPtr;
1802
1803 /*
1804 * TIP #280: Initialize the frame. Do not push it yet.
1805 */
1806
1807 bcFramePtr->type = ((codePtr->flags & TCL_BYTECODE_PRECOMPILED)
1808 ? TCL_LOCATION_PREBC : TCL_LOCATION_BC);
1809 bcFramePtr->level = (iPtr->cmdFramePtr ? iPtr->cmdFramePtr->level+1 : 1);
1810 bcFramePtr->framePtr = iPtr->framePtr;
1811 bcFramePtr->nextPtr = iPtr->cmdFramePtr;
1812 bcFramePtr->nline = 0;
1813 bcFramePtr->line = NULL;
1814
1815 bcFramePtr->data.tebc.codePtr = codePtr;
1816 bcFramePtr->data.tebc.pc = NULL;
1817 bcFramePtr->cmd.str.cmd = NULL;
1818 bcFramePtr->cmd.str.len = 0;
1819
1820 #ifdef TCL_COMPILE_DEBUG
1821 if (tclTraceExec >= 2) {
1822 PrintByteCodeInfo(codePtr);
1823 fprintf(stdout, " Starting stack top=%d\n", (int) CURR_DEPTH);
1824 fflush(stdout);
1825 }
1826 #endif
1827
1828 #ifdef TCL_COMPILE_STATS
1829 iPtr->stats.numExecutions++;
1830 #endif
1831
1832 namespacePtr = iPtr->varFramePtr->nsPtr;
1833 compiledLocals = iPtr->varFramePtr->compiledLocals;
1834
1835 /*
1836 * Loop executing instructions until a "done" instruction, a TCL_RETURN,
1837 * or some error.
1838 */
1839
1840 goto cleanup0;
1841
1842 /*
1843 * Targets for standard instruction endings; unrolled for speed in the
1844 * most frequent cases (instructions that consume up to two stack
1845 * elements).
1846 *
1847 * This used to be a "for(;;)" loop, with each instruction doing its own
1848 * cleanup.
1849 */
1850
1851 {
1852 Tcl_Obj *valuePtr;
1853
1854 cleanupV_pushObjResultPtr:
1855 switch (cleanup) {
1856 case 0:
1857 *(++tosPtr) = (objResultPtr);
1858 goto cleanup0;
1859 default:
1860 cleanup -= 2;
1861 while (cleanup--) {
1862 valuePtr = POP_OBJECT();
1863 TclDecrRefCount(valuePtr);
1864 }
1865 case 2:
1866 cleanup2_pushObjResultPtr:
1867 valuePtr = POP_OBJECT();
1868 TclDecrRefCount(valuePtr);
1869 case 1:
1870 cleanup1_pushObjResultPtr:
1871 valuePtr = OBJ_AT_TOS;
1872 TclDecrRefCount(valuePtr);
1873 }
1874 OBJ_AT_TOS = objResultPtr;
1875 goto cleanup0;
1876
1877 cleanupV:
1878 switch (cleanup) {
1879 default:
1880 cleanup -= 2;
1881 while (cleanup--) {
1882 valuePtr = POP_OBJECT();
1883 TclDecrRefCount(valuePtr);
1884 }
1885 case 2:
1886 cleanup2:
1887 valuePtr = POP_OBJECT();
1888 TclDecrRefCount(valuePtr);
1889 case 1:
1890 cleanup1:
1891 valuePtr = POP_OBJECT();
1892 TclDecrRefCount(valuePtr);
1893 case 0:
1894 /*
1895 * We really want to do nothing now, but this is needed for some
1896 * compilers (SunPro CC).
1897 */
1898
1899 break;
1900 }
1901 }
1902 cleanup0:
1903
1904 #ifdef TCL_COMPILE_DEBUG
1905 /*
1906 * Skip the stack depth check if an expansion is in progress.
1907 */
1908
1909 ValidatePcAndStackTop(codePtr, pc, CURR_DEPTH, 0,
1910 /*checkStack*/ expandNestList == NULL);
1911 if (traceInstructions) {
1912 fprintf(stdout, "%2d: %2d ", iPtr->numLevels, (int) CURR_DEPTH);
1913 TclPrintInstruction(codePtr, pc);
1914 fflush(stdout);
1915 }
1916 #endif /* TCL_COMPILE_DEBUG */
1917
1918 #ifdef TCL_COMPILE_STATS
1919 iPtr->stats.instructionCount[*pc]++;
1920 #endif
1921
1922 /*
1923 * Check for asynchronous handlers [Bug 746722]; we do the check every
1924 * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-1).
1925 */
1926
1927 if ((instructionCount++ & ASYNC_CHECK_COUNT_MASK) == 0) {
1928 /*
1929 * Check for asynchronous handlers [Bug 746722]; we do the check every
1930 * ASYNC_CHECK_COUNT_MASK instruction, of the form (2**n-<1).
1931 */
1932
1933 if (TclAsyncReady(iPtr)) {
1934 int localResult;
1935
1936 DECACHE_STACK_INFO();
1937 localResult = Tcl_AsyncInvoke(interp, result);
1938 CACHE_STACK_INFO();
1939 if (localResult == TCL_ERROR) {
1940 result = localResult;
1941 goto checkForCatch;
1942 }
1943 }
1944 if (TclLimitReady(iPtr->limit)) {
1945 int localResult;
1946
1947 DECACHE_STACK_INFO();
1948 localResult = Tcl_LimitCheck(interp);
1949 CACHE_STACK_INFO();
1950 if (localResult == TCL_ERROR) {
1951 result = localResult;
1952 goto checkForCatch;
1953 }
1954 }
1955 }
1956
1957 TCL_DTRACE_INST_NEXT();
1958
1959 /*
1960 * These two instructions account for 26% of all instructions (according
1961 * to measurements on tclbench by Ben Vitale
1962 * [http://www.cs.toronto.edu/syslab/pubs/tcl2005-vitale-zaleski.pdf]
1963 * Resolving them before the switch reduces the cost of branch
1964 * mispredictions, seems to improve runtime by 5% to 15%, and (amazingly!)
1965 * reduces total obj size.
1966 */
1967
1968 if (*pc == INST_LOAD_SCALAR1) {
1969 goto instLoadScalar1;
1970 } else if (*pc == INST_PUSH1) {
1971 goto instPush1Peephole;
1972 }
1973
1974 switch (*pc) {
1975 case INST_SYNTAX:
1976 case INST_RETURN_IMM: {
1977 int code = TclGetInt4AtPtr(pc+1);
1978 int level = TclGetUInt4AtPtr(pc+5);
1979
1980 /*
1981 * OBJ_AT_TOS is returnOpts, OBJ_UNDER_TOS is resultObjPtr.
1982 */
1983
1984 TRACE(("%u %u => ", code, level));
1985 result = TclProcessReturn(interp, code, level, OBJ_AT_TOS);
1986 if (result == TCL_OK) {
1987 TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
1988 O2S(objResultPtr)));
1989 NEXT_INST_F(9, 1, 0);
1990 } else {
1991 Tcl_SetObjResult(interp, OBJ_UNDER_TOS);
1992 if (*pc == INST_SYNTAX) {
1993 iPtr->flags &= ~ERR_ALREADY_LOGGED;
1994 }
1995 cleanup = 2;
1996 goto processExceptionReturn;
1997 }
1998 }
1999
2000 case INST_RETURN_STK:
2001 TRACE(("=> "));
2002 objResultPtr = POP_OBJECT();
2003 result = Tcl_SetReturnOptions(interp, OBJ_AT_TOS);
2004 Tcl_DecrRefCount(OBJ_AT_TOS);
2005 OBJ_AT_TOS = objResultPtr;
2006 if (result == TCL_OK) {
2007 TRACE_APPEND(("continuing to next instruction (result=\"%.30s\")",
2008 O2S(objResultPtr)));
2009 NEXT_INST_F(1, 0, 0);
2010 } else {
2011 Tcl_SetObjResult(interp, objResultPtr);
2012 cleanup = 1;
2013 goto processExceptionReturn;
2014 }
2015
2016 case INST_DONE:
2017 if (tosPtr > initTosPtr) {
2018 /*
2019 * Set the interpreter's object result to point to the topmost
2020 * object from the stack, and check for a possible [catch]. The
2021 * stackTop's level and refCount will be handled by "processCatch"
2022 * or "abnormalReturn".
2023 */
2024
2025 Tcl_SetObjResult(interp, OBJ_AT_TOS);
2026 #ifdef TCL_COMPILE_DEBUG
2027 TRACE_WITH_OBJ(("=> return code=%d, result=", result),
2028 iPtr->objResultPtr);
2029 if (traceInstructions) {
2030 fprintf(stdout, "\n");
2031 }
2032 #endif
2033 goto checkForCatch;
2034 } else {
2035 (void) POP_OBJECT();
2036 goto abnormalReturn;
2037 }
2038
2039 case INST_PUSH1:
2040 instPush1Peephole:
2041 PUSH_OBJECT(codePtr->objArrayPtr[TclGetUInt1AtPtr(pc+1)]);
2042 TRACE_WITH_OBJ(("%u => ", TclGetInt1AtPtr(pc+1)), OBJ_AT_TOS);
2043 pc += 2;
2044 #if !TCL_COMPILE_DEBUG
2045 /*
2046 * Runtime peephole optimisation: check if we are pushing again.
2047 */
2048
2049 if (*pc == INST_PUSH1) {
2050 TCL_DTRACE_INST_NEXT();
2051 goto instPush1Peephole;
2052 }
2053 #endif
2054 NEXT_INST_F(0, 0, 0);
2055
2056 case INST_PUSH4:
2057 objResultPtr = codePtr->objArrayPtr[TclGetUInt4AtPtr(pc+1)];
2058 TRACE_WITH_OBJ(("%u => ", TclGetUInt4AtPtr(pc+1)), objResultPtr);
2059 NEXT_INST_F(5, 0, 1);
2060
2061 case INST_POP: {
2062 Tcl_Obj *valuePtr;
2063
2064 TRACE_WITH_OBJ(("=> discarding "), OBJ_AT_TOS);
2065 valuePtr = POP_OBJECT();
2066 TclDecrRefCount(valuePtr);
2067
2068 /*
2069 * Runtime peephole optimisation: an INST_POP is scheduled at the end
2070 * of most commands. If the next instruction is an INST_START_CMD,
2071 * fall through to it.
2072 */
2073
2074 pc++;
2075 #if !TCL_COMPILE_DEBUG
2076 if (*pc == INST_START_CMD) {
2077 TCL_DTRACE_INST_NEXT();
2078 goto instStartCmdPeephole;
2079 }
2080 #endif
2081 NEXT_INST_F(0, 0, 0);
2082 }
2083
2084 case INST_START_CMD:
2085 #if !TCL_COMPILE_DEBUG
2086 instStartCmdPeephole:
2087 #endif
2088 /*
2089 * Remark that if the interpreter is marked for deletion its
2090 * compileEpoch is modified, so that the epoch check also verifies
2091 * that the interp is not deleted. If no outside call has been made
2092 * since the last check, it is safe to omit the check.
2093 */
2094
2095 iPtr->cmdCount += TclGetUInt4AtPtr(pc+5);
2096 if (!checkInterp) {
2097 instStartCmdOK:
2098 NEXT_INST_F(9, 0, 0);
2099 } else if (((codePtr->compileEpoch == iPtr->compileEpoch)
2100 && (codePtr->nsEpoch == namespacePtr->resolverEpoch))
2101 || (codePtr->flags & TCL_BYTECODE_PRECOMPILED)) {
2102 checkInterp = 0;
2103 goto instStartCmdOK;
2104 } else {
2105 const char *bytes;
2106 int length, opnd;
2107 Tcl_Obj *newObjResultPtr;
2108
2109 bytes = GetSrcInfoForPc(pc, codePtr, &length);
2110 DECACHE_STACK_INFO();
2111 result = Tcl_EvalEx(interp, bytes, length, 0);
2112 CACHE_STACK_INFO();
2113 if (result != TCL_OK) {
2114 cleanup = 0;
2115 if (result == TCL_ERROR) {
2116 /*
2117 * Tcl_EvalEx already did the task of logging
2118 * the error to the stack trace for us, so set
2119 * a flag to prevent the TEBC exception handling
2120 * machinery from trying to do it again.
2121 * Tcl Bug 2037338. See test execute-8.4.
2122 */
2123 iPtr->flags |= ERR_ALREADY_LOGGED;
2124 }
2125 goto processExceptionReturn;
2126 }
2127 opnd = TclGetUInt4AtPtr(pc+1);
2128 objResultPtr = Tcl_GetObjResult(interp);
2129 TclNewObj(newObjResultPtr);
2130 Tcl_IncrRefCount(newObjResultPtr);
2131 iPtr->objResultPtr = newObjResultPtr;
2132 NEXT_INST_V(opnd, 0, -1);
2133 }
2134
2135 case INST_DUP:
2136 objResultPtr = OBJ_AT_TOS;
2137 TRACE_WITH_OBJ(("=> "), objResultPtr);
2138 NEXT_INST_F(1, 0, 1);
2139
2140 case INST_OVER: {
2141 int opnd;
2142
2143 opnd = TclGetUInt4AtPtr(pc+1);
2144 objResultPtr = OBJ_AT_DEPTH(opnd);
2145 TRACE_WITH_OBJ(("=> "), objResultPtr);
2146 NEXT_INST_F(5, 0, 1);
2147 }
2148
2149 case INST_REVERSE: {
2150 int opnd;
2151 Tcl_Obj **a, **b;
2152
2153 opnd = TclGetUInt4AtPtr(pc+1);
2154 a = tosPtr-(opnd-1);
2155 b = tosPtr;
2156 while (a<b) {
2157 Tcl_Obj *temp = *a;
2158 *a = *b;
2159 *b = temp;
2160 a++; b--;
2161 }
2162 NEXT_INST_F(5, 0, 0);
2163 }
2164
2165 case INST_CONCAT1: {
2166 int opnd, length, appendLen = 0;
2167 char *bytes, *p;
2168 Tcl_Obj **currPtr;
2169
2170 opnd = TclGetUInt1AtPtr(pc+1);
2171
2172 /*
2173 * Compute the length to be appended.
2174 */
2175
2176 for (currPtr=&OBJ_AT_DEPTH(opnd-2);
2177 appendLen >= 0 && currPtr<=&OBJ_AT_TOS; currPtr++) {
2178 bytes = TclGetStringFromObj(*currPtr, &length);
2179 if (bytes != NULL) {
2180 appendLen += length;
2181 }
2182 }
2183
2184 if (appendLen < 0) {
2185 /* TODO: convert panic to error ? */
2186 Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
2187 }
2188
2189 /*
2190 * If nothing is to be appended, just return the first object by
2191 * dropping all the others from the stack; this saves both the
2192 * computation and copy of the string rep of the first object,
2193 * enabling the fast '$x[set x {}]' idiom for 'K $x [set x {}]'.
2194 */
2195
2196 if (appendLen == 0) {
2197 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
2198 NEXT_INST_V(2, (opnd-1), 0);
2199 }
2200
2201 /*
2202 * If the first object is shared, we need a new obj for the result;
2203 * otherwise, we can reuse the first object. In any case, make sure it
2204 * has enough room to accomodate all the concatenated bytes. Note that
2205 * if it is unshared its bytes are copied by ckrealloc, so that we set
2206 * the loop parameters to avoid copying them again: p points to the
2207 * end of the already copied bytes, currPtr to the second object.
2208 */
2209
2210 objResultPtr = OBJ_AT_DEPTH(opnd-1);
2211 bytes = TclGetStringFromObj(objResultPtr, &length);
2212 if (length + appendLen < 0) {
2213 /* TODO: convert panic to error ? */
2214 Tcl_Panic("max size for a Tcl value (%d bytes) exceeded", INT_MAX);
2215 }
2216 #if !TCL_COMPILE_DEBUG
2217 if (bytes != tclEmptyStringRep && !Tcl_IsShared(objResultPtr)) {
2218 TclFreeIntRep(objResultPtr);
2219 objResultPtr->typePtr = NULL;
2220 objResultPtr->bytes = ckrealloc(bytes, (length + appendLen + 1));
2221 objResultPtr->length = length + appendLen;
2222 p = TclGetString(objResultPtr) + length;
2223 currPtr = &OBJ_AT_DEPTH(opnd - 2);
2224 } else {
2225 #endif
2226 p = (char *) ckalloc((unsigned) (length + appendLen + 1));
2227 TclNewObj(objResultPtr);
2228 objResultPtr->bytes = p;
2229 objResultPtr->length = length + appendLen;
2230 currPtr = &OBJ_AT_DEPTH(opnd - 1);
2231 #if !TCL_COMPILE_DEBUG
2232 }
2233 #endif
2234
2235 /*
2236 * Append the remaining characters.
2237 */
2238
2239 for (; currPtr <= &OBJ_AT_TOS; currPtr++) {
2240 bytes = TclGetStringFromObj(*currPtr, &length);
2241 if (bytes != NULL) {
2242 memcpy(p, bytes, (size_t) length);
2243 p += length;
2244 }
2245 }
2246 *p = '\0';
2247
2248 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
2249 NEXT_INST_V(2, opnd, 1);
2250 }
2251
2252 case INST_EXPAND_START: {
2253 /*
2254 * Push an element to the expandNestList. This records the current
2255 * stack depth - i.e., the point in the stack where the expanded
2256 * command starts.
2257 *
2258 * Use a Tcl_Obj as linked list element; slight mem waste, but faster
2259 * allocation than ckalloc. This also abuses the Tcl_Obj structure, as
2260 * we do not define a special tclObjType for it. It is not dangerous
2261 * as the obj is never passed anywhere, so that all manipulations are
2262 * performed here and in INST_INVOKE_EXPANDED (in case of an expansion
2263 * error, also in INST_EXPAND_STKTOP).
2264 */
2265
2266 Tcl_Obj *objPtr;
2267
2268 TclNewObj(objPtr);
2269 objPtr->internalRep.twoPtrValue.ptr1 = (VOID *) CURR_DEPTH;
2270 objPtr->internalRep.twoPtrValue.ptr2 = (VOID *) expandNestList;
2271 expandNestList = objPtr;
2272 NEXT_INST_F(1, 0, 0);
2273 }
2274
2275 case INST_EXPAND_STKTOP: {
2276 int objc, length, i;
2277 Tcl_Obj **objv, *valuePtr;
2278 ptrdiff_t moved;
2279
2280 /*
2281 * Make sure that the element at stackTop is a list; if not, just
2282 * leave with an error. Note that the element from the expand list
2283 * will be removed at checkForCatch.
2284 */
2285
2286 valuePtr = OBJ_AT_TOS;
2287 if (TclListObjGetElements(interp, valuePtr, &objc, &objv) != TCL_OK){
2288 TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
2289 Tcl_GetObjResult(interp));
2290 result = TCL_ERROR;
2291 goto checkForCatch;
2292 }
2293 (void) POP_OBJECT();
2294
2295 /*
2296 * Make sure there is enough room in the stack to expand this list
2297 * *and* process the rest of the command (at least up to the next
2298 * argument expansion or command end). The operand is the current
2299 * stack depth, as seen by the compiler.
2300 */
2301
2302 length = objc + (codePtr->maxStackDepth - TclGetInt4AtPtr(pc+1));
2303 DECACHE_STACK_INFO();
2304 moved = (GrowEvaluationStack(iPtr->execEnvPtr, length, 1) - 1)
2305 - (Tcl_Obj **) initCatchTop;
2306
2307 if (moved) {
2308 /*
2309 * Change the global data to point to the new stack.
2310 */
2311
2312 initCatchTop += moved;
2313 catchTop += moved;
2314 bcFramePtr = (CmdFrame *) (initCatchTop + codePtr->maxExceptDepth + 1);
2315 initTosPtr += moved;
2316 tosPtr += moved;
2317 esPtr = iPtr->execEnvPtr->execStackPtr;
2318 }
2319
2320 /*
2321 * Expand the list at stacktop onto the stack; free the list. Knowing
2322 * that it has a freeIntRepProc we use Tcl_DecrRefCount().
2323 */
2324
2325 for (i = 0; i < objc; i++) {
2326 PUSH_OBJECT(objv[i]);
2327 }
2328
2329 Tcl_DecrRefCount(valuePtr);
2330 NEXT_INST_F(5, 0, 0);
2331 }
2332
2333 {
2334 /*
2335 * INVOCATION BLOCK
2336 */
2337
2338 int objc, pcAdjustment;
2339
2340 case INST_INVOKE_EXPANDED:
2341 {
2342 Tcl_Obj *objPtr = expandNestList;
2343
2344 expandNestList = (Tcl_Obj *) objPtr->internalRep.twoPtrValue.ptr2;
2345 objc = CURR_DEPTH
2346 - (ptrdiff_t) objPtr->internalRep.twoPtrValue.ptr1;
2347 TclDecrRefCount(objPtr);
2348 }
2349
2350 if (objc) {
2351 pcAdjustment = 1;
2352 goto doInvocation;
2353 } else {
2354 /*
2355 * Nothing was expanded, return {}.
2356 */
2357
2358 TclNewObj(objResultPtr);
2359 NEXT_INST_F(1, 0, 1);
2360 }
2361
2362 case INST_INVOKE_STK4:
2363 objc = TclGetUInt4AtPtr(pc+1);
2364 pcAdjustment = 5;
2365 goto doInvocation;
2366
2367 case INST_INVOKE_STK1:
2368 objc = TclGetUInt1AtPtr(pc+1);
2369 pcAdjustment = 2;
2370
2371 doInvocation:
2372 {
2373 Tcl_Obj **objv = &OBJ_AT_DEPTH(objc-1);
2374
2375 #ifdef TCL_COMPILE_DEBUG
2376 if (tclTraceExec >= 2) {
2377 int i;
2378
2379 if (traceInstructions) {
2380 strncpy(cmdNameBuf, TclGetString(objv[0]), 20);
2381 TRACE(("%u => call ", objc));
2382 } else {
2383 fprintf(stdout, "%d: (%u) invoking ", iPtr->numLevels,
2384 (unsigned)(pc - codePtr->codeStart));
2385 }
2386 for (i = 0; i < objc; i++) {
2387 TclPrintObject(stdout, objv[i], 15);
2388 fprintf(stdout, " ");
2389 }
2390 fprintf(stdout, "\n");
2391 fflush(stdout);
2392 }
2393 #endif /*TCL_COMPILE_DEBUG*/
2394
2395 /*
2396 * Reset the instructionCount variable, since we're about to check
2397 * for async stuff anyway while processing TclEvalObjvInternal.
2398 */
2399
2400 instructionCount = 1;
2401
2402 /*
2403 * Finally, let TclEvalObjvInternal handle the command.
2404 *
2405 * TIP #280: Record the last piece of info needed by
2406 * 'TclGetSrcInfoForPc', and push the frame.
2407 */
2408
2409 bcFramePtr->data.tebc.pc = (char *) pc;
2410 iPtr->cmdFramePtr = bcFramePtr;
2411 if (iPtr->flags & INTERP_DEBUG_FRAME) {
2412 TclArgumentBCEnter((Tcl_Interp *) iPtr, objv, objc,
2413 codePtr, bcFramePtr, pc - codePtr->codeStart);
2414 }
2415 DECACHE_STACK_INFO();
2416 result = TclEvalObjvInternal(interp, objc, objv,
2417 /* call from TEBC */(char *) -1, -1, 0);
2418 CACHE_STACK_INFO();
2419 if (iPtr->flags & INTERP_DEBUG_FRAME) {
2420 TclArgumentBCRelease((Tcl_Interp *) iPtr, objv, objc,
2421 codePtr, pc - codePtr->codeStart);
2422 }
2423 iPtr->cmdFramePtr = iPtr->cmdFramePtr->nextPtr;
2424
2425 if (result == TCL_OK) {
2426 Tcl_Obj *objPtr;
2427
2428 /*
2429 * Push the call's object result and continue execution with
2430 * the next instruction.
2431 */
2432
2433 TRACE_WITH_OBJ(("%u => ... after \"%.20s\": TCL_OK, result=",
2434 objc, cmdNameBuf), Tcl_GetObjResult(interp));
2435
2436 objResultPtr = Tcl_GetObjResult(interp);
2437
2438 /*
2439 * Reset the interp's result to avoid possible duplications of
2440 * large objects [Bug 781585]. We do not call Tcl_ResetResult
2441 * to avoid any side effects caused by the resetting of
2442 * errorInfo and errorCode [Bug 804681], which are not needed
2443 * here. We chose instead to manipulate the interp's object
2444 * result directly.
2445 *
2446 * Note that the result object is now in objResultPtr, it
2447 * keeps the refCount it had in its role of
2448 * iPtr->objResultPtr.
2449 */
2450
2451 TclNewObj(objPtr);
2452 Tcl_IncrRefCount(objPtr);
2453 iPtr->objResultPtr = objPtr;
2454 #ifndef TCL_COMPILE_DEBUG
2455 if (*(pc+pcAdjustment) == INST_POP) {
2456 TclDecrRefCount(objResultPtr);
2457 NEXT_INST_V((pcAdjustment+1), objc, 0);
2458 }
2459 #endif
2460 NEXT_INST_V(pcAdjustment, objc, -1);
2461 } else {
2462 cleanup = objc;
2463 goto processExceptionReturn;
2464 }
2465 }
2466
2467 #if TCL_SUPPORT_84_BYTECODE
2468 case INST_CALL_BUILTIN_FUNC1: {
2469 /*
2470 * Call one of the built-in pre-8.5 Tcl math functions. This
2471 * translates to INST_INVOKE_STK1 with the first argument of
2472 * ::tcl::mathfunc::$objv[0]. We need to insert the named math
2473 * function into the stack.
2474 */
2475
2476 int opnd, numArgs;
2477 Tcl_Obj *objPtr;
2478
2479 opnd = TclGetUInt1AtPtr(pc+1);
2480 if ((opnd < 0) || (opnd > LAST_BUILTIN_FUNC)) {
2481 TRACE(("UNRECOGNIZED BUILTIN FUNC CODE %d\n", opnd));
2482 Tcl_Panic("TclExecuteByteCode: unrecognized builtin function code %d", opnd);
2483 }
2484
2485 objPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17);
2486 Tcl_AppendToObj(objPtr, tclBuiltinFuncTable[opnd].name, -1);
2487
2488 /*
2489 * Only 0, 1 or 2 args.
2490 */
2491
2492 numArgs = tclBuiltinFuncTable[opnd].numArgs;
2493 if (numArgs == 0) {
2494 PUSH_OBJECT(objPtr);
2495 } else if (numArgs == 1) {
2496 Tcl_Obj *tmpPtr1 = POP_OBJECT();
2497 PUSH_OBJECT(objPtr);
2498 PUSH_OBJECT(tmpPtr1);
2499 Tcl_DecrRefCount(tmpPtr1);
2500 } else {
2501 Tcl_Obj *tmpPtr1, *tmpPtr2;
2502 tmpPtr2 = POP_OBJECT();
2503 tmpPtr1 = POP_OBJECT();
2504 PUSH_OBJECT(objPtr);
2505 PUSH_OBJECT(tmpPtr1);
2506 PUSH_OBJECT(tmpPtr2);
2507 Tcl_DecrRefCount(tmpPtr1);
2508 Tcl_DecrRefCount(tmpPtr2);
2509 }
2510
2511 objc = numArgs + 1;
2512 pcAdjustment = 2;
2513 goto doInvocation;
2514 }
2515
2516 case INST_CALL_FUNC1: {
2517 /*
2518 * Call a non-builtin Tcl math function previously registered by a
2519 * call to Tcl_CreateMathFunc pre-8.5. This is essentially
2520 * INST_INVOKE_STK1 converting the first arg to
2521 * ::tcl::mathfunc::$objv[0].
2522 */
2523
2524 Tcl_Obj *tmpPtr, *objPtr;
2525
2526 /*
2527 * Number of arguments. The function name is the 0-th argument.
2528 */
2529
2530 objc = TclGetUInt1AtPtr(pc+1);
2531
2532 objPtr = OBJ_AT_DEPTH(objc-1);
2533 tmpPtr = Tcl_NewStringObj("::tcl::mathfunc::", 17);
2534 Tcl_AppendObjToObj(tmpPtr, objPtr);
2535 Tcl_DecrRefCount(objPtr);
2536
2537 /*
2538 * Variation of PUSH_OBJECT.
2539 */
2540
2541 OBJ_AT_DEPTH(objc-1) = tmpPtr;
2542 Tcl_IncrRefCount(tmpPtr);
2543
2544 pcAdjustment = 2;
2545 goto doInvocation;
2546 }
2547 #else
2548 /*
2549 * INST_CALL_BUILTIN_FUNC1 and INST_CALL_FUNC1 were made obsolete by the
2550 * changes to add a ::tcl::mathfunc namespace in 8.5. Optional support
2551 * remains for existing bytecode precompiled files.
2552 */
2553
2554 case INST_CALL_BUILTIN_FUNC1:
2555 Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_BUILTIN_FUNC1 found");
2556 case INST_CALL_FUNC1:
2557 Tcl_Panic("TclExecuteByteCode: obsolete INST_CALL_FUNC1 found");
2558 #endif
2559 }
2560
2561 case INST_EVAL_STK: {
2562 /*
2563 * Note to maintainers: it is important that INST_EVAL_STK pop its
2564 * argument from the stack before jumping to checkForCatch! DO NOT
2565 * OPTIMISE!
2566 */
2567
2568 Tcl_Obj *objPtr = OBJ_AT_TOS;
2569
2570 DECACHE_STACK_INFO();
2571
2572 /*
2573 * TIP #280: The invoking context is left NULL for a dynamically
2574 * constructed command. We cannot match its lines to the outer
2575 * context.
2576 */
2577
2578 result = TclCompEvalObj(interp, objPtr, NULL, 0);
2579 CACHE_STACK_INFO();
2580 if (result == TCL_OK) {
2581 /*
2582 * Normal return; push the eval's object result.
2583 */
2584
2585 objResultPtr = Tcl_GetObjResult(interp);
2586 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)),
2587 Tcl_GetObjResult(interp));
2588
2589 /*
2590 * Reset the interp's result to avoid possible duplications of
2591 * large objects [Bug 781585]. We do not call Tcl_ResetResult to
2592 * avoid any side effects caused by the resetting of errorInfo and
2593 * errorCode [Bug 804681], which are not needed here. We chose
2594 * instead to manipulate the interp's object result directly.
2595 *
2596 * Note that the result object is now in objResultPtr, it keeps
2597 * the refCount it had in its role of iPtr->objResultPtr.
2598 */
2599
2600 TclNewObj(objPtr);
2601 Tcl_IncrRefCount(objPtr);
2602 iPtr->objResultPtr = objPtr;
2603 NEXT_INST_F(1, 1, -1);
2604 } else {
2605 cleanup = 1;
2606 goto processExceptionReturn;
2607 }
2608 }
2609
2610 case INST_EXPR_STK: {
2611 Tcl_Obj *objPtr, *valuePtr;
2612
2613 objPtr = OBJ_AT_TOS;
2614 DECACHE_STACK_INFO();
2615 /*Tcl_ResetResult(interp);*/
2616 result = Tcl_ExprObj(interp, objPtr, &valuePtr);
2617 CACHE_STACK_INFO();
2618 if (result == TCL_OK) {
2619 objResultPtr = valuePtr;
2620 TRACE_WITH_OBJ(("\"%.30s\" => ", O2S(objPtr)), valuePtr);
2621 NEXT_INST_F(1, 1, -1); /* Already has right refct. */
2622 } else {
2623 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(objPtr)),
2624 Tcl_GetObjResult(interp));
2625 goto checkForCatch;
2626 }
2627 }
2628
2629 /*
2630 * ---------------------------------------------------------
2631 * Start of INST_LOAD instructions.
2632 *
2633 * WARNING: more 'goto' here than your doctor recommended! The different
2634 * instructions set the value of some variables and then jump to some
2635 * common execution code.
2636 */
2637 {
2638 int opnd, pcAdjustment;
2639 Tcl_Obj *part1Ptr, *part2Ptr;
2640 Var *varPtr, *arrayPtr;
2641 Tcl_Obj *objPtr;
2642
2643 case INST_LOAD_SCALAR1:
2644 instLoadScalar1:
2645 opnd = TclGetUInt1AtPtr(pc+1);
2646 varPtr = &(compiledLocals[opnd]);
2647 while (TclIsVarLink(varPtr)) {
2648 varPtr = varPtr->value.linkPtr;
2649 }
2650 TRACE(("%u => ", opnd));
2651 if (TclIsVarDirectReadable(varPtr)) {
2652 /*
2653 * No errors, no traces: just get the value.
2654 */
2655
2656 objResultPtr = varPtr->value.objPtr;
2657 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
2658 NEXT_INST_F(2, 0, 1);
2659 }
2660 pcAdjustment = 2;
2661 cleanup = 0;
2662 arrayPtr = NULL;
2663 part1Ptr = part2Ptr = NULL;
2664 goto doCallPtrGetVar;
2665
2666 case INST_LOAD_SCALAR4:
2667 opnd = TclGetUInt4AtPtr(pc+1);
2668 varPtr = &(compiledLocals[opnd]);
2669 while (TclIsVarLink(varPtr)) {
2670 varPtr = varPtr->value.linkPtr;
2671 }
2672 TRACE(("%u => ", opnd));
2673 if (TclIsVarDirectReadable(varPtr)) {
2674 /*
2675 * No errors, no traces: just get the value.
2676 */
2677
2678 objResultPtr = varPtr->value.objPtr;
2679 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
2680 NEXT_INST_F(5, 0, 1);
2681 }
2682 pcAdjustment = 5;
2683 cleanup = 0;
2684 arrayPtr = NULL;
2685 part1Ptr = part2Ptr = NULL;
2686 goto doCallPtrGetVar;
2687
2688 case INST_LOAD_ARRAY4:
2689 opnd = TclGetUInt4AtPtr(pc+1);
2690 pcAdjustment = 5;
2691 goto doLoadArray;
2692
2693 case INST_LOAD_ARRAY1:
2694 opnd = TclGetUInt1AtPtr(pc+1);
2695 pcAdjustment = 2;
2696
2697 doLoadArray:
2698 part1Ptr = NULL;
2699 part2Ptr = OBJ_AT_TOS;
2700 arrayPtr = &(compiledLocals[opnd]);
2701 while (TclIsVarLink(arrayPtr)) {
2702 arrayPtr = arrayPtr->value.linkPtr;
2703 }
2704 TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr)));
2705 if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
2706 varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
2707 if (varPtr && TclIsVarDirectReadable(varPtr)) {
2708 /*
2709 * No errors, no traces: just get the value.
2710 */
2711
2712 objResultPtr = varPtr->value.objPtr;
2713 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
2714 NEXT_INST_F(pcAdjustment, 1, 1);
2715 }
2716 }
2717 varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
2718 TCL_LEAVE_ERR_MSG, "read", 0, 1, arrayPtr, opnd);
2719 if (varPtr == NULL) {
2720 TRACE_APPEND(("ERROR: %.30s\n",
2721 O2S(Tcl_GetObjResult(interp))));
2722 result = TCL_ERROR;
2723 goto checkForCatch;
2724 }
2725 cleanup = 1;
2726 goto doCallPtrGetVar;
2727
2728 case INST_LOAD_ARRAY_STK:
2729 cleanup = 2;
2730 part2Ptr = OBJ_AT_TOS; /* element name */
2731 objPtr = OBJ_UNDER_TOS; /* array name */
2732 TRACE(("\"%.30s(%.30s)\" => ", O2S(objPtr), O2S(part2Ptr)));
2733 goto doLoadStk;
2734
2735 case INST_LOAD_STK:
2736 case INST_LOAD_SCALAR_STK:
2737 cleanup = 1;
2738 part2Ptr = NULL;
2739 objPtr = OBJ_AT_TOS; /* variable name */
2740 TRACE(("\"%.30s\" => ", O2S(objPtr)));
2741
2742 doLoadStk:
2743 part1Ptr = objPtr;
2744 varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr,
2745 TCL_LEAVE_ERR_MSG, "read", /*createPart1*/0, /*createPart2*/1,
2746 &arrayPtr);
2747 if (varPtr) {
2748 if (TclIsVarDirectReadable2(varPtr, arrayPtr)) {
2749 /*
2750 * No errors, no traces: just get the value.
2751 */
2752
2753 objResultPtr = varPtr->value.objPtr;
2754 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
2755 NEXT_INST_V(1, cleanup, 1);
2756 }
2757 pcAdjustment = 1;
2758 opnd = -1;
2759 goto doCallPtrGetVar;
2760 } else {
2761 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
2762 result = TCL_ERROR;
2763 goto checkForCatch;
2764 }
2765
2766 doCallPtrGetVar:
2767 /*
2768 * There are either errors or the variable is traced: call
2769 * TclPtrGetVar to process fully.
2770 */
2771
2772 DECACHE_STACK_INFO();
2773 objResultPtr = TclPtrGetVar(interp, varPtr, arrayPtr,
2774 part1Ptr, part2Ptr, TCL_LEAVE_ERR_MSG, opnd);
2775 CACHE_STACK_INFO();
2776 if (objResultPtr) {
2777 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
2778 NEXT_INST_V(pcAdjustment, cleanup, 1);
2779 } else {
2780 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
2781 result = TCL_ERROR;
2782 goto checkForCatch;
2783 }
2784 }
2785
2786 /*
2787 * End of INST_LOAD instructions.
2788 * ---------------------------------------------------------
2789 */
2790
2791 /*
2792 * ---------------------------------------------------------
2793 * Start of INST_STORE and related instructions.
2794 *
2795 * WARNING: more 'goto' here than your doctor recommended! The different
2796 * instructions set the value of some variables and then jump to somme
2797 * common execution code.
2798 */
2799
2800 {
2801 int opnd, pcAdjustment, storeFlags;
2802 Tcl_Obj *part1Ptr, *part2Ptr;
2803 Var *varPtr, *arrayPtr;
2804 Tcl_Obj *objPtr, *valuePtr;
2805
2806 case INST_STORE_ARRAY4:
2807 opnd = TclGetUInt4AtPtr(pc+1);
2808 pcAdjustment = 5;
2809 goto doStoreArrayDirect;
2810
2811 case INST_STORE_ARRAY1:
2812 opnd = TclGetUInt1AtPtr(pc+1);
2813 pcAdjustment = 2;
2814
2815 doStoreArrayDirect:
2816 valuePtr = OBJ_AT_TOS;
2817 part2Ptr = OBJ_UNDER_TOS;
2818 arrayPtr = &(compiledLocals[opnd]);
2819 TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
2820 O2S(valuePtr)));
2821 while (TclIsVarLink(arrayPtr)) {
2822 arrayPtr = arrayPtr->value.linkPtr;
2823 }
2824 if (TclIsVarArray(arrayPtr) && !WriteTraced(arrayPtr)) {
2825 varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
2826 if (varPtr && TclIsVarDirectWritable(varPtr)) {
2827 tosPtr--;
2828 Tcl_DecrRefCount(OBJ_AT_TOS);
2829 OBJ_AT_TOS = valuePtr;
2830 goto doStoreVarDirect;
2831 }
2832 }
2833 cleanup = 2;
2834 storeFlags = TCL_LEAVE_ERR_MSG;
2835 part1Ptr = NULL;
2836 goto doStoreArrayDirectFailed;
2837
2838 case INST_STORE_SCALAR4:
2839 opnd = TclGetUInt4AtPtr(pc+1);
2840 pcAdjustment = 5;
2841 goto doStoreScalarDirect;
2842
2843 case INST_STORE_SCALAR1:
2844 opnd = TclGetUInt1AtPtr(pc+1);
2845 pcAdjustment = 2;
2846
2847 doStoreScalarDirect:
2848 valuePtr = OBJ_AT_TOS;
2849 varPtr = &(compiledLocals[opnd]);
2850 TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
2851 while (TclIsVarLink(varPtr)) {
2852 varPtr = varPtr->value.linkPtr;
2853 }
2854 if (TclIsVarDirectWritable(varPtr)) {
2855 doStoreVarDirect:
2856 /*
2857 * No traces, no errors, plain 'set': we can safely inline. The
2858 * value *will* be set to what's requested, so that the stack top
2859 * remains pointing to the same Tcl_Obj.
2860 */
2861
2862 valuePtr = varPtr->value.objPtr;
2863 if (valuePtr != NULL) {
2864 TclDecrRefCount(valuePtr);
2865 }
2866 objResultPtr = OBJ_AT_TOS;
2867 varPtr->value.objPtr = objResultPtr;
2868 #ifndef TCL_COMPILE_DEBUG
2869 if (*(pc+pcAdjustment) == INST_POP) {
2870 tosPtr--;
2871 NEXT_INST_F((pcAdjustment+1), 0, 0);
2872 }
2873 #else
2874 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
2875 #endif
2876 Tcl_IncrRefCount(objResultPtr);
2877 NEXT_INST_F(pcAdjustment, 0, 0);
2878 }
2879 storeFlags = TCL_LEAVE_ERR_MSG;
2880 part1Ptr = NULL;
2881 goto doStoreScalar;
2882
2883 case INST_LAPPEND_STK:
2884 valuePtr = OBJ_AT_TOS; /* value to append */
2885 part2Ptr = NULL;
2886 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
2887 | TCL_LIST_ELEMENT);
2888 goto doStoreStk;
2889
2890 case INST_LAPPEND_ARRAY_STK:
2891 valuePtr = OBJ_AT_TOS; /* value to append */
2892 part2Ptr = OBJ_UNDER_TOS;
2893 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
2894 | TCL_LIST_ELEMENT);
2895 goto doStoreStk;
2896
2897 case INST_APPEND_STK:
2898 valuePtr = OBJ_AT_TOS; /* value to append */
2899 part2Ptr = NULL;
2900 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
2901 goto doStoreStk;
2902
2903 case INST_APPEND_ARRAY_STK:
2904 valuePtr = OBJ_AT_TOS; /* value to append */
2905 part2Ptr = OBJ_UNDER_TOS;
2906 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
2907 goto doStoreStk;
2908
2909 case INST_STORE_ARRAY_STK:
2910 valuePtr = OBJ_AT_TOS;
2911 part2Ptr = OBJ_UNDER_TOS;
2912 storeFlags = TCL_LEAVE_ERR_MSG;
2913 goto doStoreStk;
2914
2915 case INST_STORE_STK:
2916 case INST_STORE_SCALAR_STK:
2917 valuePtr = OBJ_AT_TOS;
2918 part2Ptr = NULL;
2919 storeFlags = TCL_LEAVE_ERR_MSG;
2920
2921 doStoreStk:
2922 objPtr = OBJ_AT_DEPTH(1 + (part2Ptr != NULL)); /* variable name */
2923 part1Ptr = objPtr;
2924 #ifdef TCL_COMPILE_DEBUG
2925 if (part2Ptr == NULL) {
2926 TRACE(("\"%.30s\" <- \"%.30s\" =>", O2S(part1Ptr),O2S(valuePtr)));
2927 } else {
2928 TRACE(("\"%.30s(%.30s)\" <- \"%.30s\" => ",
2929 O2S(part1Ptr), O2S(part2Ptr), O2S(valuePtr)));
2930 }
2931 #endif
2932 varPtr = TclObjLookupVarEx(interp, objPtr,part2Ptr, TCL_LEAVE_ERR_MSG,
2933 "set", /*createPart1*/ 1, /*createPart2*/ 1, &arrayPtr);
2934 if (varPtr) {
2935 cleanup = ((part2Ptr == NULL)? 2 : 3);
2936 pcAdjustment = 1;
2937 opnd = -1;
2938 goto doCallPtrSetVar;
2939 } else {
2940 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
2941 result = TCL_ERROR;
2942 goto checkForCatch;
2943 }
2944
2945 case INST_LAPPEND_ARRAY4:
2946 opnd = TclGetUInt4AtPtr(pc+1);
2947 pcAdjustment = 5;
2948 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
2949 | TCL_LIST_ELEMENT);
2950 goto doStoreArray;
2951
2952 case INST_LAPPEND_ARRAY1:
2953 opnd = TclGetUInt1AtPtr(pc+1);
2954 pcAdjustment = 2;
2955 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
2956 | TCL_LIST_ELEMENT);
2957 goto doStoreArray;
2958
2959 case INST_APPEND_ARRAY4:
2960 opnd = TclGetUInt4AtPtr(pc+1);
2961 pcAdjustment = 5;
2962 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
2963 goto doStoreArray;
2964
2965 case INST_APPEND_ARRAY1:
2966 opnd = TclGetUInt1AtPtr(pc+1);
2967 pcAdjustment = 2;
2968 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
2969 goto doStoreArray;
2970
2971 doStoreArray:
2972 valuePtr = OBJ_AT_TOS;
2973 part2Ptr = OBJ_UNDER_TOS;
2974 arrayPtr = &(compiledLocals[opnd]);
2975 TRACE(("%u \"%.30s\" <- \"%.30s\" => ", opnd, O2S(part2Ptr),
2976 O2S(valuePtr)));
2977 while (TclIsVarLink(arrayPtr)) {
2978 arrayPtr = arrayPtr->value.linkPtr;
2979 }
2980 cleanup = 2;
2981 part1Ptr = NULL;
2982
2983 doStoreArrayDirectFailed:
2984 varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
2985 TCL_LEAVE_ERR_MSG, "set", 1, 1, arrayPtr, opnd);
2986 if (varPtr) {
2987 goto doCallPtrSetVar;
2988 } else {
2989 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
2990 result = TCL_ERROR;
2991 goto checkForCatch;
2992 }
2993
2994 case INST_LAPPEND_SCALAR4:
2995 opnd = TclGetUInt4AtPtr(pc+1);
2996 pcAdjustment = 5;
2997 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
2998 | TCL_LIST_ELEMENT);
2999 goto doStoreScalar;
3000
3001 case INST_LAPPEND_SCALAR1:
3002 opnd = TclGetUInt1AtPtr(pc+1);
3003 pcAdjustment = 2;
3004 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE
3005 | TCL_LIST_ELEMENT);
3006 goto doStoreScalar;
3007
3008 case INST_APPEND_SCALAR4:
3009 opnd = TclGetUInt4AtPtr(pc+1);
3010 pcAdjustment = 5;
3011 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
3012 goto doStoreScalar;
3013
3014 case INST_APPEND_SCALAR1:
3015 opnd = TclGetUInt1AtPtr(pc+1);
3016 pcAdjustment = 2;
3017 storeFlags = (TCL_LEAVE_ERR_MSG | TCL_APPEND_VALUE);
3018 goto doStoreScalar;
3019
3020 doStoreScalar:
3021 valuePtr = OBJ_AT_TOS;
3022 varPtr = &(compiledLocals[opnd]);
3023 TRACE(("%u <- \"%.30s\" => ", opnd, O2S(valuePtr)));
3024 while (TclIsVarLink(varPtr)) {
3025 varPtr = varPtr->value.linkPtr;
3026 }
3027 cleanup = 1;
3028 arrayPtr = NULL;
3029 part1Ptr = part2Ptr = NULL;
3030
3031 doCallPtrSetVar:
3032 DECACHE_STACK_INFO();
3033 objResultPtr = TclPtrSetVar(interp, varPtr, arrayPtr,
3034 part1Ptr, part2Ptr, valuePtr, storeFlags, opnd);
3035 CACHE_STACK_INFO();
3036 if (objResultPtr) {
3037 #ifndef TCL_COMPILE_DEBUG
3038 if (*(pc+pcAdjustment) == INST_POP) {
3039 NEXT_INST_V((pcAdjustment+1), cleanup, 0);
3040 }
3041 #endif
3042 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3043 NEXT_INST_V(pcAdjustment, cleanup, 1);
3044 } else {
3045 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
3046 result = TCL_ERROR;
3047 goto checkForCatch;
3048 }
3049 }
3050
3051 /*
3052 * End of INST_STORE and related instructions.
3053 * ---------------------------------------------------------
3054 */
3055
3056 /*
3057 * ---------------------------------------------------------
3058 * Start of INST_INCR instructions.
3059 *
3060 * WARNING: more 'goto' here than your doctor recommended! The different
3061 * instructions set the value of some variables and then jump to somme
3062 * common execution code.
3063 */
3064
3065 /*TODO: Consider more untangling here; merge with LOAD and STORE ? */
3066
3067 {
3068 Tcl_Obj *objPtr, *incrPtr;
3069 int opnd, pcAdjustment;
3070 #ifndef NO_WIDE_TYPE
3071 Tcl_WideInt w;
3072 #endif
3073 long i;
3074 Tcl_Obj *part1Ptr, *part2Ptr;
3075 Var *varPtr, *arrayPtr;
3076
3077 case INST_INCR_SCALAR1:
3078 case INST_INCR_ARRAY1:
3079 case INST_INCR_ARRAY_STK:
3080 case INST_INCR_SCALAR_STK:
3081 case INST_INCR_STK:
3082 opnd = TclGetUInt1AtPtr(pc+1);
3083 incrPtr = POP_OBJECT();
3084 switch (*pc) {
3085 case INST_INCR_SCALAR1:
3086 pcAdjustment = 2;
3087 goto doIncrScalar;
3088 case INST_INCR_ARRAY1:
3089 pcAdjustment = 2;
3090 goto doIncrArray;
3091 default:
3092 pcAdjustment = 1;
3093 goto doIncrStk;
3094 }
3095
3096 case INST_INCR_ARRAY_STK_IMM:
3097 case INST_INCR_SCALAR_STK_IMM:
3098 case INST_INCR_STK_IMM:
3099 i = TclGetInt1AtPtr(pc+1);
3100 incrPtr = Tcl_NewIntObj(i);
3101 Tcl_IncrRefCount(incrPtr);
3102 pcAdjustment = 2;
3103
3104 doIncrStk:
3105 if ((*pc == INST_INCR_ARRAY_STK_IMM)
3106 || (*pc == INST_INCR_ARRAY_STK)) {
3107 part2Ptr = OBJ_AT_TOS;
3108 objPtr = OBJ_UNDER_TOS;
3109 TRACE(("\"%.30s(%.30s)\" (by %ld) => ",
3110 O2S(objPtr), O2S(part2Ptr), i));
3111 } else {
3112 part2Ptr = NULL;
3113 objPtr = OBJ_AT_TOS;
3114 TRACE(("\"%.30s\" (by %ld) => ", O2S(objPtr), i));
3115 }
3116 part1Ptr = objPtr;
3117 opnd = -1;
3118 varPtr = TclObjLookupVarEx(interp, objPtr, part2Ptr,
3119 TCL_LEAVE_ERR_MSG, "read", 1, 1, &arrayPtr);
3120 if (varPtr) {
3121 cleanup = ((part2Ptr == NULL)? 1 : 2);
3122 goto doIncrVar;
3123 } else {
3124 Tcl_AddObjErrorInfo(interp,
3125 "\n (reading value of variable to increment)", -1);
3126 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
3127 result = TCL_ERROR;
3128 Tcl_DecrRefCount(incrPtr);
3129 goto checkForCatch;
3130 }
3131
3132 case INST_INCR_ARRAY1_IMM:
3133 opnd = TclGetUInt1AtPtr(pc+1);
3134 i = TclGetInt1AtPtr(pc+2);
3135 incrPtr = Tcl_NewIntObj(i);
3136 Tcl_IncrRefCount(incrPtr);
3137 pcAdjustment = 3;
3138
3139 doIncrArray:
3140 part1Ptr = NULL;
3141 part2Ptr = OBJ_AT_TOS;
3142 arrayPtr = &(compiledLocals[opnd]);
3143 cleanup = 1;
3144 while (TclIsVarLink(arrayPtr)) {
3145 arrayPtr = arrayPtr->value.linkPtr;
3146 }
3147 TRACE(("%u \"%.30s\" (by %ld) => ", opnd, O2S(part2Ptr), i));
3148 varPtr = TclLookupArrayElement(interp, part1Ptr, part2Ptr,
3149 TCL_LEAVE_ERR_MSG, "read", 1, 1, arrayPtr, opnd);
3150 if (varPtr) {
3151 goto doIncrVar;
3152 } else {
3153 TRACE_APPEND(("ERROR: %.30s\n", O2S(Tcl_GetObjResult(interp))));
3154 result = TCL_ERROR;
3155 Tcl_DecrRefCount(incrPtr);
3156 goto checkForCatch;
3157 }
3158
3159 case INST_INCR_SCALAR1_IMM:
3160 opnd = TclGetUInt1AtPtr(pc+1);
3161 i = TclGetInt1AtPtr(pc+2);
3162 pcAdjustment = 3;
3163 cleanup = 0;
3164 varPtr = &(compiledLocals[opnd]);
3165 while (TclIsVarLink(varPtr)) {
3166 varPtr = varPtr->value.linkPtr;
3167 }
3168
3169 if (TclIsVarDirectModifyable(varPtr)) {
3170 ClientData ptr;
3171 int type;
3172
3173 objPtr = varPtr->value.objPtr;
3174 if (GetNumberFromObj(NULL, objPtr, &ptr, &type) == TCL_OK) {
3175 if (type == TCL_NUMBER_LONG) {
3176 long augend = *((const long *)ptr);
3177 long sum = augend + i;
3178
3179 /*
3180 * Overflow when (augend and sum have different sign) and
3181 * (augend and i have the same sign). This is encapsulated
3182 * in the Overflowing macro.
3183 */
3184
3185 if (!Overflowing(augend, i, sum)) {
3186 TRACE(("%u %ld => ", opnd, i));
3187 if (Tcl_IsShared(objPtr)) {
3188 objPtr->refCount--; /* We know it's shared. */
3189 TclNewLongObj(objResultPtr, sum);
3190 Tcl_IncrRefCount(objResultPtr);
3191 varPtr->value.objPtr = objResultPtr;
3192 } else {
3193 objResultPtr = objPtr;
3194 TclSetLongObj(objPtr, sum);
3195 }
3196 goto doneIncr;
3197 }
3198 #ifndef NO_WIDE_TYPE
3199 {
3200 w = (Tcl_WideInt)augend;
3201
3202 TRACE(("%u %ld => ", opnd, i));
3203 if (Tcl_IsShared(objPtr)) {
3204 objPtr->refCount--; /* We know it's shared. */
3205 objResultPtr = Tcl_NewWideIntObj(w+i);
3206 Tcl_IncrRefCount(objResultPtr);
3207 varPtr->value.objPtr = objResultPtr;
3208 } else {
3209 objResultPtr = objPtr;
3210
3211 /*
3212 * We know the sum value is outside the long
3213 * range; use macro form that doesn't range test
3214 * again.
3215 */
3216
3217 TclSetWideIntObj(objPtr, w+i);
3218 }
3219 goto doneIncr;
3220 }
3221 #endif
3222 } /* end if (type == TCL_NUMBER_LONG) */
3223 #ifndef NO_WIDE_TYPE
3224 if (type == TCL_NUMBER_WIDE) {
3225 Tcl_WideInt sum;
3226 w = *((const Tcl_WideInt *)ptr);
3227 sum = w + i;
3228
3229 /*
3230 * Check for overflow.
3231 */
3232
3233 if (!Overflowing(w, i, sum)) {
3234 TRACE(("%u %ld => ", opnd, i));
3235 if (Tcl_IsShared(objPtr)) {
3236 objPtr->refCount--; /* We know it's shared. */
3237 objResultPtr = Tcl_NewWideIntObj(sum);
3238 Tcl_IncrRefCount(objResultPtr);
3239 varPtr->value.objPtr = objResultPtr;
3240 } else {
3241 objResultPtr = objPtr;
3242
3243 /*
3244 * We *do not* know the sum value is outside the
3245 * long range (wide + long can yield long); use
3246 * the function call that checks range.
3247 */
3248
3249 Tcl_SetWideIntObj(objPtr, sum);
3250 }
3251 goto doneIncr;
3252 }
3253 }
3254 #endif
3255 }
3256 if (Tcl_IsShared(objPtr)) {
3257 objPtr->refCount--; /* We know it's shared */
3258 objResultPtr = Tcl_DuplicateObj(objPtr);
3259 Tcl_IncrRefCount(objResultPtr);
3260 varPtr->value.objPtr = objResultPtr;
3261 } else {
3262 objResultPtr = objPtr;
3263 }
3264 TclNewLongObj(incrPtr, i);
3265 result = TclIncrObj(interp, objResultPtr, incrPtr);
3266 Tcl_DecrRefCount(incrPtr);
3267 if (result == TCL_OK) {
3268 goto doneIncr;
3269 } else {
3270 TRACE_APPEND(("ERROR: %.30s\n",
3271 O2S(Tcl_GetObjResult(interp))));
3272 goto checkForCatch;
3273 }
3274 }
3275
3276 /*
3277 * All other cases, flow through to generic handling.
3278 */
3279
3280 TclNewLongObj(incrPtr, i);
3281 Tcl_IncrRefCount(incrPtr);
3282
3283 doIncrScalar:
3284 varPtr = &(compiledLocals[opnd]);
3285 while (TclIsVarLink(varPtr)) {
3286 varPtr = varPtr->value.linkPtr;
3287 }
3288 arrayPtr = NULL;
3289 part1Ptr = part2Ptr = NULL;
3290 cleanup = 0;
3291 TRACE(("%u %ld => ", opnd, i));
3292
3293 doIncrVar:
3294 if (TclIsVarDirectModifyable2(varPtr, arrayPtr)) {
3295 objPtr = varPtr->value.objPtr;
3296 if (Tcl_IsShared(objPtr)) {
3297 objPtr->refCount--; /* We know it's shared */
3298 objResultPtr = Tcl_DuplicateObj(objPtr);
3299 Tcl_IncrRefCount(objResultPtr);
3300 varPtr->value.objPtr = objResultPtr;
3301 } else {
3302 objResultPtr = objPtr;
3303 }
3304 result = TclIncrObj(interp, objResultPtr, incrPtr);
3305 Tcl_DecrRefCount(incrPtr);
3306 if (result == TCL_OK) {
3307 goto doneIncr;
3308 } else {
3309 TRACE_APPEND(("ERROR: %.30s\n",
3310 O2S(Tcl_GetObjResult(interp))));
3311 goto checkForCatch;
3312 }
3313 } else {
3314 DECACHE_STACK_INFO();
3315 objResultPtr = TclPtrIncrObjVar(interp, varPtr, arrayPtr,
3316 part1Ptr, part2Ptr, incrPtr, TCL_LEAVE_ERR_MSG, opnd);
3317 CACHE_STACK_INFO();
3318 Tcl_DecrRefCount(incrPtr);
3319 if (objResultPtr == NULL) {
3320 TRACE_APPEND(("ERROR: %.30s\n",
3321 O2S(Tcl_GetObjResult(interp))));
3322 result = TCL_ERROR;
3323 goto checkForCatch;
3324 }
3325 }
3326 doneIncr:
3327 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3328 #ifndef TCL_COMPILE_DEBUG
3329 if (*(pc+pcAdjustment) == INST_POP) {
3330 NEXT_INST_V((pcAdjustment+1), cleanup, 0);
3331 }
3332 #endif
3333 NEXT_INST_V(pcAdjustment, cleanup, 1);
3334 }
3335
3336 /*
3337 * End of INST_INCR instructions.
3338 * ---------------------------------------------------------
3339 */
3340
3341 /*
3342 * ---------------------------------------------------------
3343 * Start of INST_EXIST instructions.
3344 */
3345 {
3346 Tcl_Obj *part1Ptr, *part2Ptr;
3347 Var *varPtr, *arrayPtr;
3348
3349 case INST_EXIST_SCALAR: {
3350 int opnd = TclGetUInt4AtPtr(pc+1);
3351
3352 varPtr = &(compiledLocals[opnd]);
3353 while (TclIsVarLink(varPtr)) {
3354 varPtr = varPtr->value.linkPtr;
3355 }
3356 TRACE(("%u => ", opnd));
3357 if (ReadTraced(varPtr)) {
3358 DECACHE_STACK_INFO();
3359 TclObjCallVarTraces(iPtr, NULL, varPtr, NULL, NULL,
3360 TCL_TRACE_READS, 0, opnd);
3361 CACHE_STACK_INFO();
3362 if (TclIsVarUndefined(varPtr)) {
3363 TclCleanupVar(varPtr, NULL);
3364 varPtr = NULL;
3365 }
3366 }
3367
3368 /*
3369 * Tricky! Arrays always exist.
3370 */
3371
3372 objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
3373 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3374 NEXT_INST_F(5, 0, 1);
3375 }
3376
3377 case INST_EXIST_ARRAY: {
3378 int opnd = TclGetUInt4AtPtr(pc+1);
3379
3380 part2Ptr = OBJ_AT_TOS;
3381 arrayPtr = &(compiledLocals[opnd]);
3382 while (TclIsVarLink(arrayPtr)) {
3383 arrayPtr = arrayPtr->value.linkPtr;
3384 }
3385 TRACE(("%u \"%.30s\" => ", opnd, O2S(part2Ptr)));
3386 if (TclIsVarArray(arrayPtr) && !ReadTraced(arrayPtr)) {
3387 varPtr = VarHashFindVar(arrayPtr->value.tablePtr, part2Ptr);
3388 if (!varPtr || !ReadTraced(varPtr)) {
3389 goto doneExistArray;
3390 }
3391 }
3392 varPtr = TclLookupArrayElement(interp, NULL, part2Ptr, 0, "access",
3393 0, 1, arrayPtr, opnd);
3394 if (varPtr) {
3395 if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
3396 DECACHE_STACK_INFO();
3397 TclObjCallVarTraces(iPtr, arrayPtr, varPtr, NULL, part2Ptr,
3398 TCL_TRACE_READS, 0, opnd);
3399 CACHE_STACK_INFO();
3400 }
3401 if (TclIsVarUndefined(varPtr)) {
3402 TclCleanupVar(varPtr, arrayPtr);
3403 varPtr = NULL;
3404 }
3405 }
3406 doneExistArray:
3407 objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
3408 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3409 NEXT_INST_F(5, 1, 1);
3410 }
3411
3412 case INST_EXIST_ARRAY_STK:
3413 cleanup = 2;
3414 part2Ptr = OBJ_AT_TOS; /* element name */
3415 part1Ptr = OBJ_UNDER_TOS; /* array name */
3416 TRACE(("\"%.30s(%.30s)\" => ", O2S(part1Ptr), O2S(part2Ptr)));
3417 goto doExistStk;
3418
3419 case INST_EXIST_STK:
3420 cleanup = 1;
3421 part2Ptr = NULL;
3422 part1Ptr = OBJ_AT_TOS; /* variable name */
3423 TRACE(("\"%.30s\" => ", O2S(part1Ptr)));
3424
3425 doExistStk:
3426 varPtr = TclObjLookupVarEx(interp, part1Ptr, part2Ptr, 0, "access",
3427 /*createPart1*/0, /*createPart2*/1, &arrayPtr);
3428 if (varPtr) {
3429 if (ReadTraced(varPtr) || (arrayPtr && ReadTraced(arrayPtr))) {
3430 DECACHE_STACK_INFO();
3431 TclObjCallVarTraces(iPtr, arrayPtr, varPtr, part1Ptr,part2Ptr,
3432 TCL_TRACE_READS, 0, -1);
3433 CACHE_STACK_INFO();
3434 }
3435 if (TclIsVarUndefined(varPtr)) {
3436 TclCleanupVar(varPtr, arrayPtr);
3437 varPtr = NULL;
3438 }
3439 }
3440 objResultPtr = constants[!varPtr || TclIsVarUndefined(varPtr) ? 0 : 1];
3441 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
3442 NEXT_INST_V(1, cleanup, 1);
3443 }
3444
3445 /*
3446 * End of INST_EXIST instructions.
3447 * ---------------------------------------------------------
3448 */
3449
3450 case INST_UPVAR: {
3451 int opnd;
3452 Var *varPtr, *otherPtr;
3453
3454 TRACE_WITH_OBJ(("upvar "), OBJ_UNDER_TOS);
3455
3456 {
3457 CallFrame *framePtr, *savedFramePtr;
3458
3459 result = TclObjGetFrame(interp, OBJ_UNDER_TOS, &framePtr);
3460 if (result != -1) {
3461 /*
3462 * Locate the other variable.
3463 */
3464
3465 savedFramePtr = iPtr->varFramePtr;
3466 iPtr->varFramePtr = framePtr;
3467 otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
3468 (TCL_LEAVE_ERR_MSG), "access",
3469 /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
3470 iPtr->varFramePtr = savedFramePtr;
3471 if (otherPtr) {
3472 result = TCL_OK;
3473 goto doLinkVars;
3474 }
3475 }
3476 result = TCL_ERROR;
3477 goto checkForCatch;
3478 }
3479
3480 case INST_VARIABLE:
3481 TRACE(("variable "));
3482 otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
3483 (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
3484 /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
3485 if (otherPtr) {
3486 /*
3487 * Do the [variable] magic.
3488 */
3489
3490 TclSetVarNamespaceVar(otherPtr);
3491 result = TCL_OK;
3492 goto doLinkVars;
3493 }
3494 result = TCL_ERROR;
3495 goto checkForCatch;
3496
3497 case INST_NSUPVAR:
3498 TRACE_WITH_OBJ(("nsupvar "), OBJ_UNDER_TOS);
3499
3500 {
3501 Tcl_Namespace *nsPtr, *savedNsPtr;
3502
3503 result = TclGetNamespaceFromObj(interp, OBJ_UNDER_TOS, &nsPtr);
3504 if (result == TCL_OK) {
3505 /*
3506 * Locate the other variable.
3507 */
3508
3509 savedNsPtr = (Tcl_Namespace *) iPtr->varFramePtr->nsPtr;
3510 iPtr->varFramePtr->nsPtr = (Namespace *) nsPtr;
3511 otherPtr = TclObjLookupVarEx(interp, OBJ_AT_TOS, NULL,
3512 (TCL_NAMESPACE_ONLY | TCL_LEAVE_ERR_MSG), "access",
3513 /*createPart1*/ 1, /*createPart2*/ 1, &varPtr);
3514 iPtr->varFramePtr->nsPtr = (Namespace *) savedNsPtr;
3515 if (otherPtr) {
3516 goto doLinkVars;
3517 }
3518 }
3519 result = TCL_ERROR;
3520 goto checkForCatch;
3521 }
3522
3523 doLinkVars:
3524
3525 /*
3526 * If we are here, the local variable has already been created: do the
3527 * little work of TclPtrMakeUpvar that remains to be done right here
3528 * if there are no errors; otherwise, let it handle the case.
3529 */
3530
3531 opnd = TclGetInt4AtPtr(pc+1);;
3532 varPtr = &(compiledLocals[opnd]);
3533 if ((varPtr != otherPtr) && !TclIsVarTraced(varPtr)
3534 && (TclIsVarUndefined(varPtr) || TclIsVarLink(varPtr))) {
3535 if (!TclIsVarUndefined(varPtr)) {
3536 /*
3537 * Then it is a defined link.
3538 */
3539
3540 Var *linkPtr = varPtr->value.linkPtr;
3541
3542 if (linkPtr == otherPtr) {
3543 goto doLinkVarsDone;
3544 }
3545 if (TclIsVarInHash(linkPtr)) {
3546 VarHashRefCount(linkPtr)--;
3547 if (TclIsVarUndefined(linkPtr)) {
3548 TclCleanupVar(linkPtr, NULL);
3549 }
3550 }
3551 }
3552 TclSetVarLink(varPtr);
3553 varPtr->value.linkPtr = otherPtr;
3554 if (TclIsVarInHash(otherPtr)) {
3555 VarHashRefCount(otherPtr)++;
3556 }
3557 } else {
3558 result = TclPtrObjMakeUpvar(interp, otherPtr, NULL, 0, opnd);
3559 if (result != TCL_OK) {
3560 goto checkForCatch;
3561 }
3562 }
3563
3564 /*
3565 * Do not pop the namespace or frame index, it may be needed for other
3566 * variables - and [variable] did not push it at all.
3567 */
3568
3569 doLinkVarsDone:
3570 NEXT_INST_F(5, 1, 0);
3571 }
3572
3573 case INST_JUMP1: {
3574 int opnd = TclGetInt1AtPtr(pc+1);
3575
3576 TRACE(("%d => new pc %u\n", opnd,
3577 (unsigned)(pc + opnd - codePtr->codeStart)));
3578 NEXT_INST_F(opnd, 0, 0);
3579 }
3580
3581 case INST_JUMP4: {
3582 int opnd = TclGetInt4AtPtr(pc+1);
3583
3584 TRACE(("%d => new pc %u\n", opnd,
3585 (unsigned)(pc + opnd - codePtr->codeStart)));
3586 NEXT_INST_F(opnd, 0, 0);
3587 }
3588
3589 {
3590 int jmpOffset[2], b;
3591 Tcl_Obj *valuePtr;
3592
3593 /* TODO: consider rewrite so we don't compute the offset we're not
3594 * going to take. */
3595 case INST_JUMP_FALSE4:
3596 jmpOffset[0] = TclGetInt4AtPtr(pc+1); /* FALSE offset */
3597 jmpOffset[1] = 5; /* TRUE offset*/
3598 goto doCondJump;
3599
3600 case INST_JUMP_TRUE4:
3601 jmpOffset[0] = 5;
3602 jmpOffset[1] = TclGetInt4AtPtr(pc+1);
3603 goto doCondJump;
3604
3605 case INST_JUMP_FALSE1:
3606 jmpOffset[0] = TclGetInt1AtPtr(pc+1);
3607 jmpOffset[1] = 2;
3608 goto doCondJump;
3609
3610 case INST_JUMP_TRUE1:
3611 jmpOffset[0] = 2;
3612 jmpOffset[1] = TclGetInt1AtPtr(pc+1);
3613
3614 doCondJump:
3615 valuePtr = OBJ_AT_TOS;
3616
3617 /* TODO - check claim that taking address of b harms performance */
3618 /* TODO - consider optimization search for constants */
3619 result = TclGetBooleanFromObj(interp, valuePtr, &b);
3620 if (result != TCL_OK) {
3621 TRACE_WITH_OBJ(("%d => ERROR: ", jmpOffset[
3622 ((*pc == INST_JUMP_FALSE1) || (*pc == INST_JUMP_FALSE4))
3623 ? 0 : 1]), Tcl_GetObjResult(interp));
3624 goto checkForCatch;
3625 }
3626
3627 #ifdef TCL_COMPILE_DEBUG
3628 if (b) {
3629 if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
3630 TRACE(("%d => %.20s true, new pc %u\n", jmpOffset[1],
3631 O2S(valuePtr),
3632 (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
3633 } else {
3634 TRACE(("%d => %.20s true\n", jmpOffset[0], O2S(valuePtr)));
3635 }
3636 } else {
3637 if ((*pc == INST_JUMP_TRUE1) || (*pc == INST_JUMP_TRUE4)) {
3638 TRACE(("%d => %.20s false\n", jmpOffset[0], O2S(valuePtr)));
3639 } else {
3640 TRACE(("%d => %.20s false, new pc %u\n", jmpOffset[0],
3641 O2S(valuePtr),
3642 (unsigned)(pc + jmpOffset[1] - codePtr->codeStart)));
3643 }
3644 }
3645 #endif
3646 NEXT_INST_F(jmpOffset[b], 1, 0);
3647 }
3648
3649 case INST_JUMP_TABLE: {
3650 Tcl_HashEntry *hPtr;
3651 JumptableInfo *jtPtr;
3652 int opnd;
3653
3654 /*
3655 * Jump to location looked up in a hashtable; fall through to next
3656 * instr if lookup fails.
3657 */
3658
3659 opnd = TclGetInt4AtPtr(pc+1);
3660 jtPtr = (JumptableInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
3661 TRACE(("%d => %.20s ", opnd, O2S(OBJ_AT_TOS)));
3662 hPtr = Tcl_FindHashEntry(&jtPtr->hashTable, TclGetString(OBJ_AT_TOS));
3663 if (hPtr != NULL) {
3664 int jumpOffset = PTR2INT(Tcl_GetHashValue(hPtr));
3665
3666 TRACE_APPEND(("found in table, new pc %u\n",
3667 (unsigned)(pc - codePtr->codeStart + jumpOffset)));
3668 NEXT_INST_F(jumpOffset, 1, 0);
3669 } else {
3670 TRACE_APPEND(("not found in table\n"));
3671 NEXT_INST_F(5, 1, 0);
3672 }
3673 }
3674
3675 /*
3676 * These two instructions are now redundant: the complete logic of the LOR
3677 * and LAND is now handled by the expression compiler.
3678 */
3679
3680 case INST_LOR:
3681 case INST_LAND: {
3682 /*
3683 * Operands must be boolean or numeric. No int->double conversions are
3684 * performed.
3685 */
3686
3687 int i1, i2, iResult;
3688 Tcl_Obj *value2Ptr = OBJ_AT_TOS;
3689 Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
3690
3691 result = TclGetBooleanFromObj(NULL, valuePtr, &i1);
3692 if (result != TCL_OK) {
3693 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
3694 (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
3695 DECACHE_STACK_INFO();
3696 IllegalExprOperandType(interp, pc, valuePtr);
3697 CACHE_STACK_INFO();
3698 goto checkForCatch;
3699 }
3700
3701 result = TclGetBooleanFromObj(NULL, value2Ptr, &i2);
3702 if (result != TCL_OK) {
3703 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(value2Ptr),
3704 (value2Ptr->typePtr? value2Ptr->typePtr->name : "null")));
3705 DECACHE_STACK_INFO();
3706 IllegalExprOperandType(interp, pc, value2Ptr);
3707 CACHE_STACK_INFO();
3708 goto checkForCatch;
3709 }
3710
3711 if (*pc == INST_LOR) {
3712 iResult = (i1 || i2);
3713 } else {
3714 iResult = (i1 && i2);
3715 }
3716 objResultPtr = constants[iResult];
3717 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
3718 NEXT_INST_F(1, 2, 1);
3719 }
3720
3721 /*
3722 * ---------------------------------------------------------
3723 * Start of INST_LIST and related instructions.
3724 */
3725
3726 case INST_LIST: {
3727 /*
3728 * Pop the opnd (objc) top stack elements into a new list obj and then
3729 * decrement their ref counts.
3730 */
3731
3732 int opnd;
3733
3734 opnd = TclGetUInt4AtPtr(pc+1);
3735 objResultPtr = Tcl_NewListObj(opnd, &OBJ_AT_DEPTH(opnd-1));
3736 TRACE_WITH_OBJ(("%u => ", opnd), objResultPtr);
3737 NEXT_INST_V(5, opnd, 1);
3738 }
3739
3740 case INST_LIST_LENGTH: {
3741 Tcl_Obj *valuePtr;
3742 int length;
3743
3744 valuePtr = OBJ_AT_TOS;
3745
3746 result = TclListObjLength(interp, valuePtr, &length);
3747 if (result == TCL_OK) {
3748 TclNewIntObj(objResultPtr, length);
3749 TRACE(("%.20s => %d\n", O2S(valuePtr), length));
3750 NEXT_INST_F(1, 1, 1);
3751 } else {
3752 TRACE_WITH_OBJ(("%.30s => ERROR: ", O2S(valuePtr)),
3753 Tcl_GetObjResult(interp));
3754 goto checkForCatch;
3755 }
3756 }
3757
3758 case INST_LIST_INDEX: {
3759 /*** lindex with objc == 3 ***/
3760
3761 /* Variables also for INST_LIST_INDEX_IMM */
3762
3763 int listc, idx, opnd, pcAdjustment;
3764 Tcl_Obj **listv;
3765 Tcl_Obj *valuePtr, *value2Ptr;
3766
3767 /*
3768 * Pop the two operands.
3769 */
3770
3771 value2Ptr = OBJ_AT_TOS;
3772 valuePtr = OBJ_UNDER_TOS;
3773
3774 /*
3775 * Extract the desired list element.
3776 */
3777
3778 result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
3779 if ((result == TCL_OK) && (value2Ptr->typePtr != &tclListType)
3780 && (TclGetIntForIndexM(NULL , value2Ptr, listc-1,
3781 &idx) == TCL_OK)) {
3782 TclDecrRefCount(value2Ptr);
3783 tosPtr--;
3784 pcAdjustment = 1;
3785 goto lindexFastPath;
3786 }
3787
3788 objResultPtr = TclLindexList(interp, valuePtr, value2Ptr);
3789 if (objResultPtr) {
3790 /*
3791 * Stash the list element on the stack.
3792 */
3793
3794 TRACE(("%.20s %.20s => %s\n",
3795 O2S(valuePtr), O2S(value2Ptr), O2S(objResultPtr)));
3796 NEXT_INST_F(1, 2, -1); /* Already has the correct refCount */
3797 } else {
3798 TRACE_WITH_OBJ(("%.30s %.30s => ERROR: ", O2S(valuePtr),
3799 O2S(value2Ptr)), Tcl_GetObjResult(interp));
3800 result = TCL_ERROR;
3801 goto checkForCatch;
3802 }
3803
3804 case INST_LIST_INDEX_IMM:
3805 /*** lindex with objc==3 and index in bytecode stream ***/
3806
3807 pcAdjustment = 5;
3808
3809 /*
3810 * Pop the list and get the index.
3811 */
3812
3813 valuePtr = OBJ_AT_TOS;
3814 opnd = TclGetInt4AtPtr(pc+1);
3815
3816 /*
3817 * Get the contents of the list, making sure that it really is a list
3818 * in the process.
3819 */
3820
3821 result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
3822
3823 if (result == TCL_OK) {
3824 /*
3825 * Select the list item based on the index. Negative operand means
3826 * end-based indexing.
3827 */
3828
3829 if (opnd < -1) {
3830 idx = opnd+1 + listc;
3831 } else {
3832 idx = opnd;
3833 }
3834
3835 lindexFastPath:
3836 if (idx >= 0 && idx < listc) {
3837 objResultPtr = listv[idx];
3838 } else {
3839 TclNewObj(objResultPtr);
3840 }
3841
3842 TRACE_WITH_OBJ(("\"%.30s\" %d => ", O2S(valuePtr), opnd),
3843 objResultPtr);
3844 NEXT_INST_F(pcAdjustment, 1, 1);
3845 } else {
3846 TRACE_WITH_OBJ(("\"%.30s\" %d => ERROR: ", O2S(valuePtr), opnd),
3847 Tcl_GetObjResult(interp));
3848 goto checkForCatch;
3849 }
3850 }
3851
3852 case INST_LIST_INDEX_MULTI: {
3853 /*
3854 * 'lindex' with multiple index args:
3855 *
3856 * Determine the count of index args.
3857 */
3858
3859 int numIdx, opnd;
3860
3861 opnd = TclGetUInt4AtPtr(pc+1);
3862 numIdx = opnd-1;
3863
3864 /*
3865 * Do the 'lindex' operation.
3866 */
3867
3868 objResultPtr = TclLindexFlat(interp, OBJ_AT_DEPTH(numIdx),
3869 numIdx, &OBJ_AT_DEPTH(numIdx - 1));
3870
3871 /*
3872 * Check for errors.
3873 */
3874
3875 if (objResultPtr) {
3876 /*
3877 * Set result.
3878 */
3879
3880 TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
3881 NEXT_INST_V(5, opnd, -1);
3882 } else {
3883 TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
3884 result = TCL_ERROR;
3885 goto checkForCatch;
3886 }
3887 }
3888
3889 case INST_LSET_FLAT: {
3890 /*
3891 * Lset with 3, 5, or more args. Get the number of index args.
3892 */
3893
3894 int numIdx,opnd;
3895 Tcl_Obj *valuePtr, *value2Ptr;
3896
3897 opnd = TclGetUInt4AtPtr(pc + 1);
3898 numIdx = opnd - 2;
3899
3900 /*
3901 * Get the old value of variable, and remove the stack ref. This is
3902 * safe because the variable still references the object; the ref
3903 * count will never go zero here - we can use the smaller macro
3904 * Tcl_DecrRefCount.
3905 */
3906
3907 value2Ptr = POP_OBJECT();
3908 Tcl_DecrRefCount(value2Ptr); /* This one should be done here */
3909
3910 /*
3911 * Get the new element value.
3912 */
3913
3914 valuePtr = OBJ_AT_TOS;
3915
3916 /*
3917 * Compute the new variable value.
3918 */
3919
3920 objResultPtr = TclLsetFlat(interp, value2Ptr, numIdx,
3921 &OBJ_AT_DEPTH(numIdx), valuePtr);
3922
3923 /*
3924 * Check for errors.
3925 */
3926
3927 if (objResultPtr) {
3928 /*
3929 * Set result.
3930 */
3931
3932 TRACE(("%d => %s\n", opnd, O2S(objResultPtr)));
3933 NEXT_INST_V(5, (numIdx+1), -1);
3934 } else {
3935 TRACE_WITH_OBJ(("%d => ERROR: ", opnd), Tcl_GetObjResult(interp));
3936 result = TCL_ERROR;
3937 goto checkForCatch;
3938 }
3939 }
3940
3941 case INST_LSET_LIST: {
3942 /*
3943 * 'lset' with 4 args.
3944 */
3945
3946 Tcl_Obj *objPtr, *valuePtr, *value2Ptr;
3947
3948 /*
3949 * Get the old value of variable, and remove the stack ref. This is
3950 * safe because the variable still references the object; the ref
3951 * count will never go zero here - we can use the smaller macro
3952 * Tcl_DecrRefCount.
3953 */
3954
3955 objPtr = POP_OBJECT();
3956 Tcl_DecrRefCount(objPtr); /* This one should be done here. */
3957
3958 /*
3959 * Get the new element value, and the index list.
3960 */
3961
3962 valuePtr = OBJ_AT_TOS;
3963 value2Ptr = OBJ_UNDER_TOS;
3964
3965 /*
3966 * Compute the new variable value.
3967 */
3968
3969 objResultPtr = TclLsetList(interp, objPtr, value2Ptr, valuePtr);
3970
3971 /*
3972 * Check for errors.
3973 */
3974
3975 if (objResultPtr) {
3976 /*
3977 * Set result.
3978 */
3979
3980 TRACE(("=> %s\n", O2S(objResultPtr)));
3981 NEXT_INST_F(1, 2, -1);
3982 } else {
3983 TRACE_WITH_OBJ(("\"%.30s\" => ERROR: ", O2S(value2Ptr)),
3984 Tcl_GetObjResult(interp));
3985 result = TCL_ERROR;
3986 goto checkForCatch;
3987 }
3988 }
3989
3990 case INST_LIST_RANGE_IMM: {
3991 /*** lrange with objc==4 and both indices in bytecode stream ***/
3992
3993 int listc, fromIdx, toIdx;
3994 Tcl_Obj **listv, *valuePtr;
3995
3996 /*
3997 * Pop the list and get the indices.
3998 */
3999
4000 valuePtr = OBJ_AT_TOS;
4001 fromIdx = TclGetInt4AtPtr(pc+1);
4002 toIdx = TclGetInt4AtPtr(pc+5);
4003
4004 /*
4005 * Get the contents of the list, making sure that it really is a list
4006 * in the process.
4007 */
4008 result = TclListObjGetElements(interp, valuePtr, &listc, &listv);
4009
4010 /*
4011 * Skip a lot of work if we're about to throw the result away (common
4012 * with uses of [lassign]).
4013 */
4014
4015 if (result == TCL_OK) {
4016 #ifndef TCL_COMPILE_DEBUG
4017 if (*(pc+9) == INST_POP) {
4018 NEXT_INST_F(10, 1, 0);
4019 }
4020 #endif
4021 } else {
4022 TRACE_WITH_OBJ(("\"%.30s\" %d %d => ERROR: ", O2S(valuePtr),
4023 fromIdx, toIdx), Tcl_GetObjResult(interp));
4024 goto checkForCatch;
4025 }
4026
4027 /*
4028 * Adjust the indices for end-based handling.
4029 */
4030
4031 if (fromIdx < -1) {
4032 fromIdx += 1+listc;
4033 if (fromIdx < -1) {
4034 fromIdx = -1;
4035 }
4036 } else if (fromIdx > listc) {
4037 fromIdx = listc;
4038 }
4039 if (toIdx < -1) {
4040 toIdx += 1+listc;
4041 if (toIdx < -1) {
4042 toIdx = -1;
4043 }
4044 } else if (toIdx > listc) {
4045 toIdx = listc;
4046 }
4047
4048 /*
4049 * Check if we are referring to a valid, non-empty list range, and if
4050 * so, build the list of elements in that range.
4051 */
4052
4053 if (fromIdx<=toIdx && fromIdx<listc && toIdx>=0) {
4054 if (fromIdx<0) {
4055 fromIdx = 0;
4056 }
4057 if (toIdx >= listc) {
4058 toIdx = listc-1;
4059 }
4060 objResultPtr = Tcl_NewListObj(toIdx-fromIdx+1, listv+fromIdx);
4061 } else {
4062 TclNewObj(objResultPtr);
4063 }
4064
4065 TRACE_WITH_OBJ(("\"%.30s\" %d %d => ", O2S(valuePtr),
4066 TclGetInt4AtPtr(pc+1), TclGetInt4AtPtr(pc+5)), objResultPtr);
4067 NEXT_INST_F(9, 1, 1);
4068 }
4069
4070 case INST_LIST_IN:
4071 case INST_LIST_NOT_IN: {
4072 /*
4073 * Basic list containment operators.
4074 */
4075
4076 int found, s1len, s2len, llen, i;
4077 Tcl_Obj *valuePtr, *value2Ptr, *o;
4078 char *s1;
4079 const char *s2;
4080
4081 value2Ptr = OBJ_AT_TOS;
4082 valuePtr = OBJ_UNDER_TOS;
4083
4084 /* TODO: Consider more efficient tests than strcmp() */
4085 s1 = TclGetStringFromObj(valuePtr, &s1len);
4086 result = TclListObjLength(interp, value2Ptr, &llen);
4087 if (result != TCL_OK) {
4088 TRACE_WITH_OBJ(("\"%.30s\" \"%.30s\" => ERROR: ", O2S(valuePtr),
4089 O2S(value2Ptr)), Tcl_GetObjResult(interp));
4090 goto checkForCatch;
4091 }
4092 found = 0;
4093 if (llen > 0) {
4094 /*
4095 * An empty list doesn't match anything.
4096 */
4097
4098 i = 0;
4099 do {
4100 Tcl_ListObjIndex(NULL, value2Ptr, i, &o);
4101 if (o != NULL) {
4102 s2 = TclGetStringFromObj(o, &s2len);
4103 } else {
4104 s2 = "";
4105 }
4106 if (s1len == s2len) {
4107 found = (strcmp(s1, s2) == 0);
4108 }
4109 i++;
4110 } while (i < llen && found == 0);
4111 }
4112
4113 if (*pc == INST_LIST_NOT_IN) {
4114 found = !found;
4115 }
4116
4117 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), found));
4118
4119 /*
4120 * Peep-hole optimisation: if you're about to jump, do jump from here.
4121 * We're saving the effort of pushing a boolean value only to pop it
4122 * for branching.
4123 */
4124
4125 pc++;
4126 #ifndef TCL_COMPILE_DEBUG
4127 switch (*pc) {
4128 case INST_JUMP_FALSE1:
4129 NEXT_INST_F((found ? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
4130 case INST_JUMP_TRUE1:
4131 NEXT_INST_F((found ? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
4132 case INST_JUMP_FALSE4:
4133 NEXT_INST_F((found ? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
4134 case INST_JUMP_TRUE4:
4135 NEXT_INST_F((found ? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
4136 }
4137 #endif
4138 objResultPtr = constants[found];
4139 NEXT_INST_F(0, 2, 1);
4140 }
4141
4142 /*
4143 * End of INST_LIST and related instructions.
4144 * ---------------------------------------------------------
4145 */
4146
4147 case INST_STR_EQ:
4148 case INST_STR_NEQ: {
4149 /*
4150 * String (in)equality check
4151 * TODO: Consider merging into INST_STR_CMP
4152 */
4153
4154 int iResult;
4155 Tcl_Obj *valuePtr, *value2Ptr;
4156
4157 value2Ptr = OBJ_AT_TOS;
4158 valuePtr = OBJ_UNDER_TOS;
4159
4160 if (valuePtr == value2Ptr) {
4161 /*
4162 * On the off-chance that the objects are the same, we don't
4163 * really have to think hard about equality.
4164 */
4165
4166 iResult = (*pc == INST_STR_EQ);
4167 } else {
4168 char *s1, *s2;
4169 int s1len, s2len;
4170
4171 s1 = TclGetStringFromObj(valuePtr, &s1len);
4172 s2 = TclGetStringFromObj(value2Ptr, &s2len);
4173 if (s1len == s2len) {
4174 /*
4175 * We only need to check (in)equality when we have equal
4176 * length strings.
4177 */
4178
4179 if (*pc == INST_STR_NEQ) {
4180 iResult = (strcmp(s1, s2) != 0);
4181 } else {
4182 /* INST_STR_EQ */
4183 iResult = (strcmp(s1, s2) == 0);
4184 }
4185 } else {
4186 iResult = (*pc == INST_STR_NEQ);
4187 }
4188 }
4189
4190 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr),O2S(value2Ptr),iResult));
4191
4192 /*
4193 * Peep-hole optimisation: if you're about to jump, do jump from here.
4194 */
4195
4196 pc++;
4197 #ifndef TCL_COMPILE_DEBUG
4198 switch (*pc) {
4199 case INST_JUMP_FALSE1:
4200 NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
4201 case INST_JUMP_TRUE1:
4202 NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
4203 case INST_JUMP_FALSE4:
4204 NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
4205 case INST_JUMP_TRUE4:
4206 NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
4207 }
4208 #endif
4209 objResultPtr = constants[iResult];
4210 NEXT_INST_F(0, 2, 1);
4211 }
4212
4213 case INST_STR_CMP: {
4214 /*
4215 * String compare.
4216 */
4217
4218 const char *s1, *s2;
4219 int s1len, s2len, iResult;
4220 Tcl_Obj *valuePtr, *value2Ptr;
4221
4222 stringCompare:
4223 value2Ptr = OBJ_AT_TOS;
4224 valuePtr = OBJ_UNDER_TOS;
4225
4226 /*
4227 * The comparison function should compare up to the minimum byte
4228 * length only.
4229 */
4230
4231 if (valuePtr == value2Ptr) {
4232 /*
4233 * In the pure equality case, set lengths too for the checks below
4234 * (or we could goto beyond it).
4235 */
4236
4237 iResult = s1len = s2len = 0;
4238 } else if (TclIsPureByteArray(valuePtr)
4239 && TclIsPureByteArray(value2Ptr)) {
4240 s1 = (char *) Tcl_GetByteArrayFromObj(valuePtr, &s1len);
4241 s2 = (char *) Tcl_GetByteArrayFromObj(value2Ptr, &s2len);
4242 iResult = memcmp(s1, s2,
4243 (size_t) ((s1len < s2len) ? s1len : s2len));
4244 } else if (((valuePtr->typePtr == &tclStringType)
4245 && (value2Ptr->typePtr == &tclStringType))) {
4246 /*
4247 * Do a unicode-specific comparison if both of the args are of
4248 * String type. If the char length == byte length, we can do a
4249 * memcmp. In benchmark testing this proved the most efficient
4250 * check between the unicode and string comparison operations.
4251 */
4252
4253 s1len = Tcl_GetCharLength(valuePtr);
4254 s2len = Tcl_GetCharLength(value2Ptr);
4255 if ((s1len == valuePtr->length) && (s2len == value2Ptr->length)) {
4256 iResult = memcmp(valuePtr->bytes, value2Ptr->bytes,
4257 (unsigned) ((s1len < s2len) ? s1len : s2len));
4258 } else {
4259 iResult = TclUniCharNcmp(Tcl_GetUnicode(valuePtr),
4260 Tcl_GetUnicode(value2Ptr),
4261 (unsigned) ((s1len < s2len) ? s1len : s2len));
4262 }
4263 } else {
4264 /*
4265 * We can't do a simple memcmp in order to handle the special Tcl
4266 * \xC0\x80 null encoding for utf-8.
4267 */
4268
4269 s1 = TclGetStringFromObj(valuePtr, &s1len);
4270 s2 = TclGetStringFromObj(value2Ptr, &s2len);
4271 iResult = TclpUtfNcmp2(s1, s2,
4272 (size_t) ((s1len < s2len) ? s1len : s2len));
4273 }
4274
4275 /*
4276 * Make sure only -1,0,1 is returned
4277 * TODO: consider peephole opt.
4278 */
4279
4280 if (iResult == 0) {
4281 iResult = s1len - s2len;
4282 }
4283
4284 if (*pc != INST_STR_CMP) {
4285 /*
4286 * Take care of the opcodes that goto'ed into here.
4287 */
4288
4289 switch (*pc) {
4290 case INST_EQ:
4291 iResult = (iResult == 0);
4292 break;
4293 case INST_NEQ:
4294 iResult = (iResult != 0);
4295 break;
4296 case INST_LT:
4297 iResult = (iResult < 0);
4298 break;
4299 case INST_GT:
4300 iResult = (iResult > 0);
4301 break;
4302 case INST_LE:
4303 iResult = (iResult <= 0);
4304 break;
4305 case INST_GE:
4306 iResult = (iResult >= 0);
4307 break;
4308 }
4309 }
4310 if (iResult < 0) {
4311 TclNewIntObj(objResultPtr, -1);
4312 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), -1));
4313 } else {
4314 objResultPtr = constants[(iResult>0)];
4315 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr),
4316 (iResult > 0)));
4317 }
4318
4319 NEXT_INST_F(1, 2, 1);
4320 }
4321
4322 case INST_STR_LEN: {
4323 int length;
4324 Tcl_Obj *valuePtr;
4325
4326 valuePtr = OBJ_AT_TOS;
4327
4328 if (valuePtr->typePtr == &tclByteArrayType) {
4329 (void) Tcl_GetByteArrayFromObj(valuePtr, &length);
4330 } else {
4331 length = Tcl_GetCharLength(valuePtr);
4332 }
4333 TclNewIntObj(objResultPtr, length);
4334 TRACE(("%.20s => %d\n", O2S(valuePtr), length));
4335 NEXT_INST_F(1, 1, 1);
4336 }
4337
4338 case INST_STR_INDEX: {
4339 /*
4340 * String compare.
4341 */
4342
4343 int index, length;
4344 char *bytes;
4345 Tcl_Obj *valuePtr, *value2Ptr;
4346
4347 bytes = NULL; /* lint */
4348 value2Ptr = OBJ_AT_TOS;
4349 valuePtr = OBJ_UNDER_TOS;
4350
4351 /*
4352 * If we have a ByteArray object, avoid indexing in the Utf string
4353 * since the byte array contains one byte per character. Otherwise,
4354 * use the Unicode string rep to get the index'th char.
4355 */
4356
4357 if (TclIsPureByteArray(valuePtr)) {
4358 bytes = (char *)Tcl_GetByteArrayFromObj(valuePtr, &length);
4359 } else {
4360 /*
4361 * Get Unicode char length to calulate what 'end' means.
4362 */
4363
4364 length = Tcl_GetCharLength(valuePtr);
4365 }
4366
4367 result = TclGetIntForIndexM(interp, value2Ptr, length - 1, &index);
4368 if (result != TCL_OK) {
4369 goto checkForCatch;
4370 }
4371
4372 if ((index >= 0) && (index < length)) {
4373 if (TclIsPureByteArray(valuePtr)) {
4374 objResultPtr = Tcl_NewByteArrayObj((unsigned char *)
4375 (&bytes[index]), 1);
4376 } else if (valuePtr->bytes && length == valuePtr->length) {
4377 objResultPtr = Tcl_NewStringObj((const char *)
4378 (&valuePtr->bytes[index]), 1);
4379 } else {
4380 char buf[TCL_UTF_MAX];
4381 Tcl_UniChar ch;
4382
4383 ch = Tcl_GetUniChar(valuePtr, index);
4384
4385 /*
4386 * This could be: Tcl_NewUnicodeObj((const Tcl_UniChar *)&ch,
4387 * 1) but creating the object as a string seems to be faster
4388 * in practical use.
4389 */
4390
4391 length = Tcl_UniCharToUtf(ch, buf);
4392 objResultPtr = Tcl_NewStringObj(buf, length);
4393 }
4394 } else {
4395 TclNewObj(objResultPtr);
4396 }
4397
4398 TRACE(("%.20s %.20s => %s\n", O2S(valuePtr), O2S(value2Ptr),
4399 O2S(objResultPtr)));
4400 NEXT_INST_F(1, 2, 1);
4401 }
4402
4403 case INST_STR_MATCH: {
4404 int nocase, match;
4405 Tcl_Obj *valuePtr, *value2Ptr;
4406
4407 nocase = TclGetInt1AtPtr(pc+1);
4408 valuePtr = OBJ_AT_TOS; /* String */
4409 value2Ptr = OBJ_UNDER_TOS; /* Pattern */
4410
4411 /*
4412 * Check that at least one of the objects is Unicode before promoting
4413 * both.
4414 */
4415
4416 if ((valuePtr->typePtr == &tclStringType)
4417 || (value2Ptr->typePtr == &tclStringType)) {
4418 Tcl_UniChar *ustring1, *ustring2;
4419 int length1, length2;
4420
4421 ustring1 = Tcl_GetUnicodeFromObj(valuePtr, &length1);
4422 ustring2 = Tcl_GetUnicodeFromObj(value2Ptr, &length2);
4423 match = TclUniCharMatch(ustring1, length1, ustring2, length2,
4424 nocase);
4425 } else if (TclIsPureByteArray(valuePtr) && !nocase) {
4426 unsigned char *string1, *string2;
4427 int length1, length2;
4428
4429 string1 = Tcl_GetByteArrayFromObj(valuePtr, &length1);
4430 string2 = Tcl_GetByteArrayFromObj(value2Ptr, &length2);
4431 match = TclByteArrayMatch(string1, length1, string2, length2, 0);
4432 } else {
4433 match = Tcl_StringCaseMatch(TclGetString(valuePtr),
4434 TclGetString(value2Ptr), nocase);
4435 }
4436
4437 /*
4438 * Reuse value2Ptr object already on stack if possible. Adjustment is
4439 * 2 due to the nocase byte
4440 * TODO: consider peephole opt.
4441 */
4442
4443 TRACE(("%.20s %.20s => %d\n", O2S(valuePtr), O2S(value2Ptr), match));
4444 objResultPtr = constants[match];
4445 NEXT_INST_F(2, 2, 1);
4446 }
4447
4448 case INST_REGEXP: {
4449 int cflags, match;
4450 Tcl_Obj *valuePtr, *value2Ptr;
4451 Tcl_RegExp regExpr;
4452
4453 cflags = TclGetInt1AtPtr(pc+1); /* RE compile flages like NOCASE */
4454 valuePtr = OBJ_AT_TOS; /* String */
4455 value2Ptr = OBJ_UNDER_TOS; /* Pattern */
4456
4457 regExpr = Tcl_GetRegExpFromObj(interp, value2Ptr, cflags);
4458 if (regExpr == NULL) {
4459 match = -1;
4460 } else {
4461 match = Tcl_RegExpExecObj(interp, regExpr, valuePtr, 0, 0, 0);
4462 }
4463
4464 /*
4465 * Adjustment is 2 due to the nocase byte
4466 */
4467
4468 if (match < 0) {
4469 objResultPtr = Tcl_GetObjResult(interp);
4470 TRACE_WITH_OBJ(("%.20s %.20s => ERROR: ",
4471 O2S(valuePtr), O2S(value2Ptr)), objResultPtr);
4472 result = TCL_ERROR;
4473 goto checkForCatch;
4474 } else {
4475 TRACE(("%.20s %.20s => %d\n",
4476 O2S(valuePtr), O2S(value2Ptr), match));
4477 objResultPtr = constants[match];
4478 NEXT_INST_F(2, 2, 1);
4479 }
4480 }
4481
4482 case INST_EQ:
4483 case INST_NEQ:
4484 case INST_LT:
4485 case INST_GT:
4486 case INST_LE:
4487 case INST_GE: {
4488 Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
4489 Tcl_Obj *value2Ptr = OBJ_AT_TOS;
4490 ClientData ptr1, ptr2;
4491 int iResult = 0, compare = 0, type1, type2;
4492 double d1, d2, tmp;
4493 long l1, l2;
4494 mp_int big1, big2;
4495 #ifndef NO_WIDE_TYPE
4496 Tcl_WideInt w1, w2;
4497 #endif
4498
4499 if (GetNumberFromObj(NULL, valuePtr, &ptr1, &type1) != TCL_OK) {
4500 /*
4501 * At least one non-numeric argument - compare as strings.
4502 */
4503
4504 goto stringCompare;
4505 }
4506 if (type1 == TCL_NUMBER_NAN) {
4507 /*
4508 * NaN first arg: NaN != to everything, other compares are false.
4509 */
4510
4511 iResult = (*pc == INST_NEQ);
4512 goto foundResult;
4513 }
4514 if (valuePtr == value2Ptr) {
4515 compare = MP_EQ;
4516 goto convertComparison;
4517 }
4518 if (GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2) != TCL_OK) {
4519 /*
4520 * At least one non-numeric argument - compare as strings.
4521 */
4522
4523 goto stringCompare;
4524 }
4525 if (type2 == TCL_NUMBER_NAN) {
4526 /*
4527 * NaN 2nd arg: NaN != to everything, other compares are false.
4528 */
4529
4530 iResult = (*pc == INST_NEQ);
4531 goto foundResult;
4532 }
4533 switch (type1) {
4534 case TCL_NUMBER_LONG:
4535 l1 = *((const long *)ptr1);
4536 switch (type2) {
4537 case TCL_NUMBER_LONG:
4538 l2 = *((const long *)ptr2);
4539 longCompare:
4540 compare = (l1 < l2) ? MP_LT : ((l1 > l2) ? MP_GT : MP_EQ);
4541 break;
4542 #ifndef NO_WIDE_TYPE
4543 case TCL_NUMBER_WIDE:
4544 w2 = *((const Tcl_WideInt *)ptr2);
4545 w1 = (Tcl_WideInt)l1;
4546 goto wideCompare;
4547 #endif
4548 case TCL_NUMBER_DOUBLE:
4549 d2 = *((const double *)ptr2);
4550 d1 = (double) l1;
4551
4552 /*
4553 * If the double has a fractional part, or if the long can be
4554 * converted to double without loss of precision, then compare
4555 * as doubles.
4556 */
4557
4558 if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
4559 || l1 == (long) d1
4560 || modf(d2, &tmp) != 0.0) {
4561 goto doubleCompare;
4562 }
4563
4564 /*
4565 * Otherwise, to make comparision based on full precision,
4566 * need to convert the double to a suitably sized integer.
4567 *
4568 * Need this to get comparsions like
4569 * expr 20000000000000003 < 20000000000000004.0
4570 * right. Converting the first argument to double will yield
4571 * two double values that are equivalent within double
4572 * precision. Converting the double to an integer gets done
4573 * exactly, then integer comparison can tell the difference.
4574 */
4575
4576 if (d2 < (double)LONG_MIN) {
4577 compare = MP_GT;
4578 break;
4579 }
4580 if (d2 > (double)LONG_MAX) {
4581 compare = MP_LT;
4582 break;
4583 }
4584 l2 = (long) d2;
4585 goto longCompare;
4586 case TCL_NUMBER_BIG:
4587 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
4588 if (mp_cmp_d(&big2, 0) == MP_LT) {
4589 compare = MP_GT;
4590 } else {
4591 compare = MP_LT;
4592 }
4593 mp_clear(&big2);
4594 }
4595 break;
4596
4597 #ifndef NO_WIDE_TYPE
4598 case TCL_NUMBER_WIDE:
4599 w1 = *((const Tcl_WideInt *)ptr1);
4600 switch (type2) {
4601 case TCL_NUMBER_WIDE:
4602 w2 = *((const Tcl_WideInt *)ptr2);
4603 wideCompare:
4604 compare = (w1 < w2) ? MP_LT : ((w1 > w2) ? MP_GT : MP_EQ);
4605 break;
4606 case TCL_NUMBER_LONG:
4607 l2 = *((const long *)ptr2);
4608 w2 = (Tcl_WideInt)l2;
4609 goto wideCompare;
4610 case TCL_NUMBER_DOUBLE:
4611 d2 = *((const double *)ptr2);
4612 d1 = (double) w1;
4613 if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
4614 || w1 == (Tcl_WideInt) d1
4615 || modf(d2, &tmp) != 0.0) {
4616 goto doubleCompare;
4617 }
4618 if (d2 < (double)LLONG_MIN) {
4619 compare = MP_GT;
4620 break;
4621 }
4622 if (d2 > (double)LLONG_MAX) {
4623 compare = MP_LT;
4624 break;
4625 }
4626 w2 = (Tcl_WideInt) d2;
4627 goto wideCompare;
4628 case TCL_NUMBER_BIG:
4629 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
4630 if (mp_cmp_d(&big2, 0) == MP_LT) {
4631 compare = MP_GT;
4632 } else {
4633 compare = MP_LT;
4634 }
4635 mp_clear(&big2);
4636 }
4637 break;
4638 #endif
4639
4640 case TCL_NUMBER_DOUBLE:
4641 d1 = *((const double *)ptr1);
4642 switch (type2) {
4643 case TCL_NUMBER_DOUBLE:
4644 d2 = *((const double *)ptr2);
4645 doubleCompare:
4646 compare = (d1 < d2) ? MP_LT : ((d1 > d2) ? MP_GT : MP_EQ);
4647 break;
4648 case TCL_NUMBER_LONG:
4649 l2 = *((const long *)ptr2);
4650 d2 = (double) l2;
4651 if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
4652 || l2 == (long) d2
4653 || modf(d1, &tmp) != 0.0) {
4654 goto doubleCompare;
4655 }
4656 if (d1 < (double)LONG_MIN) {
4657 compare = MP_LT;
4658 break;
4659 }
4660 if (d1 > (double)LONG_MAX) {
4661 compare = MP_GT;
4662 break;
4663 }
4664 l1 = (long) d1;
4665 goto longCompare;
4666 #ifndef NO_WIDE_TYPE
4667 case TCL_NUMBER_WIDE:
4668 w2 = *((const Tcl_WideInt *)ptr2);
4669 d2 = (double) w2;
4670 if (DBL_MANT_DIG > CHAR_BIT*sizeof(Tcl_WideInt)
4671 || w2 == (Tcl_WideInt) d2
4672 || modf(d1, &tmp) != 0.0) {
4673 goto doubleCompare;
4674 }
4675 if (d1 < (double)LLONG_MIN) {
4676 compare = MP_LT;
4677 break;
4678 }
4679 if (d1 > (double)LLONG_MAX) {
4680 compare = MP_GT;
4681 break;
4682 }
4683 w1 = (Tcl_WideInt) d1;
4684 goto wideCompare;
4685 #endif
4686 case TCL_NUMBER_BIG:
4687 if (TclIsInfinite(d1)) {
4688 compare = (d1 > 0.0) ? MP_GT : MP_LT;
4689 break;
4690 }
4691 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
4692 if ((d1 < (double)LONG_MAX) && (d1 > (double)LONG_MIN)) {
4693 if (mp_cmp_d(&big2, 0) == MP_LT) {
4694 compare = MP_GT;
4695 } else {
4696 compare = MP_LT;
4697 }
4698 mp_clear(&big2);
4699 break;
4700 }
4701 if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
4702 && modf(d1, &tmp) != 0.0) {
4703 d2 = TclBignumToDouble(&big2);
4704 mp_clear(&big2);
4705 goto doubleCompare;
4706 }
4707 Tcl_InitBignumFromDouble(NULL, d1, &big1);
4708 goto bigCompare;
4709 }
4710 break;
4711
4712 case TCL_NUMBER_BIG:
4713 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
4714 switch (type2) {
4715 #ifndef NO_WIDE_TYPE
4716 case TCL_NUMBER_WIDE:
4717 #endif
4718 case TCL_NUMBER_LONG:
4719 compare = mp_cmp_d(&big1, 0);
4720 mp_clear(&big1);
4721 break;
4722 case TCL_NUMBER_DOUBLE:
4723 d2 = *((const double *)ptr2);
4724 if (TclIsInfinite(d2)) {
4725 compare = (d2 > 0.0) ? MP_LT : MP_GT;
4726 mp_clear(&big1);
4727 break;
4728 }
4729 if ((d2 < (double)LONG_MAX) && (d2 > (double)LONG_MIN)) {
4730 compare = mp_cmp_d(&big1, 0);
4731 mp_clear(&big1);
4732 break;
4733 }
4734 if (DBL_MANT_DIG > CHAR_BIT*sizeof(long)
4735 && modf(d2, &tmp) != 0.0) {
4736 d1 = TclBignumToDouble(&big1);
4737 mp_clear(&big1);
4738 goto doubleCompare;
4739 }
4740 Tcl_InitBignumFromDouble(NULL, d2, &big2);
4741 goto bigCompare;
4742 case TCL_NUMBER_BIG:
4743 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
4744 bigCompare:
4745 compare = mp_cmp(&big1, &big2);
4746 mp_clear(&big1);
4747 mp_clear(&big2);
4748 }
4749 }
4750
4751 /*
4752 * Turn comparison outcome into appropriate result for opcode.
4753 */
4754
4755 convertComparison:
4756 switch (*pc) {
4757 case INST_EQ:
4758 iResult = (compare == MP_EQ);
4759 break;
4760 case INST_NEQ:
4761 iResult = (compare != MP_EQ);
4762 break;
4763 case INST_LT:
4764 iResult = (compare == MP_LT);
4765 break;
4766 case INST_GT:
4767 iResult = (compare == MP_GT);
4768 break;
4769 case INST_LE:
4770 iResult = (compare != MP_GT);
4771 break;
4772 case INST_GE:
4773 iResult = (compare != MP_LT);
4774 break;
4775 }
4776
4777 /*
4778 * Peep-hole optimisation: if you're about to jump, do jump from here.
4779 */
4780
4781 foundResult:
4782 pc++;
4783 #ifndef TCL_COMPILE_DEBUG
4784 switch (*pc) {
4785 case INST_JUMP_FALSE1:
4786 NEXT_INST_F((iResult? 2 : TclGetInt1AtPtr(pc+1)), 2, 0);
4787 case INST_JUMP_TRUE1:
4788 NEXT_INST_F((iResult? TclGetInt1AtPtr(pc+1) : 2), 2, 0);
4789 case INST_JUMP_FALSE4:
4790 NEXT_INST_F((iResult? 5 : TclGetInt4AtPtr(pc+1)), 2, 0);
4791 case INST_JUMP_TRUE4:
4792 NEXT_INST_F((iResult? TclGetInt4AtPtr(pc+1) : 5), 2, 0);
4793 }
4794 #endif
4795 objResultPtr = constants[iResult];
4796 NEXT_INST_F(0, 2, 1);
4797 }
4798
4799 case INST_MOD:
4800 case INST_LSHIFT:
4801 case INST_RSHIFT: {
4802 Tcl_Obj *value2Ptr = OBJ_AT_TOS;
4803 Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
4804 ClientData ptr1, ptr2;
4805 int invalid, shift, type1, type2;
4806 long l1 = 0;
4807
4808 result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
4809 if ((result != TCL_OK) || (type1 == TCL_NUMBER_DOUBLE)
4810 || (type1 == TCL_NUMBER_NAN)) {
4811 result = TCL_ERROR;
4812 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
4813 O2S(value2Ptr), (valuePtr->typePtr?
4814 valuePtr->typePtr->name : "null")));
4815 DECACHE_STACK_INFO();
4816 IllegalExprOperandType(interp, pc, valuePtr);
4817 CACHE_STACK_INFO();
4818 goto checkForCatch;
4819 }
4820
4821 result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
4822 if ((result != TCL_OK) || (type2 == TCL_NUMBER_DOUBLE)
4823 || (type2 == TCL_NUMBER_NAN)) {
4824 result = TCL_ERROR;
4825 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
4826 O2S(value2Ptr), (value2Ptr->typePtr?
4827 value2Ptr->typePtr->name : "null")));
4828 DECACHE_STACK_INFO();
4829 IllegalExprOperandType(interp, pc, value2Ptr);
4830 CACHE_STACK_INFO();
4831 goto checkForCatch;
4832 }
4833
4834 if (*pc == INST_MOD) {
4835 /* TODO: Attempts to re-use unshared operands on stack */
4836
4837 long l2 = 0; /* silence gcc warning */
4838
4839 if (type2 == TCL_NUMBER_LONG) {
4840 l2 = *((const long *)ptr2);
4841 if (l2 == 0) {
4842 TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
4843 O2S(value2Ptr)));
4844 goto divideByZero;
4845 }
4846 if ((l2 == 1) || (l2 == -1)) {
4847 /*
4848 * Div. by |1| always yields remainder of 0.
4849 */
4850
4851 objResultPtr = constants[0];
4852 TRACE(("%s\n", O2S(objResultPtr)));
4853 NEXT_INST_F(1, 2, 1);
4854 }
4855 }
4856 if (type1 == TCL_NUMBER_LONG) {
4857 l1 = *((const long *)ptr1);
4858 if (l1 == 0) {
4859 /*
4860 * 0 % (non-zero) always yields remainder of 0.
4861 */
4862
4863 objResultPtr = constants[0];
4864 TRACE(("%s\n", O2S(objResultPtr)));
4865 NEXT_INST_F(1, 2, 1);
4866 }
4867 if (type2 == TCL_NUMBER_LONG) {
4868 /*
4869 * Both operands are long; do native calculation.
4870 */
4871
4872 long lRemainder, lQuotient = l1 / l2;
4873
4874 /*
4875 * Force Tcl's integer division rules.
4876 * TODO: examine for logic simplification
4877 */
4878
4879 if ((lQuotient < 0 || (lQuotient == 0 &&
4880 ((l1 < 0 && l2 > 0) || (l1 > 0 && l2 < 0)))) &&
4881 (lQuotient * l2 != l1)) {
4882 lQuotient -= 1;
4883 }
4884 lRemainder = l1 - l2*lQuotient;
4885 TclNewLongObj(objResultPtr, lRemainder);
4886 TRACE(("%s\n", O2S(objResultPtr)));
4887 NEXT_INST_F(1, 2, 1);
4888 }
4889
4890 /*
4891 * First operand fits in long; second does not, so the second
4892 * has greater magnitude than first. No need to divide to
4893 * determine the remainder.
4894 */
4895
4896 #ifndef NO_WIDE_TYPE
4897 if (type2 == TCL_NUMBER_WIDE) {
4898 Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2);
4899
4900 if ((l1 > 0) ^ (w2 > (Tcl_WideInt)0)) {
4901 /*
4902 * Arguments are opposite sign; remainder is sum.
4903 */
4904
4905 objResultPtr = Tcl_NewWideIntObj(w2+(Tcl_WideInt)l1);
4906 TRACE(("%s\n", O2S(objResultPtr)));
4907 NEXT_INST_F(1, 2, 1);
4908 }
4909
4910 /*
4911 * Arguments are same sign; remainder is first operand.
4912 */
4913
4914 TRACE(("%s\n", O2S(valuePtr)));
4915 NEXT_INST_F(1, 1, 0);
4916 }
4917 #endif
4918 {
4919 mp_int big2;
4920
4921 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
4922
4923 /* TODO: internals intrusion */
4924 if ((l1 > 0) ^ (big2.sign == MP_ZPOS)) {
4925 /*
4926 * Arguments are opposite sign; remainder is sum.
4927 */
4928
4929 mp_int big1;
4930
4931 TclBNInitBignumFromLong(&big1, l1);
4932 mp_add(&big2, &big1, &big2);
4933 mp_clear(&big1);
4934 objResultPtr = Tcl_NewBignumObj(&big2);
4935 TRACE(("%s\n", O2S(objResultPtr)));
4936 NEXT_INST_F(1, 2, 1);
4937 }
4938
4939 /*
4940 * Arguments are same sign; remainder is first operand.
4941 */
4942
4943 mp_clear(&big2);
4944 TRACE(("%s\n", O2S(valuePtr)));
4945 NEXT_INST_F(1, 1, 0);
4946 }
4947 }
4948 #ifndef NO_WIDE_TYPE
4949 if (type1 == TCL_NUMBER_WIDE) {
4950 Tcl_WideInt w1 = *((const Tcl_WideInt *)ptr1);
4951
4952 if (type2 != TCL_NUMBER_BIG) {
4953 Tcl_WideInt w2, wQuotient, wRemainder;
4954
4955 Tcl_GetWideIntFromObj(NULL, value2Ptr, &w2);
4956 wQuotient = w1 / w2;
4957
4958 /*
4959 * Force Tcl's integer division rules.
4960 * TODO: examine for logic simplification
4961 */
4962
4963 if (((wQuotient < (Tcl_WideInt) 0)
4964 || ((wQuotient == (Tcl_WideInt) 0)
4965 && ((w1 < (Tcl_WideInt)0 && w2 > (Tcl_WideInt)0)
4966 || (w1 > (Tcl_WideInt)0 && w2 < (Tcl_WideInt)0))))
4967 && (wQuotient * w2 != w1)) {
4968 wQuotient -= (Tcl_WideInt) 1;
4969 }
4970 wRemainder = w1 - w2*wQuotient;
4971 objResultPtr = Tcl_NewWideIntObj(wRemainder);
4972 TRACE(("%s\n", O2S(objResultPtr)));
4973 NEXT_INST_F(1, 2, 1);
4974 }
4975 {
4976 mp_int big2;
4977 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
4978
4979 /* TODO: internals intrusion */
4980 if ((w1 > ((Tcl_WideInt) 0)) ^ (big2.sign == MP_ZPOS)) {
4981 /*
4982 * Arguments are opposite sign; remainder is sum.
4983 */
4984
4985 mp_int big1;
4986
4987 TclBNInitBignumFromWideInt(&big1, w1);
4988 mp_add(&big2, &big1, &big2);
4989 mp_clear(&big1);
4990 objResultPtr = Tcl_NewBignumObj(&big2);
4991 TRACE(("%s\n", O2S(objResultPtr)));
4992 NEXT_INST_F(1, 2, 1);
4993 }
4994
4995 /*
4996 * Arguments are same sign; remainder is first operand.
4997 */
4998
4999 mp_clear(&big2);
5000 TRACE(("%s\n", O2S(valuePtr)));
5001 NEXT_INST_F(1, 1, 0);
5002 }
5003 }
5004 #endif
5005 {
5006 mp_int big1, big2, bigResult, bigRemainder;
5007
5008 Tcl_GetBignumFromObj(NULL, valuePtr, &big1);
5009 Tcl_GetBignumFromObj(NULL, value2Ptr, &big2);
5010 mp_init(&bigResult);
5011 mp_init(&bigRemainder);
5012 mp_div(&big1, &big2, &bigResult, &bigRemainder);
5013 if (!mp_iszero(&bigRemainder)
5014 && (bigRemainder.sign != big2.sign)) {
5015 /*
5016 * Convert to Tcl's integer division rules.
5017 */
5018
5019 mp_sub_d(&bigResult, 1, &bigResult);
5020 mp_add(&bigRemainder, &big2, &bigRemainder);
5021 }
5022 mp_copy(&bigRemainder, &bigResult);
5023 mp_clear(&bigRemainder);
5024 mp_clear(&big1);
5025 mp_clear(&big2);
5026 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5027 if (Tcl_IsShared(valuePtr)) {
5028 objResultPtr = Tcl_NewBignumObj(&bigResult);
5029 TRACE(("%s\n", O2S(objResultPtr)));
5030 NEXT_INST_F(1, 2, 1);
5031 }
5032 Tcl_SetBignumObj(valuePtr, &bigResult);
5033 TRACE(("%s\n", O2S(valuePtr)));
5034 NEXT_INST_F(1, 1, 0);
5035 }
5036 }
5037
5038 /*
5039 * Reject negative shift argument.
5040 */
5041
5042 switch (type2) {
5043 case TCL_NUMBER_LONG:
5044 invalid = (*((const long *)ptr2) < (long)0);
5045 break;
5046 #ifndef NO_WIDE_TYPE
5047 case TCL_NUMBER_WIDE:
5048 invalid = (*((const Tcl_WideInt *)ptr2) < (Tcl_WideInt)0);
5049 break;
5050 #endif
5051 case TCL_NUMBER_BIG: {
5052 mp_int big2;
5053
5054 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
5055 invalid = (mp_cmp_d(&big2, 0) == MP_LT);
5056 mp_clear(&big2);
5057 break;
5058 }
5059 default:
5060 /* Unused, here to silence compiler warning */
5061 invalid = 0;
5062 }
5063 if (invalid) {
5064 Tcl_SetObjResult(interp,
5065 Tcl_NewStringObj("negative shift argument", -1));
5066 result = TCL_ERROR;
5067 goto checkForCatch;
5068 }
5069
5070 /*
5071 * Zero shifted any number of bits is still zero.
5072 */
5073
5074 if ((type1==TCL_NUMBER_LONG) && (*((const long *)ptr1) == (long)0)) {
5075 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5076 objResultPtr = constants[0];
5077 TRACE(("%s\n", O2S(objResultPtr)));
5078 NEXT_INST_F(1, 2, 1);
5079 }
5080
5081 if (*pc == INST_LSHIFT) {
5082 /*
5083 * Large left shifts create integer overflow.
5084 *
5085 * BEWARE! Can't use Tcl_GetIntFromObj() here because that
5086 * converts values in the (unsigned) range to their signed int
5087 * counterparts, leading to incorrect results.
5088 */
5089
5090 if ((type2 != TCL_NUMBER_LONG)
5091 || (*((const long *)ptr2) > (long) INT_MAX)) {
5092 /*
5093 * Technically, we could hold the value (1 << (INT_MAX+1)) in
5094 * an mp_int, but since we're using mp_mul_2d() to do the
5095 * work, and it takes only an int argument, that's a good
5096 * place to draw the line.
5097 */
5098
5099 Tcl_SetObjResult(interp, Tcl_NewStringObj(
5100 "integer value too large to represent", -1));
5101 result = TCL_ERROR;
5102 goto checkForCatch;
5103 }
5104 shift = (int)(*((const long *)ptr2));
5105
5106 /*
5107 * Handle shifts within the native long range.
5108 */
5109
5110 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5111 if ((type1 == TCL_NUMBER_LONG)
5112 && (size_t) shift < CHAR_BIT*sizeof(long)
5113 && ((l1 = *(const long *)ptr1) != 0)
5114 && !((l1>0 ? l1 : ~l1)
5115 & -(1L<<(CHAR_BIT*sizeof(long) - 1 - shift)))) {
5116 TclNewLongObj(objResultPtr, (l1<<shift));
5117 TRACE(("%s\n", O2S(objResultPtr)));
5118 NEXT_INST_F(1, 2, 1);
5119 }
5120
5121 /*
5122 * Handle shifts within the native wide range.
5123 */
5124
5125 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5126 if ((type1 != TCL_NUMBER_BIG)
5127 && ((size_t)shift < CHAR_BIT*sizeof(Tcl_WideInt))) {
5128 Tcl_WideInt w;
5129
5130 TclGetWideIntFromObj(NULL, valuePtr, &w);
5131 if (!((w>0 ? w : ~w)
5132 & -(((Tcl_WideInt)1)
5133 << (CHAR_BIT*sizeof(Tcl_WideInt) - 1 - shift)))) {
5134 objResultPtr = Tcl_NewWideIntObj(w<<shift);
5135 TRACE(("%s\n", O2S(objResultPtr)));
5136 NEXT_INST_F(1, 2, 1);
5137 }
5138 }
5139 } else {
5140 /*
5141 * Quickly force large right shifts to 0 or -1.
5142 */
5143
5144 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5145 if ((type2 != TCL_NUMBER_LONG)
5146 || (*(const long *)ptr2 > INT_MAX)) {
5147 /*
5148 * Again, technically, the value to be shifted could be an
5149 * mp_int so huge that a right shift by (INT_MAX+1) bits could
5150 * not take us to the result of 0 or -1, but since we're using
5151 * mp_div_2d to do the work, and it takes only an int
5152 * argument, we draw the line there.
5153 */
5154
5155 int zero;
5156
5157 switch (type1) {
5158 case TCL_NUMBER_LONG:
5159 zero = (*(const long *)ptr1 > 0L);
5160 break;
5161 #ifndef NO_WIDE_TYPE
5162 case TCL_NUMBER_WIDE:
5163 zero = (*(const Tcl_WideInt *)ptr1 > (Tcl_WideInt)0);
5164 break;
5165 #endif
5166 case TCL_NUMBER_BIG: {
5167 mp_int big1;
5168 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
5169 zero = (mp_cmp_d(&big1, 0) == MP_GT);
5170 mp_clear(&big1);
5171 break;
5172 }
5173 default:
5174 /* Unused, here to silence compiler warning. */
5175 zero = 0;
5176 }
5177 if (zero) {
5178 objResultPtr = constants[0];
5179 } else {
5180 TclNewIntObj(objResultPtr, -1);
5181 }
5182 TRACE(("%s\n", O2S(objResultPtr)));
5183 NEXT_INST_F(1, 2, 1);
5184 }
5185 shift = (int)(*(const long *)ptr2);
5186
5187 /*
5188 * Handle shifts within the native long range.
5189 */
5190
5191 if (type1 == TCL_NUMBER_LONG) {
5192 l1 = *((const long *)ptr1);
5193 if ((size_t)shift >= CHAR_BIT*sizeof(long)) {
5194 if (l1 >= (long)0) {
5195 objResultPtr = constants[0];
5196 } else {
5197 TclNewIntObj(objResultPtr, -1);
5198 }
5199 } else {
5200 TclNewLongObj(objResultPtr, (l1 >> shift));
5201 }
5202 TRACE(("%s\n", O2S(objResultPtr)));
5203 NEXT_INST_F(1, 2, 1);
5204 }
5205
5206 #ifndef NO_WIDE_TYPE
5207 /*
5208 * Handle shifts within the native wide range.
5209 */
5210
5211 if (type1 == TCL_NUMBER_WIDE) {
5212 Tcl_WideInt w = *(const Tcl_WideInt *)ptr1;
5213
5214 if ((size_t)shift >= CHAR_BIT*sizeof(Tcl_WideInt)) {
5215 if (w >= (Tcl_WideInt)0) {
5216 objResultPtr = constants[0];
5217 } else {
5218 TclNewIntObj(objResultPtr, -1);
5219 }
5220 } else {
5221 objResultPtr = Tcl_NewWideIntObj(w >> shift);
5222 }
5223 TRACE(("%s\n", O2S(objResultPtr)));
5224 NEXT_INST_F(1, 2, 1);
5225 }
5226 #endif
5227 }
5228
5229 {
5230 mp_int big, bigResult, bigRemainder;
5231
5232 Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
5233
5234 mp_init(&bigResult);
5235 if (*pc == INST_LSHIFT) {
5236 mp_mul_2d(&big, shift, &bigResult);
5237 } else {
5238 mp_init(&bigRemainder);
5239 mp_div_2d(&big, shift, &bigResult, &bigRemainder);
5240 if (mp_cmp_d(&bigRemainder, 0) == MP_LT) {
5241 /*
5242 * Convert to Tcl's integer division rules.
5243 */
5244
5245 mp_sub_d(&bigResult, 1, &bigResult);
5246 }
5247 mp_clear(&bigRemainder);
5248 }
5249 mp_clear(&big);
5250
5251 if (!Tcl_IsShared(valuePtr)) {
5252 Tcl_SetBignumObj(valuePtr, &bigResult);
5253 TRACE(("%s\n", O2S(valuePtr)));
5254 NEXT_INST_F(1, 1, 0);
5255 }
5256 objResultPtr = Tcl_NewBignumObj(&bigResult);
5257 }
5258 TRACE(("%s\n", O2S(objResultPtr)));
5259 NEXT_INST_F(1, 2, 1);
5260 }
5261
5262 case INST_BITOR:
5263 case INST_BITXOR:
5264 case INST_BITAND: {
5265 ClientData ptr1, ptr2;
5266 int type1, type2;
5267 Tcl_Obj *value2Ptr = OBJ_AT_TOS;
5268 Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
5269
5270 result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
5271 if ((result != TCL_OK)
5272 || (type1 == TCL_NUMBER_NAN)
5273 || (type1 == TCL_NUMBER_DOUBLE)) {
5274 result = TCL_ERROR;
5275 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n", O2S(valuePtr),
5276 O2S(value2Ptr), (valuePtr->typePtr?
5277 valuePtr->typePtr->name : "null")));
5278 DECACHE_STACK_INFO();
5279 IllegalExprOperandType(interp, pc, valuePtr);
5280 CACHE_STACK_INFO();
5281 goto checkForCatch;
5282 }
5283 result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
5284 if ((result != TCL_OK) || (type2 == TCL_NUMBER_NAN)
5285 || (type2 == TCL_NUMBER_DOUBLE)) {
5286 result = TCL_ERROR;
5287 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n", O2S(valuePtr),
5288 O2S(value2Ptr), (value2Ptr->typePtr?
5289 value2Ptr->typePtr->name : "null")));
5290 DECACHE_STACK_INFO();
5291 IllegalExprOperandType(interp, pc, value2Ptr);
5292 CACHE_STACK_INFO();
5293 goto checkForCatch;
5294 }
5295
5296 if ((type1 == TCL_NUMBER_BIG) || (type2 == TCL_NUMBER_BIG)) {
5297 mp_int big1, big2, bigResult, *First, *Second;
5298 int numPos;
5299
5300 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
5301 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
5302
5303 /*
5304 * Count how many positive arguments we have. If only one of the
5305 * arguments is negative, store it in 'Second'.
5306 */
5307
5308 if (mp_cmp_d(&big1, 0) != MP_LT) {
5309 numPos = 1 + (mp_cmp_d(&big2, 0) != MP_LT);
5310 First = &big1;
5311 Second = &big2;
5312 } else {
5313 First = &big2;
5314 Second = &big1;
5315 numPos = (mp_cmp_d(First, 0) != MP_LT);
5316 }
5317 mp_init(&bigResult);
5318
5319 switch (*pc) {
5320 case INST_BITAND:
5321 switch (numPos) {
5322 case 2:
5323 /*
5324 * Both arguments positive, base case.
5325 */
5326
5327 mp_and(First, Second, &bigResult);
5328 break;
5329 case 1:
5330 /*
5331 * First is positive; second negative:
5332 * P & N = P & ~~N = P&~(-N-1) = P & (P ^ (-N-1))
5333 */
5334
5335 mp_neg(Second, Second);
5336 mp_sub_d(Second, 1, Second);
5337 mp_xor(First, Second, &bigResult);
5338 mp_and(First, &bigResult, &bigResult);
5339 break;
5340 case 0:
5341 /*
5342 * Both arguments negative:
5343 * a & b = ~ (~a | ~b) = -(-a-1|-b-1)-1
5344 */
5345
5346 mp_neg(First, First);
5347 mp_sub_d(First, 1, First);
5348 mp_neg(Second, Second);
5349 mp_sub_d(Second, 1, Second);
5350 mp_or(First, Second, &bigResult);
5351 mp_neg(&bigResult, &bigResult);
5352 mp_sub_d(&bigResult, 1, &bigResult);
5353 break;
5354 }
5355 break;
5356
5357 case INST_BITOR:
5358 switch (numPos) {
5359 case 2:
5360 /*
5361 * Both arguments positive, base case.
5362 */
5363
5364 mp_or(First, Second, &bigResult);
5365 break;
5366 case 1:
5367 /*
5368 * First is positive; second negative:
5369 * N|P = ~(~N&~P) = ~((-N-1)&~P) = -((-N-1)&((-N-1)^P))-1
5370 */
5371
5372 mp_neg(Second, Second);
5373 mp_sub_d(Second, 1, Second);
5374 mp_xor(First, Second, &bigResult);
5375 mp_and(Second, &bigResult, &bigResult);
5376 mp_neg(&bigResult, &bigResult);
5377 mp_sub_d(&bigResult, 1, &bigResult);
5378 break;
5379 case 0:
5380 /*
5381 * Both arguments negative:
5382 * a | b = ~ (~a & ~b) = -(-a-1&-b-1)-1
5383 */
5384
5385 mp_neg(First, First);
5386 mp_sub_d(First, 1, First);
5387 mp_neg(Second, Second);
5388 mp_sub_d(Second, 1, Second);
5389 mp_and(First, Second, &bigResult);
5390 mp_neg(&bigResult, &bigResult);
5391 mp_sub_d(&bigResult, 1, &bigResult);
5392 break;
5393 }
5394 break;
5395
5396 case INST_BITXOR:
5397 switch (numPos) {
5398 case 2:
5399 /*
5400 * Both arguments positive, base case.
5401 */
5402
5403 mp_xor(First, Second, &bigResult);
5404 break;
5405 case 1:
5406 /*
5407 * First is positive; second negative:
5408 * P^N = ~(P^~N) = -(P^(-N-1))-1
5409 */
5410
5411 mp_neg(Second, Second);
5412 mp_sub_d(Second, 1, Second);
5413 mp_xor(First, Second, &bigResult);
5414 mp_neg(&bigResult, &bigResult);
5415 mp_sub_d(&bigResult, 1, &bigResult);
5416 break;
5417 case 0:
5418 /*
5419 * Both arguments negative:
5420 * a ^ b = (~a ^ ~b) = (-a-1^-b-1)
5421 */
5422
5423 mp_neg(First, First);
5424 mp_sub_d(First, 1, First);
5425 mp_neg(Second, Second);
5426 mp_sub_d(Second, 1, Second);
5427 mp_xor(First, Second, &bigResult);
5428 break;
5429 }
5430 break;
5431 }
5432
5433 mp_clear(&big1);
5434 mp_clear(&big2);
5435 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5436 if (Tcl_IsShared(valuePtr)) {
5437 objResultPtr = Tcl_NewBignumObj(&bigResult);
5438 TRACE(("%s\n", O2S(objResultPtr)));
5439 NEXT_INST_F(1, 2, 1);
5440 }
5441 Tcl_SetBignumObj(valuePtr, &bigResult);
5442 TRACE(("%s\n", O2S(valuePtr)));
5443 NEXT_INST_F(1, 1, 0);
5444 }
5445
5446 #ifndef NO_WIDE_TYPE
5447 if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE)) {
5448 Tcl_WideInt wResult, w1, w2;
5449
5450 TclGetWideIntFromObj(NULL, valuePtr, &w1);
5451 TclGetWideIntFromObj(NULL, value2Ptr, &w2);
5452
5453 switch (*pc) {
5454 case INST_BITAND:
5455 wResult = w1 & w2;
5456 break;
5457 case INST_BITOR:
5458 wResult = w1 | w2;
5459 break;
5460 case INST_BITXOR:
5461 wResult = w1 ^ w2;
5462 break;
5463 default:
5464 /* Unused, here to silence compiler warning. */
5465 wResult = 0;
5466 }
5467
5468 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5469 if (Tcl_IsShared(valuePtr)) {
5470 objResultPtr = Tcl_NewWideIntObj(wResult);
5471 TRACE(("%s\n", O2S(objResultPtr)));
5472 NEXT_INST_F(1, 2, 1);
5473 }
5474 Tcl_SetWideIntObj(valuePtr, wResult);
5475 TRACE(("%s\n", O2S(valuePtr)));
5476 NEXT_INST_F(1, 1, 0);
5477 }
5478 #endif
5479 {
5480 long lResult, l1 = *((const long *)ptr1);
5481 long l2 = *((const long *)ptr2);
5482
5483 switch (*pc) {
5484 case INST_BITAND:
5485 lResult = l1 & l2;
5486 break;
5487 case INST_BITOR:
5488 lResult = l1 | l2;
5489 break;
5490 case INST_BITXOR:
5491 lResult = l1 ^ l2;
5492 break;
5493 default:
5494 /* Unused, here to silence compiler warning. */
5495 lResult = 0;
5496 }
5497
5498 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5499 if (Tcl_IsShared(valuePtr)) {
5500 TclNewLongObj(objResultPtr, lResult);
5501 TRACE(("%s\n", O2S(objResultPtr)));
5502 NEXT_INST_F(1, 2, 1);
5503 }
5504 TclSetLongObj(valuePtr, lResult);
5505 TRACE(("%s\n", O2S(valuePtr)));
5506 NEXT_INST_F(1, 1, 0);
5507 }
5508 }
5509
5510 case INST_EXPON:
5511 case INST_ADD:
5512 case INST_SUB:
5513 case INST_DIV:
5514 case INST_MULT: {
5515 ClientData ptr1, ptr2;
5516 int type1, type2;
5517 Tcl_Obj *value2Ptr = OBJ_AT_TOS;
5518 Tcl_Obj *valuePtr = OBJ_UNDER_TOS;
5519
5520 result = GetNumberFromObj(NULL, valuePtr, &ptr1, &type1);
5521 if ((result != TCL_OK)
5522 #ifndef ACCEPT_NAN
5523 || (type1 == TCL_NUMBER_NAN)
5524 #endif
5525 ) {
5526 result = TCL_ERROR;
5527 TRACE(("%.20s %.20s => ILLEGAL 1st TYPE %s\n",
5528 O2S(value2Ptr), O2S(valuePtr),
5529 (valuePtr->typePtr? valuePtr->typePtr->name: "null")));
5530 DECACHE_STACK_INFO();
5531 IllegalExprOperandType(interp, pc, valuePtr);
5532 CACHE_STACK_INFO();
5533 goto checkForCatch;
5534 }
5535
5536 #ifdef ACCEPT_NAN
5537 if (type1 == TCL_NUMBER_NAN) {
5538 /*
5539 * NaN first argument -> result is also NaN.
5540 */
5541
5542 NEXT_INST_F(1, 1, 0);
5543 }
5544 #endif
5545
5546 result = GetNumberFromObj(NULL, value2Ptr, &ptr2, &type2);
5547 if ((result != TCL_OK)
5548 #ifndef ACCEPT_NAN
5549 || (type2 == TCL_NUMBER_NAN)
5550 #endif
5551 ) {
5552 result = TCL_ERROR;
5553 TRACE(("%.20s %.20s => ILLEGAL 2nd TYPE %s\n",
5554 O2S(value2Ptr), O2S(valuePtr),
5555 (value2Ptr->typePtr? value2Ptr->typePtr->name: "null")));
5556 DECACHE_STACK_INFO();
5557 IllegalExprOperandType(interp, pc, value2Ptr);
5558 CACHE_STACK_INFO();
5559 goto checkForCatch;
5560 }
5561
5562 #ifdef ACCEPT_NAN
5563 if (type2 == TCL_NUMBER_NAN) {
5564 /*
5565 * NaN second argument -> result is also NaN.
5566 */
5567
5568 objResultPtr = value2Ptr;
5569 NEXT_INST_F(1, 2, 1);
5570 }
5571 #endif
5572
5573 if ((type1 == TCL_NUMBER_DOUBLE) || (type2 == TCL_NUMBER_DOUBLE)) {
5574 /*
5575 * At least one of the values is floating-point, so perform
5576 * floating point calculations.
5577 */
5578
5579 double d1, d2, dResult;
5580
5581 Tcl_GetDoubleFromObj(NULL, valuePtr, &d1);
5582 Tcl_GetDoubleFromObj(NULL, value2Ptr, &d2);
5583
5584 switch (*pc) {
5585 case INST_ADD:
5586 dResult = d1 + d2;
5587 break;
5588 case INST_SUB:
5589 dResult = d1 - d2;
5590 break;
5591 case INST_MULT:
5592 dResult = d1 * d2;
5593 break;
5594 case INST_DIV:
5595 #ifndef IEEE_FLOATING_POINT
5596 if (d2 == 0.0) {
5597 TRACE(("%.6g %.6g => DIVIDE BY ZERO\n", d1, d2));
5598 goto divideByZero;
5599 }
5600 #endif
5601 /*
5602 * We presume that we are running with zero-divide unmasked if
5603 * we're on an IEEE box. Otherwise, this statement might cause
5604 * demons to fly out our noses.
5605 */
5606
5607 dResult = d1 / d2;
5608 break;
5609 case INST_EXPON:
5610 if (d1==0.0 && d2<0.0) {
5611 TRACE(("%.6g %.6g => EXPONENT OF ZERO\n", d1, d2));
5612 goto exponOfZero;
5613 }
5614 dResult = pow(d1, d2);
5615 break;
5616 default:
5617 /* Unused, here to silence compiler warning. */
5618 dResult = 0;
5619 }
5620
5621 #ifndef ACCEPT_NAN
5622 /*
5623 * Check now for IEEE floating-point error.
5624 */
5625
5626 if (TclIsNaN(dResult)) {
5627 TRACE(("%.20s %.20s => IEEE FLOATING PT ERROR\n",
5628 O2S(valuePtr), O2S(value2Ptr)));
5629 DECACHE_STACK_INFO();
5630 TclExprFloatError(interp, dResult);
5631 CACHE_STACK_INFO();
5632 result = TCL_ERROR;
5633 goto checkForCatch;
5634 }
5635 #endif
5636 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5637 if (Tcl_IsShared(valuePtr)) {
5638 TclNewDoubleObj(objResultPtr, dResult);
5639 TRACE(("%s\n", O2S(objResultPtr)));
5640 NEXT_INST_F(1, 2, 1);
5641 }
5642 TclSetDoubleObj(valuePtr, dResult);
5643 TRACE(("%s\n", O2S(valuePtr)));
5644 NEXT_INST_F(1, 1, 0);
5645 }
5646
5647 if ((sizeof(long) >= 2*sizeof(int)) && (*pc == INST_MULT)
5648 && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
5649 long l1 = *((const long *)ptr1);
5650 long l2 = *((const long *)ptr2);
5651
5652 if ((l1 <= INT_MAX) && (l1 >= INT_MIN)
5653 && (l2 <= INT_MAX) && (l2 >= INT_MIN)) {
5654 long lResult = l1 * l2;
5655
5656 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5657 if (Tcl_IsShared(valuePtr)) {
5658 TclNewLongObj(objResultPtr,lResult);
5659 TRACE(("%s\n", O2S(objResultPtr)));
5660 NEXT_INST_F(1, 2, 1);
5661 }
5662 TclSetLongObj(valuePtr, lResult);
5663 TRACE(("%s\n", O2S(valuePtr)));
5664 NEXT_INST_F(1, 1, 0);
5665 }
5666 }
5667
5668 if ((sizeof(Tcl_WideInt) >= 2*sizeof(long)) && (*pc == INST_MULT)
5669 && (type1 == TCL_NUMBER_LONG) && (type2 == TCL_NUMBER_LONG)) {
5670 Tcl_WideInt w1, w2, wResult;
5671 TclGetWideIntFromObj(NULL, valuePtr, &w1);
5672 TclGetWideIntFromObj(NULL, value2Ptr, &w2);
5673
5674 wResult = w1 * w2;
5675
5676 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5677 if (Tcl_IsShared(valuePtr)) {
5678 objResultPtr = Tcl_NewWideIntObj(wResult);
5679 TRACE(("%s\n", O2S(objResultPtr)));
5680 NEXT_INST_F(1, 2, 1);
5681 }
5682 Tcl_SetWideIntObj(valuePtr, wResult);
5683 TRACE(("%s\n", O2S(valuePtr)));
5684 NEXT_INST_F(1, 1, 0);
5685 }
5686
5687 /* TODO: Attempts to re-use unshared operands on stack. */
5688 if (*pc == INST_EXPON) {
5689 long l1 = 0, l2 = 0;
5690 int oddExponent = 0, negativeExponent = 0;
5691 #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
5692 Tcl_WideInt w1;
5693 #endif
5694
5695 if (type2 == TCL_NUMBER_LONG) {
5696 l2 = *((const long *) ptr2);
5697 if (l2 == 0) {
5698 /*
5699 * Anything to the zero power is 1.
5700 */
5701
5702 objResultPtr = constants[1];
5703 NEXT_INST_F(1, 2, 1);
5704 } else if (l2 == 1) {
5705 /*
5706 * Anything to the first power is itself
5707 */
5708 NEXT_INST_F(1, 1, 0);
5709 }
5710 }
5711
5712 switch (type2) {
5713 case TCL_NUMBER_LONG: {
5714 negativeExponent = (l2 < 0);
5715 oddExponent = (int) (l2 & 1);
5716 break;
5717 }
5718 #ifndef NO_WIDE_TYPE
5719 case TCL_NUMBER_WIDE: {
5720 Tcl_WideInt w2 = *((const Tcl_WideInt *)ptr2);
5721
5722 negativeExponent = (w2 < 0);
5723 oddExponent = (int) (w2 & (Tcl_WideInt)1);
5724 break;
5725 }
5726 #endif
5727 case TCL_NUMBER_BIG: {
5728 mp_int big2;
5729
5730 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
5731 negativeExponent = (mp_cmp_d(&big2, 0) == MP_LT);
5732 mp_mod_2d(&big2, 1, &big2);
5733 oddExponent = !mp_iszero(&big2);
5734 mp_clear(&big2);
5735 break;
5736 }
5737 }
5738
5739 if (type1 == TCL_NUMBER_LONG) {
5740 l1 = *((const long *)ptr1);
5741 }
5742 if (negativeExponent) {
5743 if (type1 == TCL_NUMBER_LONG) {
5744 switch (l1) {
5745 case 0:
5746 /*
5747 * Zero to a negative power is div by zero error.
5748 */
5749
5750 TRACE(("%s %s => EXPONENT OF ZERO\n", O2S(valuePtr),
5751 O2S(value2Ptr)));
5752 goto exponOfZero;
5753 case -1:
5754 if (oddExponent) {
5755 TclNewIntObj(objResultPtr, -1);
5756 } else {
5757 objResultPtr = constants[1];
5758 }
5759 NEXT_INST_F(1, 2, 1);
5760 case 1:
5761 /*
5762 * 1 to any power is 1.
5763 */
5764
5765 objResultPtr = constants[1];
5766 NEXT_INST_F(1, 2, 1);
5767 }
5768 }
5769
5770 /*
5771 * Integers with magnitude greater than 1 raise to a negative
5772 * power yield the answer zero (see TIP 123).
5773 */
5774
5775 objResultPtr = constants[0];
5776 NEXT_INST_F(1, 2, 1);
5777 }
5778
5779 if (type1 == TCL_NUMBER_LONG) {
5780 switch (l1) {
5781 case 0:
5782 /*
5783 * Zero to a positive power is zero.
5784 */
5785
5786 objResultPtr = constants[0];
5787 NEXT_INST_F(1, 2, 1);
5788 case 1:
5789 /*
5790 * 1 to any power is 1.
5791 */
5792
5793 objResultPtr = constants[1];
5794 NEXT_INST_F(1, 2, 1);
5795 case -1:
5796 if (oddExponent) {
5797 TclNewIntObj(objResultPtr, -1);
5798 } else {
5799 objResultPtr = constants[1];
5800 }
5801 NEXT_INST_F(1, 2, 1);
5802 }
5803 }
5804 /*
5805 * We refuse to accept exponent arguments that exceed
5806 * one mp_digit which means the max exponent value is
5807 * 2**28-1 = 0x0fffffff = 268435455, which fits into
5808 * a signed 32 bit int which is within the range of the
5809 * long int type. This means any numeric Tcl_Obj value
5810 * not using TCL_NUMBER_LONG type must hold a value larger
5811 * than we accept.
5812 */
5813 if (type2 != TCL_NUMBER_LONG) {
5814 Tcl_SetObjResult(interp,
5815 Tcl_NewStringObj("exponent too large", -1));
5816 result = TCL_ERROR;
5817 goto checkForCatch;
5818 }
5819
5820 if (type1 == TCL_NUMBER_LONG) {
5821 if (l1 == 2) {
5822 /*
5823 * Reduce small powers of 2 to shifts.
5824 */
5825
5826 if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
5827 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5828 TclNewLongObj(objResultPtr, (1L << l2));
5829 TRACE(("%s\n", O2S(objResultPtr)));
5830 NEXT_INST_F(1, 2, 1);
5831 }
5832 #if !defined(TCL_WIDE_INT_IS_LONG)
5833 if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
5834 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5835 objResultPtr =
5836 Tcl_NewWideIntObj(((Tcl_WideInt) 1) << l2);
5837 TRACE(("%s\n", O2S(objResultPtr)));
5838 NEXT_INST_F(1, 2, 1);
5839 }
5840 #endif
5841 goto overflow;
5842 }
5843 if (l1 == -2) {
5844 int signum = oddExponent ? -1 : 1;
5845
5846 /*
5847 * Reduce small powers of 2 to shifts.
5848 */
5849
5850 if ((unsigned long) l2 < CHAR_BIT * sizeof(long) - 1) {
5851 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5852 TclNewLongObj(objResultPtr, signum * (1L << l2));
5853 TRACE(("%s\n", O2S(objResultPtr)));
5854 NEXT_INST_F(1, 2, 1);
5855 }
5856 #if !defined(TCL_WIDE_INT_IS_LONG)
5857 if ((unsigned long)l2 < CHAR_BIT*sizeof(Tcl_WideInt) - 1){
5858 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5859 objResultPtr = Tcl_NewWideIntObj(
5860 signum * (((Tcl_WideInt) 1) << l2));
5861 TRACE(("%s\n", O2S(objResultPtr)));
5862 NEXT_INST_F(1, 2, 1);
5863 }
5864 #endif
5865 goto overflow;
5866 }
5867 #if (LONG_MAX == 0x7fffffff)
5868 if (l2 - 2 < (long)MaxBase32Size
5869 && l1 <= MaxBase32[l2 - 2]
5870 && l1 >= -MaxBase32[l2 - 2]) {
5871 /*
5872 * Small powers of 32-bit integers.
5873 */
5874
5875 long lResult = l1 * l1; /* b**2 */
5876 switch (l2) {
5877 case 2:
5878 break;
5879 case 3:
5880 lResult *= l1; /* b**3 */
5881 break;
5882 case 4:
5883 lResult *= lResult; /* b**4 */
5884 break;
5885 case 5:
5886 lResult *= lResult; /* b**4 */
5887 lResult *= l1; /* b**5 */
5888 break;
5889 case 6:
5890 lResult *= l1; /* b**3 */
5891 lResult *= lResult; /* b**6 */
5892 break;
5893 case 7:
5894 lResult *= l1; /* b**3 */
5895 lResult *= lResult; /* b**6 */
5896 lResult *= l1; /* b**7 */
5897 break;
5898 case 8:
5899 lResult *= lResult; /* b**4 */
5900 lResult *= lResult; /* b**8 */
5901 break;
5902 }
5903 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5904 if (Tcl_IsShared(valuePtr)) {
5905 TclNewLongObj(objResultPtr, lResult);
5906 TRACE(("%s\n", O2S(objResultPtr)));
5907 NEXT_INST_F(1, 2, 1);
5908 }
5909 Tcl_SetLongObj(valuePtr, lResult);
5910 TRACE(("%s\n", O2S(valuePtr)));
5911 NEXT_INST_F(1, 1, 0);
5912 }
5913 if (l1 - 3 >= 0 && l1 - 2 < (long)Exp32IndexSize
5914 && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
5915
5916 unsigned short base = Exp32Index[l1 - 3]
5917 + (unsigned short) (l2 - 2 - MaxBase32Size);
5918 if (base < Exp32Index[l1 - 2]) {
5919 /*
5920 * 32-bit number raised to intermediate power, done by
5921 * table lookup.
5922 */
5923
5924 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5925 if (Tcl_IsShared(valuePtr)) {
5926 TclNewLongObj(objResultPtr, Exp32Value[base]);
5927 TRACE(("%s\n", O2S(objResultPtr)));
5928 NEXT_INST_F(1, 2, 1);
5929 }
5930 Tcl_SetLongObj(valuePtr, Exp32Value[base]);
5931 TRACE(("%s\n", O2S(valuePtr)));
5932 NEXT_INST_F(1, 1, 0);
5933 }
5934 }
5935 if (-l1 - 3 >= 0 && -l1 - 2 < (long)Exp32IndexSize
5936 && l2 - 2 < (long)(Exp32ValueSize + MaxBase32Size)) {
5937 unsigned short base = Exp32Index[-l1 - 3]
5938 + (unsigned short) (l2 - 2 - MaxBase32Size);
5939 if (base < Exp32Index[-l1 - 2]) {
5940 long lResult = (oddExponent) ?
5941 -Exp32Value[base] : Exp32Value[base];
5942
5943 /*
5944 * 32-bit number raised to intermediate power, done by
5945 * table lookup.
5946 */
5947
5948 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
5949 if (Tcl_IsShared(valuePtr)) {
5950 TclNewLongObj(objResultPtr, lResult);
5951 TRACE(("%s\n", O2S(objResultPtr)));
5952 NEXT_INST_F(1, 2, 1);
5953 }
5954 Tcl_SetLongObj(valuePtr, lResult);
5955 TRACE(("%s\n", O2S(valuePtr)));
5956 NEXT_INST_F(1, 1, 0);
5957 }
5958 }
5959 #endif
5960 }
5961 #if (LONG_MAX > 0x7fffffff) || !defined(TCL_WIDE_INT_IS_LONG)
5962 if (type1 == TCL_NUMBER_LONG) {
5963 w1 = l1;
5964 #ifndef NO_WIDE_TYPE
5965 } else if (type1 == TCL_NUMBER_WIDE) {
5966 w1 = *((const Tcl_WideInt*) ptr1);
5967 #endif
5968 } else {
5969 goto overflow;
5970 }
5971 if (l2 - 2 < (long)MaxBase64Size
5972 && w1 <= MaxBase64[l2 - 2]
5973 && w1 >= -MaxBase64[l2 - 2]) {
5974 /*
5975 * Small powers of integers whose result is wide.
5976 */
5977
5978 Tcl_WideInt wResult = w1 * w1; /* b**2 */
5979
5980 switch (l2) {
5981 case 2:
5982 break;
5983 case 3:
5984 wResult *= l1; /* b**3 */
5985 break;
5986 case 4:
5987 wResult *= wResult; /* b**4 */
5988 break;
5989 case 5:
5990 wResult *= wResult; /* b**4 */
5991 wResult *= w1; /* b**5 */
5992 break;
5993 case 6:
5994 wResult *= w1; /* b**3 */
5995 wResult *= wResult; /* b**6 */
5996 break;
5997 case 7:
5998 wResult *= w1; /* b**3 */
5999 wResult *= wResult; /* b**6 */
6000 wResult *= w1; /* b**7 */
6001 break;
6002 case 8:
6003 wResult *= wResult; /* b**4 */
6004 wResult *= wResult; /* b**8 */
6005 break;
6006 case 9:
6007 wResult *= wResult; /* b**4 */
6008 wResult *= wResult; /* b**8 */
6009 wResult *= w1; /* b**9 */
6010 break;
6011 case 10:
6012 wResult *= wResult; /* b**4 */
6013 wResult *= w1; /* b**5 */
6014 wResult *= wResult; /* b**10 */
6015 break;
6016 case 11:
6017 wResult *= wResult; /* b**4 */
6018 wResult *= w1; /* b**5 */
6019 wResult *= wResult; /* b**10 */
6020 wResult *= w1; /* b**11 */
6021 break;
6022 case 12:
6023 wResult *= w1; /* b**3 */
6024 wResult *= wResult; /* b**6 */
6025 wResult *= wResult; /* b**12 */
6026 break;
6027 case 13:
6028 wResult *= w1; /* b**3 */
6029 wResult *= wResult; /* b**6 */
6030 wResult *= wResult; /* b**12 */
6031 wResult *= w1; /* b**13 */
6032 break;
6033 case 14:
6034 wResult *= w1; /* b**3 */
6035 wResult *= wResult; /* b**6 */
6036 wResult *= w1; /* b**7 */
6037 wResult *= wResult; /* b**14 */
6038 break;
6039 case 15:
6040 wResult *= w1; /* b**3 */
6041 wResult *= wResult; /* b**6 */
6042 wResult *= w1; /* b**7 */
6043 wResult *= wResult; /* b**14 */
6044 wResult *= w1; /* b**15 */
6045 break;
6046 case 16:
6047 wResult *= wResult; /* b**4 */
6048 wResult *= wResult; /* b**8 */
6049 wResult *= wResult; /* b**16 */
6050 break;
6051
6052 }
6053 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6054 objResultPtr = Tcl_NewWideIntObj(wResult);
6055 TRACE(("%s\n", O2S(objResultPtr)));
6056 NEXT_INST_F(1, 2, 1);
6057 }
6058
6059 /*
6060 * Handle cases of powers > 16 that still fit in a 64-bit word by
6061 * doing table lookup.
6062 */
6063 if (w1 - 3 >= 0 && w1 - 2 < (long)Exp64IndexSize
6064 && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
6065 unsigned short base = Exp64Index[w1 - 3]
6066 + (unsigned short) (l2 - 2 - MaxBase64Size);
6067
6068 if (base < Exp64Index[w1 - 2]) {
6069 /*
6070 * 64-bit number raised to intermediate power, done by
6071 * table lookup.
6072 */
6073
6074 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6075 if (Tcl_IsShared(valuePtr)) {
6076 objResultPtr = Tcl_NewWideIntObj(Exp64Value[base]);
6077 TRACE(("%s\n", O2S(objResultPtr)));
6078 NEXT_INST_F(1, 2, 1);
6079 }
6080 Tcl_SetWideIntObj(valuePtr, Exp64Value[base]);
6081 TRACE(("%s\n", O2S(valuePtr)));
6082 NEXT_INST_F(1, 1, 0);
6083 }
6084 }
6085
6086 if (-w1 - 3 >= 0 && -w1 - 2 < (long)Exp64IndexSize
6087 && l2 - 2 < (long)(Exp64ValueSize + MaxBase64Size)) {
6088 unsigned short base = Exp64Index[-w1 - 3]
6089 + (unsigned short) (l2 - 2 - MaxBase64Size);
6090
6091 if (base < Exp64Index[-w1 - 2]) {
6092 Tcl_WideInt wResult = (oddExponent) ?
6093 -Exp64Value[base] : Exp64Value[base];
6094 /*
6095 * 64-bit number raised to intermediate power, done by
6096 * table lookup.
6097 */
6098
6099 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6100 if (Tcl_IsShared(valuePtr)) {
6101 objResultPtr = Tcl_NewWideIntObj(wResult);
6102 TRACE(("%s\n", O2S(objResultPtr)));
6103 NEXT_INST_F(1, 2, 1);
6104 }
6105 Tcl_SetWideIntObj(valuePtr, wResult);
6106 TRACE(("%s\n", O2S(valuePtr)));
6107 NEXT_INST_F(1, 1, 0);
6108 }
6109 }
6110 #endif
6111
6112 goto overflow;
6113 }
6114
6115 if ((*pc != INST_MULT)
6116 && (type1 != TCL_NUMBER_BIG) && (type2 != TCL_NUMBER_BIG)) {
6117 Tcl_WideInt w1, w2, wResult;
6118
6119 TclGetWideIntFromObj(NULL, valuePtr, &w1);
6120 TclGetWideIntFromObj(NULL, value2Ptr, &w2);
6121
6122 switch (*pc) {
6123 case INST_ADD:
6124 wResult = w1 + w2;
6125 #ifndef NO_WIDE_TYPE
6126 if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
6127 #endif
6128 {
6129 /*
6130 * Check for overflow.
6131 */
6132
6133 if (Overflowing(w1, w2, wResult)) {
6134 goto overflow;
6135 }
6136 }
6137 break;
6138
6139 case INST_SUB:
6140 wResult = w1 - w2;
6141 #ifndef NO_WIDE_TYPE
6142 if ((type1 == TCL_NUMBER_WIDE) || (type2 == TCL_NUMBER_WIDE))
6143 #endif
6144 {
6145 /*
6146 * Must check for overflow. The macro tests for overflows
6147 * in sums by looking at the sign bits. As we have a
6148 * subtraction here, we are adding -w2. As -w2 could in
6149 * turn overflow, we test with ~w2 instead: it has the
6150 * opposite sign bit to w2 so it does the job. Note that
6151 * the only "bad" case (w2==0) is irrelevant for this
6152 * macro, as in that case w1 and wResult have the same
6153 * sign and there is no overflow anyway.
6154 */
6155
6156 if (Overflowing(w1, ~w2, wResult)) {
6157 goto overflow;
6158 }
6159 }
6160 break;
6161
6162 case INST_DIV:
6163 if (w2 == 0) {
6164 TRACE(("%s %s => DIVIDE BY ZERO\n",
6165 O2S(valuePtr), O2S(value2Ptr)));
6166 goto divideByZero;
6167 }
6168
6169 /*
6170 * Need a bignum to represent (LLONG_MIN / -1)
6171 */
6172
6173 if ((w1 == LLONG_MIN) && (w2 == -1)) {
6174 goto overflow;
6175 }
6176 wResult = w1 / w2;
6177
6178 /*
6179 * Force Tcl's integer division rules.
6180 * TODO: examine for logic simplification
6181 */
6182
6183 if (((wResult < 0) || ((wResult == 0) &&
6184 ((w1 < 0 && w2 > 0) || (w1 > 0 && w2 < 0)))) &&
6185 ((wResult * w2) != w1)) {
6186 wResult -= 1;
6187 }
6188 break;
6189 default:
6190 /*
6191 * Unused, here to silence compiler warning.
6192 */
6193
6194 wResult = 0;
6195 }
6196
6197 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6198 if (Tcl_IsShared(valuePtr)) {
6199 objResultPtr = Tcl_NewWideIntObj(wResult);
6200 TRACE(("%s\n", O2S(objResultPtr)));
6201 NEXT_INST_F(1, 2, 1);
6202 }
6203 Tcl_SetWideIntObj(valuePtr, wResult);
6204 TRACE(("%s\n", O2S(valuePtr)));
6205 NEXT_INST_F(1, 1, 0);
6206 }
6207
6208 overflow:
6209 {
6210 mp_int big1, big2, bigResult, bigRemainder;
6211
6212 TRACE(("%s %s => ", O2S(valuePtr), O2S(value2Ptr)));
6213 Tcl_TakeBignumFromObj(NULL, valuePtr, &big1);
6214 Tcl_TakeBignumFromObj(NULL, value2Ptr, &big2);
6215 mp_init(&bigResult);
6216 switch (*pc) {
6217 case INST_ADD:
6218 mp_add(&big1, &big2, &bigResult);
6219 break;
6220 case INST_SUB:
6221 mp_sub(&big1, &big2, &bigResult);
6222 break;
6223 case INST_MULT:
6224 mp_mul(&big1, &big2, &bigResult);
6225 break;
6226 case INST_DIV:
6227 if (mp_iszero(&big2)) {
6228 TRACE(("%s %s => DIVIDE BY ZERO\n", O2S(valuePtr),
6229 O2S(value2Ptr)));
6230 mp_clear(&big1);
6231 mp_clear(&big2);
6232 mp_clear(&bigResult);
6233 goto divideByZero;
6234 }
6235 mp_init(&bigRemainder);
6236 mp_div(&big1, &big2, &bigResult, &bigRemainder);
6237 /* TODO: internals intrusion */
6238 if (!mp_iszero(&bigRemainder)
6239 && (bigRemainder.sign != big2.sign)) {
6240 /*
6241 * Convert to Tcl's integer division rules.
6242 */
6243
6244 mp_sub_d(&bigResult, 1, &bigResult);
6245 mp_add(&bigRemainder, &big2, &bigRemainder);
6246 }
6247 mp_clear(&bigRemainder);
6248 break;
6249 case INST_EXPON:
6250 if (big2.used > 1) {
6251 Tcl_SetObjResult(interp,
6252 Tcl_NewStringObj("exponent too large", -1));
6253 mp_clear(&big1);
6254 mp_clear(&big2);
6255 mp_clear(&bigResult);
6256 result = TCL_ERROR;
6257 goto checkForCatch;
6258 }
6259 mp_expt_d(&big1, big2.dp[0], &bigResult);
6260 break;
6261 }
6262 mp_clear(&big1);
6263 mp_clear(&big2);
6264 if (Tcl_IsShared(valuePtr)) {
6265 objResultPtr = Tcl_NewBignumObj(&bigResult);
6266 TRACE(("%s\n", O2S(objResultPtr)));
6267 NEXT_INST_F(1, 2, 1);
6268 }
6269 Tcl_SetBignumObj(valuePtr, &bigResult);
6270 TRACE(("%s\n", O2S(valuePtr)));
6271 NEXT_INST_F(1, 1, 0);
6272 }
6273 }
6274
6275 case INST_LNOT: {
6276 int b;
6277 Tcl_Obj *valuePtr = OBJ_AT_TOS;
6278
6279 /* TODO - check claim that taking address of b harms performance */
6280 /* TODO - consider optimization search for constants */
6281 result = TclGetBooleanFromObj(NULL, valuePtr, &b);
6282 if (result != TCL_OK) {
6283 TRACE(("\"%.20s\" => ILLEGAL TYPE %s\n", O2S(valuePtr),
6284 (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
6285 DECACHE_STACK_INFO();
6286 IllegalExprOperandType(interp, pc, valuePtr);
6287 CACHE_STACK_INFO();
6288 goto checkForCatch;
6289 }
6290 /* TODO: Consider peephole opt. */
6291 objResultPtr = constants[!b];
6292 NEXT_INST_F(1, 1, 1);
6293 }
6294
6295 case INST_BITNOT: {
6296 mp_int big;
6297 ClientData ptr;
6298 int type;
6299 Tcl_Obj *valuePtr = OBJ_AT_TOS;
6300
6301 result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
6302 if ((result != TCL_OK)
6303 || (type == TCL_NUMBER_NAN) || (type == TCL_NUMBER_DOUBLE)) {
6304 /*
6305 * ... ~$NonInteger => raise an error.
6306 */
6307
6308 result = TCL_ERROR;
6309 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
6310 (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
6311 DECACHE_STACK_INFO();
6312 IllegalExprOperandType(interp, pc, valuePtr);
6313 CACHE_STACK_INFO();
6314 goto checkForCatch;
6315 }
6316 if (type == TCL_NUMBER_LONG) {
6317 long l = *((const long *)ptr);
6318
6319 if (Tcl_IsShared(valuePtr)) {
6320 TclNewLongObj(objResultPtr, ~l);
6321 NEXT_INST_F(1, 1, 1);
6322 }
6323 TclSetLongObj(valuePtr, ~l);
6324 NEXT_INST_F(1, 0, 0);
6325 }
6326 #ifndef NO_WIDE_TYPE
6327 if (type == TCL_NUMBER_WIDE) {
6328 Tcl_WideInt w = *((const Tcl_WideInt *)ptr);
6329
6330 if (Tcl_IsShared(valuePtr)) {
6331 objResultPtr = Tcl_NewWideIntObj(~w);
6332 NEXT_INST_F(1, 1, 1);
6333 }
6334 Tcl_SetWideIntObj(valuePtr, ~w);
6335 NEXT_INST_F(1, 0, 0);
6336 }
6337 #endif
6338 Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
6339 /* ~a = - a - 1 */
6340 mp_neg(&big, &big);
6341 mp_sub_d(&big, 1, &big);
6342 if (Tcl_IsShared(valuePtr)) {
6343 objResultPtr = Tcl_NewBignumObj(&big);
6344 NEXT_INST_F(1, 1, 1);
6345 }
6346 Tcl_SetBignumObj(valuePtr, &big);
6347 NEXT_INST_F(1, 0, 0);
6348 }
6349
6350 case INST_UMINUS: {
6351 ClientData ptr;
6352 int type;
6353 Tcl_Obj *valuePtr = OBJ_AT_TOS;
6354
6355 result = GetNumberFromObj(NULL, valuePtr, &ptr, &type);
6356 if ((result != TCL_OK)
6357 #ifndef ACCEPT_NAN
6358 || (type == TCL_NUMBER_NAN)
6359 #endif
6360 ) {
6361 result = TCL_ERROR;
6362 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
6363 (valuePtr->typePtr? valuePtr->typePtr->name : "null")));
6364 DECACHE_STACK_INFO();
6365 IllegalExprOperandType(interp, pc, valuePtr);
6366 CACHE_STACK_INFO();
6367 goto checkForCatch;
6368 }
6369 switch (type) {
6370 case TCL_NUMBER_DOUBLE: {
6371 double d;
6372
6373 if (Tcl_IsShared(valuePtr)) {
6374 TclNewDoubleObj(objResultPtr, -(*((const double *)ptr)));
6375 NEXT_INST_F(1, 1, 1);
6376 }
6377 d = *((const double *)ptr);
6378 TclSetDoubleObj(valuePtr, -d);
6379 NEXT_INST_F(1, 0, 0);
6380 }
6381 case TCL_NUMBER_LONG: {
6382 long l = *((const long *)ptr);
6383
6384 if (l != LONG_MIN) {
6385 if (Tcl_IsShared(valuePtr)) {
6386 TclNewLongObj(objResultPtr, -l);
6387 NEXT_INST_F(1, 1, 1);
6388 }
6389 TclSetLongObj(valuePtr, -l);
6390 NEXT_INST_F(1, 0, 0);
6391 }
6392 /* FALLTHROUGH */
6393 }
6394 #ifndef NO_WIDE_TYPE
6395 case TCL_NUMBER_WIDE: {
6396 Tcl_WideInt w;
6397
6398 if (type == TCL_NUMBER_LONG) {
6399 w = (Tcl_WideInt)(*((const long *)ptr));
6400 } else {
6401 w = *((const Tcl_WideInt *)ptr);
6402 }
6403 if (w != LLONG_MIN) {
6404 if (Tcl_IsShared(valuePtr)) {
6405 objResultPtr = Tcl_NewWideIntObj(-w);
6406 NEXT_INST_F(1, 1, 1);
6407 }
6408 Tcl_SetWideIntObj(valuePtr, -w);
6409 NEXT_INST_F(1, 0, 0);
6410 }
6411 /* FALLTHROUGH */
6412 }
6413 #endif
6414 case TCL_NUMBER_BIG: {
6415 mp_int big;
6416
6417 switch (type) {
6418 #ifdef NO_WIDE_TYPE
6419 case TCL_NUMBER_LONG:
6420 TclBNInitBignumFromLong(&big, *(const long *) ptr);
6421 break;
6422 #else
6423 case TCL_NUMBER_WIDE:
6424 TclBNInitBignumFromWideInt(&big, *(const Tcl_WideInt *) ptr);
6425 break;
6426 #endif
6427 case TCL_NUMBER_BIG:
6428 Tcl_TakeBignumFromObj(NULL, valuePtr, &big);
6429 }
6430 mp_neg(&big, &big);
6431 if (Tcl_IsShared(valuePtr)) {
6432 objResultPtr = Tcl_NewBignumObj(&big);
6433 NEXT_INST_F(1, 1, 1);
6434 }
6435 Tcl_SetBignumObj(valuePtr, &big);
6436 NEXT_INST_F(1, 0, 0);
6437 }
6438 case TCL_NUMBER_NAN:
6439 /* -NaN => NaN */
6440 NEXT_INST_F(1, 0, 0);
6441 }
6442 }
6443
6444 case INST_UPLUS:
6445 case INST_TRY_CVT_TO_NUMERIC: {
6446 /*
6447 * Try to convert the topmost stack object to numeric object. This is
6448 * done in order to support [expr]'s policy of interpreting operands
6449 * if at all possible as numbers first, then strings.
6450 */
6451
6452 ClientData ptr;
6453 int type;
6454 Tcl_Obj *valuePtr = OBJ_AT_TOS;
6455
6456 if (GetNumberFromObj(NULL, valuePtr, &ptr, &type) != TCL_OK) {
6457 if (*pc == INST_UPLUS) {
6458 /*
6459 * ... +$NonNumeric => raise an error.
6460 */
6461
6462 result = TCL_ERROR;
6463 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
6464 (valuePtr->typePtr? valuePtr->typePtr->name:"null")));
6465 DECACHE_STACK_INFO();
6466 IllegalExprOperandType(interp, pc, valuePtr);
6467 CACHE_STACK_INFO();
6468 goto checkForCatch;
6469 } else {
6470 /* ... TryConvertToNumeric($NonNumeric) is acceptable */
6471 TRACE(("\"%.20s\" => not numeric\n", O2S(valuePtr)));
6472 NEXT_INST_F(1, 0, 0);
6473 }
6474 }
6475 #ifndef ACCEPT_NAN
6476 if (type == TCL_NUMBER_NAN) {
6477 result = TCL_ERROR;
6478 if (*pc == INST_UPLUS) {
6479 /*
6480 * ... +$NonNumeric => raise an error.
6481 */
6482
6483 TRACE(("\"%.20s\" => ILLEGAL TYPE %s \n", O2S(valuePtr),
6484 (valuePtr->typePtr? valuePtr->typePtr->name:"null")));
6485 DECACHE_STACK_INFO();
6486 IllegalExprOperandType(interp, pc, valuePtr);
6487 CACHE_STACK_INFO();
6488 } else {
6489 /*
6490 * Numeric conversion of NaN -> error.
6491 */
6492
6493 TRACE(("\"%.20s\" => IEEE FLOATING PT ERROR\n",
6494 O2S(objResultPtr)));
6495 DECACHE_STACK_INFO();
6496 TclExprFloatError(interp, *((const double *)ptr));
6497 CACHE_STACK_INFO();
6498 }
6499 goto checkForCatch;
6500 }
6501 #endif
6502
6503 /*
6504 * Ensure that the numeric value has a string rep the same as the
6505 * formatted version of its internal rep. This is used, e.g., to make
6506 * sure that "expr {0001}" yields "1", not "0001". We implement this
6507 * by _discarding_ the string rep since we know it will be
6508 * regenerated, if needed later, by formatting the internal rep's
6509 * value.
6510 */
6511
6512 if (valuePtr->bytes == NULL) {
6513 TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr)));
6514 NEXT_INST_F(1, 0, 0);
6515 }
6516 if (Tcl_IsShared(valuePtr)) {
6517 /*
6518 * Here we do some surgery within the Tcl_Obj internals. We want
6519 * to copy the intrep, but not the string, so we temporarily hide
6520 * the string so we do not copy it.
6521 */
6522
6523 char *savedString = valuePtr->bytes;
6524
6525 valuePtr->bytes = NULL;
6526 objResultPtr = Tcl_DuplicateObj(valuePtr);
6527 valuePtr->bytes = savedString;
6528 TRACE(("\"%.20s\" => numeric, new Tcl_Obj\n", O2S(valuePtr)));
6529 NEXT_INST_F(1, 1, 1);
6530 }
6531 TclInvalidateStringRep(valuePtr);
6532 TRACE(("\"%.20s\" => numeric, same Tcl_Obj\n", O2S(valuePtr)));
6533 NEXT_INST_F(1, 0, 0);
6534 }
6535
6536 case INST_BREAK:
6537 /*
6538 DECACHE_STACK_INFO();
6539 Tcl_ResetResult(interp);
6540 CACHE_STACK_INFO();
6541 */
6542 result = TCL_BREAK;
6543 cleanup = 0;
6544 goto processExceptionReturn;
6545
6546 case INST_CONTINUE:
6547 /*
6548 DECACHE_STACK_INFO();
6549 Tcl_ResetResult(interp);
6550 CACHE_STACK_INFO();
6551 */
6552 result = TCL_CONTINUE;
6553 cleanup = 0;
6554 goto processExceptionReturn;
6555
6556 case INST_FOREACH_START4: {
6557 /*
6558 * Initialize the temporary local var that holds the count of the
6559 * number of iterations of the loop body to -1.
6560 */
6561
6562 int opnd, iterTmpIndex;
6563 ForeachInfo *infoPtr;
6564 Var *iterVarPtr;
6565 Tcl_Obj *oldValuePtr;
6566
6567 opnd = TclGetUInt4AtPtr(pc+1);
6568 infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
6569 iterTmpIndex = infoPtr->loopCtTemp;
6570 iterVarPtr = &(compiledLocals[iterTmpIndex]);
6571 oldValuePtr = iterVarPtr->value.objPtr;
6572
6573 if (oldValuePtr == NULL) {
6574 TclNewLongObj(iterVarPtr->value.objPtr, -1);
6575 Tcl_IncrRefCount(iterVarPtr->value.objPtr);
6576 } else {
6577 TclSetLongObj(oldValuePtr, -1);
6578 }
6579 TRACE(("%u => loop iter count temp %d\n", opnd, iterTmpIndex));
6580
6581 #ifndef TCL_COMPILE_DEBUG
6582 /*
6583 * Remark that the compiler ALWAYS sets INST_FOREACH_STEP4 immediately
6584 * after INST_FOREACH_START4 - let us just fall through instead of
6585 * jumping back to the top.
6586 */
6587
6588 pc += 5;
6589 TCL_DTRACE_INST_NEXT();
6590 #else
6591 NEXT_INST_F(5, 0, 0);
6592 #endif
6593 }
6594
6595 case INST_FOREACH_STEP4: {
6596 /*
6597 * "Step" a foreach loop (i.e., begin its next iteration) by assigning
6598 * the next value list element to each loop var.
6599 */
6600
6601 ForeachInfo *infoPtr;
6602 ForeachVarList *varListPtr;
6603 Tcl_Obj *listPtr,*valuePtr, *value2Ptr, **elements;
6604 Var *iterVarPtr, *listVarPtr, *varPtr;
6605 int opnd, numLists, iterNum, listTmpIndex, listLen, numVars;
6606 int varIndex, valIndex, continueLoop, j;
6607 long i;
6608
6609 opnd = TclGetUInt4AtPtr(pc+1);
6610 infoPtr = (ForeachInfo *) codePtr->auxDataArrayPtr[opnd].clientData;
6611 numLists = infoPtr->numLists;
6612
6613 /*
6614 * Increment the temp holding the loop iteration number.
6615 */
6616
6617 iterVarPtr = &(compiledLocals[infoPtr->loopCtTemp]);
6618 valuePtr = iterVarPtr->value.objPtr;
6619 iterNum = (valuePtr->internalRep.longValue + 1);
6620 TclSetLongObj(valuePtr, iterNum);
6621
6622 /*
6623 * Check whether all value lists are exhausted and we should stop the
6624 * loop.
6625 */
6626
6627 continueLoop = 0;
6628 listTmpIndex = infoPtr->firstValueTemp;
6629 for (i = 0; i < numLists; i++) {
6630 varListPtr = infoPtr->varLists[i];
6631 numVars = varListPtr->numVars;
6632
6633 listVarPtr = &(compiledLocals[listTmpIndex]);
6634 listPtr = listVarPtr->value.objPtr;
6635 result = TclListObjLength(interp, listPtr, &listLen);
6636 if (result == TCL_OK) {
6637 if (listLen > (iterNum * numVars)) {
6638 continueLoop = 1;
6639 }
6640 listTmpIndex++;
6641 } else {
6642 TRACE_WITH_OBJ(("%u => ERROR converting list %ld, \"%s\": ",
6643 opnd, i, O2S(listPtr)), Tcl_GetObjResult(interp));
6644 goto checkForCatch;
6645 }
6646 }
6647
6648 /*
6649 * If some var in some var list still has a remaining list element
6650 * iterate one more time. Assign to var the next element from its
6651 * value list. We already checked above that each list temp holds a
6652 * valid list object (by calling Tcl_ListObjLength), but cannot rely
6653 * on that check remaining valid: one list could have been shimmered
6654 * as a side effect of setting a traced variable.
6655 */
6656
6657 if (continueLoop) {
6658 listTmpIndex = infoPtr->firstValueTemp;
6659 for (i = 0; i < numLists; i++) {
6660 varListPtr = infoPtr->varLists[i];
6661 numVars = varListPtr->numVars;
6662
6663 listVarPtr = &(compiledLocals[listTmpIndex]);
6664 listPtr = TclListObjCopy(NULL, listVarPtr->value.objPtr);
6665 TclListObjGetElements(interp, listPtr, &listLen, &elements);
6666
6667 valIndex = (iterNum * numVars);
6668 for (j = 0; j < numVars; j++) {
6669 if (valIndex >= listLen) {
6670 TclNewObj(valuePtr);
6671 } else {
6672 valuePtr = elements[valIndex];
6673 }
6674
6675 varIndex = varListPtr->varIndexes[j];
6676 varPtr = &(compiledLocals[varIndex]);
6677 while (TclIsVarLink(varPtr)) {
6678 varPtr = varPtr->value.linkPtr;
6679 }
6680 if (TclIsVarDirectWritable(varPtr)) {
6681 value2Ptr = varPtr->value.objPtr;
6682 if (valuePtr != value2Ptr) {
6683 if (value2Ptr != NULL) {
6684 TclDecrRefCount(value2Ptr);
6685 }
6686 varPtr->value.objPtr = valuePtr;
6687 Tcl_IncrRefCount(valuePtr);
6688 }
6689 } else {
6690 DECACHE_STACK_INFO();
6691 value2Ptr = TclPtrSetVar(interp, varPtr, NULL, NULL,
6692 NULL, valuePtr, TCL_LEAVE_ERR_MSG, varIndex);
6693 CACHE_STACK_INFO();
6694 if (value2Ptr == NULL) {
6695 TRACE_WITH_OBJ((
6696 "%u => ERROR init. index temp %d: ",
6697 opnd,varIndex), Tcl_GetObjResult(interp));
6698 result = TCL_ERROR;
6699 TclDecrRefCount(listPtr);
6700 goto checkForCatch;
6701 }
6702 }
6703 valIndex++;
6704 }
6705 TclDecrRefCount(listPtr);
6706 listTmpIndex++;
6707 }
6708 }
6709 TRACE(("%u => %d lists, iter %d, %s loop\n", opnd, numLists,
6710 iterNum, (continueLoop? "continue" : "exit")));
6711
6712 /*
6713 * Run-time peep-hole optimisation: the compiler ALWAYS follows
6714 * INST_FOREACH_STEP4 with an INST_JUMP_FALSE. We just skip that
6715 * instruction and jump direct from here.
6716 */
6717
6718 pc += 5;
6719 if (*pc == INST_JUMP_FALSE1) {
6720 NEXT_INST_F((continueLoop? 2 : TclGetInt1AtPtr(pc+1)), 0, 0);
6721 } else {
6722 NEXT_INST_F((continueLoop? 5 : TclGetInt4AtPtr(pc+1)), 0, 0);
6723 }
6724 }
6725
6726 case INST_BEGIN_CATCH4:
6727 /*
6728 * Record start of the catch command with exception range index equal
6729 * to the operand. Push the current stack depth onto the special catch
6730 * stack.
6731 */
6732
6733 *(++catchTop) = CURR_DEPTH;
6734 TRACE(("%u => catchTop=%d, stackTop=%d\n",
6735 TclGetUInt4AtPtr(pc+1), (int) (catchTop - initCatchTop - 1),
6736 (int) CURR_DEPTH));
6737 NEXT_INST_F(5, 0, 0);
6738
6739 case INST_END_CATCH:
6740 catchTop--;
6741 DECACHE_STACK_INFO();
6742 Tcl_ResetResult(interp);
6743 CACHE_STACK_INFO();
6744 result = TCL_OK;
6745 TRACE(("=> catchTop=%d\n", (int) (catchTop - initCatchTop - 1)));
6746 NEXT_INST_F(1, 0, 0);
6747
6748 case INST_PUSH_RESULT:
6749 objResultPtr = Tcl_GetObjResult(interp);
6750 TRACE_WITH_OBJ(("=> "), objResultPtr);
6751
6752 /*
6753 * See the comments at INST_INVOKE_STK
6754 */
6755 {
6756 Tcl_Obj *newObjResultPtr;
6757
6758 TclNewObj(newObjResultPtr);
6759 Tcl_IncrRefCount(newObjResultPtr);
6760 iPtr->objResultPtr = newObjResultPtr;
6761 }
6762
6763 NEXT_INST_F(1, 0, -1);
6764
6765 case INST_PUSH_RETURN_CODE:
6766 TclNewIntObj(objResultPtr, result);
6767 TRACE(("=> %u\n", result));
6768 NEXT_INST_F(1, 0, 1);
6769
6770 case INST_PUSH_RETURN_OPTIONS:
6771 objResultPtr = Tcl_GetReturnOptions(interp, result);
6772 TRACE_WITH_OBJ(("=> "), objResultPtr);
6773 NEXT_INST_F(1, 0, 1);
6774
6775 /* TODO: normalize "valPtr" to "valuePtr" */
6776 {
6777 int opnd, opnd2, allocateDict;
6778 Tcl_Obj *dictPtr, *valPtr;
6779 Var *varPtr;
6780
6781 case INST_DICT_GET:
6782 opnd = TclGetUInt4AtPtr(pc+1);
6783 TRACE(("%u => ", opnd));
6784 dictPtr = OBJ_AT_DEPTH(opnd);
6785 if (opnd > 1) {
6786 dictPtr = TclTraceDictPath(interp, dictPtr, opnd-1,
6787 &OBJ_AT_DEPTH(opnd-1), DICT_PATH_READ);
6788 if (dictPtr == NULL) {
6789 TRACE_WITH_OBJ((
6790 "%u => ERROR tracing dictionary path into \"%s\": ",
6791 opnd, O2S(OBJ_AT_DEPTH(opnd))),
6792 Tcl_GetObjResult(interp));
6793 result = TCL_ERROR;
6794 goto checkForCatch;
6795 }
6796 }
6797 result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &objResultPtr);
6798 if ((result == TCL_OK) && objResultPtr) {
6799 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
6800 NEXT_INST_V(5, opnd+1, 1);
6801 }
6802 if (result != TCL_OK) {
6803 TRACE_WITH_OBJ((
6804 "%u => ERROR reading leaf dictionary key \"%s\": ",
6805 opnd, O2S(dictPtr)), Tcl_GetObjResult(interp));
6806 } else {
6807 DECACHE_STACK_INFO();
6808 Tcl_ResetResult(interp);
6809 Tcl_AppendResult(interp, "key \"", TclGetString(OBJ_AT_TOS),
6810 "\" not known in dictionary", NULL);
6811 CACHE_STACK_INFO();
6812 TRACE_WITH_OBJ(("%u => ERROR ", opnd), Tcl_GetObjResult(interp));
6813 result = TCL_ERROR;
6814 }
6815 goto checkForCatch;
6816
6817 case INST_DICT_SET:
6818 case INST_DICT_UNSET:
6819 case INST_DICT_INCR_IMM:
6820 opnd = TclGetUInt4AtPtr(pc+1);
6821 opnd2 = TclGetUInt4AtPtr(pc+5);
6822
6823 varPtr = &(compiledLocals[opnd2]);
6824 while (TclIsVarLink(varPtr)) {
6825 varPtr = varPtr->value.linkPtr;
6826 }
6827 TRACE(("%u %u => ", opnd, opnd2));
6828 if (TclIsVarDirectReadable(varPtr)) {
6829 dictPtr = varPtr->value.objPtr;
6830 } else {
6831 DECACHE_STACK_INFO();
6832 dictPtr = TclPtrGetVar(interp, varPtr, NULL,NULL,NULL, 0, opnd2);
6833 CACHE_STACK_INFO();
6834 }
6835 if (dictPtr == NULL) {
6836 TclNewObj(dictPtr);
6837 allocateDict = 1;
6838 } else {
6839 allocateDict = Tcl_IsShared(dictPtr);
6840 if (allocateDict) {
6841 dictPtr = Tcl_DuplicateObj(dictPtr);
6842 }
6843 }
6844
6845 switch (*pc) {
6846 case INST_DICT_SET:
6847 cleanup = opnd + 1;
6848 result = Tcl_DictObjPutKeyList(interp, dictPtr, opnd,
6849 &OBJ_AT_DEPTH(opnd), OBJ_AT_TOS);
6850 break;
6851 case INST_DICT_INCR_IMM:
6852 cleanup = 1;
6853 opnd = TclGetInt4AtPtr(pc+1);
6854 result = Tcl_DictObjGet(interp, dictPtr, OBJ_AT_TOS, &valPtr);
6855 if (result != TCL_OK) {
6856 break;
6857 }
6858 if (valPtr == NULL) {
6859 Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS,Tcl_NewIntObj(opnd));
6860 } else {
6861 Tcl_Obj *incrPtr = Tcl_NewIntObj(opnd);
6862
6863 Tcl_IncrRefCount(incrPtr);
6864 if (Tcl_IsShared(valPtr)) {
6865 valPtr = Tcl_DuplicateObj(valPtr);
6866 Tcl_DictObjPut(NULL, dictPtr, OBJ_AT_TOS, valPtr);
6867 }
6868 result = TclIncrObj(interp, valPtr, incrPtr);
6869 if (result == TCL_OK) {
6870 TclInvalidateStringRep(dictPtr);
6871 }
6872 TclDecrRefCount(incrPtr);
6873 }
6874 break;
6875 case INST_DICT_UNSET:
6876 cleanup = opnd;
6877 result = Tcl_DictObjRemoveKeyList(interp, dictPtr, opnd,
6878 &OBJ_AT_DEPTH(opnd-1));
6879 break;
6880 default:
6881 cleanup = 0; /* stop compiler warning */
6882 Tcl_Panic("Should not happen!");
6883 }
6884
6885 if (result != TCL_OK) {
6886 if (allocateDict) {
6887 TclDecrRefCount(dictPtr);
6888 }
6889 TRACE_WITH_OBJ(("%u %u => ERROR updating dictionary: ",
6890 opnd, opnd2), Tcl_GetObjResult(interp));
6891 goto checkForCatch;
6892 }
6893
6894 if (TclIsVarDirectWritable(varPtr)) {
6895 if (allocateDict) {
6896 Tcl_Obj *oldValuePtr = varPtr->value.objPtr;
6897
6898 Tcl_IncrRefCount(dictPtr);
6899 if (oldValuePtr != NULL) {
6900 TclDecrRefCount(oldValuePtr);
6901 }
6902 varPtr->value.objPtr = dictPtr;
6903 }
6904 objResultPtr = dictPtr;
6905 } else {
6906 Tcl_IncrRefCount(dictPtr);
6907 DECACHE_STACK_INFO();
6908 objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
6909 dictPtr, TCL_LEAVE_ERR_MSG, opnd2);
6910 CACHE_STACK_INFO();
6911 TclDecrRefCount(dictPtr);
6912 if (objResultPtr == NULL) {
6913 TRACE_APPEND(("ERROR: %.30s\n",
6914 O2S(Tcl_GetObjResult(interp))));
6915 result = TCL_ERROR;
6916 goto checkForCatch;
6917 }
6918 }
6919 #ifndef TCL_COMPILE_DEBUG
6920 if (*(pc+9) == INST_POP) {
6921 NEXT_INST_V(10, cleanup, 0);
6922 }
6923 #endif
6924 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
6925 NEXT_INST_V(9, cleanup, 1);
6926
6927 case INST_DICT_APPEND:
6928 case INST_DICT_LAPPEND:
6929 opnd = TclGetUInt4AtPtr(pc+1);
6930
6931 varPtr = &(compiledLocals[opnd]);
6932 while (TclIsVarLink(varPtr)) {
6933 varPtr = varPtr->value.linkPtr;
6934 }
6935 TRACE(("%u => ", opnd));
6936 if (TclIsVarDirectReadable(varPtr)) {
6937 dictPtr = varPtr->value.objPtr;
6938 } else {
6939 DECACHE_STACK_INFO();
6940 dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
6941 CACHE_STACK_INFO();
6942 }
6943 if (dictPtr == NULL) {
6944 TclNewObj(dictPtr);
6945 allocateDict = 1;
6946 } else {
6947 allocateDict = Tcl_IsShared(dictPtr);
6948 if (allocateDict) {
6949 dictPtr = Tcl_DuplicateObj(dictPtr);
6950 }
6951 }
6952
6953 result = Tcl_DictObjGet(interp, dictPtr, OBJ_UNDER_TOS, &valPtr);
6954 if (result != TCL_OK) {
6955 if (allocateDict) {
6956 TclDecrRefCount(dictPtr);
6957 }
6958 goto checkForCatch;
6959 }
6960
6961 /*
6962 * Note that a non-existent key results in a NULL valPtr, which is a
6963 * case handled separately below. What we *can* say at this point is
6964 * that the write-back will always succeed.
6965 */
6966
6967 switch (*pc) {
6968 case INST_DICT_APPEND:
6969 if (valPtr == NULL) {
6970 valPtr = OBJ_AT_TOS;
6971 } else {
6972 if (Tcl_IsShared(valPtr)) {
6973 valPtr = Tcl_DuplicateObj(valPtr);
6974 }
6975 Tcl_AppendObjToObj(valPtr, OBJ_AT_TOS);
6976 }
6977 break;
6978 case INST_DICT_LAPPEND:
6979 /*
6980 * More complex because list-append can fail.
6981 */
6982
6983 if (valPtr == NULL) {
6984 valPtr = Tcl_NewListObj(1, &OBJ_AT_TOS);
6985 } else if (Tcl_IsShared(valPtr)) {
6986 valPtr = Tcl_DuplicateObj(valPtr);
6987 result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS);
6988 if (result != TCL_OK) {
6989 TclDecrRefCount(valPtr);
6990 if (allocateDict) {
6991 TclDecrRefCount(dictPtr);
6992 }
6993 goto checkForCatch;
6994 }
6995 } else {
6996 result = Tcl_ListObjAppendElement(interp, valPtr, OBJ_AT_TOS);
6997 if (result != TCL_OK) {
6998 if (allocateDict) {
6999 TclDecrRefCount(dictPtr);
7000 }
7001 goto checkForCatch;
7002 }
7003 }
7004 break;
7005 default:
7006 Tcl_Panic("Should not happen!");
7007 }
7008
7009 Tcl_DictObjPut(NULL, dictPtr, OBJ_UNDER_TOS, valPtr);
7010
7011 if (TclIsVarDirectWritable(varPtr)) {
7012 if (allocateDict) {
7013 Tcl_Obj *oldValuePtr = varPtr->value.objPtr;
7014
7015 Tcl_IncrRefCount(dictPtr);
7016 if (oldValuePtr != NULL) {
7017 TclDecrRefCount(oldValuePtr);
7018 }
7019 varPtr->value.objPtr = dictPtr;
7020 }
7021 objResultPtr = dictPtr;
7022 } else {
7023 Tcl_IncrRefCount(dictPtr);
7024 DECACHE_STACK_INFO();
7025 objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
7026 dictPtr, TCL_LEAVE_ERR_MSG, opnd);
7027 CACHE_STACK_INFO();
7028 TclDecrRefCount(dictPtr);
7029 if (objResultPtr == NULL) {
7030 TRACE_APPEND(("ERROR: %.30s\n",
7031 O2S(Tcl_GetObjResult(interp))));
7032 result = TCL_ERROR;
7033 goto checkForCatch;
7034 }
7035 }
7036 #ifndef TCL_COMPILE_DEBUG
7037 if (*(pc+5) == INST_POP) {
7038 NEXT_INST_F(6, 2, 0);
7039 }
7040 #endif
7041 TRACE_APPEND(("%.30s\n", O2S(objResultPtr)));
7042 NEXT_INST_F(5, 2, 1);
7043 }
7044
7045 {
7046 int opnd, done;
7047 Tcl_Obj *statePtr, *dictPtr, *keyPtr, *valuePtr, *emptyPtr;
7048 Var *varPtr;
7049 Tcl_DictSearch *searchPtr;
7050
7051 case INST_DICT_FIRST:
7052 opnd = TclGetUInt4AtPtr(pc+1);
7053 TRACE(("%u => ", opnd));
7054 dictPtr = POP_OBJECT();
7055 searchPtr = (Tcl_DictSearch *) ckalloc(sizeof(Tcl_DictSearch));
7056 result = Tcl_DictObjFirst(interp, dictPtr, searchPtr, &keyPtr,
7057 &valuePtr, &done);
7058 if (result != TCL_OK) {
7059 ckfree((char *) searchPtr);
7060 goto checkForCatch;
7061 }
7062 TclNewObj(statePtr);
7063 statePtr->typePtr = &dictIteratorType;
7064 statePtr->internalRep.twoPtrValue.ptr1 = (void *) searchPtr;
7065 statePtr->internalRep.twoPtrValue.ptr2 = (void *) dictPtr;
7066 varPtr = (compiledLocals + opnd);
7067 if (varPtr->value.objPtr) {
7068 if (varPtr->value.objPtr->typePtr != &dictIteratorType) {
7069 TclDecrRefCount(varPtr->value.objPtr);
7070 } else {
7071 Tcl_Panic("mis-issued dictFirst!");
7072 }
7073 }
7074 varPtr->value.objPtr = statePtr;
7075 Tcl_IncrRefCount(statePtr);
7076 goto pushDictIteratorResult;
7077
7078 case INST_DICT_NEXT:
7079 opnd = TclGetUInt4AtPtr(pc+1);
7080 TRACE(("%u => ", opnd));
7081 statePtr = compiledLocals[opnd].value.objPtr;
7082 if (statePtr == NULL || statePtr->typePtr != &dictIteratorType) {
7083 Tcl_Panic("mis-issued dictNext!");
7084 }
7085 searchPtr = (Tcl_DictSearch *) statePtr->internalRep.twoPtrValue.ptr1;
7086 Tcl_DictObjNext(searchPtr, &keyPtr, &valuePtr, &done);
7087 pushDictIteratorResult:
7088 if (done) {
7089 TclNewObj(emptyPtr);
7090 PUSH_OBJECT(emptyPtr);
7091 PUSH_OBJECT(emptyPtr);
7092 } else {
7093 PUSH_OBJECT(valuePtr);
7094 PUSH_OBJECT(keyPtr);
7095 }
7096 TRACE_APPEND(("\"%.30s\" \"%.30s\" %d",
7097 O2S(OBJ_UNDER_TOS), O2S(OBJ_AT_TOS), done));
7098 objResultPtr = constants[done];
7099 /* TODO: consider opt like INST_FOREACH_STEP4 */
7100 NEXT_INST_F(5, 0, 1);
7101
7102 case INST_DICT_DONE:
7103 opnd = TclGetUInt4AtPtr(pc+1);
7104 TRACE(("%u => ", opnd));
7105 statePtr = compiledLocals[opnd].value.objPtr;
7106 if (statePtr == NULL) {
7107 Tcl_Panic("mis-issued dictDone!");
7108 }
7109
7110 if (statePtr->typePtr == &dictIteratorType) {
7111 /*
7112 * First kill the search, and then release the reference to the
7113 * dictionary that we were holding.
7114 */
7115
7116 searchPtr = (Tcl_DictSearch *)
7117 statePtr->internalRep.twoPtrValue.ptr1;
7118 Tcl_DictObjDone(searchPtr);
7119 ckfree((char *) searchPtr);
7120
7121 dictPtr = (Tcl_Obj *) statePtr->internalRep.twoPtrValue.ptr2;
7122 TclDecrRefCount(dictPtr);
7123
7124 /*
7125 * Set the internal variable to an empty object to signify that we
7126 * don't hold an iterator.
7127 */
7128
7129 TclDecrRefCount(statePtr);
7130 TclNewObj(emptyPtr);
7131 compiledLocals[opnd].value.objPtr = emptyPtr;
7132 Tcl_IncrRefCount(emptyPtr);
7133 }
7134 NEXT_INST_F(5, 0, 0);
7135 }
7136
7137 {
7138 int opnd, opnd2, i, length, allocdict;
7139 Tcl_Obj **keyPtrPtr, *dictPtr;
7140 DictUpdateInfo *duiPtr;
7141 Var *varPtr;
7142
7143 case INST_DICT_UPDATE_START:
7144 opnd = TclGetUInt4AtPtr(pc+1);
7145 opnd2 = TclGetUInt4AtPtr(pc+5);
7146 varPtr = &(compiledLocals[opnd]);
7147 duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
7148 while (TclIsVarLink(varPtr)) {
7149 varPtr = varPtr->value.linkPtr;
7150 }
7151 TRACE(("%u => ", opnd));
7152 if (TclIsVarDirectReadable(varPtr)) {
7153 dictPtr = varPtr->value.objPtr;
7154 } else {
7155 DECACHE_STACK_INFO();
7156 dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL,
7157 TCL_LEAVE_ERR_MSG, opnd);
7158 CACHE_STACK_INFO();
7159 if (dictPtr == NULL) {
7160 goto dictUpdateStartFailed;
7161 }
7162 }
7163 if (TclListObjGetElements(interp, OBJ_AT_TOS, &length,
7164 &keyPtrPtr) != TCL_OK) {
7165 goto dictUpdateStartFailed;
7166 }
7167 if (length != duiPtr->length) {
7168 Tcl_Panic("dictUpdateStart argument length mismatch");
7169 }
7170 for (i=0 ; i<length ; i++) {
7171 Tcl_Obj *valPtr;
7172
7173 if (Tcl_DictObjGet(interp, dictPtr, keyPtrPtr[i],
7174 &valPtr) != TCL_OK) {
7175 goto dictUpdateStartFailed;
7176 }
7177 varPtr = &(compiledLocals[duiPtr->varIndices[i]]);
7178 while (TclIsVarLink(varPtr)) {
7179 varPtr = varPtr->value.linkPtr;
7180 }
7181 DECACHE_STACK_INFO();
7182 if (valPtr == NULL) {
7183 TclObjUnsetVar2(interp,
7184 localName(iPtr->varFramePtr, duiPtr->varIndices[i]),
7185 NULL, 0);
7186 } else if (TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
7187 valPtr, TCL_LEAVE_ERR_MSG,
7188 duiPtr->varIndices[i]) == NULL) {
7189 CACHE_STACK_INFO();
7190 dictUpdateStartFailed:
7191 result = TCL_ERROR;
7192 goto checkForCatch;
7193 }
7194 CACHE_STACK_INFO();
7195 }
7196 NEXT_INST_F(9, 0, 0);
7197
7198 case INST_DICT_UPDATE_END:
7199 opnd = TclGetUInt4AtPtr(pc+1);
7200 opnd2 = TclGetUInt4AtPtr(pc+5);
7201 varPtr = &(compiledLocals[opnd]);
7202 duiPtr = codePtr->auxDataArrayPtr[opnd2].clientData;
7203 while (TclIsVarLink(varPtr)) {
7204 varPtr = varPtr->value.linkPtr;
7205 }
7206 TRACE(("%u => ", opnd));
7207 if (TclIsVarDirectReadable(varPtr)) {
7208 dictPtr = varPtr->value.objPtr;
7209 } else {
7210 DECACHE_STACK_INFO();
7211 dictPtr = TclPtrGetVar(interp, varPtr, NULL, NULL, NULL, 0, opnd);
7212 CACHE_STACK_INFO();
7213 }
7214 if (dictPtr == NULL) {
7215 NEXT_INST_F(9, 1, 0);
7216 }
7217 if (Tcl_DictObjSize(interp, dictPtr, &length) != TCL_OK
7218 || TclListObjGetElements(interp, OBJ_AT_TOS, &length,
7219 &keyPtrPtr) != TCL_OK) {
7220 result = TCL_ERROR;
7221 goto checkForCatch;
7222 }
7223 allocdict = Tcl_IsShared(dictPtr);
7224 if (allocdict) {
7225 dictPtr = Tcl_DuplicateObj(dictPtr);
7226 }
7227 for (i=0 ; i<length ; i++) {
7228 Tcl_Obj *valPtr;
7229 Var *var2Ptr;
7230
7231 var2Ptr = &(compiledLocals[duiPtr->varIndices[i]]);
7232 while (TclIsVarLink(var2Ptr)) {
7233 var2Ptr = var2Ptr->value.linkPtr;
7234 }
7235 if (TclIsVarDirectReadable(var2Ptr)) {
7236 valPtr = var2Ptr->value.objPtr;
7237 } else {
7238 DECACHE_STACK_INFO();
7239 valPtr = TclPtrGetVar(interp, var2Ptr, NULL, NULL, NULL, 0,
7240 duiPtr->varIndices[i]);
7241 CACHE_STACK_INFO();
7242 }
7243 if (valPtr == NULL) {
7244 Tcl_DictObjRemove(interp, dictPtr, keyPtrPtr[i]);
7245 } else if (dictPtr == valPtr) {
7246 Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i],
7247 Tcl_DuplicateObj(valPtr));
7248 } else {
7249 Tcl_DictObjPut(interp, dictPtr, keyPtrPtr[i], valPtr);
7250 }
7251 }
7252 if (TclIsVarDirectWritable(varPtr)) {
7253 Tcl_IncrRefCount(dictPtr);
7254 TclDecrRefCount(varPtr->value.objPtr);
7255 varPtr->value.objPtr = dictPtr;
7256 } else {
7257 DECACHE_STACK_INFO();
7258 objResultPtr = TclPtrSetVar(interp, varPtr, NULL, NULL, NULL,
7259 dictPtr, TCL_LEAVE_ERR_MSG, opnd);
7260 CACHE_STACK_INFO();
7261 if (objResultPtr == NULL) {
7262 if (allocdict) {
7263 TclDecrRefCount(dictPtr);
7264 }
7265 result = TCL_ERROR;
7266 goto checkForCatch;
7267 }
7268 }
7269 NEXT_INST_F(9, 1, 0);
7270 }
7271
7272 default:
7273 Tcl_Panic("TclExecuteByteCode: unrecognized opCode %u", *pc);
7274 } /* end of switch on opCode */
7275
7276 /*
7277 * Division by zero in an expression. Control only reaches this point by
7278 * "goto divideByZero".
7279 */
7280
7281 divideByZero:
7282 DECACHE_STACK_INFO();
7283 Tcl_SetObjResult(interp, Tcl_NewStringObj("divide by zero", -1));
7284 Tcl_SetErrorCode(interp, "ARITH", "DIVZERO", "divide by zero", NULL);
7285 CACHE_STACK_INFO();
7286
7287 result = TCL_ERROR;
7288 goto checkForCatch;
7289
7290 /*
7291 * Exponentiation of zero by negative number in an expression. Control
7292 * only reaches this point by "goto exponOfZero".
7293 */
7294
7295 exponOfZero:
7296 DECACHE_STACK_INFO();
7297 Tcl_SetObjResult(interp, Tcl_NewStringObj(
7298 "exponentiation of zero by negative power", -1));
7299 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN",
7300 "exponentiation of zero by negative power", NULL);
7301 CACHE_STACK_INFO();
7302 result = TCL_ERROR;
7303 goto checkForCatch;
7304
7305 /*
7306 * Block for variables needed to process exception returns.
7307 */
7308
7309 {
7310 ExceptionRange *rangePtr;
7311 /* Points to closest loop or catch exception
7312 * range enclosing the pc. Used by various
7313 * instructions and processCatch to process
7314 * break, continue, and errors. */
7315 Tcl_Obj *valuePtr;
7316 const char *bytes;
7317 int length;
7318 #if TCL_COMPILE_DEBUG
7319 int opnd;
7320 #endif
7321
7322 /*
7323 * An external evaluation (INST_INVOKE or INST_EVAL) returned
7324 * something different from TCL_OK, or else INST_BREAK or
7325 * INST_CONTINUE were called.
7326 */
7327
7328 processExceptionReturn:
7329 #if TCL_COMPILE_DEBUG
7330 switch (*pc) {
7331 case INST_INVOKE_STK1:
7332 opnd = TclGetUInt1AtPtr(pc+1);
7333 TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
7334 break;
7335 case INST_INVOKE_STK4:
7336 opnd = TclGetUInt4AtPtr(pc+1);
7337 TRACE(("%u => ... after \"%.20s\": ", opnd, cmdNameBuf));
7338 break;
7339 case INST_EVAL_STK:
7340 /*
7341 * Note that the object at stacktop has to be used before doing
7342 * the cleanup.
7343 */
7344
7345 TRACE(("\"%.30s\" => ", O2S(OBJ_AT_TOS)));
7346 break;
7347 default:
7348 TRACE(("=> "));
7349 }
7350 #endif
7351 if ((result == TCL_CONTINUE) || (result == TCL_BREAK)) {
7352 rangePtr = GetExceptRangeForPc(pc, result, codePtr);
7353 if (rangePtr == NULL) {
7354 TRACE_APPEND(("no encl. loop or catch, returning %s\n",
7355 StringForResultCode(result)));
7356 goto abnormalReturn;
7357 }
7358 if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
7359 TRACE_APPEND(("%s ...\n", StringForResultCode(result)));
7360 goto processCatch;
7361 }
7362 while (cleanup--) {
7363 valuePtr = POP_OBJECT();
7364 TclDecrRefCount(valuePtr);
7365 }
7366 if (result == TCL_BREAK) {
7367 result = TCL_OK;
7368 pc = (codePtr->codeStart + rangePtr->breakOffset);
7369 TRACE_APPEND(("%s, range at %d, new pc %d\n",
7370 StringForResultCode(result),
7371 rangePtr->codeOffset, rangePtr->breakOffset));
7372 NEXT_INST_F(0, 0, 0);
7373 } else {
7374 if (rangePtr->continueOffset == -1) {
7375 TRACE_APPEND((
7376 "%s, loop w/o continue, checking for catch\n",
7377 StringForResultCode(result)));
7378 goto checkForCatch;
7379 }
7380 result = TCL_OK;
7381 pc = (codePtr->codeStart + rangePtr->continueOffset);
7382 TRACE_APPEND(("%s, range at %d, new pc %d\n",
7383 StringForResultCode(result),
7384 rangePtr->codeOffset, rangePtr->continueOffset));
7385 NEXT_INST_F(0, 0, 0);
7386 }
7387 #if TCL_COMPILE_DEBUG
7388 } else if (traceInstructions) {
7389 if ((result != TCL_ERROR) && (result != TCL_RETURN)) {
7390 Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
7391 TRACE_APPEND(("OTHER RETURN CODE %d, result= \"%s\"\n ",
7392 result, O2S(objPtr)));
7393 } else {
7394 Tcl_Obj *objPtr = Tcl_GetObjResult(interp);
7395 TRACE_APPEND(("%s, result= \"%s\"\n",
7396 StringForResultCode(result), O2S(objPtr)));
7397 }
7398 #endif
7399 }
7400
7401 /*
7402 * Execution has generated an "exception" such as TCL_ERROR. If the
7403 * exception is an error, record information about what was being
7404 * executed when the error occurred. Find the closest enclosing catch
7405 * range, if any. If no enclosing catch range is found, stop execution
7406 * and return the "exception" code.
7407 */
7408
7409 checkForCatch:
7410 if ((result == TCL_ERROR) && !(iPtr->flags & ERR_ALREADY_LOGGED)) {
7411 bytes = GetSrcInfoForPc(pc, codePtr, &length);
7412 if (bytes != NULL) {
7413 DECACHE_STACK_INFO();
7414 Tcl_LogCommandInfo(interp, codePtr->source, bytes, length);
7415 CACHE_STACK_INFO();
7416 }
7417 }
7418 iPtr->flags &= ~ERR_ALREADY_LOGGED;
7419
7420 /*
7421 * Clear all expansions that may have started after the last
7422 * INST_BEGIN_CATCH.
7423 */
7424
7425 while ((expandNestList != NULL) && ((catchTop == initCatchTop) ||
7426 (*catchTop <=
7427 (ptrdiff_t) expandNestList->internalRep.twoPtrValue.ptr1))) {
7428 Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
7429
7430 TclDecrRefCount(expandNestList);
7431 expandNestList = objPtr;
7432 }
7433
7434 /*
7435 * We must not catch an exceeded limit. Instead, it blows outwards
7436 * until we either hit another interpreter (presumably where the limit
7437 * is not exceeded) or we get to the top-level.
7438 */
7439
7440 if (TclLimitExceeded(iPtr->limit)) {
7441 #ifdef TCL_COMPILE_DEBUG
7442 if (traceInstructions) {
7443 fprintf(stdout, " ... limit exceeded, returning %s\n",
7444 StringForResultCode(result));
7445 }
7446 #endif
7447 goto abnormalReturn;
7448 }
7449 if (catchTop == initCatchTop) {
7450 #ifdef TCL_COMPILE_DEBUG
7451 if (traceInstructions) {
7452 fprintf(stdout, " ... no enclosing catch, returning %s\n",
7453 StringForResultCode(result));
7454 }
7455 #endif
7456 goto abnormalReturn;
7457 }
7458 rangePtr = GetExceptRangeForPc(pc, TCL_ERROR, codePtr);
7459 if (rangePtr == NULL) {
7460 /*
7461 * This is only possible when compiling a [catch] that sends its
7462 * script to INST_EVAL. Cannot correct the compiler without
7463 * breakingcompat with previous .tbc compiled scripts.
7464 */
7465
7466 #ifdef TCL_COMPILE_DEBUG
7467 if (traceInstructions) {
7468 fprintf(stdout, " ... no enclosing catch, returning %s\n",
7469 StringForResultCode(result));
7470 }
7471 #endif
7472 goto abnormalReturn;
7473 }
7474
7475 /*
7476 * A catch exception range (rangePtr) was found to handle an
7477 * "exception". It was found either by checkForCatch just above or by
7478 * an instruction during break, continue, or error processing. Jump to
7479 * its catchOffset after unwinding the operand stack to the depth it
7480 * had when starting to execute the range's catch command.
7481 */
7482
7483 processCatch:
7484 while (CURR_DEPTH > *catchTop) {
7485 valuePtr = POP_OBJECT();
7486 TclDecrRefCount(valuePtr);
7487 }
7488 #ifdef TCL_COMPILE_DEBUG
7489 if (traceInstructions) {
7490 fprintf(stdout, " ... found catch at %d, catchTop=%d, "
7491 "unwound to %ld, new pc %u\n",
7492 rangePtr->codeOffset, (int) (catchTop - initCatchTop - 1),
7493 (long) *catchTop, (unsigned) rangePtr->catchOffset);
7494 }
7495 #endif
7496 pc = (codePtr->codeStart + rangePtr->catchOffset);
7497 NEXT_INST_F(0, 0, 0); /* Restart the execution loop at pc. */
7498
7499 /*
7500 * end of infinite loop dispatching on instructions.
7501 */
7502
7503 /*
7504 * Abnormal return code. Restore the stack to state it had when
7505 * starting to execute the ByteCode. Panic if the stack is below the
7506 * initial level.
7507 */
7508
7509 abnormalReturn:
7510 TCL_DTRACE_INST_LAST();
7511 while (tosPtr > initTosPtr) {
7512 Tcl_Obj *objPtr = POP_OBJECT();
7513
7514 Tcl_DecrRefCount(objPtr);
7515 }
7516
7517 /*
7518 * Clear all expansions.
7519 */
7520
7521 while (expandNestList) {
7522 Tcl_Obj *objPtr = expandNestList->internalRep.twoPtrValue.ptr2;
7523
7524 TclDecrRefCount(expandNestList);
7525 expandNestList = objPtr;
7526 }
7527 if (tosPtr < initTosPtr) {
7528 fprintf(stderr,
7529 "\nTclExecuteByteCode: abnormal return at pc %u: "
7530 "stack top %d < entry stack top %d\n",
7531 (unsigned)(pc - codePtr->codeStart),
7532 (unsigned) CURR_DEPTH, (unsigned) 0);
7533 Tcl_Panic("TclExecuteByteCode execution failure: end stack top < start stack top");
7534 }
7535 }
7536
7537 /*
7538 * Restore the stack to the state it had previous to this bytecode.
7539 */
7540
7541 TclStackFree(interp, initCatchTop+1);
7542 return result;
7543 #undef iPtr
7544 }
7545
7546 #ifdef TCL_COMPILE_DEBUG
7547 /*
7548 *----------------------------------------------------------------------
7549 *
7550 * PrintByteCodeInfo --
7551 *
7552 * This procedure prints a summary about a bytecode object to stdout. It
7553 * is called by TclExecuteByteCode when starting to execute the bytecode
7554 * object if tclTraceExec has the value 2 or more.
7555 *
7556 * Results:
7557 * None.
7558 *
7559 * Side effects:
7560 * None.
7561 *
7562 *----------------------------------------------------------------------
7563 */
7564
7565 static void
PrintByteCodeInfo(register ByteCode * codePtr)7566 PrintByteCodeInfo(
7567 register ByteCode *codePtr) /* The bytecode whose summary is printed to
7568 * stdout. */
7569 {
7570 Proc *procPtr = codePtr->procPtr;
7571 Interp *iPtr = (Interp *) *codePtr->interpHandle;
7572
7573 fprintf(stdout, "\nExecuting ByteCode 0x%p, refCt %u, epoch %u, interp 0x%p (epoch %u)\n",
7574 codePtr, codePtr->refCount, codePtr->compileEpoch, iPtr,
7575 iPtr->compileEpoch);
7576
7577 fprintf(stdout, " Source: ");
7578 TclPrintSource(stdout, codePtr->source, 60);
7579
7580 fprintf(stdout, "\n Cmds %d, src %d, inst %u, litObjs %u, aux %d, stkDepth %u, code/src %.2f\n",
7581 codePtr->numCommands, codePtr->numSrcBytes,
7582 codePtr->numCodeBytes, codePtr->numLitObjects,
7583 codePtr->numAuxDataItems, codePtr->maxStackDepth,
7584 #ifdef TCL_COMPILE_STATS
7585 codePtr->numSrcBytes?
7586 ((float)codePtr->structureSize)/codePtr->numSrcBytes :
7587 #endif
7588 0.0);
7589
7590 #ifdef TCL_COMPILE_STATS
7591 fprintf(stdout, " Code %lu = header %lu+inst %d+litObj %lu+exc %lu+aux %lu+cmdMap %d\n",
7592 (unsigned long) codePtr->structureSize,
7593 (unsigned long) (sizeof(ByteCode)-sizeof(size_t)-sizeof(Tcl_Time)),
7594 codePtr->numCodeBytes,
7595 (unsigned long) (codePtr->numLitObjects * sizeof(Tcl_Obj *)),
7596 (unsigned long) (codePtr->numExceptRanges*sizeof(ExceptionRange)),
7597 (unsigned long) (codePtr->numAuxDataItems * sizeof(AuxData)),
7598 codePtr->numCmdLocBytes);
7599 #endif /* TCL_COMPILE_STATS */
7600 if (procPtr != NULL) {
7601 fprintf(stdout,
7602 " Proc 0x%p, refCt %d, args %d, compiled locals %d\n",
7603 procPtr, procPtr->refCount, procPtr->numArgs,
7604 procPtr->numCompiledLocals);
7605 }
7606 }
7607 #endif /* TCL_COMPILE_DEBUG */
7608
7609 /*
7610 *----------------------------------------------------------------------
7611 *
7612 * ValidatePcAndStackTop --
7613 *
7614 * This procedure is called by TclExecuteByteCode when debugging to
7615 * verify that the program counter and stack top are valid during
7616 * execution.
7617 *
7618 * Results:
7619 * None.
7620 *
7621 * Side effects:
7622 * Prints a message to stderr and panics if either the pc or stack top
7623 * are invalid.
7624 *
7625 *----------------------------------------------------------------------
7626 */
7627
7628 #ifdef TCL_COMPILE_DEBUG
7629 static void
ValidatePcAndStackTop(register ByteCode * codePtr,unsigned char * pc,int stackTop,int stackLowerBound,int checkStack)7630 ValidatePcAndStackTop(
7631 register ByteCode *codePtr, /* The bytecode whose summary is printed to
7632 * stdout. */
7633 unsigned char *pc, /* Points to first byte of a bytecode
7634 * instruction. The program counter. */
7635 int stackTop, /* Current stack top. Must be between
7636 * stackLowerBound and stackUpperBound
7637 * (inclusive). */
7638 int stackLowerBound, /* Smallest legal value for stackTop. */
7639 int checkStack) /* 0 if the stack depth check should be
7640 * skipped. */
7641 {
7642 int stackUpperBound = stackLowerBound + codePtr->maxStackDepth;
7643 /* Greatest legal value for stackTop. */
7644 unsigned relativePc = (unsigned) (pc - codePtr->codeStart);
7645 unsigned long codeStart = (unsigned long) codePtr->codeStart;
7646 unsigned long codeEnd = (unsigned long)
7647 (codePtr->codeStart + codePtr->numCodeBytes);
7648 unsigned char opCode = *pc;
7649
7650 if (((unsigned long) pc < codeStart) || ((unsigned long) pc > codeEnd)) {
7651 fprintf(stderr, "\nBad instruction pc 0x%p in TclExecuteByteCode\n",
7652 pc);
7653 Tcl_Panic("TclExecuteByteCode execution failure: bad pc");
7654 }
7655 if ((unsigned) opCode > LAST_INST_OPCODE) {
7656 fprintf(stderr, "\nBad opcode %d at pc %u in TclExecuteByteCode\n",
7657 (unsigned) opCode, relativePc);
7658 Tcl_Panic("TclExecuteByteCode execution failure: bad opcode");
7659 }
7660 if (checkStack &&
7661 ((stackTop < stackLowerBound) || (stackTop > stackUpperBound))) {
7662 int numChars;
7663 const char *cmd = GetSrcInfoForPc(pc, codePtr, &numChars);
7664
7665 fprintf(stderr, "\nBad stack top %d at pc %u in TclExecuteByteCode (min %i, max %i)",
7666 stackTop, relativePc, stackLowerBound, stackUpperBound);
7667 if (cmd != NULL) {
7668 Tcl_Obj *message;
7669
7670 TclNewLiteralStringObj(message, "\n executing ");
7671 Tcl_IncrRefCount(message);
7672 Tcl_AppendLimitedToObj(message, cmd, numChars, 100, NULL);
7673 fprintf(stderr,"%s\n", Tcl_GetString(message));
7674 Tcl_DecrRefCount(message);
7675 } else {
7676 fprintf(stderr, "\n");
7677 }
7678 Tcl_Panic("TclExecuteByteCode execution failure: bad stack top");
7679 }
7680 }
7681 #endif /* TCL_COMPILE_DEBUG */
7682
7683 /*
7684 *----------------------------------------------------------------------
7685 *
7686 * IllegalExprOperandType --
7687 *
7688 * Used by TclExecuteByteCode to append an error message to the interp
7689 * result when an illegal operand type is detected by an expression
7690 * instruction. The argument opndPtr holds the operand object in error.
7691 *
7692 * Results:
7693 * None.
7694 *
7695 * Side effects:
7696 * An error message is appended to the interp result.
7697 *
7698 *----------------------------------------------------------------------
7699 */
7700
7701 static void
IllegalExprOperandType(Tcl_Interp * interp,unsigned char * pc,Tcl_Obj * opndPtr)7702 IllegalExprOperandType(
7703 Tcl_Interp *interp, /* Interpreter to which error information
7704 * pertains. */
7705 unsigned char *pc, /* Points to the instruction being executed
7706 * when the illegal type was found. */
7707 Tcl_Obj *opndPtr) /* Points to the operand holding the value
7708 * with the illegal type. */
7709 {
7710 ClientData ptr;
7711 int type;
7712 unsigned char opcode = *pc;
7713 const char *description, *operator = "unknown";
7714
7715 if (opcode == INST_EXPON) {
7716 operator = "**";
7717 } else if (opcode <= INST_LNOT) {
7718 operator = operatorStrings[opcode - INST_LOR];
7719 }
7720
7721 if (GetNumberFromObj(NULL, opndPtr, &ptr, &type) != TCL_OK) {
7722 int numBytes;
7723 const char *bytes = Tcl_GetStringFromObj(opndPtr, &numBytes);
7724
7725 if (numBytes == 0) {
7726 description = "empty string";
7727 } else if (TclCheckBadOctal(NULL, bytes)) {
7728 description = "invalid octal number";
7729 } else {
7730 description = "non-numeric string";
7731 }
7732 } else if (type == TCL_NUMBER_NAN) {
7733 description = "non-numeric floating-point value";
7734 } else if (type == TCL_NUMBER_DOUBLE) {
7735 description = "floating-point value";
7736 } else {
7737 /* TODO: No caller needs this. Eliminate? */
7738 description = "(big) integer";
7739 }
7740
7741 Tcl_SetObjResult(interp, Tcl_ObjPrintf(
7742 "can't use %s as operand of \"%s\"", description, operator));
7743 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", description, NULL);
7744 }
7745
7746 /*
7747 *----------------------------------------------------------------------
7748 *
7749 * TclGetSrcInfoForPc, GetSrcInfoForPc, TclGetSrcInfoForCmd --
7750 *
7751 * Given a program counter value, finds the closest command in the
7752 * bytecode code unit's CmdLocation array and returns information about
7753 * that command's source: a pointer to its first byte and the number of
7754 * characters.
7755 *
7756 * Results:
7757 * If a command is found that encloses the program counter value, a
7758 * pointer to the command's source is returned and the length of the
7759 * source is stored at *lengthPtr. If multiple commands resulted in code
7760 * at pc, information about the closest enclosing command is returned. If
7761 * no matching command is found, NULL is returned and *lengthPtr is
7762 * unchanged.
7763 *
7764 * Side effects:
7765 * The CmdFrame at *cfPtr is updated.
7766 *
7767 *----------------------------------------------------------------------
7768 */
7769
7770 const char *
TclGetSrcInfoForCmd(Interp * iPtr,int * lenPtr)7771 TclGetSrcInfoForCmd(
7772 Interp *iPtr,
7773 int *lenPtr)
7774 {
7775 CmdFrame *cfPtr = iPtr->cmdFramePtr;
7776 ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
7777
7778 return GetSrcInfoForPc((unsigned char *) cfPtr->data.tebc.pc,
7779 codePtr, lenPtr);
7780 }
7781
7782 void
TclGetSrcInfoForPc(CmdFrame * cfPtr)7783 TclGetSrcInfoForPc(
7784 CmdFrame *cfPtr)
7785 {
7786 ByteCode *codePtr = (ByteCode *) cfPtr->data.tebc.codePtr;
7787
7788 if (cfPtr->cmd.str.cmd == NULL) {
7789 cfPtr->cmd.str.cmd = GetSrcInfoForPc(
7790 (unsigned char *) cfPtr->data.tebc.pc, codePtr,
7791 &cfPtr->cmd.str.len);
7792 }
7793
7794 if (cfPtr->cmd.str.cmd != NULL) {
7795 /*
7796 * We now have the command. We can get the srcOffset back and from
7797 * there find the list of word locations for this command.
7798 */
7799
7800 ExtCmdLoc *eclPtr;
7801 ECL *locPtr = NULL;
7802 int srcOffset, i;
7803 Interp *iPtr = (Interp *) *codePtr->interpHandle;
7804 Tcl_HashEntry *hePtr =
7805 Tcl_FindHashEntry(iPtr->lineBCPtr, (char *) codePtr);
7806
7807 if (!hePtr) {
7808 return;
7809 }
7810
7811 srcOffset = cfPtr->cmd.str.cmd - codePtr->source;
7812 eclPtr = (ExtCmdLoc *) Tcl_GetHashValue (hePtr);
7813
7814 for (i=0; i < eclPtr->nuloc; i++) {
7815 if (eclPtr->loc[i].srcOffset == srcOffset) {
7816 locPtr = eclPtr->loc+i;
7817 break;
7818 }
7819 }
7820 if (locPtr == NULL) {
7821 Tcl_Panic("LocSearch failure");
7822 }
7823
7824 cfPtr->line = locPtr->line;
7825 cfPtr->nline = locPtr->nline;
7826 cfPtr->type = eclPtr->type;
7827
7828 if (eclPtr->type == TCL_LOCATION_SOURCE) {
7829 cfPtr->data.eval.path = eclPtr->path;
7830 Tcl_IncrRefCount(cfPtr->data.eval.path);
7831 }
7832
7833 /*
7834 * Do not set cfPtr->data.eval.path NULL for non-SOURCE. Needed for
7835 * cfPtr->data.tebc.codePtr.
7836 */
7837 }
7838 }
7839
7840 static const char *
GetSrcInfoForPc(unsigned char * pc,ByteCode * codePtr,int * lengthPtr)7841 GetSrcInfoForPc(
7842 unsigned char *pc, /* The program counter value for which to
7843 * return the closest command's source info.
7844 * This points to a bytecode instruction in
7845 * codePtr's code. */
7846 ByteCode *codePtr, /* The bytecode sequence in which to look up
7847 * the command source for the pc. */
7848 int *lengthPtr) /* If non-NULL, the location where the length
7849 * of the command's source should be stored.
7850 * If NULL, no length is stored. */
7851 {
7852 register int pcOffset = (pc - codePtr->codeStart);
7853 int numCmds = codePtr->numCommands;
7854 unsigned char *codeDeltaNext, *codeLengthNext;
7855 unsigned char *srcDeltaNext, *srcLengthNext;
7856 int codeOffset, codeLen, codeEnd, srcOffset, srcLen, delta, i;
7857 int bestDist = INT_MAX; /* Distance of pc to best cmd's start pc. */
7858 int bestSrcOffset = -1; /* Initialized to avoid compiler warning. */
7859 int bestSrcLength = -1; /* Initialized to avoid compiler warning. */
7860
7861 if ((pcOffset < 0) || (pcOffset >= codePtr->numCodeBytes)) {
7862 return NULL;
7863 }
7864
7865 /*
7866 * Decode the code and source offset and length for each command. The
7867 * closest enclosing command is the last one whose code started before
7868 * pcOffset.
7869 */
7870
7871 codeDeltaNext = codePtr->codeDeltaStart;
7872 codeLengthNext = codePtr->codeLengthStart;
7873 srcDeltaNext = codePtr->srcDeltaStart;
7874 srcLengthNext = codePtr->srcLengthStart;
7875 codeOffset = srcOffset = 0;
7876 for (i = 0; i < numCmds; i++) {
7877 if ((unsigned) *codeDeltaNext == (unsigned) 0xFF) {
7878 codeDeltaNext++;
7879 delta = TclGetInt4AtPtr(codeDeltaNext);
7880 codeDeltaNext += 4;
7881 } else {
7882 delta = TclGetInt1AtPtr(codeDeltaNext);
7883 codeDeltaNext++;
7884 }
7885 codeOffset += delta;
7886
7887 if ((unsigned) *codeLengthNext == (unsigned) 0xFF) {
7888 codeLengthNext++;
7889 codeLen = TclGetInt4AtPtr(codeLengthNext);
7890 codeLengthNext += 4;
7891 } else {
7892 codeLen = TclGetInt1AtPtr(codeLengthNext);
7893 codeLengthNext++;
7894 }
7895 codeEnd = (codeOffset + codeLen - 1);
7896
7897 if ((unsigned) *srcDeltaNext == (unsigned) 0xFF) {
7898 srcDeltaNext++;
7899 delta = TclGetInt4AtPtr(srcDeltaNext);
7900 srcDeltaNext += 4;
7901 } else {
7902 delta = TclGetInt1AtPtr(srcDeltaNext);
7903 srcDeltaNext++;
7904 }
7905 srcOffset += delta;
7906
7907 if ((unsigned) *srcLengthNext == (unsigned) 0xFF) {
7908 srcLengthNext++;
7909 srcLen = TclGetInt4AtPtr(srcLengthNext);
7910 srcLengthNext += 4;
7911 } else {
7912 srcLen = TclGetInt1AtPtr(srcLengthNext);
7913 srcLengthNext++;
7914 }
7915
7916 if (codeOffset > pcOffset) { /* Best cmd already found */
7917 break;
7918 }
7919 if (pcOffset <= codeEnd) { /* This cmd's code encloses pc */
7920 int dist = (pcOffset - codeOffset);
7921
7922 if (dist <= bestDist) {
7923 bestDist = dist;
7924 bestSrcOffset = srcOffset;
7925 bestSrcLength = srcLen;
7926 }
7927 }
7928 }
7929
7930 if (bestDist == INT_MAX) {
7931 return NULL;
7932 }
7933
7934 if (lengthPtr != NULL) {
7935 *lengthPtr = bestSrcLength;
7936 }
7937 return (codePtr->source + bestSrcOffset);
7938 }
7939
7940 /*
7941 *----------------------------------------------------------------------
7942 *
7943 * GetExceptRangeForPc --
7944 *
7945 * Given a program counter value, return the closest enclosing
7946 * ExceptionRange.
7947 *
7948 * Results:
7949 * If the searchMode is TCL_ERROR, this procedure ignores loop exception
7950 * ranges and returns a pointer to the closest catch range. If the
7951 * searchMode is TCL_BREAK, this procedure returns a pointer to the most
7952 * closely enclosing ExceptionRange regardless of whether it is a loop or
7953 * catch exception range. If the searchMode is TCL_CONTINUE, this
7954 * procedure returns a pointer to the most closely enclosing
7955 * ExceptionRange (of any type) skipping only loop exception ranges if
7956 * they don't have a sensible continueOffset defined. If no matching
7957 * ExceptionRange is found that encloses pc, a NULL is returned.
7958 *
7959 * Side effects:
7960 * None.
7961 *
7962 *----------------------------------------------------------------------
7963 */
7964
7965 static ExceptionRange *
GetExceptRangeForPc(unsigned char * pc,int searchMode,ByteCode * codePtr)7966 GetExceptRangeForPc(
7967 unsigned char *pc, /* The program counter value for which to
7968 * search for a closest enclosing exception
7969 * range. This points to a bytecode
7970 * instruction in codePtr's code. */
7971 int searchMode, /* If TCL_BREAK, consider either loop or catch
7972 * ExceptionRanges in search. If TCL_ERROR
7973 * consider only catch ranges (and ignore any
7974 * closer loop ranges). If TCL_CONTINUE, look
7975 * for loop ranges that define a continue
7976 * point or a catch range. */
7977 ByteCode *codePtr) /* Points to the ByteCode in which to search
7978 * for the enclosing ExceptionRange. */
7979 {
7980 ExceptionRange *rangeArrayPtr;
7981 int numRanges = codePtr->numExceptRanges;
7982 register ExceptionRange *rangePtr;
7983 int pcOffset = pc - codePtr->codeStart;
7984 register int start;
7985
7986 if (numRanges == 0) {
7987 return NULL;
7988 }
7989
7990 /*
7991 * This exploits peculiarities of our compiler: nested ranges are always
7992 * *after* their containing ranges, so that by scanning backwards we are
7993 * sure that the first matching range is indeed the deepest.
7994 */
7995
7996 rangeArrayPtr = codePtr->exceptArrayPtr;
7997 rangePtr = rangeArrayPtr + numRanges;
7998 while (--rangePtr >= rangeArrayPtr) {
7999 start = rangePtr->codeOffset;
8000 if ((start <= pcOffset) &&
8001 (pcOffset < (start + rangePtr->numCodeBytes))) {
8002 if (rangePtr->type == CATCH_EXCEPTION_RANGE) {
8003 return rangePtr;
8004 }
8005 if (searchMode == TCL_BREAK) {
8006 return rangePtr;
8007 }
8008 if (searchMode == TCL_CONTINUE && rangePtr->continueOffset != -1){
8009 return rangePtr;
8010 }
8011 }
8012 }
8013 return NULL;
8014 }
8015
8016 /*
8017 *----------------------------------------------------------------------
8018 *
8019 * GetOpcodeName --
8020 *
8021 * This procedure is called by the TRACE and TRACE_WITH_OBJ macros used
8022 * in TclExecuteByteCode when debugging. It returns the name of the
8023 * bytecode instruction at a specified instruction pc.
8024 *
8025 * Results:
8026 * A character string for the instruction.
8027 *
8028 * Side effects:
8029 * None.
8030 *
8031 *----------------------------------------------------------------------
8032 */
8033
8034 #ifdef TCL_COMPILE_DEBUG
8035 static char *
GetOpcodeName(unsigned char * pc)8036 GetOpcodeName(
8037 unsigned char *pc) /* Points to the instruction whose name should
8038 * be returned. */
8039 {
8040 unsigned char opCode = *pc;
8041
8042 return tclInstructionTable[opCode].name;
8043 }
8044 #endif /* TCL_COMPILE_DEBUG */
8045
8046 /*
8047 *----------------------------------------------------------------------
8048 *
8049 * TclExprFloatError --
8050 *
8051 * This procedure is called when an error occurs during a floating-point
8052 * operation. It reads errno and sets interp->objResultPtr accordingly.
8053 *
8054 * Results:
8055 * interp->objResultPtr is set to hold an error message.
8056 *
8057 * Side effects:
8058 * None.
8059 *
8060 *----------------------------------------------------------------------
8061 */
8062
8063 void
TclExprFloatError(Tcl_Interp * interp,double value)8064 TclExprFloatError(
8065 Tcl_Interp *interp, /* Where to store error message. */
8066 double value) /* Value returned after error; used to
8067 * distinguish underflows from overflows. */
8068 {
8069 const char *s;
8070
8071 if ((errno == EDOM) || TclIsNaN(value)) {
8072 s = "domain error: argument not in valid range";
8073 Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
8074 Tcl_SetErrorCode(interp, "ARITH", "DOMAIN", s, NULL);
8075 } else if ((errno == ERANGE) || TclIsInfinite(value)) {
8076 if (value == 0.0) {
8077 s = "floating-point value too small to represent";
8078 Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
8079 Tcl_SetErrorCode(interp, "ARITH", "UNDERFLOW", s, NULL);
8080 } else {
8081 s = "floating-point value too large to represent";
8082 Tcl_SetObjResult(interp, Tcl_NewStringObj(s, -1));
8083 Tcl_SetErrorCode(interp, "ARITH", "OVERFLOW", s, NULL);
8084 }
8085 } else {
8086 Tcl_Obj *objPtr = Tcl_ObjPrintf(
8087 "unknown floating-point error, errno = %d", errno);
8088
8089 Tcl_SetErrorCode(interp, "ARITH", "UNKNOWN",
8090 Tcl_GetString(objPtr), NULL);
8091 Tcl_SetObjResult(interp, objPtr);
8092 }
8093 }
8094
8095 #ifdef TCL_COMPILE_STATS
8096 /*
8097 *----------------------------------------------------------------------
8098 *
8099 * TclLog2 --
8100 *
8101 * Procedure used while collecting compilation statistics to determine
8102 * the log base 2 of an integer.
8103 *
8104 * Results:
8105 * Returns the log base 2 of the operand. If the argument is less than or
8106 * equal to zero, a zero is returned.
8107 *
8108 * Side effects:
8109 * None.
8110 *
8111 *----------------------------------------------------------------------
8112 */
8113
8114 int
TclLog2(register int value)8115 TclLog2(
8116 register int value) /* The integer for which to compute the log
8117 * base 2. */
8118 {
8119 register int n = value;
8120 register int result = 0;
8121
8122 while (n > 1) {
8123 n = n >> 1;
8124 result++;
8125 }
8126 return result;
8127 }
8128
8129 /*
8130 *----------------------------------------------------------------------
8131 *
8132 * EvalStatsCmd --
8133 *
8134 * Implements the "evalstats" command that prints instruction execution
8135 * counts to stdout.
8136 *
8137 * Results:
8138 * Standard Tcl results.
8139 *
8140 * Side effects:
8141 * None.
8142 *
8143 *----------------------------------------------------------------------
8144 */
8145
8146 static int
EvalStatsCmd(ClientData unused,Tcl_Interp * interp,int objc,Tcl_Obj * const objv[])8147 EvalStatsCmd(
8148 ClientData unused, /* Unused. */
8149 Tcl_Interp *interp, /* The current interpreter. */
8150 int objc, /* The number of arguments. */
8151 Tcl_Obj *const objv[]) /* The argument strings. */
8152 {
8153 Interp *iPtr = (Interp *) interp;
8154 LiteralTable *globalTablePtr = &iPtr->literalTable;
8155 ByteCodeStats *statsPtr = &iPtr->stats;
8156 double totalCodeBytes, currentCodeBytes;
8157 double totalLiteralBytes, currentLiteralBytes;
8158 double objBytesIfUnshared, strBytesIfUnshared, sharingBytesSaved;
8159 double strBytesSharedMultX, strBytesSharedOnce;
8160 double numInstructions, currentHeaderBytes;
8161 long numCurrentByteCodes, numByteCodeLits;
8162 long refCountSum, literalMgmtBytes, sum;
8163 int numSharedMultX, numSharedOnce;
8164 int decadeHigh, minSizeDecade, maxSizeDecade, length, i;
8165 char *litTableStats;
8166 LiteralEntry *entryPtr;
8167 Tcl_Obj *objPtr;
8168
8169 #define Percent(a,b) ((a) * 100.0 / (b))
8170
8171 objPtr = Tcl_NewObj();
8172 Tcl_IncrRefCount(objPtr);
8173
8174 numInstructions = 0.0;
8175 for (i = 0; i < 256; i++) {
8176 if (statsPtr->instructionCount[i] != 0) {
8177 numInstructions += statsPtr->instructionCount[i];
8178 }
8179 }
8180
8181 totalLiteralBytes = sizeof(LiteralTable)
8182 + iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)
8183 + (statsPtr->numLiteralsCreated * sizeof(LiteralEntry))
8184 + (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj))
8185 + statsPtr->totalLitStringBytes;
8186 totalCodeBytes = statsPtr->totalByteCodeBytes + totalLiteralBytes;
8187
8188 numCurrentByteCodes =
8189 statsPtr->numCompilations - statsPtr->numByteCodesFreed;
8190 currentHeaderBytes = numCurrentByteCodes
8191 * (sizeof(ByteCode) - sizeof(size_t) - sizeof(Tcl_Time));
8192 literalMgmtBytes = sizeof(LiteralTable)
8193 + (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *))
8194 + (iPtr->literalTable.numEntries * sizeof(LiteralEntry));
8195 currentLiteralBytes = literalMgmtBytes
8196 + iPtr->literalTable.numEntries * sizeof(Tcl_Obj)
8197 + statsPtr->currentLitStringBytes;
8198 currentCodeBytes = statsPtr->currentByteCodeBytes + currentLiteralBytes;
8199
8200 /*
8201 * Summary statistics, total and current source and ByteCode sizes.
8202 */
8203
8204 Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
8205 Tcl_AppendPrintfToObj(objPtr,
8206 "Compilation and execution statistics for interpreter %#lx\n",
8207 iPtr);
8208
8209 Tcl_AppendPrintfToObj(objPtr, "\nNumber ByteCodes executed %ld\n",
8210 statsPtr->numExecutions);
8211 Tcl_AppendPrintfToObj(objPtr, "Number ByteCodes compiled %ld\n",
8212 statsPtr->numCompilations);
8213 Tcl_AppendPrintfToObj(objPtr, " Mean executions/compile %.1f\n",
8214 statsPtr->numExecutions / (float)statsPtr->numCompilations);
8215
8216 Tcl_AppendPrintfToObj(objPtr, "\nInstructions executed %.0f\n",
8217 numInstructions);
8218 Tcl_AppendPrintfToObj(objPtr, " Mean inst/compile %.0f\n",
8219 numInstructions / statsPtr->numCompilations);
8220 Tcl_AppendPrintfToObj(objPtr, " Mean inst/execution %.0f\n",
8221 numInstructions / statsPtr->numExecutions);
8222
8223 Tcl_AppendPrintfToObj(objPtr, "\nTotal ByteCodes %ld\n",
8224 statsPtr->numCompilations);
8225 Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n",
8226 statsPtr->totalSrcBytes);
8227 Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n",
8228 totalCodeBytes);
8229 Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n",
8230 statsPtr->totalByteCodeBytes);
8231 Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n",
8232 totalLiteralBytes);
8233 Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
8234 (unsigned long) sizeof(LiteralTable),
8235 (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
8236 (unsigned long) (statsPtr->numLiteralsCreated * sizeof(LiteralEntry)),
8237 (unsigned long) (statsPtr->numLiteralsCreated * sizeof(Tcl_Obj)),
8238 statsPtr->totalLitStringBytes);
8239 Tcl_AppendPrintfToObj(objPtr, " Mean code/compile %.1f\n",
8240 totalCodeBytes / statsPtr->numCompilations);
8241 Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n",
8242 totalCodeBytes / statsPtr->totalSrcBytes);
8243
8244 Tcl_AppendPrintfToObj(objPtr, "\nCurrent (active) ByteCodes %ld\n",
8245 numCurrentByteCodes);
8246 Tcl_AppendPrintfToObj(objPtr, " Source bytes %.6g\n",
8247 statsPtr->currentSrcBytes);
8248 Tcl_AppendPrintfToObj(objPtr, " Code bytes %.6g\n",
8249 currentCodeBytes);
8250 Tcl_AppendPrintfToObj(objPtr, " ByteCode bytes %.6g\n",
8251 statsPtr->currentByteCodeBytes);
8252 Tcl_AppendPrintfToObj(objPtr, " Literal bytes %.6g\n",
8253 currentLiteralBytes);
8254 Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
8255 (unsigned long) sizeof(LiteralTable),
8256 (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
8257 (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
8258 (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
8259 statsPtr->currentLitStringBytes);
8260 Tcl_AppendPrintfToObj(objPtr, " Mean code/source %.1f\n",
8261 currentCodeBytes / statsPtr->currentSrcBytes);
8262 Tcl_AppendPrintfToObj(objPtr, " Code + source bytes %.6g (%0.1f mean code/src)\n",
8263 (currentCodeBytes + statsPtr->currentSrcBytes),
8264 (currentCodeBytes / statsPtr->currentSrcBytes) + 1.0);
8265
8266 /*
8267 * Tcl_IsShared statistics check
8268 *
8269 * This gives the refcount of each obj as Tcl_IsShared was called for it.
8270 * Shared objects must be duplicated before they can be modified.
8271 */
8272
8273 numSharedMultX = 0;
8274 Tcl_AppendPrintfToObj(objPtr, "\nTcl_IsShared object check (all objects):\n");
8275 Tcl_AppendPrintfToObj(objPtr, " Object had refcount <=1 (not shared) %ld\n",
8276 tclObjsShared[1]);
8277 for (i = 2; i < TCL_MAX_SHARED_OBJ_STATS; i++) {
8278 Tcl_AppendPrintfToObj(objPtr, " refcount ==%d %ld\n",
8279 i, tclObjsShared[i]);
8280 numSharedMultX += tclObjsShared[i];
8281 }
8282 Tcl_AppendPrintfToObj(objPtr, " refcount >=%d %ld\n",
8283 i, tclObjsShared[0]);
8284 numSharedMultX += tclObjsShared[0];
8285 Tcl_AppendPrintfToObj(objPtr, " Total shared objects %d\n",
8286 numSharedMultX);
8287
8288 /*
8289 * Literal table statistics.
8290 */
8291
8292 numByteCodeLits = 0;
8293 refCountSum = 0;
8294 numSharedMultX = 0;
8295 numSharedOnce = 0;
8296 objBytesIfUnshared = 0.0;
8297 strBytesIfUnshared = 0.0;
8298 strBytesSharedMultX = 0.0;
8299 strBytesSharedOnce = 0.0;
8300 for (i = 0; i < globalTablePtr->numBuckets; i++) {
8301 for (entryPtr = globalTablePtr->buckets[i]; entryPtr != NULL;
8302 entryPtr = entryPtr->nextPtr) {
8303 if (entryPtr->objPtr->typePtr == &tclByteCodeType) {
8304 numByteCodeLits++;
8305 }
8306 (void) Tcl_GetStringFromObj(entryPtr->objPtr, &length);
8307 refCountSum += entryPtr->refCount;
8308 objBytesIfUnshared += (entryPtr->refCount * sizeof(Tcl_Obj));
8309 strBytesIfUnshared += (entryPtr->refCount * (length+1));
8310 if (entryPtr->refCount > 1) {
8311 numSharedMultX++;
8312 strBytesSharedMultX += (length+1);
8313 } else {
8314 numSharedOnce++;
8315 strBytesSharedOnce += (length+1);
8316 }
8317 }
8318 }
8319 sharingBytesSaved = (objBytesIfUnshared + strBytesIfUnshared)
8320 - currentLiteralBytes;
8321
8322 Tcl_AppendPrintfToObj(objPtr, "\nTotal objects (all interps) %ld\n",
8323 tclObjsAlloced);
8324 Tcl_AppendPrintfToObj(objPtr, "Current objects %ld\n",
8325 (tclObjsAlloced - tclObjsFreed));
8326 Tcl_AppendPrintfToObj(objPtr, "Total literal objects %ld\n",
8327 statsPtr->numLiteralsCreated);
8328
8329 Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal objects %d (%0.1f%% of current objects)\n",
8330 globalTablePtr->numEntries,
8331 Percent(globalTablePtr->numEntries, tclObjsAlloced-tclObjsFreed));
8332 Tcl_AppendPrintfToObj(objPtr, " ByteCode literals %ld (%0.1f%% of current literals)\n",
8333 numByteCodeLits,
8334 Percent(numByteCodeLits, globalTablePtr->numEntries));
8335 Tcl_AppendPrintfToObj(objPtr, " Literals reused > 1x %d\n",
8336 numSharedMultX);
8337 Tcl_AppendPrintfToObj(objPtr, " Mean reference count %.2f\n",
8338 ((double) refCountSum) / globalTablePtr->numEntries);
8339 Tcl_AppendPrintfToObj(objPtr, " Mean len, str reused >1x %.2f\n",
8340 (numSharedMultX ? strBytesSharedMultX/numSharedMultX : 0.0));
8341 Tcl_AppendPrintfToObj(objPtr, " Mean len, str used 1x %.2f\n",
8342 (numSharedOnce ? strBytesSharedOnce/numSharedOnce : 0.0));
8343 Tcl_AppendPrintfToObj(objPtr, " Total sharing savings %.6g (%0.1f%% of bytes if no sharing)\n",
8344 sharingBytesSaved,
8345 Percent(sharingBytesSaved, objBytesIfUnshared+strBytesIfUnshared));
8346 Tcl_AppendPrintfToObj(objPtr, " Bytes with sharing %.6g\n",
8347 currentLiteralBytes);
8348 Tcl_AppendPrintfToObj(objPtr, " table %lu + bkts %lu + entries %lu + objects %lu + strings %.6g\n",
8349 (unsigned long) sizeof(LiteralTable),
8350 (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
8351 (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)),
8352 (unsigned long) (iPtr->literalTable.numEntries * sizeof(Tcl_Obj)),
8353 statsPtr->currentLitStringBytes);
8354 Tcl_AppendPrintfToObj(objPtr, " Bytes if no sharing %.6g = objects %.6g + strings %.6g\n",
8355 (objBytesIfUnshared + strBytesIfUnshared),
8356 objBytesIfUnshared, strBytesIfUnshared);
8357 Tcl_AppendPrintfToObj(objPtr, " String sharing savings %.6g = unshared %.6g - shared %.6g\n",
8358 (strBytesIfUnshared - statsPtr->currentLitStringBytes),
8359 strBytesIfUnshared, statsPtr->currentLitStringBytes);
8360 Tcl_AppendPrintfToObj(objPtr, " Literal mgmt overhead %ld (%0.1f%% of bytes with sharing)\n",
8361 literalMgmtBytes,
8362 Percent(literalMgmtBytes, currentLiteralBytes));
8363 Tcl_AppendPrintfToObj(objPtr, " table %lu + buckets %lu + entries %lu\n",
8364 (unsigned long) sizeof(LiteralTable),
8365 (unsigned long) (iPtr->literalTable.numBuckets * sizeof(LiteralEntry *)),
8366 (unsigned long) (iPtr->literalTable.numEntries * sizeof(LiteralEntry)));
8367
8368 /*
8369 * Breakdown of current ByteCode space requirements.
8370 */
8371
8372 Tcl_AppendPrintfToObj(objPtr, "\nBreakdown of current ByteCode requirements:\n");
8373 Tcl_AppendPrintfToObj(objPtr, " Bytes Pct of Avg per\n");
8374 Tcl_AppendPrintfToObj(objPtr, " total ByteCode\n");
8375 Tcl_AppendPrintfToObj(objPtr, "Total %12.6g 100.00%% %8.1f\n",
8376 statsPtr->currentByteCodeBytes,
8377 statsPtr->currentByteCodeBytes / numCurrentByteCodes);
8378 Tcl_AppendPrintfToObj(objPtr, "Header %12.6g %8.1f%% %8.1f\n",
8379 currentHeaderBytes,
8380 Percent(currentHeaderBytes, statsPtr->currentByteCodeBytes),
8381 currentHeaderBytes / numCurrentByteCodes);
8382 Tcl_AppendPrintfToObj(objPtr, "Instructions %12.6g %8.1f%% %8.1f\n",
8383 statsPtr->currentInstBytes,
8384 Percent(statsPtr->currentInstBytes,statsPtr->currentByteCodeBytes),
8385 statsPtr->currentInstBytes / numCurrentByteCodes);
8386 Tcl_AppendPrintfToObj(objPtr, "Literal ptr array %12.6g %8.1f%% %8.1f\n",
8387 statsPtr->currentLitBytes,
8388 Percent(statsPtr->currentLitBytes,statsPtr->currentByteCodeBytes),
8389 statsPtr->currentLitBytes / numCurrentByteCodes);
8390 Tcl_AppendPrintfToObj(objPtr, "Exception table %12.6g %8.1f%% %8.1f\n",
8391 statsPtr->currentExceptBytes,
8392 Percent(statsPtr->currentExceptBytes,statsPtr->currentByteCodeBytes),
8393 statsPtr->currentExceptBytes / numCurrentByteCodes);
8394 Tcl_AppendPrintfToObj(objPtr, "Auxiliary data %12.6g %8.1f%% %8.1f\n",
8395 statsPtr->currentAuxBytes,
8396 Percent(statsPtr->currentAuxBytes,statsPtr->currentByteCodeBytes),
8397 statsPtr->currentAuxBytes / numCurrentByteCodes);
8398 Tcl_AppendPrintfToObj(objPtr, "Command map %12.6g %8.1f%% %8.1f\n",
8399 statsPtr->currentCmdMapBytes,
8400 Percent(statsPtr->currentCmdMapBytes,statsPtr->currentByteCodeBytes),
8401 statsPtr->currentCmdMapBytes / numCurrentByteCodes);
8402
8403 /*
8404 * Detailed literal statistics.
8405 */
8406
8407 Tcl_AppendPrintfToObj(objPtr, "\nLiteral string sizes:\n");
8408 Tcl_AppendPrintfToObj(objPtr, " Up to length Percentage\n");
8409 maxSizeDecade = 0;
8410 for (i = 31; i >= 0; i--) {
8411 if (statsPtr->literalCount[i] > 0) {
8412 maxSizeDecade = i;
8413 break;
8414 }
8415 }
8416 sum = 0;
8417 for (i = 0; i <= maxSizeDecade; i++) {
8418 decadeHigh = (1 << (i+1)) - 1;
8419 sum += statsPtr->literalCount[i];
8420 Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
8421 decadeHigh, Percent(sum, statsPtr->numLiteralsCreated));
8422 }
8423
8424 litTableStats = TclLiteralStats(globalTablePtr);
8425 Tcl_AppendPrintfToObj(objPtr, "\nCurrent literal table statistics:\n%s\n",
8426 litTableStats);
8427 ckfree((char *) litTableStats);
8428
8429 /*
8430 * Source and ByteCode size distributions.
8431 */
8432
8433 Tcl_AppendPrintfToObj(objPtr, "\nSource sizes:\n");
8434 Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n");
8435 minSizeDecade = maxSizeDecade = 0;
8436 for (i = 0; i < 31; i++) {
8437 if (statsPtr->srcCount[i] > 0) {
8438 minSizeDecade = i;
8439 break;
8440 }
8441 }
8442 for (i = 31; i >= 0; i--) {
8443 if (statsPtr->srcCount[i] > 0) {
8444 maxSizeDecade = i;
8445 break;
8446 }
8447 }
8448 sum = 0;
8449 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
8450 decadeHigh = (1 << (i+1)) - 1;
8451 sum += statsPtr->srcCount[i];
8452 Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
8453 decadeHigh, Percent(sum, statsPtr->numCompilations));
8454 }
8455
8456 Tcl_AppendPrintfToObj(objPtr, "\nByteCode sizes:\n");
8457 Tcl_AppendPrintfToObj(objPtr, " Up to size Percentage\n");
8458 minSizeDecade = maxSizeDecade = 0;
8459 for (i = 0; i < 31; i++) {
8460 if (statsPtr->byteCodeCount[i] > 0) {
8461 minSizeDecade = i;
8462 break;
8463 }
8464 }
8465 for (i = 31; i >= 0; i--) {
8466 if (statsPtr->byteCodeCount[i] > 0) {
8467 maxSizeDecade = i;
8468 break;
8469 }
8470 }
8471 sum = 0;
8472 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
8473 decadeHigh = (1 << (i+1)) - 1;
8474 sum += statsPtr->byteCodeCount[i];
8475 Tcl_AppendPrintfToObj(objPtr, " %10d %8.0f%%\n",
8476 decadeHigh, Percent(sum, statsPtr->numCompilations));
8477 }
8478
8479 Tcl_AppendPrintfToObj(objPtr, "\nByteCode longevity (excludes Current ByteCodes):\n");
8480 Tcl_AppendPrintfToObj(objPtr, " Up to ms Percentage\n");
8481 minSizeDecade = maxSizeDecade = 0;
8482 for (i = 0; i < 31; i++) {
8483 if (statsPtr->lifetimeCount[i] > 0) {
8484 minSizeDecade = i;
8485 break;
8486 }
8487 }
8488 for (i = 31; i >= 0; i--) {
8489 if (statsPtr->lifetimeCount[i] > 0) {
8490 maxSizeDecade = i;
8491 break;
8492 }
8493 }
8494 sum = 0;
8495 for (i = minSizeDecade; i <= maxSizeDecade; i++) {
8496 decadeHigh = (1 << (i+1)) - 1;
8497 sum += statsPtr->lifetimeCount[i];
8498 Tcl_AppendPrintfToObj(objPtr, " %12.3f %8.0f%%\n",
8499 decadeHigh/1000.0, Percent(sum, statsPtr->numByteCodesFreed));
8500 }
8501
8502 /*
8503 * Instruction counts.
8504 */
8505
8506 Tcl_AppendPrintfToObj(objPtr, "\nInstruction counts:\n");
8507 for (i = 0; i <= LAST_INST_OPCODE; i++) {
8508 Tcl_AppendPrintfToObj(objPtr, "%20s %8ld ",
8509 tclInstructionTable[i].name, statsPtr->instructionCount[i]);
8510 if (statsPtr->instructionCount[i]) {
8511 Tcl_AppendPrintfToObj(objPtr, "%6.1f%%\n",
8512 Percent(statsPtr->instructionCount[i], numInstructions));
8513 } else {
8514 Tcl_AppendPrintfToObj(objPtr, "0\n");
8515 }
8516 }
8517
8518 #ifdef TCL_MEM_DEBUG
8519 Tcl_AppendPrintfToObj(objPtr, "\nHeap Statistics:\n");
8520 TclDumpMemoryInfo((ClientData) objPtr, 1);
8521 #endif
8522 Tcl_AppendPrintfToObj(objPtr, "\n----------------------------------------------------------------\n");
8523
8524 if (objc == 1) {
8525 Tcl_SetObjResult(interp, objPtr);
8526 } else {
8527 Tcl_Channel outChan;
8528 char *str = Tcl_GetStringFromObj(objv[1], &length);
8529
8530 if (length) {
8531 if (strcmp(str, "stdout") == 0) {
8532 outChan = Tcl_GetStdChannel(TCL_STDOUT);
8533 } else if (strcmp(str, "stderr") == 0) {
8534 outChan = Tcl_GetStdChannel(TCL_STDERR);
8535 } else {
8536 outChan = Tcl_OpenFileChannel(NULL, str, "w", 0664);
8537 }
8538 } else {
8539 outChan = Tcl_GetStdChannel(TCL_STDOUT);
8540 }
8541 if (outChan != NULL) {
8542 Tcl_WriteObj(outChan, objPtr);
8543 }
8544 }
8545 Tcl_DecrRefCount(objPtr);
8546 return TCL_OK;
8547 }
8548 #endif /* TCL_COMPILE_STATS */
8549
8550 #ifdef TCL_COMPILE_DEBUG
8551 /*
8552 *----------------------------------------------------------------------
8553 *
8554 * StringForResultCode --
8555 *
8556 * Procedure that returns a human-readable string representing a Tcl
8557 * result code such as TCL_ERROR.
8558 *
8559 * Results:
8560 * If the result code is one of the standard Tcl return codes, the result
8561 * is a string representing that code such as "TCL_ERROR". Otherwise, the
8562 * result string is that code formatted as a sequence of decimal digit
8563 * characters. Note that the resulting string must not be modified by the
8564 * caller.
8565 *
8566 * Side effects:
8567 * None.
8568 *
8569 *----------------------------------------------------------------------
8570 */
8571
8572 static const char *
StringForResultCode(int result)8573 StringForResultCode(
8574 int result) /* The Tcl result code for which to generate a
8575 * string. */
8576 {
8577 static char buf[TCL_INTEGER_SPACE];
8578
8579 if ((result >= TCL_OK) && (result <= TCL_CONTINUE)) {
8580 return resultStrings[result];
8581 }
8582 TclFormatInt(buf, result);
8583 return buf;
8584 }
8585 #endif /* TCL_COMPILE_DEBUG */
8586
8587 /*
8588 * Local Variables:
8589 * mode: c
8590 * c-basic-offset: 4
8591 * fill-column: 78
8592 * End:
8593 */
8594